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

Conflicts:
	module/ice-9/psyntax-pp.scm
	module/language/tree-il/compile-glil.scm

NEWS

@@ -166,6 +166,7 @@ ports)' documentation from the R6RS documentation.  Thanks Andreas!
 ** Fix multithreaded access to internal hash tables
 ** Emit a 1-based line number in error messages
 ** Fix define-module ordering
+** Fix several POSIX functions to use the locale encoding
     
 
 Changes in 2.0.1 (since 2.0.0):

acinclude.m4

@@ -529,8 +529,14 @@ AC_DEFUN([gl_CLOCK_TIME],
   AC_SUBST([LIB_CLOCK_GETTIME])
   gl_saved_libs=$LIBS
     AC_SEARCH_LIBS([clock_gettime], [rt posix4],
-                   [test "$ac_cv_search_clock_gettime" = "none required" ||
+                   [if test "$ac_cv_search_clock_gettime" = "none required"; then
-                    LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
+                      AC_SEARCH_LIBS([clock_getcpuclockid], [rt posix4],
-    AC_CHECK_FUNCS([clock_gettime clock_settime])
+                                     [test "$ac_cv_search_clock_getcpuclockid" = "none required" \
+                                      || LIB_CLOCK_GETTIME=$ac_cv_search_clock_getcpuclockid],
+                                     [LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
+                    else
+                      LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime
+                    fi])
+    AC_CHECK_FUNCS([clock_gettime clock_settime clock_getcpuclockid])
   LIBS=$gl_saved_libs
 ])

configure.ac

@@ -67,7 +67,8 @@ AC_PROG_LN_S
 dnl Gnulib.
 gl_INIT
 dnl FIXME: remove me and the acinclude.m4 code when clock-gettime is
-dnl LGPL-compatible and can be imported normally.
+dnl fixed for clock_getcpuclockid and can be imported normally from
+dnl gnulib.
 gl_CLOCK_TIME
 
 AC_PROG_CC_C89
@@ -716,7 +717,6 @@ case $host in
       [Define if you have the <winsock2.h> header file.])])
     AC_CHECK_LIB(ws2_32, main)
     AC_LIBOBJ([win32-uname])
-    AC_LIBOBJ([win32-dirent])
     if test "$enable_networking" = yes ; then
       AC_LIBOBJ([win32-socket])
     fi
@@ -1145,19 +1145,19 @@ AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos trunc)
 # use <math.h> so doesn't detect on macro-only systems like HP-UX.
 #
 AC_MSG_CHECKING([for isinf])
-AC_LINK_IFELSE(AC_LANG_SOURCE(
+AC_LINK_IFELSE([AC_LANG_SOURCE(
 [[#include <math.h>
 volatile double x = 0.0;
-int main () { return (isinf(x) != 0); }]]),
+int main () { return (isinf(x) != 0); }]])],
   [AC_MSG_RESULT([yes])
    AC_DEFINE([HAVE_ISINF], 1,
              [Define to 1 if you have the `isinf' macro or function.])],
   [AC_MSG_RESULT([no])])
 AC_MSG_CHECKING([for isnan])
-AC_LINK_IFELSE(AC_LANG_SOURCE(
+AC_LINK_IFELSE([AC_LANG_SOURCE([[
-[[#include <math.h>
+#include <math.h>
 volatile double x = 0.0;
-int main () { return (isnan(x) != 0); }]]),
+int main () { return (isnan(x) != 0); }]])],
   [AC_MSG_RESULT([yes])
    AC_DEFINE([HAVE_ISNAN], 1,
              [Define to 1 if you have the `isnan' macro or function.])],
@@ -1438,8 +1438,8 @@ case "$with_threads" in
 
     AC_CACHE_CHECK([whether PTHREAD_ONCE_INIT needs braces],
       guile_cv_need_braces_on_pthread_once_init,
-      [AC_COMPILE_IFELSE([#include <pthread.h>
+      [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <pthread.h>
-         pthread_once_t foo = PTHREAD_ONCE_INIT;],
+         pthread_once_t foo = PTHREAD_ONCE_INIT;]])],
         [guile_cv_need_braces_on_pthread_once_init=no],
         [guile_cv_need_braces_on_pthread_once_init=yes])])
     if test "$guile_cv_need_braces_on_pthread_once_init" = yes; then
@@ -1450,8 +1450,8 @@ case "$with_threads" in
     # 6.5.30m with GCC 3.3.
     AC_CACHE_CHECK([whether PTHREAD_MUTEX_INITIALIZER needs braces],
       guile_cv_need_braces_on_pthread_mutex_initializer,
-      [AC_COMPILE_IFELSE([#include <pthread.h>
+      [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <pthread.h>
-         pthread_mutex_t foo = PTHREAD_MUTEX_INITIALIZER;],
+         pthread_mutex_t foo = PTHREAD_MUTEX_INITIALIZER;]])],
         [guile_cv_need_braces_on_pthread_mutex_initializer=no],
         [guile_cv_need_braces_on_pthread_mutex_initializer=yes])])
     if test "$guile_cv_need_braces_on_pthread_mutex_initializer" = yes; then

lib/Makefile.am

@@ -9,7 +9,7 @@
 # the same distribution terms as the rest of that program.
 #
 # Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom send sendto setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
+# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom rename send sendto setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
 
 AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
 
@@ -277,6 +277,14 @@ EXTRA_libgnu_la_SOURCES += connect.c
 
 ## end   gnulib module connect
 
+## begin gnulib module dirname-lgpl
+
+libgnu_la_SOURCES += dirname-lgpl.c basename-lgpl.c stripslash.c
+
+EXTRA_DIST += dirname.h
+
+## end   gnulib module dirname-lgpl
+
 ## begin gnulib module dosname
 
 
@@ -1111,6 +1119,24 @@ EXTRA_libgnu_la_SOURCES += recvfrom.c
 
 ## end   gnulib module recvfrom
 
+## begin gnulib module rename
+
+
+EXTRA_DIST += rename.c
+
+EXTRA_libgnu_la_SOURCES += rename.c
+
+## end   gnulib module rename
+
+## begin gnulib module rmdir
+
+
+EXTRA_DIST += rmdir.c
+
+EXTRA_libgnu_la_SOURCES += rmdir.c
+
+## end   gnulib module rmdir
+
 ## begin gnulib module safe-read
 
 libgnu_la_SOURCES += safe-read.c
@@ -1129,6 +1155,13 @@ EXTRA_libgnu_la_SOURCES += safe-read.c
 
 ## end   gnulib module safe-write
 
+## begin gnulib module same-inode
+
+
+EXTRA_DIST += same-inode.h
+
+## end   gnulib module same-inode
+
 ## begin gnulib module send
 
 

lib/basename-lgpl.c

@@ -0,0 +1,75 @@
+/* basename.c -- return the last element in a file name
+
+   Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2011 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 as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+
+#include "dirname.h"
+
+#include <string.h>
+
+/* Return the address of the last file name component of NAME.  If
+   NAME has no relative file name components because it is a file
+   system root, return the empty string.  */
+
+char *
+last_component (char const *name)
+{
+  char const *base = name + FILE_SYSTEM_PREFIX_LEN (name);
+  char const *p;
+  bool saw_slash = false;
+
+  while (ISSLASH (*base))
+    base++;
+
+  for (p = base; *p; p++)
+    {
+      if (ISSLASH (*p))
+        saw_slash = true;
+      else if (saw_slash)
+        {
+          base = p;
+          saw_slash = false;
+        }
+    }
+
+  return (char *) base;
+}
+
+/* Return the length of the basename NAME.  Typically NAME is the
+   value returned by base_name or last_component.  Act like strlen
+   (NAME), except omit all trailing slashes.  */
+
+size_t
+base_len (char const *name)
+{
+  size_t len;
+  size_t prefix_len = FILE_SYSTEM_PREFIX_LEN (name);
+
+  for (len = strlen (name);  1 < len && ISSLASH (name[len - 1]);  len--)
+    continue;
+
+  if (DOUBLE_SLASH_IS_DISTINCT_ROOT && len == 1
+      && ISSLASH (name[0]) && ISSLASH (name[1]) && ! name[2])
+    return 2;
+
+  if (FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE && prefix_len
+      && len == prefix_len && ISSLASH (name[prefix_len]))
+    return prefix_len + 1;
+
+  return len;
+}

