diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index da8813baf..c52fed42c 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -3207,7 +3207,7 @@ key is typically a constant-time operation.
 
 The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as
 that of association lists found in SRFI-1, with procedure names prefixed by
-@code{vhash-} instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
+@code{vhash-} instead of @code{alist-} (@pxref{SRFI-1 Association Lists}).
 
 In addition, vhashes can be manipulated using VList operations:
 
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index f0eeb6e7e..92816ad82 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -24,9 +24,15 @@ macro must appear as the first element, like this:
 @end lisp
 
 @cindex macro expansion
+@cindex domain-specific language
+@cindex embedded domain-specific language
+@cindex DSL
+@cindex EDSL
 Macro expansion is a separate phase of evaluation, run before code is
 interpreted or compiled. A macro is a program that runs on programs, translating
-an embedded language into core Scheme.
+an embedded language into core Scheme@footnote{These days such embedded
+languages are often referred to as @dfn{embedded domain-specific
+languages}, or EDSLs.}.
 
 @menu
 * Defining Macros::             Binding macros, globally and locally.
@@ -336,6 +342,23 @@ This discussion is mostly relevant in the context of traditional Lisp macros
 (@pxref{Defmacros}), which do not preserve referential transparency. Hygiene
 adds to the expressive power of Scheme.
 
+@subsubsection Shorthands
+
+One often ends up writing simple one-clause @code{syntax-rules} macros.
+There is a convenient shorthand for this idiom, in the form of
+@code{define-syntax-rule}.
+
+@deffn {Syntax} define-syntax-rule (keyword . pattern) [docstring] template
+Define @var{keyword} as a new @code{syntax-rules} macro with one clause.
+@end deffn
+
+Cast into this form, our @code{when} example is significantly shorter:
+
+@example
+(define-syntax-rule (when c e ...)
+  (if c (begin e ...)))
+@end example
+
 @subsubsection Further Information
 
 For a formal definition of @code{syntax-rules} and its pattern language, see
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index 3feced4be..33c9819e4 100644
--- a/doc/ref/api-modules.texi
+++ b/doc/ref/api-modules.texi
@@ -919,28 +919,28 @@ can also work with modules from C, but it is more cumbersome.
 
 The following procedures are available.
 
-@deftypefn {C Procedure} SCM scm_current_module ()
+@deftypefn {C Function} SCM scm_current_module ()
 Return the module that is the @emph{current module}.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_set_current_module (SCM @var{module})
+@deftypefn {C Function} SCM scm_set_current_module (SCM @var{module})
 Set the current module to @var{module} and return the previous current
 module.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_call_with_current_module (SCM @var{module}, SCM (*@var{func})(void *), void *@var{data})
+@deftypefn {C Function} SCM scm_c_call_with_current_module (SCM @var{module}, SCM (*@var{func})(void *), void *@var{data})
 Call @var{func} and make @var{module} the current module during the
 call.  The argument @var{data} is passed to @var{func}.  The return
 value of @code{scm_c_call_with_current_module} is the return value of
 @var{func}.
 @end deftypefn
 
-@deftypefn SCM scm_public_variable (SCM @var{module_name}, SCM @var{name})
-@deftypefnx SCM scm_c_public_variable (const char * @var{module_name}, const char * @var{name})
+@deftypefn {C Function} SCM scm_public_variable (SCM @var{module_name}, SCM @var{name})
+@deftypefnx {C Function} SCM scm_c_public_variable ({const char *}@var{module_name}, {const char *}@var{name})
 Find a the variable bound to the symbol @var{name} in the public
 interface of the module named @var{module_name}.
 
- @var{module_name} should be a list of symbols, when represented as a
+@var{module_name} should be a list of symbols, when represented as a
 Scheme object, or a space-separated string, in the @code{const char *}
 case.  See @code{scm_c_define_module} below, for more examples.
 
@@ -948,17 +948,17 @@ Signals an error if no module was found with the given name.  If
 @var{name} is not bound in the module, just returns @code{#f}.
 @end deftypefn
 
-@deftypefn SCM scm_private_variable (SCM @var{module_name}, SCM @var{name})
-@deftypefnx SCM scm_c_private_variable (const char * @var{module_name}, const char * @var{name})
+@deftypefn {C Function} SCM scm_private_variable (SCM @var{module_name}, SCM @var{name})
+@deftypefnx {C Function} SCM scm_c_private_variable ({const char *}@var{module_name}, {const char *}@var{name})
 Like @code{scm_public_variable}, but looks in the internals of the
 module named @var{module_name} instead of the public interface.
 Logically, these procedures should only be called on modules you write.
 @end deftypefn
 
-@deftypefn SCM scm_public_lookup (SCM @var{module_name}, SCM @var{name})
-@deftypefnx SCM scm_c_public_lookup (const char * @var{module_name}, const char * @var{name})
-@deftypefnx SCM scm_private_lookup (SCM @var{module_name}, SCM @var{name})
-@deftypefnx SCM scm_c_private_lookup (const char * @var{module_name}, const char * @var{name})
+@deftypefn {C Function} SCM scm_public_lookup (SCM @var{module_name}, SCM @var{name})
+@deftypefnx {C Function} SCM scm_c_public_lookup ({const char *}@var{module_name}, {const char *}@var{name})
+@deftypefnx {C Function} SCM scm_private_lookup (SCM @var{module_name}, SCM @var{name})
+@deftypefnx {C Function} SCM scm_c_private_lookup ({const char *}@var{module_name}, {const char *}@var{name})
 Like @code{scm_public_variable} or @code{scm_private_variable}, but if
 the @var{name} is not bound in the module, signals an error.  Returns a
 variable, always.
@@ -977,10 +977,10 @@ SCM my_eval_string (SCM str)
 @end example
 @end deftypefn
 
-@deftypefn SCM scm_public_ref (SCM @var{module_name}, SCM @var{name})
-@deftypefnx SCM scm_c_public_ref (const char * @var{module_name}, const char * @var{name})
-@deftypefnx SCM scm_private_ref (SCM @var{module_name}, SCM @var{name})
-@deftypefnx SCM scm_c_private_ref (const char * @var{module_name}, const char * @var{name})
+@deftypefn {C Function} SCM scm_public_ref (SCM @var{module_name}, SCM @var{name})
+@deftypefnx {C Function} SCM scm_c_public_ref ({const char *}@var{module_name}, {const char *}@var{name})
+@deftypefnx {C Function} SCM scm_private_ref (SCM @var{module_name}, SCM @var{name})
+@deftypefnx {C Function} SCM scm_c_private_ref ({const char *}@var{module_name}, {const char *}@var{name})
 Like @code{scm_public_lookup} or @code{scm_private_lookup}, but
 additionally dereferences the variable.  If the variable object is
 unbound, signals an error.  Returns the value bound to @var{name} in
@@ -991,50 +991,50 @@ In addition, there are a number of other lookup-related procedures.  We
 suggest that you use the @code{scm_public_} and @code{scm_private_}
 family of procedures instead, if possible.
 
-@deftypefn {C Procedure} SCM scm_c_lookup (const char *@var{name})
+@deftypefn {C Function} SCM scm_c_lookup ({const char *}@var{name})
 Return the variable bound to the symbol indicated by @var{name} in the
 current module.  If there is no such binding or the symbol is not
 bound to a variable, signal an error.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_lookup (SCM @var{name})
+@deftypefn {C Function} SCM scm_lookup (SCM @var{name})
 Like @code{scm_c_lookup}, but the symbol is specified directly.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_module_lookup (SCM @var{module}, const char *@var{name})
-@deftypefnx {C Procedure} SCM scm_module_lookup (SCM @var{module}, SCM @var{name})
+@deftypefn {C Function} SCM scm_c_module_lookup (SCM @var{module}, {const char *}@var{name})
+@deftypefnx {C Function} SCM scm_module_lookup (SCM @var{module}, SCM @var{name})
 Like @code{scm_c_lookup} and @code{scm_lookup}, but the specified
 module is used instead of the current one.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_module_variable (SCM @var{module}, SCM @var{name})
+@deftypefn {C Function} SCM scm_module_variable (SCM @var{module}, SCM @var{name})
 Like @code{scm_module_lookup}, but if the binding does not exist, just
 returns @code{#f} instead of raising an error.
 @end deftypefn
 
 To define a value, use @code{scm_define}:
 
-@deftypefn {C Procedure} SCM scm_c_define (const char *@var{name}, SCM @var{val})
+@deftypefn {C Function} SCM scm_c_define ({const char *}@var{name}, SCM @var{val})
 Bind the symbol indicated by @var{name} to a variable in the current
 module and set that variable to @var{val}.  When @var{name} is already
 bound to a variable, use that.  Else create a new variable.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_define (SCM @var{name}, SCM @var{val})
+@deftypefn {C Function} SCM scm_define (SCM @var{name}, SCM @var{val})
 Like @code{scm_c_define}, but the symbol is specified directly.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_module_define (SCM @var{module}, const char *@var{name}, SCM @var{val})
-@deftypefnx {C Procedure} SCM scm_module_define (SCM @var{module}, SCM @var{name}, SCM @var{val})
+@deftypefn {C Function} SCM scm_c_module_define (SCM @var{module}, {const char *}@var{name}, SCM @var{val})
+@deftypefnx {C Function} SCM scm_module_define (SCM @var{module}, SCM @var{name}, SCM @var{val})
 Like @code{scm_c_define} and @code{scm_define}, but the specified
 module is used instead of the current one.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_module_reverse_lookup (SCM @var{module}, SCM @var{variable})
+@deftypefn {C Function} SCM scm_module_reverse_lookup (SCM @var{module}, SCM @var{variable})
 Find the symbol that is bound to @var{variable} in @var{module}.  When no such binding is found, return @var{#f}.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_define_module (const char *@var{name}, void (*@var{init})(void *), void *@var{data})
+@deftypefn {C Function} SCM scm_c_define_module ({const char *}@var{name}, void (*@var{init})(void *), void *@var{data})
 Define a new module named @var{name} and make it current while
 @var{init} is called, passing it @var{data}.  Return the module.
 
@@ -1046,25 +1046,25 @@ When there already exists a module named @var{name}, it is used
 unchanged, otherwise, an empty module is created.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_resolve_module (const char *@var{name})
+@deftypefn {C Function} SCM scm_c_resolve_module ({const char *}@var{name})
 Find the module name @var{name} and return it.  When it has not
 already been defined, try to auto-load it.  When it can't be found
 that way either, create an empty module.  The name is interpreted as
 for @code{scm_c_define_module}.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_resolve_module (SCM @var{name})
+@deftypefn {C Function} SCM scm_resolve_module (SCM @var{name})
 Like @code{scm_c_resolve_module}, but the name is given as a real list
 of symbols.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_use_module (const char *@var{name})
+@deftypefn {C Function} SCM scm_c_use_module ({const char *}@var{name})
 Add the module named @var{name} to the uses list of the current
 module, as with @code{(use-modules @var{name})}.  The name is
 interpreted as for @code{scm_c_define_module}.
 @end deftypefn
 
-@deftypefn {C Procedure} SCM scm_c_export (const char *@var{name}, ...)
+@deftypefn {C Function} SCM scm_c_export ({const char *}@var{name}, ...)
 Add the bindings designated by @var{name}, ... to the public interface
 of the current module.  The list of names is terminated by
 @code{NULL}.
diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi
index 9379a8b98..ccb530157 100644
--- a/doc/ref/guile-invoke.texi
+++ b/doc/ref/guile-invoke.texi
@@ -156,6 +156,12 @@ interactive session.  When executing a script with @option{-s} or
 Do not use the debugging VM engine, even when entering an interactive
 session.
 
+Note that, despite the name, Guile running with @option{--no-debug}
+@emph{does} support the usual debugging facilities, such as printing a
+detailed backtrace upon error.  The only difference with
+@option{--debug} is lack of support for VM hooks and the facilities that
+build upon it (see above).
+
 @item -q
 @cindex init file, not loading
 @cindex @file{.guile} file, not loading
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index f43cc5ab8..9581f0c05 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -17,11 +17,10 @@ Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with
-no Invariant Sections, with the Front-Cover Texts being ``A GNU
-Manual,'' and with the Back-Cover Text ``You are free to copy and
-modify this GNU Manual.''.  A copy of the license is included in the
-section entitled ``GNU Free Documentation License''.
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
+copy of the license is included in the section entitled ``GNU Free
+Documentation License.''
 @end copying
 
 
diff --git a/doc/ref/match.texi b/doc/ref/match.texi
index 66bb0bfa8..d1618ce6e 100644
--- a/doc/ref/match.texi
+++ b/doc/ref/match.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2010  Free Software Foundation, Inc.
+@c Copyright (C) 2010, 2011  Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 @c
 
@@ -26,7 +26,7 @@ matcher found in many Scheme implementations.
 @cindex pattern variable
 A pattern matcher can match an object against several patterns and
 extract the elements that make it up.  Patterns can represent any Scheme
-object: lists, strings, symbols, etc.  They can optionally contain
+object: lists, strings, symbols, records, etc.  They can optionally contain
 @dfn{pattern variables}.  When a matching pattern is found, an
 expression associated with the pattern is evaluated, optionally with all
 pattern variables bound to the corresponding elements of the object:
@@ -43,8 +43,8 @@ In this example, list @var{l} matches the pattern @code{('hello (who))},
 because it is a two-element list whose first element is the symbol
 @code{hello} and whose second element is a one-element list.  Here
 @var{who} is a pattern variable.  @code{match}, the pattern matcher,
-locally binds @var{who} to the value contained in this one-element list,
-i.e., the symbol @code{world}.
+locally binds @var{who} to the value contained in this one-element
+list---i.e., the symbol @code{world}.
 
 The same object can be matched against a simpler pattern:
 
@@ -112,8 +112,8 @@ pat ::= identifier                      anything, and binds identifier
       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
                                           of remainder must match pat_n+1
       | #&pat                           box
-      | ($ struct-name pat_1 ... pat_n) a structure
-      | (= field pat)                   a field of a structure
+      | ($ record-name pat_1 ... pat_n) a record
+      | (= field pat)                   a ``field'' of an object
       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
@@ -122,11 +122,13 @@ pat ::= identifier                      anything, and binds identifier
       | (set! identifier)               anything, and binds setter
       | (get! identifier)               anything, and binds getter
       | `qp                             a quasi-pattern
+      | (identifier *** pat)            matches pat in a tree and binds
+                                        identifier to the path leading
+                                        to the object that matches pat
 
 ooo ::= ...                             zero or more
       | ___                             zero or more
-      | ..k                             k or more
-      | __k                             k or more
+      | ..1                             1 or more
 
         quasi-patterns:                 matches:
 
@@ -154,6 +156,40 @@ The names @code{quote}, @code{quasiquote}, @code{unquote},
 @code{or}, @code{not}, @code{set!}, @code{get!}, @code{...}, and
 @code{___} cannot be used as pattern variables.
 
+Here is a more complex example:
+
+@example
+(use-modules (srfi srfi-9))
+
+(let ()
+  (define-record-type person
+    (make-person name friends)
+    person?
+    (name    person-name)
+    (friends person-friends))
+
+  (letrec ((alice (make-person "Alice" (delay (list bob))))
+           (bob   (make-person "Bob" (delay (list alice)))))
+    (match alice
+      (($ person name (= force (($ person "Bob"))))
+       (list 'friend-of-bob name))
+      (_ #f))))
+
+@result{} (friend-of-bob "Alice")
+@end example
+
+@noindent
+Here the @code{$} pattern is used to match a SRFI-9 record of type
+@var{person} containing two or more slots.  The value of the first slot
+is bound to @var{name}.  The @code{=} pattern is used to apply
+@code{force} on the second slot, and then checking that the result
+matches the given pattern.  In other words, the complete pattern matches
+any @var{person} whose second slot is a promise that evaluates to a
+one-element list containing a @var{person} whose first slot is
+@code{"Bob"}.
+
+Please refer to the @code{ice-9/match.upstream.scm} file in your Guile
+installation for more details.
 
 Guile also comes with a pattern matcher specifically tailored to SXML
 trees, @xref{sxml-match}.
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 235bbbb83..a278ed5b9 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5436,6 +5436,9 @@ char_decimal_value (scm_t_uint32 c)
   return d;
 }
 
+/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
+   in base RADIX.  Upon success, return the unsigned integer and update
+   *P_IDX and *P_EXACTNESS accordingly.  Return #f on failure.  */
 static SCM
 mem2uinteger (SCM mem, unsigned int *p_idx,
 	      unsigned int radix, enum t_exactness *p_exactness)
@@ -5707,7 +5710,16 @@ mem2ureal (SCM mem, unsigned int *p_idx,
       /* Cobble up the fractional part.  We might want to set the
 	 NaN's mantissa from it. */
       idx += 4;
-      mem2uinteger (mem, &idx, 10, &implicit_x);
+      if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0))
+        {
+#if SCM_ENABLE_DEPRECATED == 1
+          scm_c_issue_deprecation_warning
+            ("Non-zero suffixes to `+nan.' are deprecated.  Use `+nan.0'.");
+#else
+          return SCM_BOOL_F;
+#endif
+        }
+          
       *p_idx = idx;
       return scm_nan ();
     }
diff --git a/libguile/snarf.h b/libguile/snarf.h
index b0800c42c..1c072babb 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -372,7 +372,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
     SCM_PACK (0),                                                       \
     foreign,                                                            \
     SCM_BOOL_F, /* the name */                                          \
-  };									\
+  }
 
 #define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars)         \
   static SCM_ALIGNED (8) SCM_UNUSED SCM                                 \
diff --git a/libguile/strings.c b/libguile/strings.c
index dd859c4d3..2de003514 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1779,14 +1779,16 @@ scm_to_latin1_stringn (SCM str, size_t *lenp)
 
   if (scm_i_is_narrow_string (str))
     {
-      if (lenp)
-	*lenp = scm_i_string_length (str);
+      size_t len = scm_i_string_length (str);
 
-      result = scm_strdup (scm_i_string_data (str));
+      if (lenp)
+        *lenp = len;
+
+      result = scm_strndup (scm_i_string_data (str), len);
     }
   else
     result = scm_to_stringn (str, lenp, NULL,
-			     SCM_FAILED_CONVERSION_ERROR);
+                             SCM_FAILED_CONVERSION_ERROR);
 
   return result;
 }
