X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/19113f1ca7a747de06d7b43c6c1eca4cd58d05e5..f4af36aca47f7d0653b997986e8be9894bbd87ff:/module/language/tree-il.scm

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aa00b381e..dcd03466a 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -19,7 +19,7 @@
 (define-module (language tree-il)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
-  #:use-module (system base pmatch)
+  #:use-module (ice-9 match)
   #:use-module (system base syntax)
   #:export (tree-il-src
 
@@ -34,10 +34,12 @@
             <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
             <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
             <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
-            <application> application? make-application application-src application-proc application-args
-            <sequence> sequence? make-sequence sequence-src sequence-exps
+            <call> call? make-call call-src call-proc call-args
+            <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
+            <seq> seq? make-seq seq-src seq-head seq-tail
             <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
             <lambda-case> lambda-case? make-lambda-case lambda-case-src
+            ;; idea: arity
                           lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
                           lambda-case-inits lambda-case-gensyms
                           lambda-case-body lambda-case-alternate
@@ -45,21 +47,19 @@
             <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
             <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
             <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
-            <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
-            <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
-            <dynref> dynref? make-dynref dynref-src dynref-fluid
-            <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
-            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
+            <prompt> prompt? make-prompt prompt-src prompt-escape-only? prompt-tag prompt-body prompt-handler
             <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
 
+            list->seq
+
             parse-tree-il
             unparse-tree-il
             tree-il->scheme
 
             tree-il-fold
             make-tree-il-folder
-            post-order!
-            pre-order!
+            post-order
+            pre-order
 
             tree-il=?
             tree-il-hash))
@@ -121,25 +121,30 @@
   ;; (<toplevel-set> name exp)
   ;; (<toplevel-define> name exp)
   ;; (<conditional> test consequent alternate)
-  ;; (<application> proc args)
-  ;; (<sequence> exps)
+  ;; (<call> proc args)
+  ;; (<primcall> name args)
+  ;; (<seq> head tail)
   ;; (<lambda> meta body)
   ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
   ;; (<let> names gensyms vals body)
   ;; (<letrec> in-order? names gensyms vals body)
-  ;; (<dynlet> fluids vals body)
 
 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
   (<fix> names gensyms vals body)
   (<let-values> exp body)
-  (<dynwind> winder body unwinder)
-  (<dynref> fluid)
-  (<dynset> fluid exp)
-  (<prompt> tag body handler)
+  (<prompt> escape-only? tag body handler)
   (<abort> tag args tail))
 
 
 
