syntax/parse: lazily load most macro transformers and compile-time support

collects/syntax/parse/debug.rkt

@@ -6,11 +6,15 @@
                      "private/rep.rkt"
                      "private/kws.rkt")
          "../parse.rkt"
+         syntax/parse/private/residual
          "private/runtime.rkt"
          "private/runtime-progress.rkt"
-         "private/runtime-report.rkt"
+         (except-in "private/runtime-report.rkt"
+                    syntax-patterns-fail)
          "private/kws.rkt")
 
+;; No lazy loading for this module's dependencies.
+
 (provide syntax-class-parse
          syntax-class-attributes
          syntax-class-arity

collects/syntax/parse/experimental/contract.rkt

@@ -3,7 +3,7 @@
          "../private/lib.rkt"
          "provide.rkt"
          unstable/wrapc
-         (only-in "../private/runtime.rkt"
+         (only-in syntax/parse/private/residual ;; keep abs. path
                   this-context-syntax)
          racket/contract/base)
 

collects/syntax/parse/experimental/eh.rkt

@@ -1,77 +1,5 @@
 #lang racket/base
-(require (for-syntax racket/base
+(require "../private/sc.rkt"
-                     syntax/parse
+         "../private/keywords.rkt")
-                     racket/syntax
-                     "../private/minimatch.rkt"
-                     "../private/rep.rkt"
-                     "../private/rep-data.rkt"
-                     "../private/rep-patterns.rkt")
-         "../private/keywords.rkt"
-         "../private/sc.rkt")
-
 (provide ~eh-var
          define-eh-alternative-set)
-
-(define-syntax (define-eh-alternative-set stx)
-  (define-syntax-class alt
-    #:description "eh-alternate-set alternative"
-    #:literals (pattern)
-    (pattern (pattern alt)))
-  (syntax-parse stx
-    #:literals (pattern)
-    [(_ name:id a:alt ...)
-     (parameterize ((current-syntax-context stx))
-       (let* ([decls (new-declenv null #:conventions null)]
-              [ehpat+hstx-list
-               (apply append
-                      (for/list ([alt (in-list (syntax->list #'(a.alt ...)))])
-                        (parse*-ellipsis-head-pattern alt decls #t #:context stx)))]
-              [eh-alt+defs-list
-               (for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
-                 (let ([ehpat (car ehpat+hstx)]
-                       [hstx (cadr ehpat+hstx)])
-                   (cond [(syntax? hstx)
-                          (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))])
-                            (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))])
-                              (list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
-                                    (list #`(define parser
-                                              (parser/rhs parser () #,attrs
-                                                          [#:description #f (pattern #,hstx)]
-                                                          #t
-                                                          #,stx))))))]
-                         [(eh-alternative? hstx)
-                          (list hstx null)]
-                         [else
-                          (error 'define-eh-alternative-set "internal error: unexpected ~e"
-                                 hstx)])))]
-              [eh-alts (map car eh-alt+defs-list)]
-              [defs (apply append (map cadr eh-alt+defs-list))])
-         (with-syntax ([(def ...) defs]
-                       [(alt-expr ...)
-                        (for/list ([alt (in-list eh-alts)])
-                          (with-syntax ([repc-expr
-                                         (match (eh-alternative-repc alt)
-                                           ['#f
-                                            #'(quote #f)]
-                                           [(rep:once n u o)
-                                            #`(rep:once (quote-syntax #,n)
-                                                        (quote-syntax #,u)
-                                                        (quote-syntax #,o))]
-                                           [(rep:optional n o d)
-                                            #`(rep:optional (quote-syntax #,n)
-                                                            (quote-syntax #,o)
-                                                            (quote-syntax #,d))]
-                                           [(rep:bounds min max n u o)
-                                            #`(rep:bounds (quote #,min)
-                                                          (quote #,max)
-                                                          (quote-syntax #,n)
-                                                          (quote-syntax #,u)
-                                                          (quote-syntax #,o))])]
-                                        [attrs-expr
-                                         #`(quote #,(eh-alternative-attrs alt))]
-                                        [parser-expr
-                                         #`(quote-syntax #,(eh-alternative-parser alt))])
-                            #'(eh-alternative repc-expr attrs-expr parser-expr)))])
-           #'(begin def ...
-                    (define-syntax name
-                      (eh-alternative-set (list alt-expr ...)))))))]))

collects/syntax/parse/experimental/reflect.rkt

@@ -1,10 +1,38 @@
 #lang racket/base
-(require racket/contract/base
+(require (for-syntax racket/base
+                     unstable/lazy-require
+                     syntax/parse/private/residual-ct) ;; keep abs.path
+         racket/contract/base
          racket/contract/combinator
          "../private/minimatch.rkt"
          "../private/keywords.rkt"
          "../private/runtime-reflect.rkt"
          "../private/kws.rkt")
+(begin-for-syntax
+ (lazy-require
+  [syntax/parse/private/rep-data ;; keep abs. path
+   (get-stxclass
+    stxclass-delimit-cut?)]))
+
+(define-syntax (reify-syntax-class stx)
+  (if (eq? (syntax-local-context) 'expression)
+      (syntax-case stx ()
+        [(rsc sc)
+         (let* ([stxclass (get-stxclass #'sc)]
+                [splicing? (stxclass-splicing? stxclass)])
+           (unless (stxclass-delimit-cut? stxclass)
+             (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
+                                 stx #'sc))
+           (with-syntax ([name (stxclass-name stxclass)]
+                         [parser (stxclass-parser stxclass)]
+                         [arity (stxclass-arity stxclass)]
+                         [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
+                         [ctor
+                          (if splicing?
+                              #'reified-splicing-syntax-class
+                              #'reified-syntax-class)])
+             #'(ctor 'name parser 'arity '((aname adepth) ...))))])
+      #`(#%expression #,stx)))
 
 (define (reified-syntax-class-arity r)
   (match (reified-arity r)

collects/syntax/parse/experimental/splicing.rkt

@@ -1,11 +1,16 @@
 #lang racket/base
 (require (for-syntax racket/base
-                     "../../parse.rkt"
+                     syntax/parse
-                     "../private/rep-data.rkt"
+                     unstable/lazy-require
                      "../private/kws.rkt")
-         "../private/runtime.rkt")
+         syntax/parse/private/residual) ;; keep abs. path
 (provide define-primitive-splicing-syntax-class)
 
+(begin-for-syntax
+ (lazy-require
+  [syntax/parse/private/rep-attrs
+   (sort-sattrs)]))
+
 (define-syntax (define-primitive-splicing-syntax-class stx)
 
   (define-syntax-class attr

collects/syntax/parse/private/keywords.rkt

@@ -3,12 +3,13 @@
 
 ;; == Keywords
 
+(define-for-syntax (bad-keyword-use stx)
+  (raise-syntax-error #f "keyword used out of context" stx))
+
 (define-syntax-rule (define-keyword name)
   (begin
     (provide name)
-    (define-syntax name
+    (define-syntax name bad-keyword-use)))
-      (lambda (stx)
-        (raise-syntax-error #f "keyword used out of context" stx)))))
 
 (define-keyword pattern)
 (define-keyword ~var)

collects/syntax/parse/private/lib.rkt

@@ -73,11 +73,3 @@
            #:attr value (syntax-local-value #'x (lambda () notfound))
            #:fail-when (eq? (attribute value) notfound) #f
            #:fail-unless (pred (attribute value)) #f))
-
-#|
-(define-syntax-class expr
-  #:attributes ()
-  #:description "expression"
-  #:commit
-  (pattern (~and x (~fail #:when (keyword? (syntax-e #'x))))))
-|#

collects/syntax/parse/private/litconv.rkt

@@ -1,14 +1,20 @@
 #lang racket/base
 (require (for-syntax racket/base
+                     unstable/lazy-require
                      "sc.rkt"
                      "lib.rkt"
+                     "kws.rkt"
                      racket/syntax
-                     syntax/keyword
+                     syntax/keyword)
-                     "rep-data.rkt"
+         syntax/parse/private/residual-ct ;; keep abs. path
-                     "rep.rkt"
+         syntax/parse/private/residual    ;; keep abs. path
-                     "kws.rkt")
-         "runtime.rkt"
          (only-in unstable/syntax phase-of-enclosing-module))
+(begin-for-syntax
+ (lazy-require
+  [syntax/parse/private/rep ;; keep abs. path
+   (parse-kw-formals
+    check-conventions-rules
+    create-aux-def)]))
 (provide define-conventions
          define-literal-set
          literal-set->predicate
@@ -44,6 +50,8 @@
        (define/with-syntax (class-name ...)
          (map den:delayed-class dens))
 
+       ;; FIXME: could move make-den:delayed to user of conventions
+       ;; and eliminate from residual.rkt
        #'(begin
            (define-syntax h.name
              (make-conventions

collects/syntax/parse/private/parse-aux.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+(require (for-template "parse.rkt"))
+(provide id:define-syntax-class
+         id:define-splicing-syntax-class
+         id:syntax-parse
+         id:syntax-parser
+         id:define/syntax-parse
+         id:syntax-parser/template
+         id:parser/rhs
+         id:define-eh-alternative-set)
+
+(define (id:define-syntax-class) #'define-syntax-class)
+(define (id:define-splicing-syntax-class) #'define-splicing-syntax-class)
+(define (id:syntax-parse) #'syntax-parse)
+(define (id:syntax-parser) #'syntax-parser)
+(define (id:define/syntax-parse) #'define/syntax-parse)
+(define (id:syntax-parser/template) #'syntax-parser/template)
+(define (id:parser/rhs) #'parser/rhs)
+(define (id:define-eh-alternative-set) #'define-eh-alternative-set)

collects/syntax/parse/private/parse.rkt

@@ -4,18 +4,170 @@
                      syntax/id-table
                      syntax/keyword
                      racket/syntax
+                     "minimatch.rkt"
+                     "rep-attrs.rkt"
                      "rep-data.rkt"
+                     "rep-patterns.rkt"
                      "rep.rkt"
                      "kws.rkt"
                      "txlift.rkt")
+         "keywords.rkt"
          racket/syntax
          racket/stxparam
          syntax/stx
          unstable/struct
-         "runtime.rkt"
+         syntax/parse/private/residual ;; keep abs. path
-         "runtime-report.rkt"
+         syntax/parse/private/runtime  ;; keep abs.path 
-         "runtime-reflect.rkt")
+         syntax/parse/private/runtime-reflect) ;; keep abs. path
-(provide (all-defined-out))
+
+;; ============================================================
+
+(provide define-syntax-class
+         define-splicing-syntax-class
+         syntax-parse
+         syntax-parser
+         define/syntax-parse
+         syntax-parser/template
+         parser/rhs
+         define-eh-alternative-set)
+
+(begin-for-syntax
+ (define (tx:define-*-syntax-class stx splicing?)
+   (syntax-case stx ()
+     [(_ header . rhss)
+      (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]
+                          [parser (generate-temporary (format-symbol "parse-~a" name))]
+                          [arity arity]
+                          [attrs (rhs-attrs the-rhs)]
+                          [(opt-def ...)
+                           (if opt-rhs+def
+                               (list (cadr opt-rhs+def))
+                               '())]
+                          [options (rhs-options the-rhs)]
+                          [integrate-expr
+                           (syntax-case (rhs-integrate the-rhs) ()
+                             [#s(integrate predicate description)
+                                #'(integrate (quote-syntax predicate)
+                                             'description)]
+                             [#f
+                              #''#f])])
+              #`(begin (define-syntax name
+                         (stxclass 'name 'arity
+                                   'attrs
+                                   (quote-syntax parser)
+                                   '#,splicing?
+                                   options
+                                   integrate-expr))
+                       opt-def ...
+                       (define-values (parser)
+                         ;; If opt-rhs, do not reparse:
+                         ;; need to keep same generated predicate name
+                         #,(if opt-rhs+def
+                               (begin
+                                 #`(parser/rhs/parsed
+                                    name formals attrs #,the-rhs
+                                    #,(and (rhs-description the-rhs) #t)
+                                    #,splicing? #,stx))
+                               #`(parser/rhs
+                                  name formals attrs rhss #,splicing? #,stx))))))))])))
+
+(define-syntax define-syntax-class
+  (lambda (stx) (tx:define-*-syntax-class stx #f)))
+(define-syntax define-splicing-syntax-class
+  (lambda (stx) (tx:define-*-syntax-class stx #t)))
+
+(define-syntax (parser/rhs stx)
+  (syntax-case stx ()
+    [(parser/rhs name formals attrs rhss splicing? ctx)
+     (with-disappeared-uses
+      (let ([rhs
+             (parameterize ((current-syntax-context #'ctx))
+               (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
+                          #:context #'ctx))])
+        #`(parser/rhs/parsed name formals attrs
+                             #,rhs #,(and (rhs-description rhs) #t)
+                             splicing? ctx)))]))
+
+(define-syntax (parser/rhs/parsed stx)
+  (syntax-case stx ()
+    [(prp name formals attrs rhs rhs-has-description? splicing? ctx)
+     #`(let ([get-description
+              (lambda formals
+                (if 'rhs-has-description?
+                    #,(rhs-description (syntax-e #'rhs))
+                    (symbol->string 'name)))])
+         (parse:rhs rhs attrs formals splicing?
+                    (if 'rhs-has-description?
+                        #,(rhs-description (syntax-e #'rhs))
+                        (symbol->string 'name))))]))
+
+(define-syntax (syntax-parse stx)
+  (syntax-case stx ()
+    [(syntax-parse stx-expr . clauses)
+     (quasisyntax/loc stx
+       (let ([x (datum->syntax #f stx-expr)])
+         (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))]))
+
+(define-syntax (syntax-parser stx)
+  (syntax-case stx ()
+    [(syntax-parser . clauses)
+     (quasisyntax/loc stx
+       (lambda (x)
+         (let ([x (datum->syntax #f x)])
+           (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))]))
+
+(define-syntax (syntax-parser/template stx)
+  (syntax-case stx ()
+    [(syntax-parser/template ctx . clauses)
+     (quasisyntax/loc stx
+       (lambda (x)
+         (let ([x (datum->syntax #f x)])
+           (parse:clauses x clauses one-template ctx))))]))
+
+(define-syntax (define/syntax-parse stx)
+  (syntax-case stx ()
+    [(define/syntax-parse pattern . rest)
+     (let-values ([(rest pattern defs)
+                   (parse-pattern+sides #'pattern
+                                        #'rest
+                                        #:splicing? #f
+                                        #:decls (new-declenv null)
+                                        #:context stx)])
+       (let ([expr
+              (syntax-case rest ()
+                [( expr ) #'expr]
+                [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [attrs (pattern-attrs pattern)])
+         (with-syntax ([(a ...) attrs]
+                       [(#s(attr name _ _) ...) attrs]
+                       [pattern pattern]
+                       [(def ...) defs]
+                       [expr expr])
+           #'(defattrs/unpack (a ...)
+               (let* ([x (datum->syntax #f expr)]
+                      [cx x]
+                      [pr (ps-empty x x)]
+                      [es null]
+                      [fh0 (syntax-patterns-fail x)])
+                 (parameterize ((current-syntax-context x))
+                   def ...
+                   (#%expression
+                    (with ([fail-handler fh0]
+                           [cut-prompt fh0])
+                          (parse:S x cx pattern pr es
+                                   (list (attribute name) ...))))))))))]))
+
+;; ============================================================
 
 #|
 Parsing protocol:
@@ -807,11 +959,72 @@ Conventions:
     [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
      (expect:message (or too-many-msg (name->too-many name)))]))
 
-(define (name->too-few/once name)
+;; ====
-  (and name (format "missing required occurrence of ~a" name)))
 
-(define (name->too-few name)
+(define-syntax (define-eh-alternative-set stx)
-  (and name (format "too few occurrences of ~a" name)))
+  (define (parse-alt x)
-
+    (syntax-case x (pattern)
-(define (name->too-many name)
+      [(pattern alt)
-  (and name (format "too many occurrences of ~a" name)))
+       #'alt]
+      [else
+       (wrong-syntax x "expected eh-alternative-set alternative")]))
+  (parameterize ((current-syntax-context stx))
+    (syntax-case stx ()
+      [(_ name a ...)
+       (unless (identifier? #'name)
+         (wrong-syntax #'name "expected identifier"))
+       (let* ([alts (map parse-alt (syntax->list #'(a ...)))]
+              [decls (new-declenv null #:conventions null)]
+              [ehpat+hstx-list
+               (apply append
+                      (for/list ([alt (in-list alts)])
+                        (parse*-ellipsis-head-pattern alt decls #t #:context stx)))]
+              [eh-alt+defs-list
+               (for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
+                 (let ([ehpat (car ehpat+hstx)]
+                       [hstx (cadr ehpat+hstx)])
+                   (cond [(syntax? hstx)
+                          (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))])
+                            (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))])
+                              (list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
+                                    (list #`(define parser
+                                              (parser/rhs parser () #,attrs
+                                                          [#:description #f (pattern #,hstx)]
+                                                          #t
+                                                          #,stx))))))]
+                         [(eh-alternative? hstx)
+                          (list hstx null)]
+                         [else
+                          (error 'define-eh-alternative-set "internal error: unexpected ~e"
+                                 hstx)])))]
+              [eh-alts (map car eh-alt+defs-list)]
+              [defs (apply append (map cadr eh-alt+defs-list))])
+         (with-syntax ([(def ...) defs]
+                       [(alt-expr ...)
+                        (for/list ([alt (in-list eh-alts)])
+                          (with-syntax ([repc-expr
+                                         (match (eh-alternative-repc alt)
+                                           ['#f
+                                            #'(quote #f)]
+                                           [(rep:once n u o)
+                                            #`(rep:once (quote-syntax #,n)
+                                                        (quote-syntax #,u)
+                                                        (quote-syntax #,o))]
+                                           [(rep:optional n o d)
+                                            #`(rep:optional (quote-syntax #,n)
+                                                            (quote-syntax #,o)
+                                                            (quote-syntax #,d))]
+                                           [(rep:bounds min max n u o)
+                                            #`(rep:bounds (quote #,min)
+                                                          (quote #,max)
+                                                          (quote-syntax #,n)
+                                                          (quote-syntax #,u)
+                                                          (quote-syntax #,o))])]
+                                        [attrs-expr
+                                         #`(quote #,(eh-alternative-attrs alt))]
+                                        [parser-expr
+                                         #`(quote-syntax #,(eh-alternative-parser alt))])
+                            #'(eh-alternative repc-expr attrs-expr parser-expr)))])
+           #'(begin def ...
+                    (define-syntax name
+                      (eh-alternative-set (list alt-expr ...))))))])))

collects/syntax/parse/private/rep-attrs.rkt

@@ -1,9 +1,9 @@
 #lang racket/base
-(require racket/contract/base
+(require syntax/parse/private/residual-ct ;; keep abs. path
+         racket/contract/base
          syntax/id-table
          racket/syntax
          unstable/struct)
-(provide (struct-out attr))
 
 #|
 An IAttr is (make-attr identifier number boolean)
@@ -19,8 +19,6 @@ SAttr lists are always stored in sorted order, to make comparison
 of signatures easier for reified syntax-classes.
 |#
 
-(define-struct attr (name depth syntax?) #:prefab)
-
 (define (iattr? a)
   (and (attr? a) (identifier? (attr-name a))))
 

collects/syntax/parse/private/rep-data.rkt

@@ -4,45 +4,30 @@
          racket/list
          syntax/id-table
          racket/syntax
+         syntax/parse/private/residual-ct ;; keep abs. path
          "minimatch.rkt"
          "kws.rkt"
          "rep-attrs.rkt"
          "rep-patterns.rkt")
-(provide (all-from-out "rep-attrs.rkt")
+;; from residual.rkt
-         (all-from-out "rep-patterns.rkt")
+(provide (struct-out stxclass)
-         (struct-out stxclass)
          (struct-out options)
          (struct-out integrate)
-         stxclass/s?
+         (struct-out conventions)
+         (struct-out literalset)
+         (struct-out eh-alternative-set)
+         (struct-out eh-alternative))
+;; from here
+(provide stxclass/s?
          stxclass/h?
          stxclass-commit?
          stxclass-delimit-cut?
-         (struct-out attr)
          (struct-out rhs)
          (struct-out variant)
          (struct-out clause:fail)
          (struct-out clause:with)
          (struct-out clause:attr)
-         (struct-out clause:do)
+         (struct-out clause:do))
-         (struct-out conventions)
-         (struct-out literalset)
-         (struct-out eh-alternative-set)
-         (struct-out eh-alternative))
-
-#|
-A stxclass is
-  #s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
-where Options = #s(options boolean boolean)
-      Integrate = #s(integrate id string)
-Arity is defined in kws.rkt
-|#
-(define-struct stxclass (name arity attrs parser splicing? options integrate)
-  #:prefab)
-
-(define-struct options (commit? delimit-cut?)
-  #:prefab)
-(define-struct integrate (predicate description)
-  #:prefab)
 
 (define (stxclass/s? x)
   (and (stxclass? x) (not (stxclass-splicing? x))))
@@ -72,33 +57,11 @@ A Variant is
 SideClause is defined in rep-patterns
 |#
 
-#|
-A Conventions is
-  (make-conventions id (-> (listof ConventionRule)))
-A ConventionRule is (list regexp DeclEntry)
-|#
-(define-struct conventions (get-procedures get-rules) #:transparent)
-
-#|
-A LiteralSet is
-  (make-literalset (listof (list symbol id phase-var-id)))
-|#
-(define-struct literalset (literals) #:transparent)
-
 ;; make-dummy-stxclass : identifier -> SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.
 (define (make-dummy-stxclass name)
   (make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f))
 
-#|
-An EH-alternative-set is
-  (eh-alternative-set (listof EH-alternative)
-An EH-alternative is
-  (eh-alternative RepetitionConstraint (listof SAttr) id)
-|#
-(define-struct eh-alternative-set (alts))
-(define-struct eh-alternative (repc attrs parser))
-
 ;; Environments
 
 #|
@@ -130,7 +93,7 @@ expressions are duplicated, and may be evaluated in different scopes.
 (define-struct den:class (name class argu))
 (define-struct den:magic-class (name class argu))
 (define-struct den:parser (parser attrs splicing? commit? delimit-cut?))
-(define-struct den:delayed (parser class))
+;; and from residual.rkt: (define-struct den:delayed (parser class))
 
 (define (new-declenv literals #:conventions [conventions null])
   (make-declenv
@@ -229,6 +192,7 @@ expressions are duplicated, and may be evaluated in different scopes.
          (struct-out den:class)
          (struct-out den:magic-class)
          (struct-out den:parser)
+         ;; from residual.rkt:
          (struct-out den:delayed))
 
 (provide/contract

collects/syntax/parse/private/rep-patterns.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "rep-attrs.rkt"
+(require syntax/parse/private/residual-ct ;; keep abs. path
+         "rep-attrs.rkt"
          "kws.rkt"
          unstable/struct
          (for-syntax racket/base

collects/syntax/parse/private/rep.rkt

@@ -1,8 +1,9 @@
 #lang racket/base
 (require (for-template racket/base
                        racket/stxparam
-                       "keywords.rkt"
+                       syntax/parse/private/keywords
-                       "runtime.rkt")
+                       syntax/parse/private/residual ;; keep abs. path
+                       syntax/parse/private/runtime)
          racket/contract/base
          "minimatch.rkt"
          syntax/id-table
@@ -11,7 +12,10 @@
          racket/syntax
          unstable/struct
          "txlift.rkt"
+         "rep-attrs.rkt"
          "rep-data.rkt"
+         "rep-patterns.rkt"
+         syntax/parse/private/residual-ct ;; keep abs. path
          "kws.rkt")
 
 ;; Error reporting
@@ -188,7 +192,7 @@
   (define attributes (options-select-value chunks '#:attributes #:default #f))
   (define-values (decls defs) (get-decls+defs chunks strict?))
   (values rest description transparent? attributes auto-nested? colon-notation?
-          decls defs (make options commit? delimit-cut?)))
+          decls defs (options commit? delimit-cut?)))
 
 ;; ----
 

collects/syntax/parse/private/residual-ct.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+(provide (struct-out attr)
+         (struct-out stxclass)
+         (struct-out options)
+         (struct-out integrate)
+         (struct-out conventions)
+         (struct-out literalset)
+         (struct-out eh-alternative-set)
+         (struct-out eh-alternative)
+         (struct-out den:delayed))
+
+;; == from rep-attr.rkt
+(define-struct attr (name depth syntax?) #:prefab)
+
+;; == from rep-data.rkt
+
+#|
+A stxclass is
+  #s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
+where Options = #s(options boolean boolean)
+      Integrate = #s(integrate id string)
+Arity is defined in kws.rkt
+|#
+(define-struct stxclass (name arity attrs parser splicing? options integrate)
+  #:prefab)
+
+(define-struct options (commit? delimit-cut?)
+  #:prefab)
+(define-struct integrate (predicate description)
+  #:prefab)
+
+#|
+A Conventions is
+  (make-conventions id (-> (listof ConventionRule)))
+A ConventionRule is (list regexp DeclEntry)
+|#
+(define-struct conventions (get-procedures get-rules) #:transparent)
+
+#|
+A LiteralSet is
+ (make-literalset (listof (list symbol id phase-var-id)))
+|#
+(define-struct literalset (literals) #:transparent)
+
+#|
+An EH-alternative-set is
+  (eh-alternative-set (listof EH-alternative))
+An EH-alternative is
+  (eh-alternative RepetitionConstraint (listof SAttr) id)
+|#
+(define-struct eh-alternative-set (alts))
+(define-struct eh-alternative (repc attrs parser))
+
+(define-struct den:delayed (parser class))

collects/syntax/parse/private/residual.rkt

@@ -0,0 +1,194 @@
+#lang racket/base
+(require (for-syntax racket/base)
+         racket/stxparam
+         unstable/lazy-require)
+
+;; ============================================================
+;; Compile-time
+
+(require (for-syntax racket/private/sc
+                     syntax/parse/private/residual-ct))
+(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
+
+(begin-for-syntax
+  ;; == from runtime.rkt
+
+ (provide make-attribute-mapping
+          attribute-mapping?
+          attribute-mapping-var
+          attribute-mapping-name
+          attribute-mapping-depth
+          attribute-mapping-syntax?)
+
+ (define-struct attribute-mapping (var name depth syntax?)
+   #:omit-define-syntaxes
+   #:property prop:procedure
+   (lambda (self stx)
+     (if (attribute-mapping-syntax? self)
+         #`(#%expression #,(attribute-mapping-var self))
+         (let ([source-name
+                (or (let loop ([p (syntax-property stx 'disappeared-use)])
+                      (cond [(identifier? p) p]
+                            [(pair? p) (or (loop (car p)) (loop (cdr p)))]
+                            [else #f]))
+                    (attribute-mapping-name self))])
+           #`(let ([value #,(attribute-mapping-var self)])
+               (check-attr-value-is-syntax '#,(attribute-mapping-depth self)
+                                           value
+                                            (quote-syntax #,source-name))
+               value)))))
+ )
+
+;; ============================================================
+;; Run-time
+
+(require "runtime-progress.rkt"
+         syntax/stx)
+
+(provide (all-from-out "runtime-progress.rkt")
+
+         this-syntax
+         this-context-syntax
+         attribute
+         attribute-binding
+         stx-list-take
+         stx-list-drop/cx
+         check-list^depth*
+         check-literal*
+         begin-for-syntax/once
+
+         name->too-few/once
+         name->too-few
+         name->too-many
+         syntax-patterns-fail)
+
+;; == from runtime.rkt
+
+;; this-syntax
+;; Bound to syntax being matched inside of syntax class
+(define-syntax-parameter this-syntax
+  (lambda (stx)
+    (raise-syntax-error #f "used out of context: not within a syntax class" stx)))
+
+;; this-context-syntax
+;; Bound to (expression that extracts) context syntax (bottom frame in progress)
+(define-syntax-parameter this-context-syntax
+  (lambda (stx)
+    (raise-syntax-error #f "used out of context: not within a syntax class" stx)))
+
+(define-syntax (attribute stx)
+  (syntax-case stx ()
+    [(attribute name)
+     (identifier? #'name)
+     (let ([mapping (syntax-local-value #'name (lambda () #f))])
+       (unless (syntax-pattern-variable? mapping)
+         (raise-syntax-error #f "not bound as a pattern variable" stx #'name))
+       (let ([var (syntax-mapping-valvar mapping)])
+         (let ([attr (syntax-local-value var (lambda () #f))])
+           (unless (attribute-mapping? attr)
+             (raise-syntax-error #f "not bound as an attribute" stx #'name))
+           (syntax-property (attribute-mapping-var attr)
+                            'disappeared-use
+                            #'name))))]))
+
+;; (attribute-binding id)
+;; mostly for debugging/testing
+(define-syntax (attribute-binding stx)
+  (syntax-case stx ()
+    [(attribute-bound? name)
+     (identifier? #'name)
+     (let ([value (syntax-local-value #'name (lambda () #f))])
+       (if (syntax-pattern-variable? value)
+           (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
+             (if (attribute-mapping? value)
+                 #`(quote #,(make-attr (attribute-mapping-name value)
+                                       (attribute-mapping-depth value)
+                                       (attribute-mapping-syntax? value)))
+                 #'(quote #f)))
+           #'(quote #f)))]))
+
+;; stx-list-take : stxish nat -> syntax
+(define (stx-list-take stx n)
+  (datum->syntax #f
+                 (let loop ([stx stx] [n n])
+                   (if (zero? n)
+                       null
+                       (cons (stx-car stx)
+                             (loop (stx-cdr stx) (sub1 n)))))))
+
+;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
+(define (stx-list-drop/cx x cx n)
+  (let loop ([x x] [cx cx] [n n])
+    (if (zero? n)
+        (values x
+                (if (syntax? x) x cx))
+        (loop (stx-cdr x)
+              (if (syntax? x) x cx)
+              (sub1 n)))))
+
+;; check-attr-value-is-syntax : nat any id -> boolean
+;; returns #t if value is a (listof^depth syntax)
+;; used by attribute-mapping code above
+(define (check-attr-value-is-syntax depth value source-id)
+  (define (check-syntax depth value)
+    (if (zero? depth)
+        (syntax? value)
+        (and (list? value)
+             (for/and ([part (in-list value)])
+                      (check-syntax (sub1 depth) part)))))
+  (unless (check-syntax depth value)
+    (raise-syntax-error #f
+                        (format "attribute is bound to non-syntax value: ~e" value)
+                        source-id)))
+
+;; check-list^depth* : symbol nat any -> list^depth
+(define (check-list^depth* aname n0 v0)
+  (define (loop n v)
+    (when (positive? n)
+      (unless (list? v)
+        (raise-type-error aname (format "lists nested ~s deep" n0) v))
+      (for ([x (in-list v)]) (loop (sub1 n) x))))
+  (loop n0 v0)
+  v0)
+
+;; check-literal* : id phase phase (listof phase) stx -> void
+(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
+  (unless (or (memv (and used-phase (- used-phase mod-phase))
+                    ok-phases/ct-rel)
+              (identifier-binding id used-phase))
+    (raise-syntax-error
+     #f
+     (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
+             used-phase
+             (and used-phase (- used-phase mod-phase)))
+     ctx id)))
+
+;; (begin-for-syntax/once expr/phase1 ...)
+;; evaluates in pass 2 of module/intdefs expansion
+(define-syntax (begin-for-syntax/once stx)
+  (syntax-case stx ()
+    [(bfs/o e ...)
+     (cond [(list? (syntax-local-context))
+            #`(define-values ()
+                (begin (begin-for-syntax/once e ...)
+                       (values)))]
+           [else
+            #'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
+                (m))])]))
+
+;; == parse.rkt
+
+(define (name->too-few/once name)
+  (and name (format "missing required occurrence of ~a" name)))
+
+(define (name->too-few name)
+  (and name (format "too few occurrences of ~a" name)))
+
+(define (name->too-many name)
+  (and name (format "too many occurrences of ~a" name)))
+
+;; == parse.rkt
+
+(lazy-require
+ ["runtime-report.rkt"
+  (syntax-patterns-fail)])

collects/syntax/parse/private/runtime-failure.rkt

@@ -1,194 +0,0 @@
-#lang racket/base
-(require "minimatch.rkt"
-         "runtime-progress.rkt")
-(provide (struct-out failure)
-
-         expect?
-         (struct-out expect:thing)
-         (struct-out expect:atom)
-         (struct-out expect:literal)
-         (struct-out expect:message)
-         (struct-out expect:disj)
-
-         normalize-expectstack
-         simplify-common-expectstacks
-         maximal-failures
-         partition/equal?)
-
-;; A Failure is (make-failure PS ExpectStack)
-;; A FailureSet is one of
-;;   - Failure
-;;   - (cons FailureSet FailureSet)
-
-;; FailFunction = (FailureSet -> Answer)
-
-(define-struct failure (progress expectstack) #:prefab)
-
-;; == Expectations
-
-;; FIXME: add phase to expect:literal
-
-#|
-An ExpectStack is (listof Expect)
-
-An Expect is one of
-  - (make-expect:thing string boolean)
-  * (make-expect:message string)
-  * (make-expect:atom atom)
-  * (make-expect:literal identifier)
-  * (make-expect:disj (non-empty-listof Expect))
-
-The *-marked variants can only occur at the top of the stack.
-|#
-(define-struct expect:thing (description transparent?) #:prefab)
-(define-struct expect:message (message) #:prefab)
-(define-struct expect:atom (atom) #:prefab)
-(define-struct expect:literal (literal) #:prefab)
-(define-struct expect:disj (expects) #:prefab)
-
-(define (expect? x)
-  (or (expect:thing? x)
-      (expect:message? x)
-      (expect:atom? x)
-      (expect:literal? x)
-      (expect:disj? x)))
-
-
-;; == Failure simplification ==
-
-;; maximal-failures : FailureSet -> (listof (listof Failure))
-(define (maximal-failures fs)
-  (define ann-failures
-    (for/list ([f (in-list (flatten fs null))])
-      (cons f (invert-ps (failure-progress f)))))
-  (maximal/progress ann-failures))
-
-(define (flatten fs onto)
-  (cond [(pair? fs)
-         (flatten (car fs) (flatten (cdr fs) onto))]
-        [else
-         (cons fs onto)]))
-
-;; == Expectation simplification ==
-
-;; normalize-expectstack : ExpectStack -> ExpectStack
-(define (normalize-expectstack es)
-  (filter-expectstack (truncate-opaque-expectstack es)))
-
-;; truncate-opaque-expectstack : ExpectStack -> ExpectStack
-;; Eliminates expectations on top of opaque (ie, transparent=#f) frames.
-(define (truncate-opaque-expectstack es)
-  (let/ec return
-    (let loop ([es es])
-      (match es
-        ['() '()]
-        [(cons (expect:thing description '#f) rest-es)
-         ;; Tricky! If multiple opaque frames, multiple "returns",
-         ;; but innermost one called first, so jumps past the rest.
-         (return (cons (car es) (loop rest-es)))]
-        [(cons expect rest-es)
-         (cons expect (loop rest-es))]))))
-
-;; filter-expectstack : ExpectStack -> ExpectStack
-;; Eliminates missing (ie, #f) messages and descriptions
-(define (filter-expectstack es)
-  (filter (lambda (expect)
-            (match expect
-              [(expect:thing '#f _)
-               #f]
-              [(expect:message '#f)
-               #f]
-              [_ #t]))
-          es))
-
-#|
-Simplification dilemma
-
-What if we have (e1 e2) and (e2)? How do we report that?
-Options:
-  1) consider them separate
-  2) simplify to (e2), drop e1
-
-Big problem with Option 1:
-  eg (x:id ...) matching #'1 yields
-  (union (failure #:progress () #:expectstack ())
-         (failure #:progress () #:expectstack (#s(expect:atom ()))))
-but we don't want to see "expected ()"
-
-So we go with option 2.
-|#
-
-;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack)
-;; Should call remove-duplicates first.
-(define (simplify-common-expectstacks ess)
-  ;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
-  (define (simplify ress)
-    (let ([ress-partitions (partition/car ress)])
-      (if ress-partitions
-          (apply append
-                 (for/list ([ress-partition (in-list ress-partitions)])
-                   (let ([proto-frame (car (car ress-partition))]
-                         [cdr-ress (map cdr ress-partition)])
-                     (map (lambda (res) (cons proto-frame res))
-                          (simplify/check-leafs cdr-ress)))))
-          (list null))))
-  ;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
-  (define (simplify/check-leafs ress)
-    (let ([ress (simplify ress)])
-      (cond [(andmap singleton? ress)
-             (let* ([frames (map car ress)])
-               (list (list (if (singleton? frames)
-                               (car frames)
-                               (expect:disj frames)))))]
-            [else ress])))
-  ;; singleton? : list -> boolean
-  (define (singleton? res)
-    (and (pair? res) (null? (cdr res))))
-  (map reverse (simplify/check-leafs (map reverse ess))))
-
-;; partition/car : (listof list) -> (listof (listof list))/#f
-;; Returns #f if any of lists is empty.
-(define (partition/car lists)
-  (and (andmap pair? lists)
-       (partition/equal? lists car)))
-
-(define (partition/equal? items key)
-  (let ([r-keys null] ;; mutated
-        [key-t (make-hash)])
-    (for ([item (in-list items)])
-      (let ([k (key item)])
-        (let ([entry (hash-ref key-t k null)])
-          (when (null? entry)
-            (set! r-keys (cons k r-keys)))
-          (hash-set! key-t k (cons item entry)))))
-    (let loop ([r-keys r-keys] [acc null])
-      (cond [(null? r-keys) acc]
-            [else
-             (loop (cdr r-keys)
-                   (cons (reverse (hash-ref key-t (car r-keys)))
-                         acc))]))))
-
-;; ==== Debugging
-
-(provide failureset->sexpr
-         failure->sexpr
-         expectstack->sexpr
-         expect->sexpr)
-
-(define (failureset->sexpr fs)
-  (let ([fs (flatten fs null)])
-    (case (length fs)
-      ((1) (failure->sexpr (car fs)))
-      (else `(union ,@(map failure->sexpr fs))))))
-
-(define (failure->sexpr f)
-  (match f
-    [(failure progress expectstack)
-     `(failure ,(progress->sexpr progress)
-               #:expected ,(expectstack->sexpr expectstack))]))
-
-(define (expectstack->sexpr es)
-  (map expect->sexpr es))
-
-(define (expect->sexpr e)
-  e)

collects/syntax/parse/private/runtime-progress.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require unstable/struct
+(require racket/list
+         unstable/struct
          syntax/stx
          "minimatch.rkt")
 (provide ps-empty
@@ -12,14 +13,18 @@
          ps-add-unpstruct
          ps-add-opaque
 
+         invert-ps
          ps->stx+index
          ps-context-syntax
          ps-difference
 
-         invert-ps
+         (struct-out failure)
-         maximal/progress
+         expect?
-
+         (struct-out expect:thing)
-         progress->sexpr)
+         (struct-out expect:atom)
+         (struct-out expect:literal)
+         (struct-out expect:message)
+         (struct-out expect:disj))
 
 #|
 Progress (PS) is a non-empty list of Progress Frames (PF).
@@ -140,20 +145,6 @@ Interpretation: Inner PS structures are applied first.
              (loop (cdr ps))
              ps]))))
 
-#|
-Progress ordering
------------------
-
-Lexicographic generalization of partial order on frames
-  CAR < CDR < POST, stx incomparable except to self
-
-Progress equality
------------------
-
-If ps1 = ps2 then both must "blame" the same term,
-ie (ps->stx+index ps1) = (ps->stx+index ps2).
-|#
-
 ;; An Inverted PS (IPS) is a PS inverted for easy comparison.
 ;; An IPS may not contain any 'opaque frames.
 
@@ -161,100 +152,72 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
 (define (invert-ps ps)
   (reverse (ps-truncate-opaque ps)))
 
-;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A))
-;; Returns a list of equivalence sets.
-(define (maximal/progress items)
-  (cond [(null? items)
-         null]
-        [(null? (cdr items))
-         (list (list (car (car items))))]
-        [else
-         (let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR)
-                       (partition/pf items)])
-           (append (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
-                   (if (pair? rSTX)
-                       (maximal/stx rSTX)
-                       null)))]))
 
-;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0
+;; ==== Failure ====
-(define (partition/pf items)
-  (let ([rNULL null]
-        [rCAR null]
-        [rCDR null]
-        [rPOST null]
-        [rSTX null]
-        [leastCDR #f])
-    (for ([a+ips (in-list items)])
-      (let ([ips (cdr a+ips)])
-        (cond [(null? ips)
-               (set! rNULL (cons a+ips rNULL))]
-              [(eq? (car ips) 'car)
-               (set! rCAR (cons a+ips rCAR))]
-              [(exact-positive-integer? (car ips))
-               (set! rCDR (cons a+ips rCDR))
-               (set! leastCDR
-                     (if leastCDR
-                         (min leastCDR (car ips))
-                         (car ips)))]
-              [(eq? (car ips) 'post)
-               (set! rPOST (cons a+ips rPOST))]
-              [(syntax? (car ips))
-               (set! rSTX (cons a+ips rSTX))]
-              [else
-               (error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)])))
-    (values rNULL rCAR rCDR rPOST rSTX leastCDR)))
 
-;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A))
+;; A Failure is (make-failure PS ExpectStack)
-(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
+;; A FailureSet is one of
-  (cond [(pair? rPOST)
+;;   - Failure
-         (maximal/progress (rmap pop-item-ips rPOST))]
+;;   - (cons FailureSet FailureSet)
-        [(pair? rCDR)
-         (maximal/progress
-          (rmap (lambda (a+ips)
-                  (let ([a (car a+ips)] [ips (cdr a+ips)])
-                    (cond [(= (car ips) leastCDR)
-                           (cons a (cdr ips))]
-                          [else
-                           (cons a (cons (- (car ips) leastCDR) (cdr ips)))])))
-                rCDR))]
-        [(pair? rCAR)
-         (maximal/progress (rmap pop-item-ips rCAR))]
-        [(pair? rNULL)
-         (list (map car rNULL))]
-        [else
-         null]))
 
-;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A))
+;; FailFunction = (FailureSet -> Answer)
-(define (maximal/stx rSTX)
-  (let ([stxs null]
-        [table (make-hasheq)])
-    (for ([a+ips (in-list rSTX)])
-      (let* ([ips (cdr a+ips)]
-             [entry (hash-ref table (car ips) null)])
-        (when (null? entry)
-          (set! stxs (cons (car ips) stxs)))
-        (hash-set! table (car ips) (cons a+ips entry))))
-    (apply append
-           (map (lambda (key)
-                  (maximal/progress (map pop-item-ips (hash-ref table key))))
-                stxs))))
 
-;; pop-item-ips : (cons A IPS) -> (cons A IPS)
+(define-struct failure (progress expectstack) #:prefab)
-(define (pop-item-ips a+ips)
-  (let ([a (car a+ips)]
-        [ips (cdr a+ips)])
-    (cons a (cdr ips))))
 
-(define (rmap f xs)
+;; == Expectations
-  (let rmaploop ([xs xs] [accum null])
-    (cond [(pair? xs)
-           (rmaploop (cdr xs) (cons (f (car xs)) accum))]
-          [else
-           accum])))
 
-;; == Debugging ==
+;; FIXME: add phase to expect:literal
 
-(provide progress->sexpr)
+#|
+An ExpectStack is (listof Expect)
+
+An Expect is one of
+  - (make-expect:thing string boolean)
+  * (make-expect:message string)
+  * (make-expect:atom atom)
+  * (make-expect:literal identifier)
+  * (make-expect:disj (non-empty-listof Expect))
+
+The *-marked variants can only occur at the top of the stack.
+|#
+(define-struct expect:thing (description transparent?) #:prefab)
+(define-struct expect:message (message) #:prefab)
+(define-struct expect:atom (atom) #:prefab)
+(define-struct expect:literal (literal) #:prefab)
+(define-struct expect:disj (expects) #:prefab)
+
+(define (expect? x)
+  (or (expect:thing? x)
+      (expect:message? x)
+      (expect:atom? x)
+      (expect:literal? x)
+      (expect:disj? x)))
+
+
+;; ==== Debugging
+
+(provide failureset->sexpr
+         failure->sexpr
+         expectstack->sexpr
+         expect->sexpr)
+
+(define (failureset->sexpr fs)
+  (let ([fs (flatten fs null)])
+    (case (length fs)
+      ((1) (failure->sexpr (car fs)))
+      (else `(union ,@(map failure->sexpr fs))))))
+
+(define (failure->sexpr f)
+  (match f
+    [(failure progress expectstack)
+     `(failure ,(progress->sexpr progress)
+               #:expected ,(expectstack->sexpr expectstack))]))
+
+(define (expectstack->sexpr es)
+  (map expect->sexpr es))
+
+(define (expect->sexpr e)
+  e)
 
 (define (progress->sexpr ps)
   (for/list ([pf (in-list (invert-ps ps))])

collects/syntax/parse/private/runtime-reflect.rkt

@@ -1,15 +1,12 @@
 #lang racket/base
-(require (for-syntax racket/base
+(require syntax/parse/private/residual ;; keep abs. path
-                     "rep-data.rkt")
+         (only-in syntax/parse/private/residual-ct ;; keep abs. path
-         "rep-attrs.rkt"
+                  attr-name attr-depth)
          "kws.rkt")
-(provide (struct-out reified)
+(provide reflect-parser
+         (struct-out reified)
          (struct-out reified-syntax-class)
-         (struct-out reified-splicing-syntax-class)
+         (struct-out reified-splicing-syntax-class))
-         reify-syntax-class
-         reified-syntax-class?
-         reified-splicing-syntax-class?
-         reflect-parser)
 
 #|
 A Reified is
@@ -20,32 +17,8 @@ A Reified is
 (define-struct (reified-syntax-class reified) ())
 (define-struct (reified-splicing-syntax-class reified) ())
 
-;; ----
-
-(define-syntax (reify-syntax-class stx)
-  (if (eq? (syntax-local-context) 'expression)
-      (syntax-case stx ()
-        [(rsc sc)
-         (let* ([stxclass (get-stxclass #'sc)]
-                [splicing? (stxclass-splicing? stxclass)])
-           (unless (stxclass-delimit-cut? stxclass)
-             (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
-                                 stx #'sc))
-           (with-syntax ([name (stxclass-name stxclass)]
-                         [parser (stxclass-parser stxclass)]
-                         [arity (stxclass-arity stxclass)]
-                         [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
-                         [ctor
-                          (if splicing?
-                              #'reified-splicing-syntax-class
-                              #'reified-syntax-class)])
-             #'(ctor 'name parser 'arity '((aname adepth) ...))))])
-      #`(#%expression #,stx)))
-
-;; ----
-
-;; e-arity represents single call; min and max are same
 (define (reflect-parser obj e-arity e-attrs splicing?)
+  ;; e-arity represents single call; min and max are same
   (define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
   (if splicing?
       (unless (reified-splicing-syntax-class? obj)

collects/syntax/parse/private/runtime-report.rkt

@@ -1,11 +1,17 @@
 #lang racket/base
 (require racket/list
          "minimatch.rkt"
-         "runtime.rkt"
+         (except-in syntax/parse/private/residual
+                    syntax-patterns-fail)
          "kws.rkt")
 (provide syntax-patterns-fail
          current-failure-handler)
 
+#|
+Note: there is a cyclic dependence between residual.rkt and this module,
+broken by a lazy-require of this module into residual.rkt
+|#
+
 (define ((syntax-patterns-fail stx0) fs)
   (call-with-values (lambda () ((current-failure-handler) stx0 fs))
     (lambda vals
@@ -21,8 +27,6 @@
 (define current-failure-handler
   (make-parameter default-failure-handler))
 
-;; ----
-
 #|
 Reporting
 ---------
@@ -125,3 +129,223 @@ complicated.
     [(a . b) (cons #'a (improper-stx->list #'b))]
     [() null]
     [rest (list #'rest)]))
+
+
+;; ==== Failure analysis ====
+
+
+;; == Failure simplification ==
+
+;; maximal-failures : FailureSet -> (listof (listof Failure))
+(define (maximal-failures fs)
+  (define ann-failures
+    (for/list ([f (in-list (flatten fs))])
+      (cons f (invert-ps (failure-progress f)))))
+  (maximal/progress ann-failures))
+
+;; == Expectation simplification ==
+
+;; normalize-expectstack : ExpectStack -> ExpectStack
+(define (normalize-expectstack es)
+  (filter-expectstack (truncate-opaque-expectstack es)))
+
+;; truncate-opaque-expectstack : ExpectStack -> ExpectStack
+;; Eliminates expectations on top of opaque (ie, transparent=#f) frames.
+(define (truncate-opaque-expectstack es)
+  (let/ec return
+    (let loop ([es es])
+      (match es
+        ['() '()]
+        [(cons (expect:thing description '#f) rest-es)
+         ;; Tricky! If multiple opaque frames, multiple "returns",
+         ;; but innermost one called first, so jumps past the rest.
+         (return (cons (car es) (loop rest-es)))]
+        [(cons expect rest-es)
+         (cons expect (loop rest-es))]))))
+
+;; filter-expectstack : ExpectStack -> ExpectStack
+;; Eliminates missing (ie, #f) messages and descriptions
+(define (filter-expectstack es)
+  (filter (lambda (expect)
+            (match expect
+              [(expect:thing '#f _)
+               #f]
+              [(expect:message '#f)
+               #f]
+              [_ #t]))
+          es))
+
+#|
+Simplification dilemma
+
+What if we have (e1 e2) and (e2)? How do we report that?
+Options:
+  1) consider them separate
+  2) simplify to (e2), drop e1
+
+Big problem with Option 1:
+  eg (x:id ...) matching #'1 yields
+  (union (failure #:progress () #:expectstack ())
+         (failure #:progress () #:expectstack (#s(expect:atom ()))))
+but we don't want to see "expected ()"
+
+So we go with option 2.
+|#
+
+;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack)
+;; Should call remove-duplicates first.
+(define (simplify-common-expectstacks ess)
+  ;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
+  (define (simplify ress)
+    (let ([ress-partitions (partition/car ress)])
+      (if ress-partitions
+          (apply append
+                 (for/list ([ress-partition (in-list ress-partitions)])
+                   (let ([proto-frame (car (car ress-partition))]
+                         [cdr-ress (map cdr ress-partition)])
+                     (map (lambda (res) (cons proto-frame res))
+                          (simplify/check-leafs cdr-ress)))))
+          (list null))))
+  ;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
+  (define (simplify/check-leafs ress)
+    (let ([ress (simplify ress)])
+      (cond [(andmap singleton? ress)
+             (let* ([frames (map car ress)])
+               (list (list (if (singleton? frames)
+                               (car frames)
+                               (expect:disj frames)))))]
+            [else ress])))
+  ;; singleton? : list -> boolean
+  (define (singleton? res)
+    (and (pair? res) (null? (cdr res))))
+  (map reverse (simplify/check-leafs (map reverse ess))))
+
+;; partition/car : (listof list) -> (listof (listof list))/#f
+;; Returns #f if any of lists is empty.
+(define (partition/car lists)
+  (and (andmap pair? lists)
+       (partition/equal? lists car)))
+
+(define (partition/equal? items key)
+  (let ([r-keys null] ;; mutated
+        [key-t (make-hash)])
+    (for ([item (in-list items)])
+      (let ([k (key item)])
+        (let ([entry (hash-ref key-t k null)])
+          (when (null? entry)
+            (set! r-keys (cons k r-keys)))
+          (hash-set! key-t k (cons item entry)))))
+    (let loop ([r-keys r-keys] [acc null])
+      (cond [(null? r-keys) acc]
+            [else
+             (loop (cdr r-keys)
+                   (cons (reverse (hash-ref key-t (car r-keys)))
+                         acc))]))))
+
+
+;; ==== Progress
+
+#|
+Progress ordering
+-----------------
+
+Lexicographic generalization of partial order on frames
+  CAR < CDR < POST, stx incomparable except to self
+
+Progress equality
+-----------------
+
+If ps1 = ps2 then both must "blame" the same term,
+ie (ps->stx+index ps1) = (ps->stx+index ps2).
+|#
+
+;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A))
+;; Returns a list of equivalence sets.
+(define (maximal/progress items)
+  (cond [(null? items)
+         null]
+        [(null? (cdr items))
+         (list (list (car (car items))))]
+        [else
+         (let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR)
+                       (partition/pf items)])
+           (append (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
+                   (if (pair? rSTX)
+                       (maximal/stx rSTX)
+                       null)))]))
+
+;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0
+(define (partition/pf items)
+  (let ([rNULL null]
+        [rCAR null]
+        [rCDR null]
+        [rPOST null]
+        [rSTX null]
+        [leastCDR #f])
+    (for ([a+ips (in-list items)])
+      (let ([ips (cdr a+ips)])
+        (cond [(null? ips)
+               (set! rNULL (cons a+ips rNULL))]
+              [(eq? (car ips) 'car)
+               (set! rCAR (cons a+ips rCAR))]
+              [(exact-positive-integer? (car ips))
+               (set! rCDR (cons a+ips rCDR))
+               (set! leastCDR
+                     (if leastCDR
+                         (min leastCDR (car ips))
+                         (car ips)))]
+              [(eq? (car ips) 'post)
+               (set! rPOST (cons a+ips rPOST))]
+              [(syntax? (car ips))
+               (set! rSTX (cons a+ips rSTX))]
+              [else
+               (error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)])))
+    (values rNULL rCAR rCDR rPOST rSTX leastCDR)))
+
+;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A))
+(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
+  (cond [(pair? rPOST)
+         (maximal/progress (rmap pop-item-ips rPOST))]
+        [(pair? rCDR)
+         (maximal/progress
+          (rmap (lambda (a+ips)
+                  (let ([a (car a+ips)] [ips (cdr a+ips)])
+                    (cond [(= (car ips) leastCDR)
+                           (cons a (cdr ips))]
+                          [else
+                           (cons a (cons (- (car ips) leastCDR) (cdr ips)))])))
+                rCDR))]
+        [(pair? rCAR)
+         (maximal/progress (rmap pop-item-ips rCAR))]
+        [(pair? rNULL)
+         (list (map car rNULL))]
+        [else
+         null]))
+
+;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A))
+(define (maximal/stx rSTX)
+  (let ([stxs null]
+        [table (make-hasheq)])
+    (for ([a+ips (in-list rSTX)])
+      (let* ([ips (cdr a+ips)]
+             [entry (hash-ref table (car ips) null)])
+        (when (null? entry)
+          (set! stxs (cons (car ips) stxs)))
+        (hash-set! table (car ips) (cons a+ips entry))))
+    (apply append
+           (map (lambda (key)
+                  (maximal/progress (map pop-item-ips (hash-ref table key))))
+                stxs))))
+
+;; pop-item-ips : (cons A IPS) -> (cons A IPS)
+(define (pop-item-ips a+ips)
+  (let ([a (car a+ips)]
+        [ips (cdr a+ips)])
+    (cons a (cdr ips))))
+
+(define (rmap f xs)
+  (let rmaploop ([xs xs] [accum null])
+    (cond [(pair? xs)
+           (rmaploop (cdr xs) (cons (f (car xs)) accum))]
+          [else
+           accum])))

collects/syntax/parse/private/runtime.rkt

@@ -1,51 +1,46 @@
 #lang racket/base
 (require racket/stxparam
          unstable/syntax
-         "runtime-progress.rkt"
+         syntax/parse/private/residual ;; keep abs. path
-         "runtime-failure.rkt"
          (for-syntax racket/base
                      racket/list
                      syntax/kerncase
                      racket/private/sc
                      racket/syntax
-                     "rep-data.rkt"
+                     "rep-attrs.rkt"
-                     "rep-attrs.rkt"))
+                     "rep-data.rkt"))
 
-(provide (all-from-out "runtime-progress.rkt")
+(provide with
-         (all-from-out "runtime-failure.rkt")
+         fail-handler
+         cut-prompt
+         wrap-user-code
 
-         this-syntax
+         fail
-         this-context-syntax
+         try
-
-         stx-list-take
-         stx-list-drop/cx
 
          let-attributes
          let-attributes*
          let/unpack
+
          defattrs/unpack
-         attribute
+         check-list^depth
-         attribute-binding
-         check-list^depth)
 
-;; == Syntax Parameters
+         check-literal
+         no-shadow
+         curried-stxclass-parser
+         app-argu)
 
-;; this-syntax
+#|
-;; Bound to syntax being matched inside of syntax class
+TODO: rename file
-(define-syntax-parameter this-syntax
-  (lambda (stx)
-    (wrong-syntax stx "used out of context: not within a syntax class")))
 
-;; this-context-syntax
+This file contains "runtime" (ie, phase 0) auxiliary *macros* used in
-;; Bound to (expression that extracts) context syntax (bottom frame in progress)
+expansion of syntax-parse etc. This file must not contain any
-(define-syntax-parameter this-context-syntax
+reference that persists in a compiled program; those must go in
-  (lambda (stx)
+residual.rkt.
-    (wrong-syntax stx "used out of context: not within a syntax class")))
+|#
 
 ;; == with ==
 
-(provide with)
-
 (define-syntax (with stx)
   (syntax-case stx ()
     [(with ([stxparam expr] ...) . body)
@@ -58,13 +53,6 @@
 
 ;; == Control information ==
 
-(provide fail-handler
-         cut-prompt
-         wrap-user-code
-
-         fail
-         try)
-
 (define-syntax-parameter fail-handler
   (lambda (stx)
     (wrong-syntax stx "internal error: used out of context")))
@@ -96,57 +84,8 @@
                (with ([fail-handler last-fh])
                  e0)))))]))
 
-;; -----
-
-(require syntax/stx)
-(define (stx-list-take stx n)
-  (datum->syntax #f
-                 (let loop ([stx stx] [n n])
-                   (if (zero? n)
-                       null
-                       (cons (stx-car stx)
-                             (loop (stx-cdr stx) (sub1 n)))))))
-
-;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
-(define (stx-list-drop/cx x cx n)
-  (let loop ([x x] [cx cx] [n n])
-    (if (zero? n)
-        (values x
-                (if (syntax? x) x cx))
-        (loop (stx-cdr x)
-              (if (syntax? x) x cx)
-              (sub1 n)))))
-
 ;; == Attributes
 
-(begin-for-syntax
- (define-struct attribute-mapping (var name depth syntax?)
-   #:omit-define-syntaxes
-   #:property prop:procedure
-   (lambda (self stx)
-     (if (attribute-mapping-syntax? self)
-         #`(#%expression #,(attribute-mapping-var self))
-         #`(let ([value #,(attribute-mapping-var self)])
-             (if (check-syntax '#,(attribute-mapping-depth self) value)
-                 value
-                 (raise-syntax-error
-                  #f
-                  (format "attribute is bound to non-syntax value: ~e" value)
-                  (quote-syntax #,(or (let loop ([p (syntax-property stx 'disappeared-use)])
-                                        (cond [(identifier? p) p]
-                                              [(pair? p) (or (loop (car p)) (loop (cdr p)))]
-                                              [else #f]))
-                                      (attribute-mapping-name self))))))))))
-
-;; check-syntax : nat any -> boolean
-;; Returns #t if value is a (listof^depth syntax)
-(define (check-syntax depth value)
-  (if (zero? depth)
-      (syntax? value)
-      (and (list? value)
-           (for/and ([part (in-list value)])
-             (check-syntax (sub1 depth) part)))))
-
 (define-for-syntax (parse-attr x)
   (syntax-case x ()
     [#s(attr name depth syntax?) #'(name depth syntax?)]))
@@ -202,38 +141,6 @@
                   (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
                   ...)))]))
 
-(define-syntax (attribute stx)
-  (parameterize ((current-syntax-context stx))
-    (syntax-case stx ()
-      [(attribute name)
-       (identifier? #'name)
-       (let ([mapping (syntax-local-value #'name (lambda () #f))])
-         (unless (syntax-pattern-variable? mapping)
-           (wrong-syntax #'name "not bound as a pattern variable"))
-         (let ([var (syntax-mapping-valvar mapping)])
-           (let ([attr (syntax-local-value var (lambda () #f))])
-             (unless (attribute-mapping? attr)
-               (wrong-syntax #'name "not bound as an attribute"))
-             (syntax-property (attribute-mapping-var attr)
-                              'disappeared-use
-                              #'name))))])))
-
-;; (attribute-binding id)
-;; mostly for debugging/testing
-(define-syntax (attribute-binding stx)
-  (syntax-case stx ()
-    [(attribute-bound? name)
-     (identifier? #'name)
-     (let ([value (syntax-local-value #'name (lambda () #f))])
-       (if (syntax-pattern-variable? value)
-           (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
-             (if (attribute-mapping? value)
-                 #`(quote #,(make-attr (attribute-mapping-name value)
-                                       (attribute-mapping-depth value)
-                                       (attribute-mapping-syntax? value)))
-                 #'(quote #f)))
-           #'(quote #f)))]))
-
 ;; (check-list^depth attr expr)
 (define-syntax (check-list^depth stx)
   (syntax-case stx ()
@@ -242,20 +149,6 @@
        (quasisyntax/loc #'expr
          (check-list^depth* 'name 'depth expr)))]))
 
-(define (check-list^depth* aname n0 v0)
-  (define (loop n v)
-    (when (positive? n)
-      (unless (list? v)
-        (raise-type-error aname (format "lists nested ~s deep" n0) v))
-      (for ([x (in-list v)]) (loop (sub1 n) x))))
-  (loop n0 v0)
-  v0)
-
-
-;; ====
-
-(provide check-literal)
-
 ;; (check-literal id phase-level-expr ctx) -> void
 (define-syntax (check-literal stx)
   (syntax-case stx ()
@@ -274,38 +167,8 @@
                            'ok-phases/ct-rel
                            (quote-syntax ctx))))]))
 
-(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
-  (unless (or (memv (and used-phase (- used-phase mod-phase))
-                    ok-phases/ct-rel)
-              (identifier-binding id used-phase))
-    (raise-syntax-error
-     #f
-     (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
-             used-phase
-             (and used-phase (- used-phase mod-phase)))
-     ctx id)))
-
-;; ----
-
-(provide begin-for-syntax/once)
-
-;; (begin-for-syntax/once expr/phase1 ...)
-;; evaluates in pass 2 of module/intdefs expansion
-(define-syntax (begin-for-syntax/once stx)
-  (syntax-case stx ()
-    [(bfs/o e ...)
-     (cond [(list? (syntax-local-context))
-            #`(define-values ()
-                (begin (begin-for-syntax/once e ...)
-                       (values)))]
-           [else
-            #'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
-                (m))])]))
-
 ;; ====
 
-(provide no-shadow)
-
 (begin-for-syntax
  (define (check-shadow def)
    (syntax-case def ()
@@ -336,11 +199,6 @@
          [_
           ee]))]))
 
-;; ----
-
-(provide curried-stxclass-parser
-         app-argu)
-
 (define-syntax (curried-stxclass-parser stx)
   (syntax-case stx ()
     [(_ class argu)

collects/syntax/parse/private/sc.rkt

@@ -1,177 +1,64 @@
 #lang racket/base
 (require (for-syntax racket/base
-                     racket/syntax
+                     unstable/lazy-require)
-                     "rep-data.rkt"
+         "keywords.rkt")
-                     "rep.rkt")
+
-         racket/syntax
+;; keep and keep as abs. path -- lazy-loaded macros produce references to this
-         "parse.rkt"
+;; must be required via *absolute module path* from any disappearing module
-         "keywords.rkt"
+;; (so for consistency etc, require absolutely from all modules)
-         "runtime.rkt"
+(require syntax/parse/private/residual)
-         "runtime-report.rkt")
+
+(begin-for-syntax
+ (lazy-require
+  ;; load macro transformers lazily via identifier
+  ;; This module path must also be absolute (not sure why,
+  ;; but it definitely breaks on relative module path).
+  [syntax/parse/private/parse-aux
+   (id:define-syntax-class
+    id:define-splicing-syntax-class
+    id:syntax-parse
+    id:syntax-parser
+    id:define/syntax-parse
+    id:syntax-parser/template
+    id:parser/rhs
+    id:define-eh-alternative-set)]))
 
 (provide define-syntax-class
          define-splicing-syntax-class
-
          syntax-parse
          syntax-parser
+         define/syntax-parse
 
          (except-out (all-from-out "keywords.rkt")
                      ~reflect
                      ~splicing-reflect
                      ~eh-var)
-
          attribute
          this-syntax
 
-         define/syntax-parse
-
-         ;;----
          syntax-parser/template
-         parser/rhs)
+         parser/rhs
+         define-eh-alternative-set)
 
-(begin-for-syntax
+(define-syntaxes (define-syntax-class
- (define (defstxclass stx header rhss splicing?)
+                  define-splicing-syntax-class
-   (parameterize ((current-syntax-context stx))
+                  syntax-parse
-     (let-values ([(name formals arity)
+                  syntax-parser
-                   (let ([p (check-stxclass-header header stx)])
+                  define/syntax-parse
-                     (values (car p) (cadr p) (caddr p)))])
+                  syntax-parser/template
-       (let* ([the-rhs (parse-rhs rhss #f splicing? #:context stx)]
+                  parser/rhs
-              [opt-rhs+def
+                  define-eh-alternative-set)
-               (and (andmap identifier? (syntax->list formals))
+  (let ([tx (lambda (get-id)
-                    (optimize-rhs the-rhs (syntax->list formals)))]
+              (lambda (stx)
-              [the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
+                (syntax-case stx ()
-         (with-syntax ([name name]
+                  [(_ . args)
-                       [formals formals]
+                   (datum->syntax stx (cons (get-id) #'args) stx)])))])
-                       [rhss rhss]
+    (values 
-                       [parser (generate-temporary (format-symbol "parse-~a" name))]
+     (tx id:define-syntax-class)
-                       [arity arity]
+     (tx id:define-splicing-syntax-class)
-                       [attrs (rhs-attrs the-rhs)]
+     (tx id:syntax-parse)
-                       [(opt-def ...)
+     (tx id:syntax-parser)
-                        (if opt-rhs+def
+     (tx id:define/syntax-parse)
-                            (list (cadr opt-rhs+def))
+     (tx id:syntax-parser/template)
-                            '())]
+     (tx id:parser/rhs)
-                       [options (rhs-options the-rhs)]
+     (tx id:define-eh-alternative-set))))
-                       [integrate-expr
-                        (syntax-case (rhs-integrate the-rhs) ()
-                          [#s(integrate predicate description)
-                             #'(integrate (quote-syntax predicate)
-                                          'description)]
-                          [#f
-                           #''#f])])
-           #`(begin (define-syntax name
-                      (stxclass 'name 'arity
-                                'attrs
-                                (quote-syntax parser)
-                                '#,splicing?
-                                options
-                                integrate-expr))
-                    opt-def ...
-                    (define-values (parser)
-                      ;; If opt-rhs, do not reparse:
-                      ;; need to keep same generated predicate name
-                      #,(if opt-rhs+def
-                            (begin
-                              ;; (printf "Integrable syntax class: ~s\n" (syntax->datum #'name))
-                              #`(parser/rhs/parsed
-                                 name formals attrs #,the-rhs
-                                 #,(and (rhs-description the-rhs) #t)
-                                 #,splicing? #,stx))
-                            #`(parser/rhs
-                               name formals attrs rhss #,splicing? #,stx))))))))))
-
-(define-syntax (define-syntax-class stx)
-  (syntax-case stx ()
-    [(dsc header . rhss)
-     (defstxclass stx #'header #'rhss #f)]))
-
-(define-syntax (define-splicing-syntax-class stx)
-  (syntax-case stx ()
-    [(dssc header . rhss)
-     (defstxclass stx #'header #'rhss #t)]))
-
-;; ----
-
-(define-syntax (parser/rhs stx)
-  (syntax-case stx ()
-    [(parser/rhs name formals attrs rhss splicing? ctx)
-     (with-disappeared-uses
-      (let ([rhs
-             (parameterize ((current-syntax-context #'ctx))
-               (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
-                          #:context #'ctx))])
-        #`(parser/rhs/parsed name formals attrs
-                             #,rhs #,(and (rhs-description rhs) #t)
-                             splicing? ctx)))]))
-
-(define-syntax (parser/rhs/parsed stx)
-  (syntax-case stx ()
-    [(prp name formals attrs rhs rhs-has-description? splicing? ctx)
-     #`(let ([get-description
-              (lambda formals
-                (if 'rhs-has-description?
-                    #,(rhs-description (syntax-e #'rhs))
-                    (symbol->string 'name)))])
-         (parse:rhs rhs attrs formals splicing?
-                    (if 'rhs-has-description?
-                        #,(rhs-description (syntax-e #'rhs))
-                        (symbol->string 'name))))]))
-
-;; ====
-
-(define-syntax (syntax-parse stx)
-  (syntax-case stx ()
-    [(syntax-parse stx-expr . clauses)
-     (quasisyntax/loc stx
-       (let ([x (datum->syntax #f stx-expr)])
-         (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))]))
-
-(define-syntax (syntax-parser stx)
-  (syntax-case stx ()
-    [(syntax-parser . clauses)
-     (quasisyntax/loc stx
-       (lambda (x)
-         (let ([x (datum->syntax #f x)])
-           (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))]))
-
-(define-syntax (syntax-parser/template stx)
-  (syntax-case stx ()
-    [(syntax-parser/template ctx . clauses)
-     (quasisyntax/loc stx
-       (lambda (x)
-         (let ([x (datum->syntax #f x)])
-           (parse:clauses x clauses one-template ctx))))]))
-
-;; ====
-
-(define-syntax (define/syntax-parse stx)
-  (syntax-case stx ()
-    [(define/syntax-parse pattern . rest)
-     (let-values ([(rest pattern defs)
-                   (parse-pattern+sides #'pattern
-                                        #'rest
-                                        #:splicing? #f
-                                        #:decls (new-declenv null)
-                                        #:context stx)])
-       (let ([expr
-              (syntax-case rest ()
-                [( expr ) #'expr]
-                [_ (raise-syntax-error #f "bad syntax" stx)])]
-             [attrs (pattern-attrs pattern)])
-         (with-syntax ([(a ...) attrs]
-                       [(#s(attr name _ _) ...) attrs]
-                       [pattern pattern]
-                       [(def ...) defs]
-                       [expr expr])
-           #'(defattrs/unpack (a ...)
-               (let* ([x (datum->syntax #f expr)]
-                      [cx x]
-                      [pr (ps-empty x x)]
-                      [es null]
-                      [fh0 (syntax-patterns-fail x)])
-                 (parameterize ((current-syntax-context x))
-                   def ...
-                   (#%expression
-                    (with ([fail-handler fh0]
-                           [cut-prompt fh0])
-                          (parse:S x cx pattern pr es
-                                   (list (attribute name) ...))))))))))]))

collects/tests/stxparse/setup.rkt

@@ -1,8 +1,9 @@
 #lang racket/base
 (require rackunit
          syntax/parse
-         syntax/parse/private/rep-attrs
+         (only-in syntax/parse/private/residual
-         (only-in syntax/parse/private/runtime attribute-binding)
+                  attribute-binding)
+         syntax/parse/private/residual-ct  ;; for attr functions
          (for-syntax racket/base))
 
 (provide tok

collects/unstable/lazy-require.rkt

@@ -2,8 +2,7 @@
 (require (for-syntax racket/base)
          racket/runtime-path
          racket/promise)
-(provide lazy-require
+(provide lazy-require)
-         (for-syntax #%datum))
 
 (define-syntax (lazy-require stx)
   (syntax-case stx ()
@@ -20,7 +19,9 @@
                       (unless (identifier? name)
                         (raise-syntax-error #f "expected identifier" #'orig-stx name))
                       #`(define #,name (make-lazy-function '#,name get-sym)))])
-       #'(begin (define-runtime-module-path-index mpi-var modpath)
+       ;; implicit quasiquote, so can use normal module-path syntax'
+       ;; or escape to compute a the module-path via expression
+       #'(begin (define-runtime-module-path-index mpi-var (quasiquote modpath))
                 (define (get-sym sym)
                   (parameterize ((current-namespace (namespace-anchor->namespace anchor)))
                     (dynamic-require mpi-var sym)))

collects/unstable/scribblings/lazy-require.scrbl

@@ -11,14 +11,20 @@
 
 @unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
 
-@defform[(lazy-require [mod-expr (imported-fun-id ...)] ...)
+@defform/subs[#:literals (unquote)
-         #:contracts ([mod-expr module-path?])]{
+              (lazy-require [mod (imported-fun-id ...)] ...)
+              ([mod module-path
+                   (unquote module-path-expr)])
+              #:contracts ([module-path-expr module-path?])]{
 
 Defines each @racket[imported-fun-id] as a function that, when called,
 dynamically requires the export named @racket['imported-fun-id] from
-the module specified by @racket[mod-expr] and calls it with the same
+the module specified by @racket[mod] and calls it with the same
 arguments.
 
-As with @racket[define-runtime-module-path-index], @racket[mod-expr]
+The module @racket[mod] can be specified as a @racket[_module-path]
+(see @racket[require]) or as an @racket[unquote]-escaped expression
+that computes a module path. As with
+@racket[define-runtime-module-path-index], a @racket[module-path-expr]
 is evaluated both in phase 0 and phase 1.
 }