diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-29 18:02:28 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-29 18:02:28 +0200 |
commit | ca128245811fab5abcf02756cd7a322a3a40d192 (patch) | |
tree | 9138f716f1617f391d2b5f88802b2c6605dd79d2 /module/language/tree-il.scm | |
parent | 25f4a88032f51cecdf8b0147c8a2d0a4574972fa (diff) | |
parent | 014de9e25d87b7d3a13566aee4c271c1a11ea0b7 (diff) | |
download | guile-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.scm | 156 |
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)) |