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

Conflicts:
	GUILE-VERSION
	test-suite/tests/srfi-4.test

.gitignore

@@ -142,3 +142,4 @@ INSTALL
 /test-suite/standalone/test-scm-spawn-thread
 /test-suite/standalone/test-pthread-create
 /test-suite/standalone/test-pthread-create-secondary
+/lib/fcntl.h

GUILE-VERSION

@@ -18,7 +18,7 @@ GUILE_EFFECTIVE_VERSION=2.2
 # See libtool info pages for more information on how and when to
 # change these.
 
-LIBGUILE_INTERFACE_CURRENT=23
+LIBGUILE_INTERFACE_CURRENT=24
 LIBGUILE_INTERFACE_REVISION=0
-LIBGUILE_INTERFACE_AGE=1
+LIBGUILE_INTERFACE_AGE=2
 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"

NEWS

@@ -162,11 +162,16 @@ ports)' documentation from the R6RS documentation.  Thanks Andreas!
 ** Fix call-with-input-file & relatives for multiple values
 ** Fix `hash' for inf and nan
 ** Fix libguile internal type errors caught by typing-strictness==2
-** Fix compile error in mingw fstat socket detection
+** Fix compile error in MinGW fstat socket detection
+** Fix generation of auto-compiled file names on MinGW
 ** 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
+** Add type and range checks to the complex generalized vector accessors
+** Fix unaligned accesses for bytevectors of complex numbers
+** Fix '(a #{.} b)
+** Fix erroneous VM stack overflow for canceled threads
     
 
 Changes in 2.0.1 (since 2.0.0):

acinclude.m4

@@ -374,13 +374,14 @@ AC_DEFUN([GUILE_THREAD_LOCAL_STORAGE], [
      dnl
      dnl Known broken systems includes:
      dnl   - x86_64-unknown-netbsd5.0.
+     dnl   - x86_64-unknown-netbsd5.1
      dnl   - sparc-sun-solaris2.8
      dnl
      dnl On `x86_64-unknown-freebsd8.0', thread-local storage appears to
      dnl be reclaimed at the wrong time, leading to a segfault when
      dnl running `threads.test'.  So disable it.
      case "$enable_shared--$host_os" in
-       [yes--netbsd[0-5].[0-9].|yes--solaris2.8|yes--freebsd[0-8]*])
+       [yes--netbsd[0-5].[0-9]*|yes--solaris2.8|yes--freebsd[0-8]*])
          ac_cv_have_thread_storage_class="no"
          ;;
        *)

configure.ac

@@ -35,7 +35,8 @@ AC_CONFIG_AUX_DIR([build-aux])
 AC_CONFIG_MACRO_DIR([m4])
 AC_CONFIG_SRCDIR(GUILE-VERSION)
 
-AM_INIT_AUTOMAKE([gnu no-define -Wall -Wno-override])
+dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11.
+AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override dist-xz])
 m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
 
 AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
@@ -1635,6 +1636,10 @@ pkgdatadir="$datadir/$PACKAGE_TARNAME"
 sitedir="$pkgdatadir/site/$GUILE_EFFECTIVE_VERSION"
 AC_SUBST([sitedir])
 
+dnl Name of the `guile' program.
+guile_program_name="`echo guile | "$SED" "$program_transform_name"`"
+AC_SUBST([guile_program_name])
+
 # Additional SCM_I_GSC definitions are above.
 AC_SUBST([SCM_I_GSC_GUILE_DEBUG])
 AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED])

doc/ref/Makefile.am

@@ -90,6 +90,7 @@ guile_TEXINFOS = preface.texi			\
 		 mod-getopt-long.texi		\
 		 goops.texi			\
 		 goops-tutorial.texi		\
+		 guile-invoke.texi		\
 		 effective-version.texi
 
 ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS)