+;; A helper.
+(define (list->seq loc exps)
+  (if (null? (cdr exps))
+      (car exps)
+      (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+
+
 (define (location x)
   (and (pair? x)
        (let ((props (source-properties x)))
@@ -148,191 +153,181 @@
 (define (parse-tree-il exp)
   (let ((loc (location exp))
         (retrans (lambda (x) (parse-tree-il x))))
-    (pmatch exp
-     ((void)
+    (match exp
+     (('void)
       (make-void loc))
 
-     ((apply ,proc . ,args)
-      (make-application loc (retrans proc) (map retrans args)))
+     (('call proc . args)
+      (make-call loc (retrans proc) (map retrans args)))
+
+     (('primcall name . args)
+      (make-primcall loc name (map retrans args)))
 
-     ((if ,test ,consequent ,alternate)
+     (('if test consequent alternate)
       (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
 
-     ((primitive ,name) (guard (symbol? name))
+     (('primitive (and name (? symbol?)))
       (make-primitive-ref loc name))
 
-     ((lexical ,name) (guard (symbol? name))
+     (('lexical (and name (? symbol?)))
       (make-lexical-ref loc name name))
 
-     ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+     (('lexical (and name (? symbol?)) (and sym (? symbol?)))
       (make-lexical-ref loc name sym))
 
-     ((set! (lexical ,name) ,exp) (guard (symbol? name))
+     (('set! ('lexical (and name (? symbol?))) exp)
       (make-lexical-set loc name name (retrans exp)))
 
-     ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+     (('set! ('lexical (and name (? symbol?)) (and sym (? symbol?))) exp)
       (make-lexical-set loc name sym (retrans exp)))
 
-     ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+     (('@ ((and mod (? symbol?)) ...) (and name (? symbol?)))
       (make-module-ref loc mod name #t))
 
-     ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+     (('set! ('@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp)
       (make-module-set loc mod name #t (retrans exp)))
 
-     ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+     (('@@ ((and mod (? symbol?)) ...) (and name (? symbol?)))
       (make-module-ref loc mod name #f))
 
-     ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+     (('set! ('@@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp)
       (make-module-set loc mod name #f (retrans exp)))
 
-     ((toplevel ,name) (guard (symbol? name))
+     (('toplevel (and name (? symbol?)))
       (make-toplevel-ref loc name))
 
-     ((set! (toplevel ,name) ,exp) (guard (symbol? name))
+     (('set! ('toplevel (and name (? symbol?))) exp)
       (make-toplevel-set loc name (retrans exp)))
 
-     ((define ,name ,exp) (guard (symbol? name))
+     (('define (and name (? symbol?)) exp)
       (make-toplevel-define loc name (retrans exp)))
 
-     ((lambda ,meta ,body)
+     (('lambda meta body)
       (make-lambda loc meta (retrans body)))
 
-     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
+     (('lambda-case ((req opt rest kw inits gensyms) body) alternate)
       (make-lambda-case loc req opt rest kw
                         (map retrans inits) gensyms
                         (retrans body)
                         (and=> alternate retrans)))
 
-     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
+     (('lambda-case ((req opt rest kw inits gensyms) body))
       (make-lambda-case loc req opt rest kw
                         (map retrans inits) gensyms
                         (retrans body)
                         #f))
 
-     ((const ,exp)
+     (('const exp)
       (make-const loc exp))
 
-     ((begin . ,exps)
-      (make-sequence loc (map retrans exps)))
+     (('seq head tail)
+      (make-seq loc (retrans head) (retrans tail)))
+
+     ;; Convenience.
+     (('begin . exps)
+      (list->seq loc (map retrans exps)))
 
-     ((let ,names ,gensyms ,vals ,body)
+     (('let names gensyms vals body)
       (make-let loc names gensyms (map retrans vals) (retrans body)))
 
-     ((letrec ,names ,gensyms ,vals ,body)
+     (('letrec names gensyms vals body)
       (make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
 
-     ((letrec* ,names ,gensyms ,vals ,body)
+     (('letrec* names gensyms vals body)
       (make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
 
-     ((fix ,names ,gensyms ,vals ,body)
+     (('fix names gensyms vals body)
       (make-fix loc names gensyms (map retrans vals) (retrans body)))
 
-     ((let-values ,exp ,body)
+     (('let-values exp body)
       (make-let-values loc (retrans exp) (retrans body)))
 
-     ((dynwind ,winder ,body ,unwinder)
-      (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
-
-     ((dynlet ,fluids ,vals ,body)
-      (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
-
-     ((dynref ,fluid)
-      (make-dynref loc (retrans fluid)))
-
-     ((dynset ,fluid ,exp)
-      (make-dynset loc (retrans fluid) (retrans exp)))
-
-     ((prompt ,tag ,body ,handler)
-      (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
-
-     ((abort ,tag ,args ,tail)
+     (('prompt escape-only? tag body handler)
+      (make-prompt loc escape-only?
+                   (retrans tag) (retrans body) (retrans handler)))
+     
+     (('abort tag args tail)
       (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
 
      (else
       (error "unrecognized tree-il" exp)))))
 
 (define (unparse-tree-il tree-il)
-  (record-case tree-il
-    ((<void>)
+  (match tree-il
+    (($ <void> src)
      '(void))
 
-    ((<application> proc args)
-     `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+    (($ <call> src proc args)
+     `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+    (($ <primcall> src name args)
+     `(primcall ,name ,@(map unparse-tree-il args)))
 
-    ((<conditional> test consequent alternate)
-     `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
+    (($ <conditional> src test consequent alternate)
+     `(if ,(unparse-tree-il test)
+          ,(unparse-tree-il consequent)
+          ,(unparse-tree-il alternate)))
 
-    ((<primitive-ref> name)
+    (($ <primitive-ref> src name)
      `(primitive ,name))
 
-    ((<lexical-ref> name gensym)
+    (($ <lexical-ref> src name gensym)
      `(lexical ,name ,gensym))
 
-    ((<lexical-set> name gensym exp)
+    (($ <lexical-set> src name gensym exp)
      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 
-    ((<module-ref> mod name public?)
+    (($ <module-ref> src mod name public?)
      `(,(if public? '@ '@@) ,mod ,name))
 
-    ((<module-set> mod name public? exp)
+    (($ <module-set> src mod name public? exp)
      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 
-    ((<toplevel-ref> name)
+    (($ <toplevel-ref> src name)
      `(toplevel ,name))
 
-    ((<toplevel-set> name exp)
+    (($ <toplevel-set> src name exp)
      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 
-    ((<toplevel-define> name exp)
+    (($ <toplevel-define> src name exp)
      `(define ,name ,(unparse-tree-il exp)))
 
-    ((<lambda> meta body)
+    (($ <lambda> src meta body)
      (if body
          `(lambda ,meta ,(unparse-tree-il body))
          `(lambda ,meta (lambda-case))))
 
-    ((<lambda-case> req opt rest kw inits gensyms body alternate)
+    (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
      `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
                     ,(unparse-tree-il body))
                    . ,(if alternate (list (unparse-tree-il alternate)) '())))
 
-    ((<const> exp)
+    (($ <const> src exp)
      `(const ,exp))
 
-    ((<sequence> exps)
-     `(begin ,@(map unparse-tree-il exps)))
-
-    ((<let> names gensyms vals body)
+    (($ <seq> src head tail)
+     `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
+    
+    (($ <let> src names gensyms vals body)
      `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 
-    ((<letrec> in-order? names gensyms vals body)
+    (($ <letrec> src in-order? names gensyms vals body)
      `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
        ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 
-    ((<fix> names gensyms vals body)
+    (($ <fix> src names gensyms vals body)
      `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 
-    ((<let-values> exp body)
+    (($ <let-values> src exp body)
      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 
-    ((<dynwind> winder body unwinder)
-     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
-               ,(unparse-tree-il unwinder)))
-
-    ((<dynlet> fluids vals body)
-     `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
-              ,(unparse-tree-il body)))
-
-    ((<dynref> fluid)
-     `(dynref ,(unparse-tree-il fluid)))
+    (($ <prompt> src escape-only? tag body handler)
+     `(prompt ,escape-only?
+              ,(unparse-tree-il tag)
+              ,(unparse-tree-il body)
+              ,(unparse-tree-il handler)))
 
-    ((<dynset> fluid exp)
-     `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
-
-    ((<prompt> tag body handler)
-     `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
-
-    ((<abort> tag args tail)
+    (($ <abort> src tag args tail)
      `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
              ,(unparse-tree-il tail)))))
 
@@ -342,82 +337,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
-``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 consequent alternate)
-           (up tree (loop alternate
-                          (loop consequent
-                                (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)
-           (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> body winder unwinder)
-           (up tree (loop unwinder
-                          (loop winder
-                                (loop body (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 ...)
@@ -429,237 +348,222 @@ This is an implementation of `foldts' as described by Andy Wingo in
       (let*-values
           (((seed ...) (down tree seed ...))
            ((seed ...)
-            (record-case tree
-              ((<lexical-set> exp)
+            (match tree
+              (($ <lexical-set> src name gensym exp)
                (foldts exp seed ...))
-              ((<module-set> exp)
+              (($ <module-set> src mod name public? exp)
                (foldts exp seed ...))
-              ((<toplevel-set> exp)
+              (($ <toplevel-set> src name exp)
                (foldts exp seed ...))
-              ((<toplevel-define> exp)
+              (($ <toplevel-define> src name exp)
                (foldts exp seed ...))
-              ((<conditional> test consequent alternate)
+              (($ <conditional> src test consequent alternate)
                (let*-values (((seed ...) (foldts test seed ...))
                              ((seed ...) (foldts consequent seed ...)))
                  (foldts alternate seed ...)))
-              ((<application> proc args)
+              (($ <call> src proc args)
                (let-values (((seed ...) (foldts proc seed ...)))
                  (fold-values foldts args seed ...)))
-              ((<sequence> exps)
-               (fold-values foldts exps seed ...))
-              ((<lambda> body)
+              (($ <primcall> src name args)
+               (fold-values foldts args seed ...))
+              (($ <seq> src head tail)
+               (let-values (((seed ...) (foldts head seed ...)))
+                 (foldts tail seed ...)))
+              (($ <lambda> src meta body)
                (if body
                    (foldts body seed ...)
                    (values seed ...)))
-              ((<lambda-case> inits body alternate)
+              (($ <lambda-case> src req opt rest kw inits gensyms body
+                              alternate)
                (let-values (((seed ...) (fold-values foldts inits seed ...)))
                  (if alternate
                      (let-values (((seed ...) (foldts body seed ...)))
                        (foldts alternate seed ...))
                      (foldts body seed ...))))
-              ((<let> vals body)
+              (($ <let> src names gensyms vals body)
                (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                  (foldts body seed ...)))
-              ((<letrec> vals body)
+              (($ <letrec> src in-order? names gensyms vals body)
                (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                  (foldts body seed ...)))
-              ((<fix> vals body)
+              (($ <fix> src names gensyms vals body)
                (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                  (foldts body seed ...)))
-              ((<let-values> exp body)
+              (($ <let-values> src exp body)
                (let*-values (((seed ...) (foldts exp seed ...)))
                  (foldts body seed ...)))
-              ((<dynwind> body winder unwinder)
-               (let*-values (((seed ...) (foldts body seed ...))
-                             ((seed ...) (foldts winder seed ...)))
-                 (foldts unwinder seed ...)))
-              ((<dynlet> fluids vals body)
-               (let*-values (((seed ...) (fold-values foldts fluids seed ...))
-                             ((seed ...) (fold-values foldts vals seed ...)))
-                 (foldts body seed ...)))
-              ((<dynref> fluid)
-               (foldts fluid seed ...))
-              ((<dynset> fluid exp)
-               (let*-values (((seed ...) (foldts fluid seed ...)))
-                 (foldts exp seed ...)))
-              ((<prompt> tag body handler)
+              (($ <prompt> src escape-only? tag body handler)
                (let*-values (((seed ...) (foldts tag seed ...))
                              ((seed ...) (foldts body seed ...)))
                  (foldts handler seed ...)))
-              ((<abort> tag args tail)
+              (($ <abort> src tag args tail)
                (let*-values (((seed ...) (foldts tag seed ...))
                              ((seed ...) (fold-values foldts args seed ...)))
                  (foldts tail seed ...)))
-              (else
+              (_
                (values seed ...)))))
         (up tree seed ...)))))
 
-(define (post-order! f x)
-  (let lp ((x x))
-    (record-case x
-      ((<application> proc args)
-       (set! (application-proc x) (lp proc))
-       (set! (application-args x) (map lp args)))
-
-      ((<conditional> test consequent alternate)
-       (set! (conditional-test x) (lp test))
-       (set! (conditional-consequent x) (lp consequent))
-       (set! (conditional-alternate x) (lp alternate)))
-
-      ((<lexical-set> name gensym exp)
-       (set! (lexical-set-exp x) (lp exp)))
-
-      ((<module-set> mod name public? exp)
-       (set! (module-set-exp x) (lp exp)))
-
-      ((<toplevel-set> name exp)
-       (set! (toplevel-set-exp x) (lp exp)))
-
-      ((<toplevel-define> name exp)
-       (set! (toplevel-define-exp x) (lp exp)))
-
-      ((<lambda> body)
-       (if body
-           (set! (lambda-body x) (lp body))))
-
-      ((<lambda-case> inits body alternate)
-       (set! inits (map lp inits))
-       (set! (lambda-case-body x) (lp body))
-       (if alternate
-           (set! (lambda-case-alternate x) (lp alternate))))
-
-      ((<sequence> exps)
-       (set! (sequence-exps x) (map lp exps)))
-
-      ((<let> gensyms vals body)
-       (set! (let-vals x) (map lp vals))
-       (set! (let-body x) (lp body)))
-
-      ((<letrec> gensyms vals body)
-       (set! (letrec-vals x) (map lp vals))
-       (set! (letrec-body x) (lp body)))
-
-      ((<fix> gensyms vals body)
-       (set! (fix-vals x) (map lp vals))
-       (set! (fix-body x) (lp body)))
+(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.
 
-      ((<let-values> exp body)
-       (set! (let-values-exp x) (lp exp))
-       (set! (let-values-body x) (lp body)))
-
-      ((<dynwind> body winder unwinder)
-       (set! (dynwind-body x) (lp body))
-       (set! (dynwind-winder x) (lp winder))
-       (set! (dynwind-unwinder x) (lp unwinder)))
-
-      ((<dynlet> fluids vals body)
-       (set! (dynlet-fluids x) (map lp fluids))
-       (set! (dynlet-vals x) (map lp vals))
-       (set! (dynlet-body x) (lp body)))
-
-      ((<dynref> fluid)
-       (set! (dynref-fluid x) (lp fluid)))
-
-      ((<dynset> fluid exp)
-       (set! (dynset-fluid x) (lp fluid))
-       (set! (dynset-exp x) (lp exp)))
-
-      ((<prompt> tag body handler)
-       (set! (prompt-tag x) (lp tag))
-       (set! (prompt-body x) (lp body))
-       (set! (prompt-handler x) (lp handler)))
-
-      ((<abort> tag args tail)
-       (set! (abort-tag x) (lp tag))
-       (set! (abort-args x) (map lp args))
-       (set! (abort-tail x) (lp tail)))
-
-      (else #f))
-
-    (or (f x) x)))
-
-(define (pre-order! f x)
+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)
+  (define (elts-eq? a b)
+    (or (null? a)
+        (and (eq? (car a) (car b))
+             (elts-eq? (cdr a) (cdr b)))))
   (let lp ((x x))
-    (let ((x (or (f x) x)))
-      (record-case x
-        ((<application> proc args)
-         (set! (application-proc x) (lp proc))
-         (set! (application-args x) (map lp args)))
-
-        ((<conditional> test consequent alternate)
-         (set! (conditional-test x) (lp test))
-         (set! (conditional-consequent x) (lp consequent))
-         (set! (conditional-alternate x) (lp alternate)))
-
-        ((<lexical-set> exp)
-         (set! (lexical-set-exp x) (lp exp)))
-
-        ((<module-set> exp)
-         (set! (module-set-exp x) (lp exp)))
-
-        ((<toplevel-set> exp)
-         (set! (toplevel-set-exp x) (lp exp)))
-
-        ((<toplevel-define> exp)
-         (set! (toplevel-define-exp x) (lp exp)))
-
-        ((<lambda> body)
-         (if body
-             (set! (lambda-body x) (lp body))))
-
-        ((<lambda-case> inits body alternate)
-         (set! inits (map lp inits))
-         (set! (lambda-case-body x) (lp body))
-         (if alternate (set! (lambda-case-alternate x) (lp alternate))))
-
-        ((<sequence> exps)
-         (set! (sequence-exps x) (map lp exps)))
-
-        ((<let> vals body)
-         (set! (let-vals x) (map lp vals))
-         (set! (let-body x) (lp body)))
-
-        ((<letrec> vals body)
-         (set! (letrec-vals x) (map lp vals))
-         (set! (letrec-body x) (lp body)))
-
-        ((<fix> vals body)
-         (set! (fix-vals x) (map lp vals))
-         (set! (fix-body x) (lp body)))
-
-        ((<let-values> exp body)
-         (set! (let-values-exp x) (lp exp))
-         (set! (let-values-body x) (lp body)))
-
-        ((<dynwind> body winder unwinder)
-         (set! (dynwind-body x) (lp body))
-         (set! (dynwind-winder x) (lp winder))
-         (set! (dynwind-unwinder x) (lp unwinder)))
-
-        ((<dynlet> fluids vals body)
-         (set! (dynlet-fluids x) (map lp fluids))
-         (set! (dynlet-vals x) (map lp vals))
-         (set! (dynlet-body x) (lp body)))
-
-        ((<dynref> fluid)
-         (set! (dynref-fluid x) (lp fluid)))
-
-        ((<dynset> fluid exp)
-         (set! (dynset-fluid x) (lp fluid))
-         (set! (dynset-exp x) (lp exp)))
-
-        ((<prompt> tag body handler)
-         (set! (prompt-tag x) (lp tag))
-         (set! (prompt-body x) (lp body))
-         (set! (prompt-handler x) (lp handler)))
-
-        ((<abort> tag args tail)
-         (set! (abort-tag x) (lp tag))
-         (set! (abort-args x) (map lp args))
-         (set! (abort-tail x) (lp tail)))
-
-        (else #f))
-      x)))
+    (post
+     (let ((x (pre x)))
+       (match x
+         ((or ($ <void>)
+              ($ <const>)
+              ($ <primitive-ref>)
+              ($ <lexical-ref>)
+              ($ <module-ref>)
+              ($ <toplevel-ref>))
+          x)
+
+         (($ <lexical-set> src name gensym exp)
+          (let ((exp* (lp exp)))
+            (if (eq? exp exp*)
+                x
+                (make-lexical-set src name gensym exp*))))
+
+         (($ <module-set> src mod name public? exp)
+          (let ((exp* (lp exp)))
+            (if (eq? exp exp*)
+                x
+                (make-module-set src mod name public? exp*))))
+
+         (($ <toplevel-set> src name exp)
+          (let ((exp* (lp exp)))
+            (if (eq? exp exp*)
+                x
+                (make-toplevel-set src name exp*))))
+
+         (($ <toplevel-define> src name exp)
+          (let ((exp* (lp exp)))
+            (if (eq? exp exp*)
+                x
+                (make-toplevel-define src name exp*))))
+
+         (($ <conditional> src test consequent alternate)
+          (let ((test* (lp test))
+                (consequent* (lp consequent))
+                (alternate* (lp alternate)))
+            (if (and (eq? test test*)
+                     (eq? consequent consequent*)
+                     (eq? alternate alternate*))
+                x
+                (make-conditional src test* consequent* alternate*))))
+
+         (($ <call> src proc args)
+          (let ((proc* (lp proc))
+                (args* (map lp args)))
+            (if (and (eq? proc proc*)
+                     (elts-eq? args args*))
+                x
+                (make-call src proc* args*))))
+
+         (($ <primcall> src name args)
+          (let ((args* (map lp args)))
+            (if (elts-eq? args args*)
+                x
+                (make-primcall src name args*))))
+
+         (($ <seq> src head tail)
+          (let ((head* (lp head))
+                (tail* (lp tail)))
+            (if (and (eq? head head*)
+                     (eq? tail tail*))
+                x
+                (make-seq src head* tail*))))
+      
+         (($ <lambda> src meta body)
+          (let ((body* (and body (lp body))))
+            (if (eq? body body*)
+                x
+                (make-lambda src meta body*))))
+
+         (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+          (let ((inits* (map lp inits))
+                (body* (lp body))
+                (alternate* (and alternate (lp alternate))))
+            (if (and (elts-eq? inits inits*)
+                     (eq? body body*)
+                     (eq? alternate alternate*))
+                x
+                (make-lambda-case src req opt rest kw inits* gensyms body*
+                                  alternate*))))
+
+         (($ <let> src names gensyms vals body)
+          (let ((vals* (map lp vals))
+                (body* (lp body)))
+            (if (and (elts-eq? vals vals*)
+                     (eq? body body*))
+                x
+                (make-let src names gensyms vals* body*))))
+
+         (($ <letrec> src in-order? names gensyms vals body)
+          (let ((vals* (map lp vals))
+                (body* (lp body)))
+            (if (and (elts-eq? vals vals*)
+                     (eq? body body*))
+                x
+                (make-letrec src in-order? names gensyms vals* body*))))
+
+         (($ <fix> src names gensyms vals body)
+          (let ((vals* (map lp vals))
+                (body* (lp body)))
+            (if (and (elts-eq? vals vals*)
+                     (eq? body body*))
+                x
+                (make-fix src names gensyms vals* body*))))
+
+         (($ <let-values> src exp body)
+          (let ((exp* (lp exp))
+                (body* (lp body)))
+            (if (and (eq? exp exp*)
+                     (eq? body body*))
+                x
+                (make-let-values src exp* body*))))
+
+         (($ <prompt> src escape-only? tag body handler)
+          (let ((tag* (lp tag))
+                (body* (lp body))
+                (handler* (lp handler)))
+            (if (and (eq? tag tag*)
+                     (eq? body body*)
+                     (eq? handler handler*))
+                x
+                (make-prompt src escape-only? tag* body* handler*))))
+
+         (($ <abort> src tag args tail)
+          (let ((tag* (lp tag))
+                (args* (map lp args))
+                (tail* (lp tail)))
+            (if (and (eq? tag tag*)
+                     (elts-eq? args args*)
+                     (eq? tail tail*))
+                x
+                (make-abort src tag* args* tail*)))))))))
+
+(define (post-order f x)
+  (pre-post-order (lambda (x) x) f x))
+
+(define (pre-order f x)
+  (pre-post-order f (lambda (x) x) x))
 
 ;; FIXME: We should have a better primitive than this.
 (define (struct-nfields x)