Merge remote-tracking branch 'origin/stable-2.0'

Conflicts: libguile/expand.c libguile/hashtab.c libguile/ports.c libguile/vectors.c libguile/weaks.c module/language/ecmascript/compile-tree-il.scm module/language/tree-il/effects.scm module/language/tree-il/fix-letrec.scm module/language/tree-il/peval.scm test-suite/tests/peval.test
2025-06-16 08:40:19 +02:00 · 2012-07-06 16:52:54 +02:00 · 2012-07-06 16:52:54 +02:00 · 2aed2667fc
commit 2aed2667fc
parent b8bc86bce1 24dd9f6fe1
43 changed files with 699 additions and 241 deletions
--- a/169
+++ b/169
@ -5,6 +5,175 @@ See the end for copying conditions.
 Please send Guile bug reports to bug-guile@gnu.org.


+Changes in 2.0.6 (since 2.0.5):
+
+* Notable changes
+
+** New optimization pass: common subexpression elimination (CSE)
+
+Guile's optimizer will now run a CSE pass after partial evaluation.
+This pass propagates static information about branches taken, bound
+lexicals, and effects from an expression's dominators.  It can replace
+common subexpressions with their boolean values (potentially enabling
+dead code elimination), equivalent bound lexicals, or it can elide them
+entirely, depending on the context in which they are executed.  This
+pass is especially useful in removing duplicate type checks, such as
+those produced by SRFi-9 record accessors.
+
+** Improvements to the partial evaluator
+
+Peval can now hoist tests that are common to both branches of a
+conditional into the test.  This can help with long chains of
+conditionals, such as those generated by the `match' macro.  Peval can
+now do simple beta-reductions of procedures with rest arguments.  It
+also avoids residualizing degenerate lexical aliases, even when full
+inlining is not possible.  Finally, peval now uses the effects analysis
+introduced for the CSE pass.  More precise effects analysis allows peval
+to move more code.
+
+** Run finalizers asynchronously in asyncs
+
+Finalizers are now run asynchronously, via an async.  See Asyncs in the
+manual.  This allows Guile and user code to safely allocate memory while
+holding a mutex.
+
+** Update SRFI-14 character sets to Unicode 6.1
+
+Note that this update causes the Latin-1 characters `§' and `¶' to be
+reclassified as punctuation.  They were previously considered to be part
+of `char-set:symbol'.
+
+** Better source information for datums
+
+When the `positions' reader option is on, as it is by default, Guile's
+reader will record source information for more kinds of datums.
+
+** Improved error and warning messages
+
+`syntax-violation' errors now prefer 'subform' for source info, with
+'form' as fallback.  Syntactic errors in `cond' and `case' now produce
+better errors.  `case' can now warn on duplicate datums, or datums that
+cannot be usefully compared with `eqv?'.  `-Warity-mismatch' now handles
+applicable structs.  `-Wformat' is more robust in the presence of
+`gettext'.  Finally, various exceptions thrown by the Web modules now
+define appropriate exception printers.
+
+** A few important bug fixes in the HTTP modules.
+
+Guile's web server framework now checks if an application returns a body
+wheree it is not permitted, for example in response to a HEAD request,
+and warn or truncate the response as appropriate.  Bad requests now
+cause a 400 Bad Request response to be printed before closing the port.
+Finally, some date-printing and URL-parsing bugs were fixed.
+
+** Pretty-print improvements
+
+When Guile needs to pretty-print Tree-IL, it will try to reconstruct
+`cond', `or`, and other derived syntax forms from the primitive tree-IL
+forms.  It also uses the original names instead of the fresh unique
+names, when it is unambiguous to do so.  This can be seen in the output
+of REPL commands like `,optimize'.
+
+Also, the `pretty-print' procedure has a new keyword argument,
+`#:max-expr-width'.
+
+** Fix memory leak involving applicable SMOBs
+
+At some point in the 1.9.x series, Guile began leaking any applicable
+SMOB that was actually applied.  (There was a weak-key map from SMOB to
+trampoline functions, where the value had a strong reference on the
+key.)  This has been fixed.  There was much rejoicing!
+
+** Micro-optimizations
+
+A pile of micro-optimizations: the `string-trim' function when called
+with `char-set:whitespace'; the `(web http)' parsers; SMOB application;
+conversion of raw UTF-8 and UTF-32 data to and from SCM strings; vlists
+and vhashes; `read' when processing string literals.
+
+** Incompatible change to `scandir'
+
+As was the original intention, `scandir' now runs the `select?'
+procedure on all items, including subdirectories and the `.' and `..'
+entries.  It receives the basename of the file in question instead of
+the full name.  We apologize for this incompatible change to this
+function introduced in the 2.0.4 release.
+
+* Manual updates
+
+The manual has been made much more consistent in its naming conventions
+with regards to formal parameters of functions.  Thanks to Bake Timmons.
+
+* New interfaces
+
+** New C function: `scm_to_pointer'
+** New C functions: `scm_new_smob', `scm_new_double_smob'
+** (ice-9 format): Add ~h specifier for localized number output.
+** (web response): New procedure: `response-must-not-include-body?'
+** New predicate: 'supports-source-properties?'
+** New C helpers: `scm_c_values', `scm_c_nvalues'
+** Newly public inline C function: `scm_unget_byte'
+** (language tree-il): New functions: `tree-il=?', `tree-il-hash'
+** New fluid: `%default-port-conversion-strategy'
+** New syntax: `=>' within `case'
+
+Search the manual for these identifiers, for more information.
+
+* New deprecations
+
+** `close-io-port' deprecated
+
+Use `close-port'.
+
+** `scm_sym2var' deprecated
+
+In most cases, replace with `scm_lookup' or `scm_module_variable'.  Use
+`scm_define' or `scm_module_ensure_local_variable' if the second
+argument is nonzero.  See "Accessing Modules from C" in the manual, for
+full details.
+
+** Lookup closures deprecated
+
+These were never documented.  See "Module System Reflection" in the
+manual for replacements.
+
+* Build fixes
+
+** Fix compilation against uninstalled Guile on non-GNU platforms.
+** Fix `SCM_I_ERROR' definition for MinGW without networking.
+** Fix compilation with the Sun C compiler.
+** Fix check for `clock_gettime' on OpenBSD and some other systems.
+** Fix build with --enable-debug-malloc.
+** Honor $(program_transform_name) for the `guile-tools' symlink.
+** Fix cross-compilation of GOOPS-using code.
+
+* Bug fixes
+
+** Fix use of unitialized stat buffer in search-path of absolute paths.
+** Avoid calling `freelocale' with a NULL argument.
+** Work around erroneous tr_TR locale in Darwin 8 in tests.
+** Fix `getaddrinfo' test for Darwin 8.
+** Use Gnulib's `regex' module for better regex portability.
+** `source-properties' and friends work on any object
+** Rewrite open-process in C, for robustness related to threads and fork
+** Fix <TAG>vector-length when applied to other uniform vector types
+** Fix escape-only prompt optimization (was disabled previously)
+** Fix a segfault when /dev/urandom is not accessible
+** Fix flush on soft ports, so that it actually runs.
+** Better compatibility of SRFI-9 records with core records
+** Fix and clarify documentation of `sorted?'.
+** Fix IEEE-754 endianness conversion in bytevectors.
+** Correct thunk check in the `wind' instruction.
+** Add @acronym support to texinfo modules
+** Fix docbook->texi for <ulink> without URL
+** Fix `setvbuf' to leave the line/column number unchanged.
+** Add missing public declaration for `scm_take_from_input_buffers'.
+** Fix relative file name canonicalization with empty %LOAD-PATH entries.
+** Import newer (ice-9 match) from Chibi-Scheme.
+** Fix unbound variables and unbound values in ECMAScript runtime.
+** Make SRFI-6 string ports Unicode-capable.
+
+
 Changes in 2.0.5 (since 2.0.4):

 This release fixes the binary interface information (SONAME) of
--- a/2
+++ b/2
@ -60,6 +60,7 @@ For fixes or providing information which led to a fix:
 	Clinton Ebadi
          David Fang
          Barry Fishman
+       Kevin J. Fletcher
        Charles Gagnon
             Fu-gangqiang
          Aidan Gauland
@ -88,6 +89,7 @@ For fixes or providing information which led to a fix:
          Peter Ivanyi
       Wolfgang Jaehrling
         Aubrey Jaffer
+          David Jaquay
           Paul Jarc
          Steve Juranich
        Richard Kim
--- a/build-aux/git-version-gen
+++ b/build-aux/git-version-gen
@ -1,6 +1,6 @@
 #!/bin/sh
 # Print a version string.
-scriptversion=2012-01-06.07; # UTC
+scriptversion=2012-07-06.14; # UTC

 # Copyright (C) 2007-2012 Free Software Foundation, Inc.
 #
@ -85,18 +85,25 @@ Print a version string.

 Options:

-   --prefix           prefix of git tags (default 'v')
+   --prefix     prefix of git tags to strip from version (default 'v')
+   --match      pattern for git tags to match (default: '\$prefix*')

   --help       display this help and exit
   --version    output version information and exit

-Running without arguments will suffice in most cases."
+Running without arguments will suffice in most cases.  If no --match
+argument is given, only match tags that begin with the --prefix."
+
+prefix=v
+unset match
+unset tag_sed_script

 while test $# -gt 0; do
  case $1 in
    --help) echo "$usage"; exit 0;;
    --version) echo "$version"; exit 0;;
    --prefix) shift; prefix="$1";;
+    --match) shift; match="$1";;
    -*)
      echo "$0: Unknown option '$1'." >&2
      echo "$0: Try '--help' for more information." >&2
@ -119,8 +126,8 @@ if test -z "$tarball_version_file"; then
    exit 1
 fi

+match="${match:-$prefix*}"
 tag_sed_script="${tag_sed_script:-s/x/x/}"
-prefix="${prefix:-v}"

 nl='
 '
@ -150,8 +157,7 @@ then
 # directory, and "git describe" output looks sensible, use that to
 # derive a version string.
 elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
-    && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
-          || git describe --abbrev=4 HEAD 2>/dev/null` \
+    && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
    && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
    && case $v in
         $prefix[0-9]*) ;;
