mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
Implement tree-il-fold in terms of make-tree-il-folder.
* module/language/tree-il.scm (tree-il-fold): Implement using
make-tree-il-folder. This is an incompatible change: there is no more
"leaf" procedure, and tree-il-fold only works on tree-il and not
lists.
* module/language/tree-il/analyze.scm (<tree-analysis>, analyze-tree):
Adapt to tree-il-fold change, losing the "leaf" handler.
(unused-variable-analysis, unused-toplevel-analysis)
(unbound-variable-analysis, arity-analysis): Adapt to tree-analysis
change.
* module/language/tree-il/canonicalize.scm (tree-il-any)
* module/language/tree-il/cse.scm (build-assigned-var-table)
* module/language/tree-il/peval.scm (tree-il-any, build-var-table)
(peval): Adapt to tree-il-fold change.
* test-suite/tests/tree-il.test ("tree-il-fold"): Adapt tests for new
interface and expectations.
This commit is contained in:
Andy Wingo
parent
99b4da8fb2
commit
007f671afc
6 changed files with 46 additions and 163 deletions
|
|
@ -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
|
||||
((<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 ...)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <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) ...)
|
||||
|
|
@ -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
|
||||
((<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.
|
||||
|
|
@ -641,6 +630,8 @@ accurate information is missing from a given `tree-il' element."
|
|||
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)
|
||||
|
|
@ -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
|
||||
((<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))
|
||||
|
|
@ -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
|
||||
((<toplevel-set> 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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(($ <lexical-set> src name gensym exp)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(($ <lambda-case> 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
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue