diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 4e01df933..354b7bd9c 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -368,87 +368,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 -``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 - (( exp) - (up tree (loop exp (down tree result)))) - (( exp) - (up tree (loop exp (down tree result)))) - (( exp) - (up tree (loop exp (down tree result)))) - (( exp) - (up tree (loop exp (down tree result)))) - (( test consequent alternate) - (up tree (loop alternate - (loop consequent - (loop test (down tree result)))))) - (( proc args) - (up tree (loop (cons proc args) (down tree result)))) - (( name args) - (up tree (loop args (down tree result)))) - (( head tail) - (up tree (loop tail (loop head (down tree result))))) - (( body) - (let ((result (down tree result))) - (up tree - (if body - (loop body result) - result)))) - (( inits body alternate) - (up tree (if alternate - (loop alternate - (loop body (loop inits (down tree result)))) - (loop body (loop inits (down tree result)))))) - (( vals body) - (up tree (loop body - (loop vals - (down tree result))))) - (( vals body) - (up tree (loop body - (loop vals - (down tree result))))) - (( vals body) - (up tree (loop body - (loop vals - (down tree result))))) - (( exp body) - (up tree (loop body (loop exp (down tree result))))) - (( winder pre body post unwinder) - (up tree (loop unwinder - (loop post - (loop body - (loop pre - (loop winder - (down tree result)))))))) - (( fluids vals body) - (up tree (loop body - (loop vals - (loop fluids (down tree result)))))) - (( fluid) - (up tree (loop fluid (down tree result)))) - (( fluid exp) - (up tree (loop exp (loop fluid (down tree result))))) - (( tag body handler) - (up tree - (loop tag (loop body (loop handler - (down tree result)))))) - (( 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 ...) @@ -530,6 +449,19 @@ This is an implementation of `foldts' as described by Andy Wingo in (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 diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index f5890b25a..aff05d772 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -551,9 +551,8 @@ ;;; (define-record-type - (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) ...) @@ -561,10 +560,11 @@ (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 @@ -577,14 +577,12 @@ accurate information is missing from a given `tree-il' element." 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)) @@ -618,15 +616,6 @@ accurate information is missing from a given `tree-il' element." (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 - (( 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. @@ -641,6 +630,8 @@ accurate information is missing from a given `tree-il' element." inner-names)) (record-case x + (( gensym) + (make-binding-info vars (vhash-consq gensym #t refs))) (( gensym) (make-binding-info vars (vhash-consq gensym #t refs))) (( req opt inits rest kw gensyms) @@ -789,20 +780,14 @@ accurate information is missing from a given `tree-il' element." (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 - (( 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 + (( name src) + (add-ref-from-context graph name)) (( name src) (let ((refs refs) (defs (vhash-consq name (or src (find pair? locs)) @@ -895,9 +880,10 @@ accurate information is missing from a given `tree-il' element." ;; 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)) @@ -910,19 +896,6 @@ accurate information is missing from a given `tree-il' element." (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 (( name src) (if (bound? name) (make-toplevel-info refs defs) @@ -1069,9 +1042,6 @@ accurate information is missing from a given `tree-il' element." (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) @@ -1417,10 +1387,6 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME." (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) diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm index 4f2eb5262..b291eaab9 100644 --- a/module/language/tree-il/canonicalize.scm +++ b/module/language/tree-il/canonicalize.scm @@ -27,8 +27,6 @@ (define (tree-il-any proc exp) (tree-il-fold (lambda (exp res) (or res (proc exp))) - (lambda (exp res) - (or res (proc exp))) (lambda (exp res) res) #f exp)) diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index f8df3ce55..95311490f 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -130,8 +130,6 @@ ;; (define* (build-assigned-var-table exp #:optional (table vlist-null)) (tree-il-fold - (lambda (exp res) - res) (lambda (exp res) (match exp (($ src name gensym exp) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index d7d561d4f..3755380ec 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -79,9 +79,6 @@ (tree-il-fold (lambda (exp res) (let ((res (proc exp))) (if res (k res) #f))) - (lambda (exp res) - (let ((res (proc exp))) - (if res (k res) #f))) (lambda (exp res) #f) #f exp))) @@ -132,9 +129,6 @@ (let ((var (cdr (vhash-assq gensym res)))) (set-var-refcount! var (1+ (var-refcount var))) res)) - (_ res))) - (lambda (exp res) - (match exp (($ src req opt rest kw init gensyms body alt) (fold (lambda (name sym res) (vhash-consq sym (make-var name sym 0 #f) res)) @@ -666,8 +660,6 @@ top-level bindings from ENV and return the resulting expression." (define (small-expression? x limit) (let/ec k (tree-il-fold - (lambda (x res) ; leaf - (1+ res)) (lambda (x res) ; down (1+ res)) (lambda (x res) ; up diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index a98921b53..50847fd21 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -722,24 +722,19 @@ (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) @@ -754,13 +749,15 @@ (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-toplevel-ref #f '+))) - (= (length downs) 3) - (equal? (reverse (map strip-source ups)) - (map strip-source downs)))))) + (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-lexical-ref #f 'y 'y1))))))) ;;;