--- a/configure.ac
+++ b/configure.ac
@ -29,7 +29,7 @@ Floor, Boston, MA 02110-1301, USA.
 AC_PREREQ(2.61)

 AC_INIT([GNU Guile],
-        m4_esyscmd([build-aux/git-version-gen .tarball-version]),
+        m4_esyscmd([build-aux/git-version-gen --match  v2.\[12\].\* .tarball-version]),
        [bug-guile@gnu.org])
 AC_CONFIG_AUX_DIR([build-aux])
 AC_CONFIG_MACRO_DIR([m4])
@ -756,7 +756,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #   utimensat: posix.1-2008
 #   sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
 #
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale utimensat sched_getaffinity sched_setaffinity])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale utimensat sched_getaffinity sched_setaffinity])

 # Reasons for testing:
 #   netdb.h - not in mingw
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@ -841,12 +841,27 @@ the current implementation that object shares structure with
@var{args}, so @var{args} should not be modified subsequently.
@end deffn

-@deffn {C Function} scm_c_value_ref (values, idx)
+@deftypefn {C Function} SCM scm_c_values (SCM *base, size_t n)
+@code{scm_c_values} is an alternative to @code{scm_values}.  It creates
+a new values object, and copies into it the @var{n} values starting from
+@var{base}.
+
+Currently this creates a list and passes it to @code{scm_values}, but we
+expect that in the future we will be able to use more a efficient
+representation.
+@end deftypefn
+
+@deftypefn {C Function} size_t scm_c_nvalues (SCM obj)
+If @var{obj} is a multiple-values object, returns the number of values
+it contains.  Otherwise returns 1.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_c_value_ref (SCM obj, size_t idx)
 Returns the value at the position specified by @var{idx} in
-@var{values}.  Note that @var{values} will ordinarily be a
+@var{obj}.  Note that @var{obj} will ordinarily be a
 multiple-values object, but it need not be.  Any other object
 represents a single value (itself), and is handled appropriately.
-@end deffn
+@end deftypefn

@rnindex call-with-values
@deffn {Scheme Procedure} call-with-values producer consumer
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@ -582,6 +582,22 @@ Unsafely cast @var{pointer} to a Scheme object.
 Cross your fingers!
@end deffn

+Sometimes you want to give C extensions access to the dynamic FFI.  At
+that point, the names get confusing, because ``pointer'' can refer to a
+@code{SCM} object that wraps a pointer, or to a @code{void*} value.  We
+will try to use ``pointer object'' to refer to Scheme objects, and
+``pointer value'' to refer to @code{void *} values.
+
+@deftypefn {C Function} SCM scm_from_pointer (void *ptr, void (*finalizer) (void*))
+Create a pointer object from a pointer value.
+
+If @var{finalizer} is non-null, Guile arranges to call it on the pointer
+value at some point after the pointer object becomes collectable.
+@end deftypefn
+
+@deftypefn {C Function} void* scm_to_pointer (SCM obj)
+Unpack the pointer value from a pointer object.
+@end deftypefn

@node Void Pointers and Byte Access
@subsubsection Void Pointers and Byte Access
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@ -644,9 +644,7 @@ properties interface.
 The first group of procedures in this meta-interface are predicates to
 test whether a Scheme object is a procedure, or a special procedure,
 respectively.  @code{procedure?} is the most general predicates, it
