Implement tree-il-fold in terms of make-tree-il-folder.

* module/language/tree-il.scm (tree-il-fold): Implement using
  make-tree-il-folder.  This is an incompatible change: there is no more
  "leaf" procedure, and tree-il-fold only works on tree-il and not
  lists.

* module/language/tree-il/analyze.scm (<tree-analysis>, analyze-tree):
  Adapt to tree-il-fold change, losing the "leaf" handler.
  (unused-variable-analysis, unused-toplevel-analysis)
  (unbound-variable-analysis, arity-analysis): Adapt to tree-analysis
  change.

* module/language/tree-il/canonicalize.scm (tree-il-any)
* module/language/tree-il/cse.scm (build-assigned-var-table)
* module/language/tree-il/peval.scm (tree-il-any, build-var-table)
  (peval): Adapt to tree-il-fold change.

* test-suite/tests/tree-il.test ("tree-il-fold"): Adapt tests for new
  interface and expectations.

module/language/tree-il.scm

@@ -368,87 +368,6 @@
            e env opts)))
 
 
-(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
-``Calls 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 consequent alternate)
-           (up tree (loop alternate
-                          (loop consequent
-                                (loop test (down tree result))))))
-          ((<call> proc args)
-           (up tree (loop (cons proc args) (down tree result))))
-          ((<primcall> name args)
-           (up tree (loop args (down tree result))))
-          ((<seq> head tail)
-           (up tree (loop tail (loop head (down tree result)))))
-          ((<lambda> body)
-           (let ((result (down tree result)))
-             (up tree
-                 (if body
-                     (loop body result)
-                     result))))
-          ((<lambda-case> inits body alternate)
-           (up tree (if alternate
-                        (loop alternate
-                              (loop body (loop inits (down tree result))))
-                        (loop body (loop inits (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)))))
-          ((<fix> vals body)
-           (up tree (loop body
-                          (loop vals
-                                (down tree result)))))
-          ((<let-values> exp body)
-           (up tree (loop body (loop exp (down tree result)))))
-          ((<dynwind> winder pre body post unwinder)
-           (up tree (loop unwinder
-                      (loop post
-                        (loop body
-                          (loop pre
-                            (loop winder
-                              (down tree result))))))))
-          ((<dynlet> fluids vals body)
-           (up tree (loop body
-                          (loop vals
-                                (loop fluids (down tree result))))))
-          ((<dynref> fluid)
-           (up tree (loop fluid (down tree result))))
-          ((<dynset> fluid exp)
-           (up tree (loop exp (loop fluid (down tree result)))))
-          ((<prompt> tag body handler)
-           (up tree
-               (loop tag (loop body (loop handler
-                                          (down tree result))))))
-          ((<abort> tag args tail)
-           (up tree (loop tail (loop args (loop tag (down tree result))))))
-          (else
-           (leaf tree result))))))
-
-
 (define-syntax-rule (make-tree-il-folder seed ...)
   (lambda (tree down up seed ...)
     (define (fold-values proc exps seed ...)
@@ -530,6 +449,19 @@ This is an implementation of `foldts' as described by Andy Wingo in
                (values seed ...)))))
         (up tree seed ...)))))
 
+(define (tree-il-fold down up seed tree)
+  "Traverse TREE, calling DOWN before visiting a sub-tree, and UP when
+after visiting it.  Each of these procedures is invoked as `(PROC TREE
+SEED)', where TREE is the sub-tree 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''."
+  ;; Multi-valued fold naturally puts the seeds at the end, whereas
+  ;; normal fold puts the traversable at the end.  Adapt to the expected
+  ;; argument order.
+  ((make-tree-il-folder tree) tree down up seed))
+
 (define (pre-post-order pre post x)
   (let lp ((x x))
     (post

module/language/tree-il/analyze.scm

@@ -1,6 +1,6 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -551,9 +551,8 @@
 ;;;
 
 (define-record-type <tree-analysis>
-  (make-tree-analysis leaf down up post init)
+  (make-tree-analysis down up post init)
   tree-analysis?
-  (leaf tree-analysis-leaf)  ;; (lambda (x result env locs) ...)
   (down tree-analysis-down)  ;; (lambda (x result env locs) ...)
   (up   tree-analysis-up)    ;; (lambda (x result env locs) ...)
   (post tree-analysis-post)  ;; (lambda (result env) ...)
@@ -561,10 +560,11 @@
 
 (define (analyze-tree analyses tree env)
   "Run all tree analyses listed in ANALYSES on TREE for ENV, using
-`tree-il-fold'.  Return TREE.  The leaf/down/up procedures of each analysis are
+`tree-il-fold'.  Return TREE.  The down and up procedures of each
-passed a ``location stack', which is the stack of `tree-il-src' values for each
+analysis are passed a ``location stack', which is the stack of
-parent tree (a list); it can be used to approximate source location when
+`tree-il-src' values for each parent tree (a list); it can be used to
-accurate information is missing from a given `tree-il' element."
+approximate source location when accurate information is missing from a
+given `tree-il' element."
 
   (define (traverse proc update-locs)
     ;; Return a tree traversing procedure that returns a list of analysis
@@ -577,14 +577,12 @@ accurate information is missing from a given `tree-il' element."
                    analyses
                    (cdr results))))))
 
-  ;; Keeping/extending/shrinking the location stack.
+  ;; Extending and shrinking the location stack.
-  (define (keep-locs x locs)   locs)
   (define (extend-locs x locs) (cons (tree-il-src x) locs))
   (define (shrink-locs x locs) (cdr locs))
 
   (let ((results
-         (tree-il-fold (traverse tree-analysis-leaf keep-locs)
+         (tree-il-fold (traverse tree-analysis-down extend-locs)
-                       (traverse tree-analysis-down extend-locs)
                        (traverse tree-analysis-up   shrink-locs)
                        (cons '() ;; empty location stack
                              (map tree-analysis-init analyses))
@@ -618,15 +616,6 @@ accurate information is missing from a given `tree-il' element."
 (define unused-variable-analysis
   ;; Report unused variables in the given tree.
   (make-tree-analysis
-   (lambda (x info env locs)
-     ;; X is a leaf: extend INFO's refs accordingly.
-     (let ((refs (binding-info-refs info))
-           (vars (binding-info-vars info)))
-       (record-case x
-         ((<lexical-ref> gensym)
-          (make-binding-info vars (vhash-consq gensym #t refs)))
-         (else info))))
-
    (lambda (x info env locs)
      ;; Going down into X: extend INFO's variable list
      ;; accordingly.
@@ -641,6 +630,8 @@ accurate information is missing from a given `tree-il' element."
                inner-names))
 
        (record-case x
+         ((<lexical-ref> gensym)
+          (make-binding-info vars (vhash-consq gensym #t refs)))
          ((<lexical-set> gensym)
           (make-binding-info vars (vhash-consq gensym #t refs)))
          ((<lambda-case> req opt inits rest kw gensyms)
@@ -789,20 +780,14 @@ accurate information is missing from a given `tree-il' element."
                   (macro? (variable-ref var))))))
 
     (make-tree-analysis
-     (lambda (x graph env locs)
-       ;; X is a leaf.
-       (let ((ctx (reference-graph-toplevel-context graph)))
-         (record-case x
-           ((<toplevel-ref> name src)
-            (add-ref-from-context graph name))
-           (else graph))))
-
      (lambda (x graph env locs)
        ;; Going down into X.
        (let ((ctx  (reference-graph-toplevel-context graph))
              (refs (reference-graph-refs graph))
              (defs (reference-graph-defs graph)))
          (record-case x
+           ((<toplevel-ref> name src)
+            (add-ref-from-context graph name))
            ((<toplevel-define> name src)
             (let ((refs refs)
                   (defs (vhash-consq name (or src (find pair? locs))
@@ -895,9 +880,10 @@ accurate information is missing from a given `tree-il' element."
   ;; Report possibly unbound variables in the given tree.
   (make-tree-analysis
    (lambda (x info env locs)
-     ;; X is a leaf: extend INFO's refs accordingly.
+     ;; Going down into X.
-     (let ((refs (toplevel-info-refs info))
+     (let* ((refs (toplevel-info-refs info))
-           (defs (toplevel-info-defs info)))
+            (defs (toplevel-info-defs info))
+            (src  (tree-il-src x)))
        (define (bound? name)
          (or (and (module? env)
                   (module-variable env name))
@@ -910,19 +896,6 @@ accurate information is missing from a given `tree-il' element."
               (let ((src (or src (find pair? locs))))
                 (make-toplevel-info (vhash-consq name src refs)
                                     defs))))
-         (else info))))
-
-   (lambda (x info env locs)
-     ;; Going down into X.
-     (let* ((refs (toplevel-info-refs info))
-            (defs (toplevel-info-defs info))
-            (src  (tree-il-src x)))
-       (define (bound? name)
-         (or (and (module? env)
-                  (module-variable env name))
-             (vhash-assq name defs)))
-
-       (record-case x
          ((<toplevel-set> name src)
           (if (bound? name)
               (make-toplevel-info refs defs)
@@ -1069,9 +1042,6 @@ accurate information is missing from a given `tree-il' element."
 (define arity-analysis
   ;; Report arity mismatches in the given tree.
   (make-tree-analysis
-   (lambda (x info env locs)
-     ;; X is a leaf.
-     info)
    (lambda (x info env locs)
      ;; Down into X.
      (define (extend lexical-name val info)
@@ -1417,10 +1387,6 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
 (define format-analysis
   ;; Report arity mismatches in the given tree.
   (make-tree-analysis
-   (lambda (x _ env locs)
-     ;; X is a leaf.
-     #t)
-
    (lambda (x _ env locs)
      ;; Down into X.
      (define (check-format-args args loc)

module/language/tree-il/canonicalize.scm

@@ -27,8 +27,6 @@
 (define (tree-il-any proc exp)
   (tree-il-fold (lambda (exp res)
                   (or res (proc exp)))
-                (lambda (exp res)
-                  (or res (proc exp)))
                 (lambda (exp res) res)
                 #f exp))
 

module/language/tree-il/cse.scm

@@ -130,8 +130,6 @@
 ;;
 (define* (build-assigned-var-table exp #:optional (table vlist-null))
   (tree-il-fold
-   (lambda (exp res)
-     res)
    (lambda (exp res)
      (match exp
        (($ <lexical-set> src name gensym exp)

module/language/tree-il/peval.scm

@@ -79,9 +79,6 @@
     (tree-il-fold (lambda (exp res)
                     (let ((res (proc exp)))
                       (if res (k res) #f)))
-                  (lambda (exp res)
-                    (let ((res (proc exp)))
-                      (if res (k res) #f)))
                   (lambda (exp res) #f)
                   #f exp)))
 
@@ -132,9 +129,6 @@
         (let ((var (cdr (vhash-assq gensym res))))
           (set-var-refcount! var (1+ (var-refcount var)))
           res))
-       (_ res)))
-   (lambda (exp res)
-     (match exp
        (($ <lambda-case> src req opt rest kw init gensyms body alt)
         (fold (lambda (name sym res)
                 (vhash-consq sym (make-var name sym 0 #f) res))
@@ -666,8 +660,6 @@ top-level bindings from ENV and return the resulting expression."
   (define (small-expression? x limit)
     (let/ec k
       (tree-il-fold
-       (lambda (x res)                  ; leaf
-         (1+ res))
        (lambda (x res)                  ; down
          (1+ res))
        (lambda (x res)                  ; up

test-suite/tests/tree-il.test

@@ -722,24 +722,19 @@
 
 (with-test-prefix "tree-il-fold"
 
-  (pass-if "empty tree"
+  (pass-if "void"
-    (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+    (let ((up 0) (down 0) (mark (list 'mark)))
       (and (eq? mark
-                (tree-il-fold (lambda (x y) (set! leaf? #t) y)
+                (tree-il-fold (lambda (x y) (set! down (1+ down)) y)
-                              (lambda (x y) (set! down? #t) y)
+                              (lambda (x y) (set! up (1+ up)) y)
-                              (lambda (x y) (set! up? #t) y)
                               mark
-                              '()))
+                              (make-void #f)))
-           (not leaf?)
+           (= up 1)
-           (not up?)
+           (= down 1))))
-           (not down?))))
 
   (pass-if "lambda and application"
-    (let* ((leaves '()) (ups '()) (downs '())
+    (let* ((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)
@@ -754,13 +749,15 @@
                                              (lexical x x1)
                                              (lexical y y1)))
                                       #f))))))
-      (and (equal? (map strip-source leaves)
+      (and (= result 12)
-                   (list (make-lexical-ref #f 'y 'y1)
+           (equal? (map strip-source (list-head (reverse ups) 3))
+                   (list (make-toplevel-ref #f '+)
                          (make-lexical-ref #f 'x 'x1)
-                         (make-toplevel-ref #f '+)))
+                         (make-lexical-ref #f 'y 'y1)))
-           (= (length downs) 3)
+           (equal? (map strip-source (reverse (list-head downs 3)))
-           (equal? (reverse (map strip-source ups))
+                   (list (make-toplevel-ref #f '+)
-                   (map strip-source downs))))))
+                         (make-lexical-ref #f 'x 'x1)
+                         (make-lexical-ref #f 'y 'y1)))))))
 
 
 ;;;