doc/ref/goops.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  2008, 2009
+@c Copyright (C)  2008, 2009, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -822,9 +822,10 @@ Here is an example:
   #:export (x y z ...))
 
 (define-module (my-module)
+  #:use-module (oop goops)
   #:use-module (math 2D-vectors)
   #:use-module (math 3D-vectors)
-  #:duplicates merge-generics)
+  #:duplicates (merge-generics))
 @end lisp
 
 The generic function @code{x} in @code{(my-module)} will now incorporate

doc/ref/scheme-using.texi

@@ -704,17 +704,15 @@ information.
 Guile also comes with a growing number of command-line utilities: a
 compiler, a disassembler, some module inspectors, and in the future, a
 system to install Guile packages from the internet.  These tools may be
-invoked using the @code{guild} program@footnote{Until Guile version
+invoked using the @code{guild} program.
-2.0.1, this program was known as @code{guile-tools}.  The
-@code{guile-tools} executable is still installed as of 2.0.x but may be
-removed in a future stable series.}.
 
 @example
 $ guild compile -o foo.go foo.scm
 wrote `foo.go'
 @end example
 
-This program used to be called @code{guile-tools}, and for backward
+This program used to be called @code{guile-tools} up to
+Guile version 2.0.1, and for backward
 compatibility it still may be called as such.  However we changed the
 name to @code{guild}, not only because it is pleasantly shorter and
 easier to read, but also because this tool will serve to bind Guile

doc/release.org

@@ -0,0 +1,164 @@
+#+TITLE: Release Process for GNU Guile 2.0
+#+AUTHOR: Ludovic Courtès
+#+EMAIL: ludo@gnu.org
+
+This document describes the typical release process for Guile 2.0.
+
+* Preparing & uploading the tarball
+
+** Update Gnulib
+
+The commit log's first line should be "Update Gnulib to X", where X is
+the output of `git describe' in the Gnulib repo.
+
+This allows us to keep track of the source code we use, in case a bug or
+security vulnerability gets fixed in Gnulib sometime later.
+
+Ideally update Gnulib several days prior to the release, so that
+portability or build issues can be uncovered in time.
+
+** Make sure it works, portably, and with different configurations
+
+*** Check [[http://hydra.nixos.org/jobset/gnu/guile-2-0][Hydra]]
+
+This contains builds and cross-builds on different platforms, with
+different `configure' switches, different CPPFLAGS, and different
+versions of the compiler.
+
+As of this writing, there are unfixed failures.  For instance Darwin's
+compiler randomly crashes, preventing build completion; the FreeBSD 7.x
+box experiences Guile crashes while running the test suite, which were
+not fixed because not reproduced elsewhere.  Even for these platforms,
+make sure "things don't get worse", at least.
+
+*** Check [[http://autobuild.josefsson.org/guile/][Autobuild]]
+
+This contains build reports from other people, typically on lesser used
+platforms, so it's worth checking.
+
+*** Use the [[http://gcc.gnu.org/wiki/CompileFarm][GCC Compile Farm]]
+
+Use the GCC Compile Farm to check on lesser used architectures or
+operating systems.  In particular, the Farm has ARM, SPARC64, PowerPC,
+and MIPS GNU/Linux boxes (remember that this is not superfluous: Debian
+builds on 11 architectures).  It also has FreeBSD and NetBSD boxes.
+
+*** Use porter boxes
+
+If you're still in a good mood, you may also want to check on porter
+boxes for other OSes.  The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], so does
+the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]].
+
+** Update `GUILE-VERSION'
+
+For stable releases, make sure to update the SONAME appropriately.  To
+that end, review the commit logs for libguile in search of any C ABI
+changes (new functions added, existing functions deprecated, etc.)
+Change `LIBGUILE_INTERFACE_*' accordingly.  Re-read the Libtool manual
+if in doubt.
+
+`libguile/libguile.map' should also be updated as new public symbols are
+added.  Ideally, new symbols should get under a new version
+symbol---e.g., `GUILE_2.0.3' for symbols introduced in Guile 2.0.3.
+However, this has not been done for Guile <= 2.0.2.
+
+** Tag v2.0.x
+
+Create a signed Git tag, like this:
+
+  $ git tag -s u MY-KEY -m "GNU Guile 2.0.X." v2.0.X
+
+The tag *must* be `v2.0.X'.  For the sake of consistency, always use
+"GNU Guile 2.0.X." as the tag comment.
+
+** Push the tag and changes
+
+  $ git push && git push --tags
+
+Normally nobody committed in the meantime.  ;-)
+
+** Run "make dist"
+
+This should trigger an `autoreconf', as `build-aux/git-version-gen'
+notices the new tag.  After "make dist", double-check that `./configure
+--version' reports the new version number.
+
+The reason for running "make dist" instead of "make distcheck" is that
+it's much faster and any distribution issues should have been caught by
+Hydra already.
+
+** Upload
+
+  $ ./build-aux/gnupload --to ftp.gnu.org:guile guile-2.0.X.tar.gz
+
+You'll get an email soon after when the upload is complete.
+
+Your GPG public key must be registered for this to work (info
+"(maintain) Automated Upload Registration").
+
+Make sure to publish your public key on public OpenPGP servers
+(keys.gnupg.net, pgp.mit.edu, etc.), so that people can actually use it
+to check the authenticity and integrity of the tarball.
+
+** Download
+
+Make sure the file was uploaded and is available for download as
+expected:
+
+  $ mkdir t && cd t && wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.gz
+  $ diff guile-2.0.X.tar.gz ../guile-2.0.X.tar.gz
+
+You're almost done!
+
+* Announcements
+
+First, re-read the GNU Maintainers Guide on this topic (info "(maintain)
+Announcements").
+
+** Update web pages
+
+  - Replace any references to the previous version number and replace it
+    with the new one.
+  - Update news.html.
+
+** Update the on-line copy of the manual
+
+  - Use `build-aux/gendocs', add to the manual/ directory of the web
+    site.
+
+** Prepare the email announcement
+
+  $ build-aux/announce-gen --release-type=stable --package-name=guile \
+      --previous-version=2.0.1 --current-version=2.0.2 \
+      --gpg-key-id=MY-KEY --url-directory=ftp://ftp.gnu.org/gnu/guile \
+      --bootstrap-tools=autoconf,automake,libtool,gnulib \
+      --gnulib-version=$( cd ~/src/gnulib ; git describe )
+
+The subject must be "GNU Guile 2.0.X released".  The text should remain
+formal and impersonal (it is sent on behalf of the Guile and GNU
+projects.)  It must include a description of what Guile is (not everyone
+reading info-gnu may know about it.)  Use the text of previous
+announcements as a template.
+
+Below the initial boilerplate that describes Guile should come the
+output of `announce-gen', and then the `NEWS' file excerpt in its
+entirety (don't call it a change log since that's not what it is.)
+
+** Send the email announcement
+
+  - guile-user@gnu.org, guile-devel@gnu.org, guile-sources@gnu.org
+  - info-gnu@gnu.org (for stable releases only!)
+  - comp.lang.scheme
+
+** Post a news on [[http://sv.gnu.org/p/guile/][Savannah]]
+
+The news will end up on planet.gnu.org.  The text can be shorter and
+more informal, with a link to the email announcement for details.
+
+
+
+Copyright © 2011 Free Software Foundation, Inc.
+
+  Copying and distribution of this file, with or without modification,
+  are permitted in any medium without royalty provided the copyright
+  notice and this notice are preserved.

lib/Makefile.am

@@ -420,7 +420,9 @@ float.h: $(top_builddir)/config.status
 endif
 MOSTLYCLEANFILES += float.h float.h-t
 
-EXTRA_DIST += float.in.h
+EXTRA_DIST += float.c float.in.h
+
+EXTRA_libgnu_la_SOURCES += float.c
 
 ## end   gnulib module float
 

lib/float.c

@@ -0,0 +1,33 @@
+/* Auxiliary definitions for <float.h>.
+   Copyright (C) 2011 Free Software Foundation, Inc.
+   Written by Bruno Haible <bruno@clisp.org>, 2011.
+
+   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>
+
+/* Specification.  */
+#include <float.h>
+
+#if (defined _ARCH_PPC || defined _POWER) && defined _AIX && (LDBL_MANT_DIG == 106) && defined __GNUC__
+const union gl_long_double_union gl_LDBL_MAX =
+  { { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL } };
+#elif defined __i386__
+const union gl_long_double_union gl_LDBL_MAX =
+  { { 0xFFFFFFFF, 0xFFFFFFFF, 32766 } };
+#else
+/* This declaration is solely to ensure that after preprocessing
+   this file is never empty.  */
+typedef int dummy;
+#endif

lib/float.in.h

@@ -29,6 +29,7 @@
 #define _@GUARD_PREFIX@_FLOAT_H
 
 /* 'long double' properties.  */
+
 #if defined __i386__ && (defined __BEOS__ || defined __OpenBSD__)
 /* Number of mantissa units, in base FLT_RADIX.  */
 # undef LDBL_MANT_DIG
@@ -59,5 +60,115 @@
 # define LDBL_MAX_10_EXP 4932
 #endif
 
+/* On FreeBSD/x86 6.4, the 'long double' type really has only 53 bits of
+   precision in the compiler but 64 bits of precision at runtime.  See
+   <http://lists.gnu.org/archive/html/bug-gnulib/2008-07/msg00063.html>.  */
+#if defined __i386__ && defined __FreeBSD__
+/* Number of mantissa units, in base FLT_RADIX.  */
+# undef LDBL_MANT_DIG
+# define LDBL_MANT_DIG   64
+/* Number of decimal digits that is sufficient for representing a number.  */
+# undef LDBL_DIG
+# define LDBL_DIG        18
+/* x-1 where x is the smallest representable number > 1.  */
+# undef LDBL_EPSILON
+# define LDBL_EPSILON 1.084202172485504434007452800869941711426e-19L /* 2^-63 */
+/* Minimum e such that FLT_RADIX^(e-1) is a normalized number.  */
+# undef LDBL_MIN_EXP
+# define LDBL_MIN_EXP    (-16381)
+/* Maximum e such that FLT_RADIX^(e-1) is a representable finite number.  */
+# undef LDBL_MAX_EXP
+# define LDBL_MAX_EXP    16384
+/* Minimum positive normalized number.  */
+# undef LDBL_MIN
+# define LDBL_MIN        3.3621031431120935E-4932L /* = 0x1p-16382L */
+/* Maximum representable finite number.  */
+# undef LDBL_MAX
+/* LDBL_MAX is represented as { 0xFFFFFFFF, 0xFFFFFFFF, 32766 }.
+   But the largest literal that GCC allows us to write is
+   0x0.fffffffffffff8p16384L = { 0xFFFFF800, 0xFFFFFFFF, 32766 }.
+   So, define it like this through a reference to an external variable
+
+     const unsigned int LDBL_MAX[3] = { 0xFFFFFFFF, 0xFFFFFFFF, 32766 };
+     extern const long double LDBL_MAX;
+
+   Unfortunately, this is not a constant expression.  */
+union gl_long_double_union
+  {
+    struct { unsigned int lo; unsigned int hi; unsigned int exponent; } xd;
+    long double ld;
+  };
+extern const union gl_long_double_union gl_LDBL_MAX;
+# define LDBL_MAX (gl_LDBL_MAX.ld)
+/* Minimum e such that 10^e is in the range of normalized numbers.  */
+# undef LDBL_MIN_10_EXP
+# define LDBL_MIN_10_EXP (-4931)
+/* Maximum e such that 10^e is in the range of representable finite numbers.  */
+# undef LDBL_MAX_10_EXP
+# define LDBL_MAX_10_EXP 4932
+#endif
+
+/* On AIX 7.1 with gcc 4.2, the values of LDBL_MIN_EXP, LDBL_MIN, LDBL_MAX are
+   wrong.  */
+#if (defined _ARCH_PPC || defined _POWER) && defined _AIX && (LDBL_MANT_DIG == 106) && defined __GNUC__
+# undef LDBL_MIN_EXP
+# define LDBL_MIN_EXP DBL_MIN_EXP
+# undef LDBL_MIN_10_EXP
+# define LDBL_MIN_10_EXP DBL_MIN_10_EXP
+# undef LDBL_MIN
+# define LDBL_MIN 2.22507385850720138309023271733240406422e-308L /* DBL_MIN = 2^-1022 */
+# undef LDBL_MAX
+/* LDBL_MAX is represented as { 0x7FEFFFFF, 0xFFFFFFFF, 0x7C8FFFFF, 0xFFFFFFFF }.
+   It is not easy to define:
+     #define LDBL_MAX 1.79769313486231580793728971405302307166e308L
+   is too small, whereas
+     #define LDBL_MAX 1.79769313486231580793728971405302307167e308L
+   is too large.  Apparently a bug in GCC decimal-to-binary conversion.
+   Also, I can't get values larger than
+     #define LDBL63 ((long double) (1ULL << 63))
+     #define LDBL882 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63)
+     #define LDBL945 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63)
+     #define LDBL1008 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63)
+     #define LDBL_MAX (LDBL1008 * 65535.0L + LDBL945 * (long double) 9223372036821221375ULL + LDBL882 * (long double) 4611686018427387904ULL)
+   which is represented as { 0x7FEFFFFF, 0xFFFFFFFF, 0x7C8FFFFF, 0xF8000000 }.
+   So, define it like this through a reference to an external variable
+
+     const double LDBL_MAX[2] = { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL };
+     extern const long double LDBL_MAX;
+
+   or through a pointer cast
+
+     #define LDBL_MAX \
+       (*(const long double *) (double[]) { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL })
+
+   Unfortunately, this is not a constant expression, and the latter expression
+   does not work well when GCC is optimizing..  */
+union gl_long_double_union
+  {
+    struct { double hi; double lo; } dd;
+    long double ld;
+  };
+extern const union gl_long_double_union gl_LDBL_MAX;
+# define LDBL_MAX (gl_LDBL_MAX.ld)
+#endif
+
+/* On IRIX 6.5, with cc, the value of LDBL_MANT_DIG is wrong.
+   On IRIX 6.5, with gcc 4.2, the values of LDBL_MIN_EXP, LDBL_MIN, LDBL_EPSILON
+   are wrong.  */
+#if defined __sgi && (LDBL_MANT_DIG >= 106)
+# undef LDBL_MANT_DIG
+# define LDBL_MANT_DIG 106
+# if defined __GNUC__
+#  undef LDBL_MIN_EXP
+#  define LDBL_MIN_EXP DBL_MIN_EXP
+#  undef LDBL_MIN_10_EXP
+#  define LDBL_MIN_10_EXP DBL_MIN_10_EXP
+#  undef LDBL_MIN
+#  define LDBL_MIN 2.22507385850720138309023271733240406422e-308L /* DBL_MIN = 2^-1022 */
+#  undef LDBL_EPSILON
+#  define LDBL_EPSILON 2.46519032881566189191165176650870696773e-32L /* 2^-105 */
+# endif
+#endif
+
 #endif /* _@GUARD_PREFIX@_FLOAT_H */
 #endif /* _@GUARD_PREFIX@_FLOAT_H */

lib/isinf.c

@@ -21,17 +21,20 @@
 
 #include <float.h>
 
-int gl_isinff (float x)
+int
+gl_isinff (float x)
 {
   return x < -FLT_MAX || x > FLT_MAX;
 }
 
-int gl_isinfd (double x)
+int
+gl_isinfd (double x)
 {
   return x < -DBL_MAX || x > DBL_MAX;
 }
 
-int gl_isinfl (long double x)
+int
+gl_isinfl (long double x)
 {
   return x < -LDBL_MAX || x > LDBL_MAX;
 }

lib/pathmax.h

@@ -19,6 +19,12 @@
 #ifndef _PATHMAX_H
 # define _PATHMAX_H
 
+/* POSIX:2008 defines PATH_MAX to be the maximum number of bytes in a filename,
+   including the terminating NUL byte.
+   <http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/limits.h.html>
+   PATH_MAX is not defined on systems which have no limit on filename length,
+   such as GNU/Hurd.  */
+
 # include <unistd.h>
 
 # include <limits.h>
@@ -45,4 +51,13 @@
 #  define PATH_MAX _POSIX_PATH_MAX
 # endif
 
+# ifdef __hpux
+/* On HP-UX, PATH_MAX designates the maximum number of bytes in a filename,
+   *not* including the terminating NUL byte, and is set to 1023.
+   Additionally, when _XOPEN_SOURCE is defined to 500 or more, PATH_MAX is
+   not defined at all any more.  */
+#  undef PATH_MAX
+#  define PATH_MAX 1024
+# endif
+
 #endif /* _PATHMAX_H */

lib/pipe2.c

@@ -40,6 +40,13 @@
 int
 pipe2 (int fd[2], int flags)
 {
+  /* Mingw _pipe() corrupts fd on failure; also, if we succeed at
+     creating the pipe but later fail at changing fcntl, we want
+     to leave fd unchanged: http://austingroupbugs.net/view.php?id=467  */
+  int tmp[2];
+  tmp[0] = fd[0];
+  tmp[1] = fd[1];
+
 #if HAVE_PIPE2
 # undef pipe2
   /* Try the system call first, if it exists.  (We may be running with a glibc
@@ -71,7 +78,11 @@ pipe2 (int fd[2], int flags)
 /* Native Woe32 API.  */
 
   if (_pipe (fd, 4096, flags & ~O_NONBLOCK) < 0)
+    {
+      fd[0] = tmp[0];
+      fd[1] = tmp[1];
       return -1;
+    }
 
   /* O_NONBLOCK handling.
      On native Windows platforms, O_NONBLOCK is defined by gnulib.  Use the
@@ -145,6 +156,8 @@ pipe2 (int fd[2], int flags)
     int saved_errno = errno;
     close (fd[0]);
     close (fd[1]);
+    fd[0] = tmp[0];
+    fd[1] = tmp[1];
     errno = saved_errno;
     return -1;
   }

lib/stat.c

@@ -38,6 +38,7 @@ orig_stat (const char *filename, struct stat *buf)
 #include <stdbool.h>
 #include <string.h>
 #include "dosname.h"
+#include "verify.h"
 
 /* Store information about NAME into ST.  Work around bugs with
    trailing slashes.  Mingw has other bugs (such as st_ino always
@@ -63,6 +64,12 @@ rpl_stat (char const *name, struct stat *st)
     }
 #endif /* REPLACE_FUNC_STAT_FILE */
 #if REPLACE_FUNC_STAT_DIR
+  /* The only known systems where REPLACE_FUNC_STAT_DIR is needed also
+     have a constant PATH_MAX.  */
+# ifndef PATH_MAX
+#  error "Please port this replacement to your platform"
+# endif
+
   if (result == -1 && errno == ENOENT)
     {
       /* Due to mingw's oddities, there are some directories (like
@@ -77,6 +84,7 @@ rpl_stat (char const *name, struct stat *st)
       char fixed_name[PATH_MAX + 1] = {0};
       size_t len = strlen (name);
       bool check_dir = false;
+      verify (PATH_MAX <= 4096);
       if (PATH_MAX <= len)
         errno = ENAMETOOLONG;
       else if (len)

lib/unistd.in.h

@@ -1062,6 +1062,7 @@ _GL_WARN_ON_USE (pipe2, "pipe2 is unportable - "
    specification <http://www.opengroup.org/susv3xsh/pread.html>.  */
 # if @REPLACE_PREAD@
 #  if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+#   undef pread
 #   define pread rpl_pread
 #  endif
 _GL_FUNCDECL_RPL (pread, ssize_t,
@@ -1096,6 +1097,7 @@ _GL_WARN_ON_USE (pread, "pread is unportable - "
    <http://www.opengroup.org/susv3xsh/pwrite.html>.  */
 # if @REPLACE_PWRITE@
 #  if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+#   undef pwrite
 #   define pwrite rpl_pwrite
 #  endif
 _GL_FUNCDECL_RPL (pwrite, ssize_t,

libguile/Makefile.am

@@ -647,6 +647,7 @@ libpath.h: $(srcdir)/Makefile.in  $(top_builddir)/config.status
 	@echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp
 	@echo '#define SCM_EXTENSIONS_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp
 	@echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp
+	@echo '#define SCM_SITE_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/site-ccache"' >> libpath.tmp
 	@echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
 	@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
 	@echo '	{ "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp

libguile/bytevectors.c

@@ -2109,26 +2109,56 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
 
 /* Bytevectors as generalized vectors & arrays.  */
 
+#define COMPLEX_ACCESSOR_PROLOGUE(_type)			\
+  size_t c_len, c_index;					\
+  char *c_bv;							\
+								\
+  SCM_VALIDATE_BYTEVECTOR (1, bv);				\
+  c_index = scm_to_size_t (index);				\
+								\
+  c_len = SCM_BYTEVECTOR_LENGTH (bv);				\
+  c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);			\
+								\
+  if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len))	\
+    scm_out_of_range (FUNC_NAME, index);
+
+/* Template for native access to complex numbers of type TYPE.  */
+#define COMPLEX_NATIVE_REF(_type)					\
+  SCM result;								\
+									\
+  COMPLEX_ACCESSOR_PROLOGUE (_type);					\
+									\
+  {									\
+    _type real, imag;							\
+									\
+    memcpy (&real, &c_bv[c_index], sizeof (_type));			\
+    memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type));	\
+									\
+    result = scm_c_make_rectangular (real, imag);			\
+  }									\
+									\
+  return result;
 
 static SCM
-bytevector_ref_c32 (SCM bv, SCM idx)
+bytevector_ref_c32 (SCM bv, SCM index)
-{ /* FIXME add some checks */
+#define FUNC_NAME "bytevector_ref_c32"
-  const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
+{
-  size_t i = scm_to_size_t (idx);
+  COMPLEX_NATIVE_REF (float);
-  return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
 }
+#undef FUNC_NAME
 
 static SCM
-bytevector_ref_c64 (SCM bv, SCM idx)
+bytevector_ref_c64 (SCM bv, SCM index)
-{ /* FIXME add some checks */
+#define FUNC_NAME "bytevector_ref_c64"
-  const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
+{
-  size_t i = scm_to_size_t (idx);
+  COMPLEX_NATIVE_REF (double);
-  return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
 }
+#undef FUNC_NAME
 
 typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
 
-const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = 
+static const scm_t_bytevector_ref_fn
+bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
 {
   NULL, /* SCM */
   NULL, /* CHAR */
@@ -2160,24 +2190,36 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
   return ref_fn (h->array, byte_index);
 }
 
-/* FIXME add checks!!! */
+/* Template for native modification of complex numbers of type TYPE.  */
-static SCM
+#define COMPLEX_NATIVE_SET(_type)					\
-bytevector_set_c32 (SCM bv, SCM idx, SCM val)
+  COMPLEX_ACCESSOR_PROLOGUE (_type);					\
-{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
+									\
-  size_t i = scm_to_size_t (idx);
+  {									\
-  contents[i/4] = scm_c_real_part (val);
+    _type real, imag;							\
-  contents[i/4 + 1] = scm_c_imag_part (val);
+    real = scm_c_real_part (value);					\
+    imag = scm_c_imag_part (value);					\
+									\
+    memcpy (&c_bv[c_index], &real, sizeof (_type));			\
+    memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type));	\
+  }									\
+									\
   return SCM_UNSPECIFIED;
-}
 
 static SCM
-bytevector_set_c64 (SCM bv, SCM idx, SCM val)
+bytevector_set_c32 (SCM bv, SCM index, SCM value)
-{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
+#define FUNC_NAME "bytevector_set_c32"
-  size_t i = scm_to_size_t (idx);
+{
-  contents[i/8] = scm_c_real_part (val);
+  COMPLEX_NATIVE_SET (float);
-  contents[i/8 + 1] = scm_c_imag_part (val);
-  return SCM_UNSPECIFIED;
 }
+#undef FUNC_NAME
+
+static SCM
+bytevector_set_c64 (SCM bv, SCM index, SCM value)
+#define FUNC_NAME "bytevector_set_c64"
+{
+  COMPLEX_NATIVE_SET (double);
+}
+#undef FUNC_NAME
 
 typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
 

libguile/filesys.c

@@ -261,8 +261,10 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
 
   fd = scm_to_int (scm_open_fdes (path, flags, mode));
   iflags = SCM_NUM2INT (2, flags);
-  if (iflags & O_RDWR)
+
+  if ((iflags & O_RDWR) == O_RDWR)
     {
+      /* Opened read-write.  */
       if (iflags & O_APPEND)
 	port_mode = "a+";
       else if (iflags & O_CREAT)
@@ -270,7 +272,9 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
       else
 	port_mode = "r+";
     }
-  else {
+  else
+    {
+      /* Opened read-only or write-only.  */
       if (iflags & O_APPEND)
 	port_mode = "a";
       else if (iflags & O_WRONLY)
@@ -278,6 +282,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
       else
 	port_mode = "r";
     }
+
   newpt = scm_fdes_to_port (fd, port_mode, path);
   return newpt;
 }
@@ -1857,6 +1862,9 @@ scm_init_filesys ()
 #ifdef O_LARGEFILE  
   scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
 #endif
+#ifdef O_NOTRANS
+  scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS));
+#endif
 
 #ifdef F_DUPFD  
   scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));

libguile/goops.c

@@ -2284,15 +2284,21 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
  *
  ******************************************************************************/
 
+/* Munge the CPL of C in place such that BEFORE appears before AFTER,
+   assuming that currently the reverse is true.  Recalculate slots and
+   associated getters-n-setters.  */
 static void
 fix_cpl (SCM c, SCM before, SCM after)
 {
   SCM cpl = SCM_SLOT (c, scm_si_cpl);
   SCM ls = scm_c_memq (after, cpl);
-  SCM tail = scm_delq1_x (before, SCM_CDR (ls));
+  SCM tail;
+
   if (scm_is_false (ls))
     /* if this condition occurs, fix_cpl should not be applied this way */
     abort ();
+
+  tail = scm_delq1_x (before, SCM_CDR (ls));
   SCM_SETCAR (ls, before);
   SCM_SETCDR (ls, scm_cons (after, tail));
   {
@@ -2418,8 +2424,8 @@ create_standard_classes (void)
   make_stdcls (&scm_class_extended_generic_with_setter,
 	       "<extended-generic-with-setter>",
 	       scm_class_applicable_struct_class,
-	       scm_list_2 (scm_class_generic_with_setter,
+	       scm_list_2 (scm_class_extended_generic,
-			   scm_class_extended_generic),
+                           scm_class_generic_with_setter),
 	       SCM_EOL);
   SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
 		       SCM_CLASSF_PURE_GENERIC);
@@ -2428,8 +2434,9 @@ create_standard_classes (void)
 	       scm_list_2 (scm_class_accessor,
 			   scm_class_extended_generic_with_setter),
 	       SCM_EOL);
+  /* <extended-generic> is misplaced.  */
   fix_cpl (scm_class_extended_accessor,
-	   scm_class_extended_generic, scm_class_generic);
+	   scm_class_extended_generic, scm_class_generic_with_setter);
   SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
 
   /* Primitive types classes */

