summaryrefslogtreecommitdiff
path: root/module/language/tree-il.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-29 18:02:28 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-29 18:02:28 +0200
commitca128245811fab5abcf02756cd7a322a3a40d192 (patch)
tree9138f716f1617f391d2b5f88802b2c6605dd79d2 /module/language/tree-il.scm
parent25f4a88032f51cecdf8b0147c8a2d0a4574972fa (diff)
parent014de9e25d87b7d3a13566aee4c271c1a11ea0b7 (diff)
downloadguile-ca128245811fab5abcf02756cd7a322a3a40d192.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
This was a pretty big merge involving a fair amount of porting, especially to peval and its tests. I did not update psyntax-pp.scm, that comes in the next commit. Conflicts: module/ice-9/boot-9.scm module/ice-9/psyntax-pp.scm module/language/ecmascript/compile-tree-il.scm module/language/tree-il.scm module/language/tree-il/analyze.scm module/language/tree-il/inline.scm test-suite/tests/tree-il.test
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r--module/language/tree-il.scm156
1 files changed, 77 insertions, 79 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1264f3209..cd6b01e93 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -344,7 +344,7 @@
`(dynref ,(unparse-tree-il fluid)))
((<dynset> fluid exp)
- `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il 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)))
@@ -588,84 +588,82 @@ This is an implementation of `foldts' as described by Andy Wingo in
(leaf tree result))))))
-(define-syntax make-tree-il-folder
- (syntax-rules ()
- ((_ seed ...)
- (lambda (tree down up seed ...)
- (define (fold-values proc exps seed ...)
- (if (null? exps)
- (values seed ...)
- (let-values (((seed ...) (proc (car exps) seed ...)))
- (fold-values proc (cdr exps) seed ...))))
- (let foldts ((tree tree) (seed seed) ...)
- (let*-values
- (((seed ...) (down tree seed ...))
- ((seed ...)
- (record-case tree
- ((<lexical-set> exp)
- (foldts exp seed ...))
- ((<module-set> exp)
- (foldts exp seed ...))
- ((<toplevel-set> exp)
- (foldts exp seed ...))
- ((<toplevel-define> exp)
- (foldts exp seed ...))
- ((<conditional> test consequent alternate)
- (let*-values (((seed ...) (foldts test seed ...))
- ((seed ...) (foldts consequent seed ...)))
- (foldts alternate seed ...)))
- ((<call> proc args)
- (let-values (((seed ...) (foldts proc seed ...)))
- (fold-values foldts args seed ...)))
- ((<primcall> name args)
- (fold-values foldts args seed ...))
- ((<seq> head tail)
- (let-values (((seed ...) (foldts head seed ...)))
- (foldts tail seed ...)))
- ((<lambda> body)
- (foldts body seed ...))
- ((<lambda-case> inits 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*-values (((seed ...) (fold-values foldts vals seed ...)))
- (foldts body seed ...)))
- ((<letrec> vals body)
- (let*-values (((seed ...) (fold-values foldts vals seed ...)))
- (foldts body seed ...)))
- ((<fix> vals body)
- (let*-values (((seed ...) (fold-values foldts vals seed ...)))
- (foldts body seed ...)))
- ((<let-values> exp body)
- (let*-values (((seed ...) (foldts exp seed ...)))
- (foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
- (foldts unwinder seed ...)))
- ((<dynlet> fluids vals body)
- (let*-values (((seed ...) (fold-values foldts fluids seed ...))
- ((seed ...) (fold-values foldts vals seed ...)))
- (foldts body seed ...)))
- ((<dynref> fluid)
- (foldts fluid seed ...))
- ((<dynset> fluid exp)
- (let*-values (((seed ...) (foldts fluid seed ...)))
- (foldts exp seed ...)))
- ((<prompt> tag body handler)
- (let*-values (((seed ...) (foldts tag seed ...))
- ((seed ...) (foldts body seed ...)))
- (foldts handler seed ...)))
- ((<abort> tag args tail)
- (let*-values (((seed ...) (foldts tag seed ...))
- ((seed ...) (fold-values foldts args seed ...)))
- (foldts tail seed ...)))
- (else
- (values seed ...)))))
- (up tree seed ...)))))))
+(define-syntax-rule (make-tree-il-folder seed ...)
+ (lambda (tree down up seed ...)
+ (define (fold-values proc exps seed ...)
+ (if (null? exps)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car exps) seed ...)))
+ (fold-values proc (cdr exps) seed ...))))
+ (let foldts ((tree tree) (seed seed) ...)
+ (let*-values
+ (((seed ...) (down tree seed ...))
+ ((seed ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (foldts exp seed ...))
+ ((<module-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-define> exp)
+ (foldts exp seed ...))
+ ((<conditional> test consequent alternate)
+ (let*-values (((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts consequent seed ...)))
+ (foldts alternate seed ...)))
+ ((<call> proc args)
+ (let-values (((seed ...) (foldts proc seed ...)))
+ (fold-values foldts args seed ...)))
+ ((<primcall> name args)
+ (fold-values foldts args seed ...))
+ ((<seq> head tail)
+ (let-values (((seed ...) (foldts head seed ...)))
+ (foldts tail seed ...)))
+ ((<lambda> body)
+ (foldts body seed ...))
+ ((<lambda-case> inits 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*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<fix> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<let-values> exp body)
+ (let*-values (((seed ...) (foldts exp seed ...)))
+ (foldts body seed ...)))
+ ((<dynwind> body winder unwinder)
+ (let*-values (((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts winder seed ...)))
+ (foldts unwinder seed ...)))
+ ((<dynlet> fluids vals body)
+ (let*-values (((seed ...) (fold-values foldts fluids seed ...))
+ ((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<dynref> fluid)
+ (foldts fluid seed ...))
+ ((<dynset> fluid exp)
+ (let*-values (((seed ...) (foldts fluid seed ...)))
+ (foldts exp seed ...)))
+ ((<prompt> tag body handler)
+ (let*-values (((seed ...) (foldts tag seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (foldts handler seed ...)))
+ ((<abort> tag args tail)
+ (let*-values (((seed ...) (foldts tag seed ...))
+ ((seed ...) (fold-values foldts args seed ...)))
+ (foldts tail seed ...)))
+ (else
+ (values seed ...)))))
+ (up tree seed ...)))))
(define (post-order! f x)
(let lp ((x x))