X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/403d78f915552a6eaaf2ecd7a93b2a7dc2983585..c4a209b96ff7ea75d3d74aa956223768a352d6d9:/module/language/tree-il.scm

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index b5b7807bd..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
 
@@ -39,6 +39,7 @@
             <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
@@ -46,11 +47,7 @@
             <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-pre dynwind-body dynwind-post 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
@@ -62,7 +59,7 @@
             tree-il-fold
             make-tree-il-folder
             post-order
-            pre-order!
+            pre-order
 
             tree-il=?
             tree-il-hash))
@@ -131,15 +128,11 @@
   ;; (<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 pre body post unwinder)
-  (<dynref> fluid)
-  (<dynset> fluid exp)
-  (<prompt> tag body handler)
+  (<prompt> escape-only? tag body handler)
   (<abort> tag args tail))
 
 
@@ -160,204 +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))
 
-     ((call ,proc . ,args)
+     (('call proc . args)
       (make-call loc (retrans proc) (map retrans args)))
 
-     ((primcall ,name . ,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))
 
-     ((seq ,head ,tail)
+     (('seq head tail)
       (make-seq loc (retrans head) (retrans tail)))
 
      ;; Convenience.
-     ((begin . ,exps)
+     (('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 ,pre ,body ,post ,unwinder)
-      (make-dynwind loc (retrans winder) (retrans pre)
-                    (retrans body)
-                    (retrans post) (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))
 
-    ((<call> proc args)
+    (($ <call> src proc args)
      `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 
-    ((<primcall> name 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))
 
-    ((<seq> head tail)
+    (($ <seq> src head tail)
      `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
     
-    ((<let> names gensyms vals body)
+    (($ <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 pre body post unwinder)
-     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
-               ,(unparse-tree-il body)
-               ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
-
-    ((<dynlet> fluids vals body)
-     `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
-              ,(unparse-tree-il body)))
+    (($ <prompt> src escape-only? tag body handler)
+     `(prompt ,escape-only?
+              ,(unparse-tree-il tag)
+              ,(unparse-tree-il body)
+              ,(unparse-tree-il handler)))
 
-    ((<dynref> fluid)
-     `(dynref ,(unparse-tree-il fluid)))
-
-    ((<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)))))
 
@@ -367,87 +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
-``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 ...)
@@ -459,251 +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 ...)))
-              ((<call> proc args)
+              (($ <call> src proc args)
                (let-values (((seed ...) (foldts proc seed ...)))
                  (fold-values foldts args seed ...)))
-              ((<primcall> name args)
+              (($ <primcall> src name args)
                (fold-values foldts args seed ...))
-              ((<seq> head tail)
+              (($ <seq> src head tail)
                (let-values (((seed ...) (foldts head seed ...)))
                  (foldts tail seed ...)))
-              ((<lambda> body)
+              (($ <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> winder pre body post unwinder)
-               (let*-values (((seed ...) (foldts winder seed ...))
-                             ((seed ...) (foldts pre seed ...))
-                             ((seed ...) (foldts body seed ...))
-                             ((seed ...) (foldts post 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 (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)
+  (define (elts-eq? a b)
+    (or (null? a)
+        (and (eq? (car a) (car b))
+             (elts-eq? (cdr a) (cdr b)))))
   (let lp ((x x))
     (post
-     (record-case (pre x)
-       ((<void> src)
-        (make-void src))
-
-       ((<const> src exp)
-        (make-const src exp))
-
-       ((<primitive-ref> src name)
-        (make-primitive-ref src name))
-
-       ((<lexical-ref> src name gensym)
-        (make-lexical-ref src name gensym))
-
-       ((<lexical-set> src name gensym exp)
-        (make-lexical-set src name gensym (lp exp)))
-
-       ((<module-ref> src mod name public?)
-        (make-module-ref src mod name public?))
-
-       ((<module-set> src mod name public? exp)
-        (make-module-set src mod name public? (lp exp)))
-
-       ((<toplevel-ref> src name)
-        (make-toplevel-ref src name))
-
-       ((<toplevel-set> src name exp)
-        (make-toplevel-set src name (lp exp)))
-
-       ((<toplevel-define> src name exp)
-        (make-toplevel-define src name (lp exp)))
-
-       ((<conditional> src test consequent alternate)
-        (make-conditional src (lp test) (lp consequent) (lp alternate)))
-
-       ((<call> src proc args)
-        (make-call src (lp proc) (map lp args)))
-
-       ((<primcall> src name args)
-        (make-primcall src name (map lp args)))
-
-       ((<seq> src head tail)
-        (make-seq src (lp head) (lp tail)))
+     (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)
-        (make-lambda src meta (and body (lp body))))
-
-       ((<lambda-case> src req opt rest kw inits gensyms body alternate)
-        (make-lambda-case src req opt rest kw (map lp inits) gensyms (lp body)
-                          (and alternate (lp alternate))))
-
-       ((<let> src names gensyms vals body)
-        (make-let src names gensyms (map lp vals) (lp body)))
-
-       ((<letrec> src in-order? names gensyms vals body)
-        (make-letrec src in-order? names gensyms (map lp vals) (lp body)))
-
-       ((<fix> src names gensyms vals body)
-        (make-fix src names gensyms (map lp vals) (lp body)))
-
-       ((<let-values> src exp body)
-        (make-let-values src (lp exp) (lp body)))
-
-       ((<dynwind> src winder pre body post unwinder)
-        (make-dynwind src
-                      (lp winder) (lp pre) (lp body) (lp post) (lp unwinder)))
-
-       ((<dynlet> src fluids vals body)
-        (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
-
-       ((<dynref> src fluid)
-        (make-dynref src (lp fluid)))
-
-       ((<dynset> src fluid exp)
-        (make-dynset src (lp fluid) (lp exp)))
-
-       ((<prompt> src tag body handler)
-        (make-prompt src (lp tag) (lp body) (lp handler)))
-
-       ((<abort> src tag args tail)
-        (make-abort src (lp tag) (map lp args) (lp 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)
-  (let lp ((x x))
-    (let ((x (or (f x) x)))
-      (record-case x
-        ((<call> proc args)
-         (set! (call-proc x) (lp proc))
-         (set! (call-args x) (map lp args)))
-
-        ((<primcall> name args)
-         (set! (primcall-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))))
-
-        ((<seq> head tail)
-         (set! (seq-head x) (lp head))
-         (set! (seq-tail x) (lp tail)))
-        
-        ((<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> winder pre body post unwinder)
-         (set! (dynwind-winder x) (lp winder))
-         (set! (dynwind-pre x) (lp pre))
-         (set! (dynwind-body x) (lp body))
-         (set! (dynwind-post x) (lp post))
-         (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)))
+(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)