syntax/parse:

added #:defaults arg to ~optional
  cleaned up error-reporting of special forms (not generated code)

svn: r15848

collects/syntax/private/stxparse/parse.ss

@@ -136,24 +136,28 @@
 ;; (parse:clauses id (Clause ...))
 (define-syntax (parse:clauses stx)
   (syntax-case stx ()
-    [(parse:clauses x clauses)
+    [(parse:clauses x clauses ctx)
      (let ()
        (define-values (chunks clauses-stx)
          (parse-keyword-options #'clauses parse-directive-table
-                                #:context stx
+                                #:context #'ctx
                                 #:no-duplicates? #t))
        (define context
          (options-select-value chunks '#:context #:default #'x))
-       (define-values (decls0 defs) (get-decls+defs chunks))
+       (define-values (decls0 defs)
+         (get-decls+defs chunks #t #:context #'ctx))
        (define (for-clause clause)
          (syntax-case clause ()
            [[p . rest]
-            (let-values ([(rest decls sides)
+            (let-values ([(rest decls2 defs2 sides)
-                          (parse-pattern-directives #'rest #:decls decls0)])
+                          (parse-pattern-directives #'rest
-              (define-values (decls2 defs2) (decls-create-defs decls))
+                                                    #:allow-declare? #t
+                                                    #:decls decls0
+                                                    #:context #'ctx)])
               (with-syntax ([rest rest]
                             [fc (empty-frontier #'x)]
-                            [pattern (parse-whole-pattern #'p decls2)]
+                            [pattern
+                             (parse-whole-pattern #'p decls2 #:context #'ctx)]
                             [(local-def ...) defs2])
                 #`(let ()
                     local-def ...
@@ -432,7 +436,7 @@
                                    #:fce loop-fc)]
                             ...
                             [else
-                             (let-attributes ([a (rep:finalize attr-repc alt-id)] ...)
+                             (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
                                (parse:S dx loop-fc tail k))]))))
              (let ([rel-rep 0] ...
                    [alt-id (rep:initial-value attr-repc)] ...)
@@ -468,39 +472,49 @@
                                   #:fce #,(frontier:add-index (wash #'fc)
                                                               #'index))))]))]))
 
-;; (rep:finalize RepConstraint expr) : expr
-(define-syntax (rep:finalize stx)
-  (syntax-case stx ()
-    [(_ #s(rep:once _ _ _) v) #'v]
-    [(_ #s(rep:optional _ _) v) #'v]
-    [(_ _ v) #'(reverse v)]))
-
 ;; (rep:initial-value RepConstraint) : expr
 (define-syntax (rep:initial-value stx)
   (syntax-case stx ()
     [(_ #s(rep:once _ _ _)) #'#f]
-    [(_ #s(rep:optional _ _)) #'#f]
+    [(_ #s(rep:optional _ _ _)) #'#f]
     [(_ _) #'null]))
 
+;; (rep:finalize RepConstraint expr) : expr
+(define-syntax (rep:finalize stx)
+  (syntax-case stx ()
+    [(_ a #s(rep:optional _ _ defaults) v)
+     (with-syntax ([#s(attr name _ _) #'a]
+                   [(#s(clause:attr da de) ...) #'defaults])
+       (let ([default
+              (for/or ([da (syntax->list #'(da ...))]
+                       [de (syntax->list #'(de ...))])
+                (with-syntax ([#s(attr dname _ _) da])
+                  (and (bound-identifier=? #'name #'dname) de)))])
+         (if default
+             #`(or v #,default)
+             #'v)))]
+    [(_ a #s(rep:once _ _ _) v) #'v]
+    [(_ a _ v) #'(reverse v)]))
+
 ;; (rep:min-number RepConstraint) : expr
 (define-syntax (rep:min-number stx)
   (syntax-case stx ()
     [(_ #s(rep:once _ _ _)) #'1]
-    [(_ #s(rep:optional _ _)) #'0]
+    [(_ #s(rep:optional _ _ _)) #'0]
     [(_ #s(rep:bounds min max _ _ _)) #'min]))
 
 ;; (rep:max-number RepConstraint) : expr
 (define-syntax (rep:max-number stx)
   (syntax-case stx ()
     [(_ #s(rep:once _ _ _)) #'1]
-    [(_ #s(rep:optional _ _)) #'1]
+    [(_ #s(rep:optional _ _ _)) #'1]
     [(_ #s(rep:bounds min max _ _ _)) #'max]))
 
 ;; (rep:combine RepConstraint expr expr) : expr
 (define-syntax (rep:combine stx)
   (syntax-case stx ()
     [(_ #s(rep:once _ _ _) a b) #'a]
-    [(_ #s(rep:optional _ _) a b) #'a]
+    [(_ #s(rep:optional _ _ _) a b) #'a]
     [(_ _ a b) #'(cons a b)]))
 
 ;; ----
@@ -534,7 +548,7 @@
   (syntax-rules ()
     [(_ rep #s(rep:once name too-few-msg too-many-msg))
      (expectation-of-message/too-few too-few-msg name)]
-    [(_ rep #s(rep:optional name too-many-msg))
+    [(_ rep #s(rep:optional name too-many-msg _))
      (error 'impossible)]
     [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
      (expectation-of-message/too-few too-few-msg name)]))
@@ -543,7 +557,7 @@
   (syntax-rules ()
     [(_ rep #s(rep:once name too-few-msg too-many-msg))
      (expectation-of-message/too-many too-many-msg name)]
-    [(_ rep #s(rep:optional name too-many-msg))
+    [(_ rep #s(rep:optional name too-many-msg _))
      (expectation-of-message/too-many too-many-msg name)]
     [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
      (expectation-of-message/too-many too-many-msg name)]))

collects/syntax/private/stxparse/rep-attrs.ss

@@ -61,7 +61,13 @@ a list^depth of syntax objects).
 
  [intersect-sattrss
   (-> (listof (listof sattr?))
-      (listof sattr?))])
+      (listof sattr?))]
+
+ [check-iattrs-subset
+  (-> (listof iattr?)
+      (listof iattr?)
+      (or/c syntax? false/c)
+      any)])
 
 ;; IAttr operations
 
@@ -168,3 +174,14 @@ a list^depth of syntax objects).
     (wrong-syntax (attr-name iattr)
                   "attribute may not be bound to syntax: ~s"
                   (attr-name sattr))))
+
+;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void
+(define (check-iattrs-subset little big ctx)
+  (define big-t (make-bound-id-table))
+  (for ([a big]) (bound-id-table-set! big-t (attr-name a) #t))
+  (for ([a little])
+    (unless (bound-id-table-ref big-t (attr-name a) #f)
+      (raise-syntax-error #f
+                          "attribute bound in defaults but not in pattern"
+                          ctx
+                          (attr-name a)))))

collects/syntax/private/stxparse/rep-patterns.ss

@@ -82,7 +82,7 @@ A RepConstraint is one of
 |#
 (define-struct ehpat (attrs head repc) #:prefab)
 (define-struct rep:once (name under-message over-message) #:prefab)
-(define-struct rep:optional (name over-message #| defaults |#) #:prefab)
+(define-struct rep:optional (name over-message defaults) #:prefab)
 (define-struct rep:bounds (min max name under-message over-message) #:prefab)
 
 

collects/syntax/private/stxparse/rep.ss

@@ -11,37 +11,46 @@
          "rep-data.ss"
          "codegen-data.ss")
 
+;; Error reporting
+;; All entry points should have explicit, mandatory #:context arg
+;; (mandatory from outside, at least)
+
 (provide/contract
  [parse-rhs
-  (-> syntax? boolean? boolean? syntax?
+  (-> syntax? boolean? boolean? #:context (or/c false/c syntax?)
       rhs?)]
  [parse-whole-pattern 
-  (-> syntax? DeclEnv/c
+  (-> syntax? DeclEnv/c #:context (or/c false/c syntax?)
       pattern?)]
  [parse-pattern-directives
-  (->* [stx-list?]
+  (-> stx-list?
-       [#:decls DeclEnv/c #:allow-declare? boolean?]
+      #:allow-declare? boolean?
-       (values stx-list? DeclEnv/c (listof SideClause/c)))]
+      #:decls (or/c false/c DeclEnv/c)
+      #:context (or/c false/c syntax?)
+      (values stx-list? DeclEnv/c (listof syntax?) (listof SideClause/c)))]
  [parse-directive-table any/c]
  [get-decls+defs
-  (->* [list?] [boolean?]
+  (-> list? boolean? #:context (or/c false/c syntax?)
       (values DeclEnv/c (listof syntax?)))]
+ #|
  [decls-create-defs
   (-> DeclEnv/c
       (values DeclEnv/c (listof syntax?)))]
+ |#
+ [create-aux-def
+  (-> list? ;; DeclEntry
+      (values identifier? identifier? (listof sattr?) (listof syntax?)))]
  [check-literals-list
   (-> syntax? syntax?
       (listof (list/c identifier? identifier?)))]
+ #|
  [check-literal-sets-list
   (-> syntax? syntax?
       (listof (listof (list/c identifier? identifier?))))]
- [append-lits+litsets
+ |#
-  (-> (listof (list/c identifier? identifier?))
+ [check-conventions-rules
-      (listof (listof (list/c identifier? identifier?)))
+  (-> syntax? syntax?
-      syntax?
+      (listof (list/c regexp? any/c)))])
-      (listof (list/c identifier? identifier?)))]
- [check-conventions-rules any/c]
- [create-aux-def any/c])
 
 (define (atomic-datum? stx)
   (let ([datum (syntax-e stx)])
@@ -86,74 +95,67 @@
 ;; ---
 
 ;; parse-rhs : stx boolean boolean stx -> RHS
-;; If strict? is true, then referenced stxclasses must be defined, literals must be bound.
+;; If strict? is true, then referenced stxclasses must be defined and
-;; Set to #f for pass1 (attr collection); parser requires stxclasses to be bound.
+;; literals must be bound. Set to #f for pass1 (attr collection);
-(define (parse-rhs stx strict? splicing? ctx)
+;; parser requires stxclasses to be bound.
-  (define-values (rest description transparent? attributes auto-nested? decls defs)
+(define (parse-rhs stx strict? splicing? #:context ctx)
-    (parse-rhs/part1 stx strict? ctx))
+  (parameterize ((current-syntax-context ctx))
+    (define-values (rest description transp? attributes auto-nested? decls defs)
+      (parse-rhs/part1 stx strict?))
     (define patterns
       (parameterize ((stxclass-lookup-config
                       (cond [strict? 'yes]
                             [auto-nested? 'try]
                             [else 'no])))
-      (parse-variants rest decls splicing? ctx)))
+        (parse-variants rest decls splicing?)))
     (when (null? patterns)
-    (wrong-syntax ctx "expected at least one variant"))
+      (wrong-syntax #f "expected at least one variant"))
     (let ([sattrs
            (or attributes
                (intersect-sattrss (map variant-attrs patterns)))])
-    (make rhs stx sattrs transparent? description patterns defs)))
+      (make rhs stx sattrs transp? description patterns defs))))
 
-(define (parse-rhs/part1 stx strict? ctx)
+(define (parse-rhs/part1 stx strict?)
   (define-values (chunks rest)
     (parse-keyword-options stx rhs-directive-table
-                           #:context ctx
+                           #:context (current-syntax-context)
+                           #:incompatible '((#:attributes #:auto-nested-attributes))
                            #:no-duplicates? #t))
-  (define desc0 (assq '#:description chunks))
+  (define description (options-select-value chunks '#:description #:default #f))
-  ;; (define trans0 (assq '#:transparent chunks))
+  (define opaque? (and (assq '#:opaque chunks) #t))
-  (define opaque0 (assq '#:opaque chunks))
-  (define attrs0 (assq '#:attributes chunks))
-  (define auto-nested0 (assq '#:auto-nested-attributes chunks))
-  (define description (and desc0 (caddr desc0)))
-  (define opaque? (and opaque0 #t))
   (define transparent? (not opaque?))
-  ;;(define transparent? (and trans0 #t))
+  (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t))
-  (define attributes
+  (define attributes (options-select-value chunks '#:attributes #:default #f))
-    (cond [(and attrs0 auto-nested0)
-           (raise-syntax-error #f "cannot use both #:attributes and #:auto-nested-attributes"
-                               ctx (cadr auto-nested0))]
-          [attrs0 (caddr attrs0)]
-          [else #f]))
   (define-values (decls defs) (get-decls+defs chunks strict?))
-  (values rest description transparent? attributes (and auto-nested0 #t) decls defs))
+  (values rest description transparent? attributes auto-nested? decls defs))
 
-(define (parse-variants rest decls splicing? ctx)
+(define (parse-variants rest decls splicing?)
   (define (gather-patterns stx)
     (syntax-case stx (pattern)
       [((pattern . _) . rest)
        (cons (parse-variant (stx-car stx) splicing? decls)
              (gather-patterns #'rest))]
       [(bad-variant . rest)
-       (raise-syntax-error #f "expected syntax-class variant" ctx #'bad-variant)]
+       (wrong-syntax #'bad-variant "expected syntax-class variant")]
       [()
        null]))
   (gather-patterns rest))
 
 ;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax))
-(define (get-decls+defs chunks [strict? #t])
+(define (get-decls+defs chunks strict?
-  (decls-create-defs (get-decls chunks strict?)))
+                        #:context [ctx (current-syntax-context)])
+  (parameterize ((current-syntax-context ctx))
+    (decls-create-defs (get-decls chunks strict?))))
 
 ;; get-decls : chunks -> DeclEnv
-(define (get-decls chunks strict? #:context [ctx #f])
+(define (get-decls chunks strict?)
-  (define lits0 (assq '#:literals chunks))
+  (define lits (options-select-value chunks '#:literals #:default null))
-  (define litsets0 (assq '#:literal-sets chunks))
+  (define litsets (options-select-value chunks '#:literal-sets #:default null))
-  (define convs0 (assq '#:conventions chunks))
+  (define convs (options-select-value chunks '#:conventions #:default null))
   (define literals
-    (append-lits+litsets
+    (append-lits+litsets (check-literals-bound lits strict?)
-     (check-literals-bound (if lits0 (caddr lits0) null) strict?)
+                         litsets))
-     (if litsets0 (caddr litsets0) null)
+  (define convention-rules (apply append convs))
-     ctx))
-  (define convention-rules (if convs0 (apply append (caddr convs0)) null))
   (new-declenv literals #:conventions convention-rules))
 
 (define (check-literals-bound lits strict?)
@@ -164,7 +166,7 @@
                   (identifier-binding (cadr p) 1)
                   (identifier-binding (cadr p) #f)
                   (identifier-binding (cadr p) (syntax-local-phase-level)))
-        (wrong-syntax (cadr p) "unbound literal not allowed"))))
+        (wrong-syntax (cadr p) "unbound identifier not allowed as literal"))))
   lits)
 
 ;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
@@ -195,33 +197,35 @@
             (values #'sc-parser #'sc-description (stxclass-attrs sc)
                     null))))))
 
-(define (append-lits+litsets lits litsets ctx)
+(define (append-lits+litsets lits litsets)
   (define seen (make-bound-id-table lits))
   (for ([litset litsets])
     (for ([lit litset])
       (when (bound-id-table-ref seen (car lit) #f)
-        (raise-syntax-error #f "duplicate literal declaration" ctx (car lit)))
+        (wrong-syntax (car lit) "duplicate literal declaration"))
       (bound-id-table-set! seen (car lit) #t)))
   (apply append lits litsets))
 
 ;; parse-variant : stx boolean DeclEnv -> RHS
 (define (parse-variant stx splicing? decls0)
+  (parameterize ((current-syntax-context stx))
     (syntax-case stx (pattern)
       [(pattern p . rest)
-     (let-values ([(rest decls1 clauses)
+       (let-values ([(rest decls defs clauses)
                      (parse-pattern-directives #'rest
+                                               #:allow-declare? #t
                                                #:decls decls0)])
-       (define-values (decls defs) (decls-create-defs decls1))
          (unless (stx-null? rest)
            (wrong-syntax (if (pair? rest) (car rest) rest)
                          "unexpected terms after pattern directives"))
-       (let* ([pattern (parse-whole-pattern #'p decls splicing?)]
+         (let* ([pattern
+                 (parse-whole-pattern #'p decls splicing?)]
                 [attrs
                  (append-iattrs
                   (cons (pattern-attrs pattern)
                         (side-clauses-attrss clauses)))]
                 [sattrs (iattrs->sattrs attrs)])
-         (make variant stx sattrs pattern clauses defs)))]))
+           (make variant stx sattrs pattern clauses defs)))])))
 
 (define (side-clauses-attrss clauses)
   (for/list ([c clauses]
@@ -231,7 +235,9 @@
         (list (clause:attr-attr c)))))
 
 ;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
-(define (parse-whole-pattern stx decls [splicing? #f])
+(define (parse-whole-pattern stx decls [splicing? #f]
+                             #:context [ctx (current-syntax-context)])
+  (parameterize ((current-syntax-context ctx))
     (define pattern
       (if splicing?
           (parse-head-pattern stx decls)
@@ -240,9 +246,8 @@
     (define excess-domain (declenv-domain-difference decls pvars))
     (when (pair? excess-domain)
       (wrong-syntax #f "declared pattern variables do not appear in pattern"
-                  #:extra excess-domain))
+                    #:extras excess-domain))
-  pattern)
+    pattern))
-
 
 ;; ----
 
@@ -338,9 +343,13 @@
     [(list 'literal internal-id literal-id)
      (make pat:literal null literal-id)]
     [(list 'stxclass _ _ _)
-     (error 'parse-pat:id "decls had leftover 'stxclass entry: ~s" entry)]
+     (error 'parse-pat:id
+            "(internal error) decls had leftover 'stxclass entry: ~s"
+            entry)]
     [(list 'splicing-stxclass _ _ _)
-     (error 'parse-pat:id "decls had leftover 'splicing-stxclass entry: ~s" entry)]
+     (error 'parse-pat:id
+            "(internal error) decls had leftover 'splicing-stxclass entry: ~s"
+            entry)]
     [(list 'parser parser description attrs)
      (parse-pat:id/s id id parser description attrs)]
     [(list 'splicing-parser parser description attrs)
@@ -404,7 +413,9 @@
 
 ;; prefix-attr : SAttr identifier -> IAttr
 (define (prefix-attr a prefix)
-  (make attr (prefix-attr-name prefix (attr-name a)) (attr-depth a) (attr-syntax? a)))
+  (make attr (prefix-attr-name prefix (attr-name a))
+        (attr-depth a)
+        (attr-syntax? a)))
 
 ;; prefix-attr-name : id symbol -> id
 (define (prefix-attr-name prefix name)
@@ -419,8 +430,7 @@
                    (parse-keyword-options #'rest describe-option-table
                                           #:no-duplicates? #t
                                           #:context stx)])
-       (define trans0 (assq '#:transparent chunks))
+       (define transparent? (and (assq '#:transparent chunks) #t))
-       (define transparent? (and trans0 #t))
        (syntax-case rest ()
          [(description pattern)
           (let ([p (parse-some-pattern #'pattern decls allow-head?)])
@@ -446,28 +456,6 @@
   (define patterns (parse-cdr-patterns stx decls #f #t))
   (make pat:and (append-iattrs (map pattern-attrs patterns)) patterns))
 
-;; FIXME: broken, first off, and second, must not reorder names, preserve original scopes
-(define (simplify-and-pattern patterns0)
-  (define (loop patterns names)
-    (cond [(pair? patterns)
-           (match (car patterns)
-             [(struct pat:any ('()))
-              (loop (cdr patterns) names)]
-             [(struct pat:name (_ pattern ns))
-              (loop (cons pattern (cdr patterns))
-                    (append ns names))])]
-          [else (values patterns names)]))
-  (define-values (patterns names)
-    (loop patterns0 null))
-  (define base
-    (if (pair? patterns)
-        (make pat:and (append-iattrs (map pattern-attrs patterns)) patterns)
-        (make pat:any '())))
-  (if (pair? names)
-      (let ([new-attrs (for/list ([name names]) (make attr name 0 #t))])
-        (make pat:name (append new-attrs (pattern-attrs base)) base names))
-      base))
-
 (define (parse-hpat:seq stx list-stx decls)
   (define pattern (parse-single-pattern list-stx decls))
   (check-list-pattern pattern stx)
@@ -479,14 +467,14 @@
   (let ([result
          (for/list ([sub (cdr (stx->list stx))])
            (if allow-cut?
-               (or (parse-cut/and sub)
+               (or (parse-cut-in-and sub)
                    (parse-some-pattern sub decls allow-head?))
                (parse-some-pattern sub decls allow-head?)))])
     (when (null? result)
       (wrong-syntax stx "expected at least one pattern"))
     result))
 
-(define (parse-cut/and stx)
+(define (parse-cut-in-and stx)
   (syntax-case stx (~!)
     [~! (make pat:cut null (make pat:any null))]
     [_ #f]))
@@ -495,7 +483,7 @@
   (define p (parse-head-pattern stx decl))
   (when (head-pattern? p)
     (unless allow-head?
-      (wrong-syntax stx "head pattern not allowed")))
+      (wrong-syntax stx "head pattern not allowed here")))
   p)
 
 (define (parse-pat:dots stx head tail decls)
@@ -529,12 +517,8 @@
      (let-values ([(chunks rest)
                    (parse-keyword-options #'rest fail-directive-table
                                           #:context stx
+                                          #:incompatible '((#:when #:unless))
                                           #:no-duplicates? #t)])
-       ;; chunks has 0 or 1 of each of #:when, #:unless
-       ;; if has both, second one is bad; report it
-       (when (> (length chunks) 1)
-         (wrong-syntax (cadr (cadr chunks))
-                       "cannot use both #:when and #:unless conditions"))
        (let ([condition
               (if (null? chunks)
                   #'#t
@@ -594,13 +578,16 @@
               (options-select-value chunks '#:too-many #:default #'#f)]
              [name
               (options-select-value chunks '#:name #:default #'#f)]
-             #|
              [defaults
-              (options-select-value chunks '#:defaults #:default '())]
+              (options-select-value chunks '#:defaults #:default '())])
-             |#)
+         (define pattern-iattrs (pattern-attrs head))
-         (make ehpat (map attr-make-uncertain (pattern-attrs head))
+         (define defaults-iattrs
-               head
+           (append-iattrs (side-clauses-attrss defaults)))
-               (make rep:optional name too-many-msg #| defaults |#))))]))
+         (define all-iattrs
+           (union-iattrs (list pattern-iattrs defaults-iattrs)))
+         (check-iattrs-subset defaults-iattrs pattern-iattrs stx)
+         (make ehpat all-iattrs head
+               (make rep:optional name too-many-msg defaults))))]))
 
 (define (parse-ehpat/once stx decls)
   (syntax-case stx (~once)
@@ -655,12 +642,14 @@
 ;; -----
 
 ;; parse-pattern-directives : stxs(PatternDirective) <kw-args>
-;;                         -> stx DeclEnv (listof SideClause)
+;;                         -> stx DeclEnv (listof stx) (listof SideClause)
 (define (parse-pattern-directives stx
-                                  #:decls [decls #f]
+                                  #:allow-declare? allow-declare?
-                                  #:allow-declare? [allow-declare? #t])
+                                  #:decls decls
+                                  #:context [ctx (current-syntax-context)])
+  (parameterize ((current-syntax-context ctx))
     (define-values (chunks rest)
-    (parse-keyword-options stx pattern-directive-table))
+      (parse-keyword-options stx pattern-directive-table #:context ctx))
     (define-values (decls2 chunks2)
       (if allow-declare?
           (grab-decls chunks decls)
@@ -669,7 +658,9 @@
       ;; NOTE: use *original* decls
       ;; because decls2 has #:declares for *above* pattern
       (parse-pattern-sides chunks2 decls))
-  (values rest decls2 (parse-pattern-sides chunks2 decls)))
+    (define-values (decls3 defs)
+      (decls-create-defs decls2))
+    (values rest decls3 defs (parse-pattern-sides chunks2 decls))))
 
 ;; parse-pattern-sides : (listof chunk) DeclEnv
 ;;                    -> (listof SideClause/c)
@@ -719,6 +710,9 @@
       [else (values decls chunks)]))
   (loop chunks decls))
 
+
+;; ----
+
 ;; Keyword Options & Checkers
 
 ;; check-attr-arity-list : stx stx -> (listof SAttr)
@@ -885,4 +879,4 @@
 (define optional-directive-table
   (list (list '#:too-many check-expression)
         (list '#:name check-expression)
-        #| (list '#:defaults check-bind-clause-list) |#))
+        (list '#:defaults check-bind-clause-list)))

collects/syntax/private/stxparse/sc.ss

@@ -49,7 +49,7 @@
                  [rhss rhss])
      (let ([the-rhs
             (parameterize ((current-syntax-context stx))
-              (parse-rhs #'rhss #f splicing? stx))])
+              (parse-rhs #'rhss #f splicing? #:context stx))])
        (with-syntax ([parser (generate-temporary
                               (format-symbol "parse-~a" (syntax-e #'name)))]
                      [attrs (rhs-attrs the-rhs)])
@@ -125,7 +125,7 @@
      (with-disappeared-uses
       (let ([rhs
              (parameterize ((current-syntax-context #'ctx))
-               (parse-rhs #'rhss #t (syntax-e #'splicing?) #'ctx))])
+               (parse-rhs #'rhss #t (syntax-e #'splicing?) #:context #'ctx))])
         #`(let ([get-description
                  (lambda args
                    #,(or (rhs-description rhs)
@@ -164,32 +164,28 @@
 (define-syntax (debug-rhs stx)
   (syntax-case stx ()
     [(debug-rhs rhs)
-     (let ([rhs (parse-rhs #'rhs #t stx)])
+     (let ([rhs (parse-rhs #'rhs #t #:context stx)])
        #`(quote #,rhs))]))
 
 (define-syntax (debug-pattern stx)
   (syntax-case stx ()
     [(debug-pattern p)
-     (let ([p (parse-whole-pattern #'p (new-declenv null))])
+     (let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)])
        #`(quote #,p))]))
 
-(define-syntax-rule (syntax-parse stx-expr . clauses)
+(define-syntax (syntax-parse stx)
-  (let ([x stx-expr])
-    (syntax-parse* syntax-parse x . clauses)))
-
-(define-syntax-rule (syntax-parser . clauses)
-  (lambda (x) (syntax-parse* syntax-parser x . clauses)))
-
-(define-syntax (syntax-parse* stx)
   (syntax-case stx ()
-    [(syntax-parse report-as expr . clauses)
+    [(syntax-parse stx-expr . clauses)
-     (with-disappeared-uses
+     (quasisyntax/loc stx
-      (parameterize ((current-syntax-context
+       (let ([x stx-expr])
-                      (syntax-property stx
+         (parse:clauses x clauses #,stx)))]))
-                                       'report-errors-as
+
-                                       (syntax-e #'report-as))))
+(define-syntax (syntax-parser stx)
-        #`(let ([x expr])
+  (syntax-case stx ()
-            (parse:clauses x clauses))))]))
+    [(syntax-parser . clauses)
+     (quasisyntax/loc stx
+       (lambda (x)
+         (parse:clauses x clauses #,stx)))]))
 
 (define-syntax with-patterns
   (syntax-rules ()

collects/syntax/private/util/error.ss

@@ -12,5 +12,5 @@
     (raise-syntax-error (if (symbol? blame) blame #f)
                         (apply format format-string args)
                         ctx
-                        (or stx ctx)
+                        stx
                         extras)))