-;;;; 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
(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
<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
<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))
;; (<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))
\f
+;; A helper.
+(define (list->seq loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+\f
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(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)))))
e env opts)))
\f
-(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 ...)
(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)
HCoop / bpt / guile.git / blobdiff