diff options
author | Andy Wingo <wingo@pobox.com> | 2009-08-05 21:25:35 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-08-05 21:35:30 +0200 |
commit | 4dcd84998fc61e15920aea83c4420c7357b9be46 (patch) | |
tree | 14f17398e91c6c3eddedbcd9b2dda7f44fed4f92 /module/language/tree-il.scm | |
parent | c21c89b1384415313cd4bc03e76d6e1507e48d7a (diff) | |
download | guile-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.scm | 78 |
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 |