syntax/parse: only check for empty match on unbounded EH patterns

This change permits EH patterns like (~once <nullable>), because the
match will happen at most once, so there is no danger of divergence.
Thanks to Alex Knauth for pointing out this special case.

Merge to release branch.

pkgs/racket-test/tests/stxparse/test.rkt

@@ -645,3 +645,20 @@
 (tok (1 2 3) (~datum (1 2 3)) 'ok)
 (tok (1 2 . 3) (~datum (1 2 . 3)) 'ok)
 (tok (1 . (2 3)) (~datum (1 . (2 3))) 'ok)
+
+;; nullable EH pattern raises error on match (rather than diverging) (7/2016)
+(tcerr "nullable"
+  (syntax-parse #'(1 2 3)
+    [((~seq) ... n:nat ...) 'ok])
+  #rx"nullable ellipsis-head pattern|ellipsis-head pattern matched an empty sequence")
+(tcerr "nullable (dynamic)"
+  (let ()
+    (define-splicing-syntax-class empty
+      (pattern (~seq)))
+    (syntax-parse #'(1 2 3)
+      [((~seq e:empty) ... n:nat ...) 'ok]))
+  #rx"ellipsis-head pattern matched an empty sequence")
+
+;; nullable but bounded EH pattern ok (thanks Alex Knauth) (7/2016)
+(tok (1 2 3) ((~once (~seq)) ... n:nat ...) 'ok)
+(tok (1 2 3) ((~once (~or (~seq a:id) (~seq))) ... x y z) 'ok)

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

@@ -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 nullable?) ...) tail pr es k)
+    [(parse:dots x cx (#s(ehpat head-attrs head head-repc check-null?) ...) tail pr es k)
      (let ()
        (define repcs (wash-list wash #'(head-repc ...)))
        (define rep-ids (for/list ([repc (in-list repcs)])
@@ -946,7 +946,7 @@ Conventions:
              (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...)
                (with ([fail-handler fh])
                  (try-or-pair/null-check do-pair/null? dx dcx loop-pr es
-                   (try (parse:EH dx dcx loop-pr head-attrs nullable? head-repc dx* dcx* loop-pr* 
+                   (try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr* 
                                   alt-map head-rep head es loop-k)
                         ...)
                    (cond [(< rel-rep (rep:min-number rel-repc))
@@ -974,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 nullable? repc x* cx* pr* alts rep head es k)
+    [(parse:EH x cx pr attrs check-null? repc x* cx* pr* alts rep head es k)
      (let ()
        (define/with-syntax k*
          (let* ([main-attrs (wash-iattrs #'attrs)]
@@ -988,7 +988,7 @@ Conventions:
            (with-syntax ([(id ...) ids]
                          [(alt-id ...) alt-ids])
              #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
-                 #,(if (syntax->datum #'nullable?)
+                 #,(if (syntax->datum #'check-null?)
                        #'(if (zero? (ps-difference pr pr*)) (error/null-eh-match) k)
                        #'k)))))
        (syntax-case #'repc ()

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

@@ -128,11 +128,11 @@ An EllipsisHeadPattern is
 A RepConstraint is one of
   (rep:once stx stx stx)
   (rep:optional stx stx (listof BindAction))
-  (rep:bounds nat/#f nat/#f stx stx stx)
+  (rep:bounds nat posint/+inf.0 stx stx stx)
   #f
 |#
 
-(define-struct ehpat (attrs head repc nullable?) #:prefab)
+(define-struct ehpat (attrs head repc check-null?) #: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)
@@ -322,10 +322,15 @@ A RepConstraint is one of
   (let* ([iattrs0 (pattern-attrs head)]
          [iattrs (repc-adjust-attrs iattrs0 repc)])
     (define nullable (hpat-nullable head))
-    (when (eq? nullable 'yes)
+    (define unbounded-iterations?
+      (cond [(rep:once? repc) #f]
+            [(rep:optional? repc) #f]
+            [(rep:bounds? repc) (eq? (rep:bounds-max repc) +inf.0)]
+            [else #t]))
+    (when (and (eq? nullable 'yes) unbounded-iterations?)
       (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]))))
+    (ehpat iattrs head repc (case nullable [(yes unknown) unbounded-iterations?] [(no) #f]))))
 
 (define (repc-adjust-attrs iattrs repc)
   (cond [(rep:once? repc)
@@ -461,6 +466,9 @@ A RepConstraint is one of
     [(no) b]
     [(unknown) (case b [(yes) 'yes] [(no unknown) 'unknown])]))
 
+(define (3andmap f xs) (foldl 3and 'yes (map f xs)))
+(define (3ormap f xs) (foldl 3or 'no (map f xs)))
+
 ;; lpat-nullable : ListPattern -> AbsNullable
 (define/memo (lpat-nullable lp)
   (match lp
@@ -468,15 +476,19 @@ A RepConstraint is one of
     [(pat:action ap lp) (lpat-nullable lp)]
     [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))]
     [(pat:pair '#t sp lp) 'no]
-    [(pat:dots ehp lp) (lpat-nullable lp)]))
+    [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))]
+    ;; For hpat:and, handle the following which are not ListPatterns
+    [(pat:and lps) (3andmap lpat-nullable lps)]
+    [(pat:any) #t]
+    [_ 'unknown]))
 
 ;; hpat-nullable : HeadPattern -> AbsNullable
 (define/memo (hpat-nullable hp)
   (match hp
     [(hpat:seq lp) (lpat-nullable lp)]
     [(hpat:action ap hp) (hpat-nullable hp)]
-    [(hpat:and hp sp) (hpat-nullable hp)]
-    [(hpat:or _attrs hps _attrss) (foldl 3or 'no (map hpat-nullable hps))]
+    [(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))]
+    [(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)]
     [(hpat:describe hp _ _ _) (hpat-nullable hp)]
     [(hpat:delimit hp) (hpat-nullable hp)]
     [(hpat:commit hp) (hpat-nullable hp)]
@@ -484,6 +496,18 @@ A RepConstraint is one of
     [(hpat:post hp) (hpat-nullable hp)]
     [_ 'unknown]))
 
+;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable
+(define (ehpat-nullable ehp)
+  (match ehp
+    [(ehpat _ hp repc _)
+     (3or (repc-nullable repc) (hpat-nullable hp))]))
+
+;; repc-nullable : RepConstraint -> AbsNullable
+(define (repc-nullable repc)
+  (cond [(rep:once? repc) 'no]
+        [(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no]
+        [else 'yes]))
+
 ;; ----
 
 ;; create-post-pattern : *Pattern -> *Pattern