1 files changed, 39 insertions, 61 deletions

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 8ad7065c6..ad8b73176 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -327,73 +327,51 @@ This is an implementation of `foldts' as described by Andy Wingo in
 (define-syntax make-tree-il-folder
   (syntax-rules ()
     ((_ seed ...)
-     (lambda (tree down up leaf seed ...)
+     (lambda (tree down up 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 ...))))))))
-
+         (let*-values
+             (((seed ...) (down tree seed ...))
+              ((seed ...)
+               (record-case tree
+                 ((<lexical-set> exp)
+                  (foldts exp seed ...))
+                 ((<module-set> exp)
+                  (foldts exp seed ...))
+                 ((<toplevel-set> exp)
+                  (foldts exp seed ...))
+                 ((<toplevel-define> exp)
+                  (foldts exp seed ...))
+                 ((<conditional> test then else)
+                  (let*-values (((seed ...) (foldts test seed ...))
+                                ((seed ...) (foldts then seed ...)))
+                    (foldts else seed ...)))
+                 ((<application> proc args)
+                  (let-values (((seed ...) (foldts proc seed ...)))
+                    (fold-values foldts args seed ...)))
+                 ((<sequence> exps)
+                  (fold-values foldts exps seed ...))
+                 ((<lambda> body)
+                  (foldts body seed ...))
+                 ((<let> vals body)
+                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                    (foldts body seed ...)))
+                 ((<letrec> vals body)
+                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                    (foldts body seed ...)))
+                 ((<fix> vals body)
+                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                    (foldts body seed ...)))
+                 ((<let-values> exp body)
+                  (let*-values (((seed ...) (foldts exp seed ...)))
+                    (foldts body seed ...)))
+                 (else
+                  (values seed ...)))))
+           (up tree seed ...)))))))
 
 (define (post-order! f x)
   (let lp ((x x))