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
-``Calls 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))))))
- ((<call> proc args)
- (up tree (loop (cons proc args) (down tree result))))
- ((<primcall> name args)
- (up tree (loop args (down tree result))))
- ((<seq> head tail)
- (up tree (loop tail (loop head (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> winder pre body post unwinder)
- (up tree (loop unwinder
- (loop post
- (loop body
- (loop pre
- (loop winder
- (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 ...)
(values seed ...)))))
(up tree seed ...)))))
+(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))
(post
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, 2013 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-record-type <tree-analysis>
- (make-tree-analysis leaf down up post init)
+ (make-tree-analysis down up post init)
tree-analysis?
- (leaf tree-analysis-leaf) ;; (lambda (x result env locs) ...)
(down tree-analysis-down) ;; (lambda (x result env locs) ...)
(up tree-analysis-up) ;; (lambda (x result env locs) ...)
(post tree-analysis-post) ;; (lambda (result env) ...)
(define (analyze-tree analyses tree env)
"Run all tree analyses listed in ANALYSES on TREE for ENV, using
-`tree-il-fold'. Return TREE. The leaf/down/up procedures of each analysis are
-passed a ``location stack', which is the stack of `tree-il-src' values for each
-parent tree (a list); it can be used to approximate source location when
-accurate information is missing from a given `tree-il' element."
+`tree-il-fold'. Return TREE. The down and up procedures of each
+analysis are passed a ``location stack', which is the stack of
+`tree-il-src' values for each parent tree (a list); it can be used to
+approximate source location when accurate information is missing from a
+given `tree-il' element."
(define (traverse proc update-locs)
;; Return a tree traversing procedure that returns a list of analysis
analyses
(cdr results))))))
- ;; Keeping/extending/shrinking the location stack.
- (define (keep-locs x locs) locs)
+ ;; Extending and shrinking the location stack.
(define (extend-locs x locs) (cons (tree-il-src x) locs))
(define (shrink-locs x locs) (cdr locs))
(let ((results
- (tree-il-fold (traverse tree-analysis-leaf keep-locs)
- (traverse tree-analysis-down extend-locs)
+ (tree-il-fold (traverse tree-analysis-down extend-locs)
(traverse tree-analysis-up shrink-locs)
(cons '() ;; empty location stack
(map tree-analysis-init analyses))
(define unused-variable-analysis
;; Report unused variables in the given tree.
(make-tree-analysis
- (lambda (x info env locs)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info)))
- (record-case x
- ((<lexical-ref> gensym)
- (make-binding-info vars (vhash-consq gensym #t refs)))
- (else info))))
-
(lambda (x info env locs)
;; Going down into X: extend INFO's variable list
;; accordingly.
inner-names))
(record-case x
+ ((<lexical-ref> gensym)
+ (make-binding-info vars (vhash-consq gensym #t refs)))
((<lexical-set> gensym)
(make-binding-info vars (vhash-consq gensym #t refs)))
((<lambda-case> req opt inits rest kw gensyms)
(macro? (variable-ref var))))))
(make-tree-analysis
- (lambda (x graph env locs)
- ;; X is a leaf.
- (let ((ctx (reference-graph-toplevel-context graph)))
- (record-case x
- ((<toplevel-ref> name src)
- (add-ref-from-context graph name))
- (else graph))))
-
(lambda (x graph env locs)
;; Going down into X.
(let ((ctx (reference-graph-toplevel-context graph))
(refs (reference-graph-refs graph))
(defs (reference-graph-defs graph)))
(record-case x
+ ((<toplevel-ref> name src)
+ (add-ref-from-context graph name))
((<toplevel-define> name src)
(let ((refs refs)
(defs (vhash-consq name (or src (find pair? locs))
;; Report possibly unbound variables in the given tree.
(make-tree-analysis
(lambda (x info env locs)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info)))
+ ;; Going down into X.
+ (let* ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (src (tree-il-src x)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
(let ((src (or src (find pair? locs))))
(make-toplevel-info (vhash-consq name src refs)
defs))))
- (else info))))
-
- (lambda (x info env locs)
- ;; Going down into X.
- (let* ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (src (tree-il-src x)))
- (define (bound? name)
- (or (and (module? env)
- (module-variable env name))
- (vhash-assq name defs)))
-
- (record-case x
((<toplevel-set> name src)
(if (bound? name)
(make-toplevel-info refs defs)
(define arity-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x info env locs)
- ;; X is a leaf.
- info)
(lambda (x info env locs)
;; Down into X.
(define (extend lexical-name val info)
(define format-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x _ env locs)
- ;; X is a leaf.
- #t)
-
(lambda (x _ env locs)
;; Down into X.
(define (check-format-args args loc)
\f
(with-test-prefix "tree-il-fold"
- (pass-if "empty tree"
- (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+ (pass-if "void"
+ (let ((up 0) (down 0) (mark (list 'mark)))
(and (eq? mark
- (tree-il-fold (lambda (x y) (set! leaf? #t) y)
- (lambda (x y) (set! down? #t) y)
- (lambda (x y) (set! up? #t) y)
+ (tree-il-fold (lambda (x y) (set! down (1+ down)) y)
+ (lambda (x y) (set! up (1+ up)) y)
mark
- '()))
- (not leaf?)
- (not up?)
- (not down?))))
+ (make-void #f)))
+ (= up 1)
+ (= down 1))))
(pass-if "lambda and application"
- (let* ((leaves '()) (ups '()) (downs '())
+ (let* ((ups '()) (downs '())
(result (tree-il-fold (lambda (x y)
- (set! leaves (cons x leaves))
- (1+ y))
- (lambda (x y)
(set! downs (cons x downs))
(1+ y))
(lambda (x y)
(lexical x x1)
(lexical y y1)))
#f))))))
- (and (equal? (map strip-source leaves)
- (list (make-lexical-ref #f 'y 'y1)
+ (and (= result 12)
+ (equal? (map strip-source (list-head (reverse ups) 3))
+ (list (make-toplevel-ref #f '+)
+ (make-lexical-ref #f 'x 'x1)
+ (make-lexical-ref #f 'y 'y1)))
+ (equal? (map strip-source (reverse (list-head downs 3)))
+ (list (make-toplevel-ref #f '+)
(make-lexical-ref #f 'x 'x1)
- (make-toplevel-ref #f '+)))
- (= (length downs) 3)
- (equal? (reverse (map strip-source ups))
- (map strip-source downs))))))
+ (make-lexical-ref #f 'y 'y1)))))))
\f
;;;