diff --git a/module/Makefile.am b/module/Makefile.am
index 0787f2004..6b265b60d 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -91,10 +91,12 @@ SCHEME_LANG_SOURCES =						\
 
 TREE_IL_LANG_SOURCES =						\
   language/tree-il/primitives.scm				\
-  language/tree-il/optimize.scm                                 \
-  language/tree-il/inline.scm                                   \
+  language/tree-il/peval.scm                                 	\
   language/tree-il/fix-letrec.scm                               \
+  language/tree-il/optimize.scm                                 \
+  language/tree-il/canonicalize.scm                             \
   language/tree-il/analyze.scm					\
+  language/tree-il/inline.scm 					\
   language/tree-il/compile-glil.scm 				\
   language/tree-il/spec.scm
 
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index b233a00a3..639a63c37 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -410,6 +410,20 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; The binding for `macroexpand' has now been overridden, making psyntax the
 ;; expander now.
 
+(define-syntax define-syntax-rule
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (name . pattern) template)
+       #'(define-syntax name
+           (syntax-rules ()
+             ((_ . pattern) template))))
+      ((_ (name . pattern) docstring template)
+       (string? (syntax->datum #'docstring))
+       #'(define-syntax name
+           (syntax-rules ()
+             docstring
+             ((_ . pattern) template)))))))
+
 (define-syntax and
   (syntax-rules ()
     ((_) #t)
@@ -504,9 +518,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 +530,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 +864,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 +886,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 +1387,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)))
 
 
 
@@ -2819,11 +2825,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
@@ -3150,10 +3154,8 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (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 ()
@@ -3164,18 +3166,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
@@ -3234,39 +3232,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 ...))
 
 
 
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index e94336a90..8aed74ec6 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -122,8 +122,8 @@ If FILE begins with `-' the -s switch is mandatory.
   -e FUNCTION    after reading script, apply FUNCTION to
                  command line arguments
   -ds            do -s script at this point
-  --debug        start with debugging evaluator and backtraces
-  --no-debug     start with normal evaluator
+  --debug        start with the \"debugging\" VM engine
+  --no-debug     start with the normal VM engine, which also supports debugging
                  Default is to enable debugging for interactive
                  use, but not for `-s' and `-c'.
   --auto-compile compile source files automatically
