From b34b66b346ef7c09878112d7cf6d757bb1906344 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 28 May 2013 12:38:16 -0400
Subject: [PATCH] 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.
---
 module/language/tree-il.scm | 45 +++++++++++++++++++------------------
 1 file changed, 23 insertions(+), 22 deletions(-)

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index b40224b2f..580bc6cfa 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -382,73 +382,74 @@
       (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 ...)))))