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