libguile/i18n.c

@@ -400,7 +400,7 @@ install_locale (scm_t_locale locale)
 	 account.  */
       category_mask |= locale->category_mask;
 
-      if (locale->base_locale != SCM_UNDEFINED)
+      if (!SCM_UNBNDP (locale->base_locale))
 	locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
       else
 	locale = NULL;

libguile/load.c

@@ -270,7 +270,10 @@ scm_init_load_path ()
   else if (env)
     cpath = scm_parse_path (scm_from_locale_string (env), cpath);
   else
-    cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
+    {
+      cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR),
+                          scm_from_locale_string (SCM_SITE_CCACHE_DIR));
+    }
 
 #endif /* SCM_LIBRARY_DIR */
 
@@ -793,6 +796,22 @@ scm_try_auto_compile (SCM source)
                       NULL, NULL);
 }
 
+/* See also (system base compile):compiled-file-name. */
+static SCM
+canonical_to_suffix (SCM canon)
+{
+  size_t len = scm_c_string_length (canon);
+  
+  if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
+    return canon;
+  else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':')))
+    return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"),
+                                          scm_c_substring (canon, 0, 1),
+                                          scm_c_substring (canon, 2, len)));
+  else
+    return canon;
+}
+
 SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
 	    (SCM args),
 	    "Search @var{%load-path} for the file named @var{filename} and\n"
@@ -857,7 +876,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
     {
       SCM fallback = scm_string_append
         (scm_list_3 (*scm_loc_compile_fallback_path,
-                     full_filename,
+                     canonical_to_suffix (full_filename),
                      scm_car (*scm_loc_load_compiled_extensions)));
       if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
         {
@@ -895,7 +914,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
     {
       SCM fallback = scm_string_append
         (scm_list_3 (*scm_loc_compile_fallback_path,
-                     full_filename,
+                     canonical_to_suffix (full_filename),
                      scm_car (*scm_loc_load_compiled_extensions)));
       if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
           && compiled_is_fresh (full_filename, fallback))

libguile/modules.c

@@ -294,39 +294,46 @@ resolve_duplicate_binding (SCM module, SCM sym,
 			   SCM iface1, SCM var1,
 			   SCM iface2, SCM var2)
 {
+  SCM args[8];
+  SCM handlers;
   SCM result = SCM_BOOL_F;
 
-  if (!scm_is_eq (var1, var2))
+  if (scm_is_eq (var1, var2))
-    {
+    return var1;
-      SCM val1, val2;
-      SCM handlers, h, handler_args;
   
-      val1 = SCM_VARIABLE_REF (var1);
+  args[0] = module;
-      val2 = SCM_VARIABLE_REF (var2);
+  args[1] = sym;
-
+  args[2] = iface1;
-      val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
+  args[3] = SCM_VARIABLE_REF (var1);
-      val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
+  if (SCM_UNBNDP (args[3]))
+    args[3] = SCM_BOOL_F;
+  args[4] = iface2;
+  args[5] = SCM_VARIABLE_REF (var2);
+  if (SCM_UNBNDP (args[5]))
+    args[5] = SCM_BOOL_F;
+  args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F);
+  args[7] = SCM_BOOL_F;
       
   handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
   if (scm_is_false (handlers))
     handlers = default_duplicate_binding_handlers ();
 
-      handler_args = scm_list_n (module, sym,
+  for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
-				 iface1, val1, iface2, val2,
-				 var1, val1,
-				 SCM_UNDEFINED);
-
-      for (h = handlers;
-	   scm_is_pair (h) && scm_is_false (result);
-	   h = SCM_CDR (h))
     {
-	  result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
+      if (scm_is_true (args[6])) 
+        {
+          args[7] = SCM_VARIABLE_REF (args[6]);
+          if (SCM_UNBNDP (args[7]))
+            args[7] = SCM_BOOL_F;
         }
-    }
-  else
-    result = var1;
       
+      result = scm_call_n (SCM_CAR (handlers), args, 8);
+
+      if (scm_is_true (result))
         return result;
+    }
+
+  return SCM_BOOL_F;
 }
 
 /* No lock is needed for access to this variable, as there are no
@@ -371,6 +378,12 @@ module_imported_variable (SCM module, SCM sym)
                 found_var = resolve_duplicate_binding (module, sym,
                                                        found_iface, found_var,
                                                        iface, var);
+
+                /* Note that it could be that FOUND_VAR doesn't belong
+                   either to FOUND_IFACE or to IFACE, if it was created
+                   by merge-generics.  The right thing to do there would
+                   be to treat the import obarray as the iface, but the
+                   import obarray isn't actually a module.  Oh well.  */
 		if (scm_is_eq (found_var, var))
 		  found_iface = iface;
 	      }

libguile/read.c

@@ -376,8 +376,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
     return SCM_EOL;
 
   scm_ungetc (c, port);
-  if (scm_is_eq (scm_sym_dot,
+  tmp = scm_read_expression (port);
-		 (tmp = scm_read_expression (port))))
+
+  /* Note that it is possible for scm_read_expression to return
+     scm_sym_dot, but not as part of a dotted pair: as in #{.}#.  So
+     check that it's a real dot by checking `c'.  */
+  if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
     {
       ans = scm_read_expression (port);
       if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
@@ -401,7 +405,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
       scm_ungetc (c, port);
       tmp = scm_read_expression (port);
 
-      if (scm_is_eq (scm_sym_dot, tmp))
+      /* See above note about scm_sym_dot.  */
+      if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
 	{
 	  SCM_SETCDR (tl, tmp = scm_read_expression (port));
 

libguile/threads.c

@@ -692,6 +692,10 @@ on_thread_exit (void *v)
   /* This handler is executed in non-guile mode.  */
   scm_i_thread *t = (scm_i_thread *) v, **tp;
 
+  /* If we were canceled, we were unable to clear `t->guile_mode', so do
+     it here.  */
+  t->guile_mode = 0;
+
   /* If this thread was cancelled while doing a cond wait, it will
      still have a mutex locked, so we unlock it here. */
   if (t->held_mutex)
@@ -831,12 +835,6 @@ scm_init_guile ()
     }
 }
 
