mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

Rewrite make-tree-il-folder to use the Wright matcher.

Browse source 
* module/language/tree-il.scm (make-tree-il-folder): Rewrite to use the
  Wright matcher instead of record-case.
This commit is contained in:
Andy Wingo 2013-05-28 12:38:16 -04:00
parent 98f778ea28
commit b34b66b346
1 changed files with 23 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

45
module/language/tree-il.scm
View file

@ -382,73 +382,74 @@
(let*-values (let*-values
(((seed ...) (down tree seed ...)) (((seed ...) (down tree seed ...))
((seed ...) ((seed ...)
(record-case tree (match tree
((<lexical-set> exp) (($ <lexical-set> src name gensym exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<module-set> exp) (($ <module-set> src mod name public? exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<toplevel-set> exp) (($ <toplevel-set> src name exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<toplevel-define> exp) (($ <toplevel-define> src name exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<conditional> test consequent alternate) (($ <conditional> src test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...)) (let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...))) ((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...))) (foldts alternate seed ...)))
((<call> proc args) (($ <call> src proc args)
(let-values (((seed ...) (foldts proc seed ...))) (let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...))) (fold-values foldts args seed ...)))
((<primcall> name args) (($ <primcall> src name args)
(fold-values foldts args seed ...)) (fold-values foldts args seed ...))
((<seq> head tail) (($ <seq> src head tail)
(let-values (((seed ...) (foldts head seed ...))) (let-values (((seed ...) (foldts head seed ...)))
(foldts tail seed ...))) (foldts tail seed ...)))
((<lambda> body) (($ <lambda> src meta body)
(if body (if body
(foldts body seed ...) (foldts body seed ...)
(values seed ...))) (values seed ...)))
((<lambda-case> inits body alternate) (($ <lambda-case> src req opt rest kw inits gensyms body
alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...))) (let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate (if alternate
(let-values (((seed ...) (foldts body seed ...))) (let-values (((seed ...) (foldts body seed ...)))
(foldts alternate seed ...)) (foldts alternate seed ...))
(foldts body seed ...)))) (foldts body seed ...))))
((<let> vals body) (($ <let> src names gensyms vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
((<letrec> vals body) (($ <letrec> src in-order? names gensyms vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
((<fix> vals body) (($ <fix> src names gensyms vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
((<let-values> exp body) (($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...))) (let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
((<dynwind> winder pre body post unwinder) (($ <dynwind> src winder pre body post unwinder)
(let*-values (((seed ...) (foldts winder seed ...)) (let*-values (((seed ...) (foldts winder seed ...))
((seed ...) (foldts pre seed ...)) ((seed ...) (foldts pre seed ...))
((seed ...) (foldts body seed ...)) ((seed ...) (foldts body seed ...))
((seed ...) (foldts post seed ...))) ((seed ...) (foldts post seed ...)))
(foldts unwinder seed ...))) (foldts unwinder seed ...)))
((<dynlet> fluids vals body) (($ <dynlet> src fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...)) (let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...))) ((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
((<dynref> fluid) (($ <dynref> src fluid)
(foldts fluid seed ...)) (foldts fluid seed ...))
((<dynset> fluid exp) (($ <dynset> src fluid exp)
(let*-values (((seed ...) (foldts fluid seed ...))) (let*-values (((seed ...) (foldts fluid seed ...)))
(foldts exp seed ...))) (foldts exp seed ...)))
((<prompt> tag body handler) (($ <prompt> src tag body handler)
(let*-values (((seed ...) (foldts tag seed ...)) (let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...))) ((seed ...) (foldts body seed ...)))
(foldts handler seed ...))) (foldts handler seed ...)))
((<abort> tag args tail) (($ <abort> src tag args tail)
(let*-values (((seed ...) (foldts tag seed ...)) (let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (fold-values foldts args seed ...))) ((seed ...) (fold-values foldts args seed ...)))
(foldts tail seed ...))) (foldts tail seed ...)))
(else (_
(values seed ...))))) (values seed ...)))))
(up tree seed ...))))) (up tree seed ...)))))