Merge branch 'stable-2.0'

Conflicts:
	benchmark-suite/benchmarks/ports.bm
	libguile/async.h
	libguile/bytevectors.c
	libguile/foreign.c
	libguile/gsubr.c
	libguile/srfi-1.c
	libguile/vm-engine.h
	libguile/vm-i-scheme.c
	module/Makefile.am
	module/language/tree-il/analyze.scm
	module/language/tree-il/peval.scm
	module/scripts/compile.scm
	module/scripts/disassemble.scm
	test-suite/tests/asm-to-bytecode.test
	test-suite/tests/peval.test
	test-suite/tests/rdelim.test

THANKS

@@ -167,6 +167,7 @@ For fixes or providing information which led to a fix:
           Cesar Strauss
 	  Klaus Stehle
          Rainer Tammer
+          Frank Terbeck
 	 Samuel Thibault
         Richard Todd
     Sree Harsha Totakura
@@ -182,6 +183,7 @@ For fixes or providing information which led to a fix:
           Aaron VanDevender
          Sjoerd Van Leent
 	Andreas Vögele
+          Chris Vine
         Michael Talbot-Wilson
         Michael Tuexen
             Xin Wang

autogen.sh

@@ -15,11 +15,7 @@ autoconf --version
 echo ""
 automake --version
 echo ""
-if test "`uname -s`" = Darwin; then
+libtoolize --version
-  glibtool --version
-else
-  libtool --version
-fi
 echo ""
 ${M4:-m4} --version
 echo ""

benchmark-suite/benchmarks/ports.bm

@@ -1,6 +1,6 @@
 ;;; ports.bm --- Port I/O.         -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public License
@@ -87,4 +87,9 @@
   (let ((str (string-concatenate (make-list 1000 "one line\n"))))
     (benchmark "read-line" 1000
                (let ((port (open-input-string str)))
-                 (sequence (read-line port) 1000)))))
+                 (sequence (read-line port) 1000))))
+
+  (let ((str (large-string "Hello, world.\n")))
+    (benchmark "read-string" 200
+               (let ((port (open-input-string str)))
+                 (read-string port)))))

configure.ac

@@ -692,10 +692,9 @@ AC_TYPE_GETGROUPS
 AC_TYPE_SIGNAL
 AC_TYPE_MODE_T
 
-# On mingw -lm is empty, so this test is unnecessary, but it's
+dnl Check whether we need -lm.
-# harmless so we don't hard-code to suppress it.
+LT_LIB_M
-#
+LIBS="$LIBS $LIBM"
-AC_CHECK_LIB(m, cos)
 
 AC_CHECK_FUNCS(gethostbyname)
 if test $ac_cv_func_gethostbyname = no; then
@@ -770,9 +769,6 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid		\
   strcoll strcoll_l newlocale utimensat sched_getaffinity		\
   sched_setaffinity sendfile])
 
-AM_CONDITIONAL([BUILD_ICE_9_POPEN],
-  [test "x$enable_posix" = "xyes" && test "x$ac_cv_func_fork" = "xyes"])
-
 # Reasons for testing:
 #   netdb.h - not in mingw
 #   sys/param.h - not in mingw
@@ -1351,8 +1347,11 @@ case "$with_threads" in
     #     pthread_attr_get_np - "np" meaning "non portable" says it
     #         all; specific to FreeBSD
     #     pthread_sigmask - not available on mingw
+    #     pthread_cancel - not available on Android (Bionic libc)
     #
-    AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask)
+    AC_CHECK_FUNCS([pthread_attr_getstack pthread_getattr_np		\
+      pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask	\
+      pthread_cancel])
 
     # On past versions of Solaris, believe 8 through 10 at least, you
     # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };".

doc/ref/api-evaluation.texi

@@ -215,8 +215,9 @@ convention is used when indenting code in Emacs' Scheme mode.
 In addition to the standard line comments defined by R5RS, Guile has
 another comment type for multiline comments, called @dfn{block
 comments}.  This type of comment begins with the character sequence