-SCM_UNUSED static void
-scm_leave_guile_cleanup (void *x)
-{
-  on_thread_exit (SCM_I_CURRENT_THREAD);
-}
-
 struct with_guile_args
 {
   GC_fn_type func;
@@ -1368,7 +1366,9 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
 	    {
 	      scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
 
-	      scm_i_pthread_mutex_unlock (&m->lock);
+	      /* FIXME: The order in which `t->admin_mutex' and
+		 `m->lock' are taken differs from that in
+		 `on_thread_exit', potentially leading to deadlocks.  */
 	      scm_i_pthread_mutex_lock (&t->admin_mutex);
 
 	      /* Only keep a weak reference to MUTEX so that it's not
@@ -1379,7 +1379,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
 	      t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
 
 	      scm_i_pthread_mutex_unlock (&t->admin_mutex);
-	      scm_i_pthread_mutex_lock (&m->lock);
 	    }
 	  *ret = 1;
 	  break;
@@ -1458,6 +1457,9 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
       waittime = &cwaittime;
     }
 
+  if (!SCM_UNBNDP (owner) && !scm_is_false (owner))
+    SCM_VALIDATE_THREAD (3, owner);
+
   exception = fat_mutex_lock (m, waittime, owner, &ret);
   if (!scm_is_false (exception))
     scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);

libguile/vm-engine.c

@@ -61,23 +61,31 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   SCM finish_args;                      /* used both for returns: both in error
                                            and normal situations */
 #ifdef HAVE_LABELS_AS_VALUES
-  static void **jump_table = NULL;
+  static const void **jump_table_pointer = NULL;
 #endif
 
 #ifdef HAVE_LABELS_AS_VALUES
-  if (SCM_UNLIKELY (!jump_table))
+  register const void **jump_table JT_REG;
+
+  if (SCM_UNLIKELY (!jump_table_pointer))
     {
       int i;
-      jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*));
+      jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
-        jump_table[i] = &&vm_error_bad_instruction;
+        jump_table_pointer[i] = &&vm_error_bad_instruction;
 #define VM_INSTRUCTION_TO_LABEL 1
+#define jump_table jump_table_pointer
 #include <libguile/vm-expand.h>
 #include <libguile/vm-i-system.i>
 #include <libguile/vm-i-scheme.i>
 #include <libguile/vm-i-loader.i>
+#undef jump_table
 #undef VM_INSTRUCTION_TO_LABEL
     }
+
+  /* Attempt to keep JUMP_TABLE_POINTER in a register.  This saves one
+     load instruction at each instruction dispatch.  */
+  jump_table = jump_table_pointer;
 #endif
 
   /* Initialization */

libguile/vm-engine.h

@@ -57,6 +57,11 @@
 /* too few registers! because of register allocation errors with various gcs,
    just punt on explicit assignments on i386, hoping that the "register"
    declaration will be sufficient. */
+#elif defined __x86_64__
+/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
+   well.  Tell it to keep the jump table in a r12, which is
+   callee-saved.  */
+#define JT_REG asm ("r12")
 #endif
 #if defined(PPC) || defined(_POWER) || defined(_IBMR2)
 #define IP_REG asm("26")
@@ -89,6 +94,9 @@
 #ifndef FP_REG
 #define FP_REG
 #endif
+#ifndef JT_REG
+#define JT_REG
+#endif
 
 
 /*

m4/alloca.m4

@@ -1,4 +1,4 @@
-# alloca.m4 serial 11
+# alloca.m4 serial 12
 dnl Copyright (C) 2002-2004, 2006-2007, 2009-2011 Free Software Foundation,
 dnl Inc.
 dnl This file is free software; the Free Software Foundation
@@ -42,3 +42,80 @@ AC_DEFUN([gl_FUNC_ALLOCA],
 # Prerequisites of lib/alloca.c.
 # STACK_DIRECTION is already handled by AC_FUNC_ALLOCA.
 AC_DEFUN([gl_PREREQ_ALLOCA], [:])
+
+# This works around a bug in autoconf <= 2.68.
+# See <http://lists.gnu.org/archive/html/bug-gnulib/2011-06/msg00277.html>.
+
+m4_version_prereq([2.69], [] ,[
+
+# This is taken from the following Autoconf patch:
+# http://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=6cd9f12520b0d6f76d3230d7565feba1ecf29497
+
+# _AC_LIBOBJ_ALLOCA
+# -----------------
+# Set up the LIBOBJ replacement of `alloca'.  Well, not exactly
+# AC_LIBOBJ since we actually set the output variable `ALLOCA'.
+# Nevertheless, for Automake, AC_LIBSOURCES it.
+m4_define([_AC_LIBOBJ_ALLOCA],
+[# The SVR3 libPW and SVR4 libucb both contain incompatible functions
+# that cause trouble.  Some versions do not even contain alloca or
+# contain a buggy version.  If you still want to use their alloca,
+# use ar to extract alloca.o from them instead of compiling alloca.c.
+AC_LIBSOURCES(alloca.c)
+AC_SUBST([ALLOCA], [\${LIBOBJDIR}alloca.$ac_objext])dnl
+AC_DEFINE(C_ALLOCA, 1, [Define to 1 if using `alloca.c'.])
+
+AC_CACHE_CHECK(whether `alloca.c' needs Cray hooks, ac_cv_os_cray,
+[AC_EGREP_CPP(webecray,
+[#if defined CRAY && ! defined CRAY2
+webecray
+#else
+wenotbecray
+#endif
+], ac_cv_os_cray=yes, ac_cv_os_cray=no)])
+if test $ac_cv_os_cray = yes; then
+  for ac_func in _getb67 GETB67 getb67; do
+    AC_CHECK_FUNC($ac_func,
+		  [AC_DEFINE_UNQUOTED(CRAY_STACKSEG_END, $ac_func,
+				      [Define to one of `_getb67', `GETB67',
+				       `getb67' for Cray-2 and Cray-YMP
+				       systems. This function is required for
+				       `alloca.c' support on those systems.])
+    break])
+  done
+fi
+
+AC_CACHE_CHECK([stack direction for C alloca],
+	       [ac_cv_c_stack_direction],
+[AC_RUN_IFELSE([AC_LANG_SOURCE(
+[AC_INCLUDES_DEFAULT
+int
+find_stack_direction (int *addr, int depth)
+{
+  int dir, dummy = 0;
+  if (! addr)
+    addr = &dummy;
+  *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1;
+  dir = depth ? find_stack_direction (addr, depth - 1) : 0;
+  return dir + dummy;
+}
+
+int
+main (int argc, char **argv)
+{
+  return find_stack_direction (0, argc + !argv + 20) < 0;
+}])],
+	       [ac_cv_c_stack_direction=1],
+	       [ac_cv_c_stack_direction=-1],
+	       [ac_cv_c_stack_direction=0])])
+AH_VERBATIM([STACK_DIRECTION],
+[/* If using the C implementation of alloca, define if you know the
+   direction of stack growth for your system; otherwise it will be
+   automatically deduced at runtime.
+	STACK_DIRECTION > 0 => grows toward higher addresses
+	STACK_DIRECTION < 0 => grows toward lower addresses
+	STACK_DIRECTION = 0 => direction of growth unknown */
+@%:@undef STACK_DIRECTION])dnl
+AC_DEFINE_UNQUOTED(STACK_DIRECTION, $ac_cv_c_stack_direction)
+])# _AC_LIBOBJ_ALLOCA
+])

m4/ceil.m4

@@ -1,4 +1,4 @@
-# ceil.m4 serial 6
+# ceil.m4 serial 8
 dnl Copyright (C) 2007, 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,
@@ -28,12 +28,18 @@ AC_DEFUN([gl_FUNC_CEIL],
 #include <math.h>
 ]gl_DOUBLE_MINUS_ZERO_CODE[
 ]gl_DOUBLE_SIGNBIT_CODE[
-int main()
+static double dummy (double f) { return 0; }
+int main (int argc, char *argv[])
 {
+  double (*my_ceil) (double) = argc ? ceil : dummy;
+  int result = 0;
   /* Test whether ceil (-0.0) is -0.0.  */
-  if (signbitd (minus_zerod) && !signbitd (ceil (minus_zerod)))
+  if (signbitd (minus_zerod) && !signbitd (my_ceil (minus_zerod)))
-    return 1;
+    result |= 1;
-  return 0;
+  /* Test whether ceil (-0.3) is -0.0.  */
+  if (signbitd (-0.3) && !signbitd (my_ceil (-0.3)))
+    result |= 2;
+  return result;
 }
             ]])],
             [gl_cv_func_ceil_ieee=yes],

m4/float_h.m4

@@ -1,4 +1,4 @@
-# float_h.m4 serial 6
+# float_h.m4 serial 7
 dnl Copyright (C) 2007, 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,
@@ -9,12 +9,41 @@ AC_DEFUN([gl_FLOAT_H],
   AC_REQUIRE([AC_PROG_CC])
   AC_REQUIRE([AC_CANONICAL_HOST])
   FLOAT_H=
+  REPLACE_FLOAT_LDBL=0
   case "$host_os" in
-    beos* | openbsd* | mirbsd*)
+    aix* | beos* | openbsd* | mirbsd* | irix*)
       FLOAT_H=float.h
-      gl_NEXT_HEADERS([float.h])
+      ;;
+    freebsd*)
+      case "$host_cpu" in
+changequote(,)dnl
+        i[34567]86 )
+changequote([,])dnl
+          FLOAT_H=float.h
+          ;;
+        x86_64 )
+          # On x86_64 systems, the C compiler may still be generating
+          # 32-bit code.
+          AC_EGREP_CPP([yes],
+            [#if defined __LP64__ || defined __x86_64__ || defined __amd64__
+             yes
+             #endif],
+            [],
+            [FLOAT_H=float.h])
           ;;
       esac
+      ;;
+  esac
+  case "$host_os" in
+    aix* | freebsd*)
+      if test -n "$FLOAT_H"; then
+        REPLACE_FLOAT_LDBL=1
+      fi
+      ;;
+  esac
+  if test -n "$FLOAT_H"; then
+    gl_NEXT_HEADERS([float.h])
+  fi
   AC_SUBST([FLOAT_H])
   AM_CONDITIONAL([GL_GENERATE_FLOAT_H], [test -n "$FLOAT_H"])
 ])

m4/floor.m4

@@ -1,4 +1,4 @@
-# floor.m4 serial 6
+# floor.m4 serial 7
 dnl Copyright (C) 2007, 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,
