more define-syntax-rule usage

* module/ice-9/boot-9.scm: * module/ice-9/control.scm: * module/ice-9/futures.scm: * module/ice-9/optargs.scm: * module/ice-9/poll.scm: * module/ice-9/receive.scm: * module/ice-9/threads.scm: * module/ice-9/vlist.scm: * module/language/assembly/compile-bytecode.scm: * module/language/ecmascript/compile-tree-il.scm: * module/language/tree-il.scm: * module/oop/goops.scm: * module/oop/goops/simple.scm: * module/oop/goops/stklos.scm: * module/srfi/srfi-1.scm: * module/srfi/srfi-35.scm: * module/srfi/srfi-39.scm: * module/srfi/srfi-45.scm: * module/srfi/srfi-67/compare.scm: * module/sxml/match.scm: * module/system/repl/error-handling.scm: * module/system/repl/repl.scm: * module/system/vm/inspect.scm: * module/texinfo.scm: * module/web/server.scm: Use define-syntax-rule, where it makes sense.
2025-04-30 03:40:34 +02:00 · 2011-09-02 11:36:14 +02:00 · 2011-09-02 11:36:14 +02:00 · 0c65f52c6d
commit 0c65f52c6d
parent 1bbe0a631c
25 changed files with 373 additions and 513 deletions
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@ -504,9 +504,8 @@ If there is no handler at all, Guile prints an error and then exits."
    ((do "step" x y)
     y)))

-(define-syntax delay
-  (syntax-rules ()
-    ((_ exp) (make-promise (lambda () exp)))))
+(define-syntax-rule (delay exp)
+  (make-promise (lambda () exp)))

 (include-from-path "ice-9/quasisyntax")

@ -517,11 +516,9 @@ If there is no handler at all, Guile prints an error and then exits."
       (with-syntax ((s (datum->syntax x (syntax-source x))))
         #''s)))))

-(define-syntax define-once
-  (syntax-rules ()
-    ((_ sym val)
-     (define sym
-       (if (module-locally-bound? (current-module) 'sym) sym val)))))
+(define-syntax-rule (define-once sym val)
+  (define sym
+    (if (module-locally-bound? (current-module) 'sym) sym val)))

 ;;; The real versions of `map' and `for-each', with cycle detection, and
 ;;; that use reverse! instead of recursion in the case of `map'.
@ -853,12 +850,10 @@ VALUE."
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)

-(define-syntax false-if-exception
-  (syntax-rules ()
-    ((_ expr)
-     (catch #t
-       (lambda () expr)
-       (lambda (k . args) #f)))))
+(define-syntax-rule (false-if-exception expr)
+  (catch #t
+    (lambda () expr)
+    (lambda (k . args) #f)))



@ -877,12 +872,10 @@ VALUE."
 ;; properties within the object itself.

 (define (make-object-property)
-  (define-syntax with-mutex
-    (syntax-rules ()
-      ((_ lock exp)
-       (dynamic-wind (lambda () (lock-mutex lock))
-                     (lambda () exp)
-                     (lambda () (unlock-mutex lock))))))
+  (define-syntax-rule (with-mutex lock exp)
+    (dynamic-wind (lambda () (lock-mutex lock))
+                  (lambda () exp)
+                  (lambda () (unlock-mutex lock))))
  (let ((prop (make-weak-key-hash-table))
        (lock (make-mutex)))
    (make-procedure-with-setter
@ -1380,10 +1373,9 @@ VALUE."
         (thunk)))
     (lambda (k . args)
       (%start-stack tag (lambda () (apply k args)))))))
-(define-syntax start-stack
-  (syntax-rules ()
-    ((_ tag exp)
-     (%start-stack tag (lambda () exp)))))
+
+(define-syntax-rule (start-stack tag exp)
+  (%start-stack tag (lambda () exp)))



@ -2846,11 +2838,9 @@ module '(ice-9 q) '(make-q q-length))}."
                     flags)
           (interface options)
           (interface)))
-       (define-syntax option-set!
-         (syntax-rules ()
-           ((_ opt val)
-            (eval-when (eval load compile expand)
-              (options (append (options) (list 'opt val)))))))))))
+       (define-syntax-rule (option-set! opt val)
+         (eval-when (eval load compile expand)
+           (options (append (options) (list 'opt val)))))))))

 (define-option-interface
  (debug-options-interface
@ -3175,21 +3165,17 @@ module '(ice-9 q) '(make-q q-length))}."
             (process-use-modules (list quoted-args ...))
             *unspecified*))))))

-(define-syntax use-syntax
-  (syntax-rules ()
-    ((_ spec ...)
-     (begin
-       (eval-when (eval load compile expand)
-         (issue-deprecation-warning
-          "`use-syntax' is deprecated. Please contact guile-devel for more info."))
-       (use-modules spec ...)))))
+(define-syntax-rule (use-syntax spec ...)
+  (begin
+    (eval-when (eval load compile expand)
+      (issue-deprecation-warning
+       "`use-syntax' is deprecated. Please contact guile-devel for more info."))
+    (use-modules spec ...)))

 (include-from-path "ice-9/r6rs-libraries")

-(define-syntax define-private
-  (syntax-rules ()
-    ((_ foo bar)
-     (define foo bar))))
+(define-syntax-rule (define-private foo bar)
+  (define foo bar))

 (define-syntax define-public
  (syntax-rules ()
@ -3200,18 +3186,14 @@ module '(ice-9 q) '(make-q q-length))}."
       (define name val)
       (export name)))))

-(define-syntax defmacro-public
-  (syntax-rules ()
-    ((_ name args . body)
-     (begin
-       (defmacro name args . body)
-       (export-syntax name)))))
+(define-syntax-rule (defmacro-public name args body ...)
+  (begin
+    (defmacro name args body ...)
+    (export-syntax name)))

 ;; And now for the most important macro.
-(define-syntax λ
-  (syntax-rules ()
-    ((_ formals body ...)
-     (lambda formals body ...))))
+(define-syntax-rule (λ formals body ...)
+  (lambda formals body ...))


 ;; Export a local variable
@ -3270,39 +3252,29 @@ module '(ice-9 q) '(make-q q-length))}."
                         (module-add! public-i external-name var)))))
              names)))