@@ -331,15 +331,15 @@ If FILE begins with `-' the -s switch is mandatory.
             (parse
              args
              (cons
-              (let ((where (substring arg 8)))
+              (let ((where (substring arg 9)))
                 (cond
                  ((string->number where) ; --listen=PORT
                   => (lambda (port)
                        (if (and (integer? port) (exact? port) (>= port 0))
-                           (error "invalid port for --listen")
                            `(@@ (system repl server)
                                 (spawn-server
-                                 (make-tcp-server-socket #:port ,port))))))
+                                 (make-tcp-server-socket #:port ,port)))
+                           (error "invalid port for --listen"))))
                  ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
                   `(@@ (system repl server)
                        (spawn-server
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 86b94ac6e..48bab9236 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 Free Software Foundation, Inc.
+;;; Copyright (C) 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
@@ -18,6 +18,7 @@
 
 (use-modules (language tree-il)
              (language tree-il optimize)
+             (language tree-il canonicalize)
              (ice-9 pretty-print))
 
 (let ((source (list-ref (command-line) 1))
@@ -34,10 +35,11 @@
             (close-port in))
           (begin
             (pretty-print (tree-il->scheme
-                           (optimize!
-                            (macroexpand x 'c '(compile load eval))
-                            (current-module)
-                            '()))
+                           (canonicalize!
+                            (optimize!
+                             (macroexpand x 'c '(compile load eval))
+                             (current-module)
+                             '())))
                           out)
             (newline out)
             (loop (read in))))))
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index 908e0e938..5f25738fa 100644
--- 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)))
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 012ebbf3f..3c4cd7d2c 100644
--- 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)))
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index 7cedff0bd..0384f69fc 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/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
@@ -28,11 +28,50 @@
   ;; Error procedure for run-time "no matching pattern" errors.
   (throw 'match-error "match" msg))
 
+;; Support for record matching.
+
+(define-syntax slot-ref
+  (syntax-rules ()
+    ((_ rtd rec n)
+     (struct-ref rec n))))
+
+(define-syntax slot-set!
+  (syntax-rules ()
+    ((_ rtd rec n value)
+     (struct-set! rec n value))))
+
+(define-syntax is-a?
+  (syntax-rules ()
+    ((_ rec rtd)
+     (and (struct? rec)
+          (eq? (struct-vtable rec) rtd)))))
+
 ;; Compared to Andrew K. Wright's `match', this one lacks `match-define',
 ;; `match:error-control', `match:set-error-control', `match:error',
 ;; `match:set-error', and all structure-related procedures.  Also,
 ;; `match' doesn't support clauses of the form `(pat => exp)'.
 
 ;; Unmodified public domain code by Alex Shinn retrieved from
-;; <http://synthcode.com/scheme/match.scm>.
+;; the Chibi-Scheme repository, commit 833:6daa2971f3fe.
+;;
+;; Note: Make sure to update `match.test.upstream' when updating this
+;; file.
 (include-from-path "ice-9/match.upstream.scm")
+
+(define-syntax match
+  (syntax-rules ()
+    ((match)
+     (match-syntax-error "missing match expression"))
+    ((match atom)
+     (match-syntax-error "no match clauses"))
+    ((match (app ...) (pat . body) ...)
+     (let ((v (app ...)))
+       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+    ((match #(vec ...) (pat . body) ...)
+     (let ((v #(vec ...)))
+       (match-next v (v (set! v)) (pat . body) ...)))
+    ((match atom (pat . body) ...)
+     (let ((v atom))
+       (match-next v (atom (set! atom)) (pat . body) ...)))
+    ))
+
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index df6b3d914..6fc01a6f3 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -1,20 +1,203 @@
 ;;;; match.scm -- portable hygienic pattern matcher
+;;;; -*- coding: utf-8 -*-
 ;;
 ;; This code is written by Alex Shinn and placed in the
 ;; Public Domain.  All warranties are disclaimed.
 
-;; This is a full superset of the popular MATCH package by Andrew
-;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
-;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
+;;> @example-import[(srfi 9)]
 
-;; This is a simple generative pattern matcher - each pattern is
-;; expanded into the required tests, calling a failure continuation if
-;; the tests fail.  This makes the logic easy to follow and extend,
-;; but produces sub-optimal code in cases where you have many similar
-;; clauses due to repeating the same tests.  Nonetheless a smart
-;; compiler should be able to remove the redundant tests.  For
-;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
-;; hit.
+;;> This is a full superset of the popular @hyperlink[
+;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
+;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
+;;> and thus preserving hygiene.
+
+;;> The most notable extensions are the ability to use @emph{non-linear}
+;;> patterns - patterns in which the same identifier occurs multiple
+;;> times, tail patterns after ellipsis, and the experimental tree patterns.
+
+;;> @subsubsection{Patterns}
+
+;;> Patterns are written to look like the printed representation of
+;;> the objects they match.  The basic usage is
+
+;;> @scheme{(match expr (pat body ...) ...)}
+
+;;> where the result of @var{expr} is matched against each pattern in
+;;> turn, and the corresponding body is evaluated for the first to
+;;> succeed.  Thus, a list of three elements matches a list of three
+;;> elements.
+
+;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
+
+;;> If no patterns match an error is signalled.
+
+;;> Identifiers will match anything, and make the corresponding
+;;> binding available in the body.
+
+;;> @example{(match (list 1 2 3) ((a b c) b))}
+
+;;> If the same identifier occurs multiple times, the first instance
+;;> will match anything, but subsequent instances must match a value
+;;> which is @scheme{equal?} to the first.
+
+;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
+
+;;> The special identifier @scheme{_} matches anything, no matter how
+;;> many times it is used, and does not bind the result in the body.
+
+;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
+
+;;> To match a literal identifier (or list or any other literal), use
+;;> @scheme{quote}.
+
+;;> @example{(match 'a ('b 1) ('a 2))}
+
+;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
+;;> be used to quote a mostly literally matching object with selected
+;;> parts unquoted.
+
+;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
+
+;;> Often you want to match any number of a repeated pattern.  Inside
+;;> a list pattern you can append @scheme{...} after an element to
+;;> match zero or more of that pattern (like a regexp Kleene star).
+
+;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
+
+;;> Pattern variables matched inside the repeated pattern are bound to
+;;> a list of each matching instance in the body.
+
+;;> @example{(match (list 1 2) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
+
+;;> More than one @scheme{...} may not be used in the same list, since
+;;> this would require exponential backtracking in the general case.
+;;> However, @scheme{...} need not be the final element in the list,
+;;> and may be succeeded by a fixed number of patterns.
+
+;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
+
+;;> @scheme{___} is provided as an alias for @scheme{...} when it is
+;;> inconvenient to use the ellipsis (as in a syntax-rules template).
+
+;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
+;;> that it matches one or more repetitions (like a regexp "+").
+
+;;> @example{(match (list 1 2) ((a b c ..1) c))}
+;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
+
+;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
+;;> can be used to group and negate patterns analogously to their
+;;> Scheme counterparts.
+
+;;> The @scheme{and} operator ensures that all subpatterns match.
+;;> This operator is often used with the idiom @scheme{(and x pat)} to
+;;> bind @var{x} to the entire value that matches @var{pat}
+;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
+;;> conjunction with @scheme{not} patterns to match a general case
+;;> with certain exceptions.
+
+;;> @example{(match 1 ((and) #t))}
+;;> @example{(match 1 ((and x) x))}
+;;> @example{(match 1 ((and x 1) x))}
+
+;;> The @scheme{or} operator ensures that at least one subpattern
+;;> matches.  If the same identifier occurs in different subpatterns,
+;;> it is matched independently.  All identifiers from all subpatterns
+;;> are bound if the @scheme{or} operator matches, but the binding is
+;;> only defined for identifiers from the subpattern which matched.
+
+;;> @example{(match 1 ((or) #t) (else #f))}
+;;> @example{(match 1 ((or x) x))}
+;;> @example{(match 1 ((or x 2) x))}
+
+;;> The @scheme{not} operator succeeds if the given pattern doesn't
+;;> match.  None of the identifiers used are available in the body.
+
+;;> @example{(match 1 ((not 2) #t))}
+
+;;> The more general operator @scheme{?} can be used to provide a
+;;> predicate.  The usage is @scheme{(? predicate pat ...)} where
+;;> @var{predicate} is a Scheme expression evaluating to a predicate
+;;> called on the value to match, and any optional patterns after the
+;;> predicate are then matched as in an @scheme{and} pattern.
+
+;;> @example{(match 1 ((? odd? x) x))}
+
+;;> The field operator @scheme{=} is used to extract an arbitrary
+;;> field and match against it.  It is useful for more complex or
+;;> conditional destructuring that can't be more directly expressed in
+;;> the pattern syntax.  The usage is @scheme{(= field pat)}, where
+;;> @var{field} can be any expression, and should result in a
+;;> procedure of one argument, which is applied to the value to match
+;;> to generate a new value to match against @var{pat}.
+
+;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
+;;> to @scheme{(x . y)}, except it will result in an immediate error
+;;> if the value isn't a pair.
+
+;;> @example{(match '(1 . 2) ((= car x) x))}
+;;> @example{(match 4 ((= sqrt x) x))}
+
+;;> The record operator @scheme{$} is used as a concise way to match
+;;> records defined by SRFI-9 (or SRFI-99).  The usage is
+;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
+;;> type descriptor specified as the first argument to
+;;> @scheme{define-record-type}, and each @var{field} is a subpattern
+;;> matched against the fields of the record in order.  Not all fields
+;;> must be present.
+
+;;> @example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     (($ employee n t) (list t n))))
+;;> }
+
+;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
+;;> identifier to the setter and getter of a field, respectively.  The
+;;> setter is a procedure of one argument, which mutates the field to
+;;> that argument.  The getter is a procedure of no arguments which
+;;> returns the current value of the field.
+
+;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
+;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
+
+;;> The new operator @scheme{***} can be used to search a tree for
+;;> subpatterns.  A pattern of the form @scheme{(x *** y)} represents
+;;> the subpattern @var{y} located somewhere in a tree where the path
+;;> from the current object to @var{y} can be seen as a list of the
+;;> form @scheme{(x ...)}.  @var{y} can immediately match the current
+;;> object in which case the path is the empty list.  In a sense it's
+;;> a 2-dimensional version of the @scheme{...} pattern.
+
+;;> As a common case the pattern @scheme{(_ *** y)} can be used to
+;;> search for @var{y} anywhere in a tree, regardless of the path
+;;> used.
+
+;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
+;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Notes
+
+;; The implementation is a simple generative pattern matcher - each
+;; pattern is expanded into the required tests, calling a failure
+;; continuation if the tests fail.  This makes the logic easy to
+;; follow and extend, but produces sub-optimal code in cases where you
+;; have many similar clauses due to repeating the same tests.
+;; Nonetheless a smart compiler should be able to remove the redundant
+;; tests.  For MATCH-LET and DESTRUCTURING-BIND type uses there is no
+;; performance hit.
 
 ;; The original version was written on 2006/11/29 and described in the
 ;; following Usenet post:
@@ -28,6 +211,9 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
+;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
+;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
 ;; 2009/11/25 - adding `***' tree search patterns
 ;; 2008/03/20 - fixing bug where (a ...) matched non-lists
 ;; 2008/03/15 - removing redundant check in vector patterns
@@ -49,6 +235,21 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;;> @subsubsection{Syntax}
+
+;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
+;;> (match expr (pattern (=> failure) . body) ...)}}
+
+;;> The result of @var{expr} is matched against each @var{pattern} in
+;;> turn, according to the pattern rules described in the previous
+;;> section, until the the first @var{pattern} matches.  When a match is
+;;> found, the corresponding @var{body}s are evaluated in order,
+;;> and the result of the last expression is returned as the result
+;;> of the entire @scheme{match}.  If a @var{failure} is provided,
+;;> then it is bound to a procedure of no arguments which continues,
+;;> processing at the next @var{pattern}.  If no @var{pattern} matches,
+;;> an error is signalled.
+
 ;; The basic interface.  MATCH just performs some basic syntax
 ;; validation, binds the match expression to a temporary variable `v',
 ;; and passes it on to MATCH-NEXT.  It's a constant throughout the
@@ -165,6 +366,10 @@
      (if (pair? v)
          (match-one v (p ___) g+s sk fk i)
          fk))
+    ((match-two v ($ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
     ((match-two v (p . q) g+s sk fk i)
      (if (pair? v)
          (let ((w (car v)) (x (cdr v)))
@@ -240,6 +445,11 @@
   (syntax-rules ()
     ((_ expr ids ...) expr)))
 
+(define-syntax match-tuck-ids
+  (syntax-rules ()
+    ((_ (letish args (expr ...)) ids ...)
+     (letish args (expr ... ids ...)))))
+
 (define-syntax match-drop-first-arg
   (syntax-rules ()
     ((_ arg expr) expr)))
@@ -309,14 +519,14 @@
       r
       (let* ((tail-len (length 'r))
              (ls v)
-             (len (length ls)))
-        (if (< len tail-len)
+             (len (and (list? ls) (length ls))))
+        (if (or (not len) (< len tail-len))
             fk
             (let loop ((ls ls) (n len) (id-ls '()) ...)
               (cond
                 ((= n tail-len)
                  (let ((id (reverse id-ls)) ...)
-                   (match-one ls r (#f #f) (sk ... i) fk i)))
+                   (match-one ls r (#f #f) (sk ...) fk i)))
                 ((pair? ls)
                  (let ((w (car ls)))
                    (match-one w p ((car ls) (set-car! ls))
@@ -349,21 +559,7 @@
     ((_ x sk)
      (match-syntax-error "dotted tail not allowed after ellipse" x))))
 
-;; Matching a tree search pattern is only slightly more complicated.
-;; Here we allow patterns of the form
-;;
-;;     (x *** y)
-;;
-;; to represent the pattern y located somewhere in a tree where the
-;; path from the current object to y can be seen as a list of the form
-;; (X ...).  Y can immediately match the current object in which case
-;; the path is the empty list.  In a sense it's a 2-dimensional
-;; version of the ... pattern.
-;;
-;; As a common case the pattern (_ *** y) can be used to search for Y
-;; anywhere in a tree, regardless of the path used.
-;;
-;; To implement the search, we use two recursive procedures.  TRY
+;; To implement the tree search, we use two recursive procedures.  TRY
 ;; attempts to match Y once, and on success it calls the normal SK on
 ;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
 ;; call NEXT which first checks if the current value is a list
@@ -380,7 +576,7 @@
     ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
      (letrec ((try (lambda (w fail id-ls ...)
                      (match-one w q g+s
-                                (match-drop-ids
+                                (match-tuck-ids
                                  (let ((id (reverse id-ls)) ...)
                                    sk))
                                 (next w fail id-ls ...) i)))
@@ -475,6 +671,15 @@
                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                       fk i)))))))
 
+(define-syntax match-record-refs
+  (syntax-rules ()
+    ((_ v rec n (p . q) g+s sk fk i)
+     (let ((w (slot-ref rec v n)))
+       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
+                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
+    ((_ v rec n () g+s (sk ...) fk i)
+     (sk ... i))))
+
 ;; Extract all identifiers in a pattern.  A little more complicated
 ;; than just looking for symbols, we need to ignore special keywords
 ;; and non-pattern forms (such as the predicate expression in ?
@@ -518,8 +723,8 @@
      (match-extract-vars (p ...) . x))
     ((match-extract-vars _ (k ...) i v)    (k ... v))
     ((match-extract-vars ___ (k ...) i v)  (k ... v))
-    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
     ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
     ;; This is the main part, the only place where we might add a new
     ;; var if it's an unbound symbol.
     ((match-extract-vars p (k ...) (i ...) v)
@@ -527,7 +732,7 @@
          ((new-sym?
            (syntax-rules (i ...)
              ((new-sym? p sk fk) sk)
-             ((new-sym? x sk fk) fk))))
+             ((new-sym? any sk fk) fk))))
        (new-sym? random-sym-to-match
                  (k ... ((p p-ls) . v))
                  (k ... v))))
@@ -572,24 +777,42 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Gimme some sugar baby.
 
+;;> Shortcut for @scheme{lambda} + @scheme{match}.  Creates a
+;;> procedure of one argument, and matches that argument against each
+;;> clause.
+
 (define-syntax match-lambda
   (syntax-rules ()
-    ((_ clause ...) (lambda (expr) (match expr clause ...)))))
+    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
+
+;;> Similar to @scheme{match-lambda}.  Creates a procedure of any
+;;> number of arguments, and matches the argument list against each
+;;> clause.
 
 (define-syntax match-lambda*
   (syntax-rules ()
-    ((_ clause ...) (lambda expr (match expr clause ...)))))
+    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
+
+;;> Matches each var to the corresponding expression, and evaluates
+;;> the body with all match variables in scope.  Raises an error if
+;;> any of the expressions fail to match.  Syntax analogous to named
+;;> let can also be used for recursive functions which match on their
+;;> arguments as in @scheme{match-lambda*}.
 
 (define-syntax match-let
   (syntax-rules ()
-    ((_ (vars ...) . body)
-     (match-let/helper let () () (vars ...) . body))
-    ((_ loop . rest)
-     (match-named-let loop () . rest))))
+    ((_ ((var value) ...) . body)
+     (match-let/helper let () () ((var value) ...) . body))
+    ((_ loop ((var init) ...) . body)
+     (match-named-let loop ((var init) ...) . body))))
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
+;;> matches and binds the variables with all match variables in scope.
 
 (define-syntax match-letrec
   (syntax-rules ()
-    ((_ vars . body) (match-let/helper letrec () () vars . body))))
+    ((_ ((var value) ...) . body)
+     (match-let/helper letrec () () ((var value) ...) . body))))
 
 (define-syntax match-let/helper
   (syntax-rules ()
@@ -617,6 +840,12 @@
     ((_ loop (v ...) ((pat expr) . rest) . body)
      (match-named-let loop (v ... (pat expr tmp)) rest . body))))
 
+;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
+;;> matches and binds the variables in sequence, with preceding match
+;;> variables in scope.
+
 (define-syntax match-let*
   (syntax-rules ()
     ((_ () . body)
diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm
index 50a829912..dc4ec9571 100644
--- 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))
diff --git a/module/ice-9/poll.scm b/module/ice-9/poll.scm
index 26b264b8e..cf61294d7 100644
--- 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)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 292d6e27e..1717ba506 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -272,9 +272,8 @@
         (lambda (x mod)
           (primitive-eval x)))
     
-      (define-syntax gensym-hook
-        (syntax-rules ()
-          ((_) (gensym))))
+      (define-syntax-rule (gensym-hook)
+        (gensym))
 
       (define put-global-definition-hook
         (lambda (symbol type val)
@@ -451,9 +450,8 @@
 
 
     ;; FIXME: use a faster gensym
-    (define-syntax build-lexical-var
-      (syntax-rules ()
-        ((_ src id) (gensym (string-append (symbol->string id) " ")))))
+    (define-syntax-rule (build-lexical-var src id)
+      (gensym (string-append (symbol->string id) " ")))
 
     (define-structure (syntax-object expression wrap module))
 
@@ -470,11 +468,9 @@
                           #f)))
          (else #f))))
 
-    (define-syntax arg-check
-      (syntax-rules ()
-        ((_ pred? e who)
-         (let ((x e))
-           (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
+    (define-syntax-rule (arg-check pred? e who)
+      (let ((x e))
+        (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
 
     ;; compile-time environments
 
@@ -537,12 +533,10 @@
         ((_ type value) (cons type value))
         ((_ 'type) '(type))
         ((_ type) (cons type '()))))
-    (define-syntax binding-type
-      (syntax-rules ()
-        ((_ x) (car x))))
-    (define-syntax binding-value
-      (syntax-rules ()
-        ((_ x) (cdr x))))
+    (define-syntax-rule (binding-type x)
+      (car x))
+    (define-syntax-rule (binding-value x)
+      (cdr x))
 
     (define-syntax null-env (identifier-syntax '()))
 
@@ -607,13 +601,11 @@
          ((syntax-object? x) (symbol? (syntax-object-expression x)))
          (else #f))))
 
-    (define-syntax id-sym-name
-      (syntax-rules ()
-        ((_ e)
-         (let ((x e))
-           (if (syntax-object? x)
-               (syntax-object-expression x)
-               x)))))
+    (define-syntax-rule (id-sym-name e)
+      (let ((x e))
+        (if (syntax-object? x)
+            (syntax-object-expression x)
+            x)))
 
     (define id-sym-name&marks
       (lambda (x w)
@@ -635,12 +627,11 @@
     (define-syntax wrap-subst (identifier-syntax cdr))
 
     (define-syntax subst-rename? (identifier-syntax vector?))
-    (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
-    (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
-    (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
-    (define-syntax make-rename
-      (syntax-rules ()
-        ((_ old new marks) (vector old new marks))))
+    (define-syntax-rule (rename-old x) (vector-ref x 0))
+    (define-syntax-rule (rename-new x) (vector-ref x 1))
+    (define-syntax-rule (rename-marks x) (vector-ref x 2))
+    (define-syntax-rule (make-rename old new marks)
+      (vector old new marks))
 
     ;; labels must be comparable with "eq?", have read-write invariance,
     ;; and distinct from symbols.
@@ -659,9 +650,8 @@
 
     (define-syntax top-wrap (identifier-syntax '((top))))
 
-    (define-syntax top-marked?
-      (syntax-rules ()
-        ((_ w) (memq 'top (wrap-marks w)))))
+    (define-syntax-rule (top-marked? w)
+      (memq 'top (wrap-marks w)))
 
     ;; Marks must be comparable with "eq?" and distinct from pairs and
     ;; the symbol top.  We do not use integers so that marks will remain
@@ -674,15 +664,13 @@
         (make-wrap (cons the-anti-mark (wrap-marks w))
                    (cons 'shift (wrap-subst w)))))
 
-    (define-syntax new-mark
-      (syntax-rules ()
-        ((_) (gensym "m"))))
+    (define-syntax-rule (new-mark)
+      (gensym "m"))
 
     ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
     ;; internal definitions, in which the ribcages are built incrementally
-    (define-syntax make-empty-ribcage
-      (syntax-rules ()
-        ((_) (make-ribcage '() '() '()))))
+    (define-syntax-rule (make-empty-ribcage)
+      (make-ribcage '() '() '()))
 
     (define extend-ribcage!
       ;; must receive ids with complete wraps
@@ -751,10 +739,9 @@
 
     (define id-var-name
       (lambda (id w)
-        (define-syntax first
-          (syntax-rules ()
-            ;; Rely on Guile's multiple-values truncation.
-            ((_ e) e)))
+        (define-syntax-rule (first e)
+          ;; Rely on Guile's multiple-values truncation.
+          e)
         (define search
           (lambda (sym subst marks)
             (if (null? subst)
@@ -2686,6 +2673,20 @@
              ((dummy . pattern) #'template)
              ...))))))
 
+(define-syntax define-syntax-rule
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (name . pattern) template)
+       #'(define-syntax name
+           (syntax-rules ()
+             ((_ . pattern) template))))
+      ((_ (name . pattern) docstring template)
+       (string? (syntax->datum #'docstring))
+       #'(define-syntax name
+           (syntax-rules ()
+             docstring
+             ((_ . pattern) template)))))))
+
 (define-syntax let*
   (lambda (x)
     (syntax-case x ()
diff --git a/module/ice-9/receive.scm b/module/ice-9/receive.scm
index f4f4d81a9..c931b5936 100644
--- 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))
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index ee7ff267c..047a73373 100644
--- 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)
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index d5e28d540..4b40b9932 100644
--- 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)
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 163ffccdc..85805a523 100644
--- 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))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index 7a96d0723..0914f920a 100644
--- 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 ...)
-     (-> (call (@implv sym) arg ...)))))
+(define-syntax-rule (@impl sym arg ...)
+  (-> (call (@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)))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index a0818227d..c76e41225 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -856,7 +856,7 @@
             (vector-fold2 (lambda (x codes addr)
                             (receive (subcode addr) (ref-or-dump x i addr)
                               (values (cons subcode codes) addr)))
-                          x '() addr)
+                          contents '() addr)
           (receive (shape addr) (ref-or-dump (array-shape x) i addr)
             (values (fold append
                           (let ((len (vector-length contents)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1264f3209..cd6b01e93 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -344,7 +344,7 @@
      `(dynref ,(unparse-tree-il fluid)))
 
     ((<dynset> fluid exp)
-     `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il 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)))
@@ -588,84 +588,82 @@ 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 ...)))
-                 ((<call> proc args)
-                  (let-values (((seed ...) (foldts proc seed ...)))
-                    (fold-values foldts args seed ...)))
-                 ((<primcall> name args)
-                  (fold-values foldts args seed ...))
-                 ((<seq> head tail)
-                  (let-values (((seed ...) (foldts head seed ...)))
-                    (foldts tail 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 ...)))
+              ((<call> proc args)
+               (let-values (((seed ...) (foldts proc seed ...)))
+                 (fold-values foldts args seed ...)))
+              ((<primcall> name args)
+               (fold-values foldts args seed ...))
+              ((<seq> head tail)
+               (let-values (((seed ...) (foldts head seed ...)))
+                 (foldts tail 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))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 9e5c685a5..e578a0596 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -23,6 +23,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
   #:use-module (system base syntax)
   #:use-module (system base message)
   #:use-module (system vm program)
@@ -869,25 +870,20 @@ accurate information is missing from a given `tree-il' element."
   ;; the name of the variable being defined; otherwise return #f.  This
   ;; assumes knowledge of the current implementation of `define-class' et al.
   (define (toplevel-define-arg args)
-    (and (pair? args) (pair? (cdr args)) (null? (cddr args))
-         (record-case (car args)
-           ((<const> exp)
-            (and (symbol? exp) exp))
-           (else #f))))
+    (match args
+      ((($ <const> _ (and (? symbol?) exp)) _)
+       exp)
+      (_ #f)))
 
-  (record-case proc
-    ((<module-ref> mod public? name)
-     (and (equal? mod '(oop goops))
-          (not public?)
-          (eq? name 'toplevel-define!)
-          (toplevel-define-arg args)))
-    ((<toplevel-ref> name)
+  (match proc
+    (($ <module-ref> _ '(oop goops) 'toplevel-define! #f)
+     (toplevel-define-arg args))
+    (($ <toplevel-ref> _ 'toplevel-define!)
      ;; This may be the result of expanding one of the GOOPS macros within
      ;; `oop/goops.scm'.
-     (and (eq? name 'toplevel-define!)
-          (eq? env (resolve-module '(oop goops)))
+     (and (eq? env (resolve-module '(oop goops)))
           (toplevel-define-arg args)))
-    (else #f)))
+    (_ #f)))
 
 (define unbound-variable-analysis
   ;; Report possibly unbound variables in the given tree.
@@ -1345,24 +1341,17 @@ accurate information is missing from a given `tree-il' element."
                               min-count max-count))))
           (else (error "computer bought the farm" state))))))
 
-;; Return the literal format pattern for X, or #f.
 (define (const-fmt x)
-  (record-case x
-    ((<const> exp)
+  ;; Return the literal format pattern for X, or #f.
+  (match x
+    (($ <const> _ exp)
      exp)
-    ((<call> proc args)
+    (($ <call> _
+        (or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
+        (($ <const> _ (and (? string?) fmt))))
      ;; Gettexted literals, like `(_ "foo")'.
-     (and (record-case proc
-            ((<toplevel-ref> name) (eq? name '_))
-            ((<module-ref> name) (eq? name '_))
-            (else #f))
-          (pmatch args
-            ((,fmt)
-             (record-case fmt
-               ((<const> exp) exp)
-               (else #f)))
-            (else #f))))
-    (else #f)))
+     fmt)
+    (_ #f)))
 
 (define format-analysis
   ;; Report arity mismatches in the given tree.
@@ -1413,18 +1402,13 @@ accurate information is missing from a given `tree-il' element."
        (and (module? env)
             (false-if-exception (module-ref env name))))
 
-     (record-case x
-       ((<call> proc args src)
-        (let ((loc src))
-          (record-case proc
-            ((<toplevel-ref> name src)
-             (let ((proc (resolve-toplevel name)))
-               (and (or (eq? proc format)
-                        (eq? proc (@ (ice-9 format) format)))
-                    (check-format-args args (or src (find pair? locs))))))
-            (else #t)))
-        #t)
-       (else #t))
+     (match x
+       (($ <call> src ($ <toplevel-ref> _ name) args)
+        (let ((proc (resolve-toplevel name)))
+          (and (or (eq? proc format)
+                   (eq? proc (@ (ice-9 format) format)))
+               (check-format-args args (or src (find pair? locs))))))
+       (_ #t))
      #t)
 
    (lambda (x _ env locs)
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
new file mode 100644
index 000000000..27d72956f
--- /dev/null
+++ b/module/language/tree-il/canonicalize.scm
@@ -0,0 +1,76 @@
+;;; Tree-il canonicalizer
+
+;; Copyright (C) 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 the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language tree-il canonicalize)
+  #:use-module (language tree-il)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #: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!
+   (lambda (x)
+     (match x
+       (($ <let> src () () () body)
+        body)
+       (($ <letrec> src _ () () () body)
+        body)
+       (($ <fix> src () () () body)
+        body)
+       (($ <dynlet> src () () body)
+        body)
+       (($ <prompt> src tag body handler)
+        (define (escape-only? handler)
+          (match handler
+            (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
+             (tree-il-any (lambda (x)
+                            (and (lexical-ref? x)
+                                 (eq? (lexical-ref-gensym x) cont)))
+                          body))
+            (else #f)))
+        (define (thunk-application? x)
+          (match x
+            (($ <call> _
+                ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
+                ()) #t)
+            (_ #f)))
+        (define (make-thunk-application body)
+          (define thunk
+            (make-lambda #f '()
+                         (make-lambda-case #f '() #f #f #f '() '() body #f)))
+          (make-call #f thunk '()))
+
+        ;; This code has a nasty job to do: to ensure that either the
+        ;; handler is escape-only, or the body is the application of a
+        ;; thunk.  Sad but true.
+        (if (or (escape-only? handler)
+                (thunk-application? body))
+            #f
+            (make-prompt src tag (make-thunk-application body) handler)))
+       (_ #f)))
+   x))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index a22063b0e..acb3e932e 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -27,6 +27,7 @@
   #:use-module (system vm instruction)
   #:use-module (language tree-il)
   #:use-module (language tree-il optimize)
+  #:use-module (language tree-il canonicalize)
   #:use-module (language tree-il analyze)
   #:use-module ((srfi srfi-1) #:select (filter-map))
   #:export (compile-glil))
@@ -64,6 +65,7 @@
   (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))
          (allocation (analyze-lexicals x)))
 
     (with-fluids ((*comp-module* e))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index 16af52a18..5a2d9af55 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -17,189 +17,9 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (language tree-il inline)
-  #:use-module (system base pmatch)
-  #:use-module (system base syntax)
-  #:use-module (language tree-il)
   #:export (inline!))
 
-;; Possible optimizations:
-;; * constant folding, propagation
-;; * procedure inlining
-;;   * always when single call site
-;;   * always for "trivial" procs
-;;   * otherwise who knows
-;; * dead code elimination
-;; * degenerate case optimizations
-;; * "fixing letrec"
-
-(define (boolean-value x)
-  (let ((src (tree-il-src x)))
-    (record-case x
-      ((<void>)
-       (make-const src #t))
-
-      ((<conditional> test consequent alternate)
-       (record-case (boolean-value test)
-         ((<const> exp)
-          (case exp
-            ((#t) (boolean-value consequent))
-            ((#f) (boolean-value alternate))
-            (else x)))
-         (else x)))
-      
-      ((<primcall> src name args)
-       (pmatch (cons name args)
-         ((,member ,k ,l) (guard (and (memq member '(memq memv))
-                                      (const? k)
-                                      (list? (const-exp l))))
-          (cond
-           ((null? (const-exp l))
-            (make-const #f #f))
-           ((const? k)
-            (make-const #f (->bool ((case member
-                                      ((memq) memq)
-                                      ((memv) memv)
-                                      (else (error "what" member)))
-                                    (const-exp k) (const-exp l)))))
-           (else
-            (let lp ((elts (const-exp l)))
-              (let ((test (make-primcall
-                           #f
-                           (case member
-                             ((memq) 'eq?)
-                             ((memv) 'eqv?)
-                             (else (error "what" member)))
-                           (list k (make-const #f (car elts))))))
-                (if (null? (cdr elts))
-                    test
-                    (make-conditional
-                     src
-                     test
-                     (make-const #f #t)
-                     (lp (cdr elts)))))))))
-         (else x)))
-       
-      ((<lambda> meta body)
-       (make-const src #t))
-
-      ((<const> exp)
-       (make-const src (not (not exp))))
-
-      (else
-       x))))
-
-;; This is a completely brain-dead optimization pass whose sole claim to
-;; fame is ((lambda () x)) => x.
 (define (inline! x)
-  (define (inline1 x)
-    (record-case x
-      ((<call> src proc args)
-       (record-case proc
-         ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
-         ((<lambda> body)
-          (let lp ((lcase body))
-            (and lcase
-                 (record-case lcase
-                   ((<lambda-case> req opt rest kw inits gensyms body alternate)
-                    (if (and (= (length gensyms) (length req) (length args)))
-                        (let ((x (make-let src req gensyms args body)))
-                          (or (inline1 x) x))
-                        (lp alternate)))))))
-
-         (else #f)))
-       
-      ((<primcall> src name args)
-       (pmatch (cons name args)
-         ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
-         ;; => (let-values (((a b . c) foo)) bar)
-         ;;
-         ;; Note that this is a singly-binding form of let-values.  Also
-         ;; note that Scheme's let-values expands into call-with-values,
-         ;; then here we reduce it to tree-il's let-values.
-         ((@call-with-values ,producer ,consumer)
-          (guard (lambda? consumer)
-                 (lambda-case? (lambda-body consumer))
-                 (not (lambda-case-opt (lambda-body consumer)))
-                 (not (lambda-case-kw (lambda-body consumer)))
-                 (not (lambda-case-alternate (lambda-body consumer))))
-          (make-let-values
-           src
-           (let ((x (make-call src producer '())))
-             (or (inline1 x) x))
-           (lambda-body consumer)))
-         (else #f)))
-
-      ((<conditional> test consequent alternate)
-       (let ((btest (boolean-value test)))
-         (or (record-case btest
-               ((<const> exp)
-                (case exp
-                  ((#t) consequent)
-                  ((#f) alternate)
-                  (else #f)))
-               (else #f))
-             (if (eq? test btest)
-                 x
-                 (make-conditional (conditional-src x)
-                                   btest consequent alternate)))))
-
-      ((<let> gensyms body)
-       (if (null? gensyms) body x))
-       
-      ((<letrec> gensyms body)
-       (if (null? gensyms) body x))
-       
-      ((<fix> gensyms body)
-       (if (null? gensyms) body x))
-       
-      ((<lambda-case> req opt rest kw gensyms body alternate)
-       (define (args-compatible? args gensyms)
-         (let lp ((args args) (gensyms gensyms))
-           (cond
-            ((null? args) (null? gensyms))
-            ((null? gensyms) #f)
-            ((and (lexical-ref? (car args))
-                  (eq? (lexical-ref-gensym (car args)) (car gensyms)))
-             (lp (cdr args) (cdr gensyms)))
-            (else #f))))
-         
-       (and (not opt) (not kw) rest (not alternate)
-            (record-case body
-              ((<primcall> name args)
-               ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
-               (and (eq? name '@apply)
-                    (pair? args)
-                    (lambda? (car args))
-                    (args-compatible? (cdr args) gensyms)
-                    (lambda-body (car args))))
-              (else #f))))
-
-      ;; Actually the opposite of inlining -- if the prompt cannot be proven to
-      ;; be escape-only, ensure that its body is the call of a thunk.
-      ((<prompt> src tag body handler)
-       (define (escape-only? handler)
-         (and (pair? (lambda-case-req handler))
-              (let ((cont (car (lambda-case-gensyms handler))))
-                (tree-il-fold (lambda (leaf escape-only?)
-                                (and escape-only?
-                                     (not
-                                      (and (lexical-ref? leaf)
-                                           (eq? (lexical-ref-gensym leaf) cont)))))
-                              (lambda (down escape-only?) escape-only?)
-                              (lambda (up escape-only?) escape-only?)
-                              #t
-                              (lambda-case-body handler)))))
-       (define (make-thunk body)
-         (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
-
-       (if (or (and (call? body)
-                    (lambda? (call-proc body))
-                    (null? (call-args body)))
-               (escape-only? handler))
-           x
-           (make-prompt src tag
-                        (make-call #f (make-thunk body) '())
-                        handler)))
-      
-      (else #f)))
-  (post-order! inline1 x))
+  (issue-deprecation-warning
+   "`inline!' is deprecated.  Use (language tree-il peval) instead.")
+  x)
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index dbbc21655..cb199053d 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 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 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
@@ -21,12 +21,17 @@
 (define-module (language tree-il optimize)
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
-  #:use-module (language tree-il inline)
+  #:use-module (language tree-il peval)
   #:use-module (language tree-il fix-letrec)
+  #:use-module (ice-9 match)
   #:export (optimize!))
 
 (define (optimize! x env opts)
-  (inline!
-   (fix-letrec!
-    (expand-primitives! 
-     (resolve-primitives! x env)))))
+  (let ((peval (match (memq #:partial-eval? opts)
+                 ((#:partial-eval? #f _ ...)
+                  ;; Disable partial evaluation.
+                  (lambda (x e) x))
+                 (_ peval))))
+    (fix-letrec!
+     (peval (expand-primitives! (resolve-primitives! x env))
+            env))))
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
new file mode 100644
index 000000000..664792098
--- /dev/null
+++ b/module/language/tree-il/peval.scm
@@ -0,0 +1,922 @@
+;;; Tree-IL partial evaluator
+
+;; Copyright (C) 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 the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il peval)
+  #:use-module (language tree-il)
+  #:use-module (language tree-il primitives)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:export (peval))
+
+;;;
+;;; Partial evaluation.
+;;;
+
+(define (fresh-gensyms syms)
+  (map (lambda (x) (gensym (string-append (symbol->string x) " ")))
+       syms))
+
+(define (alpha-rename exp)
+  "Alpha-rename EXP.  For any lambda in EXP, generate new symbols and
+replace all lexical references to the former symbols with lexical
+references to the new symbols."
+  ;; XXX: This should be factorized somehow.
+  (let loop ((exp     exp)
+             (mapping vlist-null))             ; maps old to new gensyms
+    (match exp
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       ;; Create new symbols to replace GENSYMS and propagate them down
+       ;; in BODY and ALT.
+       (let* ((new     (fresh-gensyms
+                        (append req
+                                (or opt '())
+                                (if rest (list rest) '())
+                                (match kw
+                                  ((aok? (_ name _) ...) name)
+                                  (_ '())))))
+              (mapping (fold vhash-consq mapping gensyms new)))
+         (make-lambda-case src req opt rest
+                           (match kw
+                             ((aok? (kw name old) ...)
+                              (cons aok? (map list
+                                              kw
+                                              name
+                                              (take-right new (length old)))))
+                             (_ #f))
+                           (map (cut loop <> mapping) inits)
+                           new
+                           (loop body mapping)
+                           (and alt (loop alt mapping)))))
+      (($ <lexical-ref> src name gensym)
+       ;; Possibly replace GENSYM by the new gensym defined in MAPPING.
+       (let ((val (vhash-assq gensym mapping)))
+         (if val
+             (make-lexical-ref src name (cdr val))
+             exp)))
+      (($ <lexical-set> src name gensym exp)
+       (let ((val (vhash-assq gensym mapping)))
+         (make-lexical-set src name (if val (cdr val) gensym)
+                           (loop exp mapping))))
+      (($ <lambda> src meta body)
+       (make-lambda src meta (loop body mapping)))
+      (($ <let> src names gensyms vals body)
+       ;; As for `lambda-case' rename GENSYMS to avoid any collision.
+       (let* ((new     (fresh-gensyms names))
+              (mapping (fold vhash-consq mapping gensyms new))
+              (vals    (map (cut loop <> mapping) vals))
+              (body    (loop body mapping)))
+         (make-let src names new vals body)))
+      (($ <letrec> src in-order? names gensyms vals body)
+       ;; Likewise.
+       (let* ((new     (fresh-gensyms names))
+              (mapping (fold vhash-consq mapping gensyms new))
+              (vals    (map (cut loop <> mapping) vals))
+              (body    (loop body mapping)))
+         (make-letrec src in-order? names new vals body)))
+      (($ <fix> src names gensyms vals body)
+       ;; Likewise.
+       (let* ((new     (fresh-gensyms names))
+              (mapping (fold vhash-consq mapping gensyms new))
+              (vals    (map (cut loop <> mapping) vals))
+              (body    (loop body mapping)))
+         (make-fix src names new vals body)))
+      (($ <let-values> src exp body)
+       (make-let-values src (loop exp mapping) (loop body mapping)))
+      (($ <const>)
+       exp)
+      (($ <void>)
+       exp)
+      (($ <toplevel-ref>)
+       exp)
+      (($ <module-ref>)
+       exp)
+      (($ <primitive-ref>)
+       exp)
+      (($ <toplevel-set> src name exp)
+       (make-toplevel-set src name (loop exp mapping)))
+      (($ <toplevel-define> src name exp)
+       (make-toplevel-define src name (loop exp mapping)))
+      (($ <module-set> src mod name public? exp)
+       (make-module-set src mod name public? (loop exp mapping)))
+      (($ <dynlet> src fluids vals body)
+       (make-dynlet src
+                    (map (cut loop <> mapping) fluids)
+                    (map (cut loop <> mapping) vals)
+                    (loop body mapping)))
+      (($ <dynwind> src winder body unwinder)
+       (make-dynwind src
+                     (loop winder mapping)
+                     (loop body mapping)
+                     (loop unwinder mapping)))
+      (($ <dynref> src fluid)
+       (make-dynref src (loop fluid mapping)))
+      (($ <dynset> src fluid exp)
+       (make-dynset src (loop fluid mapping) (loop exp mapping)))
+      (($ <conditional> src condition subsequent alternate)
+       (make-conditional src
+                         (loop condition mapping)
+                         (loop subsequent mapping)
+                         (loop alternate mapping)))
+      (($ <call> src proc args)
+       (make-call src (loop proc mapping)
+                  (map (cut loop <> mapping) args)))
+      (($ <primcall> src name args)
+       (make-primcall src name (map (cut loop <> mapping) args)))
+      (($ <seq> src head tail)
+       (make-seq src (loop head mapping) (loop tail mapping)))
+      (($ <prompt> src tag body handler)
+       (make-prompt src (loop tag mapping) (loop body mapping)
+                    (loop handler mapping)))
+      (($ <abort> src tag args tail)
+       (make-abort src (loop tag mapping) (map (cut loop <> mapping) args)
+                   (loop tail mapping))))))
+
+(define-syntax-rule (let/ec k e e* ...)
+  (let ((tag (make-prompt-tag)))
+    (call-with-prompt
+     tag
+     (lambda ()
+       (let ((k (lambda args (apply abort-to-prompt tag args))))
+         e e* ...))
+     (lambda (_ res) res))))
+
+(define (tree-il-any proc exp)
+  (let/ec k
+    (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)))
+
+(define (vlist-any proc vlist)
+  (let ((len (vlist-length vlist)))
+    (let lp ((i 0))
+      (and (< i len)
+           (or (proc (vlist-ref vlist i))
+               (lp (1+ i)))))))
+
+(define-record-type <var>
+  (make-var name gensym refcount set?)
+  var?
+  (name var-name)
+  (gensym var-gensym)
+  (refcount var-refcount set-var-refcount!)
+  (set? var-set? set-var-set?!))
+
+(define* (build-var-table exp #:optional (table vlist-null))
+  (tree-il-fold
+   (lambda (exp res)
+     (match exp
+       (($ <lexical-ref> src name gensym)
+        (let ((var (vhash-assq gensym res)))
+          (if var
+              (begin
+                (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var))))
+                res)
+              (vhash-consq gensym (make-var name gensym 1 #f) res))))
+       (_ res)))
+   (lambda (exp res)
+     (match exp
+       (($ <lexical-set> src name gensym exp)
+        (let ((var (vhash-assq gensym res)))
+          (if var
+              (begin
+                (set-var-set?! (cdr var) #t)
+                res)
+              (vhash-consq gensym (make-var name gensym 0 #t) res))))
+       (_ res)))
+   (lambda (exp res) res)
+   table exp))
+
+(define-record-type <counter>
+  (%make-counter effort size continuation recursive? data prev)
+  counter?
+  (effort effort-counter)
+  (size size-counter)
+  (continuation counter-continuation)
+  (recursive? counter-recursive?)
+  (data counter-data)
+  (prev counter-prev))
+
+(define (abort-counter c)
+  ((counter-continuation c)))
+
+(define (record-effort! c)
+  (let ((e (effort-counter c)))
+    (if (zero? (variable-ref e))
+        (abort-counter c)
+        (variable-set! e (1- (variable-ref e))))))
+
+(define (record-size! c)
+  (let ((s (size-counter c)))
+    (if (zero? (variable-ref s))
+        (abort-counter c)
+        (variable-set! s (1- (variable-ref s))))))
+
+(define (find-counter data counter)
+  (and counter
+       (if (eq? data (counter-data counter))
+           counter
+           (find-counter data (counter-prev counter)))))
+
+(define* (transfer! from to #:optional
+                    (effort (variable-ref (effort-counter from)))
+                    (size (variable-ref (size-counter from))))
+  (define (transfer-counter! from-v to-v amount)
+    (let* ((from-balance (variable-ref from-v))
+           (to-balance (variable-ref to-v))
+           (amount (min amount from-balance)))
+      (variable-set! from-v (- from-balance amount))
+      (variable-set! to-v (+ to-balance amount))))
+
+  (transfer-counter! (effort-counter from) (effort-counter to) effort)
+  (transfer-counter! (size-counter from) (size-counter to) size))
+
+(define (make-top-counter effort-limit size-limit continuation data)
+  (%make-counter (make-variable effort-limit)
+                 (make-variable size-limit)
+                 continuation
+                 #t
+                 data
+                 #f))
+
+(define (make-nested-counter continuation data current)
+  (let ((c (%make-counter (make-variable 0)
+                          (make-variable 0)
+                          continuation
+                          #f
+                          data
+                          current)))
+    (transfer! current c)
+    c))
+
+(define (make-recursive-counter effort-limit size-limit orig current)
+  (let ((c (%make-counter (make-variable 0)
+                          (make-variable 0)
+                          (counter-continuation orig)
+                          #t
+                          (counter-data orig)
+                          current)))
+    (transfer! current c effort-limit size-limit)
+    c))
+
+(define (types-check? primitive-name args)
+  (case primitive-name
+    ((values) #t)
+    ((not pair? null? list? symbol? vector? struct?)
+     (= (length args) 1))
+    ((eq? eqv? equal?)
+     (= (length args) 2))
+    ;; FIXME: add more cases?
+    (else #f)))
+
+(define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
+                #:key
+                (operator-size-limit 40)
+                (operand-size-limit 20)
+                (value-size-limit 10)
+                (effort-limit 500)
+                (recursive-effort-limit 100))
+  "Partially evaluate EXP in compilation environment CENV, with
+top-level bindings from ENV and return the resulting expression.  Since
+it does not handle <fix> and <let-values>, it should be called before
+`fix-letrec'."
+
+  ;; This is a simple partial evaluator.  It effectively performs
+  ;; constant folding, copy propagation, dead code elimination, and
+  ;; inlining, but not across top-level bindings---there should be a way
+  ;; to allow this (TODO).
+  ;;
+  ;; Unlike a full-blown partial evaluator, it does not emit definitions
+  ;; of specialized versions of lambdas encountered on its way.  Also,
+  ;; it's not yet complete: it bails out for `prompt', etc.
+
+  (define local-toplevel-env
+    ;; The top-level environment of the module being compiled.
+    (let ()
+      (define (env-folder x env)
+        (match x
+          (($ <toplevel-define> _ name)
+           (vhash-consq name #t env))
+          (($ <seq> _ head tail)
+           (env-folder tail (env-folder head env)))
+          (_ env)))
+      (env-folder exp vlist-null)))
+
+  (define (local-toplevel? name)
+    (vhash-assq name local-toplevel-env))
+
+  (define store (build-var-table exp))
+
+  (define (assigned-lexical? sym)
+    (let ((v (vhash-assq sym store)))
+      (and v (var-set? (cdr v)))))
+
+  (define (lexical-refcount sym)
+    (let ((v (vhash-assq sym store)))
+      (if v (var-refcount (cdr v)) 0)))
+
+  (define (record-source-expression! orig new)
+    (set! store (vhash-consq new
+                             (source-expression orig)
+                             (build-var-table new store)))
+    new)
+
+  (define (source-expression new)
+    (let ((x (vhash-assq new store)))
+      (if x (cdr x) new)))
+
+  (define residual-lexical-references (make-hash-table))
+
+  (define (record-residual-lexical-reference! sym)
+    (hashq-set! residual-lexical-references sym #t))
+
+  (define (apply-primitive name args)
+    ;; todo: further optimize commutative primitives
+    (catch #t
+      (lambda ()
+        (call-with-values
+            (lambda ()
+              (apply (module-ref the-scm-module name) args))
+          (lambda results
+            (values #t results))))
+      (lambda _
+        (values #f '()))))
+
+  (define (inline-values exp src names gensyms body)
+    (let loop ((exp exp))
+      (match exp
+        ;; Some expression types are always singly-valued.
+        ((or ($ <const>)
+             ($ <void>)
+             ($ <lambda>)
+             ($ <lexical-ref>)
+             ($ <toplevel-ref>)
+             ($ <module-ref>)
+             ($ <primitive-ref>)
+             ($ <dynref>)
+             ($ <lexical-set>)          ; FIXME: these set! expressions
+             ($ <toplevel-set>)         ; could return zero values in
+             ($ <toplevel-define>)      ; the future
+             ($ <module-set>)           ;
+             ($ <dynset>))              ; 
+         (and (= (length names) 1)
+              (make-let src names gensyms (list exp) body)))
+        (($ <primcall> src (? singly-valued-primitive? name))
+         (and (= (length names) 1)
+              (make-let src names gensyms (list exp) body)))
+
+        ;; Statically-known number of values.
+        (($ <primcall> src 'values vals)
+         (and (= (length names) (length vals))
+              (make-let src names gensyms vals body)))
+
+        ;; Not going to copy code into both branches.
+        (($ <conditional>) #f)
+
+        ;; Bail on other applications.
+        (($ <call>) #f)
+        (($ <primcall>) #f)
+
+        ;; Bail on prompt and abort.
+        (($ <prompt>) #f)
+        (($ <abort>) #f)
+        
+        ;; Propagate to tail positions.
+        (($ <let> src names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-let src names gensyms vals body))))
+        (($ <letrec> src in-order? names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-letrec src in-order? names gensyms vals body))))
+        (($ <fix> src names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-fix src names gensyms vals body))))
+        (($ <let-values> src exp
+            ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
+         (let ((body (loop body)))
+           (and body
+                (make-let-values src exp
+                                 (make-lambda-case src2 req opt rest kw
+                                                   inits gensyms body #f)))))
+        (($ <dynwind> src winder body unwinder)
+         (let ((body (loop body)))
+           (and body
+                (make-dynwind src winder body unwinder))))
+        (($ <dynlet> src fluids vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-dynlet src fluids vals body))))
+        (($ <seq> src head tail)
+         (let ((tail (loop tail)))
+           (and tail (make-seq src head tail)))))))
+
+  (define (make-values src values)
+    (match values
+      ((single) single)                 ; 1 value
+      ((_ ...)                          ; 0, or 2 or more values
+       (make-primcall src 'values values))))
+
+  (define (constant-expression? x)
+    ;; Return true if X is constant---i.e., if it is known to have no
+    ;; effects, does not allocate storage for a mutable object, and does
+    ;; not access mutable data (like `car' or toplevel references).
+    (let loop ((x x))
+      (match x
+        (($ <void>) #t)
+        (($ <const>) #t)
+        (($ <lambda>) #t)
+        (($ <lambda-case> _ req opt rest kw inits _ body alternate)
+         (and (every loop inits) (loop body) (loop alternate)))
+        (($ <lexical-ref> _ _ gensym)
+         (not (assigned-lexical? gensym)))
+        (($ <primitive-ref>) #t)
+        (($ <conditional> _ condition subsequent alternate)
+         (and (loop condition) (loop subsequent) (loop alternate)))
+        (($ <primcall> _ name args)
+         (and (effect-free-primitive? name)
+              (not (constructor-primitive? name))
+              (types-check? name args)
+              (every loop args)))
+        (($ <call> _ ($ <lambda> _ _ body) args)
+         (and (loop body) (every loop args)))
+        (($ <seq> _ head tail)
+         (and (loop head) (loop tail)))
+        (($ <let> _ _ _ vals body)
+         (and (every loop vals) (loop body)))
+        (($ <letrec> _ _ _ _ vals body)
+         (and (every loop vals) (loop body)))
+        (($ <fix> _ _ _ vals body)
+         (and (every loop vals) (loop body)))
+        (($ <let-values> _ exp body)
+         (and (loop exp) (loop body)))
+        (($ <prompt> _ tag body handler)
+         (and (loop tag) (loop body) (loop handler)))
+        (_ #f))))
+
+  (define (prune-bindings names syms vals body for-effect
+                          build-result)
+    (let lp ((names names) (syms syms) (vals vals)
+             (names* '()) (syms* '()) (vals* '())
+             (effects '()))
+      (match (list names syms vals)
+       ((() () ())
+        (let ((body (list->seq #f (append effects (list body)))))
+          (if (null? names*)
+              body
+              (build-result (reverse names*) (reverse syms*)
+                            (reverse vals*) body))))
+       (((name . names) (sym . syms) (val . vals))
+        (if (hashq-ref residual-lexical-references sym)
+            (lp names syms vals
+                (cons name names*) (cons sym syms*) (cons val vals*)
+                effects)
+            (let ((effect (for-effect val)))
+              (lp names syms vals
+                  names* syms* vals*
+                  (if (void? effect)
+                      effects
+                      (cons effect effects)))))))))
+  
+  (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
+         (if (< res limit)
+             res
+             (k #f)))
+       0 x)
+      #t))
+  
+  (let loop ((exp   exp)
+             (env   vlist-null)         ; static environment
+             (counter #f)               ; inlined call stack
+             (ctx 'value))   ; effect, value, test, operator, or operand
+    (define (lookup var)
+      (and=> (vhash-assq var env) cdr))
+
+    (define (for-value exp)
+      (loop exp env counter 'value))
+    (define (for-operand exp)
+      (loop exp env counter 'operand))
+    (define (for-test exp)
+      (loop exp env counter 'test))
+    (define (for-effect exp)
+      (loop exp env counter 'effect))
+    (define (for-tail exp)
+      (loop exp env counter ctx))
+
+    (if counter
+        (record-effort! counter))
+
+    (match exp
+      (($ <const>)
+       (case ctx
+         ((effect) (make-void #f))
+         (else exp)))
+      (($ <void>)
+       (case ctx
+         ((test) (make-const #f #t))
+         (else exp)))
+      (($ <lexical-ref> _ _ gensym)
+       (case ctx
+         ((effect) (make-void #f))
+         (else
+          (let ((val (lookup gensym)))
+            (cond
+             ((or (not val)
+                  (assigned-lexical? gensym)
+                  (not (constant-expression? val)))
+              ;; Don't copy-propagate through assigned variables,
+              ;; and don't reorder effects.
+              (record-residual-lexical-reference! gensym)
+              exp)
+             ((lexical-ref? val)
+              (for-tail val))
+             ((or (const? val)
+                  (void? val)
+                  (primitive-ref? val))
+              ;; Always propagate simple values that cannot lead to
+              ;; code bloat.
+              (for-tail val))
+             ((= 1 (lexical-refcount gensym))
+              ;; Always propagate values referenced only once.
+              ;; There is no need to rename the bindings, as they
+              ;; are only being moved, not copied.  However in
+              ;; operator context we do rename it, as that
+              ;; effectively clears out the residualized-lexical
+              ;; flags that may have been set when this value was
+              ;; visited previously as an operand.
+              (case ctx
+                ((test) (for-test val))
+                ((operator) (record-source-expression! val (alpha-rename val)))
+                (else val)))
+             ;; FIXME: do demand-driven size accounting rather than
+             ;; these heuristics.
+             ((eq? ctx 'operator)
+              ;; A pure expression in the operator position.  Inline
+              ;; if it's a lambda that's small enough.
+              (if (and (lambda? val)
+                       (small-expression? val operator-size-limit))
+                  (record-source-expression! val (alpha-rename val))
+                  (begin
+                    (record-residual-lexical-reference! gensym)
+                    exp)))
+             ((eq? ctx 'operand)
+              ;; A pure expression in the operand position.  Inline
+              ;; if it's small enough.
+              (if (small-expression? val operand-size-limit)
+                  (record-source-expression! val (alpha-rename val))
+                  (begin
+                    (record-residual-lexical-reference! gensym)
+                    exp)))
+             (else
+              ;; A pure expression, processed for value.  Don't
+              ;; inline lambdas, because they will probably won't
+              ;; fold because we don't know the operator.
+              (if (and (small-expression? val value-size-limit)
+                       (not (tree-il-any lambda? val)))
+                  (record-source-expression! val (alpha-rename val))
+                  (begin
+                    (record-residual-lexical-reference! gensym)
+                    exp))))))))
+      (($ <lexical-set> src name gensym exp)
+       (if (zero? (lexical-refcount gensym))
+           (let ((exp (for-effect exp)))
+             (if (void? exp)
+                 exp
+                 (make-seq src exp (make-void #f))))
+           (begin
+             (record-residual-lexical-reference! gensym)
+             (make-lexical-set src name gensym (for-value exp)))))
+      (($ <let> src names gensyms vals body)
+       (let* ((vals (map for-operand vals))
+              (body (loop body
+                      (fold vhash-consq env gensyms vals)
+                      counter
+                      ctx)))
+         (cond
+          ((const? body)
+           (for-tail (list->seq src (append vals (list body)))))
+          ((and (lexical-ref? body)
+                (memq (lexical-ref-gensym body) gensyms))
+           (let ((sym (lexical-ref-gensym body))
+                 (pairs (map cons gensyms vals)))
+             ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
+             (for-tail
+              (list->seq
+               src
+               (append (map cdr (alist-delete sym pairs eq?))
+                       (list (assq-ref pairs sym)))))))
+          (else
+           ;; Only include bindings for which lexical references
+           ;; have been residualized.
+           (prune-bindings names gensyms vals body for-effect
+                           (lambda (names gensyms vals body)
+                             (if (null? names) (error "what!" names))
+                             (make-let src names gensyms vals body)))))))
+      (($ <letrec> src in-order? names gensyms vals body)
+       ;; Things could be done more precisely when IN-ORDER? but
+       ;; it's OK not to do it---at worst we lost an optimization
+       ;; opportunity.
+       (let* ((vals (map for-operand vals))
+              (body (loop body
+                      (fold vhash-consq env gensyms vals)
+                      counter
+                      ctx)))
+         (if (and (const? body)
+                  (every constant-expression? vals))
+             body
+             (prune-bindings names gensyms vals body for-effect
+                             (lambda (names gensyms vals body)
+                               (make-letrec src in-order?
+                                            names gensyms vals body))))))
+      (($ <fix> src names gensyms vals body)
+       (let* ((vals (map for-operand vals))
+              (body (loop body
+                      (fold vhash-consq env gensyms vals)
+                      counter
+                      ctx)))
+         (if (const? body)
+             body
+             (prune-bindings names gensyms vals body for-effect
+                             (lambda (names gensyms vals body)
+                               (make-fix src names gensyms vals body))))))
+      (($ <let-values> lv-src producer consumer)
+       ;; Peval the producer, then try to inline the consumer into
+       ;; the producer.  If that succeeds, peval again.  Otherwise
+       ;; reconstruct the let-values, pevaling the consumer.
+       (let ((producer (for-value producer)))
+         (or (match consumer
+               (($ <lambda-case> src req #f #f #f () gensyms body #f)
+                (cond
+                 ((inline-values producer src req gensyms body)
+                  => for-tail)
+                 (else #f)))
+               (_ #f))
+             (make-let-values lv-src producer (for-tail consumer)))))
+      (($ <dynwind> src winder body unwinder)
+       (make-dynwind src (for-value winder) (for-tail body)
+                     (for-value unwinder)))
+      (($ <dynlet> src fluids vals body)
+       (make-dynlet src (map for-value fluids) (map for-value vals)
+                    (for-tail body)))
+      (($ <dynref> src fluid)
+       (make-dynref src (for-value fluid)))
+      (($ <dynset> src fluid exp)
+       (make-dynset src (for-value fluid) (for-value exp)))
+      (($ <toplevel-ref> src (? effect-free-primitive? name))
+       (if (local-toplevel? name)
+           exp
+           (resolve-primitives! exp cenv)))
+      (($ <toplevel-ref>)
+       ;; todo: open private local bindings.
+       exp)
+      (($ <module-ref>)
+       exp)
+      (($ <module-set> src mod name public? exp)
+       (make-module-set src mod name public? (for-value exp)))
+      (($ <toplevel-define> src name exp)
+       (make-toplevel-define src name (for-value exp)))
+      (($ <toplevel-set> src name exp)
+       (make-toplevel-set src name (for-value exp)))
+      (($ <primitive-ref>)
+       (case ctx
+         ((effect) (make-void #f))
+         ((test) (make-const #f #t))
+         (else exp)))
+      (($ <conditional> src condition subsequent alternate)
+       (let ((condition (for-test condition)))
+         (if (const? condition)
+             (if (const-exp condition)
+                 (for-tail subsequent)
+                 (for-tail alternate))
+             (make-conditional src condition
+                               (for-tail subsequent)
+                               (for-tail alternate)))))
+      (($ <primcall> src '@call-with-values
+          (producer
+           ($ <lambda> _ _
+              (and consumer
+                   ;; No optional or kwargs.
+                   ($ <lambda-case>
+                      _ req #f rest #f () gensyms body #f)))))
+       (for-tail (make-let-values src (make-call src producer '())
+                                  consumer)))
+
+      (($ <primcall> src (? constructor-primitive? name) args)
+       (case ctx
+         ((effect test)
+          (let ((res (if (eq? ctx 'effect)
+                         (make-void #f)
+                         (make-const #f #t))))
+            (match (cons name (map for-value args))
+              (('cons x xs)
+               (for-tail (make-seq src (make-seq src x xs) res)))
+              (((or 'list 'vector) . elts)
+               (for-tail (list->seq src (append elts (list res)))))
+              (('make-prompt-tag . (or () (($ <const> _ (? string?)))))
+               res)
+              ((name . args)
+               (make-primcall src name args)))))
+         (else
+          (match (cons name (map for-value args))
+            (('cons x ($ <const> _ ()))
+             (make-primcall src 'list (list x)))
+            (('cons x ($ <primcall> _ 'list elts))
+             (make-primcall src 'list (cons x elts)))
+            ;; FIXME: these for-tail recursions could take
+            ;; place outside an effort counter.
+            (('car ($ <primcall> _ 'cons (x xs)))
+             (for-tail (make-seq src xs x)))
+            (('cdr ($ <primcall> _ 'cons (x xs)))
+             (for-tail (make-seq src x xs)))
+            (('car ($ <primcall> _ 'list (head . rest)))
+             (for-tail (list->seq src (append rest (list head)))))
+            (('cdr ($ <primcall> _ 'list (head . rest)))
+             (for-tail (make-seq src head
+                                 (make-primcall src 'list rest))))
+            (('car ($ <const> _ (head . tail)))
+             (for-tail (make-const src head)))
+            (('cdr ($ <const> _ (head . tail)))
+             (for-tail (make-const src tail)))
+            ((name . args)
+             (make-primcall src name args))))))
+
+      (($ <primcall> src (? effect-free-primitive? name) args)
+       (let ((args (map for-value args)))
+         (if (every const? args)        ; only simple constants
+             (let-values (((success? values)
+                           (apply-primitive name
+                                            (map const-exp args))))
+               (if success?
+                   (case ctx
+                     ((effect) (make-void #f))
+                     ((test)
+                      ;; Values truncation: only take the first
+                      ;; value.
+                      (if (pair? values)
+                          (make-const #f (car values))
+                          (make-values src '())))
+                     (else
+                      (make-values src (map (cut make-const src <>)
+                                            values))))
+                   (make-primcall src name args)))
+             (cond
+              ((and (eq? ctx 'effect) (types-check? name args))
+               (make-void #f))
+              (else
+               (make-primcall src name args))))))
+
+      (($ <primcall> src name args)
+       (make-primcall src name (map for-value args)))
+
+      (($ <call> src orig-proc orig-args)
+       ;; todo: augment the global env with specialized functions
+       (let ((proc (loop orig-proc env counter 'operator)))
+         (match proc
+           (($ <primitive-ref> _ name)
+            (for-tail (make-primcall src name orig-args)))
+
+           (($ <lambda> _ _
+               ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
+            ;; Simple case: no rest, no keyword arguments.
+            ;; todo: handle the more complex cases
+            (let* ((nargs (length orig-args))
+                   (nreq (length req))
+                   (nopt (if opt (length opt) 0))
+                   (key (source-expression proc)))
+              (cond
+               ((or (< nargs nreq) (> nargs (+ nreq nopt)))
+                ;; An error, or effecting arguments.
+                (make-call src (for-value orig-proc) (map for-value orig-args)))
+               ((or (and=> (find-counter key counter) counter-recursive?)
+                    (lambda? orig-proc))
+                ;; A recursive call, or a lambda in the operator
+                ;; position of the source expression.  Process again in
+                ;; tail context.
+                (loop (make-let src (append req (or opt '()))
+                                gensyms
+                                (append orig-args
+                                        (drop inits (- nargs nreq)))
+                                body)
+                  env counter ctx))
+               (else
+                ;; An integration at the top-level, the first
+                ;; recursion of a recursive procedure, or a nested
+                ;; integration of a procedure that hasn't been seen
+                ;; yet.
+                (let/ec k
+                  (define (abort)
+                    (k (make-call src
+                                  (for-value orig-proc)
+                                  (map for-value orig-args))))
+                  (define new-counter
+                    (cond
+                     ;; These first two cases will transfer effort
+                     ;; from the current counter into the new
+                     ;; counter.
+                     ((find-counter key counter)
+                      => (lambda (prev)
+                           (make-recursive-counter recursive-effort-limit
+                                                   operand-size-limit
+                                                   prev counter)))
+                     (counter
+                      (make-nested-counter abort key counter))
+                     ;; This case opens a new account, effectively
+                     ;; printing money.  It should only do so once
+                     ;; for each call site in the source program.
+                     (else
+                      (make-top-counter effort-limit operand-size-limit
+                                        abort key))))
+                  (define result
+                    (loop (make-let src (append req (or opt '()))
+                                    gensyms
+                                    (append orig-args
+                                            (drop inits (- nargs nreq)))
+                                    body)
+                      env new-counter ctx))
+                      
+                  (if counter
+                      ;; The nested inlining attempt succeeded.
+                      ;; Deposit the unspent effort and size back
+                      ;; into the current counter.
+                      (transfer! new-counter counter))
+
+                  result)))))
+           (_
+            (make-call src proc (map for-value orig-args))))))
+      (($ <lambda> src meta body)
+       (case ctx
+         ((effect) (make-void #f))
+         ((test) (make-const #f #t))
+         ((operator) exp)
+         (else
+          (make-lambda src meta (for-value body)))))
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       (make-lambda-case src req opt rest kw
+                         (map for-value inits)
+                         gensyms
+                         (for-tail body)
+                         (and alt (for-tail alt))))
+      (($ <seq> src head tail)
+       (let ((head (for-effect head))
+             (tail (for-tail tail)))
+         (if (void? head)
+             tail
+             (make-seq src
+                       (if (and (seq? head)
+                                (void? (seq-tail head)))
+                           (seq-head head)
+                           head)
+                       tail))))
+      (($ <prompt> src tag body handler)
+       (define (singly-used-definition x)
+         (cond
+          ((and (lexical-ref? x)
+                ;; Only fetch definitions with single uses.
+                (= (lexical-refcount (lexical-ref-gensym x)) 1)
+                (lookup (lexical-ref-gensym x)))
+           => singly-used-definition)
+          (else x)))
+       (match (singly-used-definition tag)
+         (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
+          ;; There is no way that an <abort> could know the tag
+          ;; for this <prompt>, so we can elide the <prompt>
+          ;; entirely.
+          (for-tail body))
+         (_
+          (make-prompt src (for-value tag) (for-tail body)
+                       (for-value handler)))))
+      (($ <abort> src tag args tail)
+       (make-abort src (for-value tag) (map for-value args)
+                   (for-value tail))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 74c465ff5..ae35306bf 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -27,7 +27,8 @@
   #:use-module (srfi srfi-16)
   #:export (resolve-primitives! add-interesting-primitive!
             expand-primitives!
-            effect-free-primitive? effect+exception-free-primitive?))
+            effect-free-primitive? effect+exception-free-primitive?
+            constructor-primitive? singly-valued-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -106,21 +107,23 @@
 
 (for-each add-interesting-primitive! *interesting-primitive-names*)
 
+(define *primitive-constructors*
+  ;; Primitives that return a fresh object.
+  '(acons cons cons* list vector make-struct make-struct/no-tail
+          car cdr vector-ref struct-ref make-prompt-tag))
+
 (define *effect-free-primitives*
-  '(values
+  `(values
     eq? eqv? equal?
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo
     not
-    pair? null? list? symbol? vector? acons cons cons*
-    list vector
-    car cdr
+    pair? null? list? symbol? vector?
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr
     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
-    vector-ref
-    struct? struct-vtable make-struct make-struct/no-tail struct-ref
+    struct? struct-vtable
     bytevector-u8-ref bytevector-s8-ref
     bytevector-u16-ref bytevector-u16-native-ref
     bytevector-s16-ref bytevector-s16-native-ref
@@ -129,7 +132,8 @@
     bytevector-u64-ref bytevector-u64-native-ref
     bytevector-s64-ref bytevector-s64-native-ref
     bytevector-ieee-single-ref bytevector-ieee-single-native-ref
-    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+    bytevector-ieee-double-ref bytevector-ieee-double-native-ref
+    ,@*primitive-constructors*))
 
 ;; Like *effect-free-primitives* above, but further restricted in that they
 ;; cannot raise exceptions.
@@ -141,8 +145,55 @@
     list vector
     struct?))
 
+;; Primitives that only return one value.
+(define *singly-valued-primitives* 
+  '(eq? eqv? equal?
+    memq memv
+    = < > <= >= zero?
+    + * - / 1- 1+ quotient remainder modulo
+    ash logand logior logxor
+    not
+    pair? null? list? symbol? vector? acons cons cons*
+    list vector
+    car cdr
+    set-car! set-cdr!
+    caar cadr cdar cddr
+    caaar caadr cadar caddr cdaar cdadr cddar cdddr
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+    vector-ref vector-set!
+    variable-ref variable-set!
+    variable-bound?
+    fluid-ref fluid-set!
+    make-prompt-tag
+    struct? struct-vtable make-struct struct-ref struct-set!
+    bytevector-u8-ref bytevector-u8-set!
+    bytevector-s8-ref bytevector-s8-set!
+    u8vector-ref u8vector-set! s8vector-ref s8vector-set!
+    bytevector-u16-ref bytevector-u16-set!
+    bytevector-u16-native-ref bytevector-u16-native-set!
+    bytevector-s16-ref bytevector-s16-set!
+    bytevector-s16-native-ref bytevector-s16-native-set!
+    u16vector-ref u16vector-set! s16vector-ref s16vector-set!
+    bytevector-u32-ref bytevector-u32-set!
+    bytevector-u32-native-ref bytevector-u32-native-set!
+    bytevector-s32-ref bytevector-s32-set!
+    bytevector-s32-native-ref bytevector-s32-native-set!
+    u32vector-ref u32vector-set! s32vector-ref s32vector-set!
+    bytevector-u64-ref bytevector-u64-set!
+    bytevector-u64-native-ref bytevector-u64-native-set!
+    bytevector-s64-ref bytevector-s64-set!
+    bytevector-s64-native-ref bytevector-s64-native-set!
+    u64vector-ref u64vector-set! s64vector-ref s64vector-set!
+    bytevector-ieee-single-ref bytevector-ieee-single-set!
+    bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+    bytevector-ieee-double-ref bytevector-ieee-double-set!
+    bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+    f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+
 (define *effect-free-primitive-table* (make-hash-table))
 (define *effect+exceptions-free-primitive-table* (make-hash-table))
+(define *singly-valued-primitive-table* (make-hash-table))
 
 (for-each (lambda (x)
             (hashq-set! *effect-free-primitive-table* x #t))
@@ -150,11 +201,18 @@
 (for-each (lambda (x) 
             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
           *effect+exception-free-primitives*)
+(for-each (lambda (x) 
+            (hashq-set! *singly-valued-primitive-table* x #t))
+          *singly-valued-primitives*)
 
+(define (constructor-primitive? prim)
+  (memq prim *primitive-constructors*))
 (define (effect-free-primitive? prim)
   (hashq-ref *effect-free-primitive-table* prim))
 (define (effect+exception-free-primitive? prim)
   (hashq-ref *effect+exceptions-free-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+  (hashq-ref *singly-valued-primitive-table* prim))
 
 (define (resolve-primitives! x mod)
   (post-order!
@@ -247,6 +305,8 @@
 (define-primitive-expander zero? (x)
   (= x 0))
 
+;; FIXME: All the code that uses `const?' is redundant with `peval'.
+
 (define-primitive-expander +
   () 0
   (x) (values x)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index a49af0604..cd811b3bb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -347,21 +347,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}
@@ -428,13 +425,15 @@
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (cons eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (define (not-extended-by! gfs eg)
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (delq! eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (define* (ensure-generic old-definition #:optional name)
   (cond ((is-a? old-definition <generic>) old-definition)
@@ -449,13 +448,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))))
@@ -505,6 +502,7 @@
 		(slot-set! method 'generic-function gws))
 	      methods)
     (slot-set! gws 'methods methods)
+    (invalidate-method-cache! gws)
     gws))
 
 ;;;
@@ -669,15 +667,25 @@
 		methods)
 	      (loop (cdr l)))))))
 
+(define (method-n-specializers m)
+  (length* (slot-ref m 'specializers)))
+
+(define (calculate-n-specialized gf)
+  (fold (lambda (m n) (max n (method-n-specializers m)))
+        0
+        (generic-function-methods gf)))
+
+(define (invalidate-method-cache! gf)
+  (%invalidate-method-cache! gf)
+  (slot-set! gf 'n-specialized (calculate-n-specialized gf))
+  (for-each (lambda (gf) (invalidate-method-cache! gf))
+            (slot-ref gf 'extended-by)))
+
 (define internal-add-method!
   (method ((gf <generic>) (m <method>))
     (slot-set! m  'generic-function gf)
     (slot-set! gf 'methods (compute-new-list-of-methods gf m))
-    (let ((specializers (slot-ref m 'specializers)))
-      (slot-set! gf 'n-specialized
-                 (max (length* specializers)
-                      (slot-ref gf 'n-specialized))))
-    (%invalidate-method-cache! gf)
+    (invalidate-method-cache! gf)
     (add-method-in-classes! m)
     *unspecified*))
 
@@ -917,6 +925,7 @@
 	 (slot-set! val2
 		    'extended-by
 		    (cons gf (delq! gf (slot-ref val2 'extended-by))))
+         (invalidate-method-cache! gf)
 	 var)))
 
 (module-define! duplicate-handlers 'merge-generics merge-generics)
@@ -1100,7 +1109,7 @@
 		    ;; remove the method from its GF
 		    (slot-set! gf 'methods
 			       (delq1! m (slot-ref gf 'methods)))
-		    (%invalidate-method-cache! gf)
+		    (invalidate-method-cache! gf)
 		    ;; remove the method from its specializers
 		    (remove-method-in-classes! m))))
 	    (class-direct-methods c)))
diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm
index 8f4d839c1..fba4d4192 100644
--- 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)))
diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm
index 8a7ae1636..45272fa19 100644
--- 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))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 765bd50e9..d2347b0d1 100644
--- 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
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 7f1ff7fc9..d2b9c9420 100644
--- 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.
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
index 61e67b820..dba86fdbb 100644
--- 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)
diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm
index 1b912befc..29b0393ff 100644
--- 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)))
diff --git a/module/srfi/srfi-67/compare.scm b/module/srfi/srfi-67/compare.scm
index 21b0e94c4..767f3dba0 100644
--- 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)
diff --git a/module/sxml/match.scm b/module/sxml/match.scm
index 9aebc019b..84cbce344 100644
--- 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))
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index c6c64cc73..2a585aaff 100644
--- 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)))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 5bab7780e..1cffa7187 100644
--- 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)
diff --git a/module/system/vm/inspect.scm b/module/system/vm/inspect.scm
index aebf50d30..1023437bf 100644
--- 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)
diff --git a/module/texinfo.scm b/module/texinfo.scm
index 970895ff6..8798eb3c1 100644
--- 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
 
diff --git a/module/web/http.scm b/module/web/http.scm
index 21874ee16..70db81335 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -702,15 +702,25 @@ ordered alist."
 ;; 0         1         2
 (define (parse-rfc-822-date str)
   ;; We could verify the day of the week but we don't.
-  (if (not (string-match? str "aaa, dd aaa dddd dd:dd:dd GMT"))
-      (bad-header 'date str))
-  (let ((date (parse-non-negative-integer str 5 7))
-        (month (parse-month str 8 11))
-        (year (parse-non-negative-integer str 12 16))
-        (hour (parse-non-negative-integer str 17 19))
-        (minute (parse-non-negative-integer str 20 22))
-        (second (parse-non-negative-integer str 23 25)))
-    (make-date 0 second minute hour date month year 0)))
+  (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
+         (let ((date (parse-non-negative-integer str 5 7))
+               (month (parse-month str 8 11))
+               (year (parse-non-negative-integer str 12 16))
+               (hour (parse-non-negative-integer str 17 19))
+               (minute (parse-non-negative-integer str 20 22))
+               (second (parse-non-negative-integer str 23 25)))
+           (make-date 0 second minute hour date month year 0)))
+        ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
+         (let ((date (parse-non-negative-integer str 5 6))
+               (month (parse-month str 7 10))
+               (year (parse-non-negative-integer str 11 15))
+               (hour (parse-non-negative-integer str 16 18))
+               (minute (parse-non-negative-integer str 19 21))
+               (second (parse-non-negative-integer str 22 24)))
+           (make-date 0 second minute hour date month year 0)))
+        (else
+         (bad-header 'date str)         ; prevent tail call
+         #f)))
 
 ;; RFC 850, updated by RFC 1036
 ;; Sunday, 06-Nov-94 08:49:37 GMT
diff --git a/module/web/server.scm b/module/web/server.scm
index c5e623a19..ef6879ec3 100644
--- 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
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 8ee570b32..05aee7837 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -67,6 +67,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/list.test			\
 	    tests/load.test			\
 	    tests/match.test			\
+	    tests/match.test.upstream		\
 	    tests/modules.test			\
 	    tests/multilingual.nottest		\
 	    tests/net-db.test			\
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index 00655bd12..76c47c4b9 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -178,6 +178,13 @@ test_scm_take_u8vector_LDADD = $(LIBGUILE_LDADD)
 check_PROGRAMS += test-scm-take-u8vector
 TESTS += test-scm-take-u8vector
 
+# test-scm-take-u8vector
+test_scm_to_latin1_string_SOURCES = test-scm-to-latin1-string.c
+test_scm_to_latin1_string_CFLAGS = ${test_cflags}
+test_scm_to_latin1_string_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-scm-to-latin1-string
+TESTS += test-scm-to-latin1-string
+
 if HAVE_SHARED_LIBRARIES
 
 # test-extensions
diff --git a/test-suite/standalone/test-scm-to-latin1-string.c b/test-suite/standalone/test-scm-to-latin1-string.c
new file mode 100644
index 000000000..b8f012072
--- /dev/null
+++ b/test-suite/standalone/test-scm-to-latin1-string.c
@@ -0,0 +1,78 @@
+/* Copyright (C) 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 the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+#include <stdlib.h>
+
+/*
+  This outputs:
+
+  dhansen@localhorst ~/tmp $ ./a.out
+  foo,bar
+  bar
+
+*/
+
+#define TEST(x) \
+  if (!(x)) abort()
+
+static void
+inner_main (void *data, int argc, char **argv)
+{
+  char *cstr;
+
+  SCM string, tokens, tok;
+
+  string = scm_from_latin1_string ("foo,bar");
+  tokens = scm_string_split (string, SCM_MAKE_CHAR (','));
+
+  TEST (scm_is_pair (tokens));
+  tok = scm_car (tokens);
+  TEST (scm_is_string (tok));
+  cstr = scm_to_latin1_string (tok);
+  TEST (strcmp (cstr, "foo") == 0);
+  free (cstr);
+  tokens = scm_cdr (tokens);
+  
+  TEST (scm_is_pair (tokens));
+  tok = scm_car (tokens);
+  TEST (scm_is_string (tok));
+  cstr = scm_to_latin1_string (tok);
+  TEST (strcmp (cstr, "bar") == 0);
+  free (cstr);
+  tokens = scm_cdr (tokens);
+  
+  TEST (scm_is_null (tokens));
+}
+
+int
+main (int argc, char **argv)
+{
+  scm_boot_guile (argc, argv, inner_main, NULL);
+
+  return EXIT_SUCCESS;
+}
+
+/* Local Variables: */
+/* compile-command: "gcc `pkg-config --cflags --libs guile-2.0` main.c" */
+/* End: */
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 9aa12be34..57643e825 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -1,5 +1,6 @@
 ;;;; gc.test --- test guile's garbage collection    -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
+;;;;   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
@@ -46,6 +47,13 @@
 ;;; 
 ;;;
 
+(define (stack-cleanup depth)
+  ;; Clean up stack space for DEPTH words.  This is defined here so that
+  ;; `peval' doesn't inline it.
+  (let cleanup ((i depth))
+    (and (> i 0)
+         (begin (cleanup (1- i)) i))))
+
 (with-test-prefix "gc"
 
   (pass-if "after-gc-hook gets called"
@@ -65,9 +73,7 @@
       (for-each (lambda (x) (guard (make-module))) (iota total))
 
       ;; Avoid false references to the modules on the stack.
-      (let cleanup ((i 20))
-        (and (> i 0)
-             (begin (cleanup (1- i)) i)))
+      (stack-cleanup 20)
 
       (gc)
       (gc) ;; twice: have to kill the weak vectors.
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index f2e670c08..8b19ff702 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
 ;;;; match.test --- (ice-9 match)  -*- 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
@@ -18,11 +18,25 @@
 
 (define-module (test-match)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
   #:use-module (test-suite lib))
 
 (define exception:match-error
   (cons 'match-error "^.*$"))
 
+(define-record-type rtd-2-slots
+  (make-2-slot-record a b)
+  two-slot-record?
+  (a slot-first)
+  (b slot-second))
+
+(define-record-type rtd-3-slots
+  (make-3-slot-record a b c)
+  three-slot-record?
+  (a slot-one)
+  (b slot-two)
+  (c slot-three))
+
 
 (with-test-prefix "matches"
 
@@ -86,7 +100,61 @@
     (let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
       (match tree
         (('one ('two x) ('three y ('and z '(and 5))))
-         (equal? (list x y z) '(2 3 4)))))))
+         (equal? (list x y z) '(2 3 4))))))
+
+  (pass-if "and, unique names"
+    (let ((tree '(1 2)))
+      (match tree
+        ((and (a 2) (1 b))
+         (equal? 3 (+ a b))))))
+  
+  (pass-if "and, same names"
+    (let ((a '(1 2)))
+      (match a
+        ((and (a 2) (1 b))
+         (equal? 3 (+ a b))))))
+  
+  (with-test-prefix "records"
+
+    (pass-if "all slots, bind"
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots a b c)
+           (equal? (list a b c) '(1 2 3))))))
+
+    (pass-if "all slots, literals"
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots 1 2 3)
+           #t))))
+
+    (pass-if "2 slots"
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots x y)
+           (equal? (list x y) '(1 2))))))
+
+    (pass-if "RTD correctly checked"
+      (let ((r (make-2-slot-record 1 2)))
+        (match r
+          (($ rtd-3-slots a b)
+           #f)
+          (($ rtd-2-slots a b)
+           (equal? (list a b) '(1 2))))))
+
+    (pass-if "getter"
+      (match (make-2-slot-record 1 2)
+        (($ rtd-2-slots (get! first) (get! second))
+         (equal? (list (first) (second)) '(1 2)))))
+
+    (pass-if "setter"
+      (let ((r (make-2-slot-record 1 2)))
+        (match r
+          (($ rtd-2-slots (set! set-first!) (set! set-second!))
+           (set-first! 'one)
+           (set-second! 'two)
+           (equal? (list (slot-first r) (slot-second r))
+                   '(one two))))))))
 
 
 (with-test-prefix "doesn't match"
@@ -105,4 +173,36 @@
     exception:match-error
     (match '(a 0)
       (((and x (? symbol?)) ..1)
-       (equal? x '(a b c))))))
+       (equal? x '(a b c)))))
+
+  (with-test-prefix "records"
+
+    (pass-if "not a record"
+      (match "hello"
+        (($ rtd-2-slots) #f)
+        (_               #t)))
+
+    (pass-if-exception "too many slots"
+      exception:out-of-range
+      (let ((r (make-3-slot-record 1 2 3)))
+        (match r
+          (($ rtd-3-slots a b c d)
+           #f))))))
+
+
+;;;
+;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
+;;;
+
+(let-syntax ((load       (syntax-rules ()
+                           ((_ file) #t)))
+             (test       (syntax-rules ()
+                           ((_ name expected expr)
+                            (pass-if name
+                                     (equal? expected expr)))))
+             (test-begin (syntax-rules ()
+                           ((_ name) #t)))
+             (test-end   (syntax-rules ()
+                           ((_) #t))))
+  (with-test-prefix "upstream tests"
+    (include-from-path "test-suite/tests/match.test.upstream")))
diff --git a/test-suite/tests/match.test.upstream b/test-suite/tests/match.test.upstream
new file mode 100644
index 000000000..47bf44e72
--- /dev/null
+++ b/test-suite/tests/match.test.upstream
@@ -0,0 +1,168 @@
+
+(cond-expand
+ (modules (import (chibi match) (only (chibi test) test-begin test test-end)))
+ (else (load "lib/chibi/match/match.scm")))
+
+(test-begin "match")
+
+(test "any" 'ok (match 'any (_ 'ok)))
+(test "symbol" 'ok (match 'ok (x x)))
+(test "number" 'ok (match 28 (28 'ok)))
+(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
+(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
+(test "null" 'ok (match '() (() 'ok)))
+(test "pair" 'ok (match '(ok) ((x) x)))
+(test "vector" 'ok (match '#(ok) (#(x) x)))
+(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
+(test "and empty" 'ok (match '(o k) ((and) 'ok)))
+(test "and single" 'ok (match 'ok ((and x) x)))
+(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
+(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
+(test "or single" 'ok (match 'ok ((or x) 'ok)))
+(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
+(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
+(test "pred" 'ok (match 28 ((? number?) 'ok)))
+(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
+
+(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
+(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
+(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
+
+(test "ellipses" '((a b c) (1 2 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ___) (list x y))))
+
+(test "real ellipses" '((a b c) (1 2 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ...) (list x y))))
+
+(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
+  (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
+    (#(a b c (hd . tl) ...) (list a b c hd tl))))
+
+(test "pred ellipses" '(1 2 3)
+  (match '(1 2 3)
+    (((? odd? n) ___) n)
+    (((? number? n) ___) n)))
+
+(test "failure continuation" 'ok
+  (match '(1 2)
+    ((a . b) (=> next) (if (even? a) 'fail (next)))
+    ((a . b) 'ok)))
+
+(test "let" '(o k)
+  (match-let ((x 'ok) (y '(o k))) y))
+
+(test "let*" '(f o o f)
+  (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
+
+(test "getter car" '(1 2)
+  (match '(1 . 2) (((get! a) . b) (list (a) b))))
+
+(test "getter cdr" '(1 2)
+  (match '(1 . 2) ((a . (get! b)) (list a (b)))))
+
+(test "getter vector" '(1 2 3)
+  (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
+
+(test "setter car" '(3 . 2)
+  (let ((x (cons 1 2)))
+    (match x (((set! a) . b) (a 3)))
+    x))
+
+(test "setter cdr" '(1 . 3)
+  (let ((x (cons 1 2)))
+    (match x ((a . (set! b)) (b 3)))
+    x))
+
+(test "setter vector" '#(1 0 3)
+  (let ((x (vector 1 2 3)))
+    (match x (#(a (set! b) c) (b 0)))
+    x))
+
+(test "single tail" '((a b) (1 2) (c . 3))
+  (match '((a . 1) (b . 2) (c . 3))
+    (((x . y) ... last) (list x y last))))
+
+(test "single tail 2" '((a b) (1 2) 3)
+  (match '((a . 1) (b . 2) 3)
+    (((x . y) ... last) (list x y last))))
+
+(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
+  (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
+    (((x . y) ... u v w) (list x y u v w))))
+
+(test "tail against improper list" #f
+  (match '(a b c d e f . g)
+    ((x ... y u v w) (list x y u v w))
+    (else #f)))
+
+(test "Riastradh quasiquote" '(2 3)
+  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
+
+(test "trivial tree search" '(1 2 3)
+  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
+
+(test "simple tree search" '(1 2 3)
+  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
+
+(test "deep tree search" '(1 2 3)
+  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
+
+(test "non-tail tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
+
+(test "restricted tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
+
+(test "fail restricted tree search" #f
+  (match '(x (y (x a b c (1 2 3) d e f)))
+    (('x *** (a b c)) (list a b c))
+    (else #f)))
+
+(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "failed sxml tree search" #f
+  (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "collect tree search"
+    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
+     (list tag attrs text))
+    (else #f)))
+
+(test "anded tail pattern" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "anded search pattern" '(a b c)
+      (match '(a (b (c d))) ((and (p *** 'd) x) p)))
+
+(test "joined tail" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "list ..1" '(a b c)
+    (match '(a b c) ((x ..1) x)))
+
+(test "list ..1 failed" #f
+    (match '()
+      ((x ..1) x)
+      (else #f)))
+
+(test "list ..1 with predicate" '(a b c)
+    (match '(a b c)
+      (((and x (? symbol?)) ..1) x)))
+
+(test "list ..1 with failed predicate" #f
+    (match '(a b 3)
+      (((and x (? symbol?)) ..1) x)
+      (else #f)))
+
+(test-end)
diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test
index 66af55f6b..7ce39badb 100644
--- a/test-suite/tests/statprof.test
+++ b/test-suite/tests/statprof.test
@@ -40,8 +40,11 @@
 
     ;; make sure these are compiled so we're not swamped in `eval'
     (define (make-func)
+      ;; Disable partial evaluation so that `(+ i i)' doesn't get
+      ;; stripped.
       (compile '(lambda (n)
-                  (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))))
+                  (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))
+               #:opts '(#:partial-eval? #f)))
     (define run-test
       (compile '(lambda (num-calls funcs)
                   (let loop ((x num-calls) (funcs funcs))
@@ -50,11 +53,11 @@
                       ((car funcs) x)
                       (loop (- x 1) (cdr funcs))))))))
     
-    (let ((num-calls 40000)
+    (let ((num-calls 80000)
           (funcs (circular-list (make-func) (make-func) (make-func))))
 
-      ;; Run test. 10000 us == 100 Hz.
-      (statprof-reset 0 10000 #f #f)
+      ;; Run test. 20000 us == 200 Hz.
+      (statprof-reset 0 20000 #f #f)
       (statprof-start)
       (run-test num-calls funcs)
       (statprof-stop)
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index db002f245..85a7c38ef 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -36,6 +36,13 @@
     (equal? '(a b c) '(a b c))
     a))
 
+(define (stack-cleanup depth)
+  ;; Clean up stack space for DEPTH words.  This is defined here so that
+  ;; `peval' doesn't inline it.
+  (let cleanup ((i depth))
+    (and (> i 0)
+         (begin (cleanup (1- i)) i))))
+
 (if (provided? 'threads)
     (begin
 
@@ -403,9 +410,7 @@
             (g (let ((m (make-mutex))) (lock-mutex m) m))
 
             ;; Avoid false references to M on the stack.
-            (let cleanup ((i 20))
-              (and (> i 0)
-                   (begin (cleanup (1- i)) i)))
+            (stack-cleanup 20)
 
             (gc) (gc)
             (let ((m (g)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 0f445fdd2..9a7f05157 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -23,6 +23,7 @@
   #:use-module (system base pmatch)
   #:use-module (system base message)
   #:use-module (language tree-il)
+  #:use-module (language tree-il primitives)
   #:use-module (language glil)
   #:use-module (srfi srfi-13))
 
@@ -34,26 +35,28 @@
   (post-order! (lambda (x) (set! (tree-il-src x) #f))
                x))
 
-(define-syntax assert-scheme->glil
-  (syntax-rules ()
-    ((_ in out)
-     (let ((tree-il (strip-source
-                     (compile 'in #:from 'scheme #:to 'tree-il))))
-       (pass-if 'in
-                (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
-                        'out))))))
-
 (define-syntax assert-tree-il->glil
-  (syntax-rules ()
-    ((_ in pat test ...)
+  (syntax-rules (with-partial-evaluation without-partial-evaluation
+                 with-options)
+    ((_ with-partial-evaluation in pat test ...)
+     (assert-tree-il->glil with-options (#:partial-eval? #t)
+                           in pat test ...))
+    ((_ without-partial-evaluation in pat test ...)
+     (assert-tree-il->glil with-options (#:partial-eval? #f)
+                           in pat test ...))
+    ((_ with-options opts in pat test ...)
      (let ((exp 'in))
        (pass-if 'in
          (let ((glil (unparse-glil
                       (compile (strip-source (parse-tree-il exp))
-                               #:from 'tree-il #:to 'glil))))
+                               #:from 'tree-il #:to 'glil
+                               #:opts 'opts))))
            (pmatch glil
              (pat (guard test ...) #t)
-             (else #f))))))))
+             (else #f))))))
+    ((_ in pat test ...)
+     (assert-tree-il->glil with-partial-evaluation
+                           in pat test ...))))
 
 (define-syntax pass-if-tree-il->scheme
   (syntax-rules ()
@@ -66,6 +69,39 @@
          (pat (guard guard-exp) #t)
          (_ #f))))))
 
+(define peval
+  ;; The partial evaluator.
+  (@@ (language tree-il optimize) peval))
+
+(define-syntax pass-if-peval
+  (syntax-rules (resolve-primitives)
+    ((_ in pat)
+     (pass-if-peval in pat
+                    (compile 'in #:from 'scheme #:to 'tree-il)))
+    ((_ resolve-primitives in pat)
+     (pass-if-peval in pat
+                    (expand-primitives!
+                     (resolve-primitives!
+                      (compile 'in #:from 'scheme #:to 'tree-il)
+                      (current-module)))))
+    ((_ in pat code)
+     (pass-if 'in
+       (let ((evaled (unparse-tree-il (peval code))))
+         (pmatch evaled
+           (pat #t)
+           (_   (pk 'peval-mismatch)
+                ((@ (ice-9 pretty-print) pretty-print)
+                    'in)
+                (newline)
+                ((@ (ice-9 pretty-print) pretty-print)
+                    evaled)
+                (newline)
+                ((@ (ice-9 pretty-print) pretty-print)
+                    'pat)
+                (newline)
+                #f)))))))
+
+
 (with-test-prefix "tree-il->scheme"
   (pass-if-tree-il->scheme
    (case-lambda ((a) a) ((b c) (list b c)))
@@ -107,8 +143,8 @@
             (const 1) (call return 1)
             (label ,l2) (const 2) (call return 1))
    (eq? l1 l2))
-  
-  (assert-tree-il->glil
+
+  (assert-tree-il->glil without-partial-evaluation
    (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
             (label ,l3) (label ,l4) (const #f) (call return 1))
@@ -137,21 +173,21 @@
             (call return 1))))
 
 (with-test-prefix "lexical refs"
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1)) (lexical x y))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (call return 1)
             (unbind)))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (const #f) (call return 1)
             (unbind)))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
@@ -270,7 +306,7 @@
             (toplevel ref bar)
             (call return 1)))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (begin (toplevel bar) (const #f))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref bar) (call drop 1)
@@ -332,13 +368,14 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
+   ;; This gets simplified by `peval'.
    (primcall null? (const 2))
    (program () (std-prelude 0 0 #f) (label _)
-            (const 2) (call null? 1) (call return 1))))
+            (const #f) (call return 1))))
 
 (with-test-prefix "letrec"
   ;; simple bindings -> let
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec (x y) (x1 y1) ((const 10) (const 20))
            (call (toplevel foo) (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
@@ -351,7 +388,7 @@
             (unbind)))
 
   ;; complex bindings -> box and set! within let
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
            (primcall + (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 4 #f) (label _)
@@ -367,7 +404,7 @@
             (call add 2) (call return 1) (unbind)))
   
   ;; complex bindings in letrec* -> box and set! in order
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
             (primcall + (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
@@ -383,7 +420,7 @@
             (call add 2) (call return 1) (unbind)))
 
   ;; simple bindings in letrec* -> equivalent to letrec
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec* (x y) (xx yy) ((const 1) (const 2))
             (lexical y yy))
    (program () (std-prelude 0 1 #f) (label _)
@@ -487,9 +524,10 @@
             (const #t) (call return 1)))
 
   (assert-tree-il->glil
+   ;; This gets simplified by `peval'.
    (primcall null? (begin (const #f) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
-            (const 2) (call null? 1) (call return 1))))
+            (const #f) (call return 1))))
 
 (with-test-prefix "values"
   (assert-tree-il->glil
@@ -514,7 +552,7 @@
 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 ;; and could be tightened in any case
 (with-test-prefix "the or hack"
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1))
         (if (lexical x y)
             (lexical x y)
@@ -532,7 +570,7 @@
    (eq? l1 l2))
 
   ;; second bound var is unreferenced
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1))
         (if (lexical x y)
             (lexical x y)
@@ -586,6 +624,693 @@
             (toplevel ref bar) (call call/cc 1)
             (call tail-call 1))))
 
+
+(with-test-prefix "partial evaluation"
+
+  (pass-if-peval
+    ;; First order, primitive.
+    (let ((x 1) (y 2)) (+ x y))
+    (const 3))
+
+  (pass-if-peval
+    ;; First order, thunk.
+    (let ((x 1) (y 2))
+      (let ((f (lambda () (+ x y))))
+        (f)))
+    (const 3))
+
+  (pass-if-peval resolve-primitives
+    ;; First order, let-values (requires primitive expansion for
+    ;; `call-with-values'.)
+    (let ((x 0))
+      (call-with-values
+          (lambda () (if (zero? x) (values 1 2) (values 3 4)))
+        (lambda (a b)
+          (+ a b))))
+    (const 3))
+
+  (pass-if-peval
+    ;; First order, coalesced, mutability preserved.
+    (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+    (primcall list
+              (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+
+  (pass-if-peval
+   ;; First order, coalesced, mutability preserved.
+   (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+   ;; This must not be a constant.
+   (primcall list
+             (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+
+  (pass-if-peval
+    ;; First order, coalesced, immutability preserved.
+    (cons 0 (cons 1 (cons 2 '(3 4 5))))
+    (primcall cons (const 0)
+              (primcall cons (const 1)
+                        (primcall cons (const 2)
+                                  (const (3 4 5))))))
+
+  ;; These two tests doesn't work any more because we changed the way we
+  ;; deal with constants -- now the algorithm will see a construction as
+  ;; being bound to the lexical, so it won't propagate it.  It can't
+  ;; even propagate it in the case that it is only referenced once,
+  ;; because:
+  ;;
+  ;;   (let ((x (cons 1 2))) (lambda () x))
+  ;;
+  ;; is not the same as
+  ;;
+  ;;   (lambda () (cons 1 2))
+  ;;
+  ;; Perhaps if we determined that not only was it only referenced once,
+  ;; it was not closed over by a lambda, then we could propagate it, and
+  ;; re-enable these two tests.
+  ;;
+  #;
+  (pass-if-peval
+   ;; First order, mutability preserved.
+   (let loop ((i 3) (r '()))
+     (if (zero? i)
+         r
+         (loop (1- i) (cons (cons i i) r))))
+   (primcall list
+             (primcall cons (const 1) (const 1))
+             (primcall cons (const 2) (const 2))
+             (primcall cons (const 3) (const 3))))
+  ;;
+  ;; See above.
+  #;
+  (pass-if-peval
+   ;; First order, evaluated.
+   (let loop ((i 7)
+              (r '()))
+     (if (<= i 0)
+         (car r)
+         (loop (1- i) (cons i r))))
+   (const 1))
+
+  ;; Instead here are tests for what happens for the above cases: they
+  ;; unroll but they don't fold.
+  (pass-if-peval
+   (let loop ((i 3) (r '()))
+     (if (zero? i)
+         r
+         (loop (1- i) (cons (cons i i) r))))
+   (letrec (loop) (_) (_)
+           (let (r) (_)
+                ((primcall list
+                           (primcall cons (const 3) (const 3))))
+                (let (r) (_)
+                     ((primcall cons
+                                (primcall cons (const 2) (const 2))
+                                (lexical r _)))
+                     (primcall cons
+                               (primcall cons (const 1) (const 1))
+                               (lexical r _))))))
+
+  ;; See above.
+  (pass-if-peval
+   (let loop ((i 4)
+              (r '()))
+     (if (<= i 0)
+         (car r)
+         (loop (1- i) (cons i r))))
+   (letrec (loop) (_) (_)
+           (let (r) (_)
+                ((primcall list (const 4)))
+                (let (r) (_)
+                     ((primcall cons
+                                (const 3)
+                                (lexical r _)))
+                     (let (r) (_)
+                          ((primcall cons
+                                     (const 2)
+                                     (lexical r _)))
+                          (let (r) (_)
+                               ((primcall cons
+                                          (const 1)
+                                          (lexical r _)))
+                               (primcall car
+                                         (lexical r _))))))))
+
+   ;; Static sums.
+  (pass-if-peval
+   (let loop ((l '(1 2 3 4)) (sum 0))
+     (if (null? l)
+         sum
+         (loop (cdr l) (+ sum (car l)))))
+   (const 10))
+
+  (pass-if-peval
+   ;; Mutability preserved.
+   ((lambda (x y z) (list x y z)) 1 2 3)
+   (primcall list (const 1) (const 2) (const 3)))
+
+  (pass-if-peval
+   ;; Don't propagate effect-free expressions that operate on mutable
+   ;; objects.
+   (let* ((x (list 1))
+          (y (car x)))
+     (set-car! x 0)
+     y)
+   (let (x) (_) ((primcall list (const 1)))
+        (let (y) (_) ((primcall car (lexical x _)))
+             (seq
+               (call (toplevel set-car!) (lexical x _) (const 0))
+               (lexical y _)))))
+  
+  (pass-if-peval
+   ;; Don't propagate effect-free expressions that operate on objects we
+   ;; don't know about.
+   (let ((y (car x)))
+     (set-car! x 0)
+     y)
+   (let (y) (_) ((primcall car (toplevel x)))
+        (seq
+          (call (toplevel set-car!) (toplevel x) (const 0))
+          (lexical y _))))
+  
+  (pass-if-peval
+   ;; Infinite recursion
+   ((lambda (x) (x x)) (lambda (x) (x x)))
+   (let (x) (_)
+        ((lambda _
+           (lambda-case
+            (((x) _ _ _ _ _)
+             (call (lexical x _) (lexical x _))))))
+        (call (lexical x _) (lexical x _))))
+
+  (pass-if-peval
+    ;; First order, aliased primitive.
+    (let* ((x *) (y (x 1 2))) y)
+    (const 2))
+
+  (pass-if-peval
+    ;; First order, shadowed primitive.
+    (begin
+      (define (+ x y) (pk x y))
+      (+ 1 2))
+    (seq
+      (define +
+        (lambda (_)
+          (lambda-case
+           (((x y) #f #f #f () (_ _))
+            (call (toplevel pk) (lexical x _) (lexical y _))))))
+      (call (toplevel +) (const 1) (const 2))))
+
+  (pass-if-peval
+    ;; First-order, effects preserved.
+    (let ((x 2))
+      (do-something!)
+      x)
+    (seq
+      (call (toplevel do-something!))
+      (const 2)))
+
+  (pass-if-peval
+    ;; First order, residual bindings removed.
+    (let ((x 2) (y 3))
+      (* (+ x y) z))
+    (primcall * (const 5) (toplevel z)))
+
+  (pass-if-peval
+    ;; First order, with lambda.
+    (define (foo x)
+      (define (bar z) (* z z))
+      (+ x (bar 3)))
+    (define foo
+      (lambda (_)
+        (lambda-case
+         (((x) #f #f #f () (_))
+          (primcall + (lexical x _) (const 9)))))))
+
+  (pass-if-peval
+    ;; First order, with lambda inlined & specialized twice.
+    (let ((f (lambda (x y)
+               (+ (* x top) y)))
+          (x 2)
+          (y 3))
+      (+ (* x (f x y))
+         (f something x)))
+    (primcall +
+              (primcall *
+                        (const 2)
+                        (primcall +     ; (f 2 3)
+                                  (primcall *
+                                            (const 2)
+                                            (toplevel top))
+                                  (const 3)))
+              (let (x) (_) ((toplevel something)) ; (f something 2)
+                   ;; `something' is not const, so preserve order of
+                   ;; effects with a lexical binding.
+                   (primcall +
+                             (primcall *
+                                       (lexical x _)
+                                       (toplevel top))
+                             (const 2)))))
+  
+  (pass-if-peval
+   ;; First order, with lambda inlined & specialized 3 times.
+   (let ((f (lambda (x y) (if (> x 0) y x))))
+     (+ (f -1 0)
+        (f 1 0)
+        (f -1 y)
+        (f 2 y)
+        (f z y)))
+   (primcall +
+             (const -1)                               ; (f -1 0)
+             (const 0)                                ; (f 1 0)
+             (seq (toplevel y) (const -1))          ; (f -1 y)
+             (toplevel y)                             ; (f 2 y)
+             (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+                  (if (primcall > (lexical x _) (const 0))
+                      (lexical y _)
+                      (lexical x _)))))
+
+  (pass-if-peval
+    ;; First order, conditional.
+    (let ((y 2))
+      (lambda (x)
+        (if (> y 0)
+            (display x)
+            'never-reached)))
+    (lambda ()
+      (lambda-case
+       (((x) #f #f #f () (_))
+        (call (toplevel display) (lexical x _))))))
+
+  (pass-if-peval
+    ;; First order, recursive procedure.
+    (letrec ((fibo (lambda (n)
+                     (if (<= n 1)
+                         n
+                         (+ (fibo (- n 1))
+                            (fibo (- n 2)))))))
+      (fibo 4))
+    (const 3))
+
+  (pass-if-peval
+   ;; Don't propagate toplevel references, as intervening expressions
+   ;; could alter their bindings.
+   (let ((x top))
+     (foo)
+     x)
+   (let (x) (_) ((toplevel top))
+        (seq
+          (call (toplevel foo))
+          (lexical x _))))
+
+  (pass-if-peval
+    ;; Higher order.
+    ((lambda (f x)
+       (f (* (car x) (cadr x))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 7))
+
+  (pass-if-peval
+    ;; Higher order with optional argument (default value).
+    ((lambda* (f x #:optional (y 0))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 7))
+
+  (pass-if-peval
+    ;; Higher order with optional argument (caller-supplied value).
+    ((lambda* (f x #:optional (y 0))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     35)
+    (const 42))
+
+  (pass-if-peval
+    ;; Higher order with optional argument (side-effecting default
+    ;; value).
+    ((lambda* (f x #:optional (y (foo)))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (let (y) (_) ((call (toplevel foo)))
+         (primcall + (lexical y _) (const 7))))
+
+  (pass-if-peval
+    ;; Higher order with optional argument (caller-supplied value).
+    ((lambda* (f x #:optional (y (foo)))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     35)
+    (const 42))
+
+  (pass-if-peval
+    ;; Higher order.
+    ((lambda (f) (f x)) (lambda (x) x))
+    (toplevel x))
+
+  (pass-if-peval
+    ;; Bug reported at
+    ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+    (let ((fold (lambda (f g) (f (g top)))))
+      (fold 1+ (lambda (x) x)))
+    (primcall 1+ (toplevel top)))
+  
+  (pass-if-peval
+    ;; Procedure not inlined when residual code contains recursive calls.
+    ;; <http://debbugs.gnu.org/9542>
+    (letrec ((fold (lambda (f x3 b null? car cdr)
+                     (if (null? x3)
+                         b
+                         (f (car x3) (fold f (cdr x3) b null? car cdr))))))
+      (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
+    (letrec (fold) (_) (_)
+            (call (lexical fold _)
+                   (primitive *)
+                   (toplevel x)
+                   (const 1)
+                   (primitive zero?)
+                   (lambda ()
+                     (lambda-case
+                      (((x1) #f #f #f () (_))
+                       (lexical x1 _))))
+                   (lambda ()
+                     (lambda-case
+                      (((x2) #f #f #f () (_))
+                       (primcall - (lexical x2 _) (const 1))))))))
+
+  (pass-if "inlined lambdas are alpha-renamed"
+    ;; In this example, `make-adder' is inlined more than once; thus,
+    ;; they should use different gensyms for their arguments, because
+    ;; the various optimization passes assume uniquely-named variables.
+    ;;
+    ;; Bug reported at
+    ;; <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 (compile
+                     '(let ((make-adder
+                             (lambda (x) (lambda (y) (+ x y)))))
+                        (cons (make-adder 1) (make-adder 2)))
+                     #:to 'tree-il)))
+      ((primcall cons
+                 (lambda ()
+                   (lambda-case
+                    (((y) #f #f #f () (,gensym1))
+                     (primcall +
+                               (const 1)
+                               (lexical y ,ref1)))))
+                 (lambda ()
+                   (lambda-case
+                    (((y) #f #f #f () (,gensym2))
+                     (primcall +
+                               (const 2)
+                               (lexical y ,ref2))))))
+       (and (eq? gensym1 ref1)
+            (eq? gensym2 ref2)
+            (not (eq? gensym1 gensym2))))
+      (_ #f)))
+
+  (pass-if-peval
+    ;; Higher order, mutually recursive procedures.
+    (letrec ((even? (lambda (x)
+                      (or (= 0 x)
+                          (odd? (- x 1)))))
+             (odd?  (lambda (x)
+                      (not (even? (- x 1))))))
+      (and (even? 4) (odd? 7)))
+    (const #t))
+
+  ;;
+  ;; Below are cases where constant propagation should bail out.
+  ;;
+
+  (pass-if-peval
+    ;; Non-constant lexical is not propagated.
+    (let ((v (make-vector 6 #f)))
+      (lambda (n)
+        (vector-set! v n n)))
+    (let (v) (_)
+         ((call (toplevel make-vector) (const 6) (const #f)))
+         (lambda ()
+           (lambda-case
+            (((n) #f #f #f () (_))
+             (call (toplevel vector-set!)
+                    (lexical v _) (lexical n _) (lexical n _)))))))
+
+  (pass-if-peval
+    ;; Mutable lexical is not propagated.
+    (let ((v (vector 1 2 3)))
+      (lambda ()
+        v))
+    (let (v) (_)
+         ((primcall vector (const 1) (const 2) (const 3)))
+         (lambda ()
+           (lambda-case
+            ((() #f #f #f () ())
+             (lexical v _))))))
+
+  (pass-if-peval
+    ;; Lexical that is not provably pure is not inlined nor propagated.
+    (let* ((x (if (> p q) (frob!) (display 'chbouib)))
+           (y (* x 2)))
+      (+ x x y))
+    (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
+                      (call (toplevel frob!))
+                      (call (toplevel display) (const chbouib))))
+         (let (y) (_) ((primcall * (lexical x _) (const 2)))
+              (primcall +
+                        (lexical x _) (lexical x _) (lexical y _)))))
+
+  (pass-if-peval
+    ;; Non-constant arguments not propagated to lambdas.
+    ((lambda (x y z)
+       (vector-set! x 0 0)
+       (set-car! y 0)
+       (set-cdr! z '()))
+     (vector 1 2 3)
+     (make-list 10)
+     (list 1 2 3))
+    (let (x y z) (_ _ _)
+         ((primcall vector (const 1) (const 2) (const 3))
+          (call (toplevel make-list) (const 10))
+          (primcall list (const 1) (const 2) (const 3)))
+         (seq
+           (call (toplevel vector-set!)
+                  (lexical x _) (const 0) (const 0))
+           (seq (call (toplevel set-car!)
+                  (lexical y _) (const 0))
+                (call (toplevel set-cdr!)
+                      (lexical z _) (const ()))))))
+
+  (pass-if-peval
+   (let ((foo top-foo) (bar top-bar))
+     (let* ((g (lambda (x y) (+ x y)))
+            (f (lambda (g x) (g x x))))
+       (+ (f g foo) (f g bar))))
+   (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
+        (primcall +
+                  (primcall + (lexical foo _) (lexical foo _))
+                  (primcall + (lexical bar _) (lexical bar _)))))
+
+  (pass-if-peval
+    ;; Fresh objects are not turned into constants, nor are constants
+    ;; turned into fresh objects.
+    (let* ((c '(2 3))
+           (x (cons 1 c))
+           (y (cons 0 x)))
+      y)
+    (let (x) (_) ((primcall cons (const 1) (const (2 3))))
+         (primcall cons (const 0) (lexical x _))))
+
+  (pass-if-peval
+    ;; Bindings mutated.
+    (let ((x 2))
+      (set! x 3)
+      x)
+    (let (x) (_) ((const 2))
+         (seq
+           (set! (lexical x _) (const 3))
+           (lexical x _))))
+
+  (pass-if-peval
+    ;; Bindings mutated.
+    (letrec ((x 0)
+             (f (lambda ()
+                  (set! x (+ 1 x))
+                  x)))
+      (frob f) ; may mutate `x'
+      x)
+    (letrec (x) (_) ((const 0))
+            (seq
+              (call (toplevel frob) (lambda _ _))
+              (lexical x _))))
+
+  (pass-if-peval
+    ;; Bindings mutated.
+    (letrec ((f (lambda (x)
+                  (set! f (lambda (_) x))
+                  x)))
+      (f 2))
+    (letrec _ . _))
+
+  (pass-if-peval
+    ;; Bindings possibly mutated.
+    (let ((x (make-foo)))
+      (frob! x) ; may mutate `x'
+      x)
+    (let (x) (_) ((call (toplevel make-foo)))
+         (seq
+           (call (toplevel frob!) (lexical x _))
+           (lexical x _))))
+
+  (pass-if-peval
+    ;; Inlining stops at recursive calls with dynamic arguments.
+    (let loop ((x x))
+      (if (< x 0) x (loop (1- x))))
+    (letrec (loop) (_) ((lambda (_)
+                          (lambda-case
+                           (((x) #f #f #f () (_))
+                            (if _ _
+                                (call (lexical loop _)
+                                       (primcall 1-
+                                                 (lexical x _))))))))
+            (call (lexical loop _) (toplevel x))))
+
+  (pass-if-peval
+    ;; Recursion on the 2nd argument is fully evaluated.
+    (let ((x (top)))
+      (let loop ((x x) (y 10))
+        (if (> y 0)
+            (loop x (1- y))
+            (foo x y))))
+    (let (x) (_) ((call (toplevel top)))
+         (letrec (loop) (_) (_)
+                 (call (toplevel foo) (lexical x _) (const 0)))))
+
+  (pass-if-peval
+    ;; Inlining aborted when residual code contains recursive calls.
+    ;;
+    ;; <http://debbugs.gnu.org/9542>
+    (let loop ((x x) (y 0))
+      (if (> y 0)
+          (loop (1- x) (1- y))
+          (if (< x 0)
+              x
+              (loop (1+ x) (1+ y)))))
+    (letrec (loop) (_) ((lambda (_)
+                          (lambda-case
+                           (((x y) #f #f #f () (_ _))
+                            (if (primcall >
+                                          (lexical y _) (const 0))
+                                _ _)))))
+            (call (lexical loop _) (toplevel x) (const 0))))
+
+  (pass-if-peval
+    ;; Infinite recursion: `peval' gives up and leaves it as is.
+    (letrec ((f (lambda (x) (g (1- x))))
+             (g (lambda (x) (h (1+ x))))
+             (h (lambda (x) (f x))))
+      (f 0))
+    (letrec _ . _))
+
+  (pass-if-peval
+    ;; Constant folding: cons
+   (begin (cons 1 2) #f)
+   (const #f))
+  
+  (pass-if-peval
+    ;; Constant folding: cons
+   (begin (cons (foo) 2) #f)
+   (seq (call (toplevel foo)) (const #f)))
+  
+  (pass-if-peval
+    ;; Constant folding: cons
+   (if (cons 0 0) 1 2)
+   (const 1))
+  
+  (pass-if-peval
+   ;; Constant folding: car+cons
+   (car (cons 1 0))
+   (const 1))
+  
+  (pass-if-peval
+   ;; Constant folding: cdr+cons
+   (cdr (cons 1 0))
+   (const 0))
+  
+  (pass-if-peval
+   ;; Constant folding: car+cons, impure
+   (car (cons 1 (bar)))
+   (seq (call (toplevel bar)) (const 1)))
+  
+  (pass-if-peval
+   ;; Constant folding: cdr+cons, impure
+   (cdr (cons (bar) 0))
+   (seq (call (toplevel bar)) (const 0)))
+  
+  (pass-if-peval
+   ;; Constant folding: car+list
+   (car (list 1 0))
+   (const 1))
+  
+  (pass-if-peval
+   ;; Constant folding: cdr+list
+   (cdr (list 1 0))
+   (primcall list (const 0)))
+  
+  (pass-if-peval
+   ;; Constant folding: car+list, impure
+   (car (list 1 (bar)))
+   (seq (call (toplevel bar)) (const 1)))
+  
+  (pass-if-peval
+   ;; Constant folding: cdr+list, impure
+   (cdr (list (bar) 0))
+   (seq (call (toplevel bar)) (primcall list (const 0))))
+  
+  (pass-if-peval
+   resolve-primitives
+   ;; Prompt is removed if tag is unreferenced
+   (let ((tag (make-prompt-tag)))
+     (call-with-prompt tag
+                       (lambda () 1)
+                       (lambda args args)))
+   (const 1))
+  
+  (pass-if-peval
+   resolve-primitives
+   ;; Prompt is removed if tag is unreferenced, with explicit stem
+   (let ((tag (make-prompt-tag "foo")))
+     (call-with-prompt tag
+                       (lambda () 1)
+                       (lambda args args)))
+   (const 1))
+
+  (pass-if-peval
+   resolve-primitives
+   ;; `while' without `break' or `continue' has no prompts and gets its
+   ;; condition folded.  Unfortunately the outer `lp' does not yet get
+   ;; elided.
+   (while #t #t)
+   (letrec (lp) (_)
+           ((lambda _
+              (lambda-case
+               ((() #f #f #f () ())
+                (letrec (loop) (_)
+                        ((lambda _
+                           (lambda-case
+                            ((() #f #f #f () ())
+                             (call (lexical loop _))))))
+                        (call (lexical loop _)))))))
+           (call (lexical lp _)))))
+
+
 
 (with-test-prefix "tree-il-fold"
 
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index c191c6eab..e4d6efb8f 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -89,6 +89,9 @@
   (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
                                "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+  (pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
+                 (string->date "Wed, 7 Sep 2011 11:25:00 +0000"
+                               "~a,~e ~b ~Y ~H:~M:~S ~z"))
   (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date)
   (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
 
diff --git a/test-suite/vm/t-match.scm b/test-suite/vm/t-match.scm
index ed56ae7ef..2032fbe17 100644
--- a/test-suite/vm/t-match.scm
+++ b/test-suite/vm/t-match.scm
@@ -12,7 +12,7 @@
 (define (matches? obj)
 ;  (format #t "matches? ~a~%" obj)
   (match obj
-	 (($ stuff) #t)
+	 (($ <stuff>) #t)
 ;	 (blurps    #t)
 	 ("hello"   #t)
 	 (else #f)))