suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: record nullability in ehpat

Browse Source 
Non-nullable ellipsis-head patterns can omit the null match check.
This commit is contained in:
Ryan Culpepper 2016-05-16 12:46:19 -04:00
parent 3da626d483
commit add08c902d
4 changed files with 41 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
racket/collects/syntax/parse/private/parse.rkt
View File

@ -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

19
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -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)

20
racket/collects/syntax/parse/private/rep.rkt
View File

@ -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)))]))
;; -----

8
racket/collects/syntax/parse/private/residual-ct.rkt
View File

@ -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)