summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-28 12:28:56 -0400
committerAndy Wingo <wingo@pobox.com>2013-06-10 22:46:08 +0200
commit98f778ea28b7df3def9da6f7447f5f6c5fc9c6c9 (patch)
tree2aa19c5fe38afdb15e63369892ee79644e524384
parentf852e05ee863e47a62b2cd3ee5b8b9dd303170f2 (diff)
downloadguile-98f778ea28b7df3def9da6f7447f5f6c5fc9c6c9.tar.gz
Rewrite unparse-tree-il to use the Wright matcher.
* module/language/tree-il.scm (unparse-tree-il): Rewrite to use the Wright matcher.
-rw-r--r--module/language/tree-il.scm62
1 files changed, 33 insertions, 29 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 7ed2c7bab..b40224b2f 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -273,91 +273,95 @@
(error "unrecognized tree-il" exp)))))
(define (unparse-tree-il tree-il)
- (record-case tree-il
- ((<void>)
+ (match tree-il
+ (($ <void> src)
'(void))
- ((<call> proc args)
+ (($ <call> src proc args)
`(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
- ((<primcall> name args)
+ (($ <primcall> src name args)
`(primcall ,name ,@(map unparse-tree-il args)))
- ((<conditional> test consequent alternate)
- `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
+ (($ <conditional> src test consequent alternate)
+ `(if ,(unparse-tree-il test)
+ ,(unparse-tree-il consequent)
+ ,(unparse-tree-il alternate)))
- ((<primitive-ref> name)
+ (($ <primitive-ref> src name)
`(primitive ,name))
- ((<lexical-ref> name gensym)
+ (($ <lexical-ref> src name gensym)
`(lexical ,name ,gensym))
- ((<lexical-set> name gensym exp)
+ (($ <lexical-set> src name gensym exp)
`(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
- ((<module-ref> mod name public?)
+ (($ <module-ref> src mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
- ((<module-set> mod name public? exp)
+ (($ <module-set> src mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
- ((<toplevel-ref> name)
+ (($ <toplevel-ref> src name)
`(toplevel ,name))
- ((<toplevel-set> name exp)
+ (($ <toplevel-set> src name exp)
`(set! (toplevel ,name) ,(unparse-tree-il exp)))
- ((<toplevel-define> name exp)
+ (($ <toplevel-define> src name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> meta body)
+ (($ <lambda> src meta body)
(if body
`(lambda ,meta ,(unparse-tree-il body))
`(lambda ,meta (lambda-case))))
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
`(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
,(unparse-tree-il body))
. ,(if alternate (list (unparse-tree-il alternate)) '())))
- ((<const> exp)
+ (($ <const> src exp)
`(const ,exp))
- ((<seq> head tail)
+ (($ <seq> src head tail)
`(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
- ((<let> names gensyms vals body)
+ (($ <let> src names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<letrec> in-order? names gensyms vals body)
+ (($ <letrec> src in-order? names gensyms vals body)
`(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<fix> names gensyms vals body)
+ (($ <fix> src names gensyms vals body)
`(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> exp body)
+ (($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder pre body post unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
`(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
,(unparse-tree-il body)
,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
- ((<dynlet> fluids vals body)
+ (($ <dynlet> src fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
,(unparse-tree-il body)))
- ((<dynref> fluid)
+ (($ <dynref> src fluid)
`(dynref ,(unparse-tree-il fluid)))
- ((<dynset> fluid exp)
+ (($ <dynset> src fluid exp)
`(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
- ((<prompt> tag body handler)
- `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
+ (($ <prompt> src tag body handler)
+ `(prompt ,(unparse-tree-il tag)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il handler)))
- ((<abort> tag args tail)
+ (($ <abort> src tag args tail)
`(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
,(unparse-tree-il tail)))))