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

syntax/parse: use generic tree functions in analyses

Browse Source
This commit is contained in:
Ryan Culpepper 2018-08-13 23:49:47 +02:00
parent 4b64cdef54
commit eb4ec000b0
1 changed files with 30 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -175,68 +175,36 @@
[else (values p onto)]))] [else (values p onto)]))]
[_ (values p onto)])) [_ (values p onto)]))
(define (pattern-factorable? p) ;; pattern-factorable? : *Pattern -> Boolean
;; Can factor out p if p can succeed at most once, does not cut (define (pattern-factorable? p) (not (pattern-unfactorable? p)))
;; - 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) ;; pattern-unfactorable? : *Pattern -> Boolean
(define (pattern-unfactorable? p)
;; Cannot factor out p if
;; - if p can succeed multiple times (factoring changes success order)
;; - if p can cut (factoring changes which choice points are discarded (too few))
;; Note: presence of sub-expressions handled by pattern-equal?.
(define (for-pattern p recur)
(match p (match p
[(pat:any) #t] [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
[(pat:svar _n) #t] [(pat:action _act _pat) #t]
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
;; commit? implies delimit-cut
commit?]
[(? pat:integrated?) #t]
[(pat:literal _lit _ip _lp) #t]
[(pat:datum _datum) #t]
[(pat:action _act _pat) #f]
[(pat:head head tail)
(and (pattern-factorable? head)
(pattern-factorable? tail))]
[(pat:dots 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) (or (> (length heads) 1)
(let ([head (car heads)]) (not (equal? tail (pat:datum '())))
(and (pattern-factorable? head))) (recur))]
(equal? tail (pat:datum '())))] [(pat:or _ patterns _) #t]
[(pat:and patterns) [(pat:not pattern) #t]
(andmap pattern-factorable? patterns)] [(pat:commit pattern) #f]
[(pat:or _ patterns _) #f] [(? pat:reflect?) #t]
[(pat:not pattern) #f] ;; FIXME: ? [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
[(pat:pair head tail) [(hpat:commit inner) #f]
(and (pattern-factorable? head)
(pattern-factorable? tail))]
[(pat:vector pattern)
(pattern-factorable? pattern)]
[(pat:box pattern)
(pattern-factorable? pattern)]
[(pat:pstruct key pattern)
(pattern-factorable? pattern)]
[(pat:describe pattern _desc _trans _role)
(pattern-factorable? pattern)]
[(pat:delimit pattern)
(pattern-factorable? pattern)]
[(pat:commit pattern) #t]
[(? pat:reflect?) #f]
[(pat:ord pattern _ _)
(pattern-factorable? pattern)]
[(pat:post pattern)
(pattern-factorable? pattern)]
[(pat:seq-end) #t]
;; ----
[(hpat:single inner)
(pattern-factorable? inner)]
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
commit?]
[(hpat:seq inner)
(pattern-factorable? inner)]
[(hpat:commit inner) #t]
;; ----
[(ehpat _ head repc _) [(ehpat _ head repc _)
(and (equal? repc #f) (or (not (equal? repc #f))
(pattern-factorable? head))] (recur))]
;; ---- [_ (recur)]))
[else #f])) (pattern-ormap p for-pattern))
(define (subpatterns-equal? as bs) (define (subpatterns-equal? as bs)
(and (= (length as) (length bs)) (and (= (length as) (length bs))