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

92
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
(match p (define (pattern-unfactorable? p)
[(pat:any) #t] ;; Cannot factor out p if
[(pat:svar _n) #t] ;; - if p can succeed multiple times (factoring changes success order)
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) ;; - if p can cut (factoring changes which choice points are discarded (too few))
;; commit? implies delimit-cut ;; Note: presence of sub-expressions handled by pattern-equal?.
commit?] (define (for-pattern p recur)
[(? pat:integrated?) #t] (match p
[(pat:literal _lit _ip _lp) #t] [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
[(pat:datum _datum) #t] [(pat:action _act _pat) #t]
[(pat:action _act _pat) #f] [(pat:dots heads tail)
[(pat:head head tail) ;; Conservative approximation for common case: one head pattern
(and (pattern-factorable? head) ;; In general, check if heads don't overlap, don't overlap with tail.
(pattern-factorable? tail))] (or (> (length heads) 1)
[(pat:dots heads tail) (not (equal? tail (pat:datum '())))
;; Conservative approximation for common case: one head pattern (recur))]
;; In general, check if heads don't overlap, don't overlap with tail. [(pat:or _ patterns _) #t]
(and (= (length heads) 1) [(pat:not pattern) #t]
(let ([head (car heads)]) [(pat:commit pattern) #f]
(and (pattern-factorable? head))) [(? pat:reflect?) #t]
(equal? tail (pat:datum '())))] [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
[(pat:and patterns) [(hpat:commit inner) #f]
(andmap pattern-factorable? patterns)] [(ehpat _ head repc _)
[(pat:or _ patterns _) #f] (or (not (equal? repc #f))
[(pat:not pattern) #f] ;; FIXME: ? (recur))]
[(pat:pair head tail) [_ (recur)]))
(and (pattern-factorable? head) (pattern-ormap p for-pattern))
(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 _)
(and (equal? repc #f)
(pattern-factorable? head))]
;; ----
[else #f]))
(define (subpatterns-equal? as bs) (define (subpatterns-equal? as bs)
(and (= (length as) (length bs)) (and (= (length as) (length bs))