-@code{#!} and ends with the characters @code{!#}, which must appear on a
+@code{#!} and ends with the characters @code{!#}.
-line of their own.  These comments are compatible with the block
+
+These comments are compatible with the block
 comments in the Scheme Shell @file{scsh} (@pxref{The Scheme shell
 (scsh)}).  The characters @code{#!} were chosen because they are the
 magic characters used in shell scripts for indicating that the name of

doc/ref/api-modules.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+@c Copyright (C)  1996, 1997, 2000-2004, 2007-2014
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -126,6 +126,16 @@ them to suit the current module's needs.  For example:
               #:renamer (symbol-prefix-proc 'unixy:)))
 @end lisp
 
+@noindent
+or more simply:
+
+@cindex prefix
+@lisp
+(use-modules ((ice-9 popen)
+              #:select ((open-pipe . pipe-open) close-pipe)
+              #:prefix unixy:))
+@end lisp
+
 Here, the interface specification is more complex than before, and the
 result is that a custom interface with only two bindings is created and
 subsequently accessed by the current module.  The mapping of old to new
@@ -184,21 +194,24 @@ whose public interface is found and used.
 
 @cindex binding renamer
 @lisp
- (MODULE-NAME [#:select SELECTION] [#:renamer RENAMER])
+ (MODULE-NAME [#:select SELECTION]
+              [#:prefix PREFIX]
+              [#:renamer RENAMER])
 @end lisp
 
 in which case a custom interface is newly created and used.
 @var{module-name} is a list of symbols, as above; @var{selection} is a
-list of selection-specs; and @var{renamer} is a procedure that takes a
+list of selection-specs; @var{prefix} is a symbol that is prepended to
-symbol and returns its new name.  A selection-spec is either a symbol or
+imported names; and @var{renamer} is a procedure that takes a symbol and
-a pair of symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in
+returns its new name.  A selection-spec is either a symbol or a pair of
-the used module and @var{seen} is the name in the using module.  Note
+symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in the used
-that @var{seen} is also passed through @var{renamer}.
+module and @var{seen} is the name in the using module.  Note that
+@var{seen} is also modified by @var{prefix} and @var{renamer}.
 
-The @code{#:select} and @code{#:renamer} clauses are optional.  If both are
+The @code{#:select}, @code{#:prefix}, and @code{#:renamer} clauses are
-omitted, the returned interface has no bindings.  If the @code{#:select}
+optional.  If all are omitted, the returned interface has no bindings.
-clause is omitted, @var{renamer} operates on the used module's public
+If the @code{#:select} clause is omitted, @var{prefix} and @var{renamer}
-interface.
+operate on the used module's public interface.
 
 In addition to the above, @var{spec} can also include a @code{#:version} 
 clause, of the form:
@@ -584,8 +597,8 @@ expression:
 
 @lisp
   (library (mylib (1 2))
-    (import (otherlib (3)))
+    (export mybinding)
-    (export mybinding))
+    (import (otherlib (3))))
 @end lisp
 
 is equivalent to the module definition:

doc/ref/api-utility.texi

@@ -222,7 +222,7 @@ setting of @var{obj}'s @var{property}.
 
 A single object property created by @code{make-object-property} can
 associate distinct property values with all Scheme values that are
-distinguishable by @code{eq?} (including, for example, integers).
+distinguishable by @code{eq?} (ruling out numeric values).
 
 Internally, object properties are implemented using a weak key hash
 table.  This means that, as long as a Scheme value with property values

doc/ref/posix.texi

@@ -1793,13 +1793,19 @@ Example: (system* "echo" "foo" "bar")
 Terminate the current process with proper unwinding of the Scheme stack.
 The exit status zero if @var{status} is not supplied.  If @var{status}
 is supplied, and it is an integer, that integer is used as the exit
-status.  If @var{status} is @code{#t} or @code{#f}, the exit status is 0
+status.  If @var{status} is @code{#t} or @code{#f}, the exit status is
-or 1, respectively.
+@var{EXIT_SUCCESS} or @var{EXIT_FAILURE}, respectively.
 
 The procedure @code{exit} is an alias of @code{quit}.  They have the
 same functionality.
 @end deffn
 
+@defvr {Scheme Variable} EXIT_SUCCESS
+@defvrx {Scheme Variable} EXIT_FAILURE
+These constants represent the standard exit codes for success (zero) or
+failure (one.)
+@end defvr
+
 @deffn {Scheme Procedure} primitive-exit [status]
 @deffnx {Scheme Procedure} primitive-_exit [status]
 @deffnx {C Function} scm_primitive_exit (status)

doc/ref/srfi-modules.texi

@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008,
+@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014
-@c   2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+@c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node SRFI Support
@@ -4517,11 +4517,11 @@ Create and return a vector whose elements are @var{x} @enddots{}.
 @end deffn
 
 @deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{}
-The fundamental vector constructor.  Create a vector whose length is
+The fundamental vector constructor.  Create a vector whose length
-@var{length} and iterates across each index k from 0 up to
+is @var{length} and iterates across each index k from 0 up to
-@var{length} - 1, applying @var{f} at each iteration to the current index
+@var{length} - 1, applying @var{f} at each iteration to the current
-and current seeds, in that order, to receive n + 1 values: first, the
+index and current seeds, in that order, to receive n + 1 values: the
-element to put in the kth slot of the new vector and n new seeds for
+element to put in the kth slot of the new vector, and n new seeds for
 the next iteration.  It is an error for the number of seeds to vary
 between iterations.
 

doc/ref/texinfo.texi

@@ -287,7 +287,7 @@ as an argument, and the returned value is sent to the output string via
 @samp{display}. If @var{replace} is anything else, it is sent through
 the output string via @samp{display}.
 
-Note that te replacement for the matched characters does not need to be
+Note that the replacement for the matched characters does not need to be
 a single character. That is what differentiates this function from
 @samp{string-map}, and what makes it useful for applications such as
 converting @samp{#\&} to @samp{"&"} in web page text. Some other

guile-readline/ice-9/readline.scm

@@ -119,7 +119,8 @@
 (define-once the-readline-port #f)
 
 (define-once history-variable "GUILE_HISTORY")
-(define-once history-file (string-append (getenv "HOME") "/.guile_history"))
+(define-once history-file
+  (string-append (or (getenv "HOME") ".") "/.guile_history"))
 
 (define-public readline-port
   (let ((do (lambda (r/w)

libguile/async.h

@@ -3,7 +3,8 @@
 #ifndef SCM_ASYNC_H
 #define SCM_ASYNC_H
 
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 2009, 2011
+ *   2014 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
@@ -44,10 +45,10 @@ SCM_API SCM scm_run_asyncs (SCM list_of_a);
 SCM_API SCM scm_noop (SCM args);
 SCM_API SCM scm_call_with_blocked_asyncs (SCM proc);
 SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc);
-void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d);
+SCM_API void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d);
-void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d);
+SCM_API void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d);
-void scm_dynwind_block_asyncs (void);
+SCM_API void scm_dynwind_block_asyncs (void);
-void scm_dynwind_unblock_asyncs (void);
+SCM_API void scm_dynwind_unblock_asyncs (void);
 
 /* Critical sections */
 

libguile/bytevectors.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2009-2014 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
@@ -332,10 +332,16 @@ scm_c_shrink_bytevector (SCM bv, size_t c_new_len)
   SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
 
   if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
-    new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv),
+    {
-				      c_len + SCM_BYTEVECTOR_HEADER_BYTES,
+      signed char *c_bv;
-				      c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
+
-				      SCM_GC_BYTEVECTOR));
+      c_bv = scm_gc_realloc (SCM2PTR (bv),
+			     c_len + SCM_BYTEVECTOR_HEADER_BYTES,
+			     c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
+			     SCM_GC_BYTEVECTOR);
+      new_bv = PTR2SCM (c_bv);
+      SCM_BYTEVECTOR_SET_CONTENTS (new_bv, c_bv + SCM_BYTEVECTOR_HEADER_BYTES);
+    }
   else
     {
       signed char *c_bv;

libguile/debug.c

@@ -27,6 +27,11 @@
 #include <sys/resource.h>
 #endif
 
+#ifdef __MINGW32__
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+#endif
+
 #include "libguile/_scm.h"
 #include "libguile/async.h"
 #include "libguile/eval.h"
@@ -180,7 +185,7 @@ scm_local_eval (SCM exp, SCM env)
 static void
 init_stack_limit (void)
 {
-#ifdef HAVE_GETRLIMIT
+#if defined HAVE_GETRLIMIT
   struct rlimit lim;
   if (getrlimit (RLIMIT_STACK, &lim) == 0)
       {
@@ -194,6 +199,16 @@ init_stack_limit (void)
           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
       }
   errno = 0;
+#elif defined __MINGW32__
+  MEMORY_BASIC_INFORMATION m;
+  uintptr_t bytes;
+
+  if (VirtualQuery ((LPCVOID) &m, &m, sizeof m))
+    {
+      bytes = (DWORD_PTR) m.BaseAddress + m.RegionSize
+	       - (DWORD_PTR) m.AllocationBase;
+      SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
+    }
 #endif
 }
 

libguile/filesys.c

@@ -50,6 +50,7 @@
 
 #include "libguile/validate.h"
 #include "libguile/filesys.h"
+#include "libguile/load.h"	/* for scm_i_mirror_backslashes */
 
 
 #ifdef HAVE_IO_H
@@ -1238,6 +1239,9 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
       errno = save_errno;
       SCM_SYSERROR;
     }
+  /* On Windows, convert backslashes in current directory to forward
+     slashes.  */
+  scm_i_mirror_backslashes (wd);
   result = scm_from_locale_stringn (wd, strlen (wd));
   free (wd);
   return result;

libguile/foreign.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2010, 2011, 2012, 2013  Free Software Foundation, Inc.
+/* Copyright (C) 2010-2013  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/fports.c

@@ -155,7 +155,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
   int cmode;
   long csize;
   size_t ndrained;
-  char *drained;
+  char *drained = NULL;
   scm_t_port *pt;
   scm_t_ptob_descriptor *ptob;
 

libguile/gsubr.c

@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013
+ *   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/i18n.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2006-2014 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
@@ -1465,6 +1465,14 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
    Note: We don't use Gnulib's `nl_langinfo' module because it's currently not
    as complete as the compatibility hacks in `i18n.scm'.  */
 
+static char *
+copy_string_or_null (const char *s)
+{
+  if (s == NULL)
+    return NULL;
+  else
+    return strdup (s);
+}
 
 SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	    (SCM item, SCM locale),
@@ -1496,8 +1504,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
   if (c_locale != NULL)
     {
 #ifdef USE_GNU_LOCALE_API
-      c_result = nl_langinfo_l (c_item, c_locale);
+      c_result = copy_string_or_null (nl_langinfo_l (c_item, c_locale));
-      codeset = nl_langinfo_l (CODESET, c_locale);
+      codeset = copy_string_or_null (nl_langinfo_l (CODESET, c_locale));
 #else /* !USE_GNU_LOCALE_API */
       /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
 	 mutex is already taken.  */
@@ -1521,8 +1529,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	scm_locale_error (FUNC_NAME, lsec_err);
       else
 	{
-	  c_result = nl_langinfo (c_item);
+	  c_result = copy_string_or_null (nl_langinfo (c_item));
-          codeset = nl_langinfo (CODESET);
+          codeset = copy_string_or_null (nl_langinfo (CODESET));
 
 	  restore_locale_settings (&lsec_prev_locale);
 	  free_locale_settings (&lsec_prev_locale);
@@ -1531,13 +1539,10 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
     }
   else
     {
-      c_result = nl_langinfo (c_item);
+      c_result = copy_string_or_null (nl_langinfo (c_item));
-      codeset = nl_langinfo (CODESET);
+      codeset = copy_string_or_null (nl_langinfo (CODESET));
     }
 
-  if (c_result != NULL)
-    c_result = strdup (c_result);
-
   unlock_locale_mutex ();
 
   if (c_result == NULL)
@@ -1580,9 +1585,13 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	  }
 #endif
 
-#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
+#if defined FRAC_DIGITS || defined INT_FRAC_DIGITS
+#ifdef FRAC_DIGITS
 	case FRAC_DIGITS:
+#endif
+#ifdef INT_FRAC_DIGITS
 	case INT_FRAC_DIGITS:
+#endif
 	  /* This is to be interpreted as a single integer.  */
 	  if (*c_result == CHAR_MAX)
 	    /* Unspecified.  */
@@ -1594,12 +1603,18 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	  break;
 #endif
 
-#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
+#if defined P_CS_PRECEDES || defined N_CS_PRECEDES ||	\
+  defined INT_P_CS_PRECEDES || defined INT_N_CS_PRECEDES || \
+  defined P_SEP_BY_SPACE || defined N_SEP_BY_SPACE
+#ifdef P_CS_PRECEDES
 	case P_CS_PRECEDES:
 	case N_CS_PRECEDES:
+#endif
+#ifdef INT_N_CS_PRECEDES
 	case INT_P_CS_PRECEDES:
 	case INT_N_CS_PRECEDES:
-#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
+#endif
+#ifdef P_SEP_BY_SPACE
 	case P_SEP_BY_SPACE:
 	case N_SEP_BY_SPACE:
 #endif
@@ -1610,11 +1625,16 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	  break;
 #endif
 
-#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
+#if defined P_SIGN_POSN || defined N_SIGN_POSN || \
+  defined INT_P_SIGN_POSN || defined INT_N_SIGN_POSN
+#ifdef P_SIGN_POSN
 	case P_SIGN_POSN:
 	case N_SIGN_POSN:
+#endif
+#ifdef INT_P_SIGN_POSN
 	case INT_P_SIGN_POSN:
 	case INT_N_SIGN_POSN:
+#endif
 	  /* See `(libc) Sign of Money Amount' for the interpretation of the
 	     return value here.  */
 	  switch (*c_result)
@@ -1654,6 +1674,9 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	}
     }
 
+  if (codeset != NULL)
+    free (codeset);
+
   return result;
 }
 #undef FUNC_NAME

libguile/init.c

@@ -310,6 +310,9 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
   void *res;
   struct main_func_closure c;
 
+  /* On Windows, convert backslashes in argv[0] to forward
+     slashes.  */
+  scm_i_mirror_backslashes (argv[0]);
   c.main_func = main_func;
   c.closure = closure;
   c.argc = argc;

libguile/list.c

@@ -1,5 +1,5 @@
-/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011
+/* Copyright (C) 1995-1997, 2000, 2001, 2003, 2004, 2008-2011,
- * Free Software Foundation, Inc.
+ *   2014 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
@@ -179,24 +179,25 @@ SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
    long" lists (i.e. lists with cycles in their cdrs), and returns -1
    if it does find one.  */
 long
-scm_ilength(SCM sx)
+scm_ilength (SCM sx)
 {
   long i = 0;
   SCM tortoise = sx;
   SCM hare = sx;
 
-  do {
+  do
-    if (SCM_NULL_OR_NIL_P(hare)) return i;
+    {
-    if (!scm_is_pair (hare)) return -1;
+      if (!scm_is_pair (hare))
-    hare = SCM_CDR(hare);
+        return SCM_NULL_OR_NIL_P (hare) ? i : -1;
-    i++;
+      hare = SCM_CDR (hare);
-    if (SCM_NULL_OR_NIL_P(hare)) return i;
+      i++;
-    if (!scm_is_pair (hare)) return -1;
+      if (!scm_is_pair (hare))
-    hare = SCM_CDR(hare);
+        return SCM_NULL_OR_NIL_P (hare) ? i : -1;
-    i++;
+      hare = SCM_CDR (hare);
-    /* For every two steps the hare takes, the tortoise takes one.  */
+      i++;
-    tortoise = SCM_CDR(tortoise);
+      /* For every two steps the hare takes, the tortoise takes one.  */
-  }
+      tortoise = SCM_CDR (tortoise);
+    }
   while (!scm_is_eq (hare, tortoise));
 
   /* If the tortoise ever catches the hare, then the list must contain

libguile/load.c

@@ -276,6 +276,41 @@ SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+/* On Posix hosts, just return PATH unaltered.  On Windows,
+   destructively replace all backslashes in PATH with Unix-style
+   forward slashes, so that Scheme code always gets d:/foo/bar style
+   file names.  This avoids multiple subtle problems with comparing
+   file names as strings, and with redirections in /bin/sh command
+   lines.
+
+   Note that, if PATH is result of a call to 'getenv', this
+   destructively modifies the environment variables, so both
+   scm_getenv and subprocesses will afterwards see the values with
+   forward slashes.  That is OK as long as applied to Guile-specific
+   environment variables, since having scm_getenv return the same
+   value as used by the callers of this function is good for
+   consistency and file-name comparison.  Avoid using this function on
+   values returned by 'getenv' for general-purpose environment
+   variables; instead, make a copy of the value and work on that.  */
+SCM_INTERNAL char *
+scm_i_mirror_backslashes (char *path)
+{
+#ifdef __MINGW32__
+  if (path)
+    {
+      char *p = path;
+
+      while (*p)
+	{
+	  if (*p == '\\')
+	    *p = '/';
+	  p++;
+	}
+    }
+#endif
+
+  return path;
+}
 
 /* Initialize the global variable %load-path, given the value of the
    SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
@@ -288,7 +323,7 @@ scm_init_load_path ()
   SCM cpath = SCM_EOL;
 
 #ifdef SCM_LIBRARY_DIR
-  env = getenv ("GUILE_SYSTEM_PATH");
+  env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_PATH"));
   if (env && strcmp (env, "") == 0)
     /* special-case interpret system-path=="" as meaning no system path instead
        of '("") */
@@ -301,7 +336,7 @@ scm_init_load_path ()
                        scm_from_locale_string (SCM_GLOBAL_SITE_DIR),
                        scm_from_locale_string (SCM_PKGDATA_DIR));
 
-  env = getenv ("GUILE_SYSTEM_COMPILED_PATH");
+  env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_COMPILED_PATH"));
   if (env && strcmp (env, "") == 0)
     /* like above */
     ; 
@@ -344,14 +379,17 @@ scm_init_load_path ()
       cachedir[0] = 0;
 
     if (cachedir[0])
-      *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir);
+      {
+	scm_i_mirror_backslashes (cachedir);
+	*scm_loc_compile_fallback_path = scm_from_locale_string (cachedir);
+      }
   }
 
-  env = getenv ("GUILE_LOAD_PATH");
+  env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_PATH"));
   if (env)
     path = scm_parse_path_with_ellipsis (scm_from_locale_string (env), path);
 
-  env = getenv ("GUILE_LOAD_COMPILED_PATH");
+  env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_COMPILED_PATH"));
   if (env)
     cpath = scm_parse_path_with_ellipsis (scm_from_locale_string (env), cpath);
 
@@ -451,11 +489,10 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
   return 0;
 }
 
-#ifdef __MINGW32__
+/* Defined as "/" for Unix and Windows alike, so that file names
-#define FILE_NAME_SEPARATOR_STRING "\\"
+   constructed by the functions in this module wind up with Unix-style
-#else
+   forward slashes as directory separators.  */
 #define FILE_NAME_SEPARATOR_STRING "/"
-#endif
 
 static int
 is_file_name_separator (SCM c)
@@ -619,7 +656,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
 	  if (stat (buf.buf, stat_buf) == 0
 	      && ! (stat_buf->st_mode & S_IFDIR))
 	    {
-	      result = scm_from_locale_string (buf.buf);
+	      result =
+		scm_from_locale_string (scm_i_mirror_backslashes (buf.buf));
 	      goto end;
 	    }
 	}
@@ -876,7 +914,7 @@ canonical_suffix (SCM fname)
 
   /* CANON should be absolute.  */
   canon = scm_canonicalize_path (fname);
-  
+
 #ifdef __MINGW32__
   {
     size_t len = scm_c_string_length (canon);

libguile/load.h

@@ -44,6 +44,7 @@ SCM_INTERNAL void scm_init_load_path (void);
 SCM_INTERNAL void scm_init_load (void);
 SCM_INTERNAL void scm_init_load_should_auto_compile (void);
 SCM_INTERNAL void scm_init_eval_in_scheme (void);
+SCM_INTERNAL char *scm_i_mirror_backslashes (char *path);
 
 #endif  /* SCM_LOAD_H */
 

libguile/locale-categories.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2014 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
@@ -23,8 +23,10 @@
 SCM_DEFINE_LOCALE_CATEGORY (COLLATE)
 SCM_DEFINE_LOCALE_CATEGORY (CTYPE)
 
-#ifdef LC_MESSAGES
+#if defined(LC_MESSAGES) && !(defined(LC_MAX) && LC_MESSAGES > LC_MAX)
-/* MinGW doesn't have `LC_MESSAGES'.  */
+/* MinGW doesn't have `LC_MESSAGES'.  libintl.h might define
+   `LC_MESSAGES' for MinGW to an arbitrary large value which we cannot
+   use in a call to `setlocale'.  */
 SCM_DEFINE_LOCALE_CATEGORY (MESSAGES)
 #endif
 

libguile/posix.c

@@ -1346,23 +1346,21 @@ scm_open_process (SCM mode, SCM prog, SCM args)
       SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F;
 
       /* There is no sense in catching errors on close().  */
-      if (reading) 
+      if (reading)
         {
           close (c2p[1]);
-          read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe);
+          read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe);
-          scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED);
         }
       if (writing)
         {
           close (p2c[0]);
-          write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe);
+          write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe);
-          scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED);
         }
-      
+
       return scm_values
         (scm_list_3 (read_port, write_port, scm_from_int (pid)));
     }
-  
+
   /* The child.  */
   if (reading)
     close (c2p[0]);
@@ -1982,9 +1980,9 @@ cpu_set_to_bitvector (const cpu_set_t *cs)
   SCM bv;
   size_t cpu;
 
-  bv = scm_c_make_bitvector (sizeof (*cs), SCM_BOOL_F);
+  bv = scm_c_make_bitvector (CPU_SETSIZE, SCM_BOOL_F);
 
-  for (cpu = 0; cpu < sizeof (*cs); cpu++)
+  for (cpu = 0; cpu < CPU_SETSIZE; cpu++)
     {
       if (CPU_ISSET (cpu, cs))
 	/* XXX: This is inefficient but avoids code duplication.  */
@@ -2250,6 +2248,12 @@ void
 scm_init_posix ()
 {
   scm_add_feature ("posix");
+#ifdef EXIT_SUCCESS
+  scm_c_define ("EXIT_SUCCESS", scm_from_int (EXIT_SUCCESS));
+#endif
+#ifdef EXIT_FAILURE
+  scm_c_define ("EXIT_FAILURE", scm_from_int (EXIT_FAILURE));
+#endif
 #ifdef HAVE_GETEUID
   scm_add_feature ("EIDs");
 #endif

libguile/simpos.c

@@ -45,6 +45,10 @@
 # include <sys/wait.h>
 #endif
 
+#ifdef __MINGW32__
+# include <process.h>	/* for spawnvp and friends */
+#endif
+
 #include "posix.h"
 
 
@@ -86,8 +90,6 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0,
 
 
 #ifdef HAVE_SYSTEM
-#ifdef HAVE_WAITPID
-
 
 SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
            (SCM args),
@@ -115,11 +117,18 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
   if (scm_is_pair (args))
     {
       SCM oldint;
-      SCM oldquit;
       SCM sig_ign;
       SCM sigint;
+      /* SIGQUIT is undefined on MS-Windows.  */
+#ifdef SIGQUIT
+      SCM oldquit;
       SCM sigquit;
+#endif
+#ifdef HAVE_FORK
       int pid;
+#else
+      int status;
+#endif
       char **execargv;
 
       /* allocate before fork */
@@ -128,10 +137,13 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
       /* make sure the child can't kill us (as per normal system call) */
       sig_ign = scm_from_ulong ((unsigned long) SIG_IGN);
       sigint = scm_from_int (SIGINT);
-      sigquit = scm_from_int (SIGQUIT);
       oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
+#ifdef SIGQUIT
+      sigquit = scm_from_int (SIGQUIT);
       oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);
-      
+#endif
+
+#ifdef HAVE_FORK
       pid = fork ();
       if (pid == 0)
         {
@@ -164,12 +176,20 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
 
           return scm_from_int (status);
         }
+#else  /* !HAVE_FORK */
+      status = spawnvp (P_WAIT, execargv[0], (const char * const *)execargv);
+      scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
+#ifdef SIGQUIT
+      scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
+#endif
+
+      return scm_from_int (status);
+#endif /* !HAVE_FORK */
     }
   else
     SCM_WRONG_TYPE_ARG (1, args);
 }
 #undef FUNC_NAME
-#endif /* HAVE_WAITPID */
 #endif /* HAVE_SYSTEM */
 
 

libguile/smob.h

@@ -147,14 +147,14 @@ scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
 #define SCM_SET_SMOB_OBJECT_1(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 1, (obj)))
 #define SCM_SET_SMOB_OBJECT_2(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 2, (obj)))
 #define SCM_SET_SMOB_OBJECT_3(x,obj)	(SCM_SET_SMOB_OBJECT_N ((x), 3, (obj)))
-#define SCM_SMOB_OBJECT_0_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 0)))
+#define SCM_SMOB_OBJECT_0_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 0))
-#define SCM_SMOB_OBJECT_1_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 1)))
+#define SCM_SMOB_OBJECT_1_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 1))
-#define SCM_SMOB_OBJECT_2_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 2)))
+#define SCM_SMOB_OBJECT_2_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 2))
-#define SCM_SMOB_OBJECT_3_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 3)))
+#define SCM_SMOB_OBJECT_3_LOC(x)	(SCM_SMOB_OBJECT_N_LOC ((x), 3))
 
 #define SCM_SMOB_OBJECT(x)		(SCM_SMOB_OBJECT_1 (x))
 #define SCM_SET_SMOB_OBJECT(x,obj)	(SCM_SET_SMOB_OBJECT_1 ((x), (obj)))
-#define SCM_SMOB_OBJECT_LOC(x)		(SCM_SMOB_OBJECT_1_LOC (x)))
+#define SCM_SMOB_OBJECT_LOC(x)		(SCM_SMOB_OBJECT_1_LOC (x))
 
 
 #define SCM_SMOB_APPLY_0(x)		(scm_call_0 (x))

libguile/srfi-1.c

@@ -1,7 +1,7 @@
 /* srfi-1.c --- SRFI-1 procedures for Guile
  *
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
+ * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011, 2013
- *   2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+ *   2014 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
@@ -614,8 +614,40 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
 	    "circular.")
 #define FUNC_NAME s_scm_srfi1_length_plus
 {
-  long len = scm_ilength (lst);
+  size_t i = 0;
-  return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
+  SCM tortoise = lst;
+  SCM hare = lst;
+
+  do
+    {
+      if (!scm_is_pair (hare))
+        {
+          if (SCM_NULL_OR_NIL_P (hare))
+            return scm_from_size_t (i);
+          else
+            scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
+                                    "proper or circular list");
+        }
+      hare = SCM_CDR (hare);
+      i++;
+      if (!scm_is_pair (hare))
+        {
+          if (SCM_NULL_OR_NIL_P (hare))
+            return scm_from_size_t (i);
+          else
+            scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
+                                    "proper or circular list");
+        }
+      hare = SCM_CDR (hare);
+      i++;
+      /* For every two steps the hare takes, the tortoise takes one.  */
+      tortoise = SCM_CDR (tortoise);
+    }
+  while (!scm_is_eq (hare, tortoise));
+
+  /* If the tortoise ever catches the hare, then the list must contain
+     a cycle.  */
+  return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 

libguile/threads.c

@@ -1036,6 +1036,11 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+/* Some systems, notably Android, lack 'pthread_cancel'.  Don't provide
+   'cancel-thread' on these systems.  */
+
+#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL
+
 SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
 	    (SCM thread),
 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
@@ -1061,6 +1066,8 @@ SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+#endif
+
 SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0,
 	    (SCM thread, SCM proc),
 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "

module/Makefile.am

@@ -198,7 +198,9 @@ SCRIPTS_SOURCES =				\
   scripts/summarize-guile-TODO.scm		\
   scripts/api-diff.scm				\
   scripts/read-rfc822.scm			\
-  scripts/snarf-guile-m4-docs.scm
+  scripts/snarf-guile-m4-docs.scm		\
+  scripts/autofrisk.scm				\
+  scripts/scan-api.scm
 
 SYSTEM_BASE_SOURCES =				\
   system/base/pmatch.scm			\
@@ -248,6 +250,7 @@ ICE_9_SOURCES = \
   ice-9/peg.scm \
   ice-9/poe.scm \
   ice-9/poll.scm \
+  ice-9/popen.scm \
   ice-9/posix.scm \
   ice-9/q.scm \
   ice-9/rdelim.scm \
@@ -280,18 +283,6 @@ ICE_9_SOURCES = \
   ice-9/local-eval.scm \
   ice-9/unicode.scm
 
-if BUILD_ICE_9_POPEN
-
-# This functionality is missing on systems without `fork'---i.e., Windows.
-ICE_9_SOURCES += ice-9/popen.scm
-
-# These modules rely on (ice-9 popen).
-SCRIPTS_SOURCES +=				\
-  scripts/autofrisk.scm				\
-  scripts/scan-api.scm
-
-endif BUILD_ICE_9_POPEN
-
 srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
 
 SRFI_SOURCES = \

module/ice-9/boot-9.scm

@@ -1,8 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;;; Copyright (C) 1995-2014  Free Software Foundation, Inc.
-;;;;   2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
-;;;;   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
@@ -430,13 +428,15 @@ file with the given name already exists, the effect is unspecified."
   (syntax-rules ()
     ((_) #t)
     ((_ x) x)
-    ((_ x y ...) (if x (and y ...) #f))))
+    ;; Avoid ellipsis, which would lead to quadratic expansion time.
+    ((_ x . y) (if x (and . y) #f))))
 
 (define-syntax or
   (syntax-rules ()
     ((_) #f)
     ((_ x) x)
-    ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+    ;; Avoid ellipsis, which would lead to quadratic expansion time.
+    ((_ x . y) (let ((t x)) (if t t (or . y))))))
 
 (include-from-path "ice-9/quasisyntax")
 
@@ -1891,7 +1891,7 @@ written into the port is returned."
        (or (char=? c #\/)
            (char=? c #\\)))
 
-     (define file-name-separator-string "\\")
+     (define file-name-separator-string "/")
 
      (define (absolute-file-name? file-name)
        (define (file-name-separator-at-index? idx)
@@ -1982,7 +1982,7 @@ written into the port is returned."
 (define-syntax-rule (add-to-load-path elt)
   "Add ELT to Guile's load path, at compile-time and at run-time."
   (eval-when (expand load eval)
-    (set! %load-path (cons elt %load-path))))
+    (set! %load-path (cons elt (delete elt %load-path)))))
 
 (define %load-verbosely #f)
 (define (assert-load-verbosity v) (set! %load-verbosely v))

module/ice-9/curried-definitions.scm

@@ -17,7 +17,8 @@
 (define-module (ice-9 curried-definitions)
   #:replace ((cdefine . define)
              (cdefine* . define*)
-             define-public))
+             define-public
+             define*-public))
 
 (define-syntax cdefine
   (syntax-rules ()
@@ -44,3 +45,13 @@
      (begin
        (define name val)
        (export name)))))
+
+(define-syntax define*-public
+  (syntax-rules ()
+    ((_ (head . rest) body body* ...)
+     (define*-public head
+       (lambda* rest body body* ...)))
+    ((_ name val)
+     (begin
+       (define* name val)
+       (export name)))))

module/ice-9/rdelim.scm

@@ -1,7 +1,8 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013,
-;;;; 
+;;;;   2014 Free Software Foundation, Inc.
+;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
@@ -148,26 +149,29 @@ left in the port."
                 (lp (1+ n)))))
         (- n start))))
 
-(define* (read-string #:optional (port (current-input-port)) (count #f))
+(define* read-string
-  "Read all of the characters out of PORT and return them as a string.
+  (case-lambda*
+   "Read all of the characters out of PORT and return them as a string.
 If the COUNT argument is present, treat it as a limit to the number of
 characters to read.  By default, there is no limit."
-  (check-arg (or (not count) (index? count)) "bad count" count)
+   ((#:optional (port (current-input-port)))
-  (let loop ((substrings '())
+    ;; Fast path.
-             (total-chars 0)
+    ;; This creates more garbage than using 'string-set!' as in
-             (buf-size 100))		; doubled each time through.
+    ;; 'read-string!', but currently that is faster nonetheless.
-    (let* ((buf (make-string (if count
+    (let loop ((chars '()))
-                                 (min buf-size (- count total-chars))
+      (let ((char (read-char port)))
-                                 buf-size)))
+        (if (eof-object? char)
-           (nchars (read-string! buf port))
+            (list->string (reverse! chars))
-           (new-total (+ total-chars nchars)))
+            (loop (cons char chars))))))
-      (cond
+   ((port count)
-       ((= nchars buf-size)
+    ;; Slower path.
-        ;; buffer filled.
+    (let loop ((chars '())
-        (loop (cons buf substrings) new-total (* buf-size 2)))
+               (total 0))
-       (else
+      (let ((char (read-char port)))
-        (string-concatenate-reverse
+        (if (or (eof-object? char) (>= total count))
-         (cons (substring buf 0 nchars) substrings)))))))
+            (list->string (reverse chars))
+            (loop (cons char chars) (+ 1 total))))))))
+
 
 ;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
 ;;; from PORT.  The return value depends on the value of HANDLE-DELIM,

module/language/tree-il/analyze.scm

@@ -1,6 +1,6 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008-2014 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
@@ -1222,6 +1222,16 @@ given `tree-il' element."
                               conditions end-group
                               (+ 1 min-count)
                               (+ 1 max-count)))
+             ((#\p #\P) (let* ((colon?    (memq #\: params))
+                               (min-count (if colon?
+                                              (max 1 min-count)
+                                              (+ 1 min-count))))
+                          (loop (cdr chars) 'literal '()
+                                conditions end-group
+                                min-count
+                                (if colon?
+                                    (max max-count min-count)
+                                    (+ 1 max-count)))))
              ((#\[)
               (loop chars 'literal '() '()
                     (let ((selector (previous-number params))

module/language/tree-il/peval.scm

@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014 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
@@ -1405,18 +1405,31 @@ top-level bindings from ENV and return the resulting expression."
                                 gensyms
                                 (append req-vals opt-vals rest-vals)
                                 body)
-                      ;; The required argument values are in the scope
+                      ;; The default initializers of optional arguments
-                      ;; of the optional argument initializers.
+                      ;; may refer to earlier arguments, so in the general
+                      ;; case we must expand into a series of nested let
+                      ;; expressions.
+                      ;;
+                      ;; In the generated code, the outermost let
+                      ;; expression will bind all required arguments, as
+                      ;; well as the empty rest argument, if any.  Each
+                      ;; optional argument will be bound within an inner
+                      ;; let.
                       (make-let src
                                 (append req rest)
                                 (append (list-head gensyms nreq)
                                         (last-pair gensyms))
                                 (append req-vals rest-vals)
-                                (make-let src
+                                (fold-right (lambda (var gensym val body)
-                                          opt
+                                              (make-let src
-                                          (list-head (drop gensyms nreq) nopt)
+                                                        (list var)
-                                          opt-vals
+                                                        (list gensym)
-                                          body)))))
+                                                        (list val)
+                                                        body))
+                                            body
+                                            opt
+                                            (list-head (drop gensyms nreq) nopt)
+                                            opt-vals)))))
 
               (cond
                ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))

module/scripts/compile.scm

@@ -1,6 +1,6 @@
 ;;; Compile --- Command-line Guile Scheme compiler  -*- coding: iso-8859-1 -*-
 
-;; Copyright 2005,2008,2009,2010,2011,2013 Free Software Foundation, Inc.
+;; Copyright 2005, 2008-2011, 2013, 2014 Free Software Foundation, Inc.
 ;;
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public License
@@ -176,6 +176,14 @@ Report bugs to <~A>.~%"
         (fail "`-o' option can only be specified "
               "when compiling a single file"))
 
+    ;; Install a SIGINT handler.  As a side effect, this gives unwind
+    ;; handlers an opportunity to run upon SIGINT; this includes that of
+    ;; 'call-with-output-file/atomic', called by 'compile-file', which
+    ;; removes the temporary output file.
+    (sigaction SIGINT
+      (lambda args
+        (fail "interrupted by the user")))
+
     (for-each (lambda (file)
                 (format #t "wrote `~A'\n"
                         (with-fluids ((*current-warning-prefix* ""))

module/srfi/srfi-43.scm

@@ -104,10 +104,10 @@
 
 The fundamental vector constructor.  Create a vector whose length is
 LENGTH and iterates across each index k from 0 up to LENGTH - 1,
-applying F at each iteration to the current index and current seeds,
+applying F at each iteration to the current index and current seeds, in
-in that order, to receive n + 1 values: first, the element to put in
+that order, to receive n + 1 values: the element to put in the kth slot
-the kth slot of the new vector and n new seeds for the next iteration.
+of the new vector, and n new seeds for the next iteration.  It is an
-It is an error for the number of seeds to vary between iterations."
+error for the number of seeds to vary between iterations."
     ((f len)
      (assert-procedure f 'vector-unfold)
      (assert-nonneg-exact-integer len 'vector-unfold)
@@ -154,10 +154,10 @@ It is an error for the number of seeds to vary between iterations."
 
 The fundamental vector constructor.  Create a vector whose length is
 LENGTH and iterates across each index k from LENGTH - 1 down to 0,
-applying F at each iteration to the current index and current seeds,
+applying F at each iteration to the current index and current seeds, in
-in that order, to receive n + 1 values: first, the element to put in
+that order, to receive n + 1 values: the element to put in the kth slot
-the kth slot of the new vector and n new seeds for the next iteration.
+of the new vector, and n new seeds for the next iteration.  It is an
-It is an error for the number of seeds to vary between iterations."
+error for the number of seeds to vary between iterations."
     ((f len)
      (assert-procedure f 'vector-unfold-right)
      (assert-nonneg-exact-integer len 'vector-unfold-right)
@@ -304,7 +304,7 @@ from the subsequent locations in VEC ..."
 
 Append each vector in LIST-OF-VECTORS.  Equivalent to:
   (apply vector-append LIST-OF-VECTORS)"
-  (assert-vectors vs 'vector-append)
+  (assert-vectors vs 'vector-concatenate)
   (%vector-concatenate vs))
 
 (define (vector-empty? vec)

module/system/base/target.scm

@@ -1,6 +1,6 @@
 ;;; Compilation targets
 
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 2014 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
@@ -70,6 +70,14 @@
              (endianness big))
             ((string-match "^arm.*el" cpu)
              (endianness little))
+            ((string-match "^arm.*eb" cpu)
+             (endianness big))
+            ((string-prefix? "arm" cpu)          ;ARMs are LE by default
+             (endianness little))
+            ((string-match "^aarch64.*be" cpu)
+             (endianness big))
+            ((string=? "aarch64" cpu)
+             (endianness little))
             (else
              (error "unknown CPU endianness" cpu)))))
 
@@ -93,7 +101,7 @@
           ((string-match "^x86_64-.*-gnux32" triplet) 4)  ; x32
 
           ((string-match "64$" cpu) 8)
-          ((string-match "64[lbe][lbe]$" cpu) 8)
+          ((string-match "64_?[lbe][lbe]$" cpu) 8)
           ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4)
           ((string-match "^arm.*" cpu) 4)
           (else (error "unknown CPU word size" cpu)))))

module/web/client.scm

@@ -1,6 +1,6 @@
 ;;; Web client
 
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 2014 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
@@ -92,8 +92,6 @@
 
           ;; Buffer input and output on this port.
           (setvbuf s _IOFBF)
-          ;; Enlarge the receive buffer.
-          (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
           ;; If we're using a proxy, make a note of that.
           (when http-proxy (set-http-proxy-port?! s #t))
           s)

test-suite/standalone/Makefile.am

@@ -93,6 +93,9 @@ check_SCRIPTS += test-language
 TESTS += test-language
 EXTRA_DIST += test-language.el test-language.js
 
+check_SCRIPTS += test-guild-compile
+TESTS += test-guild-compile
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}
@@ -190,7 +193,8 @@ TESTS += test-scm-c-read
 # test-scm-take-locale-symbol
 test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c
 test_scm_take_locale_symbol_CFLAGS = ${test_cflags}
-test_scm_take_locale_symbol_LDADD = $(LIBGUILE_LDADD)
+test_scm_take_locale_symbol_LDADD =			\
+  $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la
 check_PROGRAMS += test-scm-take-locale-symbol
 TESTS += test-scm-take-locale-symbol
 

test-suite/standalone/test-guild-compile

@@ -0,0 +1,42 @@
+#!/bin/sh
+#
+# This -*- sh -*- script tests whether 'guild compile' leaves traces
+# behind it upon SIGINT.
+
+source="t-guild-compile-$$"
+target="$source.go"
+
+trap 'rm -f "$source" "$target"' EXIT
+
+cat > "$source"<<EOF
+(eval-when (expand load eval)
+  (sleep 100))
+(define chbouib 42)
+EOF
+
+guild compile -o "$target" "$source" &
+pid="$!"
+
+# Send SIGINT.
+sleep 2 && kill -INT "$pid"
+
+# Wait for 'guild compile' to terminate.
+sleep 2
+
+# Check whether there are any leftovers.
+for file in "$target"*
+do
+    if test "$file" != "${target}*"
+    then
+	echo "error: 'guild compile' failed to remove '$file'" >&2
+	rm "$target"*
+	kill "$pid"
+	exit 1
+    fi
+done
+
+if test -f "$target"
+then
+    echo "error: '$target' produced" >&2
+    exit 1
+fi

test-suite/test-suite/lib.scm

@@ -63,6 +63,9 @@
  ;; Using a given locale
  with-locale with-locale* with-latin1-locale with-latin1-locale*
 
+ ;; The bit bucket.
+ %null-device
+
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
  make-count-reporter print-counts
@@ -562,6 +565,17 @@
     ((_ body ...)
      (with-latin1-locale* (lambda () body ...)))))
 
+(define %null-device
+  ;; On Windows (MinGW), /dev/null does not exist and we must instead
+  ;; use NUL.  Note that file system procedures automatically translate
+  ;; /dev/null, so this variable is only useful for shell snippets.
+
+  ;; Test for Windowsness by checking whether the current directory name
+  ;; starts with a drive letter.
+  (if (string-match "^[a-zA-Z]:[/\\]" (getcwd))
+      "NUL"
+      "/dev/null"))
+
 
 ;;;; REPORTERS
 ;;;;

test-suite/tests/c-api.test

@@ -1,7 +1,7 @@
 ;;;; c-api.test --- complementary test suite for the c-api     -*- scheme -*-
 ;;;; MDJ 990915 <djurfeldt@nada.kth.se>
 ;;;;
-;;;;   Copyright (C) 1999, 2006, 2012 Free Software Foundation, Inc.
+;;;;   Copyright (C) 1999, 2006, 2012, 2014 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
@@ -22,7 +22,8 @@
 (define srcdir (cdr (assq 'srcdir %guile-build-info)))
 
 (define (egrep string filename)
-  (zero? (system (string-append "egrep '" string "' " filename " >/dev/null"))))
+  (zero? (system (string-append "egrep '" string "' " filename
+                                " >" %null-device))))
 
 (define (seek-offset-test dirname)
   (let ((dir (opendir dirname)))

test-suite/tests/coding.test

@@ -20,7 +20,10 @@
   #:use-module (test-suite lib))
 
 (define (with-temp-file proc)
-  (let* ((name (string-copy "/tmp/coding-test.XXXXXX"))
+  (let* ((tmpdir (or (getenv "TMPDIR")
+                     (getenv "TEMP")
+                     "/tmp"))
+         (name (string-append tmpdir "/coding-test.XXXXXX"))
          (port (mkstemp! name)))
     (let ((res (with-throw-handler
                 #t

test-suite/tests/cross-compilation.test

@@ -1,6 +1,6 @@
 ;;;; Cross compilation   -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010-2014 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
@@ -79,6 +79,14 @@
                (endianness little) 8)
   (test-target "x86_64-unknown-linux-gnux32"      ; x32 ABI (Debian tuplet)
                (endianness little) 4)
+  (test-target "arm-unknown-linux-androideabi"
+               (endianness little) 4)
+  (test-target "armeb-unknown-linux-gnu"
+               (endianness big) 4)
+  (test-target "aarch64-linux-gnu"
+               (endianness little) 8)
+  (test-target "aarch64_be-linux-gnu"
+               (endianness big) 8)
 
   (pass-if-exception "unknown target" exception:miscellaneous-error
     (with-target "fcpu-unknown-gnu1.0"

test-suite/tests/i18n.test

@@ -1,7 +1,7 @@
 ;;;; i18n.test --- Exercise the i18n API.  -*- coding: utf-8; mode: scheme; -*-
 ;;;;
 ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012,
-;;;;   2013 Free Software Foundation, Inc.
+;;;;   2013, 2014 Free Software Foundation, Inc.
 ;;;; Ludovic Courtès
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -38,18 +38,18 @@
     (not (not (make-locale LC_ALL "C"))))
 
   (pass-if "make-locale (2 args, list)"
-    (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C"))))
+    (not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C"))))
 
   (pass-if "make-locale (3 args)"
     (not (not (make-locale (list LC_COLLATE) "C"
-                           (make-locale (list LC_MESSAGES) "C")))))
+                           (make-locale (list LC_NUMERIC) "C")))))
 
   (pass-if-exception "make-locale with unknown locale" exception:locale-error
     (make-locale LC_ALL "does-not-exist"))
 
   (pass-if "locale?"
     (and (locale? (make-locale (list LC_ALL) "C"))
-         (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C"
+         (locale? (make-locale (list LC_TIME LC_NUMERIC) "C"
                                (make-locale (list LC_CTYPE) "C")))))
 
   (pass-if "%global-locale"
@@ -81,20 +81,36 @@
                              (make-locale (list LC_COLLATE) "C")))))
 
 
+(define mingw?
+  (string-contains %host-type "-mingw32"))
+
 (define %french-locale-name
-  "fr_FR.ISO-8859-1")
+  (if mingw?
+      "fra_FRA.850"
+      "fr_FR.ISO-8859-1"))
+
+;; What we really want for the following locales is that they be Unicode
+;; capable, not necessarily UTF-8, which Windows does not provide.
 
 (define %french-utf8-locale-name
-  "fr_FR.UTF-8")
+  (if mingw?
+      "fra_FRA.1252"
+      "fr_FR.UTF-8"))
 
 (define %turkish-utf8-locale-name
-  "tr_TR.UTF-8")
+  (if mingw?
+      "tur_TRK.1254"
+      "tr_TR.UTF-8"))
 
 (define %german-utf8-locale-name
-  "de_DE.UTF-8")
+  (if mingw?
+      "deu_DEU.1252"
+      "de_DE.UTF-8"))
 
 (define %greek-utf8-locale-name
-  "el_GR.UTF-8")
+  (if mingw?
+      "grc_ELL.1253"
+      "el_GR.UTF-8"))
 
 (define %american-english-locale-name
   "en_US")
@@ -148,13 +164,14 @@
   (under-locale-or-unresolved %french-utf8-locale thunk))
 
 (define (under-turkish-utf8-locale-or-unresolved thunk)
-  ;; FreeBSD 8.2 and 9.1, Solaris 2.10, and Darwin 8.11.0 have a broken
+  ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, and MinGW have
-  ;; tr_TR locale where `i' is mapped to uppercase `I' instead of `İ',
+  ;; a broken tr_TR locale where `i' is mapped to uppercase `I'
-  ;; so disable tests on that platform.
+  ;; instead of `İ', so disable tests on that platform.
   (if (or (string-contains %host-type "freebsd8")
           (string-contains %host-type "freebsd9")
           (string-contains %host-type "solaris2.10")
-          (string-contains %host-type "darwin8"))
+          (string-contains %host-type "darwin8")
+          (string-contains %host-type "mingw32"))
       (throw 'unresolved)
       (under-locale-or-unresolved %turkish-utf8-locale thunk)))
 
@@ -192,7 +209,7 @@
         ;; strings.
         (dynamic-wind
           (lambda ()
-            (setlocale LC_ALL "fr_FR.UTF-8"))
+            (setlocale LC_ALL %french-utf8-locale-name))
           (lambda ()
             (string-locale-ci=? "œuf" "ŒUF"))
           (lambda ()

test-suite/tests/modules.test

@@ -1,6 +1,6 @@
 ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
 
-;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009-2011, 2014 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,8 +18,7 @@
 
 (define-module (test-suite test-modules)
   #:use-module (srfi srfi-1)
-  #:use-module ((ice-9 streams)  ;; for test purposes
+  #:use-module ((ice-9 streams) #:prefix s:)  ; for test purposes
-                #:renamer (symbol-prefix-proc 's:))
   #:use-module (test-suite lib))
 
 

test-suite/tests/peval.test

@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009-2014 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
@@ -409,6 +409,90 @@
      '(2 3))
     (const 7))
 
+  (pass-if-peval
+    ;; Higher order with optional argument (default uses earlier argument).
+    ;; <http://bugs.gnu.org/17634>
+    ((lambda* (f x #:optional (y (+ 3 (car x))))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 12))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments
+    ;; (default uses earlier optional argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 20))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments (one caller-supplied value,
+    ;; one default that uses earlier optional argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3)
+    (const 4))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments (caller-supplied values).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17)
+    (const 21))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments (one
+    ;; caller-supplied value, one default that uses earlier optional
+    ;; argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3)
+    (primcall list (const ()) (const 4)))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments
+    ;; (caller-supplied values for optionals).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17)
+    (primcall list (const ()) (const 21)))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments
+    ;; (caller-supplied values for optionals and rest).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17
+     8
+     3)
+    (let (r) (_) ((primcall list (const 8) (const 3)))
+         (primcall list (lexical r _) (const 21))))
+
   (pass-if-peval
     ;; Higher order with optional argument (caller-supplied value).
     ((lambda* (f x #:optional (y 0))

test-suite/tests/popen.test

@@ -1,6 +1,6 @@
 ;;;; popen.test --- exercise ice-9/popen.scm      -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2006, 2010, 2011, 2013 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2010, 2011, 2013, 2014 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
@@ -36,8 +36,7 @@
       restore-signals))
 
 (define-syntax-rule (if-supported body ...)
-  (if (provided? 'fork)
+  (begin body ...))
-      (begin body ...)))
 
 (if-supported
  (use-modules (ice-9 popen))
@@ -109,7 +108,9 @@
                       (with-input-from-port (car p2c)
                         (lambda ()
                           (open-input-pipe
-                           "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read REPLY")))))))
+                           (format #f "exec 1>~a; echo closed 1>&2; \
+exec 2>~a; read REPLY"
+                                   %null-device %null-device))))))))
        (close-port (cdr c2p)) ;; write side
        (let ((result (eof-object? (read-char port))))
          (display "hello!\n" (cdr p2c))

test-suite/tests/ports.test

@@ -53,12 +53,12 @@
   (let loop ((chars '()))
     (let ((char (read-char port)))
       (if (eof-object? char)
-	  (list->string (reverse! chars))
+          (list->string (reverse! chars))
-	  (loop (cons char chars))))))
+          (loop (cons char chars))))))
 
 (define (read-file filename)
   (let* ((port (open-input-file filename))
-	 (string (read-all port)))
+         (string (read-all port)))
     (close-port port)
     string))
 
@@ -95,7 +95,7 @@
 
 ;;; Write out an s-expression, and read it back.
 (let ((string '("From fairest creatures we desire increase,"
-		"That thereby beauty's rose might never die,"))
+                "That thereby beauty's rose might never die,"))
       (filename (test-file)))
   (let ((port (open-output-file filename)))
     (write string port)
@@ -103,10 +103,10 @@
   (let ((port (open-input-file filename)))
     (let ((in-string (read port)))
       (pass-if "file: write and read back list of strings" 
-	       (equal? string in-string)))
+               (equal? string in-string)))
     (close-port port))
   (delete-file filename))
-	  
+
 ;;; Write out a string, and read it back a character at a time.
 (let ((string "This is a test string\nwith no newline at the end")
       (filename (test-file)))
@@ -115,7 +115,7 @@
     (close-port port))
   (let ((in-string (read-file filename)))
     (pass-if "file: write and read back characters"
-	     (equal? string in-string)))
+             (equal? string in-string)))
   (delete-file filename))
 
 ;;; Buffered input/output port with seeking.
@@ -124,17 +124,17 @@
   (display "J'Accuse" port)
   (seek port -1 SEEK_CUR)
   (pass-if "file: r/w 1"
-	   (char=? (read-char port) #\e))
+           (char=? (read-char port) #\e))
   (pass-if "file: r/w 2"
-	   (eof-object? (read-char port)))
+           (eof-object? (read-char port)))
   (seek port -1 SEEK_CUR)
   (write-char #\x port)
   (seek port 7 SEEK_SET)
   (pass-if "file: r/w 3"
-	   (char=? (read-char port) #\x))
+           (char=? (read-char port) #\x))
   (seek port -2 SEEK_END)
   (pass-if "file: r/w 4"
-	   (char=? (read-char port) #\s))
+           (char=? (read-char port) #\s))
   (close-port port)
   (delete-file filename))
 
@@ -144,17 +144,17 @@
   (display "J'Accuse" port)
   (seek port -1 SEEK_CUR)
   (pass-if "file: ub r/w 1"
-	   (char=? (read-char port) #\e))
+           (char=? (read-char port) #\e))
   (pass-if "file: ub r/w 2"
-	   (eof-object? (read-char port)))
+           (eof-object? (read-char port)))
   (seek port -1 SEEK_CUR)
   (write-char #\x port)
   (seek port 7 SEEK_SET)
   (pass-if "file: ub r/w 3"
-	   (char=? (read-char port) #\x))
+           (char=? (read-char port) #\x))
   (seek port -2 SEEK_END)
   (pass-if "file: ub r/w 4"
-	   (char=? (read-char port) #\s))
+           (char=? (read-char port) #\s))
   (close-port port)
   (delete-file filename))
 
@@ -163,24 +163,24 @@
        (port (open-output-file filename)))
   (display "J'Accuse" port)
   (pass-if "file: out tell"
-	   (= (seek port 0 SEEK_CUR) 8))
+           (= (seek port 0 SEEK_CUR) 8))
   (seek port -1 SEEK_CUR)
   (write-char #\x port)
   (close-port port)
   (let ((iport (open-input-file filename)))
     (pass-if "file: in tell 0"
-	     (= (seek iport 0 SEEK_CUR) 0))
+             (= (seek iport 0 SEEK_CUR) 0))
     (read-char iport)
     (pass-if "file: in tell 1"
-	     (= (seek iport 0 SEEK_CUR) 1))
+             (= (seek iport 0 SEEK_CUR) 1))
     (unread-char #\z iport)
     (pass-if "file: in tell 0 after unread"
-	     (= (seek iport 0 SEEK_CUR) 0))
+             (= (seek iport 0 SEEK_CUR) 0))
     (pass-if "file: unread char still there"
-	     (char=? (read-char iport) #\z))
+             (char=? (read-char iport) #\z))
     (seek iport 7 SEEK_SET)
     (pass-if "file: in last char"
-	     (char=? (read-char iport) #\x))
+             (char=? (read-char iport) #\x))
     (close-port iport))
   (delete-file filename))
 
@@ -188,20 +188,20 @@
 (let* ((filename (test-file))
        (port (open-output-file filename)))
   (display (string #\nul (integer->char 255) (integer->char 128)
-		   #\nul) port)
+                   #\nul) port)
   (close-port port)
   (let* ((port (open-input-file filename))
-	 (line (read-line port)))
+         (line (read-line port)))
     (pass-if "file: read back NUL 1"
-	     (char=? (string-ref line 0) #\nul))
+             (char=? (string-ref line 0) #\nul))
     (pass-if "file: read back 255"
-	     (char=? (string-ref line 1) (integer->char 255)))
+             (char=? (string-ref line 1) (integer->char 255)))
     (pass-if "file: read back 128"
-	     (char=? (string-ref line 2) (integer->char 128)))
+             (char=? (string-ref line 2) (integer->char 128)))
     (pass-if "file: read back NUL 2"
-	     (char=? (string-ref line 3) #\nul))
+             (char=? (string-ref line 3) #\nul))
     (pass-if "file: EOF"
-	     (eof-object? (read-char port)))
+             (eof-object? (read-char port)))
     (close-port port))
   (delete-file filename))
 
@@ -211,11 +211,11 @@
        (test-string "one line more or less"))
   (write-line test-string port)
   (let* ((in-port (open-input-file filename))
-	 (line (read-line in-port)))
+         (line (read-line in-port)))
     (close-port in-port)
     (close-port port)
     (pass-if "file: line buffering"
-	     (string=? line test-string)))
+             (string=? line test-string)))
   (delete-file filename))
 
 ;;; read-line should use the port encoding (not the locale encoding).
@@ -573,19 +573,19 @@
 
 ;;; ungetting characters and strings.
 (with-input-from-string "walk on the moon\nmoon"
-			(lambda ()
+                        (lambda ()
-			  (read-char)
+                          (read-char)
-			  (unread-char #\a (current-input-port))
+                          (unread-char #\a (current-input-port))
-			  (pass-if "unread-char"
+                          (pass-if "unread-char"
-				   (char=? (read-char) #\a))
+                                   (char=? (read-char) #\a))
-			  (read-line)
+                          (read-line)
-			  (let ((replacenoid "chicken enchilada"))
+                          (let ((replacenoid "chicken enchilada"))
-			    (unread-char #\newline (current-input-port))
+                            (unread-char #\newline (current-input-port))
-			    (unread-string replacenoid (current-input-port))
+                            (unread-string replacenoid (current-input-port))
-			    (pass-if "unread-string"
+                            (pass-if "unread-string"
-				     (string=? (read-line) replacenoid)))
+                                     (string=? (read-line) replacenoid)))
-			  (pass-if "unread residue"
+                          (pass-if "unread residue"
-				   (string=? (read-line) "moon"))))
+                                   (string=? (read-line) "moon"))))
 
 ;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
 ;;; the reading end.  try to read a byte: should get EAGAIN or
@@ -594,13 +594,13 @@
        (r (car p)))
   (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
   (pass-if "non-blocking-I/O"
-	   (catch 'system-error
+           (catch 'system-error
-		  (lambda () (read-char r) #f)
+                  (lambda () (read-char r) #f)
-		  (lambda (key . args)
+                  (lambda (key . args)
-		    (and (eq? key 'system-error)
+                    (and (eq? key 'system-error)
-			 (let ((errno (car (list-ref args 3))))
+                         (let ((errno (car (list-ref args 3))))
-			   (or (= errno EAGAIN)
+                           (or (= errno EAGAIN)
-			       (= errno EWOULDBLOCK))))))))
+                               (= errno EWOULDBLOCK))))))))
 
 
 ;;;; Pipe (popen) ports.
@@ -610,7 +610,7 @@
        (in-string (read-all pipe)))
   (close-pipe pipe)
   (pass-if "pipe: read"
-	   (equal? in-string "Howdy there, partner!\n")))
+           (equal? in-string "Howdy there, partner!\n")))
 
 ;;; Run a command, send some output to it, and see if it worked.
 (let* ((filename (test-file))
@@ -620,9 +620,33 @@
   (close-pipe pipe)
   (let ((in-string (read-file filename)))
     (pass-if "pipe: write"
-	     (equal? in-string "Mommy, why does everybody have a bomb?\n")))
+             (equal? in-string "Mommy, why does everybody have a bomb?\n")))
   (delete-file filename))
 
+(pass-if-equal "pipe, fdopen, and _IOLBF"
+    "foo\nbar\n"
+  (let ((in+out (pipe))
+        (pid    (primitive-fork)))
+    (if (zero? pid)
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close-port (car in+out))
+            (let ((port (cdr in+out)))
+              (setvbuf port _IOLBF )
+              ;; Strings containing '\n' or should be flushed; others
+              ;; should be kept in PORT's buffer.
+              (display "foo\n" port)
+              (display "bar\n" port)
+              (display "this will be kept in PORT's buffer" port)))
+          (lambda ()
+            (primitive-_exit 0)))
+        (begin
+          (close-port (cdr in+out))
+          (let ((str (read-all (car in+out))))
+            (waitpid pid)
+            str)))))
+
 
 ;;;; Void ports.  These are so trivial we don't test them.
 
@@ -633,70 +657,70 @@
 
   ;; Write text to a string port.
   (let* ((string "Howdy there, partner!")
-	 (in-string (call-with-output-string
+         (in-string (call-with-output-string
-		     (lambda (port)
+                     (lambda (port)
-		       (display string port)
+                       (display string port)
-		       (newline port)))))
+                       (newline port)))))
     (pass-if "display text"
-	     (equal? in-string (string-append string "\n"))))
+             (equal? in-string (string-append string "\n"))))
-		   
+
   ;; Write an s-expression to a string port.
   (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
-	 (in-sexpr 
+         (in-sexpr
-	  (call-with-input-string (call-with-output-string
+          (call-with-input-string (call-with-output-string
-				   (lambda (port)
+                                   (lambda (port)
-				     (write sexpr port)))
+                                     (write sexpr port)))
-				  read)))
+                                  read)))
     (pass-if "write/read sexpr"
-	     (equal? in-sexpr sexpr)))
+             (equal? in-sexpr sexpr)))
 
   ;; seeking and unreading from an input string.
   (let ((text "that text didn't look random to me"))
     (call-with-input-string text
-			    (lambda (p)
+                            (lambda (p)
-			      (pass-if "input tell 0"
+                              (pass-if "input tell 0"
-				       (= (seek p 0 SEEK_CUR) 0))
+                                       (= (seek p 0 SEEK_CUR) 0))
-			      (read-char p)
+                              (read-char p)
-			      (pass-if "input tell 1"
+                              (pass-if "input tell 1"
-				       (= (seek p 0 SEEK_CUR) 1))
+                                       (= (seek p 0 SEEK_CUR) 1))
-			      (unread-char #\x p)
+                              (unread-char #\x p)
-			      (pass-if "input tell back to 0"
+                              (pass-if "input tell back to 0"
-				       (= (seek p 0 SEEK_CUR) 0))
+                                       (= (seek p 0 SEEK_CUR) 0))
-			      (pass-if "input ungetted char"
+                              (pass-if "input ungetted char"
-				       (char=? (read-char p) #\x))
+                                       (char=? (read-char p) #\x))
-			      (seek p 0 SEEK_END)
+                              (seek p 0 SEEK_END)
-			      (pass-if "input seek to end"
+                              (pass-if "input seek to end"
-				       (= (seek p 0 SEEK_CUR)
+                                       (= (seek p 0 SEEK_CUR)
-					  (string-length text)))
+                                          (string-length text)))
-			      (unread-char #\x p)
+                              (unread-char #\x p)
-			      (pass-if "input seek to beginning"
+                              (pass-if "input seek to beginning"
-				       (= (seek p 0 SEEK_SET) 0))
+                                       (= (seek p 0 SEEK_SET) 0))
-			      (pass-if "input reread first char"
+                              (pass-if "input reread first char"
-				       (char=? (read-char p)
+                                       (char=? (read-char p)
-					       (string-ref text 0))))))
+                                               (string-ref text 0))))))
 
   ;; seeking an output string.
   (let* ((text (string-copy "123456789"))
-	 (len (string-length text))
+         (len (string-length text))
-	 (result (call-with-output-string
+         (result (call-with-output-string
-		  (lambda (p)
+                  (lambda (p)
-		    (pass-if "output tell 0"
+                    (pass-if "output tell 0"
-			     (= (seek p 0 SEEK_CUR) 0))
+                             (= (seek p 0 SEEK_CUR) 0))
-		    (display text p)
+                    (display text p)
-		    (pass-if "output tell end"
+                    (pass-if "output tell end"
-			     (= (seek p 0 SEEK_CUR) len))
+                             (= (seek p 0 SEEK_CUR) len))
-		    (pass-if "output seek to beginning"
+                    (pass-if "output seek to beginning"
-			     (= (seek p 0 SEEK_SET) 0))
+                             (= (seek p 0 SEEK_SET) 0))
-		    (write-char #\a p)
+                    (write-char #\a p)
-		    (seek p -1 SEEK_END)
+                    (seek p -1 SEEK_END)
-		    (pass-if "output seek to last char"
+                    (pass-if "output seek to last char"
-			     (= (seek p 0 SEEK_CUR)
+                             (= (seek p 0 SEEK_CUR)
-				(- len 1)))
+                                (- len 1)))
-		    (write-char #\b p)))))
+                    (write-char #\b p)))))
     (string-set! text 0 #\a)
     (string-set! text (- len 1) #\b)
     (pass-if "output check"
-	     (string=? text result)))
+             (string=? text result)))
 
   (pass-if "%default-port-encoding is ignored"
     (let ((str "ĉu bone?"))
@@ -936,17 +960,17 @@
   ;; Return a list of input ports that all return the same text.
   ;; We map tests over this list.
   (define (input-port-list text)
-    
+
     ;; Create a text file some of the ports will use.
     (let ((out-port (open-output-file port-loop-temp)))
       (display text out-port)
       (close-port out-port))
 
     (list (open-input-file port-loop-temp)
-	  (open-input-pipe (string-append "cat " port-loop-temp))
+          (open-input-pipe (string-append "cat " port-loop-temp))
-	  (call-with-input-string text (lambda (x) x))
+          (call-with-input-string text (lambda (x) x))
-	  ;; We don't test soft ports at the moment.
+          ;; We don't test soft ports at the moment.
-	  ))
+          ))
 
   (define port-list-names '("file" "pipe" "string"))
 
@@ -954,55 +978,55 @@
   (define (test-line-counter text second-line final-column)
     (with-test-prefix "line counter"
       (let ((ports (input-port-list text)))
-	(for-each
+        (for-each
-	 (lambda (port port-name)
+         (lambda (port port-name)
-	   (with-test-prefix port-name
+           (with-test-prefix port-name
-	     (pass-if "at beginning of input"
+             (pass-if "at beginning of input"
-		      (= (port-line port) 0))
+                      (= (port-line port) 0))
-	     (pass-if "read first character"
+             (pass-if "read first character"
-		      (eqv? (read-char port) #\x))
+                      (eqv? (read-char port) #\x))
-	     (pass-if "after reading one character"
+             (pass-if "after reading one character"
-		      (= (port-line port) 0))
+                      (= (port-line port) 0))
-	     (pass-if "read first newline"
+             (pass-if "read first newline"
-		      (eqv? (read-char port) #\newline))
+                      (eqv? (read-char port) #\newline))
-	     (pass-if "after reading first newline char"
+             (pass-if "after reading first newline char"
-		      (= (port-line port) 1))
+                      (= (port-line port) 1))
-	     (pass-if "second line read correctly"
+             (pass-if "second line read correctly"
-		      (equal? (read-line port) second-line))
+                      (equal? (read-line port) second-line))
-	     (pass-if "read-line increments line number"
+             (pass-if "read-line increments line number"
-		      (= (port-line port) 2))
+                      (= (port-line port) 2))
-	     (pass-if "read-line returns EOF"
+             (pass-if "read-line returns EOF"
-		      (let loop ((i 0))
+                      (let loop ((i 0))
-			(cond
+                        (cond
-			 ((eof-object? (read-line port)) #t)
+                         ((eof-object? (read-line port)) #t)
-			 ((> i 20) #f)
+                         ((> i 20) #f)
-			 (else (loop (+ i 1))))))
+                         (else (loop (+ i 1))))))
-	     (pass-if "line count is 5 at EOF"
+             (pass-if "line count is 5 at EOF"
-		      (= (port-line port) 5))
+                      (= (port-line port) 5))
-	     (pass-if "column is correct at EOF"
+             (pass-if "column is correct at EOF"
-		      (= (port-column port) final-column))))
+                      (= (port-column port) final-column))))
-	 ports port-list-names)
+         ports port-list-names)
-	(for-each close-port ports)
+        (for-each close-port ports)
-	(delete-file port-loop-temp))))
+        (delete-file port-loop-temp))))
 
   (with-test-prefix "newline"
     (test-line-counter
      (string-append "x\n"
-		    "He who receives an idea from me, receives instruction\n"
+                    "He who receives an idea from me, receives instruction\n"
-		    "himself without lessening mine; as he who lights his\n"
+                    "himself without lessening mine; as he who lights his\n"
-		    "taper at mine, receives light without darkening me.\n"
+                    "taper at mine, receives light without darkening me.\n"
-		    "  --- Thomas Jefferson\n")
+                    "  --- Thomas Jefferson\n")
      "He who receives an idea from me, receives instruction"
      0))
 
   (with-test-prefix "no newline"
     (test-line-counter
      (string-append "x\n"
-		    "He who receives an idea from me, receives instruction\n"
+                    "He who receives an idea from me, receives instruction\n"
-		    "himself without lessening mine; as he who lights his\n"
+                    "himself without lessening mine; as he who lights his\n"
-		    "taper at mine, receives light without darkening me.\n"
+                    "taper at mine, receives light without darkening me.\n"
-		    "  --- Thomas Jefferson\n"
+                    "  --- Thomas Jefferson\n"
-		    "no newline here")
+                    "no newline here")
      "He who receives an idea from me, receives instruction"
      15)))
 
@@ -1012,28 +1036,28 @@
   (with-test-prefix "port-line and port-column for output ports"
     (let ((port (open-output-string)))
       (pass-if "at beginning of input"
-	       (and (= (port-line port) 0)
+               (and (= (port-line port) 0)
-		    (= (port-column port) 0)))
+                    (= (port-column port) 0)))
       (write-char #\x port)
       (pass-if "after writing one character"
-	       (and (= (port-line port) 0)
+               (and (= (port-line port) 0)
-		    (= (port-column port) 1)))
+                    (= (port-column port) 1)))
       (write-char #\newline port)
       (pass-if "after writing first newline char"
-	       (and (= (port-line port) 1)
+               (and (= (port-line port) 1)
-		    (= (port-column port) 0)))
+                    (= (port-column port) 0)))
       (display text port)
       (pass-if "line count is 5 at end"
-	       (= (port-line port) 5))
+               (= (port-line port) 5))
       (pass-if "column is correct at end"
-	       (= (port-column port) final-column)))))
+               (= (port-column port) final-column)))))
 
 (test-output-line-counter
  (string-append "He who receives an idea from me, receives instruction\n"
-		"himself without lessening mine; as he who lights his\n"
+                "himself without lessening mine; as he who lights his\n"
-		"taper at mine, receives light without darkening me.\n"
+                "taper at mine, receives light without darkening me.\n"
-		"  --- Thomas Jefferson\n"
+                "  --- Thomas Jefferson\n"
-		"no newline here")
+                "no newline here")
  15)
 
 (with-test-prefix "port-column"
@@ -1042,115 +1066,115 @@
 
     (pass-if "x"
       (let ((port (open-output-string)))
-	(display "x" port)
+        (display "x" port)
-	(= 1 (port-column port))))
+        (= 1 (port-column port))))
 
     (pass-if "\\a"
       (let ((port (open-output-string)))
-	(display "\a" port)
+        (display "\a" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\a"
       (let ((port (open-output-string)))
-	(display "x\a" port)
+        (display "x\a" port)
-	(= 1 (port-column port))))
+        (= 1 (port-column port))))
 
     (pass-if "\\x08 backspace"
       (let ((port (open-output-string)))
-	(display "\x08" port)
+        (display "\x08" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\x08 backspace"
       (let ((port (open-output-string)))
-	(display "x\x08" port)
+        (display "x\x08" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "\\n"
       (let ((port (open-output-string)))
-	(display "\n" port)
+        (display "\n" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\n"
       (let ((port (open-output-string)))
-	(display "x\n" port)
+        (display "x\n" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "\\r"
       (let ((port (open-output-string)))
-	(display "\r" port)
+        (display "\r" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\r"
       (let ((port (open-output-string)))
-	(display "x\r" port)
+        (display "x\r" port)
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "\\t"
       (let ((port (open-output-string)))
-	(display "\t" port)
+        (display "\t" port)
-	(= 8 (port-column port))))
+        (= 8 (port-column port))))
 
     (pass-if "x\\t"
       (let ((port (open-output-string)))
-	(display "x\t" port)
+        (display "x\t" port)
-	(= 8 (port-column port)))))
+        (= 8 (port-column port)))))
 
   (with-test-prefix "input"
 
     (pass-if "x"
       (let ((port (open-input-string "x")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 1 (port-column port))))
+        (= 1 (port-column port))))
 
     (pass-if "\\a"
       (let ((port (open-input-string "\a")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\a"
       (let ((port (open-input-string "x\a")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 1 (port-column port))))
+        (= 1 (port-column port))))
 
     (pass-if "\\x08 backspace"
       (let ((port (open-input-string "\x08")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\x08 backspace"
       (let ((port (open-input-string "x\x08")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "\\n"
       (let ((port (open-input-string "\n")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\n"
       (let ((port (open-input-string "x\n")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "\\r"
       (let ((port (open-input-string "\r")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "x\\r"
       (let ((port (open-input-string "x\r")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 0 (port-column port))))
+        (= 0 (port-column port))))
 
     (pass-if "\\t"
       (let ((port (open-input-string "\t")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 8 (port-column port))))
+        (= 8 (port-column port))))
 
     (pass-if "x\\t"
       (let ((port (open-input-string "x\t")))
-	(while (not (eof-object? (read-char port))))
+        (while (not (eof-object? (read-char port))))
-	(= 8 (port-column port))))))
+        (= 8 (port-column port))))))
 
 (with-test-prefix "port-line"
 
@@ -1159,7 +1183,7 @@
   ;; systems
   (pass-if "set most-positive-fixnum/2"
     (let ((n    (quotient most-positive-fixnum 2))
-	  (port (open-output-string)))
+          (port (open-output-string)))
       (set-port-line! port n)
       (eqv? n (port-line port)))))
 
@@ -1205,7 +1229,7 @@
       (gc)
       ;; but they're still in the port table, so this sees them
       (port-for-each (lambda (port)
-		       (set! lst (cons port lst))))
+                       (set! lst (cons port lst))))
       ;; this forces completion of the sweeping
       (gc) (gc) (gc)
       ;; and (if the bug is present) the cells accumulated in LST are now
@@ -1215,9 +1239,10 @@
 (with-test-prefix
  "fdes->port"
  (pass-if "fdes->ports finds port"
-	  (let ((port (open-file (test-file) "w")))
+          (let* ((port (open-file (test-file) "w"))
-
+                 (res (not (not (memq port (fdes->ports (port->fdes port)))))))
-	    (not (not (memq port (fdes->ports (port->fdes port))))))))
+            (close-port port)
+            res)))
 
 ;;;
 ;;; seek
@@ -1229,30 +1254,36 @@
 
     (pass-if "SEEK_CUR"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "abcde" port)))
+          (display "abcde" port)))
       (let ((port (open-file (test-file) "r")))
-	(read-char port)
+        (read-char port)
-	(seek port 2 SEEK_CUR)
+        (seek port 2 SEEK_CUR)
-	(eqv? #\d (read-char port))))
+        (let ((res (eqv? #\d (read-char port))))
+          (close-port port)
+          res)))
 
     (pass-if "SEEK_SET"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "abcde" port)))
+          (display "abcde" port)))
       (let ((port (open-file (test-file) "r")))
-	(read-char port)
+        (read-char port)
-	(seek port 3 SEEK_SET)
+        (seek port 3 SEEK_SET)
-	(eqv? #\d (read-char port))))
+        (let ((res (eqv? #\d (read-char port))))
+          (close-port port)
+          res)))
 
     (pass-if "SEEK_END"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "abcde" port)))
+          (display "abcde" port)))
       (let ((port (open-file (test-file) "r")))
-	(read-char port)
+        (read-char port)
-	(seek port -2 SEEK_END)
+        (seek port -2 SEEK_END)
-	(eqv? #\d (read-char port))))))
+        (let ((res (eqv? #\d (read-char port))))
+          (close-port port)
+          res)))))
 
 ;;;
 ;;; truncate-file
@@ -1270,61 +1301,63 @@
 
     (pass-if-exception "flonum length" exception:wrong-type-arg
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (truncate-file (test-file) 1.0))
 
     (pass-if "shorten"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (truncate-file (test-file) 1)
       (eqv? 1 (stat:size (stat (test-file)))))
 
     (pass-if-exception "shorten to current pos" exception:miscellaneous-error
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (truncate-file (test-file))))
 
   (with-test-prefix "file descriptor"
 
     (pass-if "shorten"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (let ((fd (open-fdes (test-file) O_RDWR)))
-	(truncate-file fd 1)
+        (truncate-file fd 1)
-	(close-fdes fd))
+        (close-fdes fd))
       (eqv? 1 (stat:size (stat (test-file)))))
 
     (pass-if "shorten to current pos"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (let ((fd (open-fdes (test-file) O_RDWR)))
-	(seek fd 1 SEEK_SET)
+        (seek fd 1 SEEK_SET)
-	(truncate-file fd)
+        (truncate-file fd)
-	(close-fdes fd))
+        (close-fdes fd))
       (eqv? 1 (stat:size (stat (test-file))))))
 
   (with-test-prefix "file port"
 
     (pass-if "shorten"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (let ((port (open-file (test-file) "r+")))
-	(truncate-file port 1))
+        (truncate-file port 1)
+        (close-port port))
       (eqv? 1 (stat:size (stat (test-file)))))
 
     (pass-if "shorten to current pos"
       (call-with-output-file (test-file)
-	(lambda (port)
+        (lambda (port)
-	  (display "hello" port)))
+          (display "hello" port)))
       (let ((port (open-file (test-file) "r+")))
-	(read-char port)
+        (read-char port)
-	(truncate-file port))
+        (truncate-file port)
+        (close-port port))
       (eqv? 1 (stat:size (stat (test-file)))))))
 
 
@@ -1332,17 +1365,17 @@
 
 (with-test-prefix "read-delimited!"
   (let ((c (make-string 20 #\!)))
-    (call-with-input-string 
+    (call-with-input-string
      "defdef\nghighi\n"
      (lambda (port)
-       
+
        (read-delimited! "\n" c port 'concat)
        (pass-if "read-delimited! reads a first line"
-		(string=? c "defdef\n!!!!!!!!!!!!!"))
+                (string=? c "defdef\n!!!!!!!!!!!!!"))
 
        (read-delimited! "\n" c port 'concat 3)
        (pass-if "read-delimited! reads a first line"
-		(string=? c "defghighi\n!!!!!!!!!!"))))))
+                (string=? c "defghighi\n!!!!!!!!!!"))))))
 
 
 ;;;; char-ready?
@@ -1351,7 +1384,7 @@
  "howdy"
  (lambda (port)
    (pass-if "char-ready? returns true on string port"
-	    (char-ready? port))))
+            (char-ready? port))))
 
 ;;; This segfaults on some versions of Guile.  We really should run
 ;;; the tests in a subprocess...
@@ -1363,7 +1396,7 @@
        port
      (lambda ()
        (pass-if "char-ready? returns true on string port as default port"
-		(char-ready?))))))
+                (char-ready?))))))
 
 
 ;;;; pending-eof behavior
@@ -1454,15 +1487,15 @@
 
 (with-test-prefix "closing current-input-port"
   (for-each (lambda (procedure name)
-	      (with-input-from-port
+              (with-input-from-port
-		  (call-with-input-string "foo" (lambda (p) p))
+                  (call-with-input-string "foo" (lambda (p) p))
-		(lambda ()
+                (lambda ()
-		  (close-port (current-input-port))
+                  (close-port (current-input-port))
-		  (pass-if-exception name
+                  (pass-if-exception name
-		    exception:wrong-type-arg
+                    exception:wrong-type-arg
-		    (procedure)))))
+                    (procedure)))))
-	    (list read read-char read-line)
+            (list read read-char read-line)
-	    '("read" "read-char" "read-line")))
+            '("read" "read-char" "read-line")))
 
 
 
@@ -1824,6 +1857,17 @@
     (with-fluids ((%file-port-name-canonicalization 'absolute))
       (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
 
+(with-test-prefix "file name separators"
+
+  (pass-if "no backslash separators in Windows file names"
+    ;; In Guile 2.0.11 and earlier, %load-path on Windows could
+    ;; include file names with backslashes, and `getcwd' on Windows
+    ;; would always return a directory name with backslashes.
+    (or (not (file-name-separator? #\\))
+        (with-load-path (cons (getcwd) %load-path)
+          (not (string-index (%search-load-path (basename (test-file)))
+                             #\\))))))
+
 (delete-file (test-file))
 
 ;;; Local Variables:

test-suite/tests/posix.test

@@ -70,9 +70,10 @@
 
   (pass-if "filename string modified"
     (let* ((template "T-XXXXXX")
-	   (str      (string-copy template))
+           (str      (string-copy template))
-	   (port     (mkstemp! str))
+           (port     (mkstemp! str))
-	   (result   (not (string=? str template))))
+           (result   (not (string=? str template))))
+      (close-port port)
       (delete-file str)
       result)))
 

test-suite/tests/r6rs-files.test

@@ -24,7 +24,9 @@
 
 (with-test-prefix "delete-file"
   (pass-if "delete-file deletes file"
-    (let ((filename (port-filename (mkstemp! "T-XXXXXX"))))
+    (let* ((port (mkstemp! "T-XXXXXX"))
+           (filename (port-filename port)))
+      (close-port port)
       (delete-file filename)
       (not (file-exists? filename))))
 
@@ -32,9 +34,9 @@
     (let ((success #f))
       (call/cc
        (lambda (continuation)
-	 (with-exception-handler
+         (with-exception-handler
-	  (lambda (condition)
+          (lambda (condition)
-	    (set! success (i/o-filename-error? condition))
+            (set! success (i/o-filename-error? condition))
-	    (continuation))
+            (continuation))
-	  (lambda () (delete-file "")))))
+          (lambda () (delete-file "")))))
       success)))

test-suite/tests/r6rs-ports.test

@@ -137,6 +137,26 @@
       (close-port port)
       (get-bytevector-n port 3)))
 
+  (let ((expected (make-bytevector 20 (char->integer #\a))))
+    (pass-if-equal "http://bugs.gnu.org/17466"
+        ;; <http://bugs.gnu.org/17466> is about a memory corruption
+        ;; whereas bytevector shrunk in 'get-bytevector-n' would keep
+        ;; referring to the previous (larger) bytevector.
+        expected
+      (let loop ((count 50))
+        (if (zero? count)
+            expected
+            (let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa"
+                        (lambda (port)
+                          (get-bytevector-n port 4096)))))
+              ;; Cause the 4 KiB bytevector initially created by
+              ;; 'get-bytevector-n' to be reclaimed.
+              (make-bytevector 4096)
+
+              (if (equal? bv expected)
+                  (loop (- count 1))
+                  bv))))))
+
   (pass-if "get-bytevector-n! [short]"
     (let* ((port (open-input-string "GNU Guile"))
            (bv   (make-bytevector 4))

test-suite/tests/rdelim.test

@@ -1,7 +1,7 @@
 ;;;; rdelim.test --- Delimited I/O.      -*- mode: scheme; coding: utf-8; -*-
 ;;;; Ludovic Courtès <ludo@gnu.org>
 ;;;;
-;;;; 	Copyright (C) 2011, 2013 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2011, 2013, 2014 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
@@ -207,7 +207,13 @@
     (let* ((s (string-concatenate (make-list 20 "hello, world!")))
            (p (open-input-string s)))
       (and (string=? (read-string p) s)
-           (string=? (read-string p) "")))))
+           (string=? (read-string p) ""))))
+
+  (pass-if-equal "longer than 100 chars, with limit"
+      "hello, world!"
+    (let* ((s (string-concatenate (make-list 20 "hello, world!")))
+           (p (open-input-string s)))
+      (read-string p 13))))
 
 (with-test-prefix "read-string!"
 

test-suite/tests/srfi-1.test

@@ -1,6 +1,6 @@
 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright 2003-2006, 2008-2011, 2014 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
@@ -1329,6 +1329,10 @@
     (length+))
   (pass-if-exception "too many args" exception:wrong-num-args
     (length+ 123 456))
+  (pass-if-exception "not a pair" exception:wrong-type-arg
+    (length+ 'x))
+  (pass-if-exception "improper list" exception:wrong-type-arg
+    (length+ '(x y . z)))
   (pass-if (= 0 (length+ '())))
   (pass-if (= 1 (length+ '(x))))
   (pass-if (= 2 (length+ '(x y))))

test-suite/tests/threads.test

@@ -1,6 +1,7 @@
 ;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
+;;;;   2014 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
@@ -36,6 +37,11 @@
     (equal? '(a b c) '(a b c))
     a))
 
+(define (require-cancel-thread)
+  ;; Skip the test when 'cancel-thread' is unavailable.
+  (unless (defined? 'cancel-thread)
+    (throw 'unresolved)))
+
 (if (provided? 'threads)
     (begin
 
@@ -277,6 +283,7 @@
       (with-test-prefix "join-thread"
 
 	(pass-if "timed joining fails if timeout exceeded"
+          (require-cancel-thread)
 	  (let* ((m (make-mutex))
 		 (c (make-condition-variable))
 		 (t (begin-thread (begin (lock-mutex m)
@@ -286,6 +293,7 @@
 	    (not r)))
 
         (pass-if "join-thread returns timeoutval on timeout"
+          (require-cancel-thread)
           (let* ((m (make-mutex))
 		 (c (make-condition-variable))
 		 (t (begin-thread (begin (lock-mutex m)
@@ -335,6 +343,7 @@
       (with-test-prefix "cancel-thread"
 
         (pass-if "cancel succeeds"
+          (require-cancel-thread)
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (begin (lock-mutex m) 'foo))))
@@ -343,6 +352,7 @@
 	      #t)))
 
 	(pass-if "handler result passed to join"
+          (require-cancel-thread)
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (lock-mutex m))))
@@ -351,6 +361,7 @@
 	      (eq? (join-thread t) 'foo))))
 
 	(pass-if "can cancel self"
+          (require-cancel-thread)
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (begin

test-suite/tests/tree-il.test

@@ -1,8 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
+;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
-;;;;   2014 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
@@ -1132,6 +1131,50 @@
               (number? (string-contains (car w)
                                         "expected 3, got 2")))))
 
+     (pass-if "~p"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(((@ (ice-9 format) format) #f "thing~p" 2))
+                          #:opts %opts-w-format
+                          #:to 'cps)))))
+
+     (pass-if "~p, too few arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "~p")
+                            #:opts %opts-w-format
+                            #:to 'cps)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 1, got 0")))))
+
+     (pass-if "~:p"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(((@ (ice-9 format) format) #f "~d thing~:p" 2))
+                          #:opts %opts-w-format
+                          #:to 'cps)))))
+
+     (pass-if "~:@p, too many arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "~d pupp~:@p" 5 5)
+                            #:opts %opts-w-format
+                            #:to 'cps)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 1, got 2")))))
+
+     (pass-if "~:@p, too few arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "pupp~:@p")
+                            #:opts %opts-w-format
+                            #:to 'cps)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 1, got 0")))))
+
      (pass-if "~?"
        (null? (call-with-warnings
                (lambda ()
@@ -1202,8 +1245,7 @@
        (let ((w (call-with-warnings
                  (lambda ()
                    (let ((in (open-input-string
-                              "(use-modules ((ice-9 format)
+                              "(use-modules ((ice-9 format) #:prefix i9-))
-                                 #:renamer (symbol-prefix-proc 'i9-)))
                                (i9-format #t \"yo! ~A\" 1 2)")))
                      (read-and-compile in
                                        #:opts %opts-w-format