guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-43-gb34b66b


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-43-gb34b66b
Date: Mon, 10 Jun 2013 20:57:54 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b34b66b346ef7c09878112d7cf6d757bb1906344

The branch, master has been updated
       via  b34b66b346ef7c09878112d7cf6d757bb1906344 (commit)
       via  98f778ea28b7df3def9da6f7447f5f6c5fc9c6c9 (commit)
       via  f852e05ee863e47a62b2cd3ee5b8b9dd303170f2 (commit)
       via  007f671afc4a0deb4e9b3e91f7b908d7be5fef44 (commit)
       via  99b4da8fb2098762c9d51ee5cc92b1db971bbe1d (commit)
       via  25450a0d0e03ab55ca48fd9996e966d213f9b435 (commit)
       via  403d78f915552a6eaaf2ecd7a93b2a7dc2983585 (commit)
      from  64fc50c294df9b6644fd40bec90eb8f4dfbc3907 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit b34b66b346ef7c09878112d7cf6d757bb1906344
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 12:38:16 2013 -0400

    Rewrite make-tree-il-folder to use the Wright matcher.
    
    * module/language/tree-il.scm (make-tree-il-folder): Rewrite to use the
      Wright matcher instead of record-case.

commit 98f778ea28b7df3def9da6f7447f5f6c5fc9c6c9
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 12:28:56 2013 -0400

    Rewrite unparse-tree-il to use the Wright matcher.
    
    * module/language/tree-il.scm (unparse-tree-il): Rewrite to use the
      Wright matcher.

commit f852e05ee863e47a62b2cd3ee5b8b9dd303170f2
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 12:20:48 2013 -0400

    Rewrite parse-tree-il to use the Wright matcher.
    
    * module/language/tree-il.scm (parse-tree-il): Rewrite to use match
      instead of pmatch.  Remove pmatch import.

commit 007f671afc4a0deb4e9b3e91f7b908d7be5fef44
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 12:06:30 2013 -0400

    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.

commit 99b4da8fb2098762c9d51ee5cc92b1db971bbe1d
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 11:07:02 2013 -0400

    Rewrite tree-il pre-post-order in terms of (ice-9 match)
    
    * module/language/tree-il.scm (pre-post-order): Re-implement in terms
      of (ice-9 match), so that we standardize on one matcher (more or
      less).

commit 25450a0d0e03ab55ca48fd9996e966d213f9b435
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 11:02:25 2013 -0400

    Pre-order tree-il rewrites are now non-destructive
    
    * module/language/tree-il.scm (pre-order): Re-implement in terms of
      pre-post-order, and rename from pre-order!.
    
    * module/language/tree-il/primitives.scm (expand-primitives): Adapt to
      pre-order change, and rename from expand-primitives!.
    
    * module/language/tree-il/optimize.scm (optimize): Adapt to
      expand-primitives! change, and rename from optimize!.
    
    * module/language/tree-il/compile-glil.scm:
    * module/system/repl/common.scm:
    * test-suite/tests/cse.test:
    * test-suite/tests/peval.test:
    * test-suite/tests/tree-il.test: Adapt to expand-primitives and optimize
      changes.

commit 403d78f915552a6eaaf2ecd7a93b2a7dc2983585
Author: Andy Wingo <address@hidden>
Date:   Tue May 28 10:56:05 2013 -0400

    Tree-il post-order rewriter no longer destructive
    
    * module/language/tree-il.scm (pre-post-order): New helper, like
      pre-order! and post-order! but not destructive.
      (post-order): Implement in terms of pre-post-order, and rename from
      post-order!.
    
    * module/ice-9/compile-psyntax.scm (squeeze-tree-il):
    * module/language/tree-il/canonicalize.scm (canonicalize):
    * module/language/tree-il/fix-letrec.scm (fix-letrec):
    * module/language/tree-il/primitives.scm (resolve-primitives): Use
      post-order, and rename from the destructive
      variants (squeeze-tree-il!, canonicalize!, etc).  Adapt callers.
    
    * test-suite/tests/tree-il.test (strip-source): Adapt to post-order.
    
    * test-suite/tests/cse.test:
    * test-suite/tests/peval.test:
    * module/language/tree-il/optimize.scm: Adapt callers.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/compile-psyntax.scm         |   22 +-
 module/language/tree-il.scm              |  498 +++++++++++-------------------
 module/language/tree-il/analyze.scm      |   68 +---
 module/language/tree-il/canonicalize.scm |   12 +-
 module/language/tree-il/compile-glil.scm |    4 +-
 module/language/tree-il/cse.scm          |    2 -
 module/language/tree-il/fix-letrec.scm   |    8 +-
 module/language/tree-il/optimize.scm     |   10 +-
 module/language/tree-il/peval.scm        |    8 -
 module/language/tree-il/primitives.scm   |   67 ++--
 module/system/repl/common.scm            |   10 +-
 test-suite/tests/cse.test                |   10 +-
 test-suite/tests/peval.test              |    8 +-
 test-suite/tests/tree-il.test            |   43 ++--
 14 files changed, 287 insertions(+), 483 deletions(-)

diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 201ae39..21d639f 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 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
@@ -73,13 +73,13 @@
          x)
         (else x)))
 
-(define (squeeze-tree-il! x)
-  (post-order! (lambda (x)
-                 (if (const? x)
-                     (set! (const-exp x)
-                           (squeeze-constant! (const-exp x))))
-                 #f)
-               x))
+(define (squeeze-tree-il x)
+  (post-order (lambda (x)
+                (if (const? x)
+                    (make-const (const-src x)
+                                (squeeze-constant! (const-exp x)))
+                    x))
+              x))
 
 ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
 ;; changing session identifiers.
@@ -99,9 +99,9 @@
             (close-port in))
           (begin
             (pretty-print (tree-il->scheme
-                           (squeeze-tree-il!
-                            (canonicalize!
-                             (resolve-primitives!
+                           (squeeze-tree-il
+                            (canonicalize
+                             (resolve-primitives
                               (macroexpand x 'c '(compile load eval))
                               (current-module))))
                            (current-module)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index ddcba99..580bc6c 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -19,7 +19,7 @@
 (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
 
@@ -61,8 +61,8 @@
 
             tree-il-fold
             make-tree-il-folder
-            post-order!
-            pre-order!
+            post-order
+            pre-order
 
             tree-il=?
             tree-il-hash))
@@ -160,204 +160,208 @@
 (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))
 
-     ((call ,proc . ,args)
+     (('call proc . args)
       (make-call loc (retrans proc) (map retrans args)))
 
-     ((primcall ,name . ,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))
 
-     ((seq ,head ,tail)
+     (('seq head tail)
       (make-seq loc (retrans head) (retrans tail)))
 
      ;; Convenience.
-     ((begin . ,exps)
+     (('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 ,pre ,body ,post ,unwinder)
+     (('dynwind winder pre body post unwinder)
       (make-dynwind loc (retrans winder) (retrans pre)
                     (retrans body)
                     (retrans post) (retrans unwinder)))
 
-     ((dynlet ,fluids ,vals ,body)
+     (('dynlet fluids vals body)
       (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
 
-     ((dynref ,fluid)
+     (('dynref fluid)
       (make-dynref loc (retrans fluid)))
 
-     ((dynset ,fluid ,exp)
+     (('dynset fluid exp)
       (make-dynset loc (retrans fluid) (retrans exp)))
 
-     ((prompt ,tag ,body ,handler)
+     (('prompt tag body handler)
       (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
-
-     ((abort ,tag ,args ,tail)
+     
+     (('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))
 
-    ((<call> proc args)
+    (($ <call> src proc args)
      `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 
-    ((<primcall> name 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))
 
-    ((<seq> head tail)
+    (($ <seq> src head tail)
      `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
     
-    ((<let> names gensyms vals body)
+    (($ <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 pre body post unwinder)
+    (($ <dynwind> src winder pre body post unwinder)
      `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
                ,(unparse-tree-il body)
                ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
 
-    ((<dynlet> fluids vals body)
+    (($ <dynlet> src fluids vals body)
      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
               ,(unparse-tree-il body)))
 
-    ((<dynref> fluid)
+    (($ <dynref> src fluid)
      `(dynref ,(unparse-tree-il fluid)))
 
-    ((<dynset> fluid exp)
+    (($ <dynset> src 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)))
+    (($ <prompt> src 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)))))
 
@@ -367,87 +371,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 ...)
@@ -459,254 +382,179 @@ This is an implementation of `foldts' as described by 
Andy Wingo in
       (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 ...)))
-              ((<call> proc args)
+              (($ <call> src proc args)
                (let-values (((seed ...) (foldts proc seed ...)))
                  (fold-values foldts args seed ...)))
-              ((<primcall> name args)
+              (($ <primcall> src name args)
                (fold-values foldts args seed ...))
-              ((<seq> head tail)
+              (($ <seq> src head tail)
                (let-values (((seed ...) (foldts head seed ...)))
                  (foldts tail seed ...)))
-              ((<lambda> body)
+              (($ <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> winder pre body post unwinder)
+              (($ <dynwind> src winder pre body post unwinder)
                (let*-values (((seed ...) (foldts winder seed ...))
                              ((seed ...) (foldts pre seed ...))
                              ((seed ...) (foldts body seed ...))
                              ((seed ...) (foldts post seed ...)))
                  (foldts unwinder seed ...)))
-              ((<dynlet> fluids vals body)
+              (($ <dynlet> src fluids vals body)
                (let*-values (((seed ...) (fold-values foldts fluids seed ...))
                              ((seed ...) (fold-values foldts vals seed ...)))
                  (foldts body seed ...)))
-              ((<dynref> fluid)
+              (($ <dynref> src fluid)
                (foldts fluid seed ...))
-              ((<dynset> fluid exp)
+              (($ <dynset> src fluid exp)
                (let*-values (((seed ...) (foldts fluid seed ...)))
                  (foldts exp seed ...)))
-              ((<prompt> tag body handler)
+              (($ <prompt> src 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)
+(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))
-    (record-case x
-      ((<call> proc args)
-       (set! (call-proc x) (lp proc))
-       (set! (call-args x) (map lp args)))
+    (post
+     (match (pre x)
+       (($ <void> src)
+        (make-void src))
+
+       (($ <const> src exp)
+        (make-const src exp))
+
+       (($ <primitive-ref> src name)
+        (make-primitive-ref src name))
+
+       (($ <lexical-ref> src name gensym)
+        (make-lexical-ref src name gensym))
 
-      ((<primcall> name args)
-       (set! (primcall-args x) (map lp args)))
+       (($ <lexical-set> src name gensym exp)
+        (make-lexical-set src name gensym (lp exp)))
 
-      ((<conditional> test consequent alternate)
-       (set! (conditional-test x) (lp test))
-       (set! (conditional-consequent x) (lp consequent))
-       (set! (conditional-alternate x) (lp alternate)))
+       (($ <module-ref> src mod name public?)
+        (make-module-ref src mod name public?))
 
-      ((<lexical-set> name gensym exp)
-       (set! (lexical-set-exp x) (lp exp)))
+       (($ <module-set> src mod name public? exp)
+        (make-module-set src mod name public? (lp exp)))
 
-      ((<module-set> mod name public? exp)
-       (set! (module-set-exp x) (lp exp)))
+       (($ <toplevel-ref> src name)
+        (make-toplevel-ref src name))
 
-      ((<toplevel-set> name exp)
-       (set! (toplevel-set-exp x) (lp exp)))
+       (($ <toplevel-set> src name exp)
+        (make-toplevel-set src name (lp exp)))
 
-      ((<toplevel-define> name exp)
-       (set! (toplevel-define-exp x) (lp exp)))
+       (($ <toplevel-define> src name exp)
+        (make-toplevel-define src name (lp exp)))
 
-      ((<lambda> body)
-       (if body
-           (set! (lambda-body x) (lp body))))
+       (($ <conditional> src test consequent alternate)
+        (make-conditional src (lp test) (lp consequent) (lp alternate)))
 
-      ((<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))))
+       (($ <call> src proc args)
+        (make-call src (lp proc) (map lp args)))
 
-      ((<seq> head tail)
-       (set! (seq-head x) (lp head))
-       (set! (seq-tail x) (lp tail)))
+       (($ <primcall> src name args)
+        (make-primcall src name (map lp args)))
+
+       (($ <seq> src head tail)
+        (make-seq src (lp head) (lp tail)))
       
-      ((<let> gensyms vals body)
-       (set! (let-vals x) (map lp vals))
-       (set! (let-body x) (lp body)))
+       (($ <lambda> src meta body)
+        (make-lambda src meta (and body (lp body))))
 
-      ((<letrec> gensyms vals body)
-       (set! (letrec-vals x) (map lp vals))
-       (set! (letrec-body x) (lp body)))
+       (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+        (make-lambda-case src req opt rest kw (map lp inits) gensyms (lp body)
+                          (and alternate (lp alternate))))
 
-      ((<fix> gensyms vals body)
-       (set! (fix-vals x) (map lp vals))
-       (set! (fix-body x) (lp body)))
+       (($ <let> src names gensyms vals body)
+        (make-let src names gensyms (map lp vals) (lp body)))
 
-      ((<let-values> exp body)
-       (set! (let-values-exp x) (lp exp))
-       (set! (let-values-body x) (lp body)))
+       (($ <letrec> src in-order? names gensyms vals body)
+        (make-letrec src in-order? names gensyms (map lp vals) (lp body)))
 
-      ((<dynwind> winder pre body post unwinder)
-       (set! (dynwind-winder x) (lp winder))
-       (set! (dynwind-pre x) (lp pre))
-       (set! (dynwind-body x) (lp body))
-       (set! (dynwind-post x) (lp post))
-       (set! (dynwind-unwinder x) (lp unwinder)))
+       (($ <fix> src names gensyms vals body)
+        (make-fix src names gensyms (map lp vals) (lp body)))
 
-      ((<dynlet> fluids vals body)
-       (set! (dynlet-fluids x) (map lp fluids))
-       (set! (dynlet-vals x) (map lp vals))
-       (set! (dynlet-body x) (lp body)))
+       (($ <let-values> src exp body)
+        (make-let-values src (lp exp) (lp body)))
 
-      ((<dynref> fluid)
-       (set! (dynref-fluid x) (lp fluid)))
+       (($ <dynwind> src winder pre body post unwinder)
+        (make-dynwind src
+                      (lp winder) (lp pre) (lp body) (lp post) (lp unwinder)))
 
-      ((<dynset> fluid exp)
-       (set! (dynset-fluid x) (lp fluid))
-       (set! (dynset-exp x) (lp exp)))
+       (($ <dynlet> src fluids vals body)
+        (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
 
-      ((<prompt> tag body handler)
-       (set! (prompt-tag x) (lp tag))
-       (set! (prompt-body x) (lp body))
-       (set! (prompt-handler x) (lp handler)))
+       (($ <dynref> src fluid)
+        (make-dynref src (lp fluid)))
 
-      ((<abort> tag args tail)
-       (set! (abort-tag x) (lp tag))
-       (set! (abort-args x) (map lp args))
-       (set! (abort-tail x) (lp tail)))
+       (($ <dynset> src fluid exp)
+        (make-dynset src (lp fluid) (lp exp)))
 
-      (else #f))
+       (($ <prompt> src tag body handler)
+        (make-prompt src (lp tag) (lp body) (lp handler)))
 
-    (or (f x) x)))
+       (($ <abort> src tag args tail)
+        (make-abort src (lp tag) (map lp args) (lp tail)))))))
 
-(define (pre-order! f x)
-  (let lp ((x x))
-    (let ((x (or (f x) x)))
-      (record-case x
-        ((<call> proc args)
-         (set! (call-proc x) (lp proc))
-         (set! (call-args x) (map lp args)))
-
-        ((<primcall> name args)
-         (set! (primcall-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))))
-
-        ((<seq> head tail)
-         (set! (seq-head x) (lp head))
-         (set! (seq-tail x) (lp tail)))
-        
-        ((<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> winder pre body post unwinder)
-         (set! (dynwind-winder x) (lp winder))
-         (set! (dynwind-pre x) (lp pre))
-         (set! (dynwind-body x) (lp body))
-         (set! (dynwind-post x) (lp post))
-         (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)))
+(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)
diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index f5890b2..aff05d7 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 <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))
@@ -619,15 +617,6 @@ accurate information is missing from a given `tree-il' 
element."
   ;; 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.
      (let ((refs (binding-info-refs info))
@@ -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)
@@ -790,19 +781,13 @@ accurate information is missing from a given `tree-il' 
element."
 
     (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)
@@ -1070,9 +1043,6 @@ accurate information is missing from a given `tree-il' 
element."
   ;; 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)
        ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
@@ -1418,10 +1388,6 @@ resort, return #t when EXP refers to the global variable 
SPECIAL-NAME."
   ;; 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)
        (pmatch args
diff --git a/module/language/tree-il/canonicalize.scm 
b/module/language/tree-il/canonicalize.scm
index 1db8420..b291eaa 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -22,18 +22,16 @@
   #:use-module (language tree-il)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:export (canonicalize!))
+  #:export (canonicalize))
 
 (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))
 
-(define (canonicalize! x)
-  (post-order!
+(define (canonicalize x)
+  (post-order
    (lambda (x)
      (match x
        (($ <let> src () () () body)
@@ -85,7 +83,7 @@
         ;; thunk.  Sad but true.
         (if (or (escape-only? handler)
                 (thunk-application? body))
-            #f
+            x
             (make-prompt src tag (make-thunk-application body) handler)))
-       (_ #f)))
+       (_ x)))
    x))
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 1b6fea6..353bd03 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -64,8 +64,8 @@
 
   (let* ((x (make-lambda (tree-il-src x) '()
                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
-         (x (optimize! x e opts))
-         (x (canonicalize! x))
+         (x (optimize x e opts))
+         (x (canonicalize x))
          (allocation (analyze-lexicals x)))
 
     (with-fluids ((*comp-module* e))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index f8df3ce..9531149 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -131,8 +131,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)
         (vhash-consq gensym #t res))
diff --git a/module/language/tree-il/fix-letrec.scm 
b/module/language/tree-il/fix-letrec.scm
index b5722fe..d8f127a 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
 ;;; transformation of letrec into simpler forms
 
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -22,7 +22,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (language tree-il)
   #:use-module (language tree-il effects)
-  #:export (fix-letrec!))
+  #:export (fix-letrec))
 
 ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
 ;; Efficient Implementation of Scheme's Recursive Binding Construct", by
@@ -210,9 +210,9 @@
                        (car exps))
             (lp (cdr exps) (cons (car exps) effects))))))
 
-(define (fix-letrec! x)
+(define (fix-letrec x)
   (let-values (((unref simple lambda* complex) (partition-vars x)))
-    (post-order!
+    (post-order
      (lambda (x)
        (record-case x
 
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index c6e4fec..4fb8f59 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 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
@@ -26,9 +26,9 @@
   #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il debug)
   #:use-module (ice-9 match)
-  #:export (optimize!))
+  #:export (optimize))
 
-(define (optimize! x env opts)
+(define (optimize x env opts)
   (let ((peval (match (memq #:partial-eval? opts)
                  ((#:partial-eval? #f _ ...)
                   ;; Disable partial evaluation.
@@ -39,9 +39,9 @@
                 ;; Disable CSE.
                 (lambda (x) x))
                (_ cse))))
-    (fix-letrec!
+    (fix-letrec
      (verify-tree-il
       (cse
        (verify-tree-il
-        (peval (expand-primitives! (resolve-primitives! x env))
+        (peval (expand-primitives (resolve-primitives x env))
                env)))))))
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index d7d561d..3755380 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
        (($ <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
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index e3f6a90..cbda2db 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -25,8 +25,8 @@
   #:use-module (language tree-il)
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-16)
-  #:export (resolve-primitives! add-interesting-primitive!
-            expand-primitives!
+  #:export (resolve-primitives add-interesting-primitive!
+            expand-primitives
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
             singly-valued-primitive? equality-primitive?
@@ -160,7 +160,7 @@
     integer->char char->integer number->string string->number
     struct-vtable
     string-length vector-length
-    ;; These all should get expanded out by expand-primitives!.
+    ;; These all should get expanded out by expand-primitives.
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr
     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
@@ -248,7 +248,7 @@
 (define (negate-primitive prim)
   (hashq-ref *negatable-primitive-table* prim))
 
-(define (resolve-primitives! x mod)
+(define (resolve-primitives x mod)
   (define local-definitions
     (make-hash-table))
 
@@ -261,44 +261,47 @@
        (collect-local-definitions tail))
       (else #f)))
   
-  (post-order!
+  (post-order
    (lambda (x)
-     (record-case x
-       ((<toplevel-ref> src name)
-        (and=> (and (not (hashq-ref local-definitions name))
-                    (hashq-ref *interesting-primitive-vars*
-                               (module-variable mod name)))
-               (lambda (name) (make-primitive-ref src name))))
-       ((<module-ref> src mod name public?)
-        ;; for the moment, we're disabling primitive resolution for
-        ;; public refs because resolve-interface can raise errors.
-        (and=> (and=> (resolve-module mod)
-                      (if public?
-                          module-public-interface
-                          identity))
-               (lambda (m)
-                 (and=> (hashq-ref *interesting-primitive-vars*
-                                   (module-variable m name))
-                        (lambda (name)
-                          (make-primitive-ref src name))))))
-       ((<call> src proc args)
-        (and (primitive-ref? proc)
-             (make-primcall src (primitive-ref-name proc) args)))
-       (else #f)))
+     (or
+      (record-case x
+        ((<toplevel-ref> src name)
+         (and=> (and (not (hashq-ref local-definitions name))
+                     (hashq-ref *interesting-primitive-vars*
+                                (module-variable mod name)))
+                (lambda (name) (make-primitive-ref src name))))
+        ((<module-ref> src mod name public?)
+         ;; for the moment, we're disabling primitive resolution for
+         ;; public refs because resolve-interface can raise errors.
+         (and=> (and=> (resolve-module mod)
+                       (if public?
+                           module-public-interface
+                           identity))
+                (lambda (m)
+                  (and=> (hashq-ref *interesting-primitive-vars*
+                                    (module-variable m name))
+                         (lambda (name)
+                           (make-primitive-ref src name))))))
+        ((<call> src proc args)
+         (and (primitive-ref? proc)
+              (make-primcall src (primitive-ref-name proc) args)))
+        (else #f))
+      x))
    x))
 
 
 
 (define *primitive-expand-table* (make-hash-table))
 
-(define (expand-primitives! x)
-  (pre-order!
+(define (expand-primitives x)
+  (pre-order
    (lambda (x)
      (record-case x
        ((<primcall> src name args)
         (let ((expand (hashq-ref *primitive-expand-table* name)))
-          (and expand (apply expand src args))))
-       (else #f)))
+          (or (and expand (apply expand src args))
+              x)))
+       (else x)))
    x))
 
 ;;; I actually did spend about 10 minutes trying to redo this with
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 5da7c48..94b41ea 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -25,7 +25,7 @@
   #:use-module (system base language)
   #:use-module (system base message)
   #:use-module (system vm program)
-  #:autoload (language tree-il optimize) (optimize!)
+  #:autoload (language tree-il optimize) (optimize)
   #:use-module (ice-9 control)
   #:use-module (ice-9 history)
   #:export (<repl> make-repl repl-language repl-options
@@ -189,10 +189,10 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more 
details.")
 (define (repl-optimize repl form)
   (let ((from (repl-language repl))
         (opts (repl-compile-options repl)))
-    (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
-                                   #:env (current-module))
-                          (current-module)
-                          opts)
+    (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
+                                  #:env (current-module))
+                         (current-module)
+                         opts)
                #:from 'tree-il #:to from)))
 
 (define (repl-parse repl form)
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index f9b85d4..e60fdf3 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <address@hidden> --- May 2009
 ;;;;
-;;;;   Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;   Copyright (C) 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
@@ -36,12 +36,12 @@
     ((_ in pat)
      (pass-if 'in
        (let ((evaled (unparse-tree-il
-                      (canonicalize!
-                       (fix-letrec!
+                      (canonicalize
+                       (fix-letrec
                         (cse
                          (peval
-                          (expand-primitives!
-                           (resolve-primitives!
+                          (expand-primitives
+                           (resolve-primitives
                             (compile 'in #:from 'scheme #:to 'tree-il)
                             (current-module))))))))))
          (pmatch evaled
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index f409e94..8f237b8 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -36,8 +36,8 @@
   (syntax-rules ()
     ((_ in pat)
      (pass-if-peval in pat
-                    (expand-primitives!
-                     (resolve-primitives!
+                    (expand-primitives
+                     (resolve-primitives
                       (compile 'in #:from 'scheme #:to 'tree-il)
                       (current-module)))))
     ((_ in pat code)
@@ -488,8 +488,8 @@
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
     (pmatch (unparse-tree-il
-             (peval (expand-primitives!
-                     (resolve-primitives!
+             (peval (expand-primitives
+                     (resolve-primitives
                       (compile
                        '(let ((make-adder
                                (lambda (x) (lambda (y) (+ x y)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 2ed15c7..50847fd 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -32,8 +32,10 @@
 ;; information from the incoming tree-il.
 
 (define (strip-source x)
-  (post-order! (lambda (x) (set! (tree-il-src x) #f))
-               x))
+  (post-order (lambda (x)
+                (set! (tree-il-src x) #f)
+                x)
+              x))
 
 (define-syntax assert-tree-il->glil
   (syntax-rules (with-partial-evaluation without-partial-evaluation
@@ -64,7 +66,7 @@
                        (beautify-user-module! m)
                        m))
            (orig     (parse-tree-il 'in))
-           (resolved (expand-primitives! (resolve-primitives! orig module))))
+           (resolved (expand-primitives (resolve-primitives orig module))))
       (or (equal? (unparse-tree-il resolved) 'expected)
           (begin
             (format (current-error-port)
@@ -720,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)
@@ -752,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-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)))))))
 
 
 ;;;


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]