-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 2009, 2010, 2011, 2012 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
+;;;;
\f
(define-module (language tree-il)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
<toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
<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-then conditional-else
+ <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
- <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
- <let> let? make-let let-src let-names let-vars let-vals let-body
- <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
- <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
-
+ <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
+ <lambda-case> lambda-case? make-lambda-case lambda-case-src
+ lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
+ lambda-case-inits lambda-case-gensyms
+ lambda-case-body lambda-case-alternate
+ <let> let? make-let let-src let-names let-gensyms let-vals let-body
+ <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
+ <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+
parse-tree-il
unparse-tree-il
tree-il->scheme
+ tree-il-fold
+ make-tree-il-folder
post-order!
pre-order!))
-(define-type (<tree-il> #:common-slots (src))
- (<void>)
- (<const> exp)
- (<primitive-ref> name)
- (<lexical-ref> name gensym)
- (<lexical-set> name gensym exp)
- (<module-ref> mod name public?)
- (<module-set> mod name public? exp)
- (<toplevel-ref> name)
- (<toplevel-set> name exp)
- (<toplevel-define> name exp)
- (<conditional> test then else)
- (<application> proc args)
- (<sequence> exps)
- (<lambda> names vars meta body)
- (<let> names vars vals body)
- (<letrec> names vars vals body)
- (<let-values> names vars exp body))
-
+(define (print-tree-il exp port)
+ (format port "#<tree-il ~S>" (unparse-tree-il exp)))
+
+(define-syntax borrow-core-vtables
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ (let lp ((n 0) (out '()))
+ (if (< n (vector-length %expanded-vtables))
+ (lp (1+ n)
+ (let* ((vtable (vector-ref %expanded-vtables n))
+ (stem (struct-ref vtable (+ vtable-offset-user 0)))
+ (fields (struct-ref vtable (+ vtable-offset-user 2)))
+ (sfields (map
+ (lambda (f) (datum->syntax x f))
+ fields))
+ (type (datum->syntax x (symbol-append '< stem '>)))
+ (ctor (datum->syntax x (symbol-append 'make- stem)))
+ (pred (datum->syntax x (symbol-append stem '?))))
+ (let lp ((n 0) (fields fields)
+ (out (cons*
+ #`(define (#,ctor #,@sfields)
+ (make-struct #,type 0 #,@sfields))
+ #`(define (#,pred x)
+ (and (struct? x)
+ (eq? (struct-vtable x) #,type)))
+ #`(struct-set! #,type vtable-index-printer
+ print-tree-il)
+ #`(define #,type
+ (vector-ref %expanded-vtables #,n))
+ out)))
+ (if (null? fields)
+ out
+ (lp (1+ n)
+ (cdr fields)
+ (let ((acc (datum->syntax
+ x (symbol-append stem '- (car fields)))))
+ (cons #`(define #,acc
+ (make-procedure-with-setter
+ (lambda (x) (struct-ref x #,n))
+ (lambda (x v) (struct-set! x #,n v))))
+ out)))))))
+ #`(begin #,@(reverse out))))))))
+
+(borrow-core-vtables)
+
+ ;; (<void>)
+ ;; (<const> exp)
+ ;; (<primitive-ref> name)
+ ;; (<lexical-ref> name gensym)
+ ;; (<lexical-set> name gensym exp)
+ ;; (<module-ref> mod name public?)
+ ;; (<module-set> mod name public? exp)
+ ;; (<toplevel-ref> name)
+ ;; (<toplevel-set> name exp)
+ ;; (<toplevel-define> name exp)
+ ;; (<conditional> test consequent alternate)
+ ;; (<application> proc args)
+ ;; (<sequence> exps)
+ ;; (<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)
+ (<abort> tag args tail))
+
\f
(define (location x)
((apply ,proc . ,args)
(make-application loc (retrans proc) (map retrans args)))
- ((if ,test ,then ,else)
- (make-conditional loc (retrans test) (retrans then) (retrans else)))
+ ((if ,test ,consequent ,alternate)
+ (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
((primitive ,name) (guard (symbol? name))
(make-primitive-ref loc name))
((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
(make-lexical-ref loc name sym))
+ ((set! (lexical ,name) ,exp) (guard (symbol? name))
+ (make-lexical-set loc name name (retrans exp)))
+
((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
(make-lexical-set loc name sym (retrans exp)))
((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp)))
- ((lambda ,names ,vars ,exp)
- (make-lambda loc names vars '() (retrans exp)))
+ ((lambda ,meta ,body)
+ (make-lambda loc meta (retrans body)))
+
+ ((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 ,names ,vars ,meta ,exp)
- (make-lambda loc names vars meta (retrans exp)))
+ ((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)
(make-const loc exp))
((begin . ,exps)
(make-sequence loc (map retrans exps)))
- ((let ,names ,vars ,vals ,body)
- (make-let loc names vars (map retrans vals) (retrans body)))
+ ((let ,names ,gensyms ,vals ,body)
+ (make-let loc names gensyms (map retrans vals) (retrans body)))
+
+ ((letrec ,names ,gensyms ,vals ,body)
+ (make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
+
+ ((letrec* ,names ,gensyms ,vals ,body)
+ (make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
+
+ ((fix ,names ,gensyms ,vals ,body)
+ (make-fix loc names gensyms (map retrans vals) (retrans body)))
+
+ ((let-values ,exp ,body)
+ (make-let-values loc (retrans exp) (retrans body)))
- ((letrec ,names ,vars ,vals ,body)
- (make-letrec loc names vars (map retrans vals) (retrans body)))
+ ((dynwind ,winder ,body ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
- ((let-values ,names ,vars ,exp ,body)
- (make-let-values loc names vars (retrans exp) (retrans body)))
+ ((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)
+ (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
(else
(error "unrecognized tree-il" exp)))))
((<application> proc args)
`(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
- ((<conditional> test then else)
- `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
+ ((<conditional> test consequent alternate)
+ `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
((<primitive-ref> name)
`(primitive ,name))
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> names vars meta body)
- `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+ ((<lambda> meta body)
+ `(lambda ,meta ,(unparse-tree-il body)))
+
+ ((<lambda-case> 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 ,exp))
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
- ((<let> names vars vals body)
- `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<let> names gensyms vals body)
+ `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<letrec> names vars vals body)
- `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<letrec> in-order? names gensyms vals body)
+ `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
+ ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> names vars exp body)
- `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+ ((<fix> names gensyms vals body)
+ `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
-(define (tree-il->scheme e)
- (record-case e
- ((<void>)
- '(if #f #f))
+ ((<let-values> exp body)
+ `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<application> proc args)
- `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+ ((<dynwind> winder body unwinder)
+ `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
+ ,(unparse-tree-il unwinder)))
- ((<conditional> test then else)
- (if (void? else)
- `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
- `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
+ ((<dynlet> fluids vals body)
+ `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
+ ,(unparse-tree-il body)))
- ((<primitive-ref> name)
- name)
-
- ((<lexical-ref> name gensym)
- gensym)
-
- ((<lexical-set> name gensym exp)
- `(set! ,gensym ,(tree-il->scheme exp)))
-
- ((<module-ref> mod name public?)
- `(,(if public? '@ '@@) ,mod ,name))
-
- ((<module-set> mod name public? exp)
- `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
-
- ((<toplevel-ref> name)
- name)
-
- ((<toplevel-set> name exp)
- `(set! ,name ,(tree-il->scheme exp)))
-
- ((<toplevel-define> name exp)
- `(define ,name ,(tree-il->scheme exp)))
-
- ((<lambda> vars meta body)
- `(lambda ,vars
- ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
- ,(tree-il->scheme body)))
-
- ((<const> exp)
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp)))
-
- ((<sequence> exps)
- `(begin ,@(map tree-il->scheme exps)))
-
- ((<let> vars vals body)
- `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
-
- ((<letrec> vars vals body)
- `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
-
- ((<let-values> vars exp body)
- `(call-with-values (lambda () ,(tree-il->scheme exp))
- (lambda ,vars ,(tree-il->scheme body))))))
+ ((<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 ,(unparse-tree-il tag) ,(map unparse-tree-il args)
+ ,(unparse-tree-il tail)))))
+
+(define* (tree-il->scheme e #:optional (env #f) (opts '()))
+ (values ((@ (language scheme decompile-tree-il)
+ decompile-tree-il)
+ 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)
+ (up tree (loop body (down tree 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 ...)
+ (if (null? exps)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car exps) seed ...)))
+ (fold-values proc (cdr exps) seed ...))))
+ (let foldts ((tree tree) (seed seed) ...)
+ (let*-values
+ (((seed ...) (down tree seed ...))
+ ((seed ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (foldts exp seed ...))
+ ((<module-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-define> exp)
+ (foldts exp seed ...))
+ ((<conditional> test consequent alternate)
+ (let*-values (((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts consequent seed ...)))
+ (foldts alternate seed ...)))
+ ((<application> proc args)
+ (let-values (((seed ...) (foldts proc seed ...)))
+ (fold-values foldts args seed ...)))
+ ((<sequence> exps)
+ (fold-values foldts exps seed ...))
+ ((<lambda> body)
+ (foldts body seed ...))
+ ((<lambda-case> inits 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*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<fix> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<let-values> 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)
+ (let*-values (((seed ...) (foldts tag seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (foldts handler seed ...)))
+ ((<abort> 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))
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args)))
- ((<conditional> test then else)
+ ((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
- (set! (conditional-then x) (lp then))
- (set! (conditional-else x) (lp else)))
-
+ (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> vars meta body)
+
+ ((<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))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
-
- ((<let> vars vals body)
+
+ ((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
-
- ((<letrec> vars vals body)
+
+ ((<letrec> gensyms vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
-
- ((<let-values> vars exp body)
+
+ ((<fix> gensyms 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))
-
+
(or (f x) x)))
(define (pre-order! f x)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args)))
- ((<conditional> test then else)
+ ((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
- (set! (conditional-then x) (lp then))
- (set! (conditional-else x) (lp else)))
+ (set! (conditional-consequent x) (lp consequent))
+ (set! (conditional-alternate x) (lp alternate)))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> exp)
(set! (lexical-set-exp x) (lp exp)))
-
- ((<module-set> mod name public? exp)
+
+ ((<module-set> exp)
(set! (module-set-exp x) (lp exp)))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(set! (toplevel-set-exp x) (lp exp)))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<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))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
- ((<let> vars vals body)
+ ((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
- ((<letrec> vars vals body)
+ ((<letrec> vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
- ((<let-values> vars exp 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)))
HCoop / bpt / guile.git / blobdiff