-returns @code{#t} for any kind of procedure. @code{closure?} does not
-return @code{#t} for primitive procedures, and @code{thunk?} only
-returns @code{#t} for procedures which do not accept any arguments.
+returns @code{#t} for any kind of procedure.

@rnindex procedure?
@deffn {Scheme Procedure} procedure? obj
@ -656,7 +654,8 @@ Return @code{#t} if @var{obj} is a procedure.

@deffn {Scheme Procedure} thunk? obj
@deffnx {C Function} scm_thunk_p (obj)
-Return @code{#t} if @var{obj} is a thunk.
+Return @code{#t} if @var{obj} is a thunk---a procedure that does
+not accept arguments.
@end deffn

@cindex procedure properties
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@ -862,13 +862,6 @@ arguments from the stack. Return the resulting value to the calling
 procedure.
@end deffn

-@deffn Instruction smob-call nargs
-Pop off the smob object from the stack (which should have been pushed on
-by the trampoline), and call its descriptor's @code{apply} function with
-the @var{nargs} arguments from the stack. Return the resulting value or
-values to the calling procedure.
-@end deffn
-
@deffn Instruction continuation-call
 Pop off an internal continuation object (which should have been pushed
 on by the trampoline), and reinstate that continuation. All of the
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@ -178,10 +178,10 @@ URI := scheme ":" ["//" [userinfo "@@"] host [":" port]] path \

 For example, in the URI, @indicateurl{http://www.gnu.org/help/}, the
 scheme is @code{http}, the host is @code{www.gnu.org}, the path is
-@code{/help/}, and there is no userinfo, port, query, or path.  All URIs
-have a scheme and a path (though the path might be empty).  Some URIs
-have a host, and some of those have ports and userinfo.  Any URI might
-have a query part or a fragment.
+@code{/help/}, and there is no userinfo, port, query, or fragment.  All
+URIs have a scheme and a path (though the path might be empty).  Some
+URIs have a host, and some of those have ports and userinfo.  Any URI
+might have a query part or a fragment.

 Userinfo is something of an abstraction, as some legacy URI schemes
 allowed userinfo of the form @code{@var{username}:@var{passwd}}.  But
@ -665,7 +665,7 @@ A list of allowed methods on a given resource, as symbols.
 A list of content codings, as symbols.
@example
 (parse-header 'content-encoding "gzip")
-@result{} (GET HEAD)
+@result{} (gzip)
@end example
@end deftypevr

--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@ -126,7 +126,8 @@

 /* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler
 * to honor the given alignment constraint.  */
-#if defined __GNUC__
+/* Sun Studio supports alignment since Sun Studio 12 */
+#if defined __GNUC__ || (defined( __SUNPRO_C ) && (__SUNPRO_C - 0 >= 0x590))
 # define SCM_ALIGNED(x)  __attribute__ ((aligned (x)))
 #elif defined __INTEL_COMPILER
 # define SCM_ALIGNED(x)  __declspec (align (x))
--- a/libguile/bdw-gc.h
+++ b/libguile/bdw-gc.h
@ -1,7 +1,7 @@
 #ifndef SCM_BDW_GC_H
 #define SCM_BDW_GC_H

-/* Copyright (C) 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2011, 2012 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
@ -46,12 +46,6 @@
 # include <gc/gc_local_alloc.h>
 #endif

-#if (defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)
-/* This type was provided by `libgc' 6.x.  */
-typedef void *GC_PTR;
-#endif
-
-
 /* Return true if PTR points to the heap.  */
 #define SCM_I_IS_POINTER_TO_THE_HEAP(ptr)	\
  (GC_base (ptr) != NULL)
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@ -34,12 +34,6 @@

 #include "libguile/private-options.h"

-
-/* Windows defines. */
-#ifdef __MINGW32__
-#define vsnprintf _vsnprintf
-#endif
-


 struct issued_warning {
--- a/libguile/expand.c
+++ b/libguile/expand.c
@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
 * Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
@ -49,9 +49,12 @@ static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
 static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];


-#define VOID(src) \
+/* The trailing underscores on these first to are to avoid spurious
+   conflicts with macros defined on MinGW.  */
+
+#define VOID_(src) \
  SCM_MAKE_EXPANDED_VOID(src)
-#define CONST(src, exp) \
+#define CONST_(src, exp) \
  SCM_MAKE_EXPANDED_CONST(src, exp)
 #define PRIMITIVE_REF_TYPE(src, name) \
  SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
@ -375,7 +378,7 @@ expand (SCM exp, SCM env)
        return TOPLEVEL_REF (SCM_BOOL_F, exp);
    }
  else
-    return CONST (SCM_BOOL_F, exp);
+    return CONST_ (SCM_BOOL_F, exp);
 }

 static SCM
@ -433,7 +436,7 @@ expand_and (SCM expr, SCM env)
  const SCM cdr_expr = CDR (expr);

  if (scm_is_null (cdr_expr))
-    return CONST (SCM_BOOL_F, SCM_BOOL_T);
+    return CONST_ (SCM_BOOL_F, SCM_BOOL_T);

  ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);

@ -443,7 +446,7 @@ expand_and (SCM expr, SCM env)
    return CONDITIONAL (scm_source_properties (expr),
                        expand (CAR (cdr_expr), env),
                        expand_and (cdr_expr, env),
-                        CONST (SCM_BOOL_F, SCM_BOOL_F));
+                        CONST_ (SCM_BOOL_F, SCM_BOOL_F));
 }

 static SCM
@ -471,7 +474,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
    }

  if (scm_is_null (rest))
-    rest = VOID (SCM_BOOL_F);
+    rest = VOID_ (SCM_BOOL_F);
  else
    rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);

@ -588,7 +591,7 @@ expand_eval_when (SCM expr, SCM env)
      || scm_is_true (scm_memq (sym_load, CADR (expr))))
    return expand_sequence (CDDR (expr), env);
  else
-    return VOID (scm_source_properties (expr));
+    return VOID_ (scm_source_properties (expr));
 }

 static SCM
@ -602,7 +605,7 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
                      expand (CADDR (expr), env),
                      ((length == 3)
                       ? expand (CADDDR (expr), env)
-                       : VOID (SCM_BOOL_F)));
+                       : VOID_ (SCM_BOOL_F)));
 }

 /* A helper function for expand_lambda to support checking for duplicate
@ -791,7 +794,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
      vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
      env = scm_acons (x, CAR (vars), env);
      if (scm_is_symbol (x))
-        inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
+        inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
      else
        {
          ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
@ -1111,7 +1114,7 @@ expand_or (SCM expr, SCM env SCM_UNUSED)
  ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);

  if (scm_is_null (CDR (expr)))
-    return CONST (SCM_BOOL_F, SCM_BOOL_F);
+    return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
  else
    {
      SCM tmp = scm_gensym (SCM_UNDEFINED);
@ -1135,7 +1138,7 @@ expand_quote (SCM expr, SCM env SCM_UNUSED)
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
  quotee = CAR (cdr_expr);
-  return CONST (scm_source_properties (expr), quotee);
+  return CONST_ (scm_source_properties (expr), quotee);
 }

 static SCM
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@ -103,9 +103,7 @@

 /* Some more definitions for the native Windows port. */
 #ifdef __MINGW32__
-# define mkdir(path, mode) mkdir (path)
 # define fsync(fd) _commit (fd)
-# define fchmod(fd, mode) (-1)
 #endif /* __MINGW32__ */


