- (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)
- (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)))
+ (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))