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

syntax/parse: remove attrs from pattern structs, desugar hpat:optional

Browse Source
This commit is contained in:
Ryan Culpepper 2016-05-05 11:48:38 -04:00
parent 91a03eecb3
commit 158f087d8e
5 changed files with 409 additions and 523 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
racket/collects/syntax/parse/private/opt.rkt
View File

@ -118,7 +118,7 @@
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) ;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
(define (pattern->partitioner pat1) (define (pattern->partitioner pat1)
(match pat1 (match pat1
[(pat:pair attrs proper? head tail) [(pat:pair proper? head tail)
(values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?))) (values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?)))
(lambda (rows) (lambda (rows)
(when DEBUG-OPT-SUCCEED (when DEBUG-OPT-SUCCEED
@ -158,7 +158,7 @@
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern)) ;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
(define (unfold-and p onto) (define (unfold-and p onto)
(match p (match p
[(pat:and _as subpatterns) [(pat:and subpatterns)
;; pat:and is worth unfolding if first subpattern is not pat:action ;; pat:and is worth unfolding if first subpattern is not pat:action
;; if first subpattern is also pat:and, keep unfolding ;; if first subpattern is also pat:and, keep unfolding
(let* ([first-sub (car subpatterns)] (let* ([first-sub (car subpatterns)]
@ -175,54 +175,54 @@
;; - if p can succeed multiple times, then factoring changes success order ;; - if p can succeed multiple times, then factoring changes success order
;; - if p can cut, then factoring changes which choice points are discarded (too few) ;; - if p can cut, then factoring changes which choice points are discarded (too few)
(match p (match p
[(pat:any _as) #t] [(pat:any) #t]
[(pat:svar _as _n) #t] [(pat:svar _n) #t]
[(pat:var/p _as _n _p _argu _na _ac commit? _r) [(pat:var/p _n _p _argu _na _ac commit? _r)
;; commit? implies delimit-cut ;; commit? implies delimit-cut
commit?] commit?]
[(? pat:integrated?) #t] [(? pat:integrated?) #t]
[(pat:literal _as _lit _ip _lp) #t] [(pat:literal _lit _ip _lp) #t]
[(pat:datum _as _datum) #t] [(pat:datum _datum) #t]
[(pat:action _as _act _pat) #f] [(pat:action _act _pat) #f]
[(pat:head _as head tail) [(pat:head head tail)
(and (pattern-factorable? head) (and (pattern-factorable? head)
(pattern-factorable? tail))] (pattern-factorable? tail))]
[(pat:dots _as heads tail) [(pat:dots heads tail)
;; Conservative approximation for common case: one head pattern ;; Conservative approximation for common case: one head pattern
;; In general, check if heads don't overlap, don't overlap with tail. ;; In general, check if heads don't overlap, don't overlap with tail.
(and (= (length heads) 1) (and (= (length heads) 1)
(let ([head (car heads)]) (let ([head (car heads)])
(and (pattern-factorable? head))) (and (pattern-factorable? head)))
(equal? tail (create-pat:datum '())))] (equal? tail (pat:datum '())))]
[(pat:and _as patterns) [(pat:and patterns)
(andmap pattern-factorable? patterns)] (andmap pattern-factorable? patterns)]
[(pat:or _as patterns) #f] [(pat:or patterns) #f]
[(pat:not _as pattern) #f] ;; FIXME: ? [(pat:not pattern) #f] ;; FIXME: ?
[(pat:pair _as _p? head tail) [(pat:pair _p? head tail)
(and (pattern-factorable? head) (and (pattern-factorable? head)
(pattern-factorable? tail))] (pattern-factorable? tail))]
[(pat:vector _as pattern) [(pat:vector pattern)
(pattern-factorable? pattern)] (pattern-factorable? pattern)]
[(pat:box _as pattern) [(pat:box pattern)
(pattern-factorable? pattern)] (pattern-factorable? pattern)]
[(pat:pstruct _as key pattern) [(pat:pstruct key pattern)
(pattern-factorable? pattern)] (pattern-factorable? pattern)]
[(pat:describe _as pattern _desc _trans _role) [(pat:describe pattern _desc _trans _role)
(pattern-factorable? pattern)] (pattern-factorable? pattern)]
[(pat:delimit _as pattern) [(pat:delimit pattern)
(pattern-factorable? pattern)] (pattern-factorable? pattern)]
[(pat:commit _as pattern) #t] [(pat:commit pattern) #t]
[(? pat:reflect?) #f] [(? pat:reflect?) #f]
[(pat:post _as pattern) [(pat:post pattern)
(pattern-factorable? pattern)] (pattern-factorable? pattern)]
;; ---- ;; ----
[(hpat:var/p _as _name _parser _argu _na _ac commit? _role) [(hpat:var/p _name _parser _argu _na _ac commit? _role)
commit?] commit?]
[(hpat:seq _as inner) [(hpat:seq inner)
(pattern-factorable? inner)] (pattern-factorable? inner)]
[(hpat:commit _as inner) #t] [(hpat:commit inner) #t]
;; ---- ;; ----
[(ehpat _as head repc) [(ehpat head repc)
(and (equal? repc #f) (and (equal? repc #f)
(pattern-factorable? head))] (pattern-factorable? head))]
;; ---- ;; ----
@ -238,17 +238,17 @@
(define result (define result
(cond [(and (pat:any? a) (pat:any? b)) #t] (cond [(and (pat:any? a) (pat:any? b)) #t]
[(and (pat:svar? a) (pat:svar? b)) [(and (pat:svar? a) (pat:svar? b))
(equal-iattrs? (pat:svar-attrs a) (pat:svar-attrs b))] (bound-identifier=? (pat:svar-name a) (pat:svar-name b))]
[(and (pat:var/p? a) (pat:var/p? b)) [(and (pat:var/p? a) (pat:var/p? b))
(and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b)) (and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
(equal-iattrs? (pat:var/p-attrs a) (pat:var/p-attrs b)) (bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b))
(equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b))
(equal-argu? (pat:var/p-argu a) (pat:var/p-argu b)) (equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
(expr-equal? (pat:var/p-role a) (pat:var/p-role b)))] (expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
[(and (pat:integrated? a) (pat:integrated? b)) [(and (pat:integrated? a) (pat:integrated? b))
(and (free-identifier=? (pat:integrated-predicate a) (and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b))
(free-identifier=? (pat:integrated-predicate a)
(pat:integrated-predicate b)) (pat:integrated-predicate b))
(equal-iattrs? (pat:integrated-attrs a)
(pat:integrated-attrs b))
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))] (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
[(and (pat:literal? a) (pat:literal? b)) [(and (pat:literal? a) (pat:literal? b))
;; literals are hard to compare, so compare gensyms attached to ;; literals are hard to compare, so compare gensyms attached to
@ -295,7 +295,8 @@
;; --- ;; ---
[(and (hpat:var/p? a) (hpat:var/p? b)) [(and (hpat:var/p? a) (hpat:var/p? b))
(and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b)) (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
(equal-iattrs? (hpat:var/p-attrs a) (hpat:var/p-attrs b)) (bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
(equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b))
(equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b)) (equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
(expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))] (expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
[(and (hpat:seq? a) (hpat:seq? b)) [(and (hpat:seq? a) (hpat:seq? b))
@ -369,10 +370,17 @@
(identifier? b) (identifier? b)
(free-identifier=? a b)))) (free-identifier=? a b))))
(define (bound-id/f-equal? a b)
(or (and (eq? a #f)
(eq? b #f))
(and (identifier? a)
(identifier? b)
(bound-identifier=? a b))))
(define (make-and-pattern subs) (define (make-and-pattern subs)
(cond [(null? subs) (create-pat:any)] ;; shouldn't happen (cond [(null? subs) (pat:any)] ;; shouldn't happen
[(null? (cdr subs)) (car subs)] [(null? (cdr subs)) (car subs)]
[else (create-pat:and subs)])) [else (pat:and subs)]))
(define (*append a b) (if (null? b) a (append a b))) (define (*append a b) (if (null? b) a (append a b)))

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

@ -497,12 +497,12 @@ Conventions:
[rest-cx cx] [rest-cx cx]
[rest-pr pr]) [rest-pr pr])
k)] k)]
[#s(pat:any _attrs) [#s(pat:any)
#'k] #'k]
[#s(pat:svar _attrs name) [#s(pat:svar name)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)] k)]
[#s(pat:var/p _attrs name parser argu (nested-a ...) attr-count commit? role) [#s(pat:var/p name parser argu (nested-a ...) attr-count commit? role)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...) [(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
@ -530,7 +530,7 @@ Conventions:
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...)) (let-attributes* ((nested-a ...) (av ...))
k))))))] k))))))]
[#s(pat:reflect _attrs obj argu attr-decls name (nested-a ...)) [#s(pat:reflect obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
#'([#s(attr name 0 #t) (datum->syntax cx x cx)]) #'([#s(attr name 0 #t) (datum->syntax cx x cx)])
@ -544,7 +544,7 @@ Conventions:
(with ([fail-handler fh]) (with ([fail-handler fh])
k)))) k))))
argu))))] argu))))]
[#s(pat:datum attrs datum) [#s(pat:datum datum)
(with-syntax ([unwrap-x (with-syntax ([unwrap-x
(if (atomic-datum-stx? #'datum) (if (atomic-datum-stx? #'datum)
#'(if (syntax? x) (syntax-e x) x) #'(if (syntax? x) (syntax-e x) x)
@ -553,22 +553,22 @@ Conventions:
(if (equal? d (quote datum)) (if (equal? d (quote datum))
k k
(fail (failure pr (es-add-atom 'datum es))))))] (fail (failure pr (es-add-atom 'datum es))))))]
[#s(pat:literal attrs literal input-phase lit-phase) [#s(pat:literal literal input-phase lit-phase)
#`(if (and (identifier? x) #`(if (and (identifier? x)
(free-identifier=? x (quote-syntax literal) input-phase lit-phase)) (free-identifier=? x (quote-syntax literal) input-phase lit-phase))
k k
(fail (failure pr (es-add-literal (quote-syntax literal) es))))] (fail (failure pr (es-add-literal (quote-syntax literal) es))))]
[#s(pat:action attrs action subpattern) [#s(pat:action action subpattern)
#'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))]
[#s(pat:head attrs head tail) [#s(pat:head head tail)
#`(parse:H x cx rest-x rest-cx rest-pr head pr es #`(parse:H x cx rest-x rest-cx rest-pr head pr es
(parse:S rest-x rest-cx tail rest-pr es k))] (parse:S rest-x rest-cx tail rest-pr es k))]
[#s(pat:dots attrs head tail) [#s(pat:dots head tail)
#`(parse:dots x cx head tail pr es k)] #`(parse:dots x cx head tail pr es k)]
[#s(pat:and attrs subpatterns) [#s(pat:and subpatterns)
(for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))]) (for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))])
#`(parse:S x cx #,subpattern pr es #,k))] #`(parse:S x cx #,subpattern pr es #,k))]
[#s(pat:or (a ...) (subpattern ...)) [#s(pat:or (a ...) (subpattern ...) (subattrs ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success #`(let ([success
(lambda (fh id ...) (lambda (fh id ...)
@ -576,9 +576,9 @@ Conventions:
(with ([fail-handler fh]) (with ([fail-handler fh])
k)))]) k)))])
(try (parse:S x cx subpattern pr es (try (parse:S x cx subpattern pr es
(disjunct subpattern success () (id ...))) (disjunct subattrs success () (id ...)))
...)))] ...)))]
[#s(pat:not () subpattern) [#s(pat:not subpattern)
#`(let* ([fh0 fail-handler] #`(let* ([fh0 fail-handler]
[pr0 pr] [pr0 pr]
[es0 es] [es0 es]
@ -591,11 +591,9 @@ Conventions:
[cut-prompt fail-to-succeed]) ;; to be safe [cut-prompt fail-to-succeed]) ;; to be safe
(parse:S x cx subpattern pr es (parse:S x cx subpattern pr es
(fh0 (failure pr0 es0)))))] (fh0 (failure pr0 es0)))))]
[#s(pat:pair _attrs proper? head tail) [#s(pat:pair proper? head tail)
#`(let-values ([(datum cx) #`(let ([datum (if (syntax? x) (syntax-e x) x)]
(if (syntax? x) [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?!
(values (syntax-e x) x)
(values x cx))])
(if (pair? datum) (if (pair? datum)
(let ([hx (car datum)] (let ([hx (car datum)]
[hcx (car datum)] [hcx (car datum)]
@ -606,7 +604,7 @@ Conventions:
(parse:S tx cx tail tpr es k))) (parse:S tx cx tail tpr es k)))
(let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair (first-desc:S head) es) es)]) (let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair (first-desc:S head) es) es)])
(fail (failure pr es*)))))] (fail (failure pr es*)))))]
[#s(pat:vector _attrs subpattern) [#s(pat:vector subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)]) #`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (vector? datum) (if (vector? datum)
(let ([datum (vector->list datum)] (let ([datum (vector->list datum)]
@ -614,7 +612,7 @@ Conventions:
[pr* (ps-add-unvector pr)]) [pr* (ps-add-unvector pr)])
(parse:S datum vcx subpattern pr* es k)) (parse:S datum vcx subpattern pr* es k))
(fail (failure pr es))))] (fail (failure pr es))))]
[#s(pat:box _attrs subpattern) [#s(pat:box subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)]) #`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (box? datum) (if (box? datum)
(let ([datum (unbox datum)] (let ([datum (unbox datum)]
@ -622,7 +620,7 @@ Conventions:
[pr* (ps-add-unbox pr)]) [pr* (ps-add-unbox pr)])
(parse:S datum bcx subpattern pr* es k)) (parse:S datum bcx subpattern pr* es k))
(fail (failure pr es))))] (fail (failure pr es))))]
[#s(pat:pstruct _attrs key subpattern) [#s(pat:pstruct key subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)]) #`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (let ([xkey (prefab-struct-key datum)]) (if (let ([xkey (prefab-struct-key datum)])
(and xkey (equal? xkey 'key))) (and xkey (equal? xkey 'key)))
@ -631,15 +629,15 @@ Conventions:
[pr* (ps-add-unpstruct pr)]) [pr* (ps-add-unpstruct pr)])
(parse:S datum scx subpattern pr* es k)) (parse:S datum scx subpattern pr* es k))
(fail (failure pr es))))] (fail (failure pr es))))]
[#s(pat:describe attrs pattern description transparent? role) [#s(pat:describe pattern description transparent? role)
#`(let ([es* (es-add-thing pr description transparent? role es)] #`(let ([es* (es-add-thing pr description transparent? role es)]
[pr* (if 'transparent? pr (ps-add-opaque pr))]) [pr* (if 'transparent? pr (ps-add-opaque pr))])
(parse:S x cx pattern pr* es* k))] (parse:S x cx pattern pr* es* k))]
[#s(pat:delimit attrs pattern) [#s(pat:delimit pattern)
#`(let ([cp0 cut-prompt]) #`(let ([cp0 cut-prompt])
(with ([cut-prompt fail-handler]) (with ([cut-prompt fail-handler])
(parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))] (parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))]
[#s(pat:commit attrs pattern) [#s(pat:commit pattern)
#`(let ([fh0 fail-handler] #`(let ([fh0 fail-handler]
[cp0 cut-prompt]) [cp0 cut-prompt])
(with ([cut-prompt fh0]) (with ([cut-prompt fh0])
@ -647,10 +645,10 @@ Conventions:
(with ([cut-prompt cp0] (with ([cut-prompt cp0]
[fail-handler fh0]) [fail-handler fh0])
k))))] k))))]
[#s(pat:post attrs pattern) [#s(pat:post pattern)
#`(let ([pr* (ps-add-post pr)]) #`(let ([pr* (ps-add-post pr)])
(parse:S x cx pattern pr* es k))] (parse:S x cx pattern pr* es k))]
[#s(pat:integrated _attrs name predicate description role) [#s(pat:integrated name predicate description role)
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
#'([#s(attr name 0 #t) x*]) #'([#s(attr name 0 #t) x*])
@ -666,49 +664,37 @@ Conventions:
(syntax-case stx () (syntax-case stx ()
[(fds p) [(fds p)
(syntax-case #'p () (syntax-case #'p ()
[#s(pat:any _as) [#s(pat:any)
#''(any)] #''(any)]
[#s(pat:svar _as name) [#s(pat:svar name)
#''(any)] #''(any)]
[#s(pat:var/p _ ...) [#s(pat:var/p _ ...)
#'#f] ;; FIXME: need access to (constant) description as field #'#f] ;; FIXME: need access to (constant) description as field
[#s(pat:datum _as d) [#s(pat:datum d)
#''(datum d)] #''(datum d)]
[#s(pat:literal _as id _ip _lp) [#s(pat:literal id _ip _lp)
#''(literal id)] #''(literal id)]
[#s(pat:describe _as _p description _t? _role) [#s(pat:describe _p description _t? _role)
#'description] ;; FIXME??? only constants? #'description] ;; FIXME??? only constants?
[#s(pat:delimit _a pattern) [#s(pat:delimit pattern)
#'(first-desc:S pattern)] #'(first-desc:S pattern)]
[#s(pat:commit _a pattern) [#s(pat:commit pattern)
#'(first-desc:S pattern)] #'(first-desc:S pattern)]
[#s(pat:post _a pattern) [#s(pat:post pattern)
#'(first-desc:S pattern)] #'(first-desc:S pattern)]
[#s(pat:integrated _as _name _pred description _role) [#s(pat:integrated _name _pred description _role)
#''description] #''description]
[_ #'#f])])) [_ #'#f])]))
;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans] ;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans]
(define-syntax (disjunct stx) (define-syntax (disjunct stx)
(syntax-case stx () (syntax-case stx ()
[(disjunct pattern success (pre ...) (id ...)) [(disjunct (#s(attr sub-id _ _) ...) success (pre ...) (id ...))
(with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))]) (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) #`(let ([alt-sub-id (attribute sub-id)] ...)
#`(let ([alt-sub-id (attribute sub-id)] ...) (let ([id #f] ...)
(let ([id #f] ...) (let ([sub-id alt-sub-id] ...)
(let ([sub-id alt-sub-id] ...) (success fail-handler pre ... id ...)))))]))
(success fail-handler pre ... id ...))))))]))
;; (disjunct/sides clauses success (pre:expr ...) (id:id ...)) : expr[Ans]
(define-syntax (disjunct/sides stx)
(syntax-case stx ()
[(disjunct/sides clauses success (pre ...) (id ...))
(with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses])
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success fail-handler pre ... id ...))))))]))
;; (parse:A x cx A-pattern pr es k) : expr[Ans] ;; (parse:A x cx A-pattern pr es k) : expr[Ans]
;; In k: attrs(A-pattern) are bound. ;; In k: attrs(A-pattern) are bound.
@ -716,27 +702,28 @@ Conventions:
(syntax-case stx () (syntax-case stx ()
[(parse:A x cx pattern0 pr es k) [(parse:A x cx pattern0 pr es k)
(syntax-case #'pattern0 () (syntax-case #'pattern0 ()
[#s(action:cut _) [#s(action:and (action ...))
(for/fold ([k #'k]) ([action (in-list (reverse (syntax->list #'(action ...))))])
#`(parse:A x cx #,action pr es #,k))]
[#s(action:cut)
#'(with ([fail-handler cut-prompt]) k)] #'(with ([fail-handler cut-prompt]) k)]
[#s(action:bind _ (side ...)) [#s(action:bind (side ...))
#'(bind/sides (side ...) k)] #'(bind/sides (side ...) k)]
[#s(action:fail _ condition message) [#s(action:fail condition message)
#`(let ([c (wrap-user-code condition)]) #`(let ([c (wrap-user-code condition)])
(if c (if c
(let ([pr* (if (syntax? c) (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)]
(ps-add-stx pr c)
pr)]
[es* (es-add-message message es)]) [es* (es-add-message message es)])
(fail (failure pr* es*))) (fail (failure pr* es*)))
k))] k))]
[#s(action:parse _ pattern expr) [#s(action:parse pattern expr)
#`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))] #`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))]
[cy y] [cy y]
[pr* (ps-add-stx pr y)]) [pr* (ps-add-stx pr y)])
(parse:S y cy pattern pr* es k))] (parse:S y cy pattern pr* es k))]
[#s(action:do _ (stmt ...)) [#s(action:do (stmt ...))
#'(let () (no-shadow stmt) ... (#%expression k))] #'(let () (no-shadow stmt) ... (#%expression k))]
[#s(action:post _ pattern group index) [#s(action:post pattern group index)
#'(let ([pr* (ps-add-post pr 'group 'index)]) #'(let ([pr* (ps-add-post pr 'group 'index)])
(parse:A x cx pattern pr* es k))])])) (parse:A x cx pattern pr* es k))])]))
@ -757,20 +744,20 @@ Conventions:
;; to rest-var. ;; to rest-var.
(define (convert-list-pattern pattern end-pattern) (define (convert-list-pattern pattern end-pattern)
(syntax-case pattern () (syntax-case pattern ()
[#s(pat:datum () ()) [#s(pat:datum ())
end-pattern] end-pattern]
[#s(pat:action attrs action tail) [#s(pat:action action tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:action attrs action tail))] #'#s(pat:action action tail))]
[#s(pat:head attrs head tail) [#s(pat:head head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:head attrs head tail))] #'#s(pat:head head tail))]
[#s(pat:dots attrs head tail) [#s(pat:dots head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:dots attrs head tail))] #'#s(pat:dots head tail))]
[#s(pat:pair attrs proper? head-part tail-part) [#s(pat:pair proper? head-part tail-part)
(with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)])
#'#s(pat:pair attrs proper? head-part tail-part))]))) #'#s(pat:pair proper? head-part tail-part))])))
;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k) ;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k)
;; In k: rest, rest-pr, attrs(H-pattern) are bound. ;; In k: rest, rest-pr, attrs(H-pattern) are bound.
@ -778,13 +765,13 @@ Conventions:
(syntax-case stx () (syntax-case stx ()
[(parse:H x cx rest-x rest-cx rest-pr head pr es k) [(parse:H x cx rest-x rest-cx rest-pr head pr es k)
(syntax-case #'head () (syntax-case #'head ()
[#s(hpat:describe _ pattern description transparent? role) [#s(hpat:describe pattern description transparent? role)
#`(let ([es* (es-add-thing pr description transparent? role es)] #`(let ([es* (es-add-thing pr description transparent? role es)]
[pr* (if 'transparent? pr (ps-add-opaque pr))]) [pr* (if 'transparent? pr (ps-add-opaque pr))])
(parse:H x cx rest-x rest-cx rest-pr pattern pr* es* (parse:H x cx rest-x rest-cx rest-pr pattern pr* es*
(let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
k)))] k)))]
[#s(hpat:var/p _attrs name parser argu (nested-a ...) attr-count commit? role) [#s(hpat:var/p name parser argu (nested-a ...) attr-count commit? role)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...) [(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
@ -814,7 +801,7 @@ Conventions:
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...)) (let-attributes* ((nested-a ...) (av ...))
k))))))] k))))))]
[#s(hpat:reflect _attrs obj argu attr-decls name (nested-a ...)) [#s(hpat:reflect obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
#'([#s(attr name 0 #t) #'([#s(attr name 0 #t)
@ -829,12 +816,12 @@ Conventions:
(with ([fail-handler fh]) (with ([fail-handler fh])
k)))) k))))
argu))))] argu))))]
[#s(hpat:and (a ...) head single) [#s(hpat:and head single)
#`(let ([cx0 cx]) #`(let ([cx0 cx])
(parse:H x cx rest-x rest-cx rest-pr head pr es (parse:H x cx rest-x rest-cx rest-pr head pr es
(let ([lst (stx-list-take x (ps-difference pr rest-pr))]) (let ([lst (stx-list-take x (ps-difference pr rest-pr))])
(parse:S lst cx0 single pr es k))))] (parse:S lst cx0 single pr es k))))]
[#s(hpat:or (a ...) (subpattern ...)) [#s(hpat:or (a ...) (subpattern ...) (subattrs ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success #`(let ([success
(lambda (fh rest-x rest-cx rest-pr id ...) (lambda (fh rest-x rest-cx rest-pr id ...)
@ -842,39 +829,22 @@ Conventions:
(with ([fail-handler fh]) (with ([fail-handler fh])
k)))]) k)))])
(try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(disjunct subpattern success (disjunct subattrs success (rest-x rest-cx rest-pr) (id ...)))
(rest-x rest-cx rest-pr) (id ...)))
...)))] ...)))]
[#s(hpat:seq attrs pattern) [#s(hpat:seq pattern)
(with-syntax ([pattern (with-syntax ([pattern
(convert-list-pattern (convert-list-pattern
#'pattern #'pattern
#'#s(internal-rest-pattern rest-x rest-cx rest-pr))]) #'#s(internal-rest-pattern rest-x rest-cx rest-pr))])
#'(parse:S x cx pattern pr es k))] #'(parse:S x cx pattern pr es k))]
[#s(hpat:action attrs action subpattern) [#s(hpat:action action subpattern)
#'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))] #'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))]
[#s(hpat:optional (a ...) pattern defaults) [#s(hpat:delimit pattern)
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh])
k)))])
(try (parse:H x cx rest-x rest-cx rest-pr pattern pr es
(success fail-handler rest-x rest-cx rest-pr (attribute id) ...))
(let ([rest-x x]
[rest-cx cx]
[rest-pr pr])
(bind/sides defaults
(disjunct/sides defaults success
(rest-x rest-cx rest-pr)
(id ...)))))))]
[#s(hpat:delimit _attrs pattern)
#'(let ([cp0 cut-prompt]) #'(let ([cp0 cut-prompt])
(with ([cut-prompt fail-handler]) (with ([cut-prompt fail-handler])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es (parse:H x cx rest-x rest-cx rest-pr pattern pr es
(with ([cut-prompt cp0]) k))))] (with ([cut-prompt cp0]) k))))]
[#s(hpat:commit attrs pattern) [#s(hpat:commit pattern)
#`(let ([fh0 fail-handler] #`(let ([fh0 fail-handler]
[cp0 cut-prompt]) [cp0 cut-prompt])
(with ([cut-prompt fh0]) (with ([cut-prompt fh0])
@ -882,15 +852,15 @@ Conventions:
(with ([cut-prompt cp0] (with ([cut-prompt cp0]
[fail-handler fh0]) [fail-handler fh0])
k))))] k))))]
[#s(hpat:post _ pattern) [#s(hpat:post pattern)
#'(let ([pr (ps-add-post pr)]) #'(let ([pr (ps-add-post pr)])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es k))] (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
[#s(hpat:peek _ pattern) [#s(hpat:peek pattern)
#`(let ([saved-x x] [saved-cx cx] [saved-pr pr]) #`(let ([saved-x x] [saved-cx cx] [saved-pr pr])
(parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es
(let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr]) (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr])
k)))] k)))]
[#s(hpat:peek-not () subpattern) [#s(hpat:peek-not subpattern)
#`(let* ([fh0 fail-handler] #`(let* ([fh0 fail-handler]
[pr0 pr] [pr0 pr]
[es0 es] [es0 es]
@ -908,11 +878,10 @@ Conventions:
(parse:H x cx rest-x rest-cx rest-pr subpattern pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(fh0 (failure pr0 es0)))))] (fh0 (failure pr0 es0)))))]
[_ [_
(with-syntax ([attrs (pattern-attrs (wash #'head))]) #'(parse:S x cx
#'(parse:S x cx ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) #s(pat:pair #t head #s(internal-rest-pattern rest-x rest-cx rest-pr))
#s(pat:pair attrs #t head #s(internal-rest-pattern rest-x rest-cx rest-pr)) pr es k)])]))
pr es k))])]))
;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] ;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans]
;; In k: attrs(EH-pattern, S-pattern) are bound. ;; In k: attrs(EH-pattern, S-pattern) are bound.
@ -920,17 +889,15 @@ Conventions:
(syntax-case stx () (syntax-case stx ()
;; == Specialized cases ;; == Specialized cases
;; -- (x ... . ()) ;; -- (x ... . ())
[(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar _attrs name) #f)) [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f))
#s(pat:datum () ()) pr es k) #s(pat:datum ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)])
(case status (case status
((ok) (let-attributes ([attr0 result]) k)) ((ok) (let-attributes ([attr0 result]) k))
(else (fail result))))] (else (fail result))))]
;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
[(parse:dots x cx (#s(ehpat (attr0) [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f))
#s(pat:integrated _attrs _name pred? desc role) #s(pat:datum ()) pr es k)
#f))
#s(pat:datum () ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)]) #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)])
(case status (case status
((ok) (let-attributes ([attr0 result]) k)) ((ok) (let-attributes ([attr0 result]) k))
@ -974,8 +941,8 @@ Conventions:
(define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...) (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...)
(with ([fail-handler fh]) (with ([fail-handler fh])
(try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es (try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es
(try (parse:EH dx dcx loop-pr head-repc dx* dcx* loop-pr* alt-map head-rep (try (parse:EH dx dcx loop-pr head-attrs head-repc dx* dcx* loop-pr*
head es loop-k) alt-map head-rep head es loop-k)
...) ...)
(cond [(< rel-rep (rep:min-number rel-repc)) (cond [(< rel-rep (rep:min-number rel-repc))
(let ([es (expectation-of-reps/too-few es rel-rep rel-repc)]) (let ([es (expectation-of-reps/too-few es rel-rep rel-repc)])
@ -1002,10 +969,10 @@ Conventions:
;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed. ;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed.
(define-syntax (parse:EH stx) (define-syntax (parse:EH stx)
(syntax-case stx () (syntax-case stx ()
[(parse:EH x cx pr repc x* cx* pr* alts rep head es k) [(parse:EH x cx pr attrs repc x* cx* pr* alts rep head es k)
(let () (let ()
(define/with-syntax k* (define/with-syntax k*
(let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] (let* ([main-attrs (wash-iattrs #'attrs)]
[ids (map attr-name main-attrs)] [ids (map attr-name main-attrs)]
[alt-ids [alt-ids
(let ([table (make-bound-id-table)]) (let ([table (make-bound-id-table)])
@ -1014,8 +981,7 @@ Conventions:
(bound-id-table-set! table (car entry) (cdr entry)))) (bound-id-table-set! table (car entry) (cdr entry))))
(for/list ([id (in-list ids)]) (bound-id-table-ref table id)))]) (for/list ([id (in-list ids)]) (bound-id-table-ref table id)))])
(with-syntax ([(id ...) ids] (with-syntax ([(id ...) ids]
[(alt-id ...) alt-ids] [(alt-id ...) alt-ids])
[(alt-a ...) (map rename-attr main-attrs alt-ids)])
#`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
k)))) k))))
(syntax-case #'repc () (syntax-case #'repc ()

6
racket/collects/syntax/parse/private/rep-attrs.rkt
View File

@ -48,9 +48,6 @@ of signatures easier for reified syntax-classes.
[reorder-iattrs [reorder-iattrs
(-> (listof sattr?) (listof iattr?) (-> (listof sattr?) (listof iattr?)
(listof iattr?))] (listof iattr?))]
[rename-attr
(-> iattr? identifier?
iattr?)]
;; SAttr operations ;; SAttr operations
[iattr->sattr [iattr->sattr
@ -136,9 +133,6 @@ of signatures easier for reified syntax-classes.
#:key (lambda (a) (symbol->string (attr-name a))) #:key (lambda (a) (symbol->string (attr-name a)))
#:cache-keys? #t)) #:cache-keys? #t))
(define (rename-attr a name)
(make attr name (attr-depth a) (attr-syntax? a)))
;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr) ;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr)
;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort? ;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort?
(define (intersect-sattrss attrss) (define (intersect-sattrss attrss)

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

@ -2,7 +2,7 @@
(require syntax/parse/private/residual-ct ;; keep abs. path (require syntax/parse/private/residual-ct ;; keep abs. path
"rep-attrs.rkt" "rep-attrs.rkt"
"kws.rkt" "kws.rkt"
"make.rkt" "minimatch.rkt"
(for-syntax racket/base (for-syntax racket/base
syntax/stx syntax/stx
racket/syntax)) racket/syntax))
@ -12,118 +12,107 @@
Uses Arguments from kws.rkt Uses Arguments from kws.rkt
|# |#
#|
A Base is (listof IAttr)
If P = (make-pattern Attrs ...) and A is in Attrs,
the depth of A is with respect to P,
not with respect to the entire enclosing pattern.
|#
#| #|
A SinglePattern is one of A SinglePattern is one of
(pat:any Base) (pat:any)
(pat:svar Base id) -- "simple" var, no stxclass (pat:svar id) -- "simple" var, no stxclass
(pat:var/p Base id id Arguments (Listof IAttr) nat/#f bool stx) -- var with parser (pat:var/p id id Arguments (Listof IAttr) nat/#f bool stx) -- var with parser
(pat:literal Base identifier ct-phase ct-phase) (pat:literal identifier ct-phase ct-phase)
(pat:datum Base datum) (pat:datum datum)
(pat:action Base ActionPattern SinglePattern) (pat:action ActionPattern SinglePattern)
(pat:head Base HeadPattern SinglePattern) (pat:head HeadPattern SinglePattern)
(pat:dots Base (listof EllipsisHeadPattern) SinglePattern) (pat:dots (listof EllipsisHeadPattern) SinglePattern)
(pat:and Base (listof SinglePattern)) (pat:and (listof SinglePattern))
(pat:or Base (listof SinglePattern)) (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
(pat:not Base SinglePattern) (pat:not SinglePattern)
(pat:pair Base boolean SinglePattern SinglePattern) (pat:pair boolean SinglePattern SinglePattern)
(pat:vector Base SinglePattern) (pat:vector SinglePattern)
(pat:box Base SinglePattern) (pat:box SinglePattern)
(pat:pstruct Base key SinglePattern) (pat:pstruct key SinglePattern)
(pat:describe Base SinglePattern stx boolean stx) (pat:describe SinglePattern stx boolean stx)
(pat:delimit Base SinglePattern) (pat:delimit SinglePattern)
(pat:commit Base SinglePattern) (pat:commit SinglePattern)
(pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) (pat:reflect stx Arguments (listof SAttr) id (listof IAttr))
(pat:post Base SinglePattern) (pat:post SinglePattern)
(pat:integrated Base id/#f id string stx) (pat:integrated id/#f id string stx)
A ListPattern is a subtype of SinglePattern; one of A ListPattern is a subtype of SinglePattern; one of
(pat:datum Base '()) (pat:datum '())
(pat:action Base ActionPattern ListPattern) (pat:action ActionPattern ListPattern)
(pat:head Base HeadPattern ListPattern) (pat:head HeadPattern ListPattern)
(pat:pair Base #t SinglePattern ListPattern) (pat:pair #t SinglePattern ListPattern)
(pat:dots Base EllipsisHeadPattern SinglePattern) (pat:dots EllipsisHeadPattern SinglePattern)
|# |#
(define-struct pat:any (attrs) #:prefab) (define-struct pat:any () #:prefab)
(define-struct pat:svar (attrs name) #:prefab) (define-struct pat:svar (name) #:prefab)
(define-struct pat:var/p (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) (define-struct pat:var/p (name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab) (define-struct pat:literal (id input-phase lit-phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab) (define-struct pat:datum (datum) #:prefab)
(define-struct pat:action (attrs action inner) #:prefab) (define-struct pat:action (action inner) #:prefab)
(define-struct pat:head (attrs head tail) #:prefab) (define-struct pat:head (head tail) #:prefab)
(define-struct pat:dots (attrs heads tail) #:prefab) (define-struct pat:dots (heads tail) #:prefab)
(define-struct pat:and (attrs patterns) #:prefab) (define-struct pat:and (patterns) #:prefab)
(define-struct pat:or (attrs patterns) #:prefab) (define-struct pat:or (attrs patterns attrss) #:prefab)
(define-struct pat:not (attrs pattern) #:prefab) (define-struct pat:not (pattern) #:prefab)
(define-struct pat:pair (attrs proper? head tail) #:prefab) (define-struct pat:pair (proper? head tail) #:prefab)
(define-struct pat:vector (attrs pattern) #:prefab) (define-struct pat:vector (pattern) #:prefab)
(define-struct pat:box (attrs pattern) #:prefab) (define-struct pat:box (pattern) #:prefab)
(define-struct pat:pstruct (attrs key pattern) #:prefab) (define-struct pat:pstruct (key pattern) #:prefab)
(define-struct pat:describe (attrs pattern description transparent? role) #:prefab) (define-struct pat:describe (pattern description transparent? role) #:prefab)
(define-struct pat:delimit (attrs pattern) #:prefab) (define-struct pat:delimit (pattern) #:prefab)
(define-struct pat:commit (attrs pattern) #:prefab) (define-struct pat:commit (pattern) #:prefab)
(define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) (define-struct pat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
(define-struct pat:post (attrs pattern) #:prefab) (define-struct pat:post (pattern) #:prefab)
(define-struct pat:integrated (attrs name predicate description role) #:prefab) (define-struct pat:integrated (name predicate description role) #:prefab)
#| #|
A ActionPattern is one of A ActionPattern is one of
(action:cut Base) (action:cut)
(action:fail Base stx stx) (action:fail stx stx)
(action:bind Base (listof clause:attr)) (action:bind (listof clause:attr))
* (action:and Base (listof ActionPattern)) (action:and (listof ActionPattern))
(action:parse Base SinglePattern stx) (action:parse SinglePattern stx)
(action:do Base (listof stx)) (action:do (listof stx))
(action:post Base ActionPattern Quotable Nat) (action:post ActionPattern Quotable Nat)
action:and is desugared below in create-* procedures
|# |#
(define-struct action:cut (attrs) #:prefab) (define-struct action:cut () #:prefab)
(define-struct action:fail (attrs when message) #:prefab) (define-struct action:fail (when message) #:prefab)
(define-struct action:bind (attrs clauses) #:prefab) (define-struct action:bind (clauses) #:prefab)
(define-struct action:and (attrs patterns) #:prefab) (define-struct action:and (patterns) #:prefab)
(define-struct action:parse (attrs pattern expr) #:prefab) (define-struct action:parse (pattern expr) #:prefab)
(define-struct action:do (attrs stmts) #:prefab) (define-struct action:do (stmts) #:prefab)
(define-struct action:post (attrs pattern group index) #:prefab) (define-struct action:post (pattern group index) #:prefab)
#| #|
A HeadPattern is one of A HeadPattern is one of
(hpat:var/p Base id id Arguments (listof IAttr) nat/#f bool stx) (hpat:var/p id id Arguments (listof IAttr) nat/#f bool stx)
(hpat:seq Base ListPattern) (hpat:seq ListPattern)
(hpat:action Base ActionPattern HeadPattern) (hpat:action ActionPattern HeadPattern)
(hpat:and Base HeadPattern SinglePattern) (hpat:and HeadPattern SinglePattern)
(hpat:or Base (listof HeadPattern)) (hpat:or (listof IAttr) (listof HeadPattern) (listof (listof IAttr)))
(hpat:optional Base HeadPattern (listof clause:attr)) (hpat:describe HeadPattern stx/#f boolean stx)
(hpat:describe Base HeadPattern stx/#f boolean stx) (hpat:delimit HeadPattern)
(hpat:delimit Base HeadPattern) (hpat:commit HeadPattern)
(hpat:commit Base HeadPattern) (hpat:reflect stx Arguments (listof SAttr) id (listof IAttr))
(hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) (hpat:post HeadPattern)
(hpat:post Base HeadPattern) (hpat:peek HeadPattern)
(hpat:peek Base HeadPattern) (hpat:peek-not HeadPattern)
(hpat:peek-not Base HeadPattern)
|# |#
(define-struct hpat:var/p (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) (define-struct hpat:var/p (name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab) (define-struct hpat:seq (inner) #:prefab)
(define-struct hpat:action (attrs action inner) #:prefab) (define-struct hpat:action (action inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab) (define-struct hpat:and (head single) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab) (define-struct hpat:or (attrs patterns attrss) #:prefab)
(define-struct hpat:optional (attrs inner defaults) #:prefab) (define-struct hpat:describe (pattern description transparent? role) #:prefab)
(define-struct hpat:describe (attrs pattern description transparent? role) #:prefab) (define-struct hpat:delimit (pattern) #:prefab)
(define-struct hpat:delimit (attrs pattern) #:prefab) (define-struct hpat:commit (pattern) #:prefab)
(define-struct hpat:commit (attrs pattern) #:prefab) (define-struct hpat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
(define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) (define-struct hpat:post (pattern) #:prefab)
(define-struct hpat:post (attrs pattern) #:prefab) (define-struct hpat:peek (pattern) #:prefab)
(define-struct hpat:peek (attrs pattern) #:prefab) (define-struct hpat:peek-not (pattern) #:prefab)
(define-struct hpat:peek-not (attrs pattern) #:prefab)
#| #|
An EllipsisHeadPattern is An EllipsisHeadPattern is
@ -192,7 +181,6 @@ A SideClause is one of
(hpat:action? x) (hpat:action? x)
(hpat:and? x) (hpat:and? x)
(hpat:or? x) (hpat:or? x)
(hpat:optional? x)
(hpat:describe? x) (hpat:describe? x)
(hpat:delimit? x) (hpat:delimit? x)
(hpat:commit? x) (hpat:commit? x)
@ -210,186 +198,121 @@ A SideClause is one of
(or (single-pattern? x) (or (single-pattern? x)
(head-pattern? x))) (head-pattern? x)))
(define pattern-attrs ;; check-pattern : *Pattern -> *Pattern
(let () ;; Does attr computation to catch errors, but returns same pattern.
(define-syntax (mk-get-attrs stx) (define (check-pattern p)
(syntax-case stx () (void (pattern-attrs p))
[(_ struct ...) p)
(with-syntax
([([pred accessor] ...) ;; pattern-attrs-table : Hasheq[*Pattern => (Listof IAttr)]
(for/list ([s (in-list (stx->list #'(struct ...)))]) (define pattern-attrs-table (make-weak-hasheq))
(list (format-id s "~a?" (syntax-e s))
(format-id s "~a-attrs" (syntax-e s))))]) ;; pattern-attrs : *Pattern -> (Listof IAttr)
#'(lambda (x) (define (pattern-attrs p)
(cond [(pred x) (accessor x)] ... (hash-ref! pattern-attrs-table p (lambda () (pattern-attrs* p))))
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
(mk-get-attrs pat:any pat:svar pat:var/p pat:datum pat:literal pat:action pat:head (define (pattern-attrs* p)
pat:dots pat:and pat:or pat:not pat:describe (match p
pat:pair pat:vector pat:box pat:pstruct ;; -- S patterns
pat:delimit pat:commit pat:reflect pat:post pat:integrated [(pat:any)
action:cut action:bind action:fail action:and action:parse null]
action:do action:post [(pat:svar name)
hpat:var/p hpat:seq hpat:action hpat:and hpat:or hpat:describe (list (attr name 0 #t))]
hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post [(pat:var/p name _ _ nested-attrs _ _ _)
hpat:peek hpat:peek-not (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
ehpat))) [(pat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:datum _)
null]
[(pat:literal _ _ _)
null]
[(pat:action a sp)
(append-iattrs (map pattern-attrs (list a sp)))]
[(pat:head headp tailp)
(append-iattrs (map pattern-attrs (list headp tailp)))]
[(pat:pair _proper? headp tailp)
(append-iattrs (map pattern-attrs (list headp tailp)))]
[(pat:vector sp)
(pattern-attrs sp)]
[(pat:box sp)
(pattern-attrs sp)]
[(pat:pstruct key sp)
(pattern-attrs sp)]
[(pat:describe sp _ _ _)
(pattern-attrs sp)]
[(pat:and ps)
(append-iattrs (map pattern-attrs ps))]
[(pat:or _ ps _)
(union-iattrs (map pattern-attrs ps))]
[(pat:not _)
null]
[(pat:dots headps tailp)
(append-iattrs (map pattern-attrs (append headps (list tailp))))]
[(pat:delimit sp)
(pattern-attrs sp)]
[(pat:commit sp)
(pattern-attrs sp)]
[(pat:post sp)
(pattern-attrs sp)]
[(pat:integrated name _ _ _)
(if name (list (attr name 0 #t)) null)]
;; -- A patterns
[(action:cut)
null]
[(action:fail _ _)
null]
[(action:bind clauses)
(map clause:attr-attr clauses)]
[(action:and ps)
(append-iattrs (map pattern-attrs ps))]
[(action:parse sp _)
(pattern-attrs sp)]
[(action:do _)
null]
[(action:post sp _ _)
(pattern-attrs sp)]
;; -- H patterns
[(hpat:var/p name _ _ nested-attrs _ _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:seq lp)
(pattern-attrs lp)]
[(hpat:action a hp)
(append-iattrs (map pattern-attrs (list a hp)))]
[(hpat:describe hp _ _ _)
(pattern-attrs hp)]
[(hpat:and hp sp)
(append-iattrs (map pattern-attrs (list hp sp)))]
[(hpat:or _ ps _)
(union-iattrs (map pattern-attrs ps))]
[(hpat:delimit hp)
(pattern-attrs hp)]
[(hpat:commit hp)
(pattern-attrs hp)]
[(hpat:post hp)
(pattern-attrs hp)]
[(hpat:peek hp)
(pattern-attrs hp)]
[(hpat:peek-not hp)
null]
;; EH patterns
[(ehpat iattrs _ _)
iattrs]
))
;; ---- ;; ----
;; Helpers to handle attribute calculations (define (create-pat:or ps)
;; Too complicated for a few pattern forms; those are handled in rep.rkt (define attrss (map pattern-attrs ps))
(pat:or (union-iattrs attrss) ps attrss))
(define (create-pat:any) (define (create-hpat:or ps)
(make pat:any null)) (define attrss (map pattern-attrs ps))
(hpat:or (union-iattrs attrss) ps attrss))
(define (create-pat:svar name)
(let ([attrs (list (make attr name 0 #t))])
(make pat:svar attrs name)))
(define (create-pat:var/p name parser argu nested-attrs attr-count commit? role)
(let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var/p attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-pat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:reflect attrs obj argu attr-decls name nested-attrs)))
(define (create-pat:datum datum)
(make pat:datum null datum))
(define (create-pat:literal literal input-phase lit-phase)
(make pat:literal null literal input-phase lit-phase))
(define (create-pat:action g sp)
(cond [(action:and? g)
(for/fold ([sp sp]) ([g (in-list (reverse (action:and-patterns g)))])
(create-pat:action g sp))]
[else
(let ([attrs (append-iattrs (map pattern-attrs (list g sp)))])
(make pat:action attrs g sp))]))
(define (create-pat:head headp tailp)
(let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))])
(make pat:head attrs headp tailp)))
(define (create-pat:pair headp tailp)
(let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))]
[proper? (proper-list-pattern? tailp #t)])
(make pat:pair attrs proper? headp tailp)))
(define (create-pat:vector pattern)
(make pat:vector (pattern-attrs pattern) pattern))
(define (create-pat:box pattern)
(make pat:box (pattern-attrs pattern) pattern))
(define (create-pat:pstruct key pattern)
(make pat:pstruct (pattern-attrs pattern) key pattern))
(define (create-pat:describe p description transparent? role)
(make pat:describe (pattern-attrs p) p description transparent? role))
(define (create-pat:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make pat:and attrs patterns)))
(define (create-pat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make pat:or attrs patterns)))
(define (create-pat:not pattern)
(make pat:not null pattern))
(define (create-pat:dots headps tailp)
(let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))])
(make pat:dots attrs headps tailp)))
(define (create-pat:delimit pattern)
(make pat:delimit (pattern-attrs pattern) pattern))
(define (create-pat:commit pattern)
(make pat:commit (pattern-attrs pattern) pattern))
(define (create-pat:post pattern)
(make pat:post (pattern-attrs pattern) pattern))
(define (create-pat:integrated name predicate description role)
(let ([attrs (if name (list (make attr name 0 #t)) null)])
(make pat:integrated attrs name predicate description role)))
;; ----
(define (create-action:cut)
(make action:cut null))
(define (create-action:fail condition message)
(make action:fail null condition message))
(define (create-action:bind clauses)
(make action:bind (map clause:attr-attr clauses) clauses))
(define (create-action:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make action:and attrs patterns)))
(define (create-action:parse pattern expr)
(make action:parse (pattern-attrs pattern) pattern expr))
(define (create-action:do stmts)
(make action:do null stmts))
(define (create-action:post pattern group index)
(make action:post (pattern-attrs pattern) pattern group index))
;; ----
(define (create-hpat:var/p name parser argu nested-attrs attr-count commit? role)
(let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var/p attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-hpat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:reflect attrs obj argu attr-decls name nested-attrs)))
(define (create-hpat:seq lp)
(make hpat:seq (pattern-attrs lp) lp))
(define (create-hpat:action g hp)
(cond [(action:and? g)
(for/fold ([hp hp]) ([g (in-list (reverse (action:and-patterns g)))])
(create-hpat:action g hp))]
[else
(let ([attrs (append-iattrs (map pattern-attrs (list g hp)))])
(make hpat:action attrs g hp))]))
(define (create-hpat:describe p description transparent? role)
(make hpat:describe (pattern-attrs p) p description transparent? role))
(define (create-hpat:and hp sp)
(make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp))
(define (create-hpat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make hpat:or attrs patterns)))
(define (create-hpat:delimit pattern)
(make hpat:delimit (pattern-attrs pattern) pattern))
(define (create-hpat:commit pattern)
(make hpat:commit (pattern-attrs pattern) pattern))
(define (create-hpat:post pattern)
(make hpat:post (pattern-attrs pattern) pattern))
(define (create-hpat:peek pattern)
(make hpat:peek (pattern-attrs pattern) pattern))
(define (create-hpat:peek-not pattern)
(make hpat:peek-not null pattern))
;; ----
(define (create-ehpat head repc) (define (create-ehpat head repc)
(let* ([iattrs0 (pattern-attrs head)] (let* ([iattrs0 (pattern-attrs head)]
@ -410,22 +333,22 @@ A SideClause is one of
(define (action/head-pattern->list-pattern p) (define (action/head-pattern->list-pattern p)
(cond [(action-pattern? p) (cond [(action-pattern? p)
(create-pat:action p (create-pat:any))] (pat:action p (pat:any))]
[(hpat:seq? p) [(hpat:seq? p)
;; simplification: just extract list pattern from hpat:seq ;; simplification: just extract list pattern from hpat:seq
(hpat:seq-inner p)] (hpat:seq-inner p)]
[else [else
(create-pat:head p (create-pat:datum '()))])) (pat:head p (pat:datum '()))]))
(define (action-pattern->single-pattern gp) (define (action-pattern->single-pattern a)
(create-pat:action gp (create-pat:any))) (pat:action a (pat:any)))
(define (proper-list-pattern? p trust-pair?) (define (proper-list-pattern? p trust-pair?)
(or (and (pat:datum? p) (eq? (pat:datum-datum p) '())) (or (and (pat:datum? p) (eq? (pat:datum-datum p) '()))
(and (pat:pair? p) (and (pat:pair? p)
(if trust-pair? (if trust-pair?
(pat:pair-proper? p) (pat:pair-proper? p)
(proper-list-pattern? (pat:pair-tail p)))) (proper-list-pattern? (pat:pair-tail p) trust-pair?)))
(and (pat:head? p) (proper-list-pattern? (pat:head-tail p) trust-pair?)) (and (pat:head? p) (proper-list-pattern? (pat:head-tail p) trust-pair?))
(and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p) trust-pair?)) (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p) trust-pair?))
(and (pat:action? p) (proper-list-pattern? (pat:action-inner p) trust-pair?)))) (and (pat:action? p) (proper-list-pattern? (pat:action-inner p) trust-pair?))))

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

@ -402,34 +402,29 @@
;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern ;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern
(define (combine-pattern+sides pattern sides splicing?) (define (combine-pattern+sides pattern sides splicing?)
(define sides-group (gensym*)) (check-pattern
(define actions-pattern (cond [(pair? sides)
(create-action:and (define group (gensym*))
(for/list ([side (in-list sides)] [index (in-naturals)]) (define actions-pattern
(match side (action:and
[(clause:fail condition message) (for/list ([side (in-list sides)] [index (in-naturals)])
(create-action:post (side-clause->pattern side group index))))
(create-action:fail condition message) (cond [splicing? (hpat:and pattern (pat:action actions-pattern (pat:any)))]
sides-group index)] [else (pat:and (list pattern (pat:action actions-pattern (pat:any))))])]
[(clause:with wpat expr defs) [else pattern])))
(let ([ap (create-action:post
(create-action:parse wpat expr) ;; side-clause->pattern : SideClause UninternedSymbol Nat -> ActionPattern
sides-group index)]) (define (side-clause->pattern side group index)
(if (pair? defs) (match side
(create-action:and (list (create-action:do defs) ap)) [(clause:fail condition message)
ap))] (action:post (action:fail condition message) group index)]
[(clause:attr attr expr) [(clause:with wpat expr defs)
(create-action:bind (list side))] (let ([ap (action:post (action:parse wpat expr) group index)])
[(clause:do stmts) (if (pair? defs) (action:and (list (action:do defs) ap)) ap))]
(create-action:do stmts)])))) [(clause:attr attr expr)
(define dummy-pattern (action:bind (list side))]
(and (pair? sides) [(clause:do stmts)
(create-pat:action actions-pattern (create-pat:any)))) (action:do stmts)]))
(if dummy-pattern
(if splicing?
(create-hpat:and pattern dummy-pattern)
(create-pat:and (list pattern dummy-pattern)))
pattern))
;; gensym* : -> UninternedSymbol ;; gensym* : -> UninternedSymbol
;; Like gensym, but with deterministic name from compilation-local counter. ;; Like gensym, but with deterministic name from compilation-local counter.
@ -474,6 +469,7 @@
[else [else
(wrong-syntax stx "action pattern not allowed here")])) (wrong-syntax stx "action pattern not allowed here")]))
(define not-shadowed? (make-not-shadowed? decls)) (define not-shadowed? (make-not-shadowed? decls))
(check-pattern
(syntax-case* stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe (syntax-case* stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe
~seq ~optional ~! ~bind ~fail ~parse ~do ~seq ~optional ~! ~bind ~fail ~parse ~do
~post ~peek ~peek-not ~delimit-cut ~commit ~reflect ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
@ -507,7 +503,7 @@
(and (wildcard? #'wildcard) (and (wildcard? #'wildcard)
(not-shadowed? #'wildcard)) (not-shadowed? #'wildcard))
(begin (disappeared! stx) (begin (disappeared! stx)
(create-pat:any))] (pat:any))]
[~! [~!
(disappeared! stx) (disappeared! stx)
(begin (begin
@ -515,7 +511,7 @@
(wrong-syntax stx (wrong-syntax stx
"cut (~~!) not allowed within ~~not pattern")) "cut (~~!) not allowed within ~~not pattern"))
(check-action! (check-action!
(create-action:cut)))] (action:cut)))]
[reserved [reserved
(and (reserved? #'reserved) (and (reserved? #'reserved)
(not-shadowed? #'reserved)) (not-shadowed? #'reserved))
@ -525,7 +521,7 @@
(parse-pat:id stx decls allow-head?)] (parse-pat:id stx decls allow-head?)]
[datum [datum
(atomic-datum-stx? #'datum) (atomic-datum-stx? #'datum)
(create-pat:datum (syntax->datum #'datum))] (pat:datum (syntax->datum #'datum))]
[(~var . rest) [(~var . rest)
(disappeared! stx) (disappeared! stx)
(parse-pat:var stx decls allow-head?)] (parse-pat:var stx decls allow-head?)]
@ -533,7 +529,7 @@
(disappeared! stx) (disappeared! stx)
(syntax-case stx (~datum) (syntax-case stx (~datum)
[(~datum d) [(~datum d)
(create-pat:datum (syntax->datum #'d))] (pat:datum (syntax->datum #'d))]
[_ (wrong-syntax stx "bad ~~datum form")])] [_ (wrong-syntax stx "bad ~~datum form")])]
[(~literal . rest) [(~literal . rest)
(disappeared! stx) (disappeared! stx)
@ -613,25 +609,25 @@
(let ([headp (parse-*-pattern #'head decls #t #t)] (let ([headp (parse-*-pattern #'head decls #t #t)]
[tailp (parse-single-pattern #'tail decls)]) [tailp (parse-single-pattern #'tail decls)])
(cond [(action-pattern? headp) (cond [(action-pattern? headp)
(create-pat:action headp tailp)] (pat:action headp tailp)]
[(head-pattern? headp) [(head-pattern? headp)
(create-pat:head headp tailp)] (pat:head headp tailp)]
[else [else
(create-pat:pair headp tailp)]))] (pat:pair (proper-list-pattern? tailp #t) headp tailp)]))]
[#(a ...) [#(a ...)
(let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
(create-pat:vector lp))] (pat:vector lp))]
[b [b
(box? (syntax-e #'b)) (box? (syntax-e #'b))
(let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)])
(create-pat:box bp))] (pat:box bp))]
[s [s
(and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s))) (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s)))
(let* ([s (syntax-e #'s)] (let* ([s (syntax-e #'s)]
[key (prefab-struct-key s)] [key (prefab-struct-key s)]
[contents (struct->list s)]) [contents (struct->list s)])
(let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
(create-pat:pstruct key lp)))])) (pat:pstruct key lp)))])))
;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) ;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern)
(define (parse-ellipsis-head-pattern stx decls) (define (parse-ellipsis-head-pattern stx decls)
@ -653,7 +649,7 @@
(let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
[attr-count (length iattrs)]) [attr-count (length iattrs)])
(list (create-ehpat (list (create-ehpat
(create-hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f) (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(eh-alternative-repc alt)) (eh-alternative-repc alt))
(replace-eh-alternative-attrs (replace-eh-alternative-attrs
alt (iattrs->sattrs iattrs))))))] alt (iattrs->sattrs iattrs))))))]
@ -694,7 +690,7 @@
(define (parse-pat:id id decls allow-head?) (define (parse-pat:id id decls allow-head?)
(cond [(declenv-lookup decls id) (cond [(declenv-lookup decls id)
=> (lambda (entry) (parse-pat:id/entry id decls allow-head? entry))] => (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
[(not (safe-name? id)) [(not (safe-name? id))
(wrong-syntax id "expected identifier not starting with ~~ character")] (wrong-syntax id "expected identifier not starting with ~~ character")]
[else [else
@ -702,22 +698,21 @@
(cond [(stxclass? suffix) (cond [(stxclass? suffix)
(parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)] (parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)]
[(or (den:lit? suffix) (den:datum-lit? suffix)) [(or (den:lit? suffix) (den:datum-lit? suffix))
(create-pat:and (pat:and
(list (list (pat:svar name)
(create-pat:svar name) (parse-pat:id/entry id allow-head? suffix)))]
(parse-pat:id/entry id decls allow-head? suffix)))]
[(declenv-apply-conventions decls id) [(declenv-apply-conventions decls id)
=> (lambda (entry) (parse-pat:id/entry id allow-head? entry))] => (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
[else (create-pat:svar name)]))])) [else (pat:svar name)]))]))
;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern ;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern
;; Handle when meaning of identifier pattern is given by declenv entry. ;; Handle when meaning of identifier pattern is given by declenv entry.
(define (parse-pat:id/entry id allow-head? entry) (define (parse-pat:id/entry id allow-head? entry)
(match entry (match entry
[(den:lit internal literal input-phase lit-phase) [(den:lit internal literal input-phase lit-phase)
(create-pat:literal literal input-phase lit-phase)] (pat:literal literal input-phase lit-phase)]
[(den:datum-lit internal sym) [(den:datum-lit internal sym)
(create-pat:datum sym)] (pat:datum sym)]
[(den:magic-class name class argu role) [(den:magic-class name class argu role)
(let* ([pos-count (length (arguments-pargs argu))] (let* ([pos-count (length (arguments-pargs argu))]
[kws (arguments-kws argu)] [kws (arguments-kws argu)]
@ -769,14 +764,14 @@
(cond [(and (epsilon? name0) (not scname)) (cond [(and (epsilon? name0) (not scname))
(wrong-syntax name0 "illegal pattern variable name")] (wrong-syntax name0 "illegal pattern variable name")]
[(and (wildcard? name0) (not scname)) [(and (wildcard? name0) (not scname))
(create-pat:any)] (pat:any)]
[scname [scname
(let ([sc (get-stxclass/check-arity scname sc+args-stx (let ([sc (get-stxclass/check-arity scname sc+args-stx
(length (arguments-pargs argu)) (length (arguments-pargs argu))
(arguments-kws argu))]) (arguments-kws argu))])
(parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))] (parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))]
[else ;; Just proper name [else ;; Just proper name
(create-pat:svar name0)])) (pat:svar name0)]))
(define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*) (define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*)
;; if parser* not #f, overrides sc parser ;; if parser* not #f, overrides sc parser
@ -807,18 +802,18 @@
(define (parse-pat:id/s name parser argu attrs commit? pfx role) (define (parse-pat:id/s name parser argu attrs commit? pfx role)
(define prefix (name->prefix name pfx)) (define prefix (name->prefix name pfx))
(define bind (name->bind name)) (define bind (name->bind name))
(create-pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (parse-pat:id/s/integrate name integrate role) (define (parse-pat:id/s/integrate name integrate role)
(define bind (name->bind name)) (define bind (name->bind name))
(let ([predicate (integrate-predicate integrate)] (let ([predicate (integrate-predicate integrate)]
[description (integrate-description integrate)]) [description (integrate-description integrate)])
(create-pat:integrated bind predicate description role))) (pat:integrated bind predicate description role)))
(define (parse-pat:id/h name parser argu attrs commit? pfx role) (define (parse-pat:id/h name parser argu attrs commit? pfx role)
(define prefix (name->prefix name pfx)) (define prefix (name->prefix name pfx))
(define bind (name->bind name)) (define bind (name->bind name))
(create-hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) (hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (name->prefix id pfx) (define (name->prefix id pfx)
(cond [(wildcard? id) #f] (cond [(wildcard? id) #f]
@ -866,7 +861,7 @@
[_ (raise-syntax-error #f "bad syntax" stx)])) [_ (raise-syntax-error #f "bad syntax" stx)]))
(define prefix (name->prefix #'name ".")) (define prefix (name->prefix #'name "."))
(define bind (name->bind #'name)) (define bind (name->bind #'name))
(define ctor (if splicing? create-hpat:reflect create-pat:reflect)) (define ctor (if splicing? hpat:reflect pat:reflect))
(ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind (ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind
(id-pattern-attrs attr-decls prefix)))])) (id-pattern-attrs attr-decls prefix)))]))
@ -883,7 +878,7 @@
[phase (options-select-value chunks '#:phase [phase (options-select-value chunks '#:phase
#:default #'(syntax-local-phase-level))]) #:default #'(syntax-local-phase-level))])
;; FIXME: Duplicates phase expr! ;; FIXME: Duplicates phase expr!
(create-pat:literal #'lit phase phase))] (pat:literal #'lit phase phase))]
[_ [_
(wrong-syntax stx "bad ~~literal pattern")])) (wrong-syntax stx "bad ~~literal pattern")]))
@ -900,8 +895,8 @@
[(description pattern) [(description pattern)
(let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) (let ([p (parse-*-pattern #'pattern decls allow-head? #f)])
(if (head-pattern? p) (if (head-pattern? p)
(create-hpat:describe p #'description transparent? role) (hpat:describe p #'description transparent? role)
(create-pat:describe p #'description transparent? role)))]))])) (pat:describe p #'description transparent? role)))]))]))
(define (parse-pat:delimit stx decls allow-head?) (define (parse-pat:delimit stx decls allow-head?)
(syntax-case stx () (syntax-case stx ()
@ -909,8 +904,8 @@
(let ([p (parameterize ((cut-allowed? #t)) (let ([p (parameterize ((cut-allowed? #t))
(parse-*-pattern #'pattern decls allow-head? #f))]) (parse-*-pattern #'pattern decls allow-head? #f))])
(if (head-pattern? p) (if (head-pattern? p)
(create-hpat:delimit p) (hpat:delimit p)
(create-pat:delimit p)))])) (pat:delimit p)))]))
(define (parse-pat:commit stx decls allow-head?) (define (parse-pat:commit stx decls allow-head?)
(syntax-case stx () (syntax-case stx ()
@ -918,8 +913,8 @@
(let ([p (parameterize ((cut-allowed? #t)) (let ([p (parameterize ((cut-allowed? #t))
(parse-*-pattern #'pattern decls allow-head? #f))]) (parse-*-pattern #'pattern decls allow-head? #f))])
(if (head-pattern? p) (if (head-pattern? p)
(create-hpat:commit p) (hpat:commit p)
(create-pat:commit p)))])) (pat:commit p)))]))
(define (split-prefix xs pred) (define (split-prefix xs pred)
(let loop ([xs xs] [rprefix null]) (let loop ([xs xs] [rprefix null])
@ -935,7 +930,7 @@
(define-values (actions patterns) (split-prefix patterns0 action-pattern?)) (define-values (actions patterns) (split-prefix patterns0 action-pattern?))
(cond [(null? patterns) (cond [(null? patterns)
(cond [allow-action? (cond [allow-action?
(create-action:and actions)] (action:and actions)]
[allow-head? [allow-head?
(wrong-syntax stx "expected at least one head pattern")] (wrong-syntax stx "expected at least one head pattern")]
[else [else
@ -944,9 +939,9 @@
(let ([p (parse-pat:and* stx patterns)]) (let ([p (parse-pat:and* stx patterns)])
(if (head-pattern? p) (if (head-pattern? p)
(for/fold ([p p]) ([action (in-list (reverse actions))]) (for/fold ([p p]) ([action (in-list (reverse actions))])
(create-hpat:action action p)) (hpat:action action p))
(for/fold ([p p]) ([action (in-list (reverse actions))]) (for/fold ([p p]) ([action (in-list (reverse actions))])
(create-pat:action action p))))])) (pat:action action p))))]))
(define (parse-pat:and* stx patterns) (define (parse-pat:and* stx patterns)
;; patterns is non-empty (empty case handled above) ;; patterns is non-empty (empty case handled above)
@ -962,9 +957,9 @@
"single-term pattern not allowed after head pattern"))) "single-term pattern not allowed after head pattern")))
(let ([p0 (car patterns)] (let ([p0 (car patterns)]
[lps (map action/head-pattern->list-pattern (cdr patterns))]) [lps (map action/head-pattern->list-pattern (cdr patterns))])
(create-hpat:and p0 (create-pat:and lps)))] (hpat:and p0 (pat:and lps)))]
[else [else
(create-pat:and (pat:and
(for/list ([p (in-list patterns)]) (for/list ([p (in-list patterns)])
(if (action-pattern? p) (if (action-pattern? p)
(action-pattern->single-pattern p) (action-pattern->single-pattern p)
@ -985,7 +980,7 @@
[(_ pattern) [(_ pattern)
(let ([p (parameterize ((cut-allowed? #f)) (let ([p (parameterize ((cut-allowed? #f))
(parse-single-pattern #'pattern decls))]) (parse-single-pattern #'pattern decls))])
(create-pat:not p))] (pat:not p))]
[_ [_
(wrong-syntax stx "expected a single subpattern")])) (wrong-syntax stx "expected a single subpattern")]))
@ -993,7 +988,7 @@
(define pattern (parse-single-pattern list-stx decls)) (define pattern (parse-single-pattern list-stx decls))
(unless (proper-list-pattern? pattern #t) (unless (proper-list-pattern? pattern #t)
(wrong-syntax stx "expected proper list pattern")) (wrong-syntax stx "expected proper list pattern"))
(create-hpat:seq pattern)) (hpat:seq pattern))
(define (parse-cdr-patterns stx decls allow-head? allow-action?) (define (parse-cdr-patterns stx decls allow-head? allow-action?)
(unless (stx-list? stx) (unless (stx-list? stx)
@ -1010,21 +1005,19 @@
(define tailp (parse-single-pattern tail decls)) (define tailp (parse-single-pattern tail decls))
(unless (pair? headps) (unless (pair? headps)
(wrong-syntax head "expected at least one pattern")) (wrong-syntax head "expected at least one pattern"))
(create-pat:dots headps tailp)) (pat:dots headps tailp))
(define (parse-pat:plus-dots stx head tail decls) (define (parse-pat:plus-dots stx head tail decls)
(define headp (parse-head-pattern head decls)) (define headp (parse-head-pattern head decls))
(define tailp (parse-single-pattern tail 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)))
(create-pat:dots (list head/rep) tailp)) (pat:dots (list head/rep) tailp))
(define (parse-pat:bind stx decls) (define (parse-pat:bind stx decls)
(syntax-case stx () (syntax-case stx ()
[(_ clause ...) [(_ clause ...)
(let ([clauses (check-bind-clause-list #'(clause ...) stx)]) (let ([clauses (check-bind-clause-list #'(clause ...) stx)])
(make action:bind (action:bind clauses))]))
(append-iattrs (side-clauses-attrss clauses))
clauses))]))
(define (parse-pat:fail stx decls) (define (parse-pat:fail stx decls)
(syntax-case stx () (syntax-case stx ()
@ -1043,9 +1036,9 @@
#`(not #,(caddr chunk)))))]) #`(not #,(caddr chunk)))))])
(syntax-case rest () (syntax-case rest ()
[(message) [(message)
(create-action:fail condition #'message)] (action:fail condition #'message)]
[() [()
(create-action:fail condition #''#f)] (action:fail condition #''#f)]
[_ [_
(wrong-syntax stx "bad ~~fail pattern")])))])) (wrong-syntax stx "bad ~~fail pattern")])))]))
@ -1054,39 +1047,38 @@
[(_ pattern) [(_ pattern)
(let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)]) (let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)])
(cond [(action-pattern? p) (cond [(action-pattern? p)
(cond [allow-action? (create-action:post p #f 0)] (cond [allow-action? (action:post p #f 0)]
[(not allow-head?) (create-pat:post (action-pattern->single-pattern p))] [(not allow-head?) (pat:post (action-pattern->single-pattern p))]
[else (wrong-syntax stx "action pattern not allowed here")])] [else (wrong-syntax stx "action pattern not allowed here")])]
[(head-pattern? p) [(head-pattern? p)
(cond [allow-head? (create-hpat:post p)] (cond [allow-head? (hpat:post p)]
[else (wrong-syntax stx "head pattern now allowed here")])] [else (wrong-syntax stx "head pattern now allowed here")])]
[else [else (pat:post p)]))]))
(create-pat:post p)]))]))
(define (parse-pat:peek stx decls) (define (parse-pat:peek stx decls)
(syntax-case stx () (syntax-case stx ()
[(_ pattern) [(_ pattern)
(let ([p (parse-head-pattern #'pattern decls)]) (let ([p (parse-head-pattern #'pattern decls)])
(create-hpat:peek p))])) (hpat:peek p))]))
(define (parse-pat:peek-not stx decls) (define (parse-pat:peek-not stx decls)
(syntax-case stx () (syntax-case stx ()
[(_ pattern) [(_ pattern)
(let ([p (parse-head-pattern #'pattern decls)]) (let ([p (parse-head-pattern #'pattern decls)])
(create-hpat:peek-not p))])) (hpat:peek-not p))]))
(define (parse-pat:parse stx decls) (define (parse-pat:parse stx decls)
(syntax-case stx () (syntax-case stx ()
[(_ pattern expr) [(_ pattern expr)
(let ([p (parse-single-pattern #'pattern decls)]) (let ([p (parse-single-pattern #'pattern decls)])
(create-action:parse p #'expr))] (action:parse p #'expr))]
[_ [_
(wrong-syntax stx "bad ~~parse pattern")])) (wrong-syntax stx "bad ~~parse pattern")]))
(define (parse-pat:do stx decls) (define (parse-pat:do stx decls)
(syntax-case stx () (syntax-case stx ()
[(_ stmt ...) [(_ stmt ...)
(create-action:do (syntax->list #'(stmt ...)))] (action:do (syntax->list #'(stmt ...)))]
[_ [_
(wrong-syntax stx "bad ~~do pattern")])) (wrong-syntax stx "bad ~~do pattern")]))
@ -1098,10 +1090,13 @@
(define (parse-hpat:optional stx decls) (define (parse-hpat:optional stx decls)
(define-values (head-stx head iattrs _name _tmm defaults) (define-values (head-stx head iattrs _name _tmm defaults)
(parse*-optional-pattern stx decls h-optional-directive-table)) (parse*-optional-pattern stx decls h-optional-directive-table))
(make hpat:optional iattrs head defaults)) (create-hpat:or
(list head
(hpat:action (action:bind defaults)
(hpat:seq (pat:datum '()))))))
;; parse*-optional-pattern : stx DeclEnv table ;; parse*-optional-pattern : stx DeclEnv table
;; -> (values ;; -> (values Syntax HeadPattern IAttrs Stx Stx Defaults)
(define (parse*-optional-pattern stx decls optional-directive-table) (define (parse*-optional-pattern stx decls optional-directive-table)
(syntax-case stx () (syntax-case stx ()
[(_ p . options) [(_ p . options)