summaryrefslogtreecommitdiff
path: root/module/language/tree-il.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-28 11:02:25 -0400
committerAndy Wingo <wingo@pobox.com>2013-06-10 22:46:08 +0200
commit25450a0d0e03ab55ca48fd9996e966d213f9b435 (patch)
tree5f0ff6aa0e733e4596617e13fb93a94e934ce8c7 /module/language/tree-il.scm
parent403d78f915552a6eaaf2ecd7a93b2a7dc2983585 (diff)
downloadguile-25450a0d0e03ab55ca48fd9996e966d213f9b435.tar.gz
Pre-order tree-il rewrites are now non-destructive
* module/language/tree-il.scm (pre-order): Re-implement in terms of pre-post-order, and rename from pre-order!. * module/language/tree-il/primitives.scm (expand-primitives): Adapt to pre-order change, and rename from expand-primitives!. * module/language/tree-il/optimize.scm (optimize): Adapt to expand-primitives! change, and rename from optimize!. * module/language/tree-il/compile-glil.scm: * module/system/repl/common.scm: * test-suite/tests/cse.test: * test-suite/tests/peval.test: * test-suite/tests/tree-il.test: Adapt to expand-primitives and optimize changes.
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r--module/language/tree-il.scm92
1 files changed, 3 insertions, 89 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index b5b7807bd..0a5b72ae9 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -62,7 +62,7 @@
tree-il-fold
make-tree-il-folder
post-order
- pre-order!
+ pre-order
tree-il=?
tree-il-hash))
@@ -616,94 +616,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
(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)