lib/dirname-lgpl.c

@@ -0,0 +1,86 @@
+/* dirname.c -- return all but the last element in a file name
+
+   Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2011 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 as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+
+#include "dirname.h"
+
+#include <stdlib.h>
+#include <string.h>
+
+/* Return the length of the prefix of FILE that will be used by
+   dir_name.  If FILE is in the working directory, this returns zero
+   even though `dir_name (FILE)' will return ".".  Works properly even
+   if there are trailing slashes (by effectively ignoring them).  */
+
+size_t
+dir_len (char const *file)
+{
+  size_t prefix_length = FILE_SYSTEM_PREFIX_LEN (file);
+  size_t length;
+
+  /* Advance prefix_length beyond important leading slashes.  */
+  prefix_length += (prefix_length != 0
+                    ? (FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE
+                       && ISSLASH (file[prefix_length]))
+                    : (ISSLASH (file[0])
+                       ? ((DOUBLE_SLASH_IS_DISTINCT_ROOT
+                           && ISSLASH (file[1]) && ! ISSLASH (file[2])
+                           ? 2 : 1))
+                       : 0));
+
+  /* Strip the basename and any redundant slashes before it.  */
+  for (length = last_component (file) - file;
+       prefix_length < length; length--)
+    if (! ISSLASH (file[length - 1]))
+      break;
+  return length;
+}
+
+
+/* In general, we can't use the builtin `dirname' function if available,
+   since it has different meanings in different environments.
+   In some environments the builtin `dirname' modifies its argument.
+
+   Return the leading directories part of FILE, allocated with malloc.
+   Works properly even if there are trailing slashes (by effectively
+   ignoring them).  Return NULL on failure.
+
+   If lstat (FILE) would succeed, then { chdir (dir_name (FILE));
+   lstat (base_name (FILE)); } will access the same file.  Likewise,
+   if the sequence { chdir (dir_name (FILE));
+   rename (base_name (FILE), "foo"); } succeeds, you have renamed FILE
+   to "foo" in the same directory FILE was in.  */
+
+char *
+mdir_name (char const *file)
+{
+  size_t length = dir_len (file);
+  bool append_dot = (length == 0
+                     || (FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE
+                         && length == FILE_SYSTEM_PREFIX_LEN (file)
+                         && file[2] != '\0' && ! ISSLASH (file[2])));
+  char *dir = malloc (length + append_dot + 1);
+  if (!dir)
+    return NULL;
+  memcpy (dir, file, length);
+  if (append_dot)
+    dir[length++] = '.';
+  dir[length] = '\0';
+  return dir;
+}

lib/dirname.h

@@ -0,0 +1,46 @@
+/*  Take file names apart into directory and base names.
+
+    Copyright (C) 1998, 2001, 2003-2006, 2009-2011 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 as published by
+    the Free Software Foundation; either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#ifndef DIRNAME_H_
+# define DIRNAME_H_ 1
+
+# include <stdbool.h>
+# include <stddef.h>
+# include "dosname.h"
+
+# ifndef DIRECTORY_SEPARATOR
+#  define DIRECTORY_SEPARATOR '/'
+# endif
+
+# ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT
+#  define DOUBLE_SLASH_IS_DISTINCT_ROOT 0
+# endif
+
+# if GNULIB_DIRNAME
+char *base_name (char const *file);
+char *dir_name (char const *file);
+# endif
+
+char *mdir_name (char const *file);
+size_t base_len (char const *file);
+size_t dir_len (char const *file);
+char *last_component (char const *file);
+
+bool strip_trailing_slashes (char *file);
+
+#endif /* not DIRNAME_H_ */

lib/rename.c

