mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 19:44:10 +02:00
Code Activity

let-values in terms of syntax-case, add make-tree-il-folder

Browse source 
* 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."
This commit is contained in:
Andy Wingo 2009-08-05 21:25:35 +02:00
parent c21c89b138
commit 4dcd84998f
4 changed files with 194 additions and 189 deletions
Download patch file Download diff file Expand all files Collapse all files

78
module/language/tree-il.scm
View file

@ -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

4
module/language/tree-il/optimize.scm
View file

@ -29,7 +29,7 @@
(if e (car e) (current-module)))
(define (optimize! x env opts)
(fix-letrec!
(inline!
(inline!
(fix-letrec!
(expand-primitives!
(resolve-primitives! x (env-module env))))))