diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 29e6c7398c..3204c368f9 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/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) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 9fa5a0d97e..1a658139c6 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/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 () diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 088dbf7d2e..8fee65366e 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/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