@@ -0,0 +1,473 @@
+/* Work around rename bugs in some systems.
+
+   Copyright (C) 2001-2003, 2005-2006, 2009-2011 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 as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+/* Written by Volker Borchert, Eric Blake.  */
+
+#include <config.h>
+
+#include <stdio.h>
+
+#undef rename
+
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+/* The mingw rename has problems with trailing slashes; it also
+   requires use of native Windows calls to allow atomic renames over
+   existing files.  */
+
+# include <errno.h>
+# include <stdbool.h>
+# include <stdlib.h>
+# include <sys/stat.h>
+# include <unistd.h>
+
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+
+# include "dirname.h"
+
+/* Rename the file SRC to DST.  This replacement is necessary on
+   Windows, on which the system rename function will not replace
+   an existing DST.  */
+int
+rpl_rename (char const *src, char const *dst)
+{
+  int error;
+  size_t src_len = strlen (src);
+  size_t dst_len = strlen (dst);
+  char *src_base = last_component (src);
+  char *dst_base = last_component (dst);
+  bool src_slash;
+  bool dst_slash;
+  bool dst_exists;
+  struct stat src_st;
+  struct stat dst_st;
+
+  /* Filter out dot as last component.  */
+  if (!src_len || !dst_len)
+    {
+      errno = ENOENT;
+      return -1;
+    }
+  if (*src_base == '.')
+    {
+      size_t len = base_len (src_base);
+      if (len == 1 || (len == 2 && src_base[1] == '.'))
+        {
+          errno = EINVAL;
+          return -1;
+        }
+    }
+  if (*dst_base == '.')
+    {
+      size_t len = base_len (dst_base);
+      if (len == 1 || (len == 2 && dst_base[1] == '.'))
+        {
+          errno = EINVAL;
+          return -1;
+        }
+    }
+
+  /* Presence of a trailing slash requires directory semantics.  If
+     the source does not exist, or if the destination cannot be turned
+     into a directory, give up now.  Otherwise, strip trailing slashes
+     before calling rename.  There are no symlinks on mingw, so stat
+     works instead of lstat.  */
+  src_slash = ISSLASH (src[src_len - 1]);
+  dst_slash = ISSLASH (dst[dst_len - 1]);
+  if (stat (src, &src_st))
+    return -1;
+  if (stat (dst, &dst_st))
+    {
+      if (errno != ENOENT || (!S_ISDIR (src_st.st_mode) && dst_slash))
+        return -1;
+      dst_exists = false;
+    }
+  else
+    {
+      if (S_ISDIR (dst_st.st_mode) != S_ISDIR (src_st.st_mode))
+        {
+          errno = S_ISDIR (dst_st.st_mode) ? EISDIR : ENOTDIR;
+          return -1;
+        }
+      dst_exists = true;
+    }
+
+  /* There are no symlinks, so if a file existed with a trailing
+     slash, it must be a directory, and we don't have to worry about
+     stripping strip trailing slash.  However, mingw refuses to
+     replace an existing empty directory, so we have to help it out.
+     And canonicalize_file_name is not yet ported to mingw; however,
+     for directories, getcwd works as a viable alternative.  Ensure
+     that we can get back to where we started before using it; later
+     attempts to return are fatal.  Note that we can end up losing a
+     directory if rename then fails, but it was empty, so not much
+     damage was done.  */
+  if (dst_exists && S_ISDIR (dst_st.st_mode))
+    {
+      char *cwd = getcwd (NULL, 0);
+      char *src_temp;
+      char *dst_temp;
+      if (!cwd || chdir (cwd))
+        return -1;
+      if (IS_ABSOLUTE_FILE_NAME (src))
+        {
+          dst_temp = chdir (dst) ? NULL : getcwd (NULL, 0);
+          src_temp = chdir (src) ? NULL : getcwd (NULL, 0);
+        }
+      else
+        {
+          src_temp = chdir (src) ? NULL : getcwd (NULL, 0);
+          if (!IS_ABSOLUTE_FILE_NAME (dst) && chdir (cwd))
+            abort ();
+          dst_temp = chdir (dst) ? NULL : getcwd (NULL, 0);
+        }
+      if (chdir (cwd))
+        abort ();
+      free (cwd);
+      if (!src_temp || !dst_temp)
+        {
+          free (src_temp);
+          free (dst_temp);
+          errno = ENOMEM;
+          return -1;
+        }
+      src_len = strlen (src_temp);
+      if (strncmp (src_temp, dst_temp, src_len) == 0
+          && (ISSLASH (dst_temp[src_len]) || dst_temp[src_len] == '\0'))
+        {
+          error = dst_temp[src_len];
+          free (src_temp);
+          free (dst_temp);
+          if (error)
+            {
+              errno = EINVAL;
+              return -1;
+            }
+          return 0;
+        }
+      if (rmdir (dst))
+        {
+          error = errno;
+          free (src_temp);
+          free (dst_temp);
+          errno = error;
+          return -1;
+        }
+      free (src_temp);
+      free (dst_temp);
+    }
+
+  /* MoveFileEx works if SRC is a directory without any flags, but
+     fails with MOVEFILE_REPLACE_EXISTING, so try without flags first.
+     Thankfully, MoveFileEx handles hard links correctly, even though
+     rename() does not.  */
+  if (MoveFileEx (src, dst, 0))
+    return 0;
+
+  /* Retry with MOVEFILE_REPLACE_EXISTING if the move failed
+     due to the destination already existing.  */
+  error = GetLastError ();
+  if (error == ERROR_FILE_EXISTS || error == ERROR_ALREADY_EXISTS)
+    {
+      if (MoveFileEx (src, dst, MOVEFILE_REPLACE_EXISTING))
+        return 0;
+
+      error = GetLastError ();
+    }
+
+  switch (error)
+    {
+    case ERROR_FILE_NOT_FOUND:
+    case ERROR_PATH_NOT_FOUND:
+    case ERROR_BAD_PATHNAME:
+    case ERROR_DIRECTORY:
+      errno = ENOENT;
+      break;
+
+    case ERROR_ACCESS_DENIED:
+    case ERROR_SHARING_VIOLATION:
+      errno = EACCES;
+      break;
+
+    case ERROR_OUTOFMEMORY:
+      errno = ENOMEM;
+      break;
+
+    case ERROR_CURRENT_DIRECTORY:
+      errno = EBUSY;
+      break;
+
+    case ERROR_NOT_SAME_DEVICE:
+      errno = EXDEV;
+      break;
+
+    case ERROR_WRITE_PROTECT:
+      errno = EROFS;
+      break;
+
+    case ERROR_WRITE_FAULT:
+    case ERROR_READ_FAULT:
+    case ERROR_GEN_FAILURE:
+      errno = EIO;
+      break;
+
+    case ERROR_HANDLE_DISK_FULL:
+    case ERROR_DISK_FULL:
+    case ERROR_DISK_TOO_FRAGMENTED:
+      errno = ENOSPC;
+      break;
+
+    case ERROR_FILE_EXISTS:
+    case ERROR_ALREADY_EXISTS:
+      errno = EEXIST;
+      break;
+
+    case ERROR_BUFFER_OVERFLOW:
+    case ERROR_FILENAME_EXCED_RANGE:
+      errno = ENAMETOOLONG;
+      break;
+
+    case ERROR_INVALID_NAME:
+    case ERROR_DELETE_PENDING:
+      errno = EPERM;        /* ? */
+      break;
+
+# ifndef ERROR_FILE_TOO_LARGE
+/* This value is documented but not defined in all versions of windows.h.  */
+#  define ERROR_FILE_TOO_LARGE 223
+# endif
+    case ERROR_FILE_TOO_LARGE:
+      errno = EFBIG;
+      break;
+
+    default:
+      errno = EINVAL;
+      break;
+    }
+
+  return -1;
+}
+
+#else /* ! W32 platform */
+
+# include <errno.h>
+# include <stdio.h>
+# include <stdlib.h>
+# include <string.h>
+# include <sys/stat.h>
+# include <unistd.h>
+
+# include "dirname.h"
+# include "same-inode.h"
+
+/* Rename the file SRC to DST, fixing any trailing slash bugs.  */
+
+int
+rpl_rename (char const *src, char const *dst)
+{
+  size_t src_len = strlen (src);
+  size_t dst_len = strlen (dst);
+  char *src_temp = (char *) src;
+  char *dst_temp = (char *) dst;
+  bool src_slash;
+  bool dst_slash;
+  bool dst_exists;
+  int ret_val = -1;
+  int rename_errno = ENOTDIR;
+  struct stat src_st;
+  struct stat dst_st;
+
+  if (!src_len || !dst_len)
+    return rename (src, dst); /* Let strace see the ENOENT failure.  */
+
+# if RENAME_DEST_EXISTS_BUG
+  {
+    char *src_base = last_component (src);
+    char *dst_base = last_component (dst);
+    if (*src_base == '.')
+      {
+        size_t len = base_len (src_base);
+        if (len == 1 || (len == 2 && src_base[1] == '.'))
+          {
+            errno = EINVAL;
+            return -1;
+          }
+      }
+    if (*dst_base == '.')
+      {
+        size_t len = base_len (dst_base);
+        if (len == 1 || (len == 2 && dst_base[1] == '.'))
+          {
+            errno = EINVAL;
+            return -1;
+          }
+      }
+  }
+# endif /* RENAME_DEST_EXISTS_BUG */
+
+  src_slash = src[src_len - 1] == '/';
+  dst_slash = dst[dst_len - 1] == '/';
+
+# if !RENAME_HARD_LINK_BUG && !RENAME_DEST_EXISTS_BUG
+  /* If there are no trailing slashes, then trust the native
+     implementation unless we also suspect issues with hard link
+     detection or file/directory conflicts.  */
+  if (!src_slash && !dst_slash)
+    return rename (src, dst);
+# endif /* !RENAME_HARD_LINK_BUG && !RENAME_DEST_EXISTS_BUG */
+
+  /* Presence of a trailing slash requires directory semantics.  If
+     the source does not exist, or if the destination cannot be turned
+     into a directory, give up now.  Otherwise, strip trailing slashes
+     before calling rename.  */
+  if (lstat (src, &src_st))
+    return -1;
+  if (lstat (dst, &dst_st))
+    {
+      if (errno != ENOENT || (!S_ISDIR (src_st.st_mode) && dst_slash))
+        return -1;
+      dst_exists = false;
+    }
+  else
+    {
+      if (S_ISDIR (dst_st.st_mode) != S_ISDIR (src_st.st_mode))
+        {
+          errno = S_ISDIR (dst_st.st_mode) ? EISDIR : ENOTDIR;
+          return -1;
+        }
+# if RENAME_HARD_LINK_BUG
+      if (SAME_INODE (src_st, dst_st))
+        return 0;
+# endif /* RENAME_HARD_LINK_BUG */
+      dst_exists = true;
+    }
+
+# if (RENAME_TRAILING_SLASH_SOURCE_BUG || RENAME_DEST_EXISTS_BUG        \
+      || RENAME_HARD_LINK_BUG)
+  /* If the only bug was that a trailing slash was allowed on a
+     non-existing file destination, as in Solaris 10, then we've
+     already covered that situation.  But if there is any problem with
+     a trailing slash on an existing source or destination, as in
+     Solaris 9, or if a directory can overwrite a symlink, as on
+     Cygwin 1.5, or if directories cannot be created with trailing
+     slash, as on NetBSD 1.6, then we must strip the offending slash
+     and check that we have not encountered a symlink instead of a
+     directory.
+
+     Stripping a trailing slash interferes with POSIX semantics, where
+     rename behavior on a symlink with a trailing slash operates on
+     the corresponding target directory.  We prefer the GNU semantics
+     of rejecting any use of a symlink with trailing slash, but do not
+     enforce them, since Solaris 10 is able to obey POSIX semantics
+     and there might be clients expecting it, as counter-intuitive as
+     those semantics are.
+
+     Technically, we could also follow the POSIX behavior by chasing a
+     readlink trail, but that is harder to implement.  */
+  if (src_slash)
+    {
+      src_temp = strdup (src);
+      if (!src_temp)
+        {
+          /* Rather than rely on strdup-posix, we set errno ourselves.  */
+          rename_errno = ENOMEM;
+          goto out;
+        }
+      strip_trailing_slashes (src_temp);
+      if (lstat (src_temp, &src_st))
+        {
+          rename_errno = errno;
+          goto out;
+        }
+      if (S_ISLNK (src_st.st_mode))
+        goto out;
+    }
+  if (dst_slash)
+    {
+      dst_temp = strdup (dst);
+      if (!dst_temp)
+        {
+          rename_errno = ENOMEM;
+          goto out;
+        }
+      strip_trailing_slashes (dst_temp);
+      if (lstat (dst_temp, &dst_st))
+        {
+          if (errno != ENOENT)
+            {
+              rename_errno = errno;
+              goto out;
+            }
+        }
+      else if (S_ISLNK (dst_st.st_mode))
+        goto out;
+    }
+# endif /* RENAME_TRAILING_SLASH_SOURCE_BUG || RENAME_DEST_EXISTS_BUG
+           || RENAME_HARD_LINK_BUG */
+
+# if RENAME_DEST_EXISTS_BUG
+  /* Cygwin 1.5 sometimes behaves oddly when moving a non-empty
+     directory on top of an empty one (the old directory name can
+     reappear if the new directory tree is removed).  Work around this
+     by removing the target first, but don't remove the target if it
+     is a subdirectory of the source.  Note that we can end up losing
+     a directory if rename then fails, but it was empty, so not much
+     damage was done.  */
+  if (dst_exists && S_ISDIR (dst_st.st_mode))
+    {
+      if (src_st.st_dev != dst_st.st_dev)
+        {
+          rename_errno = EXDEV;
+          goto out;
+        }
+      if (src_temp != src)
+        free (src_temp);
+      src_temp = canonicalize_file_name (src);
+      if (dst_temp != dst)
+        free (dst_temp);
+      dst_temp = canonicalize_file_name (dst);
+      if (!src_temp || !dst_temp)
+        {
+          rename_errno = ENOMEM;
+          goto out;
+        }
+      src_len = strlen (src_temp);
+      if (strncmp (src_temp, dst_temp, src_len) == 0
+          && dst_temp[src_len] == '/')
+        {
+          rename_errno = EINVAL;
+          goto out;
+        }
+      if (rmdir (dst))
+        {
+          rename_errno = errno;
+          goto out;
+        }
+    }
+# endif /* RENAME_DEST_EXISTS_BUG */
+
+  ret_val = rename (src_temp, dst_temp);
+  rename_errno = errno;
+ out:
+  if (src_temp != src)
+    free (src_temp);
+  if (dst_temp != dst)
+    free (dst_temp);
+  errno = rename_errno;
+  return ret_val;
+}
+#endif /* ! W32 platform */

