From add08c902dbb55546dfd695921eb037cfece93df Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 16 May 2016 12:46:19 -0400 Subject: [PATCH] syntax/parse: record nullability in ehpat Non-nullable ellipsis-head patterns can omit the null match check. --- .../collects/syntax/parse/private/parse.rkt | 26 +++++++++++-------- .../syntax/parse/private/rep-patterns.rkt | 19 ++++++++------ racket/collects/syntax/parse/private/rep.rkt | 20 ++++++-------- .../syntax/parse/private/residual-ct.rkt | 8 +++++- 4 files changed, 41 insertions(+), 32 deletions(-) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 35c38dc7a5..9fa5a0d97e 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/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? - (equal? (syntax->datum #'tail) '#s(pat:datum ()))]) + [do-pair/null? + ;; 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 (parse:EH dx dcx loop-pr head-attrs head-repc dx* dcx* loop-pr* + (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* 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)] ... - [diff (ps-difference pr pr*)]) - (if (zero? diff) (error/null-eh-match) k))))) + #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) + #,(if (syntax->datum #'nullable?) + #'(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 diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index dbe68503e8..088dbf7d2e 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -3,9 +3,7 @@ "rep-attrs.rkt" "kws.rkt" "minimatch.rkt" - (for-syntax racket/base - syntax/stx - racket/syntax)) + 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) diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index c39178b290..528f49be19 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/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 - (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)))])) + (list (list (create-ehpat head #f stx) 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)))])) ;; ----- diff --git a/racket/collects/syntax/parse/private/residual-ct.rkt b/racket/collects/syntax/parse/private/residual-ct.rkt index ae6bed829f..922007af0e 100644 --- a/racket/collects/syntax/parse/private/residual-ct.rkt +++ b/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)