\f
(define-module (language tree-il)
+ #:use-module (srfi srfi-1)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
<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!))
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
+\f
+(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
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
+\f
+(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))))))