lib/rmdir.c

@@ -0,0 +1,53 @@
+/* Work around rmdir bugs.
+
+   Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2011 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 as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+
+#include <unistd.h>
+
+#include <errno.h>
+#include <string.h>
+
+#include "dosname.h"
+
+#undef rmdir
+
+/* Remove directory DIR.
+   Return 0 if successful, -1 if not.  */
+
+int
+rpl_rmdir (char const *dir)
+{
+  /* Work around cygwin 1.5.x bug where rmdir("dir/./") succeeds.  */
+  size_t len = strlen (dir);
+  int result;
+  while (len && ISSLASH (dir[len - 1]))
+    len--;
+  if (len && dir[len - 1] == '.' && (1 == len || ISSLASH (dir[len - 2])))
+    {
+      errno = EINVAL;
+      return -1;
+    }
+  result = rmdir (dir);
+  /* Work around mingw bug, where rmdir("file/") fails with EINVAL
+     instead of ENOTDIR.  We've already filtered out trailing ., the
+     only reason allowed by POSIX for EINVAL.  */
+  if (result == -1 && errno == EINVAL)
+    errno = ENOTDIR;
+  return result;
+}

lib/same-inode.h

@@ -0,0 +1,25 @@
+/* Determine whether two stat buffers refer to the same file.
+
+   Copyright (C) 2006, 2009-2011 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 as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#ifndef SAME_INODE_H
+# define SAME_INODE_H 1
+
+# define SAME_INODE(Stat_buf_1, Stat_buf_2) \
+   ((Stat_buf_1).st_ino == (Stat_buf_2).st_ino \
+    && (Stat_buf_1).st_dev == (Stat_buf_2).st_dev)
+
+#endif

lib/stripslash.c

@@ -0,0 +1,45 @@
+/* stripslash.c -- remove redundant trailing slashes from a file name
+
+   Copyright (C) 1990, 2001, 2003-2006, 2009-2011 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 as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+
+#include "dirname.h"
+
+/* Remove trailing slashes from FILE.  Return true if a trailing slash
+   was removed.  This is useful when using file name completion from a
+   shell that adds a "/" after directory names (such as tcsh and
+   bash), because on symlinks to directories, several system calls
+   have different semantics according to whether a trailing slash is
+   present.  */
+
+bool
+strip_trailing_slashes (char *file)
+{
+  char *base = last_component (file);
+  char *base_lim;
+  bool had_slash;
+
+  /* last_component returns "" for file system roots, but we need to turn
+     `///' into `/'.  */
+  if (! *base)
+    base = file;
+  base_lim = base + base_len (base);
+  had_slash = (*base_lim != '\0');
+  *base_lim = '\0';
+  return had_slash;
+}

libguile/Makefile.am

@@ -433,7 +433,7 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h		\
     dynl.c regex-posix.c			\
     posix.c net_db.c socket.c			\
     debug-malloc.c mkstemp.c			\
-    win32-uname.c win32-dirent.c win32-socket.c	\
+    win32-uname.c win32-socket.c		\
     locale-categories.h
 
 ## delete guile-snarf.awk from the installation bindir, in case it's
@@ -450,7 +450,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c		\
                  ieee-754.h					\
                  srfi-14.i.c					\
                  quicksort.i.c                                  \
-                 win32-uname.h win32-dirent.h win32-socket.h	\
+                 win32-uname.h win32-socket.h			\
 		 private-gc.h private-options.h
 
 # vm instructions

libguile/filesys.c

@@ -97,11 +97,7 @@
 #endif
 
 
-#if defined (__MINGW32__) || defined (_MSC_VER) || defined (__BORLANDC__)
+#if HAVE_DIRENT_H
-# include "win32-dirent.h"
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-/* The following bits are per AC_HEADER_DIRENT doco in the autoconf manual */
-#elif HAVE_DIRENT_H
 # include <dirent.h>
 # define NAMLEN(dirent) strlen((dirent)->d_name)
 #else

libguile/load.c

@@ -293,6 +293,12 @@ scm_init_load_path ()
       snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR,
                 pwd->pw_dir);
 #endif /* HAVE_GETPWENT */
+#ifdef __MINGW32__
+    else if ((e = getenv ("LOCALAPPDATA")))
+      snprintf (cachedir, sizeof (cachedir), "%s/.cache/" FALLBACK_DIR, e);
+    else if ((e = getenv ("APPDATA")))
+      snprintf (cachedir, sizeof (cachedir), "%s/.cache/" FALLBACK_DIR, e);
+#endif /* __MINGW32__ */
     else
       cachedir[0] = 0;
 
@@ -730,14 +736,27 @@ static SCM
 auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
 {
   SCM source = PTR2SCM (data);
+  SCM oport, lines;
+
+  oport = scm_open_output_string ();
+  scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
+
   scm_puts (";;; WARNING: compilation of ", scm_current_error_port ());
   scm_display (source, scm_current_error_port ());
   scm_puts (" failed:\n", scm_current_error_port ());
-  scm_puts (";;; key ", scm_current_error_port ());
+
-  scm_write (tag, scm_current_error_port ());
+  lines = scm_string_split (scm_get_output_string (oport),
-  scm_puts (", throw args ", scm_current_error_port ());
+                            SCM_MAKE_CHAR ('\n'));
-  scm_write (throw_args, scm_current_error_port ());
+  for (; scm_is_pair (lines); lines = scm_cdr (lines))
-  scm_newline (scm_current_error_port ());
+    if (scm_c_string_length (scm_car (lines)))
+      {
+        scm_puts (";;; ", scm_current_error_port ());
+        scm_display (scm_car (lines), scm_current_error_port ());
+        scm_newline (scm_current_error_port ());
+      }
+
+  scm_close_port (oport);
+
   return SCM_BOOL_F;
 }
 

