[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.0.2-105-gab4bc85
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.0.2-105-gab4bc85 |
|
Date: |
Mon, 25 Jul 2011 16:55:36 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ab4bc85398a14b62b58694bab83c63be286b2fd5
The branch, master has been updated
via ab4bc85398a14b62b58694bab83c63be286b2fd5 (commit)
via f29c300507da21a667f5b82e75300f8009eab9cc (commit)
via f4b7d918eff9770f09893b023fd834f5c0bc33d1 (commit)
via 0d2e3fc1e7095c7b64845b29ff01e2077329f127 (commit)
via 8698e810078e3224e08a67540fd42ad51b46fdf1 (commit)
via 3cf634fa7c7cf02238ef434e4a3c42d9abc64674 (commit)
via 4f0ea6e3cef32d54c1a276945b8885433a137b7c (commit)
via f4a76a315ad8f1f6f4dbdfbd2f030c6b299cb5a4 (commit)
via a1a2ed534278b968767727485f84e5957c039c23 (commit)
via d322dc92ec8170320c68abc024eb683a0bf8ab00 (commit)
via 5d48015adf47dad962b77bf464b352e7fd2aead6 (commit)
via 9957641b603f79b070fc2be0bf511235fa764229 (commit)
via 072624134b9d8b2aa37f619dc5f828d667c72737 (commit)
via ecfb148137e62fc4ca9d1b7319c5aa688cec997f (commit)
via 037a68032165a2f1e4c0311baa9f69e2a05c3326 (commit)
via 680c8c5a99e6abe040752c3471cd42a9516842b6 (commit)
via 126a32243146d9ad238a3a5adb8d6af5a87ad2aa (commit)
via 3565df4546d97da4be573610a73f333d45a6287a (commit)
via 1fe9920adc80fa7ff59020b13479e5bedeed4401 (commit)
via 2a8b3b80502e7f5ac9da462c15525858409b1909 (commit)
via ae88d9bcf622baa6745a91fafb9be2fb331ad6c0 (commit)
via 319dd08936ec2d14272f68c16f778c411ed4b505 (commit)
via a8c10aa131eb5dd104f134d2ed66afe225fea8e6 (commit)
via c1e3e9aafff8ef669fd3573f7c92d2f5ff7c2d66 (commit)
via 21b6df302fbc372a4b359f73a7441752cd6c1306 (commit)
via 0adcd1bd939cb94691b15e585623b768041c058c (commit)
via 37a5970c19ca7ad2b5de2f667748c840c199f878 (commit)
via c467c36374b7bdbdfe4c0dfccaa2fb4ebfb4d3a7 (commit)
via f39779b1be487985d32bb6ad372e9fa29572f813 (commit)
via 4f39f31ea58f08dfe22df8192e8ff02943a9ed5d (commit)
via 231c0e0e61fc4bdd69398e89084b7819f0420710 (commit)
via 97ec95b72873428f215a8a9892487c3a8435a754 (commit)
via 4bc95fccad7288004515ce78d50611499cbca2db (commit)
via 1e8f93922922b09c7003a357d86777b2a79e9735 (commit)
via e780c14fd0fd2572eaebc2949f6a67fc773c2835 (commit)
via 1f7945a768a8df06ad208ed2846dfe4f92e1515a (commit)
via b8441577f9954053a90981a5c134aa43f341f712 (commit)
via ea5c9ddcebe1d798fccfe9bbb1f4504e77fa2908 (commit)
via 6934d9e75fde9c880b39faa19237b041495c8531 (commit)
from 86e449a69987ecb943b11198e065bbb22526f8c5 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ab4bc85398a14b62b58694bab83c63be286b2fd5
Merge: f29c300 f4b7d91
Author: Andy Wingo <address@hidden>
Date: Mon Jul 25 18:26:37 2011 +0200
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
test-suite/tests/srfi-4.test
commit f29c300507da21a667f5b82e75300f8009eab9cc
Author: Andy Wingo <address@hidden>
Date: Mon Jul 25 18:24:54 2011 +0200
fix GC_get_suspend_signal on Mac OS
* libguile/scmsigs.c (GC_get_suspend_signal): Fix the back-compatibility
shim for this function to work on some other cases; I hadn't realized
that gcconfig.h could set SIG_SUSPEND. Thanks to Aleix Conchillo
Flaqué for the report.
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 1 +
GUILE-VERSION | 4 +-
NEWS | 7 +-
acinclude.m4 | 3 +-
configure.ac | 7 +-
doc/ref/Makefile.am | 1 +
doc/ref/goops.texi | 5 +-
doc/ref/scheme-using.texi | 8 +-
doc/release.org | 164 ++++++++++++++++++++++++
lib/Makefile.am | 4 +-
lib/{close.c => float.c} | 37 ++----
lib/float.in.h | 111 ++++++++++++++++
lib/isinf.c | 9 +-
lib/pathmax.h | 15 ++
lib/pipe2.c | 15 ++-
lib/stat.c | 8 +
lib/unistd.in.h | 2 +
libguile/Makefile.am | 1 +
libguile/bytevectors.c | 90 ++++++++++----
libguile/filesys.c | 28 +++--
libguile/goops.c | 15 ++-
libguile/i18n.c | 2 +-
libguile/load.c | 25 +++-
libguile/modules.c | 75 +++++++-----
libguile/read.c | 11 +-
libguile/scmsigs.c | 4 +-
libguile/threads.c | 18 ++-
libguile/vm-engine.c | 18 ++-
libguile/vm-engine.h | 8 +
m4/alloca.m4 | 79 +++++++++++-
m4/ceil.m4 | 16 ++-
m4/float_h.m4 | 35 +++++-
m4/floor.m4 | 8 +-
m4/gnulib-comp.m4 | 4 +
m4/isinf.m4 | 4 +-
m4/lstat.m4 | 4 +-
m4/mmap-anon.m4 | 8 +-
m4/printf.m4 | 11 +-
m4/trunc.m4 | 8 +-
maint.mk | 79 +++++++-----
meta/guild.in | 56 +++-----
meta/uninstalled-env.in | 4 +
module/Makefile.am | 3 +-
module/ice-9/boot-9.scm | 14 ++-
module/oop/goops.scm | 87 ++++++-------
module/scripts/PROGRAM.scm | 40 ------
module/scripts/api-diff.scm | 5 +-
module/scripts/autofrisk.scm | 5 +-
module/scripts/compile.scm | 2 +
module/scripts/disassemble.scm | 4 +-
module/scripts/display-commentary.scm | 4 +-
module/scripts/doc-snarf.scm | 4 +-
module/scripts/frisk.scm | 5 +-
module/scripts/generate-autoload.scm | 5 +-
module/scripts/help.scm | 148 +++++++++++++++++++++
module/scripts/lint.scm | 3 +
module/scripts/list.scm | 11 ++-
module/scripts/punify.scm | 3 +
module/scripts/read-rfc822.scm | 5 +-
module/scripts/read-scheme-source.scm | 5 +-
module/scripts/read-text-outline.scm | 5 +-
module/scripts/scan-api.scm | 5 +-
module/scripts/snarf-check-and-output-texi.scm | 5 +-
module/scripts/snarf-guile-m4-docs.scm | 5 +-
module/scripts/summarize-guile-TODO.scm | 5 +-
module/scripts/use2dot.scm | 4 +-
module/system/base/compile.scm | 14 ++-
module/system/repl/command.scm | 22 ++--
module/web/client.scm | 116 +++++++++++++++++
module/web/request.scm | 40 ++++--
test-suite/tests/modules.test | 4 +
test-suite/tests/reader.test | 1 +
test-suite/tests/srfi-4.test | 42 ++++++-
test-suite/tests/web-request.test | 4 +
74 files changed, 1277 insertions(+), 360 deletions(-)
create mode 100644 doc/release.org
copy lib/{close.c => float.c} (54%)
delete mode 100644 module/scripts/PROGRAM.scm
create mode 100644 module/scripts/help.scm
create mode 100644 module/web/client.scm
diff --git a/.gitignore b/.gitignore
index 0ecf41d..229acc2 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 e95f7eb..71237e4 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 2ca0272..f5760cf 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 c930444..ba17e93 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 a61492d..a5918a3 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 4def246..423a9df 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 362a6e3..10192eb 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.
address@hidden Copyright (C) 2008, 2009
address@hidden 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 119e7f8..ccf5e1e 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} address@hidden Guile version
-2.0.1, this program was known as @code{guile-tools}. The
address@hidden 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 0000000..0d18be3
--- /dev/null
+++ b/doc/release.org
@@ -0,0 +1,164 @@
+#+TITLE: Release Process for GNU Guile 2.0
+#+AUTHOR: Ludovic Courtès
+#+EMAIL: address@hidden
+
+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
+
+ - address@hidden, address@hidden, address@hidden
+ - address@hidden (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 5ae7948..fe37ae8 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/close.c b/lib/float.c
similarity index 54%
copy from lib/close.c
copy to lib/float.c
index 378c4f1..e42e08e 100644
--- a/lib/close.c
+++ b/lib/float.c
@@ -1,5 +1,6 @@
-/* close replacement.
- Copyright (C) 2008-2011 Free Software Foundation, Inc.
+/* Auxiliary definitions for <float.h>.
+ Copyright (C) 2011 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 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
@@ -17,26 +18,16 @@
#include <config.h>
/* Specification. */
-#include <unistd.h>
-
-#include "fd-hook.h"
-
-/* Override close() to call into other gnulib modules. */
-
-int
-rpl_close (int fd)
-#undef close
-{
-#if WINDOWS_SOCKETS
- int retval = execute_all_close_hooks (close, fd);
+#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
- int retval = close (fd);
+/* This declaration is solely to ensure that after preprocessing
+ this file is never empty. */
+typedef int dummy;
#endif
-
-#if REPLACE_FCHDIR
- if (retval >= 0)
- _gl_unregister_fd (fd);
-#endif
-
- return retval;
-}
diff --git a/lib/float.in.h b/lib/float.in.h
index 58a5f73..95dda79 100644
--- a/lib/float.in.h
+++ b/lib/float.in.h
@@ -29,6 +29,7 @@
#define address@hidden@_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 /* address@hidden@_FLOAT_H */
#endif /* address@hidden@_FLOAT_H */
diff --git a/lib/isinf.c b/lib/isinf.c
index 28cfc4d..0531c6f 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 8056fef..41f0ba2 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 e1884fa..bb17264 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 aa369d0..b203172 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 2101bce..f1878e0 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 e69a155..1817100 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 90252a7..99ac176 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 ceec877..f600328 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 9f61491..f0a4315 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 b22b332..f9ec723 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 3b6ba2b..de6bf7c 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 ca8875d..6c3f262 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 6e7804d..c95db5c 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/scmsigs.c b/libguile/scmsigs.c
index c324aaa..86fce0f 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -164,8 +164,10 @@ GC_get_suspend_signal (void)
return _SIGRTMIN + 6;
#elif defined SIGRTMIN
return SIGRTMIN + 6;
+#elif defined __GLIBC__
+ return 32+6;
#else
-#error what suspend signal to use?
+ return SIGUSR1;
#endif
}
#endif /* HAVE_GC_GET_SUSPEND_SIGNAL */
diff --git a/libguile/threads.c b/libguile/threads.c
index 6f529de..fcd1c1d 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 22bd39c..c90458d 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 48ab09a..000397d 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 689da75..891fc8b 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 */
address@hidden:@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 1574077..b905297 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 21a7529..261f1ac 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 62d19fe..5de0da2 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 f532ac6..881d69e 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 f6056e6..145e37e 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 72c76c6..fe161d4 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 7ba7fd2..952536f 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 9c2ed1e..ead5ece 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 953f5b1..6231101 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 6f6b8be..e6e03a8 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 bb9c37e..183323f 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:address@hidden@/@address@hidden $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 4faad64..2276b4a 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 b21b73c..0787f20 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 9c3a3e1..3bf4922 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 e48c220..a27aab5 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 56e5cf3..0000000
--- 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 b842b03..b2527b9 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 943c902..9bce06e 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 f9d6cca..0651c68 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 8907f6d..7dab2dd 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 5bd249c..81d7907 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 b7fbc99..fa3dfb3 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 c452ede..a8f7923 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 7819310..90f524b 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 0000000..107d394
--- /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 aa74fb6..cea425e 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 c4891b6..0f1d715 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 1627722..6b33ac5 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 c0a54f2..08f3fb9 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 b48a88f..1bca6a4 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 64221fb..d0933bb 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 9236f87..86d07fc 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 f92c833..6ca07a1 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 05c305e..4e59f53 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 ee4f88c..8b119e0 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 ab97afb..975a9c4 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 1b6e73f..9439990 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 109b533..a2f2a6f 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 0000000..6a04497
--- /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 8411920..c9204a4 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 5f34d9e..79e3c98 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 f350e73..437706b 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 3a07102..2e7f0d5 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 e1eec2f..8cf1c2e 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")))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.0.2-105-gab4bc85,
Andy Wingo <=