syntax/parse: record nullability in ehpat

Non-nullable ellipsis-head patterns can omit the null match check.

racket/collects/syntax/parse/private/parse.rkt

@@ -891,14 +891,14 @@ Conventions:
   (syntax-case stx ()
     ;; == Specialized cases
     ;; -- (x ... . ())
-    [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f))
+    [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f #f))
                  #s(pat:datum ()) pr es k)
      #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)])
          (case status
            ((ok) (let-attributes ([attr0 result]) k))
            (else (fail result))))]
     ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
-    [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f))
+    [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f #f))
                  #s(pat:datum ()) pr es k)
      #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)])
          (case status
@@ -909,7 +909,7 @@ Conventions:
     ;; Microbenchmark suggests this isn't a useful specialization
     ;; (probably try-or-pair/null-check already does the useful part)
     ;; == General case
-    [(parse:dots x cx (#s(ehpat head-attrs head head-repc) ...) tail pr es k)
+    [(parse:dots x cx (#s(ehpat head-attrs head head-repc nullable?) ...) tail pr es k)
      (let ()
        (define repcs (wash-list wash #'(head-repc ...)))
        (define rep-ids (for/list ([repc (in-list repcs)])
@@ -925,6 +925,7 @@ Conventions:
        (define attrs (map car aattrs))
        (define attr-repcs (map cdr aattrs))
        (define ids (map attr-name attrs))
+       (define tail-pattern-is-null? (equal? (syntax->datum #'tail) '#s(pat:datum ())))
        (with-syntax ([(id ...) ids]
                      [(alt-id ...) (generate-temporaries ids)]
                      [reps rel-rep-ids]
@@ -933,8 +934,10 @@ Conventions:
                      [(rel-repc ...) rel-repcs]
                      [(a ...) attrs]
                      [(attr-repc ...) attr-repcs]
-                     [tail-pattern-is-null?
+                     [do-pair/null?
-                      (equal? (syntax->datum #'tail) '#s(pat:datum ()))])
+                      ;; FIXME: do pair/null check only if no nullable head patterns
+                      ;; (and tail-pattern-is-null? (andmap not (syntax->datum #'(nullable? ...))))
+                      tail-pattern-is-null?])
          (define/with-syntax alt-map #'((id . alt-id) ...))
          (define/with-syntax loop-k
            #'(dots-loop dx* dcx* loop-pr* fail-handler rel-rep ... alt-id ...))
@@ -942,8 +945,8 @@ Conventions:
              ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
              (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...)
                (with ([fail-handler fh])
-                 (try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es
+                 (try-or-pair/null-check do-pair/null? dx dcx loop-pr es
-                   (try (parse:EH dx dcx loop-pr head-attrs head-repc dx* dcx* loop-pr* 
+                   (try (parse:EH dx dcx loop-pr head-attrs nullable? head-repc dx* dcx* loop-pr* 
                                   alt-map head-rep head es loop-k)
                         ...)
                    (cond [(< rel-rep (rep:min-number rel-repc))
@@ -971,7 +974,7 @@ Conventions:
 ;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed.
 (define-syntax (parse:EH stx)
   (syntax-case stx ()
-    [(parse:EH x cx pr attrs repc x* cx* pr* alts rep head es k)
+    [(parse:EH x cx pr attrs nullable? repc x* cx* pr* alts rep head es k)
      (let ()
        (define/with-syntax k*
          (let* ([main-attrs (wash-iattrs #'attrs)]
@@ -984,9 +987,10 @@ Conventions:
                    (for/list ([id (in-list ids)]) (bound-id-table-ref table id)))])
            (with-syntax ([(id ...) ids]
                          [(alt-id ...) alt-ids])
-             #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...
+             #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
-                     [diff (ps-difference pr pr*)])
+                 #,(if (syntax->datum #'nullable?)
-                 (if (zero? diff) (error/null-eh-match) k)))))
+                       #'(if (zero? (ps-difference pr pr*)) (error/null-eh-match) k)
+                       #'k)))))
        (syntax-case #'repc ()
          [#f #`(parse:H x cx x* cx* pr* head pr es k*)]
          [_  #`(parse:H x cx x* cx* pr* head pr es

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

@@ -3,9 +3,7 @@
          "rep-attrs.rkt"
          "kws.rkt"
          "minimatch.rkt"
-         (for-syntax racket/base
+         racket/syntax)
-                     syntax/stx
-                     racket/syntax))
 (provide (all-defined-out))
 
 #|
@@ -125,7 +123,7 @@ A HeadPattern is one of
 
 #|
 An EllipsisHeadPattern is
-  (ehpat (Listof IAttr) HeadPattern RepConstraint)
+  (ehpat (Listof IAttr) HeadPattern RepConstraint Boolean)
 
 A RepConstraint is one of
   (rep:once stx stx stx)
@@ -134,7 +132,7 @@ A RepConstraint is one of
   #f
 |#
 
-(define-struct ehpat (attrs head repc) #:prefab)
+(define-struct ehpat (attrs head repc nullable?) #:prefab)
 (define-struct rep:once (name under-message over-message) #:prefab)
 (define-struct rep:optional (name over-message defaults) #:prefab)
 (define-struct rep:bounds (min max name under-message over-message) #:prefab)
@@ -305,7 +303,7 @@ A RepConstraint is one of
      null]
 
     ;; EH patterns
-    [(ehpat iattrs _ _)
+    [(ehpat iattrs _ _ _)
      iattrs]
     ))
 
@@ -319,10 +317,15 @@ A RepConstraint is one of
   (define attrss (map pattern-attrs ps))
   (hpat:or (union-iattrs attrss) ps attrss))
 
-(define (create-ehpat head repc)
+;; create-ehpat : HeadPattern RepConstraint Syntax -> EllipsisHeadPattern
+(define (create-ehpat head repc head-stx)
   (let* ([iattrs0 (pattern-attrs head)]
          [iattrs (repc-adjust-attrs iattrs0 repc)])
-    (ehpat iattrs head repc)))
+    (define nullable (hpat-nullable head))
+    (when (eq? nullable 'yes)
+      (when #f (wrong-syntax head-stx "nullable ellipsis-head pattern"))
+      (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" head-stx)))
+    (ehpat iattrs head repc (case nullable [(yes unknown) #t] [(no) #f]))))
 
 (define (repc-adjust-attrs iattrs repc)
   (cond [(rep:once? repc)

racket/collects/syntax/parse/private/rep.rkt

@@ -21,8 +21,6 @@
          "kws.rkt"
          "pattern-expander-prop.rkt")
 
-(define-logger syntax-parse)
-
 ;; Error reporting
 ;; All entry points should have explicit, mandatory #:context arg
 ;; (mandatory from outside, at least)
@@ -633,7 +631,8 @@
                 [attr-count (length iattrs)])
            (list (create-ehpat
                   (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
-                  (eh-alternative-repc alt))
+                  (eh-alternative-repc alt)
+                  #f)
                  (replace-eh-alternative-attrs
                   alt (iattrs->sattrs iattrs))))))]
     [(~or . _)
@@ -656,11 +655,7 @@
      (list (parse*-ehpat/bounds stx decls))]
     [_
      (let ([head (parse-head-pattern stx decls)])
-       ;; FIXME: if 'no, can omit null-eh-match check in parse.rkt
+       (list (list (create-ehpat head #f stx) stx)))]))
-       (when (eq? (hpat-nullable head) 'yes)
-         (when #f (wrong-syntax stx "nullable ellipsis-head pattern"))
-         (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" stx)))
-       (list (list (create-ehpat head #f) stx)))]))
 
 (define (replace-eh-alternative-attrs alt sattrs)
   (match alt
@@ -998,7 +993,7 @@
 (define (parse-pat:plus-dots stx head tail decls)
   (define headp (parse-head-pattern head decls))
   (define tailp (parse-single-pattern tail decls))
-  (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f)))
+  (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f) head))
   (pat:dots (list head/rep) tailp))
 
 (define (parse-pat:bind stx decls)
@@ -1118,7 +1113,7 @@
 (define (parse*-ehpat/optional stx decls)
   (define-values (head-stx head iattrs name too-many-msg defaults)
     (parse*-optional-pattern stx decls eh-optional-directive-table))
-  (list (create-ehpat head (make rep:optional name too-many-msg defaults))
+  (list (create-ehpat head (make rep:optional name too-many-msg defaults) head-stx)
         head-stx))
 
 ;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx)
@@ -1138,7 +1133,7 @@
              (options-select-value chunks '#:too-many #:default #'#f)]
             [name
              (options-select-value chunks '#:name #:default #'#f)])
-       (list (create-ehpat head (make rep:once name too-few-msg too-many-msg))
+       (list (create-ehpat head (make rep:once name too-few-msg too-many-msg) #'p)
              #'p))]))
 
 ;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx)
@@ -1171,7 +1166,8 @@
                (options-select-value chunks '#:name #:default #'#f)])
          (list (create-ehpat head
                              (make rep:bounds #'min #'max
-                                   name too-few-msg too-many-msg))
+                                   name too-few-msg too-many-msg)
+                             #'p)
                #'p)))]))
 
 ;; -----

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

@@ -11,7 +11,13 @@
          (struct-out eh-alternative)
          (struct-out den:lit)
          (struct-out den:datum-lit)
-         (struct-out den:delayed))
+         (struct-out den:delayed)
+         log-syntax-parse-error
+         log-syntax-parse-warning
+         log-syntax-parse-info
+         log-syntax-parse-debug)
+
+(define-logger syntax-parse)
 
 ;; == from rep-attr.rkt
 (define-struct attr (name depth syntax?) #:prefab)