libguile/strings.c

@@ -2052,8 +2052,9 @@ SCM_DEFINE (scm_string_normalize_nfkd, "string-normalize-nfkd", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-/* converts C scm_array of strings to SCM scm_list of strings. */
+/* converts C scm_array of strings to SCM scm_list of strings.
-/* If argc < 0, a null terminated scm_array is assumed. */
+   If argc < 0, a null terminated scm_array is assumed.
+   The current locale encoding is assumed */
 SCM
 scm_makfromstrs (int argc, char **argv)
 {
@@ -2067,37 +2068,43 @@ scm_makfromstrs (int argc, char **argv)
 }
 
 /* Return a newly allocated array of char pointers to each of the strings
-   in args, with a terminating NULL pointer.  */
+   in args, with a terminating NULL pointer.  The strings are encoded using
+   the current locale. */
 
 char **
 scm_i_allocate_string_pointers (SCM list)
 #define FUNC_NAME "scm_i_allocate_string_pointers"
 {
   char **result;
-  int len = scm_ilength (list);
+  int list_len = scm_ilength (list);
   int i;
 
-  if (len < 0)
+  if (list_len < 0)
     scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
 
-  result = scm_gc_malloc ((len + 1) * sizeof (char *),
+  result = scm_gc_malloc ((list_len + 1) * sizeof (char *),
 			  "string pointers");
-  result[len] = NULL;
+  result[list_len] = NULL;
 
-  /* The list might be have been modified in another thread, so
+  /* The list might have been modified in another thread, so
      we check LIST before each access.
    */
-  for (i = 0; i < len && scm_is_pair (list); i++)
+  for (i = 0; i < list_len && scm_is_pair (list); i++)
     {
-      SCM str;
+      SCM str = SCM_CAR (list);
-      size_t len;
+      size_t len;  /* String length in bytes */
+      char *c_str = scm_to_locale_stringn (str, &len);
 
-      str = SCM_CAR (list);
+      /* OPTIMIZE-ME: Right now, scm_to_locale_stringn always uses
-      len = scm_c_string_length (str);
+	 scm_malloc to allocate the returned string, which must be
+	 explicitly deallocated.  This forces us to copy the string a
+	 second time into a new buffer.  Ideally there would be variants
+	 of scm_to_*_stringn that can return garbage-collected buffers. */
 
-      result[i] = scm_gc_malloc_pointerless (len + 1, "string pointers");
+      result[i] = scm_gc_malloc_pointerless (len + 1, "string");
-      memcpy (result[i], scm_i_string_chars (str), len);
+      memcpy (result[i], c_str, len);
       result[i][len] = '\0';
+      free (c_str);
 
       list = SCM_CDR (list);
     }

libguile/win32-dirent.c

@@ -1,133 +0,0 @@
-/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
- * 
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/__scm.h"
-
-#include <windows.h>
-#include <stdio.h>
-#include <string.h>
-
-#include "win32-dirent.h"
-
-DIR *
-opendir (const char * name)
-{
-  DIR *dir;
-  HANDLE hnd;
-  char *file;
-  WIN32_FIND_DATA find;
-
-  if (!name || !*name) 
-    return NULL;
-  file = malloc (strlen (name) + 3);
-  strcpy (file, name);
-  if (file[strlen (name) - 1] != '/' && file[strlen (name) - 1] != '\\')
-    strcat (file, "/*");
-  else
-    strcat (file, "*");
-  
-  if ((hnd = FindFirstFile (file, &find)) == INVALID_HANDLE_VALUE)
-    {
-      free (file);
-      return NULL;
-    }
-
-  dir = malloc (sizeof (DIR));
-  dir->mask = file;
-  dir->fd = (int) hnd;
-  dir->data = malloc (sizeof (WIN32_FIND_DATA));
-  dir->allocation = sizeof (WIN32_FIND_DATA);
-  dir->size = dir->allocation;
-  dir->filepos = 0;
-  memcpy (dir->data, &find, sizeof (WIN32_FIND_DATA));
-  return dir;
-}
-
-struct dirent *
-readdir (DIR * dir)
-{
-  static struct dirent entry;
-  WIN32_FIND_DATA *find;
-
-  entry.d_ino = 0;
-  entry.d_type = 0;
-  find = (WIN32_FIND_DATA *) dir->data;
-
-  if (dir->filepos)
-    {
-      if (!FindNextFile ((HANDLE) dir->fd, find))
-	return NULL;
-    }
-
-  entry.d_off = dir->filepos;
-  strncpy (entry.d_name, find->cFileName, sizeof (entry.d_name));
-  entry.d_reclen = strlen (find->cFileName);
-  dir->filepos++;
-  return &entry;
-}
-
-int 
-closedir (DIR * dir)
-{
-  HANDLE hnd = (HANDLE) dir->fd;
-  free (dir->data);
-  free (dir->mask);
-  free (dir);
-  return FindClose (hnd) ? 0 : -1;
-}
-
-void 
-rewinddir (DIR * dir)
-{
-  HANDLE hnd = (HANDLE) dir->fd;
-  WIN32_FIND_DATA *find = (WIN32_FIND_DATA *) dir->data;
-
-  FindClose (hnd);
-  hnd = FindFirstFile (dir->mask, find);
-  dir->fd = (int) hnd;
-  dir->filepos = 0;
-}
-
-void 
-seekdir (DIR * dir, off_t offset)
-{
-  off_t n;
-
-  rewinddir (dir);
-  for (n = 0; n < offset; n++)
-    {
-      if (FindNextFile ((HANDLE) dir->fd, (WIN32_FIND_DATA *) dir->data))
-	dir->filepos++;
-    }
-}
-
-off_t 
-telldir (DIR * dir)
-{
-  return dir->filepos;
-}
-
-int 
-dirfd (DIR * dir)
-{
-  return dir->fd;
-}

libguile/win32-dirent.h

@@ -1,65 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_WIN32_DIRENT_H
-#define SCM_WIN32_DIRENT_H
-
-/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-/* Directory stream type.
-   The miscellaneous Unix `readdir' implementations read directory data
-   into a buffer and return `struct dirent *' pointers into it.  */
-
-#include <sys/types.h>
-
-struct dirstream
-{
-  int fd;		/* File descriptor.  */
-  char *data;		/* Directory block.  */
-  size_t allocation;	/* Space allocated for the block.  */
-  size_t size;		/* Total valid data in the block.  */
-  size_t offset;	/* Current offset into the block.  */
-  off_t filepos;	/* Position of next entry to read.  */
-  char *mask;           /* Initial file mask. */
-};
-
-struct dirent
-{
-  long d_ino;
-  off_t d_off;
-  unsigned short int d_reclen;
-  unsigned char d_type;
-  char d_name[256];
-};
-
-#define d_fileno d_ino /* Backwards compatibility. */
-
-/* This is the data type of directory stream objects.
-   The actual structure is opaque to users.  */
-
-typedef struct dirstream DIR;
-
-DIR * opendir (const char * name);
-struct dirent * readdir (DIR * dir);
-int closedir (DIR * dir);
-void rewinddir (DIR * dir);
-void seekdir (DIR * dir, off_t offset);
-off_t telldir (DIR * dir);
-int dirfd (DIR * dir);
-
-#endif /* SCM_WIN32_DIRENT_H */

m4/dirname.m4

@@ -0,0 +1,19 @@
+#serial 10   -*- autoconf -*-
+dnl Copyright (C) 2002-2006, 2009-2011 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_DIRNAME],
+[
+  AC_REQUIRE([gl_DIRNAME_LGPL])
+])
+
+AC_DEFUN([gl_DIRNAME_LGPL],
+[
+  dnl Prerequisites of lib/dirname.h.
+  AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
+
+  dnl No prerequisites of lib/basename-lgpl.c, lib/dirname-lgpl.c,
+  dnl lib/stripslash.c.
+])

m4/gnulib-cache.m4

@@ -15,7 +15,7 @@
 
 
 # Specification in the form of a command-line invocation:
-#   gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom send sendto setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
+#   gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom rename send sendto setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
 
 # Specification in the form of a few gnulib-tool.m4 macro invocations:
 gl_LOCAL_DIR([])
@@ -72,6 +72,7 @@ gl_MODULES([
   putenv
   recv
   recvfrom
+  rename
   send
   sendto
   setsockopt

m4/gnulib-comp.m4

@@ -46,7 +46,9 @@ AC_DEFUN([gl_EARLY],
   # Code from module ceil:
   # Code from module close:
   # Code from module connect:
+  # Code from module dirname-lgpl:
   # Code from module dosname:
+  # Code from module double-slash-root:
   # Code from module duplocale:
   # Code from module environ:
   # Code from module errno:
@@ -130,8 +132,11 @@ AC_DEFUN([gl_EARLY],
   # Code from module readlink:
   # Code from module recv:
   # Code from module recvfrom:
+  # Code from module rename:
+  # Code from module rmdir:
   # Code from module safe-read:
   # Code from module safe-write:
+  # Code from module same-inode:
   # Code from module send:
   # Code from module sendto:
   # Code from module servent:
@@ -230,6 +235,8 @@ if test "$ac_cv_header_winsock2_h" = yes; then
   AC_LIBOBJ([connect])
 fi
 gl_SYS_SOCKET_MODULE_INDICATOR([connect])
+gl_DIRNAME_LGPL
+gl_DOUBLE_SLASH_ROOT
 gl_FUNC_DUPLOCALE
 if test $REPLACE_DUPLOCALE = 1; then
   AC_LIBOBJ([duplocale])
@@ -472,6 +479,16 @@ if test "$ac_cv_header_winsock2_h" = yes; then
   AC_LIBOBJ([recvfrom])
 fi
 gl_SYS_SOCKET_MODULE_INDICATOR([recvfrom])
+gl_FUNC_RENAME
+if test $REPLACE_RENAME = 1; then
+  AC_LIBOBJ([rename])
+fi
+gl_STDIO_MODULE_INDICATOR([rename])
+gl_FUNC_RMDIR
+if test $REPLACE_RMDIR = 1; then
+  AC_LIBOBJ([rmdir])
+fi
+gl_UNISTD_MODULE_INDICATOR([rmdir])
 gl_PREREQ_SAFE_READ
 gl_PREREQ_SAFE_WRITE
 AC_REQUIRE([gl_HEADER_SYS_SOCKET])
@@ -736,6 +753,7 @@ AC_DEFUN([gl_FILE_LIST], [
   lib/alloca.in.h
   lib/arpa_inet.in.h
   lib/asnprintf.c
+  lib/basename-lgpl.c
   lib/binary-io.h
   lib/bind.c
   lib/byteswap.in.h
@@ -749,6 +767,8 @@ AC_DEFUN([gl_FILE_LIST], [
   lib/ceil.c
   lib/close.c
   lib/connect.c
+  lib/dirname-lgpl.c
+  lib/dirname.h
   lib/dosname.h
   lib/duplocale.c
   lib/errno.in.h
@@ -825,10 +845,13 @@ AC_DEFUN([gl_FILE_LIST], [
   lib/readlink.c
   lib/recv.c
   lib/recvfrom.c
+  lib/rename.c
+  lib/rmdir.c
   lib/safe-read.c
   lib/safe-read.h
   lib/safe-write.c
   lib/safe-write.h
+  lib/same-inode.h
   lib/send.c
   lib/sendto.c
   lib/setsockopt.c
@@ -851,6 +874,7 @@ AC_DEFUN([gl_FILE_LIST], [
   lib/striconveh.c
   lib/striconveh.h
   lib/string.in.h
+  lib/stripslash.c
   lib/sys_file.in.h
   lib/sys_socket.in.h
   lib/sys_stat.in.h
@@ -888,6 +912,7 @@ AC_DEFUN([gl_FILE_LIST], [
   m4/ceil.m4
   m4/check-math-lib.m4
   m4/close.m4
+  m4/dirname.m4
   m4/double-slash-root.m4
   m4/duplocale.m4
   m4/eealloc.m4
@@ -961,6 +986,8 @@ AC_DEFUN([gl_FILE_LIST], [
   m4/putenv.m4
   m4/read.m4
   m4/readlink.m4
+  m4/rename.m4
+  m4/rmdir.m4
   m4/safe-read.m4
   m4/safe-write.m4
   m4/servent.m4

m4/rename.m4

@@ -0,0 +1,184 @@
+# serial 24
+
+# Copyright (C) 2001, 2003, 2005-2006, 2009-2011 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+dnl From Volker Borchert.
+dnl Determine whether rename works for source file names with a trailing slash.
+dnl The rename from SunOS 4.1.1_U1 doesn't.
+dnl
+dnl If it doesn't, then define RENAME_TRAILING_SLASH_BUG and arrange
+dnl to compile the wrapper function.
+dnl
+
+AC_DEFUN([gl_FUNC_RENAME],
+[
+  AC_REQUIRE([AC_CANONICAL_HOST])
+  AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+  AC_CHECK_FUNCS_ONCE([lstat])
+
+  dnl Solaris 10, AIX 7.1 mistakenly allow rename("file","name/").
+  dnl NetBSD 1.6 mistakenly forbids rename("dir","name/").
+  dnl FreeBSD 7.2 mistakenly allows rename("file","link-to-file/").
+  dnl The Solaris bug can be worked around without stripping
+  dnl trailing slash, while the NetBSD bug requires stripping;
+  dnl the two conditions can be distinguished by whether hard
+  dnl links are also broken.
+  AC_CACHE_CHECK([whether rename honors trailing slash on destination],
+    [gl_cv_func_rename_slash_dst_works],
+    [rm -rf conftest.f conftest.f1 conftest.f2 conftest.d1 conftest.d2 conftest.lnk
+    touch conftest.f && touch conftest.f1 && mkdir conftest.d1 ||
+      AC_MSG_ERROR([cannot create temporary files])
+    # Assume that if we have lstat, we can also check symlinks.
+    if test $ac_cv_func_lstat = yes; then
+      ln -s conftest.f conftest.lnk
+    fi
+    AC_RUN_IFELSE(
+      [AC_LANG_PROGRAM([[
+#        include <stdio.h>
+#        include <stdlib.h>
+         ]],
+         [[int result = 0;
+           if (rename ("conftest.f1", "conftest.f2/") == 0)
+             result |= 1;
+           if (rename ("conftest.d1", "conftest.d2/") != 0)
+             result |= 2;
+#if HAVE_LSTAT
+           if (rename ("conftest.f", "conftest.lnk/") == 0)
+             result |= 4;
+#endif
+           return result;
+         ]])],
+      [gl_cv_func_rename_slash_dst_works=yes],
+      [gl_cv_func_rename_slash_dst_works=no],
+      dnl When crosscompiling, assume rename is broken.
+      [gl_cv_func_rename_slash_dst_works="guessing no"])
+    rm -rf conftest.f conftest.f1 conftest.f2 conftest.d1 conftest.d2 conftest.lnk
+  ])
+  if test "x$gl_cv_func_rename_slash_dst_works" != xyes; then
+    REPLACE_RENAME=1
+    AC_DEFINE([RENAME_TRAILING_SLASH_DEST_BUG], [1],
+      [Define if rename does not correctly handle slashes on the destination
+       argument, such as on Solaris 10 or NetBSD 1.6.])
+  fi
+
+  dnl SunOS 4.1.1_U1 mistakenly forbids rename("dir/","name").
+  dnl Solaris 9 mistakenly allows rename("file/","name").
+  dnl FreeBSD 7.2 mistakenly allows rename("link-to-file/","name").
+  dnl These bugs require stripping trailing slash to avoid corrupting
+  dnl symlinks with a trailing slash.
+  AC_CACHE_CHECK([whether rename honors trailing slash on source],
+    [gl_cv_func_rename_slash_src_works],
+    [rm -rf conftest.f conftest.f1 conftest.d1 conftest.d2 conftest.d3 conftest.lnk
+    touch conftest.f && touch conftest.f1 && mkdir conftest.d1 ||
+      AC_MSG_ERROR([cannot create temporary files])
+    # Assume that if we have lstat, we can also check symlinks.
+    if test $ac_cv_func_lstat = yes; then
+      ln -s conftest.f conftest.lnk
+    fi
+    AC_RUN_IFELSE(
+      [AC_LANG_PROGRAM([[
+#        include <stdio.h>
+#        include <stdlib.h>
+         ]],
+         [[int result = 0;
+           if (rename ("conftest.f1/", "conftest.d3") == 0)
+             result |= 1;
+           if (rename ("conftest.d1/", "conftest.d2") != 0)
+             result |= 2;
+#if HAVE_LSTAT
+           if (rename ("conftest.lnk/", "conftest.f") == 0)
+             result |= 4;
+#endif
+           return result;
+         ]])],
+      [gl_cv_func_rename_slash_src_works=yes],
+      [gl_cv_func_rename_slash_src_works=no],
+      dnl When crosscompiling, assume rename is broken.
+      [gl_cv_func_rename_slash_src_works="guessing no"])
+    rm -rf conftest.f conftest.f1 conftest.d1 conftest.d2 conftest.d3 conftest.lnk
+  ])
+  if test "x$gl_cv_func_rename_slash_src_works" != xyes; then
+    REPLACE_RENAME=1
+    AC_DEFINE([RENAME_TRAILING_SLASH_SOURCE_BUG], [1],
+      [Define if rename does not correctly handle slashes on the source
+       argument, such as on Solaris 9 or cygwin 1.5.])
+  fi
+
+  dnl NetBSD 1.6 and cygwin 1.5.x mistakenly reduce hard link count
+  dnl on rename("h1","h2").
+  dnl This bug requires stat'ting targets prior to attempting rename.
+  AC_CACHE_CHECK([whether rename manages hard links correctly],
+    [gl_cv_func_rename_link_works],
+    [rm -rf conftest.f conftest.f1
+    if touch conftest.f && ln conftest.f conftest.f1 &&
+        set x `ls -i conftest.f conftest.f1` && test "$2" = "$4"; then
+      AC_RUN_IFELSE(
+        [AC_LANG_PROGRAM([[
+#          include <stdio.h>
+#          include <stdlib.h>
+#          include <unistd.h>
+           ]],
+           [[int result = 0;
+             if (rename ("conftest.f", "conftest.f1"))
+               result |= 1;
+             if (unlink ("conftest.f1"))
+               result |= 2;
+             if (rename ("conftest.f", "conftest.f"))
+               result |= 4;
+             if (rename ("conftest.f1", "conftest.f1") == 0)
+               result |= 8;
+             return result;
+           ]])],
+        [gl_cv_func_rename_link_works=yes],
+        [gl_cv_func_rename_link_works=no],
+        dnl When crosscompiling, assume rename is broken.
+        [gl_cv_func_rename_link_works="guessing no"])
+    else
+      gl_cv_func_rename_link_works="guessing no"
+    fi
+    rm -rf conftest.f conftest.f1
+  ])
+  if test "x$gl_cv_func_rename_link_works" != xyes; then
+    REPLACE_RENAME=1
+    AC_DEFINE([RENAME_HARD_LINK_BUG], [1],
+      [Define if rename fails to leave hard links alone, as on NetBSD 1.6
+       or Cygwin 1.5.])
+  fi
+
+  dnl Cygwin 1.5.x mistakenly allows rename("dir","file").
+  dnl mingw mistakenly forbids rename("dir1","dir2").
+  dnl These bugs require stripping trailing slash to avoid corrupting
+  dnl symlinks with a trailing slash.
+  AC_CACHE_CHECK([whether rename manages existing destinations correctly],
+    [gl_cv_func_rename_dest_works],
+    [rm -rf conftest.f conftest.d1 conftest.d2
+    touch conftest.f && mkdir conftest.d1 conftest.d2 ||
+      AC_MSG_ERROR([cannot create temporary files])
+    AC_RUN_IFELSE(
+      [AC_LANG_PROGRAM([[
+#        include <stdio.h>
+#        include <stdlib.h>
+         ]],
+         [[int result = 0;
+           if (rename ("conftest.d1", "conftest.d2") != 0)
+             result |= 1;
+           if (rename ("conftest.d2", "conftest.f") == 0)
+             result |= 2;
+           return result;
+         ]])],
+      [gl_cv_func_rename_dest_works=yes],
+      [gl_cv_func_rename_dest_works=no],
+      dnl When crosscompiling, assume rename is broken.
+      [gl_cv_func_rename_dest_works="guessing no"])
+    rm -rf conftest.f conftest.d1 conftest.d2
+  ])
+  if test "x$gl_cv_func_rename_dest_works" != xyes; then
+    REPLACE_RENAME=1
+    AC_DEFINE([RENAME_DEST_EXISTS_BUG], [1],
+      [Define if rename does not work when the destination file exists,
+       as on Cygwin 1.5 or Windows.])
+  fi
+])

m4/rmdir.m4

@@ -0,0 +1,34 @@
+# rmdir.m4 serial 11
+dnl Copyright (C) 2002, 2005, 2009-2011 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_RMDIR],
+[
+  AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+  dnl Detect cygwin 1.5.x bug.
+  AC_CACHE_CHECK([whether rmdir works], [gl_cv_func_rmdir_works],
+    [mkdir conftest.dir
+     touch conftest.file
+     AC_RUN_IFELSE(
+       [AC_LANG_PROGRAM(
+         [[#include <stdio.h>
+           #include <errno.h>
+           #include <unistd.h>
+]], [[int result = 0;
+      if (!rmdir ("conftest.file/"))
+        result |= 1;
+      else if (errno != ENOTDIR)
+        result |= 2;
+      if (!rmdir ("conftest.dir/./"))
+        result |= 4;
+      return result;
+    ]])],
+       [gl_cv_func_rmdir_works=yes], [gl_cv_func_rmdir_works=no],
+       [gl_cv_func_rmdir_works="guessing no"])
+     rm -rf conftest.dir conftest.file])
+  if test x"$gl_cv_func_rmdir_works" != xyes; then
+    REPLACE_RMDIR=1
+  fi
+])

module/ice-9/boot-9.scm

@@ -3411,7 +3411,7 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define %auto-compilation-options
   ;; Default `compile-file' option when auto-compiling.
-  '(#:warnings (unbound-variable arity-mismatch)))
+  '(#:warnings (unbound-variable arity-mismatch format)))
 
 (define* (load-in-vicinity dir path #:optional reader)
   ;; Returns the .go file corresponding to `name'. Does not search load
@@ -3470,8 +3470,14 @@ module '(ice-9 q) '(make-q q-length))}."
                  (else #f))))))
       (lambda (k . args)
         (format (current-error-port)
-                ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
+                ";;; WARNING: compilation of ~a failed:\n" name)
-                name k args)
+        (for-each (lambda (s)
+                    (if (not (string-null? s))
+                        (format (current-error-port) ";;; ~a\n" s)))
+                  (string-split
+                   (call-with-output-string
+                    (lambda (port) (print-exception port #f k args)))
+                   #\newline))
         #f)))
 
   (define (absolute-path? path)

module/ice-9/psyntax.scm

@@ -2425,7 +2425,8 @@
     (set! generate-temporaries
           (lambda (ls)
             (arg-check list? ls 'generate-temporaries)
-            (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
+            (let ((mod (cons 'hygiene (module-name (current-module)))))
+              (map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
 
     (set! free-identifier=?
           (lambda (x y)

module/language/tree-il/compile-glil.scm

@@ -207,10 +207,12 @@
          ;; write source info for proc
          (if src (emit-code #f (make-glil-source src)))
          ;; compile the body, yo
-         (flatten body allocation x self-label (car (hashq-ref allocation x))
+         (flatten-lambda-case body allocation x self-label
-                  emit-code)))))))
+                              (car (hashq-ref allocation x))
+                              emit-code)))))))
 
-(define (flatten x allocation self self-label fix-labels emit-code)
+(define (flatten-lambda-case lcase allocation self self-label fix-labels
+                             emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
@@ -218,7 +220,7 @@
 
   ;; RA: "return address"; #f unless we're in a non-tail fix with labels
   ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
-  (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+  (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
     (define (comp-tail tree) (comp tree context RA MVRA))
     (define (comp-push tree) (comp tree 'push #f #f))
     (define (comp-drop tree) (comp tree 'drop #f #f))
@@ -252,41 +254,26 @@
       
       ((<call> src proc args)
        (cond
-        ;; self-call in tail position
+        ;; call to the same lambda-case in tail position
         ((and (lexical-ref? proc)
               self-label (eq? (lexical-ref-gensym proc) self-label)
-              (eq? context 'tail))
+              (eq? context 'tail)
-         (let lp ((lcase (lambda-body self)))
+              (not (lambda-case-kw lcase))
-           (cond
+              (not (lambda-case-rest lcase))
-            ((and (lambda-case? lcase)
+              (= (length args)
-                  (not (lambda-case-kw lcase))
+                 (+ (length (lambda-case-req lcase))
-                  (not (lambda-case-rest lcase))
+                    (or (and=> (lambda-case-opt lcase) length) 0))))
-                  (= (length args)
+         (for-each comp-push args)
-                     (+ (length (lambda-case-req lcase))
+         (for-each (lambda (sym)
-                        (or (and=> (lambda-case-opt lcase) length) 0))))
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
-             ;; we have a case that matches the args; evaluate new
+                       ((#t #f . ,index) ; unboxed
-             ;; values, rename variables and goto the case label
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
-             (for-each comp-push args)
+                       ((#t #t . ,index) ; boxed
-             (for-each (lambda (sym)
+                        ;; new box
-                         (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                        (emit-code #f (make-glil-lexical #t #t 'box index)))
-                           ((#t #f . ,index) ; unboxed
+                       (,x (error "bad lambda-case arg allocation" x))))
-                            (emit-code #f (make-glil-lexical #t #f 'set index)))
+                   (reverse (lambda-case-gensyms lcase)))
-                           ((#t #t . ,index) ; boxed
+         (emit-branch src 'br (car (hashq-ref allocation lcase))))
-                            ;; new box
-                            (emit-code #f (make-glil-lexical #t #t 'box index)))
-                           (,x (error "bad lambda-case arg allocation" x))))
-                       (reverse (lambda-case-gensyms lcase)))
-             (emit-branch src 'br (car (hashq-ref allocation lcase))))
-            ((lambda-case? lcase)
-             ;; no match, try next case
-             (lp (lambda-case-alternate lcase)))
-            (else
-             ;; no cases left -- use the normal tail call mechanism. we
-             ;; can't just shuffle the args down and jump back to the
-             ;; self label, because we don't have space.
-             (comp-push proc)
-             (for-each comp-push args)
-             (emit-code src (make-glil-call 'tail-call (length args)))))))
         
         ;; lambda, the ultimate goto
         ((and (lexical-ref? proc)
@@ -378,20 +365,37 @@
               (else
                (comp-tail (make-primcall src 'apply (cons proc args))))))))
 
-         ((values . _) (guard (not (eq? context 'push)))
+         ((values . _)
           ;; tail: (lambda () (values '(1 2)))
           ;; drop: (lambda () (values '(1 2)) 3)
           ;; push: (lambda () (list (values '(10 12)) 1))
           ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
           (case context
             ((drop) (for-each comp-drop args) (maybe-emit-return))
+            ((push)
+             (case (length args)
+               ((0)
+                ;; FIXME: This is surely an error.  We need to add a
+                ;; values-mismatch warning pass.
+                (comp-push (make-call src (make-primitive-ref #f 'values)
+                                      '())))
+               ((1)
+                (comp-push (car args)))
+               (else
+                ;; Taking advantage of unspecified order of evaluation of
+                ;; arguments.
+                (for-each comp-drop (cdr args))
+                (comp-push (car args)))))
             ((vals)
              (for-each comp-push args)
              (emit-code #f (make-glil-const (length args)))
              (emit-branch src 'br MVRA))
             ((tail)
              (for-each comp-push args)
-             (emit-code src (make-glil-call 'return/values (length args))))))
+             (emit-code src (let ((len (length args)))
+                              (if (= len 1)
+                                  (make-glil-call 'return 1)
+                                  (make-glil-call 'return/values len)))))))
         
          ((@call-with-values ,producer ,consumer)
           ;; CONSUMER
@@ -724,7 +728,8 @@
          (if alternate-label
              (begin
                (emit-label alternate-label)
-               (comp-tail alternate)))))
+               (flatten-lambda-case alternate allocation self self-label
+                                    fix-labels emit-code)))))
       
       ((<let> src names gensyms vals body)
        (for-each comp-push vals)

module/language/tree-il/primitives.scm

@@ -249,7 +249,7 @@
 
 (define-primitive-expander +
   () 0
-  (x) x
+  (x) (values x)
   (x y) (if (and (const? y)
                  (let ((y (const-exp y)))
                    (and (number? y) (exact? y) (= y 1))))
@@ -267,7 +267,7 @@
   
 (define-primitive-expander *
   () 1
-  (x) x
+  (x) (values x)
   (x y z . rest) (* x (* y z . rest)))
   
 (define-primitive-expander -
@@ -313,7 +313,7 @@
 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 
 (define-primitive-expander cons*
-  (x) x
+  (x) (values x)
   (x y) (cons x y)
   (x y . rest) (cons x (cons* y . rest)))
 
@@ -332,8 +332,6 @@
 (define-primitive-expander call/cc (proc)
   (@call-with-current-continuation proc))
 
-(define-primitive-expander values (x) x)
-
 (define-primitive-expander make-struct (vtable tail-size . args)
   (if (and (const? tail-size)
            (let ((n (const-exp tail-size)))

module/system/base/language.scm

@@ -1,6 +1,6 @@
 ;;; Multi-language support
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -112,7 +112,6 @@
 ;;;
 
 (define *current-language* (make-fluid))
-(fluid-set! *current-language* 'scheme)
 
 (define (current-language)
-  (fluid-ref *current-language*))
+  (or (fluid-ref *current-language*) 'scheme))

test-suite/tests/compiler.test

@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -149,3 +149,18 @@
                                        ((y)   y)
                                        ((y z) (list y z)))))))
         (not (not (memv 0 (map source:addr s))))))))
+
+(with-test-prefix "case-lambda"
+  (pass-if "self recursion to different clause"
+    (equal? (with-output-to-string
+              (lambda ()
+                (let ()
+                  (define t
+                    (case-lambda
+                      ((x)
+                       (t x 'y))
+                      ((x y)
+                       (display (list x y))
+                       (list x y))))
+                  (display (t 'x)))))
+            "(x y)(x y)")))

test-suite/tests/tree-il.test

@@ -474,6 +474,26 @@
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (call null? 1) (call return 1))))
 
+(with-test-prefix "values"
+  (assert-tree-il->glil
+   (primcall values
+             (primcall values (const 1) (const 2)))
+   (program () (std-prelude 0 0 #f) (label _)
+            (const 1) (call return 1)))
+
+  (assert-tree-il->glil
+   (primcall values
+             (primcall values (const 1) (const 2))
+             (const 3))
+   (program () (std-prelude 0 0 #f) (label _)
+            (const 1) (const 3) (call return/values 2)))
+
+  (assert-tree-il->glil
+   (primcall +
+             (primcall values (const 1) (const 2)))
+   (program () (std-prelude 0 0 #f) (label _)
+            (const 1) (call return 1))))
+
 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 ;; and could be tightened in any case
 (with-test-prefix "the or hack"