summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-07-25 18:26:37 +0200
committerAndy Wingo <wingo@pobox.com>2011-07-25 18:26:37 +0200
commitab4bc85398a14b62b58694bab83c63be286b2fd5 (patch)
tree84bfe7b0b6064016bcfadb76ec95d07410654fe8
parentf29c300507da21a667f5b82e75300f8009eab9cc (diff)
parentf4b7d918eff9770f09893b023fd834f5c0bc33d1 (diff)
downloadguile-ab4bc85398a14b62b58694bab83c63be286b2fd5.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION test-suite/tests/srfi-4.test
-rw-r--r--.gitignore1
-rw-r--r--GUILE-VERSION4
-rw-r--r--NEWS7
-rw-r--r--acinclude.m43
-rw-r--r--configure.ac7
-rw-r--r--doc/ref/Makefile.am1
-rw-r--r--doc/ref/goops.texi5
-rw-r--r--doc/ref/scheme-using.texi8
-rw-r--r--doc/release.org164
-rw-r--r--lib/Makefile.am4
-rw-r--r--lib/float.c33
-rw-r--r--lib/float.in.h111
-rw-r--r--lib/isinf.c9
-rw-r--r--lib/pathmax.h15
-rw-r--r--lib/pipe2.c15
-rw-r--r--lib/stat.c8
-rw-r--r--lib/unistd.in.h2
-rw-r--r--libguile/Makefile.am1
-rw-r--r--libguile/bytevectors.c90
-rw-r--r--libguile/filesys.c28
-rw-r--r--libguile/goops.c15
-rw-r--r--libguile/i18n.c2
-rw-r--r--libguile/load.c25
-rw-r--r--libguile/modules.c75
-rw-r--r--libguile/read.c11
-rw-r--r--libguile/threads.c18
-rw-r--r--libguile/vm-engine.c18
-rw-r--r--libguile/vm-engine.h8
-rw-r--r--m4/alloca.m479
-rw-r--r--m4/ceil.m416
-rw-r--r--m4/float_h.m435
-rw-r--r--m4/floor.m48
-rw-r--r--m4/gnulib-comp.m44
-rw-r--r--m4/isinf.m44
-rw-r--r--m4/lstat.m44
-rw-r--r--m4/mmap-anon.m48
-rw-r--r--m4/printf.m411
-rw-r--r--m4/trunc.m48
-rw-r--r--maint.mk79
-rwxr-xr-xmeta/guild.in56
-rw-r--r--meta/uninstalled-env.in4
-rw-r--r--module/Makefile.am3
-rw-r--r--module/ice-9/boot-9.scm14
-rw-r--r--module/oop/goops.scm87
-rw-r--r--module/scripts/PROGRAM.scm40
-rw-r--r--module/scripts/api-diff.scm5
-rw-r--r--module/scripts/autofrisk.scm5
-rw-r--r--module/scripts/compile.scm2
-rw-r--r--module/scripts/disassemble.scm4
-rw-r--r--module/scripts/display-commentary.scm4
-rw-r--r--module/scripts/doc-snarf.scm4
-rw-r--r--module/scripts/frisk.scm5
-rw-r--r--module/scripts/generate-autoload.scm5
-rw-r--r--module/scripts/help.scm148
-rw-r--r--module/scripts/lint.scm3
-rw-r--r--module/scripts/list.scm11
-rw-r--r--module/scripts/punify.scm3
-rw-r--r--module/scripts/read-rfc822.scm5
-rw-r--r--module/scripts/read-scheme-source.scm5
-rw-r--r--module/scripts/read-text-outline.scm5
-rw-r--r--module/scripts/scan-api.scm5
-rw-r--r--module/scripts/snarf-check-and-output-texi.scm5
-rw-r--r--module/scripts/snarf-guile-m4-docs.scm5
-rw-r--r--module/scripts/summarize-guile-TODO.scm5
-rw-r--r--module/scripts/use2dot.scm4
-rw-r--r--module/system/base/compile.scm14
-rw-r--r--module/system/repl/command.scm22
-rw-r--r--module/web/client.scm116
-rw-r--r--module/web/request.scm40
-rw-r--r--test-suite/tests/modules.test4
-rw-r--r--test-suite/tests/reader.test1
-rw-r--r--test-suite/tests/srfi-4.test42
-rw-r--r--test-suite/tests/web-request.test4
73 files changed, 1293 insertions, 336 deletions
diff --git a/.gitignore b/.gitignore
index 0ecf41d3e..229acc2e3 100644
--- a/.gitignore
+++ b/.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
diff --git a/GUILE-VERSION b/GUILE-VERSION
index e95f7eb7c..71237e421 100644
--- a/GUILE-VERSION
+++ b/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}"
diff --git a/NEWS b/NEWS
index 2ca0272a1..f5760cf38 100644
--- a/NEWS
+++ b/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):
diff --git a/acinclude.m4 b/acinclude.m4
index c930444a3..ba17e939a 100644
--- a/acinclude.m4
+++ b/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"
;;
*)
diff --git a/configure.ac b/configure.ac
index a61492d13..a5918a3f9 100644
--- a/configure.ac
+++ b/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])
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index 4def24610..423a9dfe7 100644
--- a/doc/ref/Makefile.am
+++ b/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)
diff --git a/doc/ref/goops.texi b/doc/ref/goops.texi
index 362a6e371..10192eb3b 100644
--- a/doc/ref/goops.texi
+++ b/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
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 119e7f8a7..ccf5e1e07 100644
--- a/doc/ref/scheme-using.texi
+++ b/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
-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.}.
+invoked using the @code{guild} program.
@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
diff --git a/doc/release.org b/doc/release.org
new file mode 100644
index 000000000..0d18be383
--- /dev/null
+++ b/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.
diff --git a/lib/Makefile.am b/lib/Makefile.am
index 5ae7948be..fe37ae832 100644
--- a/lib/Makefile.am
+++ b/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
diff --git a/lib/float.c b/lib/float.c
new file mode 100644
index 000000000..e42e08e0a
--- /dev/null
+++ b/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
diff --git a/lib/float.in.h b/lib/float.in.h
index 58a5f736e..95dda79b8 100644
--- a/lib/float.in.h
+++ b/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 */
diff --git a/lib/isinf.c b/lib/isinf.c
index 28cfc4d49..0531c6f34 100644
--- a/lib/isinf.c
+++ b/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;
}
diff --git a/lib/pathmax.h b/lib/pathmax.h
index 8056fef22..41f0ba276 100644
--- a/lib/pathmax.h
+++ b/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 */
diff --git a/lib/pipe2.c b/lib/pipe2.c
index e1884fadd..bb17264a3 100644
--- a/lib/pipe2.c
+++ b/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)
- return -1;
+ {
+ 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;
}
diff --git a/lib/stat.c b/lib/stat.c
index aa369d0f2..b203172fe 100644
--- a/lib/stat.c
+++ b/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)
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index 2101bced5..f1878e017 100644
--- a/lib/unistd.in.h
+++ b/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,
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index e69a1551e..1817100fd 100644
--- a/libguile/Makefile.am
+++ b/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
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 90252a7a0..99ac1761d 100644
--- a/libguile/bytevectors.c
+++ b/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)
-{ /* FIXME add some checks */
- const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
- return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
+bytevector_ref_c32 (SCM bv, SCM index)
+#define FUNC_NAME "bytevector_ref_c32"
+{
+ COMPLEX_NATIVE_REF (float);
}
+#undef FUNC_NAME
static SCM
-bytevector_ref_c64 (SCM bv, SCM idx)
-{ /* FIXME add some checks */
- const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
- return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
+bytevector_ref_c64 (SCM bv, SCM index)
+#define FUNC_NAME "bytevector_ref_c64"
+{
+ COMPLEX_NATIVE_REF (double);
}
+#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!!! */
-static SCM
-bytevector_set_c32 (SCM bv, SCM idx, SCM val)
-{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
- contents[i/4] = scm_c_real_part (val);
- contents[i/4 + 1] = scm_c_imag_part (val);
+/* Template for native modification of complex numbers of type TYPE. */
+#define COMPLEX_NATIVE_SET(_type) \
+ COMPLEX_ACCESSOR_PROLOGUE (_type); \
+ \
+ { \
+ _type real, imag; \
+ 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_c32 (SCM bv, SCM index, SCM value)
+#define FUNC_NAME "bytevector_set_c32"
+{
+ COMPLEX_NATIVE_SET (float);
}
+#undef FUNC_NAME
static SCM
-bytevector_set_c64 (SCM bv, SCM idx, SCM val)
-{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
- size_t i = scm_to_size_t (idx);
- contents[i/8] = scm_c_real_part (val);
- contents[i/8 + 1] = scm_c_imag_part (val);
- return SCM_UNSPECIFIED;
+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);
diff --git a/libguile/filesys.c b/libguile/filesys.c
index ceec87776..f60032818 100644
--- a/libguile/filesys.c
+++ b/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,14 +272,17 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
else
port_mode = "r+";
}
- else {
- if (iflags & O_APPEND)
- port_mode = "a";
- else if (iflags & O_WRONLY)
- port_mode = "w";
- else
- port_mode = "r";
- }
+ else
+ {
+ /* Opened read-only or write-only. */
+ if (iflags & O_APPEND)
+ port_mode = "a";
+ else if (iflags & O_WRONLY)
+ port_mode = "w";
+ else
+ port_mode = "r";
+ }
+
newpt = scm_fdes_to_port (fd, port_mode, path);
return newpt;
}
@@ -1856,7 +1861,10 @@ scm_init_filesys ()
#endif
#ifdef O_LARGEFILE
scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
-#endif
+#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));
diff --git a/libguile/goops.c b/libguile/goops.c
index 9f6149171..f0a4315c1 100644
--- a/libguile/goops.c
+++ b/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_class_extended_generic),
+ scm_list_2 (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 */
diff --git a/libguile/i18n.c b/libguile/i18n.c
index b22b33222..f9ec723a0 100644
--- a/libguile/i18n.c
+++ b/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;
diff --git a/libguile/load.c b/libguile/load.c
index 3b6ba2b38..de6bf7c60 100644
--- a/libguile/load.c
+++ b/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))
diff --git a/libguile/modules.c b/libguile/modules.c
index ca8875dab..6c3f2629e 100644
--- a/libguile/modules.c
+++ b/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;
+
+ args[0] = module;
+ args[1] = sym;
+ args[2] = iface1;
+ args[3] = SCM_VARIABLE_REF (var1);
+ 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 ();
+
+ for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
{
- SCM val1, val2;
- SCM handlers, h, handler_args;
-
- val1 = SCM_VARIABLE_REF (var1);
- val2 = SCM_VARIABLE_REF (var2);
-
- val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
- val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
-
- handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
- if (scm_is_false (handlers))
- handlers = default_duplicate_binding_handlers ();
-
- handler_args = scm_list_n (module, sym,
- 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;
+ }
+
+ result = scm_call_n (SCM_CAR (handlers), args, 8);
+
+ if (scm_is_true (result))
+ return result;
}
- else
- result = var1;
- return result;
+ return SCM_BOOL_F;
}
/* No lock is needed for access to this variable, as there are no
@@ -368,9 +375,15 @@ module_imported_variable (SCM module, SCM sym)
{
/* SYM is a duplicate binding (imported more than once) so we
need to resolve it. */
- found_var = resolve_duplicate_binding (module, sym,
- found_iface, found_var,
- iface, var);
+ 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;
}
diff --git a/libguile/read.c b/libguile/read.c
index 6e7804dd8..c95db5c25 100644
--- a/libguile/read.c
+++ b/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));
diff --git a/libguile/threads.c b/libguile/threads.c
index 6f529def2..fcd1c1d2b 100644
--- a/libguile/threads.c
+++ b/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);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 22bd39c0e..c90458df6 100644
--- a/libguile/vm-engine.c
+++ b/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 */
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 48ab09a12..000397de2 100644
--- a/libguile/vm-engine.h
+++ b/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
/*
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index 689da75a2..891fc8bc3 100644
--- a/m4/alloca.m4
+++ b/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
+])
diff --git a/m4/ceil.m4 b/m4/ceil.m4
index 157407745..b9052976f 100644
--- a/m4/ceil.m4
+++ b/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)))
- return 1;
- return 0;
+ if (signbitd (minus_zerod) && !signbitd (my_ceil (minus_zerod)))
+ result |= 1;
+ /* 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],
diff --git a/m4/float_h.m4 b/m4/float_h.m4
index 21a7529fe..261f1ac3a 100644
--- a/m4/float_h.m4
+++ b/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"])
])
diff --git a/m4/floor.m4 b/m4/floor.m4
index 62d19fed7..5de0da277 100644
--- a/m4/floor.m4
+++ b/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;
}
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index f532ac6d7..881d69ef7 100644
--- a/m4/gnulib-comp.m4
+++ b/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
diff --git a/m4/isinf.m4 b/m4/isinf.m4
index f6056e610..145e37e66 100644
--- a/m4/isinf.m4
+++ b/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
diff --git a/m4/lstat.m4 b/m4/lstat.m4
index 72c76c6cf..fe161d401 100644
--- a/m4/lstat.m4
+++ b/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
diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4
index 7ba7fd26b..952536feb 100644
--- a/m4/mmap-anon.m4
+++ b/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],
diff --git a/m4/printf.m4 b/m4/printf.m4
index 9c2ed1ef2..ead5eceae 100644
--- a/m4/printf.m4
+++ b/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} # . . . # # . . . . . # . . . . # # . #
diff --git a/m4/trunc.m4 b/m4/trunc.m4
index 953f5b131..62311015b 100644
--- a/m4/trunc.m4
+++ b/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;
}
diff --git a/maint.mk b/maint.mk
index 6f6b8be39..e6e03a897 100644
--- a/maint.mk
+++ b/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) \
diff --git a/meta/guild.in b/meta/guild.in
index bb9c37e05..183323f75 100755
--- a/meta/guild.in
+++ b/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
-Copyright (C) 2010 Free Software Foundation, Inc.
-License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
-This is free software: you are free to change and redistribute it.
-There is NO WARRANTY, to the extent permitted by law.
-" (version) (effective-version)))
+ (version-etc "@PACKAGE_NAME@"
+ (version)
+ #:command-name "guild"
+ #:license *LGPLv3+*))
(define (find-script s)
(resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
@@ -62,27 +53,24 @@ There is NO WARRANTY, to the extent permitted by law.
(if (defined? 'setlocale)
(setlocale LC_ALL ""))
- (let ((options (getopt-long args *option-grammar*
- #:stop-at-first-non-option #t)))
+ (let* ((options (getopt-long args *option-grammar*
+ #: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))
+ ((find-script (if (null? args) "help" (car args)))
+ => (lambda (mod)
+ (exit (apply (module-ref mod 'main) (if (null? args)
+ '()
+ (cdr args))))))
(else
- (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)
- '()
- (cdr args))))))
- (else
- (format (current-error-port)
- "guild: unknown script ~s~%" (car args))
- (format (current-error-port)
- "Try `guild --help' for more information.~%")
- (exit 1))))))))
+ (format (current-error-port)
+ "guild: unknown script ~s~%" (car args))
+ (format (current-error-port)
+ "Try `guild help' for more information.~%")
+ (exit 1)))))
diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in
index 4faad641b..2276b4aed 100644
--- a/meta/uninstalled-env.in
+++ b/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 "$@"
diff --git a/module/Makefile.am b/module/Makefile.am
index b21b73c77..0787f2004 100644
--- a/module/Makefile.am
+++ b/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 \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 9c3a3e165..3bf492280 100644
--- a/module/ice-9/boot-9.scm
+++ b/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
- canon-path
+ (canonical->suffix canon-path)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
(warn "invalid %load-compiled-extensions"
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e48c220f2..a27aab5fb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -398,13 +398,11 @@
names))
(goops-error "no prefixes supplied"))))
-(define (make-generic . name)
- (let ((name (and (pair? name) (car name))))
- (make <generic> #:name name)))
+(define* (make-generic #:optional name)
+ (make <generic> #:name name))
-(define (make-extended-generic gfs . name)
- (let* ((name (and (pair? name) (car name)))
- (gfs (if (pair? gfs) gfs (list gfs)))
+(define* (make-extended-generic gfs #:optional name)
+ (let* ((gfs (if (list? 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,18 +439,17 @@
(delq! eg (slot-ref gf 'extended-by))))
gfs))
-(define (ensure-generic old-definition . 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>
- #:name name
- #:default (procedure old-definition)
- #:setter (setter old-definition)))
- ((procedure? old-definition)
- (if (generic-capability? old-definition) old-definition
- (make <generic> #:name name #:default old-definition)))
- (else (make <generic> #:name name)))))
+(define* (ensure-generic old-definition #:optional name)
+ (cond ((is-a? old-definition <generic>) old-definition)
+ ((procedure-with-setter? old-definition)
+ (make <generic-with-setter>
+ #:name name
+ #:default (procedure old-definition)
+ #:setter (setter old-definition)))
+ ((procedure? old-definition)
+ (if (generic-capability? old-definition) old-definition
+ (make <generic> #:name name #:default old-definition)))
+ (else (make <generic> #:name name))))
;; same semantics as <generic>
(define-syntax define-accessor
@@ -466,34 +463,32 @@
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
-(define (make-accessor . name)
- (let ((name (and (pair? name) (car name))))
- (make <accessor>
- #:name name
- #:setter (make <generic>
- #:name (and name (make-setter-name name))))))
-
-(define (ensure-accessor proc . name)
- (let ((name (and (pair? name) (car name))))
- (cond ((and (is-a? proc <accessor>)
- (is-a? (setter proc) <generic>))
- proc)
- ((is-a? proc <generic-with-setter>)
- (upgrade-accessor proc (setter proc)))
- ((is-a? proc <generic>)
- (upgrade-accessor proc (make-generic name)))
- ((procedure-with-setter? proc)
- (make <accessor>
- #:name name
- #:default (procedure proc)
- #:setter (ensure-generic (setter proc) name)))
- ((procedure? proc)
- (ensure-accessor (if (generic-capability? proc)
- (make <generic> #:name name #:default proc)
- (ensure-generic proc name))
- name))
- (else
- (make-accessor name)))))
+(define* (make-accessor #:optional name)
+ (make <accessor>
+ #:name name
+ #:setter (make <generic>
+ #:name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #:optional name)
+ (cond ((and (is-a? proc <accessor>)
+ (is-a? (setter proc) <generic>))
+ proc)
+ ((is-a? proc <generic-with-setter>)
+ (upgrade-accessor proc (setter proc)))
+ ((is-a? proc <generic>)
+ (upgrade-accessor proc (make-generic name)))
+ ((procedure-with-setter? proc)
+ (make <accessor>
+ #:name name
+ #:default (procedure proc)
+ #:setter (ensure-generic (setter proc) name)))
+ ((procedure? proc)
+ (ensure-accessor (if (generic-capability? proc)
+ (make <generic> #:name name #:default proc)
+ (ensure-generic proc name))
+ name))
+ (else
+ (make-accessor name))))
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
diff --git a/module/scripts/PROGRAM.scm b/module/scripts/PROGRAM.scm
deleted file mode 100644
index 56e5cf334..000000000
--- a/module/scripts/PROGRAM.scm
+++ /dev/null
@@ -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
diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm
index b842b03ff..b2527b9e9 100644
--- a/module/scripts/api-diff.scm
+++ b/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))))
diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm
index 943c90227..9bce06e2a 100644
--- a/module/scripts/autofrisk.scm
+++ b/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
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index f9d6cca99..0651c6804 100644
--- a/module/scripts/compile.scm
+++ b/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)
diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm
index 8907f6d08..7dab2dde9 100644
--- a/module/scripts/disassemble.scm
+++ b/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)))
diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm
index 5bd249ce9..81d7907af 100644
--- a/module/scripts/display-commentary.scm
+++ b/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)))
diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm
index b7fbc996e..fa3dfb312 100644
--- a/module/scripts/doc-snarf.scm
+++ b/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))
diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm
index c452ede25..a8f79232d 100644
--- a/module/scripts/frisk.scm
+++ b/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!)
diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm
index 781931015..90f524b06 100644
--- a/module/scripts/generate-autoload.scm
+++ b/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 '()))
diff --git a/module/scripts/help.scm b/module/scripts/help.scm
new file mode 100644
index 000000000..107d39485
--- /dev/null
+++ b/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))))
diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm
index aa74fb6a7..cea425ea9 100644
--- a/module/scripts/lint.scm
+++ b/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))))
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
index c4891b6a8..0f1d715dd 100644
--- a/module/scripts/list.scm
+++ b/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))
diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm
index 1627722d3..6b33ac5ee 100644
--- a/module/scripts/punify.scm
+++ b/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)))
diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm
index c0a54f28c..08f3fb9a1 100644
--- a/module/scripts/read-rfc822.scm
+++ b/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]+"))
diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm
index b48a88f9b..1bca6a4c4 100644
--- a/module/scripts/read-scheme-source.scm
+++ b/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.
;;
diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm
index 64221fbe1..d0933bb0b 100644
--- a/module/scripts/read-text-outline.scm
+++ b/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))))))
diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm
index 9236f8742..86d07fc3e 100644
--- a/module/scripts/scan-api.scm
+++ b/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)
diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm
index f92c833ed..6ca07a1f4 100644
--- a/module/scripts/snarf-check-and-output-texi.scm
+++ b/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)
diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm
index 05c305ebd..4e59f536d 100644
--- a/module/scripts/snarf-guile-m4-docs.scm
+++ b/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)
diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm
index ee4f88c1f..8b119e0ec 100644
--- a/module/scripts/summarize-guile-TODO.scm
+++ b/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)
diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm
index ab97afbc7..975a9c4a4 100644
--- a/module/scripts/use2dot.scm
+++ b/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
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 1b6e73f32..943999040 100644
--- a/module/system/base/compile.scm
+++ b/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
- ;; will give us an absolute path
- (canonicalize-path file)
+ (canonical->suffix (canonicalize-path file))
(compiled-extension))))
(and (false-if-exception (ensure-writable-dir (dirname f)))
f))))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 109b533f8..a2f2a6f84 100644
--- a/module/system/repl/command.scm
+++ b/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)
- (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
+ (define (diff start end)
+ (/ (- end start) 1.0 internal-time-units-per-second))
(repl-print repl result)
- (display "clock utime stime cutime cstime gctime\n")
- (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
- (get tms:clock tms-start tms-end)
- (get tms:utime tms-start tms-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))
+ (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n"
+ (diff real-start real-end)
+ (diff run-start run-end)
+ (diff gc-start gc-end))
result))
(define-meta-command (profile repl (form) . opts)
diff --git a/module/web/client.scm b/module/web/client.scm
new file mode 100644
index 000000000..6a04497cf
--- /dev/null
+++ b/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)))))
diff --git a/module/web/request.scm b/module/web/request.scm
index 84119205f..c9204a4bf 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -151,21 +151,31 @@
(validate-headers? #t))
"Construct an HTTP request object. If @var{validate-headers?} is true,
the headers are each run through their respective validators."
- (cond
- ((not (and (pair? version)
- (non-negative-integer? (car version))
- (non-negative-integer? (cdr version))))
- (bad-request "Bad version: ~a" version))
- ((not (uri? uri))
- (bad-request "Bad uri: ~a" uri))
- ((and (not port) (memq method '(POST PUT)))
- (bad-request "Missing port for message ~a" method))
- ((not (list? meta))
- (bad-request "Bad metadata alist" meta))
- (else
- (if validate-headers?
- (validate-headers headers))))
- (make-request method uri version headers meta port))
+ (let ((needs-host? (and (equal? version '(1 . 1))
+ (not (assq-ref headers 'host)))))
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-request "Bad version: ~a" version))
+ ((not (uri? uri))
+ (bad-request "Bad uri: ~a" uri))
+ ((and (not port) (memq method '(POST PUT)))
+ (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
+ (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
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index 5f34d9e70..79e3c98e9 100644
--- a/test-suite/tests/modules.test
+++ b/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)))))
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index f350e73a6..437706b00 100644
--- a/test-suite/tests/reader.test
+++ b/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
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 3a0710222..2e7f0d5f5 100644
--- a/test-suite/tests/srfi-4.test
+++ b/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)))
diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test
index e1eec2f74..8cf1c2e87 100644
--- a/test-suite/tests/web-request.test
+++ b/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")))