-(define-syntax export
-  (syntax-rules ()
-    ((_ name ...)
-     (eval-when (eval load compile expand)
-       (call-with-deferred-observers
-        (lambda ()
-          (module-export! (current-module) '(name ...))))))))
+(define-syntax-rule (export name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-export! (current-module) '(name ...))))))

-(define-syntax re-export
-  (syntax-rules ()
-    ((_ name ...)
-     (eval-when (eval load compile expand)
-       (call-with-deferred-observers
-        (lambda ()
-          (module-re-export! (current-module) '(name ...))))))))
+(define-syntax-rule (re-export name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-re-export! (current-module) '(name ...))))))

-(define-syntax export!
-  (syntax-rules ()
-    ((_ name ...)
-     (eval-when (eval load compile expand)
-       (call-with-deferred-observers
-        (lambda ()
-          (module-replace! (current-module) '(name ...))))))))
+(define-syntax-rule (export! name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-replace! (current-module) '(name ...))))))

-(define-syntax export-syntax
-  (syntax-rules ()
-    ((_ name ...)
-     (export name ...))))
+(define-syntax-rule (export-syntax name ...)
+  (export name ...))

-(define-syntax re-export-syntax
-  (syntax-rules ()
-    ((_ name ...)
-     (re-export name ...))))
+(define-syntax-rule (re-export-syntax name ...)
+  (re-export name ...))



--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@ -60,20 +60,16 @@
 ;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
 ;; public domain, as noted at the top of http://okmij.org/ftp/.
 ;; 
-(define-syntax reset
-  (syntax-rules ()
-    ((_ . body)
-     (call-with-prompt (default-prompt-tag)
-                       (lambda () . body)
-                       (lambda (cont f) (f cont))))))
+(define-syntax-rule (reset . body)
+  (call-with-prompt (default-prompt-tag)
+                    (lambda () . body)
+                    (lambda (cont f) (f cont))))

-(define-syntax shift
-  (syntax-rules ()
-    ((_ var . body)
-     (abort-to-prompt (default-prompt-tag)
-                      (lambda (cont)
-                        ((lambda (var) (reset . body))
-                         (lambda vals (reset (apply cont vals)))))))))
+(define-syntax-rule (shift var . body)
+  (abort-to-prompt (default-prompt-tag)
+                   (lambda (cont)
+                     ((lambda (var) (reset . body))
+                      (lambda vals (reset (apply cont vals)))))))

 (define (reset* thunk)
  (reset (thunk)))
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@ -173,8 +173,6 @@ touched."
 ;;; Syntax.
 ;;;

-(define-syntax future
-  (syntax-rules ()
-    "Return a new future for BODY."
-    ((_ body)
-     (make-future (lambda () body)))))
+(define-syntax-rule (future body)
+  "Return a new future for BODY."
+  (make-future (lambda () body)))
--- a/module/ice-9/optargs.scm
+++ b/module/ice-9/optargs.scm
@ -1,6 +1,6 @@
 ;;;; optargs.scm -- support for optional arguments
 ;;;;
-;;;; 	Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010, 2011 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
@ -278,12 +278,10 @@
       #'(define-macro id doc (lambda* args b0 b1 ...)))
      ((_ id args b0 b1 ...) 
       #'(define-macro id #f (lambda* args b0 b1 ...))))))
-(define-syntax defmacro*-public
-  (syntax-rules ()
-    ((_ id args b0 b1 ...)
-     (begin
-       (defmacro* id args b0 b1 ...)
-       (export-syntax id)))))
+(define-syntax-rule (defmacro*-public id args b0 b1 ...)
+  (begin
+    (defmacro* id args b0 b1 ...)
+    (export-syntax id)))

 ;;; Support for optional & keyword args with the interpreter.
 (define *uninitialized* (list 'uninitialized))
--- a/module/ice-9/poll.scm
+++ b/module/ice-9/poll.scm
@ -1,6 +1,6 @@
 ;; poll

-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011 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
@ -68,9 +68,8 @@
  (ports pset-ports set-pset-ports!)
  )

-(define-syntax pollfd-offset
-  (syntax-rules ()
-    ((_ n) (* n 8))))
+(define-syntax-rule (pollfd-offset n)
+  (* n 8))

 (define* (make-empty-poll-set #:optional (pre-allocated 4))
  (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)
--- a/module/ice-9/receive.scm
+++ b/module/ice-9/receive.scm
@ -1,6 +1,6 @@
 ;;;; SRFI-8

-;;; Copyright (C) 2000, 2001, 2004, 2006, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2000, 2001, 2004, 2006, 2010, 2011 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
@ -17,14 +17,10 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

 (define-module (ice-9 receive)
-  :export (receive)
-  :no-backtrace
-  )
+  #:export (receive))

-(define-syntax receive
-  (syntax-rules ()
-    ((receive vars vals . body)
-     (call-with-values (lambda () vals)
-       (lambda vars . body)))))
+(define-syntax-rule (receive vars vals . body)
+  (call-with-values (lambda () vals)
+    (lambda vars . body)))

 (cond-expand-provide (current-module) '(srfi-8))
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011 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
@ -51,12 +51,10 @@

 ;;; Macros first, so that the procedures expand correctly.

-(define-syntax begin-thread
-  (syntax-rules ()
-    ((_ e0 e1 ...)
-     (call-with-new-thread
-      (lambda () e0 e1 ...)
-      %thread-handler))))
+(define-syntax-rule (begin-thread e0 e1 ...)
+  (call-with-new-thread
+   (lambda () e0 e1 ...)
+   %thread-handler))

 (define-syntax parallel
  (lambda (x)
@ -67,35 +65,27 @@
                 ...)
             (values (touch tmp0) ...)))))))

-(define-syntax letpar
-  (syntax-rules ()
-    ((_ ((v e) ...) b0 b1 ...)
-     (call-with-values
-         (lambda () (parallel e ...))
-       (lambda (v ...)
-         b0 b1 ...)))))
+(define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
+  (call-with-values
+      (lambda () (parallel e ...))
+    (lambda (v ...)
+      b0 b1 ...)))

-(define-syntax make-thread
-  (syntax-rules ()
-    ((_ proc arg ...)
-     (call-with-new-thread
-      (lambda () (proc arg ...))
-      %thread-handler))))
+(define-syntax-rule (make-thread proc arg ...)
+  (call-with-new-thread
+   (lambda () (proc arg ...))
+   %thread-handler))

-(define-syntax with-mutex
-  (syntax-rules ()
-    ((_ m e0 e1 ...)
-     (let ((x m))
-       (dynamic-wind
-         (lambda () (lock-mutex x))
-         (lambda () (begin e0 e1 ...))
-         (lambda () (unlock-mutex x)))))))
+(define-syntax-rule (with-mutex m e0 e1 ...)
+  (let ((x m))
+    (dynamic-wind
+      (lambda () (lock-mutex x))
+      (lambda () (begin e0 e1 ...))
+      (lambda () (unlock-mutex x)))))

-(define-syntax monitor
-  (syntax-rules ()
-    ((_ first rest ...)
-     (with-mutex (make-mutex)
-       first rest ...))))
+(define-syntax-rule (monitor first rest ...)
+  (with-mutex (make-mutex)
+    first rest ...))

 (define (par-mapper mapper)
  (lambda (proc . arglists)
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@ -70,14 +70,12 @@
    (fluid-set! f 2)
    f))

-(define-syntax define-inline
+(define-syntax-rule (define-inline (name formals ...) body ...)
  ;; Work around the lack of an inliner.
-  (syntax-rules ()
-    ((_ (name formals ...) body ...)
-     (define-syntax name
-       (syntax-rules ()
-         ((_ formals ...)
-          (begin body ...)))))))
+  (define-syntax name
+    (syntax-rules ()
+      ((_ formals ...)
+       (begin body ...)))))

 (define-inline (make-block base offset size hash-tab?)
  ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
@ -90,11 +88,9 @@
          base offset size 0
          (and hash-tab? (make-vector size #f))))

-(define-syntax define-block-accessor
-  (syntax-rules ()
-    ((_ name index)
-     (define-inline (name block)
-       (vector-ref block index)))))
+(define-syntax-rule (define-block-accessor name index)
+  (define-inline (name block)
+    (vector-ref block index)))

 (define-block-accessor block-content 0)
 (define-block-accessor block-base 1)
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@ -28,16 +28,14 @@
  #:export (compile-bytecode))

 (define (compile-bytecode assembly env . opts)
-  (define-syntax define-inline1
-    (syntax-rules ()
-      ((_ (proc arg) body body* ...)
-       (define-syntax proc
-         (syntax-rules ()
-           ((_ (arg-expr (... ...)))
-            (let ((x (arg-expr (... ...))))
-              (proc x)))
-           ((_ arg)
-            (begin body body* ...)))))))
+  (define-syntax-rule (define-inline1 (proc arg) body body* ...)
+    (define-syntax proc
+      (syntax-rules ()
+        ((_ (arg-expr (... ...)))
+         (let ((x (arg-expr (... ...))))
+           (proc x)))
+        ((_ arg)
+         (begin body body* ...)))))
       
  (define (fill-bytecode bv target-endianness)
    (let ((pos 0))
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@ -25,20 +25,14 @@
  #:use-module (srfi srfi-1)
  #:export (compile-tree-il))

-(define-syntax ->
-  (syntax-rules ()
-    ((_ (type arg ...))
-     `(type ,arg ...))))
+(define-syntax-rule (-> (type arg ...))
+  `(type ,arg ...))

-(define-syntax @implv
-  (syntax-rules ()
-    ((_ sym)
-     (-> (@ '(language ecmascript impl) 'sym)))))
+(define-syntax-rule (@implv sym)
+  (-> (@ '(language ecmascript impl) 'sym)))

-(define-syntax @impl
-  (syntax-rules ()
-    ((_ sym arg ...)
-     (-> (apply (@implv sym) arg ...)))))
+(define-syntax-rule (@impl sym arg ...)
+  (-> (apply (@implv sym) arg ...)))

 (define (empty-lexical-environment)
  '())
@ -67,16 +61,14 @@
 ;; for emacs:
 ;; (put 'pmatch/source 'scheme-indent-function 1)

-(define-syntax pmatch/source
-  (syntax-rules ()
-    ((_ x clause ...)
-     (let ((x x))
-       (let ((res (pmatch x
-                    clause ...)))
-         (let ((loc (location x)))
-           (if loc
-               (set-source-properties! res (location x))))
-         res)))))
+(define-syntax-rule (pmatch/source x clause ...)
+  (let ((x x))
+    (let ((res (pmatch x
+                 clause ...)))
+      (let ((loc (location x)))
+        (if loc
+            (set-source-properties! res (location x))))
+      res)))

 (define (comp x e)
  (let ((l (location x)))
--- 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))
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@ -288,21 +288,18 @@
       #'(define-class-pre-definitions (rest ...) 
         out ... (define-class-pre-definition (slotopt ...)))))))

-(define-syntax define-class
-  (syntax-rules ()
-    ((_ name supers slot ...)
-     (begin
-       (define-class-pre-definitions (slot ...))
-       (if (and (defined? 'name)
-                (is-a? name <class>)
-                (memq <object> (class-precedence-list name)))
-           (class-redefinition name
-                               (class supers slot ... #:name 'name))
-           (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+(define-syntax-rule (define-class name supers slot ...)
+  (begin
+    (define-class-pre-definitions (slot ...))
+    (if (and (defined? 'name)
+             (is-a? name <class>)
+             (memq <object> (class-precedence-list name)))
+        (class-redefinition name
+                            (class supers slot ... #:name 'name))
+        (toplevel-define! 'name (class supers slot ... #:name 'name)))))
       
-(define-syntax standard-define-class
-  (syntax-rules ()
-    ((_ arg ...) (define-class arg ...))))
+(define-syntax-rule (standard-define-class arg ...)
+  (define-class arg ...))

 ;;;
 ;;; {Generic functions and accessors}
@ -390,13 +387,11 @@
        (else (make <generic> #:name name))))

 ;; same semantics as <generic>
-(define-syntax define-accessor
-  (syntax-rules ()
-    ((_ name)
-     (define name
-       (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
-             ((is-a? name <accessor>) (make <accessor> #:name 'name))
-             (else                    (ensure-accessor name 'name)))))))
+(define-syntax-rule (define-accessor name)
+  (define name
+    (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
+          ((is-a? name <accessor>) (make <accessor> #:name 'name))
+          (else                    (ensure-accessor name 'name)))))

 (define (make-setter-name name)
  (string->symbol (string-append "setter:" (symbol->string name))))
--- a/module/oop/goops/simple.scm
+++ b/module/oop/goops/simple.scm
@ -1,6 +1,6 @@
 ;;; installed-scm-file

-;;;; Copyright (C) 2005, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2005, 2006, 2010, 2011 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
@ -23,10 +23,8 @@
  :export (define-class)
  :no-backtrace)

-(define-syntax define-class
-  (syntax-rules ()
-    ((_ arg ...)
-     (define-class-with-accessors-keywords arg ...))))
+(define-syntax-rule (define-class arg ...)
+  (define-class-with-accessors-keywords arg ...))

 (module-use! (module-public-interface (current-module))
             (resolve-interface '(oop goops)))
--- a/module/oop/goops/stklos.scm
+++ b/module/oop/goops/stklos.scm
@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999,2002, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999,2002, 2006, 2010, 2011 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
@ -47,10 +47,8 @@
 ;;; Enable keyword support (*fixme*---currently this has global effect)
 (read-set! keywords 'prefix)

-(define-syntax define-class
-  (syntax-rules ()
-    ((_ name supers (slot ...) rest ...)
-     (standard-define-class name supers slot ... rest ...))))
+(define-syntax-rule (define-class name supers (slot ...) rest ...)
+  (standard-define-class name supers slot ... rest ...))

 (define (toplevel-define! name val)
  (module-define! (current-module) name val))
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@ -240,11 +240,9 @@ higher-order procedures."
  (scm-error 'wrong-type-arg (symbol->string caller)
             "Wrong type argument: ~S" (list arg) '()))

-(define-syntax check-arg
-  (syntax-rules ()
-    ((_ pred arg caller)
-     (if (not (pred arg))
-         (wrong-type-arg 'caller arg)))))
+(define-syntax-rule (check-arg pred arg caller)
+  (if (not (pred arg))
+      (wrong-type-arg 'caller arg)))

 (define (out-of-range proc arg)
  (scm-error 'out-of-range proc
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@ -1,6 +1,6 @@
 ;;; srfi-35.scm --- Conditions                 -*- coding: utf-8 -*-

-;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2009, 2010, 2011 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
@ -295,24 +295,20 @@ by C."
 ;;; Syntax.
 ;;;

-(define-syntax define-condition-type
-  (syntax-rules ()
-    ((_ name parent pred (field-name field-accessor) ...)
-     (begin
-       (define name
-         (make-condition-type 'name parent '(field-name ...)))
-       (define (pred c)
-         (condition-has-type? c name))
-       (define (field-accessor c)
-         (condition-ref c 'field-name))
-       ...))))
+(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
+  (begin
+    (define name
+      (make-condition-type 'name parent '(field-name ...)))
+    (define (pred c)
+      (condition-has-type? c name))
+    (define (field-accessor c)
+      (condition-ref c 'field-name))
+    ...))

-(define-syntax compound-condition
+(define-syntax-rule (compound-condition (type ...) (field ...))
  ;; Create a compound condition using `make-compound-condition-type'.
-  (syntax-rules ()
-    ((_ (type ...) (field ...))
-     (condition ((make-compound-condition-type '%compound `(,type ...))
-                 field ...)))))
+  (condition ((make-compound-condition-type '%compound `(,type ...))
+              field ...)))

 (define-syntax condition-instantiation
  ;; Build the `(make-condition type ...)' call.
--- a/module/srfi/srfi-39.scm
+++ b/module/srfi/srfi-39.scm
@ -1,6 +1,6 @@
 ;;; srfi-39.scm --- Parameter objects

-;; 	Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;; 	Copyright (C) 2004, 2005, 2006, 2008, 2011 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
@ -69,12 +69,10 @@
         ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
         (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))

-(define-syntax parameterize
-  (syntax-rules ()
-    ((_ ((?param ?value) ...) ?body ...)
-     (with-parameters* (list ?param ...)
-                       (list ?value ...)
-                       (lambda () ?body ...)))))
+(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
+  (with-parameters* (list ?param ...)
+                    (list ?value ...)
+                    (lambda () ?body ...)))

 (define (current-input-port . new-value)
  (if (null? new-value)
--- a/module/srfi/srfi-45.scm
+++ b/module/srfi/srfi-45.scm
@ -1,6 +1,6 @@
 ;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms

-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
 ;; Copyright (C) 2003 André van Tonder. All Rights Reserved.

 ;; Permission is hereby granted, free of charge, to any person
@ -47,17 +47,14 @@
  (tag value-tag value-tag-set!)
  (proc value-proc value-proc-set!))

-(define-syntax lazy
-  (syntax-rules ()
-    ((lazy exp)
-     (make-promise (make-value 'lazy (lambda () exp))))))
+(define-syntax-rule (lazy exp)
+  (make-promise (make-value 'lazy (lambda () exp))))

 (define (eager x)
  (make-promise (make-value 'eager x)))

-(define-syntax delay
-  (syntax-rules ()
-    ((delay exp) (lazy (eager exp)))))
+(define-syntax-rule (delay exp)
+  (lazy (eager exp)))

 (define (force promise)
  (let ((content (promise-val promise)))
--- a/module/srfi/srfi-67/compare.scm
+++ b/module/srfi/srfi-67/compare.scm
@ -1,3 +1,4 @@
+; Copyright (c) 2011 Free Software Foundation, Inc.
 ; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
 ; 
 ; Permission is hereby granted, free of charge, to any person obtaining
@ -88,14 +89,12 @@

 ; 3-sided conditional

-(define-syntax if3
-  (syntax-rules ()
-    ((if3 c less equal greater)
-     (case c
-       ((-1) less)
-       (( 0) equal)
-       (( 1) greater)
-       (else (error "comparison value not in {-1,0,1}"))))))
+(define-syntax-rule (if3 c less equal greater)
+  (case c
+    ((-1) less)
+    (( 0) equal)
+    (( 1) greater)
+    (else (error "comparison value not in {-1,0,1}"))))


 ; 2-sided conditionals for comparisons
@ -110,51 +109,37 @@
       (a-cases alternate)
       (else    (error "comparison value not in {-1,0,1}"))))))

-(define-syntax if=?
-  (syntax-rules ()
-    ((if=? arg ...)
-     (compare:if-rel? (0) (-1 1) arg ...))))
+(define-syntax-rule (if=? arg ...)
+  (compare:if-rel? (0) (-1 1) arg ...))

-(define-syntax if<?
-  (syntax-rules ()
-    ((if<? arg ...)
-     (compare:if-rel? (-1) (0 1) arg ...))))
+(define-syntax-rule (if<? arg ...)
+  (compare:if-rel? (-1) (0 1) arg ...))

-(define-syntax if>?
-  (syntax-rules ()
-    ((if>? arg ...)
-     (compare:if-rel? (1) (-1 0) arg ...))))
+(define-syntax-rule (if>? arg ...)
+  (compare:if-rel? (1) (-1 0) arg ...))

-(define-syntax if<=?
-  (syntax-rules ()
-    ((if<=? arg ...)
-     (compare:if-rel? (-1 0) (1) arg ...))))
+(define-syntax-rule (if<=? arg ...)
+  (compare:if-rel? (-1 0) (1) arg ...))

-(define-syntax if>=?
-  (syntax-rules ()
-    ((if>=? arg ...)
-     (compare:if-rel? (0 1) (-1) arg ...))))
+(define-syntax-rule (if>=? arg ...)
+  (compare:if-rel? (0 1) (-1) arg ...))

-(define-syntax if-not=?
-  (syntax-rules ()
-    ((if-not=? arg ...)
-     (compare:if-rel? (-1 1) (0) arg ...))))
+(define-syntax-rule if- (not=? arg ...)
+  (compare:if-rel? (-1 1) (0) arg ...))


 ; predicates from compare procedures

-(define-syntax compare:define-rel?
-  (syntax-rules ()
-    ((compare:define-rel? rel? if-rel?)
-     (define rel?
-       (case-lambda
-	(()        (lambda (x y) (if-rel? (default-compare x y) #t #f)))
-	((compare) (lambda (x y) (if-rel? (compare         x y) #t #f)))
-	((x y)                   (if-rel? (default-compare x y) #t #f))
-	((compare x y)
-	 (if (procedure? compare)
-	     (if-rel? (compare x y) #t #f)
-	     (error "not a procedure (Did you mean rel/rel??): " compare))))))))
+(define-syntax-rule compare:define- (rel? rel? if-rel?)
+  (define rel?
+    (case-lambda
+      (()        (lambda (x y) (if-rel? (default-compare x y) #t #f)))
+      ((compare) (lambda (x y) (if-rel? (compare         x y) #t #f)))
+      ((x y)                   (if-rel? (default-compare x y) #t #f))
+      ((compare x y)
+       (if (procedure? compare)
+           (if-rel? (compare x y) #t #f)
+           (error "not a procedure (Did you mean rel/rel??): " compare))))))

 (compare:define-rel? =?    if=?)
 (compare:define-rel? <?    if<?)
@ -166,29 +151,27 @@

 ; chains of length 3

-(define-syntax compare:define-rel1/rel2?
-  (syntax-rules ()
-    ((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
-     (define rel1/rel2?
-       (case-lambda
-	(()
-	 (lambda (x y z)
-	   (if-rel1? (default-compare x y)
-		     (if-rel2? (default-compare y z) #t #f)
-		     (compare:checked #f default-compare z))))
-	((compare)
-	 (lambda (x y z)
-	   (if-rel1? (compare x y)
-		(if-rel2? (compare y z) #t #f)
-		(compare:checked #f compare z))))
-	((x y z)
-	 (if-rel1? (default-compare x y)
-	       (if-rel2? (default-compare y z) #t #f)
-	       (compare:checked #f default-compare z)))
-	((compare x y z)
-	 (if-rel1? (compare x y)
-	       (if-rel2? (compare y z) #t #f)
-	       (compare:checked #f compare z))))))))
+(define-syntax-rule compare:define-rel1/ (rel2? rel1/rel2? if-rel1? if-rel2?)
+  (define rel1/rel2?
+    (case-lambda
+      (()
+       (lambda (x y z)
+         (if-rel1? (default-compare x y)
+                   (if-rel2? (default-compare y z) #t #f)
+                   (compare:checked #f default-compare z))))
+      ((compare)
+       (lambda (x y z)
+         (if-rel1? (compare x y)
+                   (if-rel2? (compare y z) #t #f)
+                   (compare:checked #f compare z))))
+      ((x y z)
+       (if-rel1? (default-compare x y)
+                 (if-rel2? (default-compare y z) #t #f)
+                 (compare:checked #f default-compare z)))
+      ((compare x y z)
+       (if-rel1? (compare x y)
+                 (if-rel2? (compare y z) #t #f)
+                 (compare:checked #f compare z))))))

 (compare:define-rel1/rel2? </<?   if<?  if<?)
 (compare:define-rel1/rel2? </<=?  if<?  if<=?)
@ -202,31 +185,29 @@

 ; chains of arbitrary length

-(define-syntax compare:define-chain-rel?
-  (syntax-rules ()
-    ((compare:define-chain-rel? chain-rel? if-rel?)
-     (define chain-rel?
-       (case-lambda
-	((compare)
-	 #t)
-	((compare x1)
-	 (compare:checked #t compare x1))
-	((compare x1 x2)
-	 (if-rel? (compare x1 x2) #t #f))
-	((compare x1 x2 x3)
-	 (if-rel? (compare x1 x2)
-		  (if-rel? (compare x2 x3) #t #f)
-		  (compare:checked #f compare x3)))
-	((compare x1 x2 . x3+)
-	 (if-rel? (compare x1 x2)
-		  (let chain? ((head x2) (tail x3+))
-		    (if (null? tail)
-			#t
-			(if-rel? (compare head (car tail))
-				 (chain? (car tail) (cdr tail))
-				 (apply compare:checked #f 
-					compare (cdr tail)))))
-		  (apply compare:checked #f compare x3+))))))))
+(define-syntax-rule compare:define-chain- (rel? chain-rel? if-rel?)
+  (define chain-rel?
+    (case-lambda
+      ((compare)
+       #t)
+      ((compare x1)
+       (compare:checked #t compare x1))
+      ((compare x1 x2)
+       (if-rel? (compare x1 x2) #t #f))
+      ((compare x1 x2 x3)
+       (if-rel? (compare x1 x2)
+                (if-rel? (compare x2 x3) #t #f)
+                (compare:checked #f compare x3)))
+      ((compare x1 x2 . x3+)
+       (if-rel? (compare x1 x2)
+                (let chain? ((head x2) (tail x3+))
+                  (if (null? tail)
+                      #t
+                      (if-rel? (compare head (car tail))
+                               (chain? (car tail) (cdr tail))
+                               (apply compare:checked #f 
+                                      compare (cdr tail)))))
+                (apply compare:checked #f compare x3+))))))

 (compare:define-chain-rel? chain=?  if=?)
 (compare:define-chain-rel? chain<?  if<?)
@ -468,19 +449,17 @@
     (begin (compare:type-check type? type-name x)
            (compare:type-check type? type-name y)))))

-(define-syntax compare:define-by=/<
-  (syntax-rules ()
-    ((compare:define-by=/< compare = < type? type-name)
-     (define compare
-       (let ((= =) (< <))
-	 (lambda (x y)
-	   (if (type? x)
-	       (if (eq? x y)
-		   0
-		   (if (type? y)
-		       (if (= x y) 0 (if (< x y) -1 1))
-		       (error (string-append "not " type-name ":") y)))
-	       (error (string-append "not " type-name ":") x))))))))
+(define-syntax-rule compare:define- (by=/< compare = < type? type-name)
+  (define compare
+    (let ((= =) (< <))
+      (lambda (x y)
+        (if (type? x)
+            (if (eq? x y)
+                0
+                (if (type? y)
+                    (if (= x y) 0 (if (< x y) -1 1))
+                    (error (string-append "not " type-name ":") y)))
+            (error (string-append "not " type-name ":") x))))))

 (define (boolean-compare x y)
  (compare:type-check boolean? "boolean" x y)
--- a/module/sxml/match.scm
+++ b/module/sxml/match.scm
@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011 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 License as published by
@ -40,34 +40,27 @@
 ;;; PLT compatibility layer.
 ;;;

-(define-syntax syntax-object->datum
-  (syntax-rules ()
-    ((_ stx)
-     (syntax->datum stx))))
+(define-syntax-rule (syntax-object->datum stx)
+  (syntax->datum stx))

-(define-syntax void
-  (syntax-rules ()
-    ((_) *unspecified*)))
+(define-syntax-rule (void)
+  *unspecified*)

 (define %call/ec-prompt
  (make-prompt-tag))

-(define-syntax call/ec
+(define-syntax-rule (call/ec proc)
  ;; aka. `call-with-escape-continuation'
-  (syntax-rules ()
-    ((_ proc)
-     (call-with-prompt %call/ec-prompt
-                       (lambda ()
-                         (proc (lambda args
-                                 (apply abort-to-prompt
-                                        %call/ec-prompt args))))
-                       (lambda (_ . args)
-                         (apply values args))))))
+  (call-with-prompt %call/ec-prompt
+                    (lambda ()
+                      (proc (lambda args
+                              (apply abort-to-prompt
+                                     %call/ec-prompt args))))
+                    (lambda (_ . args)
+                      (apply values args))))

-(define-syntax let/ec
-  (syntax-rules ()
-    ((_ cont body ...)
-     (call/ec (lambda (cont) body ...)))))
+(define-syntax-rule (let/ec cont body ...)
+  (call/ec (lambda (cont) body ...)))

 (define (raise-syntax-error x msg obj sub)
  (throw 'sxml-match-error x msg obj sub))
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@ -182,7 +182,5 @@
               (apply (if (memq k pass-keys) throw on-error) k args))
             (error "Unknown on-error strategy" on-error)))))))

-(define-syntax with-error-handling
-  (syntax-rules ()
-    ((_ form)
-     (call-with-error-handling (lambda () form)))))
+(define-syntax-rule (with-error-handling form)
+  (call-with-error-handling (lambda () form)))
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@ -135,15 +135,13 @@
  (run-repl (make-repl lang debug)))

 ;; (put 'abort-on-error 'scheme-indent-function 1)
-(define-syntax abort-on-error
-  (syntax-rules ()
-    ((_ string exp)
-     (catch #t
-       (lambda () exp)
-       (lambda (key . args)
-         (format #t "While ~A:~%" string)
-         (print-exception (current-output-port) #f key args)
-         (abort))))))
+(define-syntax-rule (abort-on-error string exp)
+  (catch #t
+    (lambda () exp)
+    (lambda (key . args)
+      (format #t "While ~A:~%" string)
+      (print-exception (current-output-port) #f key args)
+      (abort))))

 (define (run-repl repl)
  (define (with-stack-and-prompt thunk)
--- a/module/system/vm/inspect.scm
+++ b/module/system/vm/inspect.scm
@ -1,6 +1,6 @@
 ;;; Guile VM debugging facilities

-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011 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
@ -81,16 +81,15 @@
 ;;;

 (define (inspect x)
-  (define-syntax define-command
-    (syntax-rules ()
-      ((_ ((mod cname alias ...) . args) body ...)
-       (define cname
-         (let ((c (lambda* args body ...)))
-           (set-procedure-property! c 'name 'cname)
-           (module-define! mod 'cname c)
-           (module-add! mod 'alias (module-local-variable mod 'cname))
-           ...
-           c)))))
+  (define-syntax-rule (define-command ((mod cname alias ...) . args)
+                        body ...)
+    (define cname
+      (let ((c (lambda* args body ...)))
+        (set-procedure-property! c 'name 'cname)
+        (module-define! mod 'cname c)
+        (module-add! mod 'alias (module-local-variable mod 'cname))
+        ...
+        c)))

  (let ((commands (make-module)))
    (define (prompt)
--- a/module/texinfo.scm
+++ b/module/texinfo.scm
@ -77,6 +77,7 @@
  #:use-module (sxml transform)
  #:use-module (sxml ssax input-parse)
  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-13)
  #:export (call-with-file-and-dir
            texi-command-specs
@ -103,25 +104,6 @@ files by relative path name."
          (call-with-input-file (basename filename) proc))
        (lambda () (chdir current-dir)))))

-;; Define this version here, because (srfi srfi-11)'s definition uses
-;; syntax-rules, which is really damn slow
-(define-macro (let*-values bindings . body)
-  (if (null? bindings) (cons 'begin body)
-      (apply
-       (lambda (vars initializer)
-	 (let ((cont 
-		(cons 'let*-values
-		      (cons (cdr bindings) body))))
-	   (cond
-	    ((not (pair? vars))		; regular let case, a single var
-	     `(let ((,vars ,initializer)) ,cont))
-	    ((null? (cdr vars))		; single var, see the prev case
-	     `(let ((,(car vars) ,initializer)) ,cont))
-	   (else			; the most generic case
-	    `(call-with-values (lambda () ,initializer)
-	      (lambda ,vars ,cont))))))
-       (car bindings))))
-
 ;;========================================================================
 ;;            Reflection on the XML vocabulary

--- a/module/web/server.scm
+++ b/module/web/server.scm
@ -118,11 +118,9 @@
  (write server-impl-write)
  (close server-impl-close))

-(define-syntax define-server-impl
-  (syntax-rules ()
-    ((_ name open read write close)
-     (define name
-       (make-server-impl 'name open read write close)))))
+(define-syntax-rule (define-server-impl name open read write close)
+  (define name
+    (make-server-impl 'name open read write close)))

 (define (lookup-server-impl impl)
  "Look up a server implementation.  If @var{impl} is a server