@ -1336,12 +1334,13 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
 #define FUNC_NAME s_scm_chmod
 {
  int rv;
-  int fdes;

  object = SCM_COERCE_OUTPORT (object);

+#if HAVE_FCHMOD
  if (scm_is_integer (object) || SCM_OPFPORTP (object))
    {
+      int fdes;
      if (scm_is_integer (object))
 	fdes = scm_to_int (object);
      else
@ -1349,6 +1348,7 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
      SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
    }
  else
+#endif
    {
      STRING_SYSCALL (object, c_object,
 		      rv = chmod (c_object, scm_to_int (mode)));
--- a/libguile/finalizers.c
+++ b/libguile/finalizers.c
@ -58,7 +58,7 @@ void
 scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
 {
  GC_finalization_proc prev;
-  GC_PTR prev_data;
+  void *prev_data;
  GC_REGISTER_FINALIZER_NO_ORDER (obj, proc, data, &prev, &prev_data);
 }

--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@ -96,7 +96,7 @@ register_weak_reference (SCM from, SCM to)
 }

 static void
-pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+pointer_finalizer_trampoline (void *ptr, void *data)
 {
  scm_t_pointer_finalizer finalizer = data;
  finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@ -149,17 +149,16 @@ main (int argc, char *argv[])
  pf ("/* limits.h not available */\n");
 #endif

-# ifdef TIME_WITH_SYS_TIME
-  pf ("#include <sys/time.h>\n");
-  pf ("#include <time.h>\n");
-# else
-#  ifdef HAVE_SYS_TIME_H
+#if HAVE_SYS_TIME_H
  pf ("#include <sys/time.h>\n");
 #else
-#   ifdef HAVE_TIME_H
+  pf ("/* sys/time.h not available */\n");
+#endif
+
+#if HAVE_TIME_H
  pf ("#include <time.h>\n");
-#   endif
-#  endif
+#else
+  pf ("/* time.h not available */\n");
 #endif

  pf("\n");
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@ -1,4 +1,5 @@
-/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011,
+ *   2012 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
@ -103,7 +104,7 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
 /* Handle finalization of OBJ which is guarded by the guardians listed in
   GUARDIAN_LIST.  */
 static void
-finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
+finalize_guarded (void *ptr, void *finalizer_data)
 {
  SCM cell_pool;
  SCM obj, guardian_list, proxied_finalizer;
@ -166,7 +167,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
      /* Re-register the finalizer that was in place before we installed this
 	 one.  */
      GC_finalization_proc finalizer, prev_finalizer;
-      GC_PTR finalizer_data, prev_finalizer_data;
+      void *finalizer_data, *prev_finalizer_data;

      finalizer = (GC_finalization_proc) SCM_UNPACK_POINTER (SCM_CAR (proxied_finalizer));
      finalizer_data = SCM_UNPACK_POINTER (SCM_CDR (proxied_finalizer));
@ -206,7 +207,7 @@ scm_i_guard (SCM guardian, SCM obj)
 	 the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
 	 or by this function.  */
      GC_finalization_proc prev_finalizer;
-      GC_PTR prev_data;
+      void *prev_data;
      SCM guardians_for_obj, finalizer_data;

      g->live++;
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@ -179,7 +179,7 @@ static mpz_t z_negative_one;

 /* Clear the `mpz_t' embedded in bignum PTR.  */
 static void
-finalize_bignum (GC_PTR ptr, GC_PTR data)
+finalize_bignum (void *ptr, void *data)
 {
  SCM bignum;

--- a/libguile/ports.c
+++ b/libguile/ports.c
@ -553,7 +553,7 @@ do_free (void *body_data)

 /* Finalize the object (a port) pointed to by PTR.  */
 static void
-finalize_port (GC_PTR ptr, GC_PTR data)
+finalize_port (void *ptr, void *data)
 {
  SCM port = SCM_PACK_POINTER (ptr);

@ -925,7 +925,7 @@ scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handle
 }

 static void
-finalize_iconv_descriptors (GC_PTR ptr, GC_PTR data)
+finalize_iconv_descriptors (void *ptr, void *data)
 {
  close_iconv_descriptors (ptr);
 }
--- a/libguile/smob.c
+++ b/libguile/smob.c
@ -377,7 +377,7 @@ scm_gc_mark (SCM o)

 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 static void
-finalize_smob (GC_PTR ptr, GC_PTR data)
+finalize_smob (void *ptr, void *data)
 {
  SCM smob;
  size_t (* free_smob) (SCM);
--- a/libguile/struct.c
+++ b/libguile/struct.c
@ -411,7 +411,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,

 /* Finalization: invoke the finalizer of the struct pointed to by PTR.  */
 static void
-struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+struct_finalizer_trampoline (void *ptr, void *unused_data)
 {
  SCM obj = PTR2SCM (ptr);
  scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
--- a/libguile/values.c
+++ b/libguile/values.c
@ -67,6 +67,15 @@ print_values (SCM obj, SCM pwps)
  return SCM_UNSPECIFIED;
 }

+size_t
+scm_c_nvalues (SCM obj)
+{
+  if (SCM_LIKELY (SCM_VALUESP (obj)))
+    return scm_ilength (scm_struct_ref (obj, SCM_INUM0));
+  else
+    return 1;
+}
+
 SCM
 scm_c_value_ref (SCM obj, size_t idx)
 {
--- a/libguile/values.h
+++ b/libguile/values.h
@ -33,8 +33,9 @@ SCM_API SCM scm_values_vtable;
 SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);

 SCM_API SCM scm_values (SCM args);
-SCM_API SCM scm_c_values (SCM *base, size_t nvalues);
-SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
+SCM_API SCM scm_c_values (SCM *base, size_t n);
+SCM_API size_t scm_c_nvalues (SCM obj);
+SCM_API SCM scm_c_value_ref (SCM obj, size_t idx);
 SCM_INTERNAL void scm_init_values (void);

 #endif  /* SCM_VALUES_H */
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010,
+ *   2011, 2012 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
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@ -174,11 +174,11 @@ move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to)
      if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
        {
 #ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
-          GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+          GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
 #else
-          GC_unregister_disappearing_link ((GC_PTR) &from->key);
-          SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key,
-                                            (GC_PTR) to->key);
+          GC_unregister_disappearing_link ((void **) &from->key);
+          SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key,
+                                            to->key);
 #endif
        }
    }
@ -418,8 +418,8 @@ resize_set (scm_t_weak_set *set)
      new_entries[new_k].key = copy.key;

      if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
-        SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &new_entries[new_k].key,
-                                          (GC_PTR) new_entries[new_k].key);
+        SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
+                                          (void *) new_entries[new_k].key);
    }
 }

@ -579,8 +579,8 @@ weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
  entries[k].key = SCM_UNPACK (obj);

  if (SCM_HEAP_OBJECT_P (obj))
-    SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entries[k].key,
-                                      (GC_PTR) SCM2PTR (obj));
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
+                                      (void *) SCM2PTR (obj));

  return obj;
 }
@ -631,7 +631,7 @@ weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
              entries[k].key = 0;

              if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
-                GC_unregister_disappearing_link ((GC_PTR) &entries[k].key);
+                GC_unregister_disappearing_link ((void **) &entries[k].key);

              if (--set->n_items < set->lower)
                resize_set (set);
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@ -130,14 +130,14 @@ register_disappearing_links (scm_t_weak_entry *entry,
  if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
      && (kind == SCM_WEAK_TABLE_KIND_KEY
          || kind == SCM_WEAK_TABLE_KIND_BOTH))
-    SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
-                                      (GC_PTR) SCM2PTR (k));
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
+                                      SCM2PTR (k));

  if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
      && (kind == SCM_WEAK_TABLE_KIND_VALUE
          || kind == SCM_WEAK_TABLE_KIND_BOTH))
-    SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value,
-                                      (GC_PTR) SCM2PTR (v));
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
+                                      SCM2PTR (v));
 }

 static void
@ -145,10 +145,10 @@ unregister_disappearing_links (scm_t_weak_entry *entry,
                               scm_t_weak_table_kind kind)
 {
  if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
-    GC_unregister_disappearing_link ((GC_PTR) &entry->key);
+    GC_unregister_disappearing_link ((void **) &entry->key);

  if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
-    GC_unregister_disappearing_link ((GC_PTR) &entry->value);
+    GC_unregister_disappearing_link ((void **) &entry->value);
 }

 static void
@ -159,10 +159,10 @@ move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
      && SCM_HEAP_OBJECT_P (key))
    {
 #ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
-      GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+      GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
 #else
-      GC_unregister_disappearing_link (&from->key);
-      SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (key));
+      GC_unregister_disappearing_link ((void **) &from->key);
+      SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key, SCM2PTR (key));
 #endif
    }

@ -170,10 +170,10 @@ move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
      && SCM_HEAP_OBJECT_P (value))
    {
 #ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
-      GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
+      GC_move_disappearing_link ((void **) &from->value, (void **) &to->value);
 #else
-      GC_unregister_disappearing_link (&from->value);
-      SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value));
+      GC_unregister_disappearing_link ((void **) &from->value);
+      SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->value, SCM2PTR (value));
 #endif
    }
 }
