diff options
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r-- | module/language/tree-il.scm | 539 |
1 files changed, 186 insertions, 353 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index aa00b381e..4ae1484cb 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -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))) - ((if ,test ,consequent ,alternate) + (('primcall name . args) + (make-primcall loc name (map retrans args))) + + (('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,151 @@ 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) +(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) (let lp ((x x)) - (record-case x - ((<application> proc args) - (set! (application-proc x) (lp proc)) - (set! (application-args x) (map lp args))) + (post + (match (pre x) + (($ <void> src) + (make-void src)) - ((<conditional> test consequent alternate) - (set! (conditional-test x) (lp test)) - (set! (conditional-consequent x) (lp consequent)) - (set! (conditional-alternate x) (lp alternate))) + (($ <const> src exp) + (make-const src exp)) - ((<lexical-set> name gensym exp) - (set! (lexical-set-exp x) (lp exp))) + (($ <primitive-ref> src name) + (make-primitive-ref src name)) - ((<module-set> mod name public? exp) - (set! (module-set-exp x) (lp exp))) + (($ <lexical-ref> src name gensym) + (make-lexical-ref src name gensym)) - ((<toplevel-set> name exp) - (set! (toplevel-set-exp x) (lp exp))) + (($ <lexical-set> src name gensym exp) + (make-lexical-set src name gensym (lp exp))) - ((<toplevel-define> name exp) - (set! (toplevel-define-exp x) (lp exp))) + (($ <module-ref> src mod name public?) + (make-module-ref src mod name public?)) - ((<lambda> body) - (if body - (set! (lambda-body x) (lp body)))) + (($ <module-set> src mod name public? exp) + (make-module-set src mod name public? (lp exp))) - ((<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)))) + (($ <toplevel-ref> src name) + (make-toplevel-ref src name)) - ((<sequence> exps) - (set! (sequence-exps x) (map lp exps))) + (($ <toplevel-set> src name exp) + (make-toplevel-set src name (lp exp))) - ((<let> gensyms vals body) - (set! (let-vals x) (map lp vals)) - (set! (let-body x) (lp body))) + (($ <toplevel-define> src name exp) + (make-toplevel-define src name (lp exp))) - ((<letrec> gensyms vals body) - (set! (letrec-vals x) (map lp vals)) - (set! (letrec-body x) (lp body))) + (($ <conditional> src test consequent alternate) + (make-conditional src (lp test) (lp consequent) (lp alternate))) - ((<fix> gensyms vals body) - (set! (fix-vals x) (map lp vals)) - (set! (fix-body x) (lp body))) + (($ <call> src proc args) + (make-call src (lp proc) (map lp args))) - ((<let-values> exp body) - (set! (let-values-exp x) (lp exp)) - (set! (let-values-body x) (lp body))) + (($ <primcall> src name args) + (make-primcall src name (map lp args))) - ((<dynwind> body winder unwinder) - (set! (dynwind-body x) (lp body)) - (set! (dynwind-winder x) (lp winder)) - (set! (dynwind-unwinder x) (lp unwinder))) + (($ <seq> src head tail) + (make-seq src (lp head) (lp tail))) + + (($ <lambda> src meta body) + (make-lambda src meta (and body (lp body)))) - ((<dynlet> fluids vals body) - (set! (dynlet-fluids x) (map lp fluids)) - (set! (dynlet-vals x) (map lp vals)) - (set! (dynlet-body x) (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)))) - ((<dynref> fluid) - (set! (dynref-fluid x) (lp fluid))) + (($ <let> src names gensyms vals body) + (make-let src names gensyms (map lp vals) (lp body))) - ((<dynset> fluid exp) - (set! (dynset-fluid x) (lp fluid)) - (set! (dynset-exp x) (lp exp))) + (($ <letrec> src in-order? names gensyms vals body) + (make-letrec src in-order? names gensyms (map lp vals) (lp body))) - ((<prompt> tag body handler) - (set! (prompt-tag x) (lp tag)) - (set! (prompt-body x) (lp body)) - (set! (prompt-handler x) (lp handler))) + (($ <fix> src names gensyms vals body) + (make-fix src names gensyms (map lp vals) (lp body))) - ((<abort> tag args tail) - (set! (abort-tag x) (lp tag)) - (set! (abort-args x) (map lp args)) - (set! (abort-tail x) (lp tail))) + (($ <let-values> src exp body) + (make-let-values src (lp exp) (lp body))) - (else #f)) + (($ <prompt> src escape-only? tag body handler) + (make-prompt src escape-only? (lp tag) (lp body) (lp handler))) - (or (f x) x))) + (($ <abort> src tag args tail) + (make-abort src (lp tag) (map lp args) (lp tail))))))) -(define (pre-order! f x) - (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))) +(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) |