summaryrefslogtreecommitdiff
path: root/module/language/tree-il.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-08-05 21:25:35 +0200
committerAndy Wingo <wingo@pobox.com>2009-08-05 21:35:30 +0200
commit4dcd84998fc61e15920aea83c4420c7357b9be46 (patch)
tree14f17398e91c6c3eddedbcd9b2dda7f44fed4f92 /module/language/tree-il.scm
parentc21c89b1384415313cd4bc03e76d6e1507e48d7a (diff)
downloadguile-4dcd84998fc61e15920aea83c4420c7357b9be46.tar.gz
let-values in terms of syntax-case, add make-tree-il-folder
* module/language/tree-il.scm (tree-il-fold): Fix for let-values case. (make-tree-il-folder): New public macro, makes a multi-valued folder specific to the number of seeds that the user wants. * module/language/tree-il/optimize.scm (optimize!): Reverse the order of inline! and fix-letrec!, as the latter might expose opportunities for the former. * module/srfi/srfi-11.scm (let-values): Reimplement in terms of syntax-case, so that its expressions may reference hygienically bound variables. See the NEWS for the rationale. (let*-values): An empty let*-values still introduces a local `let' binding contour. * module/system/base/syntax.scm (record-case): Yukkkk. Reimplement in terms of syntax-case. Ug-ly, but see the NEWS again: "Lexical bindings introduced by hygienic macros may not be referenced by nonhygienic macros."
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r--module/language/tree-il.scm78
1 files changed, 76 insertions, 2 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 01d52f181..8ad7065c6 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -18,6 +18,7 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -46,6 +47,7 @@
tree-il->scheme
tree-il-fold
+ make-tree-il-folder
post-order!
pre-order!))
@@ -316,11 +318,83 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop body
(loop vals
(down tree result)))))
- ((<let-values> body)
- (up tree (loop body (down tree result))))
+ ((<let-values> exp body)
+ (up tree (loop body (loop exp (down tree result)))))
(else
(leaf tree result))))))
+
+(define-syntax make-tree-il-folder
+ (syntax-rules ()
+ ((_ seed ...)
+ (lambda (tree down up leaf 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) ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<module-set> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<toplevel-set> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<toplevel-define> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<conditional> test then else)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts then seed ...))
+ ((seed ...) (foldts else seed ...)))
+ (up tree seed ...)))
+ ((<application> proc args)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts proc seed ...))
+ ((seed ...) (fold-values foldts args seed ...)))
+ (up tree seed ...)))
+ ((<sequence> exps)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts exps seed ...)))
+ (up tree seed ...)))
+ ((<lambda> body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ ((<let> vals body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+
+ ((<fix> vals body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ ((<let-values> exp body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ (else
+ (leaf tree seed ...))))))))
+
+
(define (post-order! f x)
(let lp ((x x))
(record-case x