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

NEWS

@@ -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

THANKS

@@ -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

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 \
+    && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
-          || git describe --abbrev=4 HEAD 2>/dev/null` \
     && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
     && case $v in
          $prefix[0-9]*) ;;

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

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

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

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
+returns @code{#t} for any kind of procedure.
-return @code{#t} for primitive procedures, and @code{thunk?} only
-returns @code{#t} for procedures which do not accept any arguments.
 
 @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

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

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
+@code{/help/}, and there is no userinfo, port, query, or fragment.  All
-have a scheme and a path (though the path might be empty).  Some URIs
+URIs have a scheme and a path (though the path might be empty).  Some
-have a host, and some of those have ports and userinfo.  Any URI might
+URIs have a host, and some of those have ports and userinfo.  Any URI
-have a query part or a fragment.
+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
 

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))

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)

libguile/deprecation.c

@@ -34,12 +34,6 @@
 
 #include "libguile/private-options.h"
 
-
-/* Windows defines. */
-#ifdef __MINGW32__
-#define vsnprintf _vsnprintf
-#endif
-
 
 
 struct issued_warning {

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

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)));

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);
 }
 

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)));

libguile/gen-scmconfig.c

@@ -149,18 +149,17 @@ main (int argc, char *argv[])
   pf ("/* limits.h not available */\n");
 #endif
 
-# ifdef TIME_WITH_SYS_TIME
+#if HAVE_SYS_TIME_H
   pf ("#include <sys/time.h>\n");
+#else
+  pf ("/* sys/time.h not available */\n");
+#endif
+
+#if HAVE_TIME_H
   pf ("#include <time.h>\n");
-# else
+#else
-#  ifdef HAVE_SYS_TIME_H
+  pf ("/* time.h not available */\n");
-  pf ("#include <sys/time.h>\n");
+#endif
-#  else
-#   ifdef HAVE_TIME_H
-  pf ("#include <time.h>\n");
-#   endif
-#  endif
-# endif
 
   pf("\n");
 #ifdef STDC_HEADERS

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++;

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;
 

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);
 }

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);

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);

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)
 {

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_values (SCM *base, size_t n);
-SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
+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 */

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

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);
+          GC_unregister_disappearing_link ((void **) &from->key);
-          SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key,
+          SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key,
-                                            (GC_PTR) 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,
+        SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
-                                          (GC_PTR) 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,
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
-                                      (GC_PTR) SCM2PTR (obj));
+                                      (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);

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,
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
-                                      (GC_PTR) SCM2PTR (k));
+                                      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,
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
-                                      (GC_PTR) SCM2PTR (v));
+                                      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);
+      GC_unregister_disappearing_link ((void **) &from->key);
-      SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (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);
+      GC_unregister_disappearing_link ((void **) &from->value);
-      SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value));
+      SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->value, SCM2PTR (value));
 #endif
     }
 }

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],
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
-                                      (GC_PTR) SCM2PTR (x));
+                                      SCM2PTR (x));
 }
 
 

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)))

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)

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)
+    => (match-lambda
-         `((required . ,(car arglist))
+        ((req opt keyword aok? rest)
-           (optional . ,(cadr arglist))
+         `((required . ,(if (number? req)
-           (keyword . ,(caddr arglist))
+                            (make-list req '_)
-           (rest . ,(car (cddddr arglist))))))
+                            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)

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))
+       (return (comp expr e)))
-                 (comp expr e))))
       ((array . ,args)
        `(call ,(@implv new-array)
               ,@(map (lambda (x) (comp x e)) args)))

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)

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)
+          (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
-           (logior (accumulate-effects args)
+           (accumulate-effects args))
-                   (if (constructor-primitive? name)
+
-                       (cause &allocation)
+          (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
-                       &no-effects)))
+                               '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)

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?)
+     (and (simple-expression? test bound-vars simple-primcall?)
-          (simple-expression? consequent bound-vars simple-primitive?)
+          (simple-expression? consequent bound-vars simple-primcall?)
-          (simple-expression? alternate bound-vars simple-primitive?)))
+          (simple-expression? alternate bound-vars simple-primcall?)))
     ((<seq> head tail)
-     (and (simple-expression? head bound-vars simple-primitive?)
+     (and (simple-expression? head bound-vars simple-primcall?)
-          (simple-expression? tail bound-vars simple-primitive?)))
+          (simple-expression? tail bound-vars simple-primcall?)))
     ((<primcall> name args)
-     (and (simple-primitive? name)
+     (and (simple-primcall? x)
-          ;; FIXME: check arity?
           (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+exception-free-primcall?
-                                effect-free-primitive?))
+                                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.

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)
+    (record-operand-use op)
-    (if (eq? ctx 'value)
+    (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)
+       (define (make-prompt-tag? x)
-         (cond
+         (match x
-          ((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)
            (($ <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))
+                (unrecord-operand-uses op 1)
-         (_
+                body))
-          (make-prompt src (for-value tag) (for-tail 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))))))

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)))))
 

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)

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))?$"
+   (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
-           userinfo-pat host-pat port-pat)))
+           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)
+                    (or (match:substring m 4)
-                    (let ((port (match:substring m 5)))
+                        (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))))

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))))

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))))

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:

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"))))