@@ -28,10 +28,12 @@ AC_DEFUN([gl_FUNC_FLOOR],
 #include <math.h>
 ]gl_DOUBLE_MINUS_ZERO_CODE[
 ]gl_DOUBLE_SIGNBIT_CODE[
-int main()
+static double dummy (double f) { return 0; }
+int main (int argc, char *argv[])
 {
+  double (*my_floor) (double) = argc ? floor : dummy;
   /* Test whether floor (-0.0) is -0.0.  */
-  if (signbitd (minus_zerod) && !signbitd (floor (minus_zerod)))
+  if (signbitd (minus_zerod) && !signbitd (my_floor (minus_zerod)))
     return 1;
   return 0;
 }

m4/gnulib-comp.m4

@@ -257,6 +257,9 @@ fi
 gl_MODULE_INDICATOR([fflush])
 gl_STDIO_MODULE_INDICATOR([fflush])
 gl_FLOAT_H
+if test $REPLACE_FLOAT_LDBL = 1; then
+  AC_LIBOBJ([float])
+fi
 gl_FUNC_FLOCK
 if test $HAVE_FLOCK = 0; then
   AC_LIBOBJ([flock])
@@ -778,6 +781,7 @@ AC_DEFUN([gl_FILE_LIST], [
   lib/fd-hook.h
   lib/fflush.c
   lib/float+.h
+  lib/float.c
   lib/float.in.h
   lib/flock.c
   lib/floor.c

m4/isinf.m4

@@ -1,4 +1,4 @@
-# isinf.m4 serial 4
+# isinf.m4 serial 5
 dnl Copyright (C) 2007-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,
@@ -11,7 +11,7 @@ AC_DEFUN([gl_ISINF],
   AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
   AC_CHECK_DECLS([isinf], , , [#include <math.h>])
   if test "$ac_cv_have_decl_isinf" = yes; then
-    gl_CHECK_MATH_LIB([ISINF_LIBM], [x = isinf (x);])
+    gl_CHECK_MATH_LIB([ISINF_LIBM], [x = isinf (x) + isinf ((float) x);])
     if test "$ISINF_LIBM" != missing; then
       dnl Test whether isinf() on 'long double' works.
       gl_ISINFL_WORKS

m4/lstat.m4

@@ -1,4 +1,4 @@
-# serial 22
+# serial 23
 
 # Copyright (C) 1997-2001, 2003-2011 Free Software Foundation, Inc.
 #
@@ -15,7 +15,7 @@ AC_DEFUN([gl_FUNC_LSTAT],
   dnl "#define lstat stat", and lstat.c is a no-op.
   AC_CHECK_FUNCS_ONCE([lstat])
   if test $ac_cv_func_lstat = yes; then
-    AC_REQUIRE([AC_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
+    AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
     if test $gl_cv_func_lstat_dereferences_slashed_symlink = no; then
       REPLACE_LSTAT=1
     fi

m4/mmap-anon.m4

@@ -27,18 +27,18 @@ AC_DEFUN([gl_FUNC_MMAP_ANON],
   gl_have_mmap_anonymous=no
   if test $gl_have_mmap = yes; then
     AC_MSG_CHECKING([for MAP_ANONYMOUS])
-    AC_EGREP_CPP([I cant identify this map.], [
+    AC_EGREP_CPP([I cant identify this map], [
 #include <sys/mman.h>
 #ifdef MAP_ANONYMOUS
-    I cant identify this map.
+    I cant identify this map
 #endif
 ],
       [gl_have_mmap_anonymous=yes])
     if test $gl_have_mmap_anonymous != yes; then
-      AC_EGREP_CPP([I cant identify this map.], [
+      AC_EGREP_CPP([I cant identify this map], [
 #include <sys/mman.h>
 #ifdef MAP_ANON
-    I cant identify this map.
+    I cant identify this map
 #endif
 ],
         [AC_DEFINE([MAP_ANONYMOUS], [MAP_ANON],

m4/printf.m4

@@ -1,4 +1,4 @@
-# printf.m4 serial 42
+# printf.m4 serial 43
 dnl Copyright (C) 2003, 2007-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,
@@ -892,7 +892,8 @@ dnl On mingw, precisions larger than 512 are treated like 512, in integer,
 dnl floating-point or pointer output. On Solaris 10/x86, precisions larger
 dnl than 510 in floating-point output crash the program. On Solaris 10/SPARC,
 dnl precisions larger than 510 in floating-point output yield wrong results.
-dnl On BeOS, precisions larger than 1044 crash the program.
+dnl On AIX 7.1, precisions larger than 998 in floating-point output yield
+dnl wrong results. On BeOS, precisions larger than 1044 crash the program.
 dnl Result is gl_cv_func_printf_precision.
 
 AC_DEFUN([gl_PRINTF_PRECISION],
@@ -921,6 +922,9 @@ int main ()
   if (sprintf (buf, "%.511f %d", 1.0, 33, 44) < 511 + 5
       || buf[0] != '1')
     result |= 4;
+  if (sprintf (buf, "%.999f %d", 1.0, 33, 44) < 999 + 5
+      || buf[0] != '1')
+    result |= 4;
   return result;
 }]])],
         [gl_cv_func_printf_precision=yes],
@@ -1465,7 +1469,8 @@ dnl   Solaris 11 2010-11             .  .  #  #  #  .  .  #  .  .  .  #  .  .  .
 dnl   Solaris 10                     .  .  #  #  #  .  .  #  .  .  .  #  #  .  .  .  .  .  .  .
 dnl   Solaris 2.6 ... 9              #  .  #  #  #  #  .  #  .  .  .  #  #  .  .  .  #  .  .  .
 dnl   Solaris 2.5.1                  #  .  #  #  #  #  .  #  .  .  .  #  .  .  #  #  #  #  #  #
-dnl   AIX 5.2, 7.1                   .  .  #  #  #  .  .  .  .  .  .  #  .  .  .  .  .  .  .  .
+dnl   AIX 7.1                        .  .  #  #  #  .  .  .  .  .  .  #  #  .  .  .  .  .  .  .
+dnl   AIX 5.2                        .  .  #  #  #  .  .  .  .  .  .  #  .  .  .  .  .  .  .  .
 dnl   AIX 4.3.2, 5.1                 #  .  #  #  #  #  .  .  .  .  .  #  .  .  .  .  #  .  .  .
 dnl   HP-UX 11.31                    .  .  .  .  #  .  .  .  .  .  .  #  .  .  .  .  #  #  .  .
 dnl   HP-UX 11.{00,11,23}            #  .  .  .  #  #  .  .  .  .  .  #  .  .  .  .  #  #  .  #

m4/trunc.m4

@@ -1,4 +1,4 @@
-# trunc.m4 serial 6
+# trunc.m4 serial 7
 dnl Copyright (C) 2007, 2010-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,
@@ -56,10 +56,12 @@ AC_DEFUN([gl_FUNC_TRUNC],
 #include <math.h>
 ]gl_DOUBLE_MINUS_ZERO_CODE[
 ]gl_DOUBLE_SIGNBIT_CODE[
-int main()
+static double dummy (double f) { return 0; }
+int main (int argc, char *argv[])
 {
+  double (*my_trunc) (double) = argc ? trunc : dummy;
   /* Test whether trunc (-0.0) is -0.0.  */
-  if (signbitd (minus_zerod) && !signbitd (trunc (minus_zerod)))
+  if (signbitd (minus_zerod) && !signbitd (my_trunc (minus_zerod)))
     return 1;
   return 0;
 }

maint.mk

@@ -405,11 +405,11 @@ sc_prohibit_HAVE_MBRTOWC:
 	  $(_sc_search_regexp)
 
 # To use this "command" macro, you must first define two shell variables:
-# h: the header, enclosed in <> or ""
+# h: the header name, with no enclosing <> or ""
 # re: a regular expression that matches IFF something provided by $h is used.
 define _sc_header_without_use
   dummy=; : so we do not need a semicolon before each use;		\
-  h_esc=`echo "$$h"|sed 's/\./\\\\./g'`;				\
+  h_esc=`echo '[<"]'"$$h"'[">]'|sed 's/\./\\\\./g'`;			\
   if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then		\
     files=$$(grep -l '^# *include '"$$h_esc"				\
 	     $$($(VC_LIST_EXCEPT) | grep '\.c$$')) &&			\
@@ -422,42 +422,42 @@ endef
 
 # Prohibit the inclusion of assert.h without an actual use of assert.
 sc_prohibit_assert_without_use:
-	@h='<assert.h>' re='\<assert *\(' $(_sc_header_without_use)
+	@h='assert.h' re='\<assert *\(' $(_sc_header_without_use)
 
 # Prohibit the inclusion of close-stream.h without an actual use.
 sc_prohibit_close_stream_without_use:
-	@h='"close-stream.h"' re='\<close_stream *\(' $(_sc_header_without_use)
+	@h='close-stream.h' re='\<close_stream *\(' $(_sc_header_without_use)
 
 # Prohibit the inclusion of getopt.h without an actual use.
 sc_prohibit_getopt_without_use:
-	@h='<getopt.h>' re='\<getopt(_long)? *\(' $(_sc_header_without_use)
+	@h='getopt.h' re='\<getopt(_long)? *\(' $(_sc_header_without_use)
 
 # Don't include quotearg.h unless you use one of its functions.
 sc_prohibit_quotearg_without_use:
-	@h='"quotearg.h"' re='\<quotearg(_[^ ]+)? *\(' $(_sc_header_without_use)
+	@h='quotearg.h' re='\<quotearg(_[^ ]+)? *\(' $(_sc_header_without_use)
 
 # Don't include quote.h unless you use one of its functions.
 sc_prohibit_quote_without_use:
-	@h='"quote.h"' re='\<quote(_n)? *\(' $(_sc_header_without_use)
+	@h='quote.h' re='\<quote(_n)? *\(' $(_sc_header_without_use)
 
 # Don't include this header unless you use one of its functions.
 sc_prohibit_long_options_without_use:
-	@h='"long-options.h"' re='\<parse_long_options *\(' \
+	@h='long-options.h' re='\<parse_long_options *\(' \
 	  $(_sc_header_without_use)
 
 # Don't include this header unless you use one of its functions.
 sc_prohibit_inttostr_without_use:
-	@h='"inttostr.h"' re='\<(off|[iu]max|uint)tostr *\(' \
+	@h='inttostr.h' re='\<(off|[iu]max|uint)tostr *\(' \
 	  $(_sc_header_without_use)
 
 # Don't include this header unless you use one of its functions.
 sc_prohibit_ignore_value_without_use:
-	@h='"ignore-value.h"' re='\<ignore_(value|ptr) *\(' \
+	@h='ignore-value.h' re='\<ignore_(value|ptr) *\(' \
 	  $(_sc_header_without_use)
 
 # Don't include this header unless you use one of its functions.
 sc_prohibit_error_without_use:
-	@h='"error.h"' \
+	@h='error.h' \
 	re='\<error(_at_line|_print_progname|_one_per_line|_message_count)? *\('\
 	  $(_sc_header_without_use)
 
@@ -480,7 +480,7 @@ sc_prohibit_error_without_use:
 _xa1 = x(((2n?)?re|char|n(re|m)|[cmz])alloc|alloc_(oversized|die)|(mem|str)dup)
 _xa2 = X([CZ]|N?M)ALLOC
 sc_prohibit_xalloc_without_use:
-	@h='"xalloc.h"' \
+	@h='xalloc.h' \
 	re='\<($(_xa1)|$(_xa2)) *\('\
 	  $(_sc_header_without_use)
 
@@ -491,46 +491,46 @@ clear|delete|free|get_(first|next)|insert|lookup|print_statistics|reset_tuning
 _hash_fn = \<($(_hash_re)) *\(
 _hash_struct = (struct )?\<[Hh]ash_(table|tuning)\>
 sc_prohibit_hash_without_use:
-	@h='"hash.h"' \
+	@h='hash.h' \
 	re='$(_hash_fn)|$(_hash_struct)'\
 	  $(_sc_header_without_use)
 
 sc_prohibit_cloexec_without_use:
-	@h='"cloexec.h"' re='\<(set_cloexec_flag|dup_cloexec) *\(' \
+	@h='cloexec.h' re='\<(set_cloexec_flag|dup_cloexec) *\(' \
 	  $(_sc_header_without_use)
 
 sc_prohibit_posixver_without_use:
-	@h='"posixver.h"' re='\<posix2_version *\(' $(_sc_header_without_use)
+	@h='posixver.h' re='\<posix2_version *\(' $(_sc_header_without_use)
 
 sc_prohibit_same_without_use:
-	@h='"same.h"' re='\<same_name *\(' $(_sc_header_without_use)
+	@h='same.h' re='\<same_name *\(' $(_sc_header_without_use)
 
 sc_prohibit_hash_pjw_without_use:
-	@h='"hash-pjw.h"' \
+	@h='hash-pjw.h' \
 	re='\<hash_pjw *\(' \
 	  $(_sc_header_without_use)
 
 sc_prohibit_safe_read_without_use:
-	@h='"safe-read.h"' re='(\<SAFE_READ_ERROR\>|\<safe_read *\()' \
+	@h='safe-read.h' re='(\<SAFE_READ_ERROR\>|\<safe_read *\()' \
 	  $(_sc_header_without_use)
 
 sc_prohibit_argmatch_without_use:
-	@h='"argmatch.h"' \
+	@h='argmatch.h' \
 	re='(\<(ARRAY_CARDINALITY|X?ARGMATCH(|_TO_ARGUMENT|_VERIFY))\>|\<argmatch(_exit_fn|_(in)?valid) *\()' \
 	  $(_sc_header_without_use)
 
 sc_prohibit_canonicalize_without_use:
-	@h='"canonicalize.h"' \
+	@h='canonicalize.h' \
 	re='CAN_(EXISTING|ALL_BUT_LAST|MISSING)|canonicalize_(mode_t|filename_mode)' \
 	  $(_sc_header_without_use)
 
 sc_prohibit_root_dev_ino_without_use:
-	@h='"root-dev-ino.h"' \
+	@h='root-dev-ino.h' \
 	re='(\<ROOT_DEV_INO_(CHECK|WARN)\>|\<get_root_dev_ino *\()' \
 	  $(_sc_header_without_use)
 
 sc_prohibit_openat_without_use:
-	@h='"openat.h"' \
+	@h='openat.h' \
 	re='\<(openat_(permissive|needs_fchdir|(save|restore)_fail)|l?(stat|ch(own|mod))at|(euid)?accessat)\>' \
 	  $(_sc_header_without_use)
 
@@ -538,7 +538,7 @@ sc_prohibit_openat_without_use:
 ctype_re = isalnum|isalpha|isascii|isblank|iscntrl|isdigit|isgraph|islower\
 |isprint|ispunct|isspace|isupper|isxdigit|tolower|toupper
 sc_prohibit_c_ctype_without_use:
-	@h='[<"]c-ctype.h[">]' re='\<c_($(ctype_re)) *\(' \
+	@h='c-ctype.h' re='\<c_($(ctype_re)) *\(' \
 	  $(_sc_header_without_use)
 
 _empty =
@@ -574,50 +574,56 @@ _sig_syms_re = $(subst $(_sp),|,$(strip $(_sig_names) $(_sig_types_and_consts)))
 
 # Prohibit the inclusion of signal.h without an actual use.
 sc_prohibit_signal_without_use:
-	@h='<signal.h>'							\
+	@h='signal.h'							\
 	re='\<($(_sig_function_re)) *\(|\<($(_sig_syms_re))\>'		\
 	  $(_sc_header_without_use)
 
 # Don't include stdio--.h unless you use one of its functions.
 sc_prohibit_stdio--_without_use:
-	@h='"stdio--.h"' re='\<((f(re)?|p)open|tmpfile) *\('	\
+	@h='stdio--.h' re='\<((f(re)?|p)open|tmpfile) *\('		\
 	  $(_sc_header_without_use)
 
 # Don't include stdio-safer.h unless you use one of its functions.
 sc_prohibit_stdio-safer_without_use:
-	@h='"stdio-safer.h"' re='\<((f(re)?|p)open|tmpfile)_safer *\('	\
+	@h='stdio-safer.h' re='\<((f(re)?|p)open|tmpfile)_safer *\('	\
 	  $(_sc_header_without_use)
 
 # Prohibit the inclusion of strings.h without a sensible use.
 # Using the likes of bcmp, bcopy, bzero, index or rindex is not sensible.
 sc_prohibit_strings_without_use:
-	@h='<strings.h>'						\
+	@h='strings.h'							\
 	re='\<(strn?casecmp|ffs(ll)?)\>'				\
 	  $(_sc_header_without_use)
 
 # Get the list of symbol names with this:
-# perl -lne '/^# *define (\w+)\(/ and print $1' lib/intprops.h|grep -v '^s'|fmt
+# perl -lne '/^# *define ([A-Z]\w+)\(/ and print $1' lib/intprops.h|fmt
 _intprops_names =							\
   TYPE_IS_INTEGER TYPE_TWOS_COMPLEMENT TYPE_ONES_COMPLEMENT		\
   TYPE_SIGNED_MAGNITUDE TYPE_SIGNED TYPE_MINIMUM TYPE_MAXIMUM		\
-  INT_STRLEN_BOUND INT_BUFSIZE_BOUND
+  INT_BITS_STRLEN_BOUND INT_STRLEN_BOUND INT_BUFSIZE_BOUND		\
+  INT_ADD_RANGE_OVERFLOW INT_SUBTRACT_RANGE_OVERFLOW			\
+  INT_NEGATE_RANGE_OVERFLOW INT_MULTIPLY_RANGE_OVERFLOW			\
+  INT_DIVIDE_RANGE_OVERFLOW INT_REMAINDER_RANGE_OVERFLOW		\
+  INT_LEFT_SHIFT_RANGE_OVERFLOW INT_ADD_OVERFLOW INT_SUBTRACT_OVERFLOW	\
+  INT_NEGATE_OVERFLOW INT_MULTIPLY_OVERFLOW INT_DIVIDE_OVERFLOW		\
+  INT_REMAINDER_OVERFLOW INT_LEFT_SHIFT_OVERFLOW
 _intprops_syms_re = $(subst $(_sp),|,$(strip $(_intprops_names)))
 # Prohibit the inclusion of intprops.h without an actual use.
 sc_prohibit_intprops_without_use:
-	@h='"intprops.h"'						\
+	@h='intprops.h'							\
 	re='\<($(_intprops_syms_re)) *\('				\
 	  $(_sc_header_without_use)
 
 _stddef_syms_re = NULL|offsetof|ptrdiff_t|size_t|wchar_t
 # Prohibit the inclusion of stddef.h without an actual use.
 sc_prohibit_stddef_without_use:
-	@h='<stddef.h>'							\
+	@h='stddef.h'							\
 	re='\<($(_stddef_syms_re)) *\('					\
 	  $(_sc_header_without_use)
 
 # Don't include xfreopen.h unless you use one of its functions.
 sc_prohibit_xfreopen_without_use:
-	@h='"xfreopen.h"' re='\<xfreopen *\(' $(_sc_header_without_use)
+	@h='xfreopen.h' re='\<xfreopen *\(' $(_sc_header_without_use)
 
 sc_obsolete_symbols:
 	@prohibit='\<(HAVE''_FCNTL_H|O''_NDELAY)\>'			\
@@ -1106,6 +1112,7 @@ sc_copyright_check:
 # the other init.sh-using tests also get it right.
 _hv_file ?= $(srcdir)/tests/help-version
 _hv_regex_weak ?= ^ *\. .*/init\.sh"
+# Fix syntax-highlighters "
 _hv_regex_strong ?= ^ *\. "\$${srcdir=\.}/init\.sh"
 sc_cross_check_PATH_usage_in_tests:
 	@if test -f $(_hv_file); then					\
@@ -1133,6 +1140,14 @@ sc_Wundef_boolean:
 	halt='Use 0 or 1 for macro values'				\
 	  $(_sc_search_regexp)
 
+# Even if you use pathmax.h to guarantee that PATH_MAX is defined, it might
+# not be constant, or might overflow a stack.  In general, use PATH_MAX as
+# a limit, not an array or alloca size.
+sc_prohibit_path_max_allocation:
+	@prohibit='(\balloca *\([^)]*|\[[^]]*)PATH_MAX'			\
+	halt='Avoid stack allocations of size PATH_MAX'			\
+	  $(_sc_search_regexp)
+
 sc_vulnerable_makefile_CVE-2009-4029:
 	@prohibit='perm -777 -exec chmod a\+rwx|chmod 777 \$$\(distdir\)' \
 	in_files=$$(find $(srcdir) -name Makefile.in)			\

meta/guild.in

@@ -1,6 +1,8 @@
 #!/bin/sh
 # -*- scheme -*-
-exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
+prefix="@prefix@"
+exec_prefix="@exec_prefix@"
+exec ${GUILE:-@bindir@/@guile_program_name@} $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
 !#
 
 ;;;; guild --- running scripts bundled with Guile
@@ -25,6 +27,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
 
 (define-module (guild)
   #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 command-line)
   #:autoload (ice-9 format) (format))
 
 ;; Hack to provide scripts with the bug-report address.
@@ -37,23 +40,11 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
   '((help (single-char #\h))
     (version (single-char #\v))))
 
-(define (display-help)
-  (display "\
-Usage: guild --version
-       guild --help
-       guild PROGRAM [ARGS]
-
-If PROGRAM is \"list\" or omitted, display available scripts, otherwise
-PROGRAM is run with ARGS.
-"))
-
 (define (display-version)
-  (format #t "guild (GNU Guile ~A) ~A
+  (version-etc "@PACKAGE_NAME@"
-Copyright (C) 2010 Free Software Foundation, Inc.
+               (version)
-License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
+               #:command-name "guild"
-This is free software: you are free to change and redistribute it.
+               #:license *LGPLv3+*))
-There is NO WARRANTY, to the extent permitted by law.
-" (version) (effective-version)))
 
 (define (find-script s)
   (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
@@ -62,20 +53,17 @@ There is NO WARRANTY, to the extent permitted by law.
   (if (defined? 'setlocale)
       (setlocale LC_ALL ""))
 
-  (let ((options (getopt-long args *option-grammar*
+  (let* ((options (getopt-long args *option-grammar*
-                              #:stop-at-first-non-option #t)))
+                               #:stop-at-first-non-option #t))
+         (args (option-ref options '() '())))
     (cond
      ((option-ref options 'help #f)
-      (display-help)
+      (apply (module-ref (resolve-module '(scripts help)) 'main) args)
       (exit 0))
      ((option-ref options 'version #f)
       (display-version)
       (exit 0))
-     (else
+     ((find-script (if (null? args) "help" (car args)))
-      (let ((args (option-ref options '() '())))
-        (cond ((find-script (if (null? args)
-                                "list"
-                                (car args)))
       => (lambda (mod)
            (exit (apply (module-ref mod 'main) (if (null? args)
                                                    '()
@@ -84,5 +72,5 @@ There is NO WARRANTY, to the extent permitted by law.
       (format (current-error-port)
               "guild: unknown script ~s~%" (car args))
       (format (current-error-port)
-                       "Try `guild --help' for more information.~%")
+              "Try `guild help' for more information.~%")
-               (exit 1))))))))
+      (exit 1)))))

meta/uninstalled-env.in

@@ -136,4 +136,8 @@ if test "x${top_srcdir}" != "x${top_builddir}"; then
 fi
 export PATH
 
+# Define $GUILE, used by `guild'.
+GUILE="${top_builddir}/meta/guile"
+export GUILE
+
 exec "$@"

module/Makefile.am

@@ -146,7 +146,6 @@ BRAINFUCK_LANG_SOURCES =			\
   language/brainfuck/spec.scm
 
 SCRIPTS_SOURCES =				\
-  scripts/PROGRAM.scm				\
   scripts/autofrisk.scm				\
   scripts/compile.scm				\
   scripts/disassemble.scm			\
@@ -154,6 +153,7 @@ SCRIPTS_SOURCES =				\
   scripts/doc-snarf.scm				\
   scripts/frisk.scm				\
   scripts/generate-autoload.scm			\
+  scripts/help.scm				\
   scripts/lint.scm				\
   scripts/list.scm				\
   scripts/punify.scm				\
@@ -356,6 +356,7 @@ LIB_SOURCES =					\
   texinfo/serialize.scm
 
 WEB_SOURCES =					\
+  web/client.scm				\
   web/http.scm					\
   web/request.scm				\
   web/response.scm				\

module/ice-9/boot-9.scm

@@ -3414,6 +3414,15 @@ module '(ice-9 q) '(make-q q-length))}."
   '(#:warnings (unbound-variable arity-mismatch format)))
 
 (define* (load-in-vicinity dir path #:optional reader)
+  (define (canonical->suffix canon)
+    (cond
+     ((string-prefix? "/" canon) canon)
+     ((and (> (string-length canon) 2)
+           (eqv? (string-ref canon 1) #\:))
+      ;; Paths like C:... transform to /C...
+      (string-append "/" (substring canon 0 1) (substring canon 2)))
+     (else canon)))
+
   ;; Returns the .go file corresponding to `name'. Does not search load
   ;; paths, only the fallback path. If the .go file is missing or out of
   ;; date, and auto-compilation is enabled, will try auto-compilation, just
@@ -3425,11 +3434,12 @@ module '(ice-9 q) '(make-q q-length))}."
   ;; partially duplicates functionality from (system base compile).
   ;;
   (define (compiled-file-name canon-path)
+    ;; FIXME: would probably be better just to append SHA1(canon-path)
+    ;; to the %compile-fallback-path, to avoid deep directory stats.
     (and %compile-fallback-path
          (string-append
           %compile-fallback-path
-          ;; no need for '/' separator here, canon-path is absolute
+          (canonical->suffix canon-path)
-          canon-path
           (cond ((or (null? %load-compiled-extensions)
                      (string-null? (car %load-compiled-extensions)))
                  (warn "invalid %load-compiled-extensions"

module/oop/goops.scm

@@ -398,13 +398,11 @@
                   names))
         (goops-error "no prefixes supplied"))))
 
-(define (make-generic . name)
+(define* (make-generic #:optional name)
-  (let ((name (and (pair? name) (car name))))
+  (make <generic> #:name name))
-    (make <generic> #:name name)))
 
-(define (make-extended-generic gfs . name)
+(define* (make-extended-generic gfs #:optional name)
-  (let* ((name (and (pair? name) (car name)))
+  (let* ((gfs (if (list? gfs) gfs (list gfs)))
-	 (gfs (if (pair? gfs) gfs (list gfs)))
 	 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
     (let ((ans (if gws?
 		   (let* ((sname (and name (make-setter-name name)))
@@ -441,8 +439,7 @@
 			 (delq! eg (slot-ref gf 'extended-by))))
 	    gfs))
 
-(define (ensure-generic old-definition . name)
+(define* (ensure-generic old-definition #:optional name)
-  (let ((name (and (pair? name) (car name))))
   (cond ((is-a? old-definition <generic>) old-definition)
         ((procedure-with-setter? old-definition)
          (make <generic-with-setter>
@@ -452,7 +449,7 @@
         ((procedure? old-definition)
          (if (generic-capability? old-definition) old-definition
              (make <generic> #:name name #:default old-definition)))
-	  (else (make <generic> #:name name)))))
+        (else (make <generic> #:name name))))
 
 ;; same semantics as <generic>
 (define-syntax define-accessor
@@ -466,15 +463,13 @@
 (define (make-setter-name name)
   (string->symbol (string-append "setter:" (symbol->string name))))
 
-(define (make-accessor . name)
+(define* (make-accessor #:optional name)
-  (let ((name (and (pair? name) (car name))))
   (make <accessor>
     #:name name
     #:setter (make <generic>
-		         #:name (and name (make-setter-name name))))))
+               #:name (and name (make-setter-name name)))))
 
-(define (ensure-accessor proc . name)
+(define* (ensure-accessor proc #:optional name)
-  (let ((name (and (pair? name) (car name))))
   (cond ((and (is-a? proc <accessor>)
               (is-a? (setter proc) <generic>))
          proc)
@@ -493,7 +488,7 @@
                               (ensure-generic proc name))
                           name))
         (else
-	   (make-accessor name)))))
+         (make-accessor name))))
 
 (define (upgrade-accessor generic setter)
   (let ((methods (slot-ref generic 'methods))

module/scripts/PROGRAM.scm

@@ -1,40 +0,0 @@
-;;; PROGRAM --- Does something
-
-;; 	Copyright (C) 2002, 2006 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, 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 software; see the file COPYING.LESSER.  If
-;; not, write to the Free Software Foundation, Inc., 51 Franklin
-;; Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Author: J.R.Hacker
-
-;;; Commentary:
-
-;; Usage: PROGRAM [ARGS]
-;;
-;; PROGRAM does something.
-;;
-;; TODO: Write it!
-
-;;; Code:
-
-(define-module (scripts PROGRAM)
-  :export (PROGRAM))
-
-(define (PROGRAM . args)
-  #t)
-
-(define main PROGRAM)
-
-;;; PROGRAM ends here

module/scripts/api-diff.scm

@@ -1,6 +1,6 @@
 ;;; api-diff --- diff guile-api.alist files
 
-;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2006, 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
@@ -46,6 +46,9 @@
   :autoload (srfi srfi-13) (string-tokenize)
   :export (api-diff))
 
+(define %include-in-guild-list #f)
+(define %summary "Show differences between two scan-api files.")
+
 (define (read-alist-file file)
   (with-input-from-file file
     (lambda () (read))))

module/scripts/autofrisk.scm

@@ -1,6 +1,6 @@
 ;;; autofrisk --- Generate module checks for use with auto* tools
 
-;; 	Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 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
@@ -62,6 +62,9 @@
   :use-module (scripts frisk)
   :export (autofrisk))
 
+(define %include-in-guild-list #f)
+(define %summary "Generate snippets for use in configure.ac files.")
+
 (define *recognized-keys* '(files-glob
                             non-critical-external
                             non-critical-internal

module/scripts/compile.scm

@@ -37,6 +37,8 @@
   #:use-module (ice-9 format)
   #:export (compile))
 
+(define %summary "Compile a file.")
+
 
 (define (fail . messages)
   (format (current-error-port) "error: ~{~a~}~%" messages)

module/scripts/disassemble.scm

@@ -1,6 +1,6 @@
 ;;; Disassemble --- Disassemble .go files into something human-readable
 
-;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright 2005, 2008, 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
@@ -32,6 +32,8 @@
                 #:renamer (symbol-prefix-proc 'asm:))
   #:export (disassemble))
 
+(define %summary "Disassemble a compiled .go file.")
+
 (define (disassemble . files)
   (for-each (lambda (file)
               (asm:disassemble (load-objcode file)))

module/scripts/display-commentary.scm

@@ -1,6 +1,6 @@
 ;;; display-commentary --- As advertized
 
-;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2006, 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
@@ -33,6 +33,8 @@
   :use-module (ice-9 documentation)
   :export (display-commentary))
 
+(define %summary "Display the Commentary section from a file or module.")
+
 (define (display-commentary-one file)
   (format #t "~A commentary:\n~A" file (file-commentary file)))
 

module/scripts/doc-snarf.scm

@@ -1,6 +1,6 @@
 ;;; doc-snarf --- Extract documentation from source files
 
-;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2006, 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
@@ -83,6 +83,8 @@ This procedure foos, or bars, depending on the argument @var{braz}.
   :use-module (ice-9 rdelim)
   :export (doc-snarf))
 
+(define %summary "Snarf out documentation from a file.")
+
 (define command-synopsis
   '((version (single-char #\v) (value #f))
     (help    (single-char #\h) (value #f))

module/scripts/frisk.scm

@@ -1,6 +1,6 @@
 ;;; frisk --- Grok the module interfaces of a body of files
 
-;; 	Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2006, 2010, 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
@@ -103,6 +103,9 @@
            mod-up-ls mod-down-ls mod-int?
            edge-type edge-up edge-down))
 
+(define %include-in-guild-list #f)
+(define %summary "Show dependency information for a module.")
+
 (define *default-module* '(guile-user))
 
 (define (grok-proc default-module note-use!)

module/scripts/generate-autoload.scm

@@ -1,6 +1,6 @@
 ;;; generate-autoload --- Display define-module form with autoload info
 
-;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2006, 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
@@ -59,6 +59,9 @@
 (define-module (scripts generate-autoload)
   :export (generate-autoload))
 
+(define %include-in-guild-list #f)
+(define %summary "Generate #:autoload clauses for a module.")
+
 (define (autoload-info file)
   (let ((p (open-input-file file)))
     (let loop ((form (read p)) (module-name #f) (exports '()))

module/scripts/help.scm

@@ -0,0 +1,148 @@
+;;; Help --- Show help on guild commands
+
+;;;; 	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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
+
+;;; Commentary:
+
+;; Usage: help
+;;
+;; Show help for Guild scripts.
+
+;;; Code:
+
+(define-module (scripts help)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 documentation)
+  #:use-module ((srfi srfi-1) #:select (fold append-map))
+  #:export (main))
+
+(define %summary "Show a brief help message.")
+
+
+(define (directory-files dir)
+  (if (and (file-exists? dir) (file-is-directory? dir))
+      (let ((dir-stream (opendir dir)))
+        (let loop ((new (readdir dir-stream))
+                   (acc '()))
+          (if (eof-object? new)
+              (begin
+                (closedir dir-stream)
+                acc)
+              (loop (readdir dir-stream)
+                    (if (or (string=? "."  new)             ; ignore
+                            (string=? ".." new))            ; ignore
+                        acc
+                        (cons new acc))))))
+      '()))
+
+(define (strip-extensions path)
+  (or-map (lambda (ext)
+            (and
+             (string-suffix? ext path)
+             ;; We really can't be adding e.g. ChangeLog-2008 to the set
+             ;; of runnable scripts, just because "" is a valid
+             ;; extension, by default.  So hack around that here.
+             (not (string-null? ext))
+             (substring path 0
+                        (- (string-length path) (string-length ext)))))
+          (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+  (cond ((null? l) l)
+        ((null? (cdr l)) l)
+        ((equal? (car l) (cadr l)) (unique (cdr l)))
+        (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+  (let ((shead (map symbol->string head)))
+    (unique
+     (sort
+      (append-map (lambda (path)
+                    (fold (lambda (x rest)
+                            (let ((stripped (strip-extensions x)))
+                              (if stripped (cons stripped rest) rest)))
+                          '()
+                          (directory-files
+                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
+                  %load-path)
+      string<?))))
+
+(define (list-commands all?)
+  (display "\
+Usage: guild COMMAND [ARGS]
+Run command-line scripts provided by GNU Guile and related programs.
+
+Commands:
+")
+
+  (for-each
+   (lambda (name)
+     (let* ((modname `(scripts ,(string->symbol name)))
+            (mod (resolve-module modname #:ensure #f))
+            (summary (and mod (and=> (module-variable mod '%summary)
+                                     variable-ref))))
+       (if (and mod
+                (or all?
+                    (let ((v (module-variable mod '%include-in-guild-list)))
+                      (if v (variable-ref v) #t))))
+           (if summary
+               (format #t "  ~A ~23t~a\n" name summary)
+               (format #t "  ~A\n" name)))))
+   (find-submodules '(scripts)))
+  (format #t "
+For help on a specific command, try \"guild help COMMAND\".
+
+Report guild bugs to ~a
+GNU Guile home page: <http://www.gnu.org/software/guile/>
+General help using GNU software: <http://www.gnu.org/gethelp/>
+For complete documentation, run: info guile 'Using Guile Tools'
+" %guile-bug-report-address))
+
+(define (module-commentary mod)
+  (file-commentary
+   (%search-load-path (module-filename mod))))
+
+(define (main . args)
+  (cond
+   ((null? args)
+    (list-commands #f))
+   ((or (equal? args '("--all")) (equal? args '("-a")))
+    (list-commands #t))
+   ((not (string-prefix? "-" (car args)))
+    ;; help for particular command
+    (let* ((name (car args))
+           (mod (resolve-module `(scripts ,(string->symbol name))
+                                #:ensure #f)))
+      (if mod
+          (let ((commentary (module-commentary mod)))
+            (if commentary
+                (display commentary)
+                (format #t "No documentation found for command \"~a\".\n"
+                        name)))
+          (begin
+            (format #t "No command named \"~a\".\n" name)
+            (exit 1)))))
+   (else
+    (display "Usage: guild help
+       guild help --all
+       guild help COMMAND
+
+Show a help on guild commands.  With --all, show arcane incantations as
+well.  With COMMAND, show more detailed help for a particular command.
+")
+    (exit 1))))

module/scripts/lint.scm

@@ -105,6 +105,9 @@
   #:use-module (ice-9 format)
   #:export (lint))
 
+(define %include-in-guild-list #f)
+(define %summary "Check for bugs and style errors in a Scheme file.")
+
 (define (lint filename)
   (let ((module-name (scan-file-for-module-name filename))
 	(free-vars (uniq (scan-file-for-free-variables filename))))

module/scripts/list.scm

@@ -26,9 +26,11 @@
 ;;; Code:
 
 (define-module (scripts list)
-  #:use-module ((srfi srfi-1) #:select (fold append-map))
   #:export (list-scripts))
 
+(define %include-in-guild-list #f)
+(define %summary "An alias for \"help\".")
+
 
 (define (directory-files dir)
   (if (and (file-exists? dir) (file-is-directory? dir))
@@ -50,6 +52,10 @@
   (or-map (lambda (ext)
             (and
              (string-suffix? ext path)
+             ;; We really can't be adding e.g. ChangeLog-2008 to the set
+             ;; of runnable scripts, just because "" is a valid
+             ;; extension, by default.  So hack around that here.
+             (not (string-null? ext))
              (substring path 0
                         (- (string-length path) (string-length ext)))))
           (append %load-compiled-extensions %load-extensions)))
@@ -80,4 +86,5 @@
               (format #t "~A\n" x))
             (find-submodules '(scripts))))
 
-(define main list-scripts)
+(define (main . args)
+  (apply (@@ (scripts help) main) args))

module/scripts/punify.scm

@@ -41,6 +41,9 @@
 (define-module (scripts punify)
   :export (punify))
 
+(define %include-in-guild-list #f)
+(define %summary "Strip comments and whitespace from a Scheme file.")
+
 (define (write-punily form)
   (cond ((and (list? form) (not (null? form)))
          (let ((first (car form)))

module/scripts/read-rfc822.scm

@@ -1,6 +1,6 @@
 ;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
 
-;; 	Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2004, 2006, 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
@@ -49,6 +49,9 @@
   :autoload (srfi srfi-13) (string-join)
   :export (read-rfc822 read-rfc822-silently))
 
+(define %include-in-guild-list #f)
+(define %summary "Validate an RFC822-style file.")
+
 (define from-line-rx   (make-regexp "^From "))
 (define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
 (define header-cont-rx (make-regexp "^[ \t]+"))

module/scripts/read-scheme-source.scm

@@ -1,6 +1,6 @@
 ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
 
-;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2006, 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
@@ -91,6 +91,9 @@
            quoted?
            clump))
 
+(define %include-in-guild-list #f)
+(define %summary "Print a parsed representation of a Scheme file.")
+
 ;; Try to figure out what FORM is and its various attributes.
 ;; Call proc NOTE! with key (a symbol) and value.
 ;;

module/scripts/read-text-outline.scm

@@ -1,6 +1,6 @@
 ;;; read-text-outline --- Read a text outline and display it as a sexp
 
-;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2006, 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
@@ -118,6 +118,9 @@
   :autoload (ice-9 rdelim) (read-line)
   :autoload (ice-9 getopt-long) (getopt-long))
 
+(define %include-in-guild-list #f)
+(define %summary "Convert textual outlines to s-expressions.")
+
 (define (?? symbol)
   (let ((name (symbol->string symbol)))
     (string=? "?" (substring name (1- (string-length name))))))

module/scripts/scan-api.scm

@@ -1,6 +1,6 @@
 ;;; scan-api --- Scan and group interpreter and libguile interface elements
 
-;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2006, 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
@@ -65,6 +65,9 @@
   :use-module (ice-9 regex)
   :export (scan-api))
 
+(define %include-in-guild-list #f)
+(define %summary "Generate an API description for a Guile extension.")
+
 (define put set-object-property!)
 (define get object-property)
 

module/scripts/snarf-check-and-output-texi.scm

@@ -1,6 +1,6 @@
 ;;; snarf-check-and-output-texi --- called by the doc snarfer.
 
-;; 	Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2006, 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
@@ -26,6 +26,9 @@
     :use-module (ice-9 match)
     :export (snarf-check-and-output-texi))
 
+(define %include-in-guild-list #f)
+(define %summary "Transform snarfed .doc files into texinfo documentation.")
+
 ;;; why aren't these in some module?
 
 (define-macro (when cond . body)

module/scripts/snarf-guile-m4-docs.scm

@@ -1,6 +1,6 @@
 ;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
 
-;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2006, 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
@@ -35,6 +35,9 @@
   :use-module (ice-9 rdelim)
   :export (snarf-guile-m4-docs))
 
+(define %include-in-guild-list #f)
+(define %summary "Snarf out texinfo documentation from .m4 files.")
+
 (define (display-texi lines)
   (display "@deffn {Autoconf Macro}")
   (for-each (lambda (line)

module/scripts/summarize-guile-TODO.scm

@@ -1,6 +1,6 @@
 ;;; summarize-guile-TODO --- Display Guile TODO list in various ways
 
-;; 	Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
+;; 	Copyright (C) 2002, 2006, 2010, 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
@@ -73,6 +73,9 @@
   :autoload (ice-9 common-list) (remove-if-not)
   :export (summarize-guile-TODO))
 
+(define %include-in-guild-list #f)
+(define %summary "A quaint relic of the past.")
+
 (define put set-object-property!)
 (define get object-property)
 

module/scripts/use2dot.scm

@@ -1,6 +1,6 @@
 ;;; use2dot --- Display module dependencies as a DOT specification
 
-;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2006, 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
@@ -53,6 +53,8 @@
                :select (make-frisker edge-type edge-up edge-down))
   :export (use2dot))
 
+(define %summary "Print a module's dependencies in graphviz format.")
+
 (define *default-module* '(guile-user))
 
 (define (q s)                           ; quote

module/system/base/compile.scm

@@ -103,6 +103,16 @@
 ;;;
 ;;; See also boot-9.scm:load.
 (define (compiled-file-name file)
+  ;; FIXME: would probably be better just to append SHA1(canon-path)
+  ;; to the %compile-fallback-path, to avoid deep directory stats.
+  (define (canonical->suffix canon)
+    (cond
+     ((string-prefix? "/" canon) canon)
+     ((and (> (string-length canon) 2)
+           (eqv? (string-ref canon 1) #\:))
+      ;; Paths like C:... transform to /C...
+      (string-append "/" (substring canon 0 1) (substring canon 2)))
+     (else canon)))
   (define (compiled-extension)
     (cond ((or (null? %load-compiled-extensions)
                (string-null? (car %load-compiled-extensions)))
@@ -113,9 +123,7 @@
   (and %compile-fallback-path
        (let ((f (string-append
                  %compile-fallback-path
-                 ;; no need for '/' separator here, canonicalize-path
+                 (canonical->suffix (canonicalize-path file))
-                 ;; will give us an absolute path
-                 (canonicalize-path file)
                  (compiled-extension))))
          (and (false-if-exception (ensure-writable-dir (dirname f)))
               f))))

module/system/repl/command.scm

@@ -485,21 +485,19 @@ Disassemble a file."
   "time EXP
 Time execution."
   (let* ((gc-start (gc-run-time))
-	 (tms-start (times))
+	 (real-start (get-internal-real-time))
+	 (run-start (get-internal-run-time))
 	 (result (repl-eval repl (repl-parse repl form)))
-	 (tms-end (times))
+	 (run-end (get-internal-run-time))
+	 (real-end (get-internal-real-time))
 	 (gc-end (gc-run-time)))
-    (define (get proc start end)
+    (define (diff start end)
-      (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
+      (/ (- end start) 1.0 internal-time-units-per-second))
     (repl-print repl result)
-    (display "clock utime stime cutime cstime gctime\n")
+    (format #t ";; ~,6Fs real time, ~,6Fs run time.  ~,6Fs spent in GC.\n"
-    (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
+            (diff real-start real-end)
-	    (get tms:clock tms-start tms-end)
+            (diff run-start run-end)
-	    (get tms:utime tms-start tms-end)
+            (diff gc-start gc-end))
-	    (get tms:stime tms-start tms-end)
-	    (get tms:cutime tms-start tms-end)
-	    (get tms:cstime tms-start tms-end)
-	    (get identity gc-start gc-end))
     result))
 
 (define-meta-command (profile repl (form) . opts)

module/web/client.scm

@@ -0,0 +1,116 @@
+;;; Web client
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; (web client) is a simple HTTP URL fetcher for Guile.
+;;;
+;;; In its current incarnation, (web client) is synchronous.  If you
+;;; want to fetch a number of URLs at once, probably the best thing to
+;;; do is to write an event-driven URL fetcher, similar in structure to
+;;; the web server.
+;;;
+;;; Another option, good but not as performant, would be to use threads,
+;;; possibly via par-map or futures.
+;;;
+;;; Code:
+
+(define-module (web client)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (open-socket-for-uri
+            http-get))
+
+(define (open-socket-for-uri uri)
+  (let* ((ai (car (getaddrinfo (uri-host uri)
+                               (cond
+                                ((uri-port uri) => number->string)
+                                (else (symbol->string (uri-scheme uri)))))))
+         (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                     (addrinfo:protocol ai))))
+    (set-port-encoding! s "ISO-8859-1")
+    (connect s (addrinfo:addr ai))
+    ;; Buffer input and output on this port.
+    (setvbuf s _IOFBF)
+    ;; Enlarge the receive buffer.
+    (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+    s))
+
+(define (decode-string bv encoding)
+  (if (string-ci=? encoding "utf-8")
+      (utf8->string bv)
+      (let ((p (open-bytevector-input-port bv)))
+        (set-port-encoding! p encoding)
+        (let ((res (read-delimited "" p)))
+          (close-port p)
+          res))))
+
+(define (text-type? type)
+  (let ((type (symbol->string type)))
+    (or (string-prefix? "text/" type)
+        (string-suffix? "/xml" type)
+        (string-suffix? "+xml" type))))
+
+;; Logically the inverse of (web server)'s `sanitize-response'.
+;;
+(define (decode-response-body response body)
+  ;; `body' is either #f or a bytevector.
+  (cond
+   ((not body) body)
+   ((bytevector? body)
+    (let ((rlen (response-content-length response))
+          (blen (bytevector-length body)))
+      (cond
+       ((and rlen (not (= rlen blen)))
+        (error "bad content-length" rlen blen))
+       ((response-content-type response)
+        => (lambda (type)
+             (cond
+              ((text-type? (car type))
+               (decode-string body (or (assq-ref (cdr type) 'charset)
+                                       "iso-8859-1")))
+              (else body))))
+       (else body))))
+   (else
+    (error "unexpected body type" body))))
+
+(define* (http-get uri #:key (port (open-socket-for-uri uri))
+                   (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
+                   (decode-body? #t))
+  (let ((req (build-request uri #:version version
+                            #:headers (if keep-alive?
+                                          extra-headers
+                                          (cons '(connection close)
+                                                extra-headers)))))
+    (write-request req port)
+    (force-output port)
+    (if (not keep-alive?)
+        (shutdown port 1))
+    (let* ((res (read-response port))
+           (body (read-response-body res)))
+      (if (not keep-alive?)
+          (close-port port))
+      (values res
+              (if decode-body?
+                  (decode-response-body res body)
+                  body)))))

module/web/request.scm

@@ -151,6 +151,8 @@
                         (validate-headers? #t))
   "Construct an HTTP request object. If @var{validate-headers?} is true,
 the headers are each run through their respective validators."
+  (let ((needs-host? (and (equal? version '(1 . 1))
+                          (not (assq-ref headers 'host)))))
     (cond
      ((not (and (pair? version)
                 (non-negative-integer? (car version))
@@ -162,10 +164,18 @@ the headers are each run through their respective validators."
       (bad-request "Missing port for message ~a" method))
      ((not (list? meta))
       (bad-request "Bad metadata alist" meta))
+     ((and needs-host? (not (uri-host uri)))
+      (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
+                   uri))
      (else
       (if validate-headers?
           (validate-headers headers))))
-  (make-request method uri version headers meta port))
+    (make-request method uri version
+                  (if needs-host?
+                      (acons 'host (cons (uri-host uri) (uri-port uri))
+                             headers)
+                      headers)
+                  meta port)))
 
 (define* (read-request port #:optional (meta '()))
   "Read an HTTP request from @var{port}, optionally attaching the given

test-suite/tests/modules.test

@@ -290,6 +290,10 @@
            (import2 (make-module))
            (handler-invoked? #f)
            (handler (lambda (module name int1 val1 int2 val2 var val)
+                      ;; We expect both VAR and VAL to be #f, as there
+                      ;; is no previous binding for 'imported in M.
+                      (if var (error "unexpected var" var))
+                      (if val (error "unexpected val" val))
                       (set! handler-invoked? #t)
                       ;; Keep the first binding.
                       (or var (module-local-variable int1 name)))))

test-suite/tests/reader.test

@@ -428,6 +428,7 @@
 
 (with-test-prefix "#{}#"
   (pass-if (equal? (read-string "#{}#") '#{}#))
+  (pass-if (not (equal? (read-string "(a #{.}# b)") '(a . b))))
   (pass-if (equal? (read-string "#{a}#") 'a))
   (pass-if (equal? (read-string "#{a b}#") '#{a b}#))
   (pass-if-exception "#{" exception:eof-in-symbol

test-suite/tests/srfi-4.test

@@ -436,7 +436,26 @@
             (make-c32vector 4 7)))
 
   (pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
-    (c32vector? #c32(+inf.0 -inf.0 +nan.0))))
+    (c32vector? #c32(+inf.0 -inf.0 +nan.0)))
+
+  (pass-if "generalized-vector-ref"
+    (let ((v (c32vector 1+1i)))
+      (= (c32vector-ref v 0)
+         (generalized-vector-ref v 0))))
+
+  (pass-if "generalized-vector-set!"
+    (let ((x 1+1i)
+          (v (c32vector 0)))
+      (generalized-vector-set! v 0 x)
+      (= x (generalized-vector-ref v 0))))
+
+  (pass-if-exception "generalized-vector-ref, out-of-range"
+    exception:out-of-range
+    (generalized-vector-ref (c32vector 1.0) 1))
+
+  (pass-if-exception "generalized-vector-set!, out-of-range"
+    exception:out-of-range
+    (generalized-vector-set! (c32vector 1.0) 1 2.0)))
 
 (with-test-prefix "c64 vectors"
 
@@ -476,4 +495,23 @@
             (make-c64vector 4 7)))
 
   (pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
-    (c64vector? #c64(+inf.0 -inf.0 +nan.0))))
+    (c64vector? #c64(+inf.0 -inf.0 +nan.0)))
+
+  (pass-if "generalized-vector-ref"
+    (let ((v (c64vector 1+1i)))
+      (= (c64vector-ref v 0)
+         (generalized-vector-ref v 0))))
+
+  (pass-if "generalized-vector-set!"
+    (let ((x 1+1i)
+          (v (c64vector 0)))
+      (generalized-vector-set! v 0 x)
+      (= x (generalized-vector-ref v 0))))
+
+  (pass-if-exception "generalized-vector-ref, out-of-range"
+    exception:out-of-range
+    (generalized-vector-ref (c64vector 1.0) 1))
+
+  (pass-if-exception "generalized-vector-set!, out-of-range"
+    exception:out-of-range
+    (generalized-vector-set! (c64vector 1.0) 1 2.0)))

test-suite/tests/web-request.test

@@ -47,6 +47,10 @@ Accept-Language: en-gb, en;q=0.9\r
         (set! r (read-request (open-input-string example-1)))
         (request? r)))
     
+    (pass-if (equal?
+              (request-host (build-request (string->uri "http://www.gnu.org/")))
+              '("www.gnu.org" . #f)))
+    
     (pass-if (equal? (request-method r) 'GET))
     
     (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))