--- a/libguile/weak-vector.c
+++ b/libguile/weak-vector.c
@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011, 2012 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
@ -171,13 +171,13 @@ scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
  elts = SCM_I_VECTOR_WELTS (wv);

  if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev)))
-    GC_unregister_disappearing_link ((GC_PTR) &elts[k]);
+    GC_unregister_disappearing_link ((void **) &elts[k]);
  
  elts[k] = x;

  if (SCM_HEAP_OBJECT_P (x))
-    SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &elts[k],
-                                      (GC_PTR) SCM2PTR (x));
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
+                                      SCM2PTR (x));
 }


--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@ -238,7 +238,14 @@
      (define (set-procedure-arity! proc)
        (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
          (if (not alt)
-              (set-procedure-minimum-arity! proc nreq nopt rest?)
+              (begin
+                (set-procedure-property! proc 'arglist
+                                         (list nreq
+                                               nopt
+                                               (if kw (cdr kw) '())
+                                               (and kw (car kw))
+                                               (and rest? '_)))
+                (set-procedure-minimum-arity! proc nreq nopt rest?))
              (let* ((nreq* (cadr alt))
                     (rest?* (if (null? (cddr alt)) #f (caddr alt)))
                     (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@ -2896,33 +2896,6 @@
                           (binding (car bindings)))
               #'(let (binding) body))))))))

-;; This definition of 'do' is never used, as it is immediately
-;; replaced by the definition in boot-9.scm.
-#;
-(define-syntax do
-   (lambda (orig-x)
-      (syntax-case orig-x ()
-         ((_ ((var init . step) ...) (e0 e1 ...) c ...)
-          (with-syntax (((step ...)
-                         (map (lambda (v s)
-                                (syntax-case s ()
-                                  (() v)
-                                  ((e) #'e)
-                                  (_ (syntax-violation
-                                      'do "bad step expression" 
-                                      orig-x s))))
-                              #'(var ...)
-                              #'(step ...))))
-             (syntax-case #'(e1 ...) ()
-               (() #'(let doloop ((var init) ...)
-                       (if (not e0)
-                           (begin c ... (doloop step ...)))))
-               ((e1 e2 ...)
-                #'(let doloop ((var init) ...)
-                    (if e0
-                        (begin e1 e2 ...)
-                        (begin c ... (doloop step ...)))))))))))
-
 (define-syntax quasiquote
  (let ()
    (define (quasi p lev)
@ -3072,32 +3045,6 @@
                      "expression not valid outside of quasiquote"
                      x)))

-;; This definition of 'case' is never used, as it is immediately
-;; replaced by the definition in boot-9.scm.  This version lacks
-;; R7RS-mandated support for '=>'.
-#;
-(define-syntax case
-  (lambda (x)
-    (syntax-case x ()
-      ((_ e m1 m2 ...)
-       (with-syntax
-           ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
-                    (if (null? clauses)
-                        (syntax-case clause (else)
-                          ((else e1 e2 ...) #'(begin e1 e2 ...))
-                          (((k ...) e1 e2 ...)
-                           #'(if (memv t '(k ...)) (begin e1 e2 ...)))
-                          (_ (syntax-violation 'case "bad clause" x clause)))
-                        (with-syntax ((rest (f (car clauses) (cdr clauses))))
-                          (syntax-case clause (else)
-                            (((k ...) e1 e2 ...)
-                             #'(if (memv t '(k ...))
-                                   (begin e1 e2 ...)
-                                   rest))
-                            (_ (syntax-violation 'case "bad clause" x
-                                                 clause))))))))
-         #'(let ((t e)) body))))))
-
 (define (make-variable-transformer proc)
  (if (procedure? proc)
      (let ((trans (lambda (x)
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@ -1,4 +1,5 @@
-;;;; 	Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011,
+;;;;    2012 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
@ -20,6 +21,7 @@
  #:use-module (ice-9 documentation)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
  #:export (help
            add-value-help-handler! remove-value-help-handler!
            add-name-help-handler! remove-name-help-handler!
@ -504,14 +506,20 @@ It is an image under the mapping EXTRACT."
 if the information cannot be obtained.

 The alist keys that are currently defined are `required', `optional',
-`keyword', and `rest'."
+`keyword', `allow-other-keys?', and `rest'."
  (cond
   ((procedure-property proc 'arglist)
-    => (lambda (arglist)
-         `((required . ,(car arglist))
-           (optional . ,(cadr arglist))
-           (keyword . ,(caddr arglist))
-           (rest . ,(car (cddddr arglist))))))
+    => (match-lambda
+        ((req opt keyword aok? rest)
+         `((required . ,(if (number? req)
+                            (make-list req '_)
+                            req))
+           (optional . ,(if (number? opt)
+                            (make-list opt '_)
+                            opt))
+           (keyword . ,keyword)
+           (allow-other-keys? . ,aok?)
+           (rest . ,rest)))))
   ((procedure-source proc)
    => cadr)
   (((@ (system vm program) program?) proc)
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@ -70,6 +70,26 @@
            (set-source-properties! res (location x))))
      res)))

+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+  (-> (abort (or (current-return-tag) (error "return outside function"))
+             (list expr)
+             (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+  (let ((tag (gensym "return")))
+    (parameterize ((current-return-tag
+                    (-> (lexical 'return tag))))
+      (-> (let '(return) (list tag)
+               (list (-> (primcall 'make-prompt-tag)))
+               (-> (prompt (current-return-tag)
+                           (body-thunk)
+                           (let ((val (gensym "val")))
+                             (-> (lambda-case
+                                  `(((k val) #f #f #f () (,(gensym) ,val))
+                                    ,(-> (lexical 'val val)))))))))))))
+
 (define (comp x e)
  (let ((l (location x)))
    (define (let1 what proc)
@ -330,7 +350,9 @@
         `(lambda ()
            (lambda-case
             ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
-              ,(comp-body e body formals syms))))))
+              ,(with-return-prompt
+                (lambda ()
+                  (comp-body e body formals syms))))))))
      ((call/this ,obj ,prop . ,args)
       (@impl call/this*
              obj
@ -352,8 +374,7 @@
       `(call ,(comp proc e)                
              ,@(map (lambda (x) (comp x e)) args)))
      ((return ,expr)
-       (-> (call (-> (primitive 'return))
-                 (comp expr e))))
+       (return (comp expr e)))
      ((array . ,args)
       `(call ,(@implv new-array)
              ,@(map (lambda (x) (comp x e)) args)))
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@ -841,6 +841,7 @@
          (values `(,@car-code ,@cdr-code (cons))
                  (1+ addr)))))
     ((and (vector? x)
+           (<= (vector-length x) #xffff)
           (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
      (receive (codes addr)
          (vector-fold2 (lambda (x codes addr)
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@ -265,11 +265,32 @@ of an expression."
           (cause &zero-values))

          ;; Effect-free primitives.
-          (($ <primcall> _ (and name (? effect+exception-free-primitive?)) args)
-           (logior (accumulate-effects args)
-                   (if (constructor-primitive? name)
-                       (cause &allocation)
-                       &no-effects)))
+          (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
+           (accumulate-effects args))
+
+          (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
+                               'vector? 'struct? 'string? 'number?
+                               'char?)
+              (arg))
+           (compute-effects arg))
+
+          ;; Primitives that allocate memory.
+          (($ <primcall> _ 'cons (x y))
+           (logior (compute-effects x) (compute-effects y)
+                   &allocation))
+
+          (($ <primcall> _ (or 'list 'vector) args)
+           (logior (accumulate-effects args) &allocation))
+
+          (($ <primcall> _ 'make-prompt-tag ())
+           &allocation)
+
+          (($ <primcall> _ 'make-prompt-tag (arg))
+           (logior (compute-effects arg) &allocation))
+
+          ;; Primitives that are normally effect-free, but which might
+          ;; cause type checks, allocate memory, or access mutable
+          ;; memory.  FIXME: expand, to be more precise.
          (($ <primcall> _ (and name (? effect-free-primitive?)) args)
           (logior (accumulate-effects args)
                   (cause &type-check)
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@ -21,7 +21,7 @@
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (language tree-il)
-  #:use-module (language tree-il primitives)
+  #:use-module (language tree-il effects)
  #:export (fix-letrec!))

 ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
@ -31,24 +31,23 @@
 (define fix-fold
  (make-tree-il-folder unref ref set simple lambda complex))

-(define (simple-expression? x bound-vars simple-primitive?)
+(define (simple-expression? x bound-vars simple-primcall?)
  (record-case x
    ((<void>) #t)
    ((<const>) #t)
    ((<lexical-ref> gensym)
     (not (memq gensym bound-vars)))
    ((<conditional> test consequent alternate)
-     (and (simple-expression? test bound-vars simple-primitive?)
-          (simple-expression? consequent bound-vars simple-primitive?)
-          (simple-expression? alternate bound-vars simple-primitive?)))
+     (and (simple-expression? test bound-vars simple-primcall?)
+          (simple-expression? consequent bound-vars simple-primcall?)
+          (simple-expression? alternate bound-vars simple-primcall?)))
    ((<seq> head tail)
-     (and (simple-expression? head bound-vars simple-primitive?)
-          (simple-expression? tail bound-vars simple-primitive?)))
+     (and (simple-expression? head bound-vars simple-primcall?)
+          (simple-expression? tail bound-vars simple-primcall?)))
    ((<primcall> name args)
-     (and (simple-primitive? name)
-          ;; FIXME: check arity?
+     (and (simple-primcall? x)
          (and-map (lambda (x)
-                     (simple-expression? x bound-vars simple-primitive?))
+                     (simple-expression? x bound-vars simple-primcall?))
                   args)))
    (else #f)))

@ -91,6 +90,17 @@
                  (lambda (x unref ref set simple lambda* complex)
                    (record-case x
                      ((<letrec> in-order? (orig-gensyms gensyms) vals)
+                       (define compute-effects
+                         (make-effects-analyzer (lambda (x) (memq x set))))
+                       (define (effect-free-primcall? x)
+                         (let ((effects (compute-effects x)))
+                           (effect-free?
+                            (exclude-effects effects (logior &allocation
+                                                             &type-check)))))
+                       (define (effect+exception-free-primcall? x)
+                         (let ((effects (compute-effects x)))
+                           (effect-free?
+                            (exclude-effects effects &allocation))))
                       (let lp ((gensyms orig-gensyms) (vals vals)
                                (s '()) (l '()) (c '()))
                         (cond
@ -113,7 +123,7 @@
                                    (not (lambda? (car vals)))
                                    (not (simple-expression?
                                          (car vals) orig-gensyms
-                                          effect+exception-free-primitive?)))
+                                          effect+exception-free-primcall?)))
                               (lp (cdr gensyms) (cdr vals)
                                   s l (cons (car gensyms) c))
                               (lp (cdr gensyms) (cdr vals)
@ -127,8 +137,8 @@
                          ((simple-expression?
                            (car vals) orig-gensyms
                            (if in-order?
-                                effect+exception-free-primitive?
-                                effect-free-primitive?))
+                                effect+exception-free-primcall?
+                                effect-free-primcall?))
                           ;; For letrec*, we can't consider e.g. `car' to be
                           ;; "simple", as it could raise an exception. Hence
                           ;; effect+exception-free-primitive? above.
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@ -285,7 +285,7 @@
 ;; TODO: Record value size in operand structure?
 ;; 
 (define-record-type <operand>
-  (%make-operand var sym visit source visit-count residualize?
+  (%make-operand var sym visit source visit-count use-count
                 copyable? residual-value constant-value alias-value)
  operand?
  (var operand-var)
@ -293,7 +293,7 @@
  (visit %operand-visit)
  (source operand-source)
  (visit-count operand-visit-count set-operand-visit-count!)
-  (residualize? operand-residualize? set-operand-residualize?!)
+  (use-count operand-use-count set-operand-use-count!)
  (copyable? operand-copyable? set-operand-copyable?!)
  (residual-value operand-residual-value %set-operand-residual-value!)
  (constant-value operand-constant-value set-operand-constant-value!)
@ -305,7 +305,7 @@
  ;; expression, truncate it to one value.  Copy propagation does not
  ;; work on multiply-valued expressions.
  (let ((source (and=> source truncate-values)))
-    (%make-operand var sym visit source 0 #f
+    (%make-operand var sym visit source 0 0
                   (and source (not (var-set? var))) #f #f
                   (and (not (var-set? var)) alias))))

@ -451,10 +451,19 @@ top-level bindings from ENV and return the resulting expression."
    (let ((x (vhash-assq new store)))
      (if x (cdr x) new)))

+  (define (record-operand-use op)
+    (set-operand-use-count! op (1+ (operand-use-count op))))
+
+  (define (unrecord-operand-uses op n)
+    (let ((count (- (operand-use-count op) n)))
+      (when (zero? count)
+        (set-operand-residual-value! op #f))
+      (set-operand-use-count! op count)))
+
  (define* (residualize-lexical op #:optional ctx val)
    (log 'residualize op)
-    (set-operand-residualize?! op #t)
-    (if (eq? ctx 'value)
+    (record-operand-use op)
+    (if (memq ctx '(value values))
        (set-operand-residual-value! op val))
    (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))

@ -594,7 +603,8 @@ top-level bindings from ENV and return the resulting expression."
      ;; marked as needing residualization.  Here we hack around this
      ;; and treat all bindings as referenced if we are in operator
      ;; context.
-      (or (eq? ctx 'operator) (operand-residualize? op)))
+      (or (eq? ctx 'operator)
+          (not (zero? (operand-use-count op)))))
    
    ;; values := (op ...)
    ;; effects := (op ...)
@ -808,7 +818,7 @@ top-level bindings from ENV and return the resulting expression."
                   exp
                   (make-seq src exp (make-void #f))))
             (begin
-               (set-operand-residualize?! op #t)
+               (record-operand-use op)
               (make-lexical-set src name (operand-sym op) (for-value exp))))))
      (($ <let> src names gensyms vals body)
       (define (compute-alias exp)
@ -1091,6 +1101,17 @@ top-level bindings from ENV and return the resulting expression."
               (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
               (make-primcall src 'values vals))))))

+      (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
+       (match (for-value tail)
+         (($ <const> _ (args* ...))
+          (let ((args* (map (lambda (x) (make-const #f x)) args*)))
+            (for-tail (make-call src proc (append args args*)))))
+         (($ <primcall> _ 'list args*)
+          (for-tail (make-call src proc (append args args*))))
+         (tail
+          (let ((args (append (map for-value args) (list tail))))
+            (make-primcall src '@apply (cons (for-value proc) args))))))
+
      (($ <primcall> src (? constructor-primitive? name) args)
       (cond
        ((and (memq ctx '(effect test))
@ -1339,24 +1360,79 @@ top-level bindings from ENV and return the resulting expression."
                           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)))
-           => (lambda (x)
-                (singly-used-definition (visit-operand x counter 'value 10 10))))
-          (else x)))
-       (match (singly-used-definition tag)
+       (define (make-prompt-tag? x)
+         (match x
           (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
+            #t)
+           (_ #f)))
+       (define (find-definition x n-aliases)
+         (cond
+          ((lexical-ref? x)
+           (cond
+            ((lookup (lexical-ref-gensym x))
+             => (lambda (op)
+                  (let ((y (or (operand-residual-value op)
+                               (visit-operand op counter 'value 10 10))))
+                    (cond
+                     ((and (lexical-ref? y)
+                           (= (lexical-refcount (lexical-ref-gensym x)) 1))
+                      ;; X is a simple alias for Y.  Recurse, regardless of
+                      ;; the number of aliases we were expecting.
+                      (find-definition y n-aliases))
+                     ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+                      ;; We found a definition that is aliased the right
+                      ;; number of times.  We still recurse in case it is a
+                      ;; lexical.
+                      (values (find-definition y 1)
+                              op))
+                     (else
+                      ;; We can't account for our aliases.
+                      (values #f #f))))))
+            (else
+             ;; A formal parameter.  Can't say anything about that.
+             (values #f #f))))
+          ((= n-aliases 1)
+           ;; Not a lexical: success, but only if we are looking for an
+           ;; unaliased value.
+           (values x #f))
+          (else (values #f #f))))
+
+       (let ((tag (for-value tag))
+             (body (for-tail body)))
+         (cond
+          ((find-definition tag 1)
+           (lambda (val op)
+             (make-prompt-tag? val))
+           => (lambda (val op)
                ;; 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)
+                (unrecord-operand-uses op 1)
+                body))
+          ((find-definition tag 2)
+           (lambda (val op)
+             (and (make-prompt-tag? val)
+                  (abort? body)
+                  (tree-il=? (abort-tag body) tag)))
+           => (lambda (val op)
+                ;; (let ((t (make-prompt-tag)))
+                ;;   (call-with-prompt t
+                ;;     (lambda () (abort-to-prompt t val ...))
+                ;;     (lambda (k arg ...) e ...)))
+                ;; => (let-values (((k arg ...) (values values val ...)))
+                ;;      e ...)
+                (unrecord-operand-uses op 2)
+                (for-tail
+                 (make-let-values
+                  src
+                  (make-primcall #f 'apply
+                                 `(,(make-primitive-ref #f 'values)
+                                   ,(make-primitive-ref #f 'values)
+                                   ,@(abort-args body)
+                                   ,(abort-tail body)))
                  (for-value handler)))))
+          (else
+           (make-prompt src tag body (for-value handler))))))
      (($ <abort> src tag args tail)
       (make-abort src (for-value tag) (map for-value args)
                   (for-value tail))))))
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@ -185,6 +185,7 @@
      (lambda ()
        (let ((p ((@ (system base compile) compile) exp
                  #:env *dispatch-module*
+                  #:from 'scheme
                  #:opts '(#:partial-eval? #f #:cse? #f))))
          (apply p vals)))))

--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@ -342,7 +342,12 @@ Find bindings/modules/packages."
 (define-meta-command (describe repl (form))
  "describe OBJ
 Show description/documentation."
-  (display (object-documentation (repl-eval repl (repl-parse repl form))))
+  (display
+    (object-documentation
+      (let ((input (repl-parse repl form)))
+        (if (symbol? input)
+            (module-ref (current-module) input)
+            (repl-eval repl input)))))
  (newline))

 (define-meta-command (option repl . args)
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@ -91,7 +91,7 @@ consistency checks to make sure that the constructed URI is valid."
 (define ipv4-regexp
  (make-regexp "^([0-9.]+)$"))
 (define ipv6-regexp
-  (make-regexp "^\\[([0-9a-fA-F:]+)\\]+$"))
+  (make-regexp "^([0-9a-fA-F:.]+)$"))
 (define domain-label-regexp
  (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
 (define top-label-regexp
@ -116,12 +116,14 @@ consistency checks to make sure that the constructed URI is valid."
  "[a-zA-Z0-9_.!~*'();:&=+$,-]+")
 (define host-pat
  "[a-zA-Z0-9.-]+")
+(define ipv6-host-pat
+  "[0-9a-fA-F:.]+")
 (define port-pat
  "[0-9]*")
 (define authority-regexp
  (make-regexp
-   (format #f "^//((~a)@)?(~a)(:(~a))?$"
-           userinfo-pat host-pat port-pat)))
+   (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
+           userinfo-pat host-pat ipv6-host-pat port-pat)))

 (define (parse-authority authority fail)
  (if (equal? authority "//")
@ -129,10 +131,12 @@ consistency checks to make sure that the constructed URI is valid."
      ;; file:/etc/hosts.
      (values #f #f #f)
      (let ((m (regexp-exec authority-regexp authority)))
-        (if (and m (valid-host? (match:substring m 3)))
+        (if (and m (valid-host? (or (match:substring m 4)
+                                    (match:substring m 6))))
            (values (match:substring m 2)
-                    (match:substring m 3)
-                    (let ((port (match:substring m 5)))
+                    (or (match:substring m 4)
+                        (match:substring m 6))
+                    (let ((port (match:substring m 8)))
                      (and port (not (string-null? port))
                           (string->number port))))
            (fail)))))
@ -216,7 +220,9 @@ printed."
         (string-append "//"
                        (if userinfo (string-append userinfo "@")
                            "")
-                        host
+                        (if (string-index host #\:)
+                            (string-append "[" host "]")
+                            host)
                        (if (default-port? (uri-scheme uri) port)
                            ""
                            (string-append ":" (number->string port))))
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@ -281,4 +281,10 @@
     (primcall car (toplevel x))
     (if (primcall car (toplevel x))
         (const one)
-         (const two)))))
+         (const two))))
+
+  (pass-if-cse
+   (begin (cons 1 2 3) 4)
+   (seq
+     (primcall cons (const 1) (const 2) (const 3))
+     (const 4))))
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@ -32,7 +32,7 @@
  (@@ (language tree-il optimize) peval))

 (define-syntax pass-if-peval
-  (syntax-rules (resolve-primitives)
+  (syntax-rules ()
    ((_ in pat)
     (pass-if-peval in pat
                    (expand-primitives!
@ -973,8 +973,13 @@
  (pass-if-peval
   ;; `while' without `break' or `continue' has no prompts and gets its
   ;; condition folded.  Unfortunately the outer `lp' does not yet get
-   ;; elided.
+   ;; elided, and the continuation tag stays around.  (The continue tag
+   ;; stays around because although it is not referenced, recursively
+   ;; visiting the loop in the continue handler manages to visit the tag
+   ;; twice before aborting.  The abort doesn't unroll the recursive
+   ;; reference.)
   (while #t #t)
+   (let (_) (_) ((primcall make-prompt-tag . _))
        (letrec (lp) (_)
                ((lambda _
                   (lambda-case
@ -985,7 +990,7 @@
                                 ((() #f #f #f () ())
                                  (call (lexical loop _))))))
                             (call (lexical loop _)))))))
-           (call (lexical lp _))))
+                (call (lexical lp _)))))

  (pass-if-peval
   (lambda (a . rest)
@ -1068,4 +1073,19 @@
                             (call (toplevel baz) (toplevel x))
                             (call (lexical failure _)))))
                 (call (lexical failure _)))
-             (call (lexical failure _))))))
+             (call (lexical failure _)))))
+
+  (pass-if-peval
+    (apply (lambda (x y) (cons x y)) '(1 2))
+    (primcall cons (const 1) (const 2)))
+
+  (pass-if-peval
+    (apply (lambda (x y) (cons x y)) (list 1 2))
+    (primcall cons (const 1) (const 2)))
+
+  (pass-if-peval
+    (let ((t (make-prompt-tag)))
+      (call-with-prompt t
+                        (lambda () (abort-to-prompt t 1 2 3))
+                        (lambda (k x y z) (list x y z))))
+    (primcall list (const 1) (const 2) (const 3))))
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@ -1,7 +1,7 @@
 ;;;; session.test --- test suite for (ice-9 session)   -*- scheme -*-
 ;;;; Jose Antonio Ortega Ruiz <jao@gnu.org> -- August 2010
 ;;;;
-;;;; 	Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010, 2012 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
@ -20,6 +20,8 @@

 (define-module (test-suite session)
  #:use-module (test-suite lib)
+  #:use-module (ice-9 match)
+  #:use-module (system base compile)
  #:use-module (ice-9 session))

 (define (find-module mod)
@ -51,3 +53,72 @@
 (with-test-prefix "apropos-fold-exported"
  (pass-if "a child of test-suite" (find-interface '(test-suite lib)))
  (pass-if "a child of ice-9" (find-interface '(ice-9 session))))
+
+(with-test-prefix "procedure-arguments"
+
+  (define-syntax-rule (pass-if-valid-arguments name proc expected)
+    (pass-if name
+      (let ((args (procedure-arguments (compile 'proc #:to 'value))))
+        (or (equal? args 'expected)
+            (pk 'invalid-args args #f)))))
+
+  (pass-if-valid-arguments "lambda"
+    (lambda (a b c) #f)
+    ((required . (a b c)) (optional) (keyword)
+     (allow-other-keys? . #f) (rest . #f)))
+  (pass-if-valid-arguments "lambda with rest"
+    (lambda (a b . r) #f)
+    ((required . (a b)) (optional) (keyword)
+     (allow-other-keys? . #f) (rest . r)))
+  (pass-if-valid-arguments "lambda* with optionals"
+    (lambda* (a b #:optional (p 1) (q 2)) #f)
+    ((required . (a b)) (optional . (p q))
+     (keyword) (allow-other-keys? . #f) (rest . #f)))
+  (pass-if-valid-arguments "lambda* with keywords"
+    (lambda* (a b #:key (k 42) l) #f)
+    ((required . (a b)) (optional)
+     (keyword . ((#:k . 2) (#:l . 3))) (allow-other-keys? . #f)
+     (rest . #f)))
+  (pass-if-valid-arguments "lambda* with keywords and a-o-k"
+    (lambda* (a b #:key (k 42) #:allow-other-keys) #f)
+    ((required . (a b)) (optional)
+     (keyword . ((#:k . 2))) (allow-other-keys? . #t)
+     (rest . #f)))
+  (pass-if-valid-arguments "lambda* with optionals, keys, and rest"
+    (lambda* (a b #:optional o p #:key k l #:rest r) #f)
+    ((required . (a b)) (optional . (o p))
+     (keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
+     (rest . k)))
+
+  (pass-if "aok? is preserved"
+    ;; See <http://bugs.gnu.org/10938>.
+    (let* ((proc (compile '(lambda (a b) #f) #:to 'value))
+           (args (procedure-arguments proc)))
+      (set-procedure-property! proc 'arglist (map cdr args))
+      (equal? args (procedure-arguments proc))))
+
+  (pass-if "interpreted procedures (simple)"
+    (match (procedure-arguments
+            (eval '(lambda (x y) #f) (current-module)))
+      (((required _ _)
+        (optional)
+        (keyword)
+        (allow-other-keys? . #f)
+        (rest . #f))
+       #t)
+      (_ #f)))
+
+  (pass-if "interpreted procedures (complex)"
+    (match (procedure-arguments
+            (eval '(lambda* (a b #:optional c #:key d) #f) (current-module)))
+      (((required _ _)
+        (optional _)
+        (keyword (#:d . 3))
+        (allow-other-keys? . #f)
+        (rest . #f))
+       #t)
+      (_ #f))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-valid-arguments 'scheme-indent-function 1)
+;;; End:
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@ -90,6 +90,22 @@
    (uri=? (build-uri 'http #:host "bad.host.1" #:validate? #f)
           #:scheme 'http #:host "bad.host.1" #:path ""))

+  (pass-if "http://1.good.host"
+    (uri=? (build-uri 'http #:host "1.good.host")
+           #:scheme 'http #:host "1.good.host" #:path ""))
+
+  (pass-if "http://192.0.2.1"
+    (uri=? (build-uri 'http #:host "192.0.2.1")
+           #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+  (pass-if "http://[2001:db8::1]"
+    (uri=? (build-uri 'http #:host "2001:db8::1")
+           #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+  (pass-if "http://[::ffff:192.0.2.1]"
+    (uri=? (build-uri 'http #:host "::ffff:192.0.2.1")
+           #:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
+
  (pass-if-uri-exception "http://foo:not-a-port"
                         "Expected.*port"
                         (build-uri 'http #:host "foo" #:port "not-a-port"))
@ -135,6 +151,29 @@
  (pass-if "http://bad.host.1"
    (not (string->uri "http://bad.host.1")))

+  (pass-if "http://1.good.host"
+    (uri=? (string->uri "http://1.good.host")
+           #:scheme 'http #:host "1.good.host" #:path ""))
+
+  (pass-if "http://192.0.2.1"
+    (uri=? (string->uri "http://192.0.2.1")
+           #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+  (pass-if "http://[2001:db8::1]"
+    (uri=? (string->uri "http://[2001:db8::1]")
+           #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+  (pass-if "http://[2001:db8::1]:80"
+    (uri=? (string->uri "http://[2001:db8::1]:80")
+           #:scheme 'http
+           #:host "2001:db8::1"
+           #:port 80
+           #:path ""))
+
+  (pass-if "http://[::ffff:192.0.2.1]"
+    (uri=? (string->uri "http://[::ffff:192.0.2.1]")
+           #:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
+
  (pass-if "http://foo:"
    (uri=? (string->uri "http://foo:")
           #:scheme 'http #:host "foo" #:path ""))
@ -188,6 +227,18 @@
    (equal? "ftp://foo@bar:22/baz"
            (uri->string (string->uri "ftp://foo@bar:22/baz"))))
  
+  (pass-if "http://192.0.2.1"
+    (equal? "http://192.0.2.1"
+            (uri->string (string->uri "http://192.0.2.1"))))
+
+  (pass-if "http://[2001:db8::1]"
+    (equal? "http://[2001:db8::1]"
+            (uri->string (string->uri "http://[2001:db8::1]"))))
+
+  (pass-if "http://[::ffff:192.0.2.1]"
+    (equal? "http://[::ffff:192.0.2.1]"
+            (uri->string (string->uri "http://[::ffff:192.0.2.1]"))))
+
  (pass-if "http://foo:"
    (equal? "http://foo"
            (uri->string (string->uri "http://foo:"))))
@ -197,7 +248,11 @@
            (uri->string (string->uri "http://foo:/")))))

 (with-test-prefix "decode"
-  (pass-if (equal? "foo bar" (uri-decode "foo%20bar"))))
+  (pass-if "foo%20bar"
+    (equal? "foo bar" (uri-decode "foo%20bar")))
+
+  (pass-if "foo+bar"
+    (equal? "foo bar" (uri-decode "foo+bar"))))

 (with-test-prefix "encode"
  (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))))