mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Add tree-il-fold', a purely functional iterator on tree-il'.

Browse source 
* module/language/tree-il.scm (tree-il-fold): New procedure.

* test-suite/tests/tree-il.test ("tree-il-fold"): New test prefix.
This commit is contained in:
Ludovic Courtès 2009-07-30 00:48:04 +02:00
parent 904a78f11d
commit f4aa0f104b
2 changed files with 87 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -17,6 +17,7 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@ -38,11 +39,12 @@
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
parse-tree-il
unparse-tree-il
tree-il->scheme
tree-il-fold
post-order!
pre-order!))
@ -258,6 +260,51 @@
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
(define (tree-il-fold leaf down up seed tree)
"Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED.
This is an implementation of `foldts' as described by Andy Wingo in
``Applications of fold to XML transformation''."
(let loop ((tree tree)
(result seed))
(if (or (null? tree) (pair? tree))
(fold loop result tree)
(record-case tree
((<lexical-set> exp)
(up tree (loop exp (down tree result))))
((<module-set> exp)
(up tree (loop exp (down tree result))))
((<toplevel-set> exp)
(up tree (loop exp (down tree result))))
((<toplevel-define> exp)
(up tree (loop exp (down tree result))))
((<conditional> test then else)
(up tree (loop else
(loop then
(loop test (down tree result))))))
((<application> proc args)
(up tree (loop (cons proc args) (down tree result))))
((<sequence> exps)
(up tree (loop exps (down tree result))))
((<lambda> body)
(up tree (loop body (down tree result))))
((<let> vals body)
(up tree (loop body
(loop vals
(down tree result)))))
((<letrec> vals body)
(up tree (loop body
(loop vals
(down tree result)))))
((<let-values> body)
(up tree (loop body (down tree result))))
(else
(leaf tree result))))))
(define (post-order! f x)
(let lp ((x x))
(record-case x

39
test-suite/tests/tree-il.test
View file

@ -467,3 +467,42 @@
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
(let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
(and (eq? mark
(tree-il-fold (lambda (x y) (set! leaf? #t) y)
(lambda (x y) (set! down? #t) y)
(lambda (x y) (set! up? #t) y)
mark
'()))
(not leaf?)
(not up?)
(not down?))))
(pass-if "lambda and application"
(let* ((leaves '()) (ups '()) (downs '())
(result (tree-il-fold (lambda (x y)
(set! leaves (cons x leaves))
(1+ y))
(lambda (x y)
(set! downs (cons x downs))
(1+ y))
(lambda (x y)
(set! ups (cons x ups))
(1+ y))
0
(parse-tree-il
'(lambda (x y) (x1 y1)
(apply (toplevel +)
(lexical x x1)
(lexical y y1)))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
(make-lexical-ref #f 'x 'x1)
(make-toplevel-ref #f '+)))
(= (length downs) 2)
(equal? (reverse (map strip-source ups))
(map strip-source downs))))))