From 52bfb32cd392bd624eb670b7130820bb02a86903 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 10 Jul 2016 00:21:10 -0400 Subject: [PATCH] syntax/parse: only check for empty match on unbounded EH patterns This change permits EH patterns like (~once ), 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 | 17 +++++++++ .../collects/syntax/parse/private/parse.rkt | 8 ++-- .../syntax/parse/private/rep-patterns.rkt | 38 +++++++++++++++---- 3 files changed, 52 insertions(+), 11 deletions(-) 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