From f4aa0f104b3347c21093b837046022fb7bb6a2ff Mon Sep 17 00:00:00 2001
From: =?utf8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 30 Jul 2009 00:48:04 +0200
Subject: [PATCH] Add `tree-il-fold', a purely functional iterator on
 `tree-il'.

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

* test-suite/tests/tree-il.test ("tree-il-fold"): New test prefix.
---
 module/language/tree-il.scm   | 49 ++++++++++++++++++++++++++++++++++-
 test-suite/tests/tree-il.test | 39 ++++++++++++++++++++++++++++
 2 files changed, 87 insertions(+), 1 deletion(-)

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 0f8448a44..aec4eedb9 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -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
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 6634dcdd7..8b8f1238d 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -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))))))
-- 
2.20.1