more define-syntax-rule usage

[bpt/guile.git] / module / language / tree-il.scm

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index decd363..580ebda 100644 (file)
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -554,81 +554,79 @@ This is an implementation of `foldts' as described by Andy Wingo in
            (leaf tree result))))))
 
 
-(define-syntax make-tree-il-folder
-  (syntax-rules ()
-    ((_ seed ...)
-     (lambda (tree down up seed ...)
-       (define (fold-values proc exps seed ...)
-         (if (null? exps)
-             (values seed ...)
-             (let-values (((seed ...) (proc (car exps) seed ...)))
-               (fold-values proc (cdr exps) seed ...))))
-       (let foldts ((tree tree) (seed seed) ...)
-         (let*-values
-             (((seed ...) (down tree seed ...))
-              ((seed ...)
-               (record-case tree
-                 ((<lexical-set> exp)
-                  (foldts exp seed ...))
-                 ((<module-set> exp)
-                  (foldts exp seed ...))
-                 ((<toplevel-set> exp)
-                  (foldts exp seed ...))
-                 ((<toplevel-define> exp)
-                  (foldts exp seed ...))
-                 ((<conditional> test consequent alternate)
-                  (let*-values (((seed ...) (foldts test seed ...))
-                                ((seed ...) (foldts consequent seed ...)))
-                    (foldts alternate seed ...)))
-                 ((<application> proc args)
-                  (let-values (((seed ...) (foldts proc seed ...)))
-                    (fold-values foldts args seed ...)))
-                 ((<sequence> exps)
-                  (fold-values foldts exps seed ...))
-                 ((<lambda> body)
-                  (foldts body seed ...))
-                 ((<lambda-case> inits 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*-values (((seed ...) (fold-values foldts vals seed ...)))
-                    (foldts body seed ...)))
-                 ((<letrec> vals body)
-                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
-                    (foldts body seed ...)))
-                 ((<fix> vals body)
-                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
-                    (foldts body seed ...)))
-                 ((<let-values> exp body)
-                  (let*-values (((seed ...) (foldts exp seed ...)))
-                    (foldts body seed ...)))
-                 ((<dynwind> body winder unwinder)
-                  (let*-values (((seed ...) (foldts body seed ...))
-                                ((seed ...) (foldts winder seed ...)))
-                    (foldts unwinder seed ...)))
-                 ((<dynlet> fluids vals body)
-                  (let*-values (((seed ...) (fold-values foldts fluids seed ...))
-                                ((seed ...) (fold-values foldts vals seed ...)))
-                    (foldts body seed ...)))
-                 ((<dynref> fluid)
-                  (foldts fluid seed ...))
-                 ((<dynset> fluid exp)
-                  (let*-values (((seed ...) (foldts fluid seed ...)))
-                    (foldts exp seed ...)))
-                 ((<prompt> tag body handler)
-                  (let*-values (((seed ...) (foldts tag seed ...))
-                                ((seed ...) (foldts body seed ...)))
-                    (foldts handler seed ...)))
-                 ((<abort> 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-syntax-rule (make-tree-il-folder seed ...)
+  (lambda (tree down up seed ...)
+    (define (fold-values proc exps seed ...)
+      (if (null? exps)
+          (values seed ...)
+          (let-values (((seed ...) (proc (car exps) seed ...)))
+            (fold-values proc (cdr exps) seed ...))))
+    (let foldts ((tree tree) (seed seed) ...)
+      (let*-values
+          (((seed ...) (down tree seed ...))
+           ((seed ...)
+            (record-case tree
+              ((<lexical-set> exp)
+               (foldts exp seed ...))
+              ((<module-set> exp)
+               (foldts exp seed ...))
+              ((<toplevel-set> exp)
+               (foldts exp seed ...))
+              ((<toplevel-define> exp)
+               (foldts exp seed ...))
+              ((<conditional> test consequent alternate)
+               (let*-values (((seed ...) (foldts test seed ...))
+                             ((seed ...) (foldts consequent seed ...)))
+                 (foldts alternate seed ...)))
+              ((<application> proc args)
+               (let-values (((seed ...) (foldts proc seed ...)))
+                 (fold-values foldts args seed ...)))
+              ((<sequence> exps)
+               (fold-values foldts exps seed ...))
+              ((<lambda> body)
+               (foldts body seed ...))
+              ((<lambda-case> inits 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*-values (((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<letrec> vals body)
+               (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<fix> vals body)
+               (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<let-values> exp body)
+               (let*-values (((seed ...) (foldts exp seed ...)))
+                 (foldts body seed ...)))
+              ((<dynwind> body winder unwinder)
+               (let*-values (((seed ...) (foldts body seed ...))
+                             ((seed ...) (foldts winder seed ...)))
+                 (foldts unwinder seed ...)))
+              ((<dynlet> fluids vals body)
+               (let*-values (((seed ...) (fold-values foldts fluids seed ...))
+                             ((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<dynref> fluid)
+               (foldts fluid seed ...))
+              ((<dynset> fluid exp)
+               (let*-values (((seed ...) (foldts fluid seed ...)))
+                 (foldts exp seed ...)))
+              ((<prompt> tag body handler)
+               (let*-values (((seed ...) (foldts tag seed ...))
+                             ((seed ...) (foldts body seed ...)))
+                 (foldts handler seed ...)))
+              ((<abort> 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)
   (let lp ((x x))