[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-522-ge0c211b
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-522-ge0c211b |
|
Date: |
Mon, 07 Jan 2013 22:36:11 +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=e0c211bb2e80605b4ae3fb121c34136f6e266b70
The branch, master has been updated
via e0c211bb2e80605b4ae3fb121c34136f6e266b70 (commit)
via 9f17d967c9b108f856776c035462e93017a6e7e2 (commit)
via 6fca8730f768429b31906104635cb5501e7e3df4 (commit)
via 44390164ce7ad4b28571d30037529833a4b4f985 (commit)
via c23fb152b708697473603c9b893a7fd7a30b6561 (commit)
via 668ba7c95594b8294e46027dfade8fa0adb25614 (commit)
via b9d724982d01899ca09b02f889e7207e06a43803 (commit)
via 21982d68ab11580cbe35dee2f98334e09545fd93 (commit)
via afdf5467e5d8f9b1c13cae2d2cc0679a710d2403 (commit)
via 9977b316434c6ac59e0224fd530ab8065f2cc938 (commit)
via cc948107089bf9a8aee25f33f46c8b1dfa914ae6 (commit)
via 4578dc947922d79cf7ffd937c46ae6bd261ef6a4 (commit)
via 8f63b9b670899c9a1a6e017e8979614a9b4b649b (commit)
via 2355f01709eadfd5350c510cdb095b4e3f71f17c (commit)
via e6a730b22a852c4bbbf387907659f284e4da1408 (commit)
via 3eaa5876451f0a69d650a0ff1c8bc74f43181d8e (commit)
via 3b5390989d347b4ffd363d83d516f5d0dc56af77 (commit)
via 9a535f09e09d5bc1bdfd12adcf700796b4abaaa0 (commit)
via 3919585f7945b3df8bb22f8296466eb8f89a7bf0 (commit)
via 2813d72571fc5730a8ffb96ceed20d17b63dbd0f (commit)
via a94e7d85dd98893cebdb6108f3e7a7afb1e784dd (commit)
via 13fac28218b42fc5408ce62b64ae3d09c95cd91e (commit)
via 4d599c24413ace78824a71c755ce2d6a5154a71e (commit)
via a638be152c73c9d16b49b923e923748370096db2 (commit)
via 8eccf6cdbdd03f8816110d07b56111aecc4880e6 (commit)
via bd31bce6ac5df7e45d0ec802d9d0738cbc32d9bf (commit)
via 99b94347f9c93459e2111e9cacbe3632b8041072 (commit)
via 91e693a8e8a9d6d7841b189171829ed1c91a01d1 (commit)
via 75d6c59fc25cdcc02f19b626961d46a96bb33234 (commit)
via ee2d874119b898114c6f4b61051cc3c35e1bab38 (commit)
via cb17c4422b6ef005556b7b6fdc137580b6f0e89e (commit)
via c438cd7175540536c3965b4ffea28ae6df7e59e0 (commit)
via fc32c44995dacb2c3f2fb9d1eafec59c44787c32 (commit)
via c04c11846127d481afc56a1d4e7f657460cd4f21 (commit)
via 4e81e9d9a37ee958bf4b9a636a8f106f1241f1ce (commit)
via 261af76005f0e31f570bed201a2ef2a43cdd6e11 (commit)
via ca8be3f5b3e4ee55d6df361c402a2a5d57497062 (commit)
via 9fbca4b32edfe1ba6e2159bbfa90e95315322f6c (commit)
via 6356e0dc2f95cdf3883f92f480c130957be49817 (commit)
via 085552d83d647a05b8ab33810ce50401d0f3afe4 (commit)
via 5d7c55bdcffbc326e775b0b9c881a01e44eee160 (commit)
via 890647559da97944e82801b5e11b25c6f56f22c5 (commit)
via 06883ae000a65ba727f2f8debb393ffceeb4d6e9 (commit)
via e8772a9edef3fed3c592e61bbde618de197f4b53 (commit)
via 9ee0455738f90086894d602075915d49a5044fb7 (commit)
via 5cd10307866e6e6c44cb46b366f71d4118fa6aed (commit)
via 679a35567dbb0a467e99f19d3f513fac28317f26 (commit)
via 712ca51ffe731d5b0e4dacb4d343426092df2eb0 (commit)
via 06906f370f77cbab520ff0d3c47449526934a9c8 (commit)
via 2c7b7e0f214be5ec5184949a94209668775f60bc (commit)
via 2d37a9349404c3161d89967c014cbaa1a28e59ea (commit)
via 3e529bf02af7939c7c7d06ed68f0108b336ed4d2 (commit)
via ab975cf592a89eee30fec94e77ef064eda0b38b5 (commit)
via f2fb5e5328473556208b041cc4806e5a8fd11a4c (commit)
via 7ae4e75af5366086e60fbc2e9454dfd9e5965102 (commit)
via 44cd55752aad2a69e1583a2cb37c3b98c5c44ad3 (commit)
via 67768115d7faa8c9da63a6b5c347adab107403d0 (commit)
from 110ef00ba1dfae4461afdd189fed4dfec05ee137 (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 e0c211bb2e80605b4ae3fb121c34136f6e266b70
Merge: 110ef00 9f17d96
Author: Mark H Weaver <address@hidden>
Date: Mon Jan 7 17:23:26 2013 -0500
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
libguile/posix.c
module/ice-9/eval.scm
test-suite/tests/cse.test
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 5 +-
Makefile.am | 1 -
NEWS | 188 +++++++
THANKS | 2 +
build-aux/gendocs.sh | 167 ++++---
build-aux/gitlog-to-changelog | 35 ++-
build-aux/gnu-web-doc-update | 83 +++-
configure.ac | 11 +-
doc/gendocs_template | 2 -
doc/ref/api-compound.texi | 59 +--
doc/ref/api-evaluation.texi | 30 +-
doc/ref/api-procedures.texi | 29 +-
doc/ref/api-scheduling.texi | 30 +-
doc/ref/guile-invoke.texi | 25 +-
doc/ref/match.texi | 29 +-
doc/ref/r6rs.texi | 4 +-
doc/ref/scheme-using.texi | 4 +
doc/ref/web.texi | 71 ++-
doc/release.org | 23 +-
gnulib-local/m4/canonicalize.m4.diff | 67 ---
lib/Makefile.am | 8 +-
lib/binary-io.c | 3 +
lib/binary-io.h | 11 +-
lib/errno.in.h | 5 +
lib/fcntl.in.h | 14 +-
lib/gettext.h | 9 +-
lib/localcharset.c | 7 +
lib/malloca.h | 2 +-
lib/regexec.c | 2 +-
lib/stat-time.c | 3 +
lib/stat-time.h | 23 +-
lib/stdbool.in.h | 51 ++-
lib/stdlib.in.h | 13 +-
lib/verify.h | 6 +-
lib/xsize.c | 3 +
lib/xsize.h | 17 +-
libguile/dynl.c | 134 ++++--
libguile/eval.c | 10 +-
libguile/load.c | 35 ++-
libguile/load.h | 1 +
libguile/memoize.c | 101 +++--
libguile/numbers.c | 14 +-
libguile/posix.c | 7 +-
libguile/procs.c | 9 +-
libguile/procs.h | 5 +-
libguile/simpos.c | 22 +-
libguile/socket.c | 8 +-
libguile/values.c | 4 +-
m4/canonicalize.m4 | 10 +-
m4/eealloc.m4 | 3 +-
m4/errno_h.m4 | 5 +-
m4/extern-inline.m4 | 57 ++
m4/fcntl-o.m4 | 13 +-
m4/gnulib-cache.m4 | 2 +-
m4/gnulib-comp.m4 | 957 +++++++++++++++++-----------------
m4/lib-ld.m4 | 58 ++-
m4/stat-time.m4 | 2 -
m4/stdlib_h.m4 | 1 +
m4/xsize.m4 | 3 +-
maint.mk | 271 +++++++---
module/Makefile.am | 8 +-
module/ice-9/boot-9.scm | 142 ++++--
module/ice-9/eval.scm | 43 +-
module/ice-9/futures.scm | 236 +++++++--
module/ice-9/r6rs-libraries.scm | 8 +-
module/ice-9/threads.scm | 25 +-
module/ice-9/vlist.scm | 94 ++--
module/language/tree-il/cse.scm | 9 +-
module/rnrs/base.scm | 39 ++-
module/srfi/srfi-9/gnu.scm | 6 +-
module/system/repl/common.scm | 21 +-
module/system/vm/program.scm | 6 +-
module/web/client.scm | 67 ++-
module/web/http.scm | 100 ++--
module/web/request.scm | 30 +-
module/web/response.scm | 103 +++-
module/web/server.scm | 58 +-
module/web/uri.scm | 104 +++--
test-suite/tests/cse.test | 19 +-
test-suite/tests/eval.test | 30 ++
test-suite/tests/ftw.test | 28 +-
test-suite/tests/future.test | 20 +-
test-suite/tests/numbers.test | 10 +
test-suite/tests/posix.test | 15 +-
test-suite/tests/r6rs-base.test | 40 ++
test-suite/tests/rnrs-libraries.test | 4 +-
test-suite/tests/session.test | 4 +-
test-suite/tests/tree-il.test | 72 +++-
test-suite/tests/web-response.test | 90 ++--
89 files changed, 2768 insertions(+), 1437 deletions(-)
delete mode 100644 gnulib-local/m4/canonicalize.m4.diff
create mode 100644 lib/binary-io.c
create mode 100644 lib/stat-time.c
create mode 100644 lib/xsize.c
create mode 100644 m4/extern-inline.m4
diff --git a/.dir-locals.el b/.dir-locals.el
index 3640530..ce2af7a 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -5,7 +5,10 @@
(c-mode . ((c-file-style . "gnu")))
(scheme-mode
. ((indent-tabs-mode . nil)
- (eval . (put 'pass-if-equal 'scheme-indent-function 2))))
+ (eval . (put 'pass-if 'scheme-indent-function 1))
+ (eval . (put 'pass-if-exception 'scheme-indent-function 2))
+ (eval . (put 'pass-if-equal 'scheme-indent-function 2))
+ (eval . (put 'with-test-prefix 'scheme-indent-function 1))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
diff --git a/Makefile.am b/Makefile.am
index 446bb3c..3aa5ddd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,7 +50,6 @@ EXTRA_DIST = LICENSE HACKING GUILE-VERSION
\
gnulib-local/lib/localcharset.h.diff \
gnulib-local/lib/localcharset.c.diff \
gnulib-local/m4/clock_time.m4.diff \
- gnulib-local/m4/canonicalize.m4.diff \
gnulib-local/build-aux/git-version-gen.diff
TESTS = check-guile
diff --git a/NEWS b/NEWS
index 64d374d..ebf5d61 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,194 @@ See the end for copying conditions.
Please send Guile bug reports to address@hidden
+Changes in 2.0.7 (since 2.0.6):
+
+* Notable changes
+
+** SRFI-105 curly infix expressions are supported
+
+Curly infix expressions as described at
+http://srfi.schemers.org/srfi-105/srfi-105.html are now supported by
+Guile's reader. This allows users to write things like {a * {b + c}}
+instead of (* a (+ b c)). SRFI-105 support is enabled by using the
+`#!curly-infix' directive in source code, or the `curly-infix' reader
+option. See the manual for details.
+
+** Reader options may now be per-port
+
+Historically, `read-options' and related procedures would manipulate
+global options, affecting the `read' procedure for all threads, and all
+current uses of `read'.
+
+Guile can now associate `read' options with specific ports, allowing
+different ports to use different options. For instance, the
+`#!fold-case' and `#!no-fold-case' reader directives have been
+implemented, and their effect is to modify the current read options of
+the current port only; similarly for `#!curly-infix'. Thus, it is
+possible, for instance, to have one port reading case-sensitive code,
+while another port reads case-insensitive code.
+
+** Futures may now be nested
+
+Futures may now be nested: a future can itself spawn and then `touch'
+other futures. In addition, any thread that touches a future that has
+not completed now processes other futures while waiting for the touched
+future to completed. This allows all threads to be kept busy, and was
+made possible by the use of delimited continuations (see the manual for
+details.)
+
+Consequently, `par-map' and `par-for-each' have been rewritten and can
+now use all cores.
+
+** `GUILE_LOAD_PATH' et al can now add directories to the end of the path
+
+`GUILE_LOAD_PATH' and `GUILE_LOAD_COMPILED_PATH' can now be used to add
+directories to both ends of the load path. If the special path
+component `...' (ellipsis) is present in these environment variables,
+then the default path is put in place of the ellipsis, otherwise the
+default path is placed at the end. See "Environment Variables" in the
+manual for details.
+
+** `load-in-vicinity' search for `.go' files in `%load-compiled-path'
+
+Previously, `load-in-vicinity' would look for compiled files in the
+auto-compilation cache, but not in `%load-compiled-path'. This is now
+fixed. This affects `load', and the `-l' command-line flag. See
+<http://bugs.gnu.org/12519> for details.
+
+** Extension search order fixed, and LD_LIBRARY_PATH preserved
+
+Up to 2.0.6, Guile would modify the `LD_LIBRARY_PATH' environment
+variable (or whichever is relevant for the host OS) to insert its own
+default extension directories in the search path (using GNU libltdl
+facilities was not possible here.) This approach was problematic in two
+ways.
+
+First, the `LD_LIBRARY_PATH' modification would be visible to
+sub-processes, and would also affect future calls to `dlopen', which
+could lead to subtle bugs in the application or sub-processes. Second,
+when the installation prefix is /usr, the `LD_LIBRARY_PATH' modification
+would typically end up inserting /usr/lib before /usr/local/lib in the
+search path, which is often the opposite of system-wide settings such as
+`ld.so.conf'.
+
+Both issues have now been fixed.
+
+** `make-vtable-vtable' is now deprecated
+
+Programs should instead use `make-vtable' and `<standard-vtable>'.
+
+** The `-Wduplicate-case-datum' and `-Wbad-case-datum' are enabled
+
+These recently introduced warnings have been documented and are now
+enabled by default when auto-compiling.
+
+** Optimize calls to `equal?' or `eqv?' with a constant argument
+
+The compiler simplifies calls to `equal?' or `eqv?' with a constant
+argument to use `eq?' instead, when applicable.
+
+* Manual updates
+
+** SRFI-9 records now documented under "Compound Data Types"
+
+The documentation of SRFI-9 record types has been moved in the "Compound
+Data Types", next to Guile's other record APIs. A new section
+introduces the various record APIs, and describes the trade-offs they
+make. These changes were made in an attempt to better guide users
+through the maze of records API, and to recommend SRFI-9 as the main
+API.
+
+The documentation of Guile's raw `struct' API has also been improved.
+
+** (ice-9 and-let-star) and (ice-9 curried-definitions) now documented
+
+These modules were missing from the manual.
+
+* New interfaces
+
+** New "functional record setters" as a GNU extension of SRFI-9
+
+The (srfi srfi-9 gnu) module now provides three new macros to deal with
+"updates" of immutable records: `define-immutable-record-type',
+`set-field', and `set-fields'.
+
+The first one allows record type "functional setters" to be defined;
+such setters keep the record unchanged, and instead return a new record
+with only one different field. The remaining macros provide the same
+functionality, and also optimize updates of multiple or nested fields.
+See the manual for details.
+
+** web: New `http-get*', `response-body-port', and `text-content-type?'
+ procedures
+
+These procedures return a port from which to read the response's body.
+Unlike `http-get' and `read-response-body', they allow the body to be
+processed incrementally instead of being stored entirely in memory.
+
+The `text-content-type?' predicate allows users to determine whether the
+content type of a response is textual.
+
+See the manual for details.
+
+** `string-split' accepts character sets and predicates
+
+The `string-split' procedure can now be given a SRFI-14 character set or
+a predicate, instead of just a character.
+
+** R6RS SRFI support
+
+Previously, in R6RS modules, Guile incorrectly ignored components of
+SRFI module names after the SRFI number, making it impossible to specify
+sub-libraries. This release corrects this, bringing us into accordance
+with SRFI 97.
+
+** `define-public' is no a longer curried definition by default
+
+The (ice-9 curried-definitions) should be used for such uses. See the
+manual for details.
+
+* Build fixes
+
+** Remove reference to `scm_init_popen' when `fork' is unavailable
+
+This fixes a MinGW build issue (http://bugs.gnu.org/12477).
+
+** Fix race between installing `guild' and the `guile-tools' symlink
+
+* Bug fixes
+
+** Procedures returned by `eval' now have docstrings
+ (http://bugs.gnu.org/12173)
+** web client: correctly handle uri-query, etc. in relative URI headers
+ (http://bugs.gnu.org/12827)
+** Fix docs for R6RS `hashtable-copy'
+** R6RS `string-for-each' now accepts multiple string arguments
+** Fix out-of-range error in the compiler's CSE pass
+ (http://bugs.gnu.org/12883)
+** Add missing R6RS `open-file-input/output-port' procedure
+** Futures: Avoid creating the worker pool more than once
+** Fix invalid assertion about mutex ownership in threads.c
+ (http://bugs.gnu.org/12719)
+** Have `SCM_NUM2FLOAT' and `SCM_NUM2DOUBLE' use `scm_to_double'
+** The `scandir' procedure now uses `lstat' instead of `stat'
+** Fix `generalized-vector->list' indexing bug with shared arrays
+ (http://bugs.gnu.org/12465)
+** web: Change `http-get' to try all the addresses for the given URI
+** Implement `hash' for structs
+ (http://lists.gnu.org/archive/html/guile-devel/2012-10/msg00031.html)
+** `read' now adds source properties for data types beyond pairs
+** Improve error reporting in `append!'
+** In fold-matches, set regexp/notbol unless matching string start
+** Don't stat(2) and access(2) the .go location before using it
+** SRFI-19: use zero padding for hours in ISO 8601 format, not blanks
+** web: Fix uri-encoding for strings with no unreserved chars, and octets 0-15
+** More robust texinfo alias handling
+** Optimize `format' and `simple-format'
+ (http://bugs.gnu.org/12033)
+** Angle of -0.0 is pi, not zero
+
+
Changes in 2.0.6 (since 2.0.5):
* Notable changes
diff --git a/THANKS b/THANKS
index 2dbf570..fc2bf49 100644
--- a/THANKS
+++ b/THANKS
@@ -48,6 +48,7 @@ For fixes or providing information which led to a fix:
Rob Browning
Adrian Bunk
Michael Carmack
+ Jozef Chraplewski
R Clayton
Tristan Colgate
Stephen Compall
@@ -156,6 +157,7 @@ For fixes or providing information which led to a fix:
Panagiotis Vossos
Neil W. Van Dyke
Aaron VanDevender
+ Sjoerd Van Leent
Andreas Vögele
Michael Talbot-Wilson
Michael Tuexen
diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh
index c8abd55..0c0bc4b 100755
--- a/build-aux/gendocs.sh
+++ b/build-aux/gendocs.sh
@@ -2,10 +2,10 @@
# gendocs.sh -- generate a GNU manual in many formats. This script is
# mentioned in maintain.texi. See the help message below for usage details.
-scriptversion=2011-04-08.14
+scriptversion=2012-10-27.11
-# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software
-# Foundation, Inc.
+# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+# Free Software Foundation, Inc.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -30,6 +30,12 @@ scriptversion=2011-04-08.14
#
# An up-to-date copy is also maintained in Gnulib (gnu.org/software/gnulib).
+# TODO:
+# - image importation was only implemented for HTML generated by
+# makeinfo. But it should be simple enough to adjust.
+# - images are not imported in the source tarball. All the needed
+# formats (PDF, PNG, etc.) should be included.
+
prog=`basename "$0"`
srcdir=`pwd`
@@ -39,35 +45,37 @@
templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/
: ${SETLANG="env LANG= LC_MESSAGES= LC_ALL= LANGUAGE="}
: ${MAKEINFO="makeinfo"}
: ${TEXI2DVI="texi2dvi -t @finalout"}
-: ${DVIPS="dvips"}
: ${DOCBOOK2HTML="docbook2html"}
: ${DOCBOOK2PDF="docbook2pdf"}
-: ${DOCBOOK2PS="docbook2ps"}
: ${DOCBOOK2TXT="docbook2txt"}
: ${GENDOCS_TEMPLATE_DIR="."}
+: ${PERL='perl'}
: ${TEXI2HTML="texi2html"}
unset CDPATH
unset use_texi2html
version="gendocs.sh $scriptversion
-Copyright 2010 Free Software Foundation, Inc.
+Copyright 2012 Free Software Foundation, Inc.
There is NO warranty. You may redistribute this software
under the terms of the GNU General Public License.
For more information about these matters, see the files named COPYING."
usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE
-Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source.
-See the GNU Maintainers document for a more extensive discussion:
+Generate output in various formats from PACKAGE.texinfo (or .texi or
+.txi) source. See the GNU Maintainers document for a more extensive
+discussion:
http://www.gnu.org/prep/maintain_toc.html
Options:
-s SRCFILE read Texinfo from SRCFILE, instead of PACKAGE.{texinfo|texi|txi}
-o OUTDIR write files into OUTDIR, instead of manual/.
+ -I DIR append DIR to the Texinfo search path.
--email ADR use ADR as contact in generated web pages.
- --docbook convert to DocBook too (xml, txt, html, pdf and ps).
+ --docbook convert through DocBook too (xml, txt, html, pdf).
--html ARG pass indicated ARG to makeinfo or texi2html for HTML targets.
+ --info ARG pass indicated ARG to makeinfo for Info, instead of --no-split.
--texi2html use texi2html to generate HTML targets.
--help display this help and exit successfully.
--version display version information and exit successfully.
@@ -80,11 +88,11 @@ Typical sequence:
wget \"$templateurl\"
$prog --email BUGLIST MANUAL \"GNU MANUAL - One-line description\"
-Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR
-to override). Move all the new files into your web CVS tree, as
-explained in the Web Pages node of maintain.texi.
+Output will be in a new subdirectory \"manual\" (by default;
+use -o OUTDIR to override). Move all the new files into your web CVS
+tree, as explained in the Web Pages node of maintain.texi.
-Please use the --email ADDRESS option to specify your bug-reporting
+Please do use the --email ADDRESS option to specify your bug-reporting
address in the generated HTML pages.
MANUAL-TITLE is included as part of the HTML <title> of the overall
@@ -102,11 +110,14 @@ If a manual's Texinfo sources are spread across several
directories,
first copy or symlink all Texinfo sources into a single directory.
(Part of the script's work is to make a tar.gz of the sources.)
-You can set the environment variables MAKEINFO, TEXI2DVI, TEXI2HTML, and
-DVIPS to control the programs that get executed, and
+As implied above, by default monolithic Info files are generated.
+If you want split Info, or other Info options, use --info to override.
+
+You can set the environment variables MAKEINFO, TEXI2DVI, TEXI2HTML,
+and PERL to control the programs that get executed, and
GENDOCS_TEMPLATE_DIR to control where the gendocs_template file is
looked for. With --docbook, the environment variables DOCBOOK2HTML,
-DOCBOOK2PDF, DOCBOOK2PS, and DOCBOOK2TXT are also respected.
+DOCBOOK2PDF, and DOCBOOK2TXT are also respected.
By default, makeinfo and texi2dvi are run in the default (English)
locale, since that's the language of most Texinfo manuals. If you
@@ -116,16 +127,13 @@ SETLANG setting in the source.
Email bug reports or enhancement requests to address@hidden
"
-calcsize()
-{
- size=`ls -ksl $1 | awk '{print $1}'`
- echo $size
-}
-
MANUAL_TITLE=
PACKAGE=
address@hidden # please override with --email
+commonarg= # Options passed to all the tools (-I dir).
+dirs= # -I's directories.
htmlarg=
+infoarg=--no-split
outdir=manual
srcfile=
@@ -136,8 +144,10 @@ while test $# -gt 0; do
--version) echo "$version"; exit 0;;
-s) shift; srcfile=$1;;
-o) shift; outdir=$1;;
+ -I) shift; commonarg="$commonarg -I '$1'"; dirs="$dirs $1";;
--docbook) docbook=yes;;
--html) shift; htmlarg=$1;;
+ --info) shift; infoarg=$1;;
--texi2html) use_texi2html=1;;
-*)
echo "$0: Unknown option \`$1'." >&2
@@ -183,15 +193,64 @@ if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then
exit 1
fi
+# Function to return size of $1 in something resembling kilobytes.
+calcsize()
+{
+ size=`ls -ksl $1 | awk '{print $1}'`
+ echo $size
+}
+
+# copy_images OUTDIR HTML-FILE...
+# -------------------------------
+# Copy all the images needed by the HTML-FILEs into OUTDIR. Look
+# for them in the -I directories.
+copy_images()
+{
+ local odir
+ odir=$1
+ shift
+ $PERL -n -e "
+BEGIN {
+ \$me = '$prog';
+ \$odir = '$odir';
+ @dirs = qw($dirs);
+}
+" -e '
+/<img src="(.*?)"/g && ++$need{$1};
+
+END {
+ #print "$me: @{[keys %need]}\n"; # for debugging, show images found.
+ FILE: for my $f (keys %need) {
+ for my $d (@dirs) {
+ if (-f "$d/$f") {
+ use File::Basename;
+ my $dest = dirname ("$odir/$f");
+ #
+ use File::Path;
+ -d $dest || mkpath ($dest)
+ || die "$me: cannot mkdir $dest: $!\n";
+ #
+ use File::Copy;
+ copy ("$d/$f", $dest)
+ || die "$me: cannot copy $d/$f to $dest: $!\n";
+ next FILE;
+ }
+ }
+ die "$me: $ARGV: cannot find image $f\n";
+ }
+}
+' -- "$@" || exit 1
+}
+
case $outdir in
/*) abs_outdir=$outdir;;
*) abs_outdir=$srcdir/$outdir;;
esac
-echo Generating output formats for $srcfile
+echo "Generating output formats for $srcfile"
-cmd="$SETLANG $MAKEINFO -o $PACKAGE.info \"$srcfile\""
-echo "Generating info files... ($cmd)"
+cmd="$SETLANG $MAKEINFO -o $PACKAGE.info $commonarg $infoarg \"$srcfile\""
+echo "Generating info file(s)... ($cmd)"
eval "$cmd"
mkdir -p "$outdir/"
tar czf "$outdir/$PACKAGE.info.tar.gz" $PACKAGE.info*
@@ -199,29 +258,23 @@ info_tgz_size=`calcsize "$outdir/$PACKAGE.info.tar.gz"`
# do not mv the info files, there's no point in having them available
# separately on the web.
-cmd="$SETLANG ${TEXI2DVI} \"$srcfile\""
+cmd="$SETLANG $TEXI2DVI $commonarg \"$srcfile\""
echo "Generating dvi ... ($cmd)"
eval "$cmd"
-# now, before we compress dvi:
-echo Generating postscript...
-${DVIPS} $PACKAGE -o
-gzip -f -9 $PACKAGE.ps
-ps_gz_size=`calcsize $PACKAGE.ps.gz`
-mv $PACKAGE.ps.gz "$outdir/"
-
# compress/finish dvi:
gzip -f -9 $PACKAGE.dvi
dvi_gz_size=`calcsize $PACKAGE.dvi.gz`
mv $PACKAGE.dvi.gz "$outdir/"
-cmd="$SETLANG ${TEXI2DVI} --pdf \"$srcfile\""
+cmd="$SETLANG $TEXI2DVI --pdf $commonarg \"$srcfile\""
echo "Generating pdf ... ($cmd)"
eval "$cmd"
pdf_size=`calcsize $PACKAGE.pdf`
mv $PACKAGE.pdf "$outdir/"
-cmd="$SETLANG $MAKEINFO -o $PACKAGE.txt --no-split --no-headers \"$srcfile\""
+opt="-o $PACKAGE.txt --no-split --no-headers $commonarg"
+cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
echo "Generating ASCII... ($cmd)"
eval "$cmd"
ascii_size=`calcsize $PACKAGE.txt`
@@ -231,7 +284,7 @@ mv $PACKAGE.txt "$outdir/"
html_split()
{
- opt="--split=$1 $htmlarg --node-files"
+ opt="--split=$1 $commonarg $htmlarg --node-files"
cmd="$SETLANG $TEXI2HTML --output $PACKAGE.html $opt \"$srcfile\""
echo "Generating html by $1... ($cmd)"
eval "$cmd"
@@ -249,7 +302,7 @@ html_split()
}
if test -z "$use_texi2html"; then
- opt="--no-split --html -o $PACKAGE.html $htmlarg"
+ opt="--no-split --html -o $PACKAGE.html $commonarg $htmlarg"
cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
echo "Generating monolithic html... ($cmd)"
rm -rf $PACKAGE.html # in case a directory is left over
@@ -257,23 +310,25 @@ if test -z "$use_texi2html"; then
html_mono_size=`calcsize $PACKAGE.html`
gzip -f -9 -c $PACKAGE.html >"$outdir/$PACKAGE.html.gz"
html_mono_gz_size=`calcsize "$outdir/$PACKAGE.html.gz"`
+ copy_images "$outdir/" $PACKAGE.html
mv $PACKAGE.html "$outdir/"
- cmd="$SETLANG $MAKEINFO --html -o $PACKAGE.html $htmlarg \"$srcfile\""
+ opt="--html -o $PACKAGE.html $commonarg $htmlarg"
+ cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
echo "Generating html by node... ($cmd)"
eval "$cmd"
split_html_dir=$PACKAGE.html
+ copy_images $split_html_dir/ $split_html_dir/*.html
(
- cd ${split_html_dir} || exit 1
- tar -czf "$abs_outdir/${PACKAGE}.html_node.tar.gz" -- *.html
+ cd $split_html_dir || exit 1
+ tar -czf "$abs_outdir/$PACKAGE.html_node.tar.gz" -- *
)
- html_node_tgz_size=`calcsize "$outdir/${PACKAGE}.html_node.tar.gz"`
- rm -f "$outdir"/html_node/*.html
- mkdir -p "$outdir/html_node/"
- mv ${split_html_dir}/*.html "$outdir/html_node/"
- rmdir ${split_html_dir}
+ html_node_tgz_size=`calcsize "$outdir/$PACKAGE.html_node.tar.gz"`
+ rm -rf "$outdir/html_node/"
+ mv $split_html_dir "$outdir/html_node/"
else
- cmd="$SETLANG $TEXI2HTML --output $PACKAGE.html $htmlarg \"$srcfile\""
+ opt="--output $PACKAGE.html $commonarg $htmlarg"
+ cmd="$SETLANG $TEXI2HTML $opt \"$srcfile\""
echo "Generating monolithic html... ($cmd)"
rm -rf $PACKAGE.html # in case a directory is left over
eval "$cmd"
@@ -297,7 +352,8 @@ d=`dirname $srcfile`
texi_tgz_size=`calcsize "$outdir/$PACKAGE.texi.tar.gz"`
if test -n "$docbook"; then
- cmd="$SETLANG $MAKEINFO -o - --docbook \"$srcfile\" >
${srcdir}/$PACKAGE-db.xml"
+ opt="-o - --docbook $commonarg"
+ cmd="$SETLANG $MAKEINFO $opt \"$srcfile\" >${srcdir}/$PACKAGE-db.xml"
echo "Generating docbook XML... ($cmd)"
eval "$cmd"
docbook_xml_size=`calcsize $PACKAGE-db.xml`
@@ -306,7 +362,8 @@ if test -n "$docbook"; then
mv $PACKAGE-db.xml "$outdir/"
split_html_db_dir=html_node_db
- cmd="${DOCBOOK2HTML} -o $split_html_db_dir \"${outdir}/$PACKAGE-db.xml\""
+ opt="$commonarg -o $split_html_db_dir"
+ cmd="$DOCBOOK2HTML $opt \"${outdir}/$PACKAGE-db.xml\""
echo "Generating docbook HTML... ($cmd)"
eval "$cmd"
(
@@ -319,20 +376,13 @@ if test -n "$docbook"; then
mv ${split_html_db_dir}/*.html "$outdir/html_node_db/"
rmdir ${split_html_db_dir}
- cmd="${DOCBOOK2TXT} \"${outdir}/$PACKAGE-db.xml\""
+ cmd="$DOCBOOK2TXT \"${outdir}/$PACKAGE-db.xml\""
echo "Generating docbook ASCII... ($cmd)"
eval "$cmd"
docbook_ascii_size=`calcsize $PACKAGE-db.txt`
mv $PACKAGE-db.txt "$outdir/"
- cmd="${DOCBOOK2PS} \"${outdir}/$PACKAGE-db.xml\""
- echo "Generating docbook PS... ($cmd)"
- eval "$cmd"
- gzip -f -9 -c $PACKAGE-db.ps >"$outdir/$PACKAGE-db.ps.gz"
- docbook_ps_gz_size=`calcsize "$outdir/$PACKAGE-db.ps.gz"`
- mv $PACKAGE-db.ps "$outdir/"
-
- cmd="${DOCBOOK2PDF} \"${outdir}/$PACKAGE-db.xml\""
+ cmd="$DOCBOOK2PDF \"${outdir}/$PACKAGE-db.xml\""
echo "Generating docbook PDF... ($cmd)"
eval "$cmd"
docbook_pdf_size=`calcsize $PACKAGE-db.pdf`
@@ -346,6 +396,7 @@ if test -z "$use_texi2html"; then
else
CONDS="/%%ENDIF.*%%/d;/%%IF *HTML_SECTION%%/d;/%%IF *HTML_CHAPTER%%/d"
fi
+
curdate=`$SETLANG date '+%B %d, %Y'`
sed \
-e "s!%%TITLE%%!$MANUAL_TITLE!g" \
@@ -360,13 +411,11 @@ sed \
-e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \
-e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \
-e "s!%%PDF_SIZE%%!$pdf_size!g" \
- -e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \
-e "s!%%ASCII_SIZE%%!$ascii_size!g" \
-e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \
-e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \
-e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \
-e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \
- -e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \
-e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \
-e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \
-e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 17c4562..5184edc 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -3,7 +3,7 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
if 0;
# Convert git log output to ChangeLog format.
-my $VERSION = '2012-05-22 09:40'; # UTC
+my $VERSION = '2012-07-29 06:11'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -68,6 +68,8 @@ OPTIONS:
header; the default is to cluster adjacent commit messages
if their headers are the same and neither commit message
contains multiple paragraphs.
+ --srcdir=DIR the root of the source tree, from which the .git/
+ directory can be derived.
--since=DATE convert only the logs since DATE;
the default is to convert all log entries.
--format=FMT set format string for commit subject and body;
@@ -192,6 +194,30 @@ sub parse_amend_file($)
return $h;
}
+# git_dir_option $SRCDIR
+#
+# From $SRCDIR, the --git-dir option to pass to git (none if $SRCDIR
+# is undef). Return as a list (0 or 1 element).
+sub git_dir_option($)
+{
+ my ($srcdir) = @_;
+ my @res = ();
+ if (defined $srcdir)
+ {
+ my $qdir = shell_quote $srcdir;
+ my $cmd = "cd $qdir && git rev-parse --show-toplevel";
+ my $qcmd = shell_quote $cmd;
+ my $git_dir = qx($cmd);
+ defined $git_dir
+ or die "$ME: cannot run $qcmd: $!\n";
+ $? == 0
+ or die "$ME: $qcmd had unexpected exit code or signal ($?)\n";
+ chomp $git_dir;
+ push @res, "--git-dir=$git_dir/.git";
+ }
+ @res;
+}
+
{
my $since_date;
my $format_string = '%s%n%b%n';
@@ -200,6 +226,7 @@ sub parse_amend_file($)
my $cluster = 1;
my $strip_tab = 0;
my $strip_cherry_pick = 0;
+ my $srcdir;
GetOptions
(
help => sub { usage 0 },
@@ -211,9 +238,9 @@ sub parse_amend_file($)
'cluster!' => \$cluster,
'strip-tab' => \$strip_tab,
'strip-cherry-pick' => \$strip_cherry_pick,
+ 'srcdir=s' => \$srcdir,
) or usage 1;
-
defined $since_date
and unshift @ARGV, "--since=$since_date";
@@ -221,7 +248,9 @@ sub parse_amend_file($)
# that makes a correction in the log or attribution of that commit.
my $amend_code = defined $amend_file ? parse_amend_file $amend_file : {};
- my @cmd = (qw (git log --log-size),
+ my @cmd = ('git',
+ git_dir_option $srcdir,
+ qw(log --log-size),
'--pretty=format:%H:%ct %an <%ae>%n%n'.$format_string, @ARGV);
open PIPE, '-|', @cmd
or die ("$ME: failed to run '". quoted_cmd (@cmd) ."': $!\n"
diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update
index 851f8b8..4acd69d 100755
--- a/build-aux/gnu-web-doc-update
+++ b/build-aux/gnu-web-doc-update
@@ -24,9 +24,6 @@ VERSION=2009-07-21.16; # UTC
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
-# Requirements: everything required to bootstrap your package,
-# plus these: git, cvs, cvsu, rsync, mktemp
-
ME=$(basename "$0")
warn() { printf '%s: %s\n' "$ME" "$*" >&2; }
die() { warn "$*"; exit 1; }
@@ -36,10 +33,9 @@ help()
cat <<EOF
Usage: $ME
-Run this script from top_srcdir (no options or arguments) after each
-non-alpha release, to update the web documentation at
-http://www.gnu.org/software/\$pkg/manual/ Run it from your project's
-the top-level directory.
+Run this script from top_srcdir (no arguments) after each non-alpha
+release, to update the web documentation at
+http://www.gnu.org/software/\$pkg/manual/
Options:
-C, --builddir=DIR location of (configured) Makefile (default: .)
@@ -64,6 +60,51 @@ EOF
exit
}
+# find_tool ENVVAR NAMES...
+# -------------------------
+# Search for a required program. Use the value of ENVVAR, if set,
+# otherwise find the first of the NAMES that can be run (i.e.,
+# supports --version). If found, set ENVVAR to the program name,
+# die otherwise.
+#
+# FIXME: code duplication, see also bootstrap.
+find_tool ()
+{
+ find_tool_envvar=$1
+ shift
+ find_tool_names=$@
+ eval "find_tool_res=\$$find_tool_envvar"
+ if test x"$find_tool_res" = x; then
+ for i
+ do
+ if ($i --version </dev/null) >/dev/null 2>&1; then
+ find_tool_res=$i
+ break
+ fi
+ done
+ else
+ find_tool_error_prefix="\$$find_tool_envvar: "
+ fi
+ test x"$find_tool_res" != x \
+ || die "one of these is required: $find_tool_names"
+ ($find_tool_res --version </dev/null) >/dev/null 2>&1 \
+ || die "${find_tool_error_prefix}cannot run $find_tool_res --version"
+ eval "$find_tool_envvar=\$find_tool_res"
+ eval "export $find_tool_envvar"
+}
+
+## ------ ##
+## Main. ##
+## ------ ##
+
+# Requirements: everything required to bootstrap your package, plus
+# these.
+find_tool CVS cvs
+find_tool CVSU cvsu
+find_tool GIT git
+find_tool RSYNC rsync
+find_tool XARGS gxargs xargs
+
builddir=.
while test $# != 0
do
@@ -86,22 +127,22 @@ do
done
test $# = 0 \
- || die "$ME: too many arguments"
+ || die "too many arguments"
prev=.prev-version
-version=$(cat $prev) || die "$ME: no $prev file?"
+version=$(cat $prev) || die "no $prev file?"
pkg=$(sed -n 's/^PACKAGE = \(.*\)/\1/p' $builddir/Makefile) \
- || die "$ME: no Makefile?"
+ || die "no Makefile?"
tmp_branch=web-doc-$version-$$
-current_branch=$(git branch | sed -ne '/^\* /{s///;p;q;}')
+current_branch=$($GIT branch | sed -ne '/^\* /{s///;p;q;}')
cleanup()
{
__st=$?
rm -rf "$tmp"
- git checkout "$current_branch"
- git submodule update --recursive
- git branch -d $tmp_branch
+ $GIT checkout "$current_branch"
+ $GIT submodule update --recursive
+ $GIT branch -d $tmp_branch
exit $__st
}
trap cleanup 0
@@ -111,8 +152,8 @@ trap 'exit $?' 1 2 13 15
# just-released version number, not some string like 7.6.18-20761.
# That version string propagates into all documentation.
set -e
-git checkout -b $tmp_branch v$version
-git submodule update --recursive
+$GIT checkout -b $tmp_branch v$version
+$GIT submodule update --recursive
./bootstrap
srcdir=$(pwd)
cd "$builddir"
@@ -125,16 +166,18 @@ set +e
tmp=$(mktemp -d web-doc-update.XXXXXX) || exit 1
( cd $tmp \
- && cvs -d address@hidden:/webcvs/$pkg co $pkg )
-rsync -avP "$builddir"/doc/manual/ $tmp/$pkg/manual
+ && $CVS -d address@hidden:/webcvs/$pkg co $pkg )
+$RSYNC -avP "$builddir"/doc/manual/ $tmp/$pkg/manual
(
cd $tmp/$pkg/manual
# Add any new files:
- cvsu --types='?'|sed s/..// | xargs --no-run-if-empty -- cvs add -ko
+ $CVSU --types='?' \
+ | sed s/..// \
+ | $XARGS --no-run-if-empty -- $CVS add -ko
- cvs ci -m $version
+ $CVS ci -m $version
)
# Local variables:
diff --git a/configure.ac b/configure.ac
index 8adfd47..e5002b0 100644
--- a/configure.ac
+++ b/configure.ac
@@ -35,8 +35,8 @@ AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_SRCDIR(GUILE-VERSION)
-dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11.
-AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override color-tests dist-xz])
+dnl `AM_PROG_AR' was introduced in Automake 1.11.2.
+AM_INIT_AUTOMAKE([1.11.2 gnu no-define -Wall -Wno-override color-tests
dist-xz])
m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])],
[AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
@@ -79,10 +79,6 @@ AC_PROG_LIBTOOL
AM_CONDITIONAL([HAVE_SHARED_LIBRARIES], [test "x$enable_shared" = "xyes"])
-AC_DEFINE_UNQUOTED([SHARED_LIBRARY_PATH_VARIABLE], ["$shlibpath_var"],
- [Name of the environment variable that tells the dynamic linker where
-to find shared libraries.])
-
dnl Check for libltdl.
AC_LIB_HAVE_LINKFLAGS([ltdl], [], [#include <ltdl.h>],
[lt_dlopenext ("foo");])
@@ -748,11 +744,14 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
+# fork - unavailable on Windows
# utimensat: posix.1-2008
# sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown fchmod getcwd geteuid getsid gettimeofday gmtime_r ioctl
lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename
rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt
stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname
waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent
getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index
bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l
newlocale utimensat sched_getaffinity sched_setaffinity])
+AM_CONDITIONAL([HAVE_FORK], [test "x$ac_cv_func_fork" = "xyes"])
+
# Reasons for testing:
# netdb.h - not in mingw
# sys/param.h - not in mingw
diff --git a/doc/gendocs_template b/doc/gendocs_template
index f3a3ff6..a62ad61 100644
--- a/doc/gendocs_template
+++ b/doc/gendocs_template
@@ -45,8 +45,6 @@
(%%ASCII_GZ_SIZE%%K bytes gzipped)</a>.</li>
<li><a href="%%PACKAGE%%.dvi.gz">TeX dvi file
(%%DVI_GZ_SIZE%%K bytes gzipped)</a>.</li>
-<li><a href="%%PACKAGE%%.ps.gz">PostScript file
- (%%PS_GZ_SIZE%%K bytes gzipped)</a>.</li>
<li><a href="%%PACKAGE%%.pdf">PDF file
(%%PDF_SIZE%%K bytes)</a>.</li>
<li><a href="%%PACKAGE%%.texi.tar.gz">Texinfo source
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 0b21065..be3d65f 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -105,10 +105,14 @@ Return 1 when @var{x} is a pair; otherwise return 0.
The two parts of a pair are traditionally called @dfn{car} and
@dfn{cdr}. They can be retrieved with procedures of the same name
(@code{car} and @code{cdr}), and can be modified with the procedures
address@hidden and @code{set-cdr!}. Since a very common operation in
-Scheme programs is to access the car of a car of a pair, or the car of
-the cdr of a pair, etc., the procedures called @code{caar},
address@hidden and so on are also predefined.
address@hidden and @code{set-cdr!}.
+
+Since a very common operation in Scheme programs is to access the car of
+a car of a pair, or the car of the cdr of a pair, etc., the procedures
+called @code{caar}, @code{cadr} and so on are also predefined. However,
+using these procedures is often detrimental to readability, and
+error-prone. Thus, accessing the contents of a list is usually better
+achieved using pattern matching techniques (@pxref{Pattern Matching}).
@rnindex car
@rnindex cdr
@@ -2381,9 +2385,9 @@ You may use @code{set-record-type-printer!} to customize
the default printing
behavior of records. This is a Guile extension and is not part of SRFI-9. It
is located in the @nicode{(srfi srfi-9 gnu)} module.
address@hidden {Scheme Syntax} set-record-type-printer! name thunk
address@hidden {Scheme Syntax} set-record-type-printer! name proc
Where @var{type} corresponds to the first argument of
@code{define-record-type},
-and @var{thunk} is a procedure accepting two arguments, the record to print,
and
+and @var{proc} is a procedure accepting two arguments, the record to print, and
an output port.
@end deffn
@@ -3717,12 +3721,6 @@ search in constant time. The drawback is that hash
tables require a
little bit more memory, and that you can not use the normal list
procedures (@pxref{Lists}) for working with them.
-Guile provides two types of hashtables. One is an abstract data type
-that can only be manipulated with the functions in this section. The
-other type is concrete: it uses a normal vector with alists as
-elements. The advantage of the abstract hash tables is that they will
-be automatically resized when they become too full or too empty.
-
@menu
* Hash Table Examples:: Demonstration of hash table usage.
* Hash Table Reference:: Hash table procedure descriptions.
@@ -3746,13 +3744,6 @@ h
@result{}
#<hash-table 0/31>
-;; We can also use a vector of alists.
-(define h (make-vector 7 '()))
-
-h
address@hidden
-#(() () () () () () ())
-
;; Inserting into a hash table can be done with hashq-set!
(hashq-set! h 'foo "bar")
@result{}
@@ -3766,17 +3757,6 @@ h
(hashq-create-handle! h 'frob #f)
@result{}
(frob . #f)
-
-;; The vector now contains three elements in the alists and the frob
-;; entry is at index (hashq 'frob).
-h
address@hidden
-#(((braz . "zonk")) ((foo . "bar")) () () () () ((frob . #f)))
-
-(hashq 'frob 7)
address@hidden
-6
-
@end lisp
You can get the value for a given key with the procedure
@@ -3845,19 +3825,12 @@ Hash tables are implemented as a vector indexed by a
hash value formed
from the key, with an association list of key/value pairs for each
bucket in case distinct keys hash together. Direct access to the
pairs in those lists is provided by the @code{-handle-} functions.
-The abstract kind of hash tables hide the vector in an opaque object
-that represents the hash table, while for the concrete kind the vector
address@hidden the hashtable.
-
-When the number of table entries in an abstract hash table goes above
-a threshold, the vector is made larger and the entries are rehashed,
-to prevent the bucket lists from becoming too long and slowing down
-accesses. When the number of entries goes below a threshold, the
-vector is shrunk to save space.
-A abstract hash table is created with @code{make-hash-table}. To
-create a vector that is suitable as a hash table, use
address@hidden(make-vector @var{size} '())}, for example.
+When the number of entries in a hash table goes above a threshold, the
+vector is made larger and the entries are rehashed, to prevent the
+bucket lists from becoming too long and slowing down accesses. When the
+number of entries goes below a threshold, the vector is shrunk to save
+space.
For the @code{hashx-} ``extended'' routines, an application supplies a
@var{hash} function producing an integer index like @code{hashq} etc
@@ -3892,7 +3865,7 @@ addition to @code{hashq} etc below, include
@code{symbol-hash}
@sp 1
@deffn {Scheme Procedure} make-hash-table [size]
-Create a new abstract hash table object, with an optional minimum
+Create a new hash table object, with an optional minimum
vector @var{size}.
When @var{size} is given, the table vector will still grow and shrink
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index c471f64..2e5a3d2 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -661,7 +661,8 @@ name is as for @code{compile-file} (see below).
Emit warnings of type @var{warning}; use @code{--warn=help} for a list
of available warnings and their description. Currently recognized
warnings include @code{unused-variable}, @code{unused-toplevel},
address@hidden, @code{arity-mismatch}, and @code{format}.
address@hidden, @code{arity-mismatch}, @code{format},
address@hidden, and @code{bad-case-datum}.
@item -f @var{lang}
@itemx address@hidden
@@ -837,14 +838,16 @@ The procedure in the previous section look for Scheme
code in the file
system at specific location. Guile also has some procedures to search
the load path for code.
address@hidden @env{GUILE_LOAD_PATH}
@defvar %load-path
List of directories which should be searched for Scheme modules and
-libraries. @code{%load-path} is initialized when Guile starts up to
address@hidden(list (%site-dir) (%library-dir) (%package-data-dir))}, prepended
-with the contents of the @env{GUILE_LOAD_PATH} environment variable, if
-it is set. @xref{Build Config}, for more on @code{%site-dir} and
-related procedures.
+libraries. When Guile starts up, @code{%load-path} is initialized to
+the default load path @code{(list (%library-dir) (%site-dir)
+(%global-site-dir) (%package-data-dir))}. The @env{GUILE_LOAD_PATH}
+environment variable can be used to prepend or append additional
+directories (@pxref{Environment Variables}).
+
address@hidden Config}, for more on @code{%site-dir} and related
+procedures.
@end defvar
@deffn {Scheme Procedure} load-from-path filename
@@ -912,7 +915,9 @@ using @code{load-compiled}.
@defvar %load-compiled-path
Like @code{%load-path}, but for compiled files. By default, this path
has two entries: one for compiled files from Guile itself, and one for
-site packages.
+site packages. The @env{GUILE_LOAD_COMPILED_PATH} environment variable
+can be used to prepend or append additional directories
+(@pxref{Environment Variables}).
@end defvar
When @code{primitive-load-path} searches the @code{%load-compiled-path}
@@ -942,6 +947,15 @@ a list and return the resulting list with @var{tail}
appended. If
@var{path} is @code{#f}, @var{tail} is returned.
@end deffn
address@hidden {Scheme Procedure} parse-path-with-ellipsis path base
address@hidden {C Function} scm_parse_path_with_ellipsis (path, base)
+Parse @var{path}, which is expected to be a colon-separated string, into
+a list and return the resulting list with @var{base} (a list) spliced in
+place of the @code{...} path component, if present, or else @var{base}
+is added to the end. If @var{path} is @code{#f}, @var{base} is
+returned.
address@hidden deffn
+
@deffn {Scheme Procedure} search-path path filename [extensions
[require-exts?]]
@deffnx {C Function} scm_search_path (path, filename, rest)
Search @var{path} for a directory containing a file named
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 02d7771..d77a2bd 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010,
address@hidden 2011, 2012 Free Software Foundation, Inc.
address@hidden 2011, 2012, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Procedures
@@ -270,6 +270,33 @@ sense at certain points in the program, delimited by these
@code{arity:start} and @code{arity:end} values.
@end deffn
address@hidden {Scheme Procedure} program-arguments-alist program [ip]
+Return an association list describing the arguments that @var{program}
accepts, or
address@hidden if the information cannot be obtained.
+
+For example:
address@hidden
+(program-arguments-alist
+ (lambda* (a b #:optional c #:key (d 1) #:rest e)
+ #t)) @result{}
+((required . (a b))
+ (optional . (c))
+ (keyword . ((#:d . 4)))
+ (allow-other-keys? . #f)
+ (rest . d))
address@hidden example
+
+The alist keys that are currently defined are `required', `optional',
+`keyword', `allow-other-keys?', and `rest'.
+
address@hidden {Scheme Procedure} program-lambda-list program [ip]
+Accessors for a representation of the arguments of a program, with both
+names and types (ie. either required, optional or keywords)
+
address@hidden returns this information in the form of
+an association list while @code{program-lambda-list} returns the same
+information in a form similar to a lambda definition.
address@hidden deffn
@node Optional Arguments
@subsection Optional Arguments
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index a301663..9c2b413 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -982,6 +982,24 @@ machine, though, the computation of @code{(find prime?
lst2)} may be
done in parallel with that of the other @code{find} call, which can
reduce the execution time of @code{find-prime}.
+Futures may be nested: a future can itself spawn and then @code{touch}
+other futures, leading to a directed acyclic graph of futures. Using
+this facility, a parallel @code{map} procedure can be defined along
+these lines:
+
address@hidden
+(use-modules (ice-9 futures) (ice-9 match))
+
+(define (par-map proc lst)
+ (match lst
+ (()
+ '())
+ ((head tail ...)
+ (let ((tail (future (par-map proc tail)))
+ (head (proc head)))
+ (cons head (touch tail))))))
address@hidden lisp
+
Note that futures are intended for the evaluation of purely functional
expressions. Expressions that have side-effects or rely on I/O may
require additional care, such as explicit synchronization
@@ -995,6 +1013,15 @@ pool contains one thread per available CPU core, minus
one, to account
for the main thread. The number of available CPU cores is determined
using @code{current-processor-count} (@pxref{Processes}).
+When a thread touches a future that has not completed yet, it processes
+any pending future while waiting for it to complete, or just waits if
+there are no pending futures. When @code{touch} is called from within a
+future, the execution of the calling future is suspended, allowing its
+host thread to process other futures, and resumed when the touched
+future has completed. This suspend/resume is achieved by capturing the
+calling future's continuation, and later reinstating it (@pxref{Prompts,
+delimited continuations}).
+
@deffn {Scheme Syntax} future exp
Return a future for expression @var{exp}. This is equivalent to:
@@ -1024,7 +1051,8 @@ Return the result of the expression embedded in future
@var{f}.
If the result was already computed in parallel, @code{touch} returns
instantaneously. Otherwise, it waits for the computation to complete,
-if it already started, or initiates it.
+if it already started, or initiates it. In the former case, the calling
+thread may process other futures in the meantime.
@end deffn
diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi
index 08c1698..5a9a3f7 100644
--- a/doc/ref/guile-invoke.texi
+++ b/doc/ref/guile-invoke.texi
@@ -295,8 +295,10 @@ variable. By default, the history file is
@file{$HOME/.guile_history}.
@vindex GUILE_LOAD_COMPILED_PATH
This variable may be used to augment the path that is searched for
compiled Scheme files (@file{.go} files) when loading. Its value should
-be a colon-separated list of directories, which will be prefixed to the
-value of the default search path stored in @code{%load-compiled-path}.
+be a colon-separated list of directories. If it contains the special
+path component @code{...} (ellipsis), then the default path is put in
+place of the ellipsis, otherwise the default path is placed at the end.
+The result is stored in @code{%load-compiled-path} (@pxref{Load Paths}).
Here is an example using the Bash shell that adds the current directory,
@file{.}, and the relative directory @file{../my-library} to
@@ -312,18 +314,23 @@ $ guile -c '(display %load-compiled-path) (newline)'
@vindex GUILE_LOAD_PATH
This variable may be used to augment the path that is searched for
Scheme files when loading. Its value should be a colon-separated list
-of directories, which will be prefixed to the value of the default
-search path stored in @code{%load-path}.
+of directories. If it contains the special path component @code{...}
+(ellipsis), then the default path is put in place of the ellipsis,
+otherwise the default path is placed at the end. The result is stored
+in @code{%load-path} (@pxref{Load Paths}).
-Here is an example using the Bash shell that adds the current directory
-and the parent of the current directory to @code{%load-path}:
+Here is an example using the Bash shell that prepends the current
+directory to @code{%load-path}, and adds the relative directory
address@hidden/srfi} to the end:
@example
-$ env GUILE_LOAD_PATH=".:.." \
+$ env GUILE_LOAD_PATH=".:...:../srfi" \
guile -c '(display %load-path) (newline)'
-(. .. /usr/local/share/guile/2.0 \
+(. /usr/local/share/guile/2.0 \
/usr/local/share/guile/site/2.0 \
-/usr/local/share/guile/site /usr/local/share/guile)
+/usr/local/share/guile/site \
+/usr/local/share/guile \
+../srfi)
@end example
(Note: The line breaks, above, are for documentation purposes only, and
diff --git a/doc/ref/match.texi b/doc/ref/match.texi
index 40b5be8..12e3814 100644
--- a/doc/ref/match.texi
+++ b/doc/ref/match.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010, 2011 Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@c
@@ -44,7 +44,8 @@ because it is a two-element list whose first element is the
symbol
@code{hello} and whose second element is a one-element list. Here
@var{who} is a pattern variable. @code{match}, the pattern matcher,
locally binds @var{who} to the value contained in this one-element
-list---i.e., the symbol @code{world}.
+list---i.e., the symbol @code{world}. An error would be raised if
address@hidden did not match the pattern.
The same object can be matched against a simpler pattern:
@@ -61,6 +62,30 @@ Here pattern @code{(x y)} matches any two-element list,
regardless of
the types of these elements. Pattern variables @var{x} and @var{y} are
bound to, respectively, the first and second element of @var{l}.
+Patterns can be composed, and nested. For instance, @code{...}
+(ellipsis) means that the previous pattern may be matched zero or more
+times in a list:
+
address@hidden
+(match lst
+ (((heads tails ...) ...)
+ heads))
address@hidden example
+
address@hidden
+This expression returns the first element of each list within @var{lst}.
+For proper lists of proper lists, it is equivalent to @code{(map car
+lst)}. However, it performs additional checks to make sure that
address@hidden and the lists therein are proper lists, as prescribed by the
+pattern, raising an error if they are not.
+
+Compared to hand-written code, pattern matching noticeably improves
+clarity and conciseness---no need to resort to series of @code{car} and
address@hidden calls when matching lists, for instance. It also improves
+robustness, by making sure the input @emph{completely} matches the
+pattern---conversely, hand-written code often trades robustness for
+conciseness. And of course, @code{match} is a macro, and the code it
+expands to is just as efficient as equivalent hand-written code.
The pattern matcher is defined as follows:
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index f9bc9e9..2028ada 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -2101,8 +2101,8 @@ immutable.
@deffn {Scheme Procedure} hashtable-copy hashtable
@deffnx {Scheme Procedure} hashtable-copy hashtable mutable
Returns a copy of the hash table @var{hashtable}. If the optional
-argument @var{mutable} is a true value, the new hash table will be
-immutable.
+argument @var{mutable} is provided and is a true value, the new hash
+table will be mutable.
@end deffn
@deffn {Scheme Procedure} hashtable-clear! hashtable
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 7eb84de..4f9e6db 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -445,6 +445,10 @@ choice is available. Off by default (indicating
compilation).
@item prompt
A customized REPL prompt. @code{#f} by default, indicating the default
prompt.
address@hidden print
+A procedure of two arguments used to print the result of evaluating each
+expression. The arguments are the current REPL and the value to print.
+By default, @code{#f}, to use the default procedure.
@item value-history
Whether value history is on or not. @xref{Value History}.
@item on-error
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 161a28d..e892453 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -209,10 +209,11 @@ access to them.
@deffn {Scheme Procedure} build-uri scheme [#:address@hidden [#:address@hidden
@
[#:address@hidden [#:address@hidden""}] [#:address@hidden @
[#:address@hidden [#:address@hidden
-Construct a URI object. @var{scheme} should be a symbol, and the rest
-of the fields are either strings or @code{#f}. If @var{validate?} is
-true, also run some consistency checks to make sure that the constructed
-URI is valid.
+Construct a URI object. @var{scheme} should be a symbol, @var{port}
+either a positive, exact integer or @code{#f}, and the rest of the
+fields are either strings or @code{#f}. If @var{validate?} is true,
+also run some consistency checks to make sure that the constructed URI
+is valid.
@end deffn
@deffn {Scheme Procedure} uri? x
@@ -224,8 +225,8 @@ URI is valid.
@deffnx {Scheme Procedure} uri-query uri
@deffnx {Scheme Procedure} uri-fragment uri
A predicate and field accessors for the URI record type. The URI scheme
-will be a symbol, and the rest either strings or @code{#f} if not
-present.
+will be a symbol, the port either a positive, exact integer or @code{#f},
+and the rest either strings or @code{#f} if not present.
@end deffn
@deffn {Scheme Procedure} string->uri string
@@ -431,8 +432,8 @@ from @code{header-writer}.
@end deffn
@deffn {Scheme Procedure} read-headers port
-Read the headers of an HTTP message from @var{port}, returning the
-headers as an ordered alist.
+Read the headers of an HTTP message from @var{port}, returning them
+as an ordered alist.
@end deffn
@deffn {Scheme Procedure} write-headers headers port
@@ -1314,6 +1315,16 @@ Note also, though, that responses to @code{HEAD}
requests must also not
have a body.
@end deffn
address@hidden {Scheme Procedure} response-body-port r [#:decode?=#t]
[#:keep-alive?=#t]
+Return an input port from which the body of @var{r} can be read. The encoding
+of the returned port is set according to @var{r}'s @code{content-type} header,
+when it's textual, except if @var{decode?} is @code{#f}. Return @code{#f}
+when no body is available.
+
+When @var{keep-alive?} is @code{#f}, closing the returned port also closes
address@hidden's response port.
address@hidden deffn
+
@deffn {Scheme Procedure} read-response-body r
Read the response body from @var{r}, as a bytevector. Returns @code{#f}
if there was no response body.
@@ -1360,6 +1371,12 @@ headers.
Return the given response header, or @var{default} if none was present.
@end deffn
address@hidden {Scheme Procedure} text-content-type? @var{type}
+Return @code{#t} if @var{type}, a symbol as returned by
address@hidden, represents a textual type such as
address@hidden/plain}.
address@hidden deffn
+
@node Web Client
@subsection Web Client
@@ -1368,6 +1385,7 @@ Return the given response header, or @var{default} if
none was present.
the lower-level HTTP, request, and response modules.
@deffn {Scheme Procedure} open-socket-for-uri uri
+Return an open input/output port for a connection to URI.
@end deffn
@deffn {Scheme Procedure} http-get uri [#:port=(open-socket-for-uri uri)]
[#:version='(1 . 1)] [#:keep-alive?=#f] [#:extra-headers='()]
[#:decode-body?=#t]
@@ -1382,6 +1400,13 @@ response will be decoded to string, if it is a textual
content-type.
Otherwise it will be returned as a bytevector.
@end deffn
address@hidden {Scheme Procedure} http-get* uri [#:port=(open-socket-for-uri
uri)] [#:version='(1 . 1)] [#:keep-alive?=#f] [#:extra-headers='()]
[#:decode-body?=#t]
+Like @code{http-get}, but return an input port from which to read. When
address@hidden is true, as is the default, the returned port has its
+encoding set appropriately if the data at @var{uri} is textual. Closing the
+returned port closes @var{port}, unless @var{keep-alive?} is true.
address@hidden deffn
+
@code{http-get} is useful for making one-off requests to web sites. If
you are writing a web spider or some other client that needs to handle a
number of requests in parallel, it's better to build an event-driven URL
@@ -1470,17 +1495,17 @@ the server socket.
A user may define a server implementation with the following form:
address@hidden {Scheme Procedure} define-server-impl name open read write close
address@hidden {Scheme Syntax} define-server-impl name open read write close
Make a @code{<server-impl>} object with the hooks @var{open},
@var{read}, @var{write}, and @var{close}, and bind it to the symbol
@var{name} in the current module.
@end deffn
@deffn {Scheme Procedure} lookup-server-impl impl
-Look up a server implementation. If @var{impl} is a server
-implementation already, it is returned directly. If it is a symbol, the
+Look up a server implementation. If @var{impl} is a server
+implementation already, it is returned directly. If it is a symbol, the
binding named @var{impl} in the @code{(web server @var{impl})} module is
-looked up. Otherwise an error is signaled.
+looked up. Otherwise an error is signaled.
Currently a server implementation is a somewhat opaque type, useful only
for passing to other procedures in this module, like @code{read-client}.
@@ -1494,7 +1519,7 @@ any access to the impl objects.
@deffn {Scheme Procedure} open-server impl open-params
Open a server for the given implementation. Return one value, the new
-server object. The implementation's @code{open} procedure is applied to
+server object. The implementation's @code{open} procedure is applied to
@var{open-params}, which should be a list.
@end deffn
@@ -1502,7 +1527,7 @@ server object. The implementation's @code{open} procedure
is applied to
Read a new client from @var{server}, by applying the implementation's
@code{read} procedure to the server. If successful, return three
values: an object corresponding to the client, a request object, and the
-request body. If any exception occurs, return @code{#f} for all three
+request body. If any exception occurs, return @code{#f} for all three
values.
@end deffn
@@ -1513,9 +1538,9 @@ The response and response body are produced by calling
the given
@var{handler} with @var{request} and @var{body} as arguments.
The elements of @var{state} are also passed to @var{handler} as
-arguments, and may be returned as additional values. The new
+arguments, and may be returned as additional values. The new
@var{state}, collected from the @var{handler}'s return values, is then
-returned as a list. The idea is that a server loop receives a handler
+returned as a list. The idea is that a server loop receives a handler
from the user, along with whatever state values the user is interested
in, allowing the user's handler to explicitly manage its state.
@end deffn
@@ -1526,20 +1551,20 @@ given request.
As a convenience to web handler authors, @var{response} may be given as
an alist of headers, in which case it is used to construct a default
-response. Ensures that the response version corresponds to the request
-version. If @var{body} is a string, encodes the string to a bytevector,
-in an encoding appropriate for @var{response}. Adds a
+response. Ensures that the response version corresponds to the request
+version. If @var{body} is a string, encodes the string to a bytevector,
+in an encoding appropriate for @var{response}. Adds a
@code{content-length} and @code{content-type} header, as necessary.
If @var{body} is a procedure, it is called with a port as an argument,
-and the output collected as a bytevector. In the future we might try to
+and the output collected as a bytevector. In the future we might try to
instead use a compressing, chunk-encoded port, and call this procedure
-later, in the write-client procedure. Authors are advised not to rely on
+later, in the write-client procedure. Authors are advised not to rely on
the procedure being called at any particular time.
@end deffn
@deffn {Scheme Procedure} write-client impl server client response body
-Write an HTTP response and body to @var{client}. If the server and
+Write an HTTP response and body to @var{client}. If the server and
client support persistent connections, it is the implementation's
responsibility to keep track of the client thereafter, presumably by
attaching it to the @var{server} argument somehow.
@@ -1572,7 +1597,7 @@ before sending back to the client.
Additional arguments to @var{handler} are taken from @var{state}.
Additional return values are accumulated into a new @var{state}, which
-will be used for subsequent requests. In this way a handler can
+will be used for subsequent requests. In this way a handler can
explicitly manage its state.
@end deffn
diff --git a/doc/release.org b/doc/release.org
index 462c705..95ba12e 100644
--- a/doc/release.org
+++ b/doc/release.org
@@ -50,8 +50,8 @@ 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]].
+boxes for other OSes. The GNU/Hurd people have
[[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], and
so do
+the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]] and
the
[[http://lists.gnu.org/archive/html/autoconf/2012-11/msg00039.html][Snakebite]]
project.
*** Post a pre-release announcement to address@hidden'
@@ -76,7 +76,7 @@ However, this has not been done for Guile <= 2.0.2.
Create a signed Git tag, like this:
- $ git tag -s u MY-KEY -m "GNU Guile 2.0.X." v2.0.X
+ $ 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.
@@ -115,8 +115,11 @@ to check the authenticity and integrity of the tarball.
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
+ $ mkdir t && cd t && \
+ wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.gz && \
+ wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.xz
$ diff guile-2.0.X.tar.gz ../guile-2.0.X.tar.gz
+ $ diff guile-2.0.X.tar.xz ../guile-2.0.X.tar.xz
You're almost done!
@@ -133,8 +136,10 @@ Announcements").
** Update the on-line copy of the manual
- - Use `build-aux/gendocs', add to the manual/ directory of the web
- site.
+Use `build-aux/gendocs', add to the manual/ directory of the web site.
+
+ $ cd doc/ref
+ $ ../../build-aux/gendocs.sh guile "GNU Guile 2.0.X Reference Manual"
** Prepare the email announcement
@@ -156,18 +161,20 @@ entirety (don't call it a change log since that's not
what it is.)
** Send the email announcement
+Send to these places, preferably in the morning on a working day (UTC):
+
- 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]]
+** Post a news item 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.
+Copyright © 2011, 2012 Free Software Foundation, Inc.
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
diff --git a/gnulib-local/m4/canonicalize.m4.diff
b/gnulib-local/m4/canonicalize.m4.diff
deleted file mode 100644
index 57f4472..0000000
--- a/gnulib-local/m4/canonicalize.m4.diff
+++ /dev/null
@@ -1,67 +0,0 @@
-Fix `canonicalize_file_name' replacement handling when cross-compiling.
-Without this patch, we end up with:
-
- ./.libs/libguile-2.0.so: undefined reference to `rpl_canonicalize_file_name'
-
-See <http://hydra.nixos.org/build/2765567> for details.
-
-index 69b3f4c..3c4c5ee 100644
---- a/m4/canonicalize.m4
-+++ b/m4/canonicalize.m4
-@@ -16,8 +16,11 @@ AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE],
- AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
- if test $ac_cv_func_canonicalize_file_name = no; then
- HAVE_CANONICALIZE_FILE_NAME=0
-- elif test "$gl_cv_func_realpath_works" != yes; then
-- REPLACE_CANONICALIZE_FILE_NAME=1
-+ else
-+ case "$gl_cv_func_realpath_works" in
-+ *yes) ;;
-+ *) REPLACE_CANONICALIZE_FILE_NAME=1 ;;
-+ esac
- fi
- ])
-
-@@ -30,12 +33,21 @@ AC_DEFUN([gl_CANONICALIZE_LGPL],
- HAVE_CANONICALIZE_FILE_NAME=0
- if test $ac_cv_func_realpath = no; then
- HAVE_REALPATH=0
-- elif test "$gl_cv_func_realpath_works" != yes; then
-- REPLACE_REALPATH=1
-+ else
-+ case "$gl_cv_func_realpath_works" in
-+ *yes) ;;
-+ *) REPLACE_REALPATH=1 ;;
-+ esac
- fi
-- elif test "$gl_cv_func_realpath_works" != yes; then
-- REPLACE_CANONICALIZE_FILE_NAME=1
-- REPLACE_REALPATH=1
-+ else
-+ case "$gl_cv_func_realpath_works" in
-+ *yes)
-+ ;;
-+ *)
-+ REPLACE_CANONICALIZE_FILE_NAME=1
-+ REPLACE_REALPATH=1
-+ ;;
-+ esac
- fi
- ])
-
-
-Now, work around a second bug: fix default value when cross-compiling
-for GNU/Hurd.
-
-index 69b3f4c..111ddf8 100644
---- a/m4/canonicalize.m4
-+++ b/m4/canonicalize.m4
-@@ -95,7 +95,7 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS],
- [gl_cv_func_realpath_works=no],
- [case "$host_os" in
- # Guess yes on glibc systems.
-- *-gnu*) gl_cv_func_realpath_works="guessing yes" ;;
-+ *gnu*) gl_cv_func_realpath_works="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_realpath_works="guessing no" ;;
- esac
diff --git a/lib/Makefile.am b/lib/Makefile.am
index 8602e13..49c5140 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -155,7 +155,7 @@ EXTRA_DIST += arpa_inet.in.h
## begin gnulib module binary-io
-libgnu_la_SOURCES += binary-io.h
+libgnu_la_SOURCES += binary-io.h binary-io.c
## end gnulib module binary-io
@@ -614,7 +614,7 @@ EXTRA_DIST += $(top_srcdir)/build-aux/gnu-web-doc-update
distclean-local: clean-GNUmakefile
clean-GNUmakefile:
- test x'$(VPATH)' != x && rm -f $(top_builddir)/GNUmakefile || :
+ test '$(srcdir)' = . || rm -f $(top_builddir)/GNUmakefile
EXTRA_DIST += $(top_srcdir)/GNUmakefile
@@ -1795,6 +1795,7 @@ EXTRA_libgnu_la_SOURCES += stat.c
## begin gnulib module stat-time
+libgnu_la_SOURCES += stat-time.c
EXTRA_DIST += stat-time.h
@@ -2133,6 +2134,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status
$(CXXDEFS_H) \
-e 's|@''REPLACE_MALLOC''@|$(REPLACE_MALLOC)|g' \
-e 's|@''REPLACE_MBTOWC''@|$(REPLACE_MBTOWC)|g' \
-e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \
+ -e 's|@''REPLACE_PTSNAME''@|$(REPLACE_PTSNAME)|g' \
-e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \
-e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \
-e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \
@@ -3008,7 +3010,7 @@ EXTRA_libgnu_la_SOURCES += write.c
## begin gnulib module xsize
-libgnu_la_SOURCES += xsize.h
+libgnu_la_SOURCES += xsize.h xsize.c
## end gnulib module xsize
diff --git a/lib/binary-io.c b/lib/binary-io.c
new file mode 100644
index 0000000..8bbdb44
--- /dev/null
+++ b/lib/binary-io.c
@@ -0,0 +1,3 @@
+#include <config.h>
+#define BINARY_IO_INLINE _GL_EXTERN_INLINE
+#include "binary-io.h"
diff --git a/lib/binary-io.h b/lib/binary-io.h
index 77cbd4e..30315e1 100644
--- a/lib/binary-io.h
+++ b/lib/binary-io.h
@@ -25,6 +25,11 @@
so we include it here first. */
#include <stdio.h>
+_GL_INLINE_HEADER_BEGIN
+#ifndef BINARY_IO_INLINE
+# define BINARY_IO_INLINE _GL_INLINE
+#endif
+
/* set_binary_mode (fd, mode)
sets the binary/text I/O mode of file descriptor fd to the given mode
(must be O_BINARY or O_TEXT) and returns the previous mode. */
@@ -39,9 +44,9 @@
# endif
#else
/* On reasonable systems, binary I/O is the only choice. */
- /* Use an inline function rather than a macro, to avoid gcc warnings
+ /* Use a function rather than a macro, to avoid gcc warnings
"warning: statement with no effect". */
-static inline int
+BINARY_IO_INLINE int
set_binary_mode (int fd, int mode)
{
(void) fd;
@@ -62,4 +67,6 @@ set_binary_mode (int fd, int mode)
# define SET_BINARY(fd) ((void) set_binary_mode (fd, O_BINARY))
#endif
+_GL_INLINE_HEADER_END
+
#endif /* _BINARY_H */
diff --git a/lib/errno.in.h b/lib/errno.in.h
index 21ba05b..774c786 100644
--- a/lib/errno.in.h
+++ b/lib/errno.in.h
@@ -270,5 +270,10 @@
# define GNULIB_defined_ENOTRECOVERABLE 1
# endif
+# ifndef EILSEQ
+# define EILSEQ 2015
+# define GNULIB_defined_EILSEQ 1
+# endif
+
#endif /* address@hidden@_ERRNO_H */
#endif /* address@hidden@_ERRNO_H */
diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h
index f39dfe5..5c934c0 100644
--- a/lib/fcntl.in.h
+++ b/lib/fcntl.in.h
@@ -216,6 +216,10 @@ _GL_WARN_ON_USE (openat, "openat is not portable - "
# define O_EXEC O_RDONLY /* This is often close enough in older systems. */
#endif
+#ifndef O_IGNORE_CTTY
+# define O_IGNORE_CTTY 0
+#endif
+
#ifndef O_NDELAY
# define O_NDELAY 0
#endif
@@ -249,10 +253,18 @@ _GL_WARN_ON_USE (openat, "openat is not portable - "
# define O_NOFOLLOW 0
#endif
+#ifndef O_NOLINK
+# define O_NOLINK 0
+#endif
+
#ifndef O_NOLINKS
# define O_NOLINKS 0
#endif
+#ifndef O_NOTRANS
+# define O_NOTRANS 0
+#endif
+
#ifndef O_RSYNC
# define O_RSYNC 0
#endif
@@ -269,7 +281,7 @@ _GL_WARN_ON_USE (openat, "openat is not portable - "
# define O_TTY_INIT 0
#endif
-#if O_ACCMODE != (O_RDONLY | O_WRONLY | O_RDWR | O_EXEC | O_SEARCH)
+#if ~O_ACCMODE & (O_RDONLY | O_WRONLY | O_RDWR | O_EXEC | O_SEARCH)
# undef O_ACCMODE
# define O_ACCMODE (O_RDONLY | O_WRONLY | O_RDWR | O_EXEC | O_SEARCH)
#endif
diff --git a/lib/gettext.h b/lib/gettext.h
index c7d9740..d130faa 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -183,9 +183,12 @@ npgettext_aux (const char *domain,
#include <string.h>
-#define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS \
- (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \
- /* || __STDC_VERSION__ >= 199901L */ )
+#if (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \
+ /* || __STDC_VERSION__ >= 199901L */ )
+# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 1
+#else
+# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 0
+#endif
#if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS
#include <stdlib.h>
diff --git a/lib/localcharset.c b/lib/localcharset.c
index ad28ec6..c4a0596 100644
--- a/lib/localcharset.c
+++ b/lib/localcharset.c
@@ -542,6 +542,13 @@ locale_charset (void)
if (codeset[0] == '\0')
codeset = "ASCII";
+#ifdef DARWIN7
+ /* Mac OS X sets MB_CUR_MAX to 1 when LC_ALL=C, and "UTF-8"
+ (the default codeset) does not work when MB_CUR_MAX is 1. */
+ if (strcmp (codeset, "UTF-8") == 0 && MB_CUR_MAX <= 1)
+ codeset = "ASCII";
+#endif
+
return codeset;
}
diff --git a/lib/malloca.h b/lib/malloca.h
index c9bc15b..deb9bda 100644
--- a/lib/malloca.h
+++ b/lib/malloca.h
@@ -42,7 +42,7 @@ extern "C" {
and a page size can be as small as 4096 bytes. So we cannot safely
allocate anything larger than 4096 bytes. Also care for the possibility
of a few compiler-allocated temporary stack slots.
- This must be a macro, not an inline function. */
+ This must be a macro, not a function. */
# define safe_alloca(N) ((N) < 4032 ? alloca (N) : NULL)
#else
# define safe_alloca(N) ((void) (N), NULL)
diff --git a/lib/regexec.c b/lib/regexec.c
index b2c174f..13c3f15 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -735,7 +735,7 @@ re_search_internal (const regex_t *preg,
mctx.input.tip_context = (eflags & REG_NOTBOL) ? CONTEXT_BEGBUF
: CONTEXT_NEWLINE | CONTEXT_BEGBUF;
- /* Check incrementally whether of not the input string match. */
+ /* Check incrementally whether the input string matches. */
incr = (last_start < start) ? -1 : 1;
left_lim = (last_start < start) ? last_start : start;
right_lim = (last_start < start) ? start : last_start;
diff --git a/lib/stat-time.c b/lib/stat-time.c
new file mode 100644
index 0000000..81b83dd
--- /dev/null
+++ b/lib/stat-time.c
@@ -0,0 +1,3 @@
+#include <config.h>
+#define _GL_STAT_TIME_INLINE _GL_EXTERN_INLINE
+#include "stat-time.h"
diff --git a/lib/stat-time.h b/lib/stat-time.h
index 1aae18a..daf2ca6 100644
--- a/lib/stat-time.h
+++ b/lib/stat-time.h
@@ -23,6 +23,11 @@
#include <sys/stat.h>
#include <time.h>
+_GL_INLINE_HEADER_BEGIN
+#ifndef _GL_STAT_TIME_INLINE
+# define _GL_STAT_TIME_INLINE _GL_INLINE
+#endif
+
/* STAT_TIMESPEC (ST, ST_XTIM) is the ST_XTIM member for *ST of type
struct timespec, if available. If not, then STAT_TIMESPEC_NS (ST,
ST_XTIM) is the nanosecond component of the ST_XTIM member for *ST,
@@ -46,7 +51,7 @@
#endif
/* Return the nanosecond component of *ST's access time. */
-static inline long int
+_GL_STAT_TIME_INLINE long int
get_stat_atime_ns (struct stat const *st)
{
# if defined STAT_TIMESPEC
@@ -59,7 +64,7 @@ get_stat_atime_ns (struct stat const *st)
}
/* Return the nanosecond component of *ST's status change time. */
-static inline long int
+_GL_STAT_TIME_INLINE long int
get_stat_ctime_ns (struct stat const *st)
{
# if defined STAT_TIMESPEC
@@ -72,7 +77,7 @@ get_stat_ctime_ns (struct stat const *st)
}
/* Return the nanosecond component of *ST's data modification time. */
-static inline long int
+_GL_STAT_TIME_INLINE long int
get_stat_mtime_ns (struct stat const *st)
{
# if defined STAT_TIMESPEC
@@ -85,7 +90,7 @@ get_stat_mtime_ns (struct stat const *st)
}
/* Return the nanosecond component of *ST's birth time. */
-static inline long int
+_GL_STAT_TIME_INLINE long int
get_stat_birthtime_ns (struct stat const *st)
{
# if defined HAVE_STRUCT_STAT_ST_BIRTHTIMESPEC_TV_NSEC
@@ -100,7 +105,7 @@ get_stat_birthtime_ns (struct stat const *st)
}
/* Return *ST's access time. */
-static inline struct timespec
+_GL_STAT_TIME_INLINE struct timespec
get_stat_atime (struct stat const *st)
{
#ifdef STAT_TIMESPEC
@@ -114,7 +119,7 @@ get_stat_atime (struct stat const *st)
}
/* Return *ST's status change time. */
-static inline struct timespec
+_GL_STAT_TIME_INLINE struct timespec
get_stat_ctime (struct stat const *st)
{
#ifdef STAT_TIMESPEC
@@ -128,7 +133,7 @@ get_stat_ctime (struct stat const *st)
}
/* Return *ST's data modification time. */
-static inline struct timespec
+_GL_STAT_TIME_INLINE struct timespec
get_stat_mtime (struct stat const *st)
{
#ifdef STAT_TIMESPEC
@@ -143,7 +148,7 @@ get_stat_mtime (struct stat const *st)
/* Return *ST's birth time, if available; otherwise return a value
with tv_sec and tv_nsec both equal to -1. */
-static inline struct timespec
+_GL_STAT_TIME_INLINE struct timespec
get_stat_birthtime (struct stat const *st)
{
struct timespec t;
@@ -186,4 +191,6 @@ get_stat_birthtime (struct stat const *st)
return t;
}
+_GL_INLINE_HEADER_END
+
#endif
diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h
index 6ea7f70..4193429 100644
--- a/lib/stdbool.in.h
+++ b/lib/stdbool.in.h
@@ -66,24 +66,19 @@
# undef true
#endif
-/* For the sake of symbolic names in gdb, we define true and false as
- enum constants, not only as macros.
- It is tempting to write
- typedef enum { false = 0, true = 1 } _Bool;
- so that gdb prints values of type 'bool' symbolically. But if we do
- this, values of type '_Bool' may promote to 'int' or 'unsigned int'
- (see ISO C 99 6.7.2.2.(4)); however, '_Bool' must promote to 'int'
- (see ISO C 99 6.3.1.1.(2)). So we add a negative value to the
- enum; this ensures that '_Bool' promotes to 'int'. */
-#if defined __cplusplus || (defined __BEOS__ && !defined __HAIKU__)
+#ifdef __cplusplus
+# define _Bool bool
+# define bool bool
+#else
+# if defined __BEOS__ && !defined __HAIKU__
/* A compiler known to have 'bool'. */
/* If the compiler already has both 'bool' and '_Bool', we can assume they
are the same types. */
-# if address@hidden@
+# if address@hidden@
typedef bool _Bool;
-# endif
-#else
-# if !defined __GNUC__
+# endif
+# else
+# if !defined __GNUC__
/* If @HAVE__BOOL@:
Some HP-UX cc and AIX IBM C compiler versions have compiler bugs when
the built-in _Bool type is used. See
@@ -103,19 +98,35 @@ typedef bool _Bool;
"Invalid enumerator. (badenum)" with HP-UX cc on Tru64.
The only benefit of the enum, debuggability, is not important
with these compilers. So use 'signed char' and no enum. */
-# define _Bool signed char
-# else
+# define _Bool signed char
+# else
/* With this compiler, trust the _Bool type if the compiler has it. */
-# if address@hidden@
+# if address@hidden@
+ /* For the sake of symbolic names in gdb, define true and false as
+ enum constants, not only as macros.
+ It is tempting to write
+ typedef enum { false = 0, true = 1 } _Bool;
+ so that gdb prints values of type 'bool' symbolically. But then
+ values of type '_Bool' might promote to 'int' or 'unsigned int'
+ (see ISO C 99 6.7.2.2.(4)); however, '_Bool' must promote to 'int'
+ (see ISO C 99 6.3.1.1.(2)). So add a negative value to the
+ enum; this ensures that '_Bool' promotes to 'int'. */
typedef enum { _Bool_must_promote_to_int = -1, false = 0, true = 1 } _Bool;
+# endif
# endif
# endif
+# define bool _Bool
#endif
-#define bool _Bool
/* The other macros must be usable in preprocessor directives. */
-#define false 0
-#define true 1
+#ifdef __cplusplus
+# define false false
+# define true true
+#else
+# define false 0
+# define true 1
+#endif
+
#define __bool_true_false_are_defined 1
#endif /* _GL_STDBOOL_H */
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
index 72c9dd1..b67a348 100644
--- a/lib/stdlib.in.h
+++ b/lib/stdlib.in.h
@@ -457,10 +457,19 @@ _GL_WARN_ON_USE (posix_openpt, "posix_openpt is not
portable - "
#if @GNULIB_PTSNAME@
/* Return the pathname of the pseudo-terminal slave associated with
the master FD is open on, or NULL on errors. */
-# if address@hidden@
+# if @REPLACE_PTSNAME@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef ptsname
+# define ptsname rpl_ptsname
+# endif
+_GL_FUNCDECL_RPL (ptsname, char *, (int fd));
+_GL_CXXALIAS_RPL (ptsname, char *, (int fd));
+# else
+# if address@hidden@
_GL_FUNCDECL_SYS (ptsname, char *, (int fd));
-# endif
+# endif
_GL_CXXALIAS_SYS (ptsname, char *, (int fd));
+# endif
_GL_CXXALIASWARN (ptsname);
#elif defined GNULIB_POSIXCHECK
# undef ptsname
diff --git a/lib/verify.h b/lib/verify.h
index 6c4bd43..780b55e 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -125,7 +125,7 @@
extern int (*dummy (void)) [sizeof (struct {...})];
* GCC warns about duplicate declarations of the dummy function if
- -Wredundant_decls is used. GCC 4.3 and later have a builtin
+ -Wredundant-decls is used. GCC 4.3 and later have a builtin
__COUNTER__ macro that can let us generate unique identifiers for
each dummy function, to suppress this warning.
@@ -133,6 +133,10 @@
which do not support _Static_assert, also do not warn about the
last declaration mentioned above.
+ * GCC warns if -Wnested-externs is enabled and verify() is used
+ within a function body; but inside a function, you can always
+ arrange to use verify_expr() instead.
+
* In C++, any struct definition inside sizeof is invalid.
Use a template type to work around the problem. */
diff --git a/lib/xsize.c b/lib/xsize.c
new file mode 100644
index 0000000..4b4914c
--- /dev/null
+++ b/lib/xsize.c
@@ -0,0 +1,3 @@
+#include <config.h>
+#define XSIZE_INLINE _GL_EXTERN_INLINE
+#include "xsize.h"
diff --git a/lib/xsize.h b/lib/xsize.h
index 38d1afd..8312243 100644
--- a/lib/xsize.h
+++ b/lib/xsize.h
@@ -27,6 +27,11 @@
# include <stdint.h>
#endif
+_GL_INLINE_HEADER_BEGIN
+#ifndef XSIZE_INLINE
+# define XSIZE_INLINE _GL_INLINE
+#endif
+
/* The size of memory objects is often computed through expressions of
type size_t. Example:
void* p = malloc (header_size + n * element_size).
@@ -48,7 +53,7 @@
((N) <= SIZE_MAX ? (size_t) (N) : SIZE_MAX)
/* Sum of two sizes, with overflow check. */
-static inline size_t
+XSIZE_INLINE size_t
#if __GNUC__ >= 3
__attribute__ ((__pure__))
#endif
@@ -59,7 +64,7 @@ xsum (size_t size1, size_t size2)
}
/* Sum of three sizes, with overflow check. */
-static inline size_t
+XSIZE_INLINE size_t
#if __GNUC__ >= 3
__attribute__ ((__pure__))
#endif
@@ -69,7 +74,7 @@ xsum3 (size_t size1, size_t size2, size_t size3)
}
/* Sum of four sizes, with overflow check. */
-static inline size_t
+XSIZE_INLINE size_t
#if __GNUC__ >= 3
__attribute__ ((__pure__))
#endif
@@ -79,7 +84,7 @@ xsum4 (size_t size1, size_t size2, size_t size3, size_t size4)
}
/* Maximum of two sizes, with overflow check. */
-static inline size_t
+XSIZE_INLINE size_t
#if __GNUC__ >= 3
__attribute__ ((__pure__))
#endif
@@ -92,7 +97,7 @@ xmax (size_t size1, size_t size2)
/* Multiplication of a count with an element size, with overflow check.
The count must be >= 0 and the element size must be > 0.
- This is a macro, not an inline function, so that it works correctly even
+ This is a macro, not a function, so that it works correctly even
when N is of a wider type and N > SIZE_MAX. */
#define xtimes(N, ELSIZE) \
((N) <= SIZE_MAX / (ELSIZE) ? (size_t) (N) * (ELSIZE) : SIZE_MAX)
@@ -104,4 +109,6 @@ xmax (size_t size1, size_t size2)
#define size_in_bounds_p(SIZE) \
((SIZE) != SIZE_MAX)
+_GL_INLINE_HEADER_END
+
#endif /* _XSIZE_H */
diff --git a/libguile/dynl.c b/libguile/dynl.c
index 72305a4..79198e6 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -26,6 +26,7 @@
#endif
#include <alloca.h>
+#include <string.h>
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
@@ -61,6 +62,7 @@ maybe_drag_in_eprintf ()
#include "libguile/validate.h"
#include "libguile/dynwind.h"
#include "libguile/foreign.h"
+#include "libguile/gc.h"
#include <ltdl.h>
@@ -75,18 +77,78 @@ maybe_drag_in_eprintf ()
*/
/* njrev: not threadsafe, protection needed as described above */
+
+/* LT_PATH_SEP-separated extension library search path, searched last */
+static char *system_extensions_path;
+
static void *
sysdep_dynl_link (const char *fname, const char *subr)
{
lt_dlhandle handle;
- if (fname != NULL)
- handle = lt_dlopenext (fname);
- else
+ if (fname == NULL)
/* Return a handle for the program as a whole. */
handle = lt_dlopen (NULL);
+ else
+ {
+ handle = lt_dlopenext (fname);
- if (NULL == handle)
+ if (handle == NULL
+#ifdef LT_DIRSEP_CHAR
+ && strchr (fname, LT_DIRSEP_CHAR) == NULL
+#endif
+ && strchr (fname, '/') == NULL)
+ {
+ /* FNAME contains no directory separators and was not in the
+ usual library search paths, so now we search for it in
+ SYSTEM_EXTENSIONS_PATH. */
+ char *fname_attempt
+ = scm_gc_malloc_pointerless (strlen (system_extensions_path)
+ + strlen (fname) + 2,
+ "dynl fname_attempt");
+ char *path; /* remaining path to search */
+ char *end; /* end of current path component */
+ char *s;
+
+ /* Iterate over the components of SYSTEM_EXTENSIONS_PATH */
+ for (path = system_extensions_path;
+ *path != '\0';
+ path = (*end == '\0') ? end : (end + 1))
+ {
+ /* Find end of path component */
+ end = strchr (path, LT_PATHSEP_CHAR);
+ if (end == NULL)
+ end = strchr (path, '\0');
+
+ /* Skip empty path components */
+ if (path == end)
+ continue;
+
+ /* Construct FNAME_ATTEMPT, starting with path component */
+ s = fname_attempt;
+ memcpy (s, path, end - path);
+ s += end - path;
+
+ /* Append directory separator, but avoid duplicates */
+ if (s[-1] != '/'
+#ifdef LT_DIRSEP_CHAR
+ && s[-1] != LT_DIRSEP_CHAR
+#endif
+ )
+ *s++ = '/';
+
+ /* Finally, append FNAME (including null terminator) */
+ strcpy (s, fname);
+
+ /* Try to load it, and terminate the search if successful */
+ handle = lt_dlopenext (fname_attempt);
+ if (handle != NULL)
+ break;
+ }
+ }
+ }
+
+ if (handle == NULL)
{
SCM fn;
SCM msg;
@@ -120,30 +182,6 @@ sysdep_dynl_value (const char *symb, void *handle, const
char *subr)
return fptr;
}
-/* Augment environment variable VARIABLE with VALUE, assuming VARIABLE
- is a path kind of variable. */
-static void
-augment_env (const char *variable, const char *value)
-{
- const char *env;
-
- env = getenv (variable);
- if (env != NULL)
- {
- char *new_value;
- static const char path_sep[] = { LT_PATHSEP_CHAR, 0 };
-
- new_value = alloca (strlen (env) + strlen (value) + 2);
- strcpy (new_value, env);
- strcat (new_value, path_sep);
- strcat (new_value, value);
-
- setenv (variable, new_value, 1);
- }
- else
- setenv (variable, value, 1);
-}
-
static void
sysdep_dynl_init ()
{
@@ -151,26 +189,32 @@ sysdep_dynl_init ()
lt_dlinit ();
+ /* Initialize 'system_extensions_path' from
+ $GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set:
+ <SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>.
+
+ 'lt_dladdsearchdir' can't be used because it is searched before
+ the system-dependent search path, which is the one 'libtool
+ --mode=execute -dlopen' fiddles with (info "(libtool) Libltdl
+ Interface"). See
+ <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>.
+
+ The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH
+ can't be used because they would be propagated to subprocesses
+ which may cause problems for other programs. See
+ <http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */
+
env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
- if (env && strcmp (env, "") == 0)
- /* special-case interpret system-ltdl-path=="" as meaning no system path,
- which is the case during the build */
- ;
- else if (env)
- /* FIXME: should this be a colon-separated path? Or is the only point to
- allow the build system to turn off the installed extensions path? */
- lt_dladdsearchdir (env);
+ if (env)
+ system_extensions_path = env;
else
{
- /* Add SCM_LIB_DIR and SCM_EXTENSIONS_DIR to the loader's search
- path. `lt_dladdsearchdir' and $LTDL_LIBRARY_PATH can't be used
- for that because they are searched before the system-dependent
- search path, which is the one `libtool --mode=execute -dlopen'
- fiddles with (info "(libtool) Libltdl Interface"). See
- <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>
- for details. */
- augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_LIB_DIR);
- augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_EXTENSIONS_DIR);
+ system_extensions_path
+ = scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR)
+ + strlen (SCM_EXTENSIONS_DIR) + 2,
+ "system_extensions_path");
+ sprintf (system_extensions_path, "%s%c%s",
+ SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR);
}
}
diff --git a/libguile/eval.c b/libguile/eval.c
index d7ab562..4076d16 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -109,16 +109,16 @@ static scm_t_bits scm_tc16_boot_closure;
#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
#define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
-#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE
(x)))
-#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x)))
+#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR
(BOOT_CLOSURE_CODE (x))))
+#define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
/* NB: One may only call the following accessors if the closure is not FIXED.
*/
-#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE
(x)))
-#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))
+#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR
(BOOT_CLOSURE_CODE (x))))
+#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE
(x))))
/* NB: One may only call the following accessors if the closure is not REST. */
#define BOOT_CLOSURE_IS_FULL(x) (1)
#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
do { SCM fu = fu_; \
- body = CAR (fu); fu = CDR (fu); \
+ body = CAR (fu); fu = CDDR (fu); \
\
rest = kw = alt = SCM_BOOL_F; \
inits = SCM_EOL; \
diff --git a/libguile/load.c b/libguile/load.c
index 86d7e53..3b11a7c 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -221,6 +221,9 @@ static SCM *scm_loc_fresh_auto_compile;
/* The fallback path for auto-compilation */
static SCM *scm_loc_compile_fallback_path;
+/* Ellipsis: "..." */
+static SCM scm_ellipsis;
+
SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
(SCM path, SCM tail),
"Parse @var{path}, which is expected to be a colon-separated\n"
@@ -243,6 +246,32 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0,
+ (SCM path, SCM base),
+ "Parse @var{path}, which is expected to be a colon-separated\n"
+ "string, into a list and return the resulting list with\n"
+ "@var{base} (a list) spliced in place of the @code{...} path\n"
+ "component, if present, or else @var{base} is added to the end.\n"
+ "If @var{path} is @code{#f}, @var{base} is returned.")
+#define FUNC_NAME s_scm_parse_path_with_ellipsis
+{
+ SCM lst = scm_parse_path (path, SCM_EOL);
+ SCM walk = lst;
+ SCM *prev = &lst;
+
+ while (!scm_is_null (walk) &&
+ scm_is_false (scm_equal_p (scm_car (walk), scm_ellipsis)))
+ {
+ prev = SCM_CDRLOC (walk);
+ walk = *prev;
+ }
+ *prev = scm_is_null (walk)
+ ? base
+ : scm_append (scm_list_2 (base, scm_cdr (walk)));
+ return lst;
+}
+#undef FUNC_NAME
+
/* Initialize the global variable %load-path, given the value of the
SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
@@ -316,11 +345,11 @@ scm_init_load_path ()
env = getenv ("GUILE_LOAD_PATH");
if (env)
- path = scm_parse_path (scm_from_locale_string (env), path);
+ path = scm_parse_path_with_ellipsis (scm_from_locale_string (env), path);
env = getenv ("GUILE_LOAD_COMPILED_PATH");
if (env)
- cpath = scm_parse_path (scm_from_locale_string (env), cpath);
+ cpath = scm_parse_path_with_ellipsis (scm_from_locale_string (env), cpath);
*scm_loc_load_path = path;
*scm_loc_load_compiled_path = cpath;
@@ -1047,6 +1076,8 @@ scm_init_load ()
scm_loc_fresh_auto_compile
= SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F));
+ scm_ellipsis = scm_from_latin1_string ("...");
+
the_reader = scm_make_fluid_with_default (SCM_BOOL_F);
scm_c_define("current-reader", the_reader);
diff --git a/libguile/load.h b/libguile/load.h
index 0bddac2..698bbaf 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -27,6 +27,7 @@
SCM_API SCM scm_parse_path (SCM path, SCM tail);
+SCM_API SCM scm_parse_path_with_ellipsis (SCM path, SCM base);
SCM_API SCM scm_primitive_load (SCM filename);
SCM_API SCM scm_c_primitive_load (const char *filename);
SCM_API SCM scm_sys_package_data_dir (void);
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 1be276b..af68610 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -1,6 +1,7 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
- * Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+ * 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
@@ -78,8 +79,9 @@ scm_t_bits scm_tc16_memoized;
#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
alt, SCM_UNDEFINED)
-#define MAKMEMO_LAMBDA(body, arity) \
- MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity)))
+#define MAKMEMO_LAMBDA(body, arity, docstring) \
+ MAKMEMO (SCM_M_LAMBDA, \
+ scm_cons (body, scm_cons (docstring, arity)))
#define MAKMEMO_LET(inits, body) \
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \
@@ -283,7 +285,21 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
- return memoize (REF (exp, LAMBDA, BODY), env);
+ {
+ SCM meta, docstring, proc;
+
+ meta = REF (exp, LAMBDA, META);
+ docstring = scm_assoc_ref (meta, scm_sym_documentation);
+
+ proc = memoize (REF (exp, LAMBDA, BODY), env);
+ if (scm_is_string (docstring))
+ {
+ SCM args = SCM_MEMOIZED_ARGS (proc);
+ SCM_SETCAR (SCM_CDR (args), docstring);
+ }
+
+ return proc;
+ }
case SCM_EXPANDED_LAMBDA_CASE:
{
@@ -365,7 +381,8 @@ memoize (SCM exp, SCM env)
else
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
- return MAKMEMO_LAMBDA (memoize (body, new_env), arity);
+ return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
+ SCM_BOOL_F /* docstring */);
}
case SCM_EXPANDED_LET:
@@ -667,39 +684,43 @@ unmemoize (const SCM expr)
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr
(args)));
case SCM_M_LAMBDA:
- if (scm_is_null (CDDR (args)))
- return scm_list_3 (scm_sym_lambda,
- scm_make_list (CADR (args), sym_placeholder),
- unmemoize (CAR (args)));
- else if (scm_is_null (CDDDR (args)))
- {
- SCM formals = scm_make_list (CADR (args), sym_placeholder);
- return scm_list_3 (scm_sym_lambda,
- scm_is_true (CADDR (args))
- ? scm_cons_star (sym_placeholder, formals)
- : formals,
- unmemoize (CAR (args)));
- }
- else
- {
- SCM body = CAR (args), spec = CDR (args), alt, tail;
-
- alt = CADDR (CDDDR (spec));
- if (scm_is_true (alt))
- tail = CDR (unmemoize (alt));
- else
- tail = SCM_EOL;
-
- return scm_cons
- (sym_case_lambda_star,
- scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
- CADR (spec),
- CADDR (spec),
- CADDDR (spec),
- unmemoize_exprs (CADR (CDDDR
(spec)))),
- unmemoize (body)),
- tail));
- }
+ {
+ SCM body = CAR (args), spec = CDDR (args);
+
+ if (scm_is_null (CDR (spec)))
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (spec), sym_placeholder),
+ unmemoize (CAR (args)));
+ else if (scm_is_null (SCM_CDDR (spec)))
+ {
+ SCM formals = scm_make_list (CAR (spec), sym_placeholder);
+ return scm_list_3 (scm_sym_lambda,
+ scm_is_true (CADR (spec))
+ ? scm_cons_star (sym_placeholder, formals)
+ : formals,
+ unmemoize (CAR (args)));
+ }
+ else
+ {
+ SCM alt, tail;
+
+ alt = CADDR (CDDDR (spec));
+ if (scm_is_true (alt))
+ tail = CDR (unmemoize (alt));
+ else
+ tail = SCM_EOL;
+
+ return scm_cons
+ (sym_case_lambda_star,
+ scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
+ CADR (spec),
+ CADDR (spec),
+ CADDDR (spec),
+ unmemoize_exprs (CADR (CDDDR
(spec)))),
+ unmemoize (body)),
+ tail));
+ }
+ }
case SCM_M_LET:
return scm_list_3 (scm_sym_let,
unmemoize_bindings (CAR (args)),
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 63a6501..01f8e05 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -7643,10 +7643,16 @@ scm_product (SCM x, SCM y)
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
scm_t_inum yy = SCM_I_INUM (y);
- scm_t_inum kk = xx * yy;
- SCM k = SCM_I_MAKINUM (kk);
- if ((kk == SCM_I_INUM (k)) && (kk / xx == yy))
- return k;
+#if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
+ scm_t_int64 kk = xx * (scm_t_int64) yy;
+ if (SCM_FIXABLE (kk))
+ return SCM_I_MAKINUM (kk);
+#else
+ scm_t_inum axx = (xx > 0) ? xx : -xx;
+ scm_t_inum ayy = (yy > 0) ? yy : -yy;
+ if (SCM_MOST_POSITIVE_FIXNUM / axx >= ayy)
+ return SCM_I_MAKINUM (xx * yy);
+#endif
else
{
SCM result = scm_i_inum2big (xx);
diff --git a/libguile/posix.c b/libguile/posix.c
index 25476e5..baa711b 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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
@@ -2388,10 +2389,12 @@ scm_init_posix ()
#include "libguile/cpp-SIG.c"
#include "libguile/posix.x"
+#ifdef HAVE_FORK
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_popen",
(scm_t_extension_init_func) scm_init_popen,
NULL);
+#endif /* HAVE_FORK */
}
/*
diff --git a/libguile/procs.c b/libguile/procs.c
index 7a2f491..5899df0 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009,
+ * 2010, 2011, 2012 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
@@ -64,7 +65,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_SYMBOL (sym_documentation, "documentation");
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
(SCM proc),
@@ -75,7 +76,7 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
#define FUNC_NAME s_scm_procedure_documentation
{
SCM_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, sym_documentation);
+ return scm_procedure_property (proc, scm_sym_documentation);
}
#undef FUNC_NAME
diff --git a/libguile/procs.h b/libguile/procs.h
index a4dfaff..a35872e 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -3,7 +3,8 @@
#ifndef SCM_PROCS_H
#define SCM_PROCS_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
+ * 2012 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
@@ -36,6 +37,8 @@ SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
+SCM_INTERNAL SCM scm_sym_documentation;
+
#endif /* SCM_PROCS_H */
/*
diff --git a/libguile/simpos.c b/libguile/simpos.c
index 5c8fe96..8859d4f 100644
--- a/libguile/simpos.c
+++ b/libguile/simpos.c
@@ -1,6 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009, 2010 Free
Software
- * Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009,
+ * 2010, 2012 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
@@ -26,6 +26,7 @@
#include <errno.h>
#include <signal.h> /* for SIG constants */
#include <stdlib.h> /* for getenv */
+#include <stdio.h>
#include "libguile/_scm.h"
@@ -137,10 +138,17 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
if (pid == 0)
{
/* child */
- execvp (execargv[0], execargv);
- SCM_SYSERROR;
- /* not reached. */
- return SCM_BOOL_F;
+ execvp (execargv[0], execargv);
+
+ /* Something went wrong. */
+ fprintf (stderr, "In execvp of %s: %s\n",
+ execargv[0], strerror (errno));
+
+ /* Exit directly instead of throwing, because otherwise this
+ process may keep on running. Use exit status 127, like
+ shells in this case, as per POSIX
+
<http://pubs.opengroup.org/onlinepubs/007904875/utilities/xcu_chap02.html#tag_02_09_01_01>.
*/
+ _exit (127);
}
else
{
diff --git a/libguile/socket.c b/libguile/socket.c
index 149ec00..2320414 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
- * 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
+ * 2006, 2007, 2009, 2011, 2012 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
@@ -26,6 +26,7 @@
#include <errno.h>
#include <gmp.h>
+#include <verify.h>
#include "libguile/_scm.h"
#include "libguile/arrays.h"
@@ -738,6 +739,11 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
}
#undef FUNC_NAME
+/* Our documentation hard-codes this mapping, so make sure it holds. */
+verify (SHUT_RD == 0);
+verify (SHUT_WR == 1);
+verify (SHUT_RDWR == 2);
+
SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
(SCM sock, SCM how),
"Sockets can be closed simply by using @code{close-port}. The\n"
diff --git a/libguile/values.c b/libguile/values.c
index d135da0..670e222 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -97,8 +97,8 @@ scm_c_value_ref (SCM obj, size_t idx)
scm_error (scm_out_of_range_key,
"scm_c_value_ref",
"Too few values in ~S to access index ~S",
- scm_list_2 (obj, scm_from_unsigned_integer (idx)),
- scm_list_1 (scm_from_unsigned_integer (idx)));
+ scm_list_2 (obj, scm_from_size_t (idx)),
+ scm_list_1 (scm_from_size_t (idx)));
}
SCM_DEFINE (scm_values, "values", 0, 0, 1,
diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4
index 37df6fc..ea51ac4 100644
--- a/m4/canonicalize.m4
+++ b/m4/canonicalize.m4
@@ -1,4 +1,4 @@
-# canonicalize.m4 serial 24
+# canonicalize.m4 serial 26
dnl Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc.
@@ -106,10 +106,10 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS],
[gl_cv_func_realpath_works=yes],
[gl_cv_func_realpath_works=no],
[case "$host_os" in
- # Guess yes on glibc systems.
- *gnu*) gl_cv_func_realpath_works="guessing yes" ;;
- # If we don't know, assume the worst.
- *) gl_cv_func_realpath_works="guessing no" ;;
+ # Guess yes on glibc systems.
+ *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_realpath_works="guessing no" ;;
esac
])
rm -rf conftest.a conftest.d
diff --git a/m4/eealloc.m4 b/m4/eealloc.m4
index 75f17e2..9e5df45 100644
--- a/m4/eealloc.m4
+++ b/m4/eealloc.m4
@@ -1,4 +1,4 @@
-# eealloc.m4 serial 2
+# eealloc.m4 serial 3
dnl Copyright (C) 2003, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -8,7 +8,6 @@ AC_DEFUN([gl_EEALLOC],
[
AC_REQUIRE([gl_EEMALLOC])
AC_REQUIRE([gl_EEREALLOC])
- AC_REQUIRE([AC_C_INLINE])
])
AC_DEFUN([gl_EEMALLOC],
diff --git a/m4/errno_h.m4 b/m4/errno_h.m4
index 1e76ba2..4e33ba8 100644
--- a/m4/errno_h.m4
+++ b/m4/errno_h.m4
@@ -1,4 +1,4 @@
-# errno_h.m4 serial 11
+# errno_h.m4 serial 12
dnl Copyright (C) 2004, 2006, 2008-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -58,6 +58,9 @@ booboo
#if !defined ENOTRECOVERABLE
booboo
#endif
+#if !defined EILSEQ
+booboo
+#endif
],
[gl_cv_header_errno_h_complete=no],
[gl_cv_header_errno_h_complete=yes])
diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4
new file mode 100644
index 0000000..600c8d3
--- /dev/null
+++ b/m4/extern-inline.m4
@@ -0,0 +1,57 @@
+dnl 'extern inline' a la ISO C99.
+
+dnl Copyright 2012 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_EXTERN_INLINE],
+[
+ AC_REQUIRE([AC_C_INLINE])
+ AH_VERBATIM([extern_inline],
+[/* _GL_INLINE is a portable alternative to ISO C99 plain 'inline'.
+ _GL_EXTERN_INLINE is a portable alternative to 'extern inline'.
+ _GL_INLINE_HEADER_BEGIN contains useful stuff to put
+ in an include file, before uses of _GL_INLINE.
+ It suppresses GCC's bogus "no previous prototype for 'FOO'" diagnostic,
+ when FOO is an inline function in the header; see
+ <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=54113>.
+ _GL_INLINE_HEADER_END contains useful stuff to put
+ in the same include file, after uses of _GL_INLINE. */
+#if (__GNUC__ \
+ ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \
+ : 199901L <= __STDC_VERSION__)
+# define _GL_INLINE inline
+# define _GL_EXTERN_INLINE extern inline
+#elif 2 < __GNUC__ + (7 <= __GNUC_MINOR__)
+# if __GNUC_GNU_INLINE__
+ /* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */
+# define _GL_INLINE extern inline __attribute__ ((__gnu_inline__))
+# else
+# define _GL_INLINE extern inline
+# endif
+# define _GL_EXTERN_INLINE extern
+#else
+# define _GL_INLINE static inline
+# define _GL_EXTERN_INLINE static inline
+#endif
+
+#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__)
+# if defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__
+# define _GL_INLINE_HEADER_CONST_PRAGMA
+# else
+# define _GL_INLINE_HEADER_CONST_PRAGMA \
+ _Pragma ("GCC diagnostic ignored \"-Wsuggest-attribute=const\"")
+# endif
+# define _GL_INLINE_HEADER_BEGIN \
+ _Pragma ("GCC diagnostic push") \
+ _Pragma ("GCC diagnostic ignored \"-Wmissing-prototypes\"") \
+ _Pragma ("GCC diagnostic ignored \"-Wmissing-declarations\"") \
+ _GL_INLINE_HEADER_CONST_PRAGMA
+# define _GL_INLINE_HEADER_END \
+ _Pragma ("GCC diagnostic pop")
+#else
+# define _GL_INLINE_HEADER_BEGIN
+# define _GL_INLINE_HEADER_END
+#endif])
+])
diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4
index 9862741..740e78b 100644
--- a/m4/fcntl-o.m4
+++ b/m4/fcntl-o.m4
@@ -50,7 +50,18 @@ AC_DEFUN([gl_FCNTL_O_FLAGS],
#if HAVE_SYMLINK
{
static char const sym[] = "conftest.sym";
- if (symlink (".", sym) != 0)
+ if (symlink ("/dev/null", sym) != 0)
+ result |= 2;
+ else
+ {
+ int fd = open (sym, O_WRONLY | O_NOFOLLOW | O_CREAT, 0);
+ if (fd >= 0)
+ {
+ close (fd);
+ result |= 4;
+ }
+ }
+ if (unlink (sym) != 0 || symlink (".", sym) != 0)
result |= 2;
else
{
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 1b64060..50102b2 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -121,5 +121,5 @@ gl_MAKEFILE_NAME([])
gl_LIBTOOL
gl_MACRO_PREFIX([gl])
gl_PO_DOMAIN([])
-gl_WITNESS_C_DOMAIN([])
+gl_WITNESS_C_MACRO([])
gl_VC_FILES([false])
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 13bf4e8..b52b972 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -70,6 +70,7 @@ AC_DEFUN([gl_EARLY],
# Code from module errno:
# Code from module extensions:
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ # Code from module extern-inline:
# Code from module fcntl-h:
# Code from module fd-hook:
# Code from module float:
@@ -232,482 +233,482 @@ AC_DEFUN([gl_INIT],
m4_pushdef([gl_LIBSOURCES_DIR], [])
gl_COMMON
gl_source_base='lib'
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([accept])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([accept])
-gl_FUNC_ALLOCA
-gl_HEADER_ARPA_INET
-AC_PROG_MKDIR_P
-AC_REQUIRE([AC_C_INLINE])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([bind])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([bind])
-gl_FUNC_BTOWC
-if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then
- AC_LIBOBJ([btowc])
- gl_PREREQ_BTOWC
-fi
-gl_WCHAR_MODULE_INDICATOR([btowc])
-gl_BYTESWAP
-gl_CANONICALIZE_LGPL
-if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test
$REPLACE_CANONICALIZE_FILE_NAME = 1; then
- AC_LIBOBJ([canonicalize-lgpl])
-fi
-gl_MODULE_INDICATOR([canonicalize-lgpl])
-gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name])
-gl_STDLIB_MODULE_INDICATOR([realpath])
-gl_FUNC_CEIL
-if test $REPLACE_CEIL = 1; then
- AC_LIBOBJ([ceil])
-fi
-gl_MATH_MODULE_INDICATOR([ceil])
-gl_UNISTD_MODULE_INDICATOR([chdir])
-gl_CLOCK_TIME
-gl_FUNC_CLOSE
-if test $REPLACE_CLOSE = 1; then
- AC_LIBOBJ([close])
-fi
-gl_UNISTD_MODULE_INDICATOR([close])
-gl_CONFIGMAKE_PREP
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([connect])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([connect])
-gl_DIRENT_H
-gl_FUNC_DIRFD
-if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then
- AC_LIBOBJ([dirfd])
- gl_PREREQ_DIRFD
-fi
-gl_DIRENT_MODULE_INDICATOR([dirfd])
-gl_DIRNAME_LGPL
-gl_DOUBLE_SLASH_ROOT
-gl_FUNC_DUPLOCALE
-if test $REPLACE_DUPLOCALE = 1; then
- AC_LIBOBJ([duplocale])
- gl_PREREQ_DUPLOCALE
-fi
-gl_LOCALE_MODULE_INDICATOR([duplocale])
-gl_ENVIRON
-gl_UNISTD_MODULE_INDICATOR([environ])
-gl_HEADER_ERRNO_H
-gl_FCNTL_H
-gl_FLOAT_H
-if test $REPLACE_FLOAT_LDBL = 1; then
- AC_LIBOBJ([float])
-fi
-if test $REPLACE_ITOLD = 1; then
- AC_LIBOBJ([itold])
-fi
-gl_FUNC_FLOCK
-if test $HAVE_FLOCK = 0; then
- AC_LIBOBJ([flock])
- gl_PREREQ_FLOCK
-fi
-gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock])
-gl_FUNC_FLOOR
-if test $REPLACE_FLOOR = 1; then
- AC_LIBOBJ([floor])
-fi
-gl_MATH_MODULE_INDICATOR([floor])
-gl_FUNC_FREXP
-if test $gl_func_frexp != yes; then
- AC_LIBOBJ([frexp])
-fi
-gl_MATH_MODULE_INDICATOR([frexp])
-gl_FUNC_FSTAT
-if test $REPLACE_FSTAT = 1; then
- AC_LIBOBJ([fstat])
- gl_PREREQ_FSTAT
-fi
-gl_SYS_STAT_MODULE_INDICATOR([fstat])
-gl_FUNC
-gl_GETADDRINFO
-if test $HAVE_GETADDRINFO = 0; then
- AC_LIBOBJ([getaddrinfo])
-fi
-if test $HAVE_DECL_GAI_STRERROR = 0 || test $REPLACE_GAI_STRERROR = 1; then
- AC_LIBOBJ([gai_strerror])
-fi
-gl_NETDB_MODULE_INDICATOR([getaddrinfo])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([getpeername])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([getpeername])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([getsockname])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([getsockname])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([getsockopt])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([getsockopt])
-AC_SUBST([LIBINTL])
-AC_SUBST([LTLIBINTL])
-# Autoconf 2.61a.99 and earlier don't support linking a file only
-# in VPATH builds. But since GNUmakefile is for maintainer use
-# only, it does not matter if we skip the link with older autoconf.
-# Automake 1.10.1 and earlier try to remove GNUmakefile in non-VPATH
-# builds, so use a shell variable to bypass this.
-GNUmakefile=GNUmakefile
-m4_if(m4_version_compare([2.61a.100],
- m4_defn([m4_PACKAGE_VERSION])), [1], [],
- [AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [],
- [GNUmakefile=$GNUmakefile])])
-gl_HOSTENT
-AM_ICONV
-m4_ifdef([gl_ICONV_MODULE_INDICATOR],
- [gl_ICONV_MODULE_INDICATOR([iconv])])
-gl_ICONV_H
-gl_FUNC_ICONV_OPEN
-if test $REPLACE_ICONV_OPEN = 1; then
- AC_LIBOBJ([iconv_open])
-fi
-if test $REPLACE_ICONV = 1; then
- AC_LIBOBJ([iconv])
- AC_LIBOBJ([iconv_close])
-fi
-gl_FUNC_ICONV_OPEN_UTF
-gl_FUNC_INET_NTOP
-if test $HAVE_INET_NTOP = 0 || test $REPLACE_INET_NTOP = 1; then
- AC_LIBOBJ([inet_ntop])
- gl_PREREQ_INET_NTOP
-fi
-gl_ARPA_INET_MODULE_INDICATOR([inet_ntop])
-gl_FUNC_INET_PTON
-if test $HAVE_INET_PTON = 0 || test $REPLACE_INET_NTOP = 1; then
- AC_LIBOBJ([inet_pton])
- gl_PREREQ_INET_PTON
-fi
-gl_ARPA_INET_MODULE_INDICATOR([inet_pton])
-gl_INLINE
-gl_ISINF
-if test $REPLACE_ISINF = 1; then
- AC_LIBOBJ([isinf])
-fi
-gl_MATH_MODULE_INDICATOR([isinf])
-gl_ISNAN
-gl_MATH_MODULE_INDICATOR([isnan])
-gl_FUNC_ISNAND
-m4_ifdef([gl_ISNAN], [
- AC_REQUIRE([gl_ISNAN])
-])
-if test $HAVE_ISNAND = 0 || test $REPLACE_ISNAN = 1; then
- AC_LIBOBJ([isnand])
- gl_PREREQ_ISNAND
-fi
-gl_MATH_MODULE_INDICATOR([isnand])
-gl_FUNC_ISNAND_NO_LIBM
-if test $gl_func_isnand_no_libm != yes; then
- AC_LIBOBJ([isnand])
- gl_PREREQ_ISNAND
-fi
-gl_FUNC_ISNANF
-m4_ifdef([gl_ISNAN], [
- AC_REQUIRE([gl_ISNAN])
-])
-if test $HAVE_ISNANF = 0 || test $REPLACE_ISNAN = 1; then
- AC_LIBOBJ([isnanf])
- gl_PREREQ_ISNANF
-fi
-gl_MATH_MODULE_INDICATOR([isnanf])
-gl_FUNC_ISNANL
-m4_ifdef([gl_ISNAN], [
- AC_REQUIRE([gl_ISNAN])
-])
-if test $HAVE_ISNANL = 0 || test $REPLACE_ISNAN = 1; then
- AC_LIBOBJ([isnanl])
- gl_PREREQ_ISNANL
-fi
-gl_MATH_MODULE_INDICATOR([isnanl])
-gl_LANGINFO_H
-AC_REQUIRE([gl_LARGEFILE])
-gl_FUNC_LDEXP
-gl_LD_VERSION_SCRIPT
-gl_VISIBILITY
-gl_LIBUNISTRING
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([listen])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([listen])
-gl_LOCALCHARSET
-LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(abs_top_builddir)/$gl_source_base\""
-AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
-gl_LOCALE_H
-gl_FUNC_LOCALECONV
-if test $REPLACE_LOCALECONV = 1; then
- AC_LIBOBJ([localeconv])
- gl_PREREQ_LOCALECONV
-fi
-gl_LOCALE_MODULE_INDICATOR([localeconv])
-AC_REQUIRE([gl_FUNC_LOG])
-if test $REPLACE_LOG = 1; then
- AC_LIBOBJ([log])
-fi
-gl_MATH_MODULE_INDICATOR([log])
-gl_FUNC_LOG1P
-if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then
- AC_LIBOBJ([log1p])
-fi
-gl_MATH_MODULE_INDICATOR([log1p])
-gl_FUNC_LSTAT
-if test $REPLACE_LSTAT = 1; then
- AC_LIBOBJ([lstat])
- gl_PREREQ_LSTAT
-fi
-gl_SYS_STAT_MODULE_INDICATOR([lstat])
-AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER],
- [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])])
-gl_FUNC_MALLOC_GNU
-if test $REPLACE_MALLOC = 1; then
- AC_LIBOBJ([malloc])
-fi
-gl_MODULE_INDICATOR([malloc-gnu])
-gl_FUNC_MALLOC_POSIX
-if test $REPLACE_MALLOC = 1; then
- AC_LIBOBJ([malloc])
-fi
-gl_STDLIB_MODULE_INDICATOR([malloc-posix])
-gl_MALLOCA
-gl_MATH_H
-gl_FUNC_MBRTOWC
-if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then
- AC_LIBOBJ([mbrtowc])
- gl_PREREQ_MBRTOWC
-fi
-gl_WCHAR_MODULE_INDICATOR([mbrtowc])
-gl_FUNC_MBSINIT
-if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then
- AC_LIBOBJ([mbsinit])
- gl_PREREQ_MBSINIT
-fi
-gl_WCHAR_MODULE_INDICATOR([mbsinit])
-gl_FUNC_MBTOWC
-if test $REPLACE_MBTOWC = 1; then
- AC_LIBOBJ([mbtowc])
- gl_PREREQ_MBTOWC
-fi
-gl_STDLIB_MODULE_INDICATOR([mbtowc])
-gl_FUNC_MEMCHR
-if test $HAVE_MEMCHR = 0 || test $REPLACE_MEMCHR = 1; then
- AC_LIBOBJ([memchr])
- gl_PREREQ_MEMCHR
-fi
-gl_STRING_MODULE_INDICATOR([memchr])
-gl_MSVC_INVAL
-if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then
- AC_LIBOBJ([msvc-inval])
-fi
-gl_MSVC_NOTHROW
-if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then
- AC_LIBOBJ([msvc-nothrow])
-fi
-gl_MULTIARCH
-gl_HEADER_NETDB
-gl_HEADER_NETINET_IN
-AC_PROG_MKDIR_P
-gl_FUNC_NL_LANGINFO
-if test $HAVE_NL_LANGINFO = 0 || test $REPLACE_NL_LANGINFO = 1; then
- AC_LIBOBJ([nl_langinfo])
-fi
-gl_LANGINFO_MODULE_INDICATOR([nl_langinfo])
-gl_NPROC
-gl_FUNC_OPEN
-if test $REPLACE_OPEN = 1; then
- AC_LIBOBJ([open])
- gl_PREREQ_OPEN
-fi
-gl_FCNTL_MODULE_INDICATOR([open])
-gl_PATHMAX
-gl_FUNC_PIPE2
-gl_UNISTD_MODULE_INDICATOR([pipe2])
-gl_FUNC_PUTENV
-if test $REPLACE_PUTENV = 1; then
- AC_LIBOBJ([putenv])
-fi
-gl_STDLIB_MODULE_INDICATOR([putenv])
-gl_FUNC_RAISE
-if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then
- AC_LIBOBJ([raise])
- gl_PREREQ_RAISE
-fi
-gl_SIGNAL_MODULE_INDICATOR([raise])
-gl_FUNC_READ
-if test $REPLACE_READ = 1; then
- AC_LIBOBJ([read])
- gl_PREREQ_READ
-fi
-gl_UNISTD_MODULE_INDICATOR([read])
-gl_FUNC_READLINK
-if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then
- AC_LIBOBJ([readlink])
- gl_PREREQ_READLINK
-fi
-gl_UNISTD_MODULE_INDICATOR([readlink])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([recv])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([recv])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([recvfrom])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([recvfrom])
-gl_REGEX
-if test $ac_use_included_regex = yes; then
- AC_LIBOBJ([regex])
- gl_PREREQ_REGEX
-fi
-gl_FUNC_RENAME
-if test $REPLACE_RENAME = 1; then
- AC_LIBOBJ([rename])
-fi
-gl_STDIO_MODULE_INDICATOR([rename])
-gl_FUNC_RMDIR
-if test $REPLACE_RMDIR = 1; then
- AC_LIBOBJ([rmdir])
-fi
-gl_UNISTD_MODULE_INDICATOR([rmdir])
-gl_FUNC_ROUND
-if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then
- AC_LIBOBJ([round])
-fi
-gl_MATH_MODULE_INDICATOR([round])
-gl_PREREQ_SAFE_READ
-gl_PREREQ_SAFE_WRITE
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([send])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([send])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([sendto])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([sendto])
-gl_SERVENT
-gl_FUNC_SETENV
-if test $HAVE_SETENV = 0 || test $REPLACE_SETENV = 1; then
- AC_LIBOBJ([setenv])
-fi
-gl_STDLIB_MODULE_INDICATOR([setenv])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([setsockopt])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([setsockopt])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([shutdown])
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([shutdown])
-gl_SIGNAL_H
-gl_SIZE_MAX
-gl_FUNC_SNPRINTF
-gl_STDIO_MODULE_INDICATOR([snprintf])
-gl_MODULE_INDICATOR([snprintf])
-AC_REQUIRE([gl_HEADER_SYS_SOCKET])
-if test "$ac_cv_header_winsock2_h" = yes; then
- AC_LIBOBJ([socket])
-fi
-# When this module is used, sockets may actually occur as file descriptors,
-# hence it is worth warning if the modules 'close' and 'ioctl' are not used.
-m4_ifdef([gl_UNISTD_H_DEFAULTS], [AC_REQUIRE([gl_UNISTD_H_DEFAULTS])])
-m4_ifdef([gl_SYS_IOCTL_H_DEFAULTS], [AC_REQUIRE([gl_SYS_IOCTL_H_DEFAULTS])])
-AC_REQUIRE([gl_PREREQ_SYS_H_WINSOCK2])
-if test "$ac_cv_header_winsock2_h" = yes; then
- UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1
- SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1
-fi
-gl_SYS_SOCKET_MODULE_INDICATOR([socket])
-gl_SOCKETLIB
-gl_SOCKETS
-gl_TYPE_SOCKLEN_T
-gt_TYPE_SSIZE_T
-gl_FUNC_STAT
-if test $REPLACE_STAT = 1; then
- AC_LIBOBJ([stat])
- gl_PREREQ_STAT
-fi
-gl_SYS_STAT_MODULE_INDICATOR([stat])
-gl_STAT_TIME
-gl_STAT_BIRTHTIME
-gl_STDALIGN_H
-AM_STDBOOL_H
-gl_STDDEF_H
-gl_STDINT_H
-gl_STDIO_H
-gl_STDLIB_H
-gl_FUNC_GNU_STRFTIME
-if test $gl_cond_libtool = false; then
- gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV"
- gl_libdeps="$gl_libdeps $LIBICONV"
-fi
-gl_HEADER_STRING_H
-gl_HEADER_SYS_FILE_H
-AC_PROG_MKDIR_P
-gl_HEADER_SYS_SOCKET
-AC_PROG_MKDIR_P
-gl_HEADER_SYS_STAT_H
-AC_PROG_MKDIR_P
-gl_HEADER_SYS_TIME_H
-AC_PROG_MKDIR_P
-gl_SYS_TYPES_H
-AC_PROG_MKDIR_P
-gl_HEADER_SYS_UIO
-AC_PROG_MKDIR_P
-gl_HEADER_TIME_H
-gl_TIME_R
-if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then
- AC_LIBOBJ([time_r])
- gl_PREREQ_TIME_R
-fi
-gl_TIME_MODULE_INDICATOR([time_r])
-gl_FUNC_TRUNC
-if test $HAVE_DECL_TRUNC = 0 || test $REPLACE_TRUNC = 1; then
- AC_LIBOBJ([trunc])
-fi
-gl_MATH_MODULE_INDICATOR([trunc])
-gl_UNISTD_H
-gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h])
-gl_MODULE_INDICATOR([unistr/u8-mbtouc])
-gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc])
-gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe])
-gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc-unsafe])
-gl_MODULE_INDICATOR([unistr/u8-mbtoucr])
-gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-mbtoucr])
-gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev])
-gl_MODULE_INDICATOR([unistr/u8-uctomb])
-gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb])
-gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h])
-gl_FUNC_VASNPRINTF
-gl_FUNC_VSNPRINTF
-gl_STDIO_MODULE_INDICATOR([vsnprintf])
-gl_WCHAR_H
-gl_FUNC_WCRTOMB
-if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then
- AC_LIBOBJ([wcrtomb])
- gl_PREREQ_WCRTOMB
-fi
-gl_WCHAR_MODULE_INDICATOR([wcrtomb])
-gl_WCTYPE_H
-gl_FUNC_WRITE
-if test $REPLACE_WRITE = 1; then
- AC_LIBOBJ([write])
- gl_PREREQ_WRITE
-fi
-gl_UNISTD_MODULE_INDICATOR([write])
-gl_XSIZE
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([accept])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([accept])
+ gl_FUNC_ALLOCA
+ gl_HEADER_ARPA_INET
+ AC_PROG_MKDIR_P
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([bind])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([bind])
+ gl_FUNC_BTOWC
+ if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then
+ AC_LIBOBJ([btowc])
+ gl_PREREQ_BTOWC
+ fi
+ gl_WCHAR_MODULE_INDICATOR([btowc])
+ gl_BYTESWAP
+ gl_CANONICALIZE_LGPL
+ if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test
$REPLACE_CANONICALIZE_FILE_NAME = 1; then
+ AC_LIBOBJ([canonicalize-lgpl])
+ fi
+ gl_MODULE_INDICATOR([canonicalize-lgpl])
+ gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name])
+ gl_STDLIB_MODULE_INDICATOR([realpath])
+ gl_FUNC_CEIL
+ if test $REPLACE_CEIL = 1; then
+ AC_LIBOBJ([ceil])
+ fi
+ gl_MATH_MODULE_INDICATOR([ceil])
+ gl_UNISTD_MODULE_INDICATOR([chdir])
+ gl_CLOCK_TIME
+ gl_FUNC_CLOSE
+ if test $REPLACE_CLOSE = 1; then
+ AC_LIBOBJ([close])
+ fi
+ gl_UNISTD_MODULE_INDICATOR([close])
+ gl_CONFIGMAKE_PREP
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([connect])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([connect])
+ gl_DIRENT_H
+ gl_FUNC_DIRFD
+ if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then
+ AC_LIBOBJ([dirfd])
+ gl_PREREQ_DIRFD
+ fi
+ gl_DIRENT_MODULE_INDICATOR([dirfd])
+ gl_DIRNAME_LGPL
+ gl_DOUBLE_SLASH_ROOT
+ gl_FUNC_DUPLOCALE
+ if test $REPLACE_DUPLOCALE = 1; then
+ AC_LIBOBJ([duplocale])
+ gl_PREREQ_DUPLOCALE
+ fi
+ gl_LOCALE_MODULE_INDICATOR([duplocale])
+ gl_ENVIRON
+ gl_UNISTD_MODULE_INDICATOR([environ])
+ gl_HEADER_ERRNO_H
+ AC_REQUIRE([gl_EXTERN_INLINE])
+ gl_FCNTL_H
+ gl_FLOAT_H
+ if test $REPLACE_FLOAT_LDBL = 1; then
+ AC_LIBOBJ([float])
+ fi
+ if test $REPLACE_ITOLD = 1; then
+ AC_LIBOBJ([itold])
+ fi
+ gl_FUNC_FLOCK
+ if test $HAVE_FLOCK = 0; then
+ AC_LIBOBJ([flock])
+ gl_PREREQ_FLOCK
+ fi
+ gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock])
+ gl_FUNC_FLOOR
+ if test $REPLACE_FLOOR = 1; then
+ AC_LIBOBJ([floor])
+ fi
+ gl_MATH_MODULE_INDICATOR([floor])
+ gl_FUNC_FREXP
+ if test $gl_func_frexp != yes; then
+ AC_LIBOBJ([frexp])
+ fi
+ gl_MATH_MODULE_INDICATOR([frexp])
+ gl_FUNC_FSTAT
+ if test $REPLACE_FSTAT = 1; then
+ AC_LIBOBJ([fstat])
+ gl_PREREQ_FSTAT
+ fi
+ gl_SYS_STAT_MODULE_INDICATOR([fstat])
+ gl_FUNC
+ gl_GETADDRINFO
+ if test $HAVE_GETADDRINFO = 0; then
+ AC_LIBOBJ([getaddrinfo])
+ fi
+ if test $HAVE_DECL_GAI_STRERROR = 0 || test $REPLACE_GAI_STRERROR = 1; then
+ AC_LIBOBJ([gai_strerror])
+ fi
+ gl_NETDB_MODULE_INDICATOR([getaddrinfo])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([getpeername])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([getpeername])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([getsockname])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([getsockname])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([getsockopt])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([getsockopt])
+ AC_SUBST([LIBINTL])
+ AC_SUBST([LTLIBINTL])
+ # Autoconf 2.61a.99 and earlier don't support linking a file only
+ # in VPATH builds. But since GNUmakefile is for maintainer use
+ # only, it does not matter if we skip the link with older autoconf.
+ # Automake 1.10.1 and earlier try to remove GNUmakefile in non-VPATH
+ # builds, so use a shell variable to bypass this.
+ GNUmakefile=GNUmakefile
+ m4_if(m4_version_compare([2.61a.100],
+ m4_defn([m4_PACKAGE_VERSION])), [1], [],
+ [AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [],
+ [GNUmakefile=$GNUmakefile])])
+ gl_HOSTENT
+ AM_ICONV
+ m4_ifdef([gl_ICONV_MODULE_INDICATOR],
+ [gl_ICONV_MODULE_INDICATOR([iconv])])
+ gl_ICONV_H
+ gl_FUNC_ICONV_OPEN
+ if test $REPLACE_ICONV_OPEN = 1; then
+ AC_LIBOBJ([iconv_open])
+ fi
+ if test $REPLACE_ICONV = 1; then
+ AC_LIBOBJ([iconv])
+ AC_LIBOBJ([iconv_close])
+ fi
+ gl_FUNC_ICONV_OPEN_UTF
+ gl_FUNC_INET_NTOP
+ if test $HAVE_INET_NTOP = 0 || test $REPLACE_INET_NTOP = 1; then
+ AC_LIBOBJ([inet_ntop])
+ gl_PREREQ_INET_NTOP
+ fi
+ gl_ARPA_INET_MODULE_INDICATOR([inet_ntop])
+ gl_FUNC_INET_PTON
+ if test $HAVE_INET_PTON = 0 || test $REPLACE_INET_NTOP = 1; then
+ AC_LIBOBJ([inet_pton])
+ gl_PREREQ_INET_PTON
+ fi
+ gl_ARPA_INET_MODULE_INDICATOR([inet_pton])
+ gl_INLINE
+ gl_ISINF
+ if test $REPLACE_ISINF = 1; then
+ AC_LIBOBJ([isinf])
+ fi
+ gl_MATH_MODULE_INDICATOR([isinf])
+ gl_ISNAN
+ gl_MATH_MODULE_INDICATOR([isnan])
+ gl_FUNC_ISNAND
+ m4_ifdef([gl_ISNAN], [
+ AC_REQUIRE([gl_ISNAN])
+ ])
+ if test $HAVE_ISNAND = 0 || test $REPLACE_ISNAN = 1; then
+ AC_LIBOBJ([isnand])
+ gl_PREREQ_ISNAND
+ fi
+ gl_MATH_MODULE_INDICATOR([isnand])
+ gl_FUNC_ISNAND_NO_LIBM
+ if test $gl_func_isnand_no_libm != yes; then
+ AC_LIBOBJ([isnand])
+ gl_PREREQ_ISNAND
+ fi
+ gl_FUNC_ISNANF
+ m4_ifdef([gl_ISNAN], [
+ AC_REQUIRE([gl_ISNAN])
+ ])
+ if test $HAVE_ISNANF = 0 || test $REPLACE_ISNAN = 1; then
+ AC_LIBOBJ([isnanf])
+ gl_PREREQ_ISNANF
+ fi
+ gl_MATH_MODULE_INDICATOR([isnanf])
+ gl_FUNC_ISNANL
+ m4_ifdef([gl_ISNAN], [
+ AC_REQUIRE([gl_ISNAN])
+ ])
+ if test $HAVE_ISNANL = 0 || test $REPLACE_ISNAN = 1; then
+ AC_LIBOBJ([isnanl])
+ gl_PREREQ_ISNANL
+ fi
+ gl_MATH_MODULE_INDICATOR([isnanl])
+ gl_LANGINFO_H
+ AC_REQUIRE([gl_LARGEFILE])
+ gl_FUNC_LDEXP
+ gl_LD_VERSION_SCRIPT
+ gl_VISIBILITY
+ gl_LIBUNISTRING
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([listen])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([listen])
+ gl_LOCALCHARSET
+
LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(abs_top_builddir)/$gl_source_base\""
+ AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
+ gl_LOCALE_H
+ gl_FUNC_LOCALECONV
+ if test $REPLACE_LOCALECONV = 1; then
+ AC_LIBOBJ([localeconv])
+ gl_PREREQ_LOCALECONV
+ fi
+ gl_LOCALE_MODULE_INDICATOR([localeconv])
+ AC_REQUIRE([gl_FUNC_LOG])
+ if test $REPLACE_LOG = 1; then
+ AC_LIBOBJ([log])
+ fi
+ gl_MATH_MODULE_INDICATOR([log])
+ gl_FUNC_LOG1P
+ if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then
+ AC_LIBOBJ([log1p])
+ fi
+ gl_MATH_MODULE_INDICATOR([log1p])
+ gl_FUNC_LSTAT
+ if test $REPLACE_LSTAT = 1; then
+ AC_LIBOBJ([lstat])
+ gl_PREREQ_LSTAT
+ fi
+ gl_SYS_STAT_MODULE_INDICATOR([lstat])
+ AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER],
+ [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])])
+ gl_FUNC_MALLOC_GNU
+ if test $REPLACE_MALLOC = 1; then
+ AC_LIBOBJ([malloc])
+ fi
+ gl_MODULE_INDICATOR([malloc-gnu])
+ gl_FUNC_MALLOC_POSIX
+ if test $REPLACE_MALLOC = 1; then
+ AC_LIBOBJ([malloc])
+ fi
+ gl_STDLIB_MODULE_INDICATOR([malloc-posix])
+ gl_MALLOCA
+ gl_MATH_H
+ gl_FUNC_MBRTOWC
+ if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then
+ AC_LIBOBJ([mbrtowc])
+ gl_PREREQ_MBRTOWC
+ fi
+ gl_WCHAR_MODULE_INDICATOR([mbrtowc])
+ gl_FUNC_MBSINIT
+ if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then
+ AC_LIBOBJ([mbsinit])
+ gl_PREREQ_MBSINIT
+ fi
+ gl_WCHAR_MODULE_INDICATOR([mbsinit])
+ gl_FUNC_MBTOWC
+ if test $REPLACE_MBTOWC = 1; then
+ AC_LIBOBJ([mbtowc])
+ gl_PREREQ_MBTOWC
+ fi
+ gl_STDLIB_MODULE_INDICATOR([mbtowc])
+ gl_FUNC_MEMCHR
+ if test $HAVE_MEMCHR = 0 || test $REPLACE_MEMCHR = 1; then
+ AC_LIBOBJ([memchr])
+ gl_PREREQ_MEMCHR
+ fi
+ gl_STRING_MODULE_INDICATOR([memchr])
+ gl_MSVC_INVAL
+ if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then
+ AC_LIBOBJ([msvc-inval])
+ fi
+ gl_MSVC_NOTHROW
+ if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then
+ AC_LIBOBJ([msvc-nothrow])
+ fi
+ gl_MULTIARCH
+ gl_HEADER_NETDB
+ gl_HEADER_NETINET_IN
+ AC_PROG_MKDIR_P
+ gl_FUNC_NL_LANGINFO
+ if test $HAVE_NL_LANGINFO = 0 || test $REPLACE_NL_LANGINFO = 1; then
+ AC_LIBOBJ([nl_langinfo])
+ fi
+ gl_LANGINFO_MODULE_INDICATOR([nl_langinfo])
+ gl_NPROC
+ gl_FUNC_OPEN
+ if test $REPLACE_OPEN = 1; then
+ AC_LIBOBJ([open])
+ gl_PREREQ_OPEN
+ fi
+ gl_FCNTL_MODULE_INDICATOR([open])
+ gl_PATHMAX
+ gl_FUNC_PIPE2
+ gl_UNISTD_MODULE_INDICATOR([pipe2])
+ gl_FUNC_PUTENV
+ if test $REPLACE_PUTENV = 1; then
+ AC_LIBOBJ([putenv])
+ fi
+ gl_STDLIB_MODULE_INDICATOR([putenv])
+ gl_FUNC_RAISE
+ if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then
+ AC_LIBOBJ([raise])
+ gl_PREREQ_RAISE
+ fi
+ gl_SIGNAL_MODULE_INDICATOR([raise])
+ gl_FUNC_READ
+ if test $REPLACE_READ = 1; then
+ AC_LIBOBJ([read])
+ gl_PREREQ_READ
+ fi
+ gl_UNISTD_MODULE_INDICATOR([read])
+ gl_FUNC_READLINK
+ if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then
+ AC_LIBOBJ([readlink])
+ gl_PREREQ_READLINK
+ fi
+ gl_UNISTD_MODULE_INDICATOR([readlink])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([recv])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([recv])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([recvfrom])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([recvfrom])
+ gl_REGEX
+ if test $ac_use_included_regex = yes; then
+ AC_LIBOBJ([regex])
+ gl_PREREQ_REGEX
+ fi
+ gl_FUNC_RENAME
+ if test $REPLACE_RENAME = 1; then
+ AC_LIBOBJ([rename])
+ fi
+ gl_STDIO_MODULE_INDICATOR([rename])
+ gl_FUNC_RMDIR
+ if test $REPLACE_RMDIR = 1; then
+ AC_LIBOBJ([rmdir])
+ fi
+ gl_UNISTD_MODULE_INDICATOR([rmdir])
+ gl_FUNC_ROUND
+ if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then
+ AC_LIBOBJ([round])
+ fi
+ gl_MATH_MODULE_INDICATOR([round])
+ gl_PREREQ_SAFE_READ
+ gl_PREREQ_SAFE_WRITE
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([send])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([send])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([sendto])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([sendto])
+ gl_SERVENT
+ gl_FUNC_SETENV
+ if test $HAVE_SETENV = 0 || test $REPLACE_SETENV = 1; then
+ AC_LIBOBJ([setenv])
+ fi
+ gl_STDLIB_MODULE_INDICATOR([setenv])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([setsockopt])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([setsockopt])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([shutdown])
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([shutdown])
+ gl_SIGNAL_H
+ gl_SIZE_MAX
+ gl_FUNC_SNPRINTF
+ gl_STDIO_MODULE_INDICATOR([snprintf])
+ gl_MODULE_INDICATOR([snprintf])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ AC_LIBOBJ([socket])
+ fi
+ # When this module is used, sockets may actually occur as file descriptors,
+ # hence it is worth warning if the modules 'close' and 'ioctl' are not used.
+ m4_ifdef([gl_UNISTD_H_DEFAULTS], [AC_REQUIRE([gl_UNISTD_H_DEFAULTS])])
+ m4_ifdef([gl_SYS_IOCTL_H_DEFAULTS], [AC_REQUIRE([gl_SYS_IOCTL_H_DEFAULTS])])
+ AC_REQUIRE([gl_PREREQ_SYS_H_WINSOCK2])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1
+ SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1
+ fi
+ gl_SYS_SOCKET_MODULE_INDICATOR([socket])
+ gl_SOCKETLIB
+ gl_SOCKETS
+ gl_TYPE_SOCKLEN_T
+ gt_TYPE_SSIZE_T
+ gl_FUNC_STAT
+ if test $REPLACE_STAT = 1; then
+ AC_LIBOBJ([stat])
+ gl_PREREQ_STAT
+ fi
+ gl_SYS_STAT_MODULE_INDICATOR([stat])
+ gl_STAT_TIME
+ gl_STAT_BIRTHTIME
+ gl_STDALIGN_H
+ AM_STDBOOL_H
+ gl_STDDEF_H
+ gl_STDINT_H
+ gl_STDIO_H
+ gl_STDLIB_H
+ gl_FUNC_GNU_STRFTIME
+ if test $gl_cond_libtool = false; then
+ gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV"
+ gl_libdeps="$gl_libdeps $LIBICONV"
+ fi
+ gl_HEADER_STRING_H
+ gl_HEADER_SYS_FILE_H
+ AC_PROG_MKDIR_P
+ gl_HEADER_SYS_SOCKET
+ AC_PROG_MKDIR_P
+ gl_HEADER_SYS_STAT_H
+ AC_PROG_MKDIR_P
+ gl_HEADER_SYS_TIME_H
+ AC_PROG_MKDIR_P
+ gl_SYS_TYPES_H
+ AC_PROG_MKDIR_P
+ gl_HEADER_SYS_UIO
+ AC_PROG_MKDIR_P
+ gl_HEADER_TIME_H
+ gl_TIME_R
+ if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then
+ AC_LIBOBJ([time_r])
+ gl_PREREQ_TIME_R
+ fi
+ gl_TIME_MODULE_INDICATOR([time_r])
+ gl_FUNC_TRUNC
+ if test $HAVE_DECL_TRUNC = 0 || test $REPLACE_TRUNC = 1; then
+ AC_LIBOBJ([trunc])
+ fi
+ gl_MATH_MODULE_INDICATOR([trunc])
+ gl_UNISTD_H
+ gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h])
+ gl_MODULE_INDICATOR([unistr/u8-mbtouc])
+ gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc])
+ gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe])
+ gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc-unsafe])
+ gl_MODULE_INDICATOR([unistr/u8-mbtoucr])
+ gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-mbtoucr])
+ gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev])
+ gl_MODULE_INDICATOR([unistr/u8-uctomb])
+ gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb])
+ gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h])
+ gl_FUNC_VASNPRINTF
+ gl_FUNC_VSNPRINTF
+ gl_STDIO_MODULE_INDICATOR([vsnprintf])
+ gl_WCHAR_H
+ gl_FUNC_WCRTOMB
+ if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then
+ AC_LIBOBJ([wcrtomb])
+ gl_PREREQ_WCRTOMB
+ fi
+ gl_WCHAR_MODULE_INDICATOR([wcrtomb])
+ gl_WCTYPE_H
+ gl_FUNC_WRITE
+ if test $REPLACE_WRITE = 1; then
+ AC_LIBOBJ([write])
+ gl_PREREQ_WRITE
+ fi
+ gl_UNISTD_MODULE_INDICATOR([write])
+ gl_XSIZE
# End of code from modules
m4_ifval(gl_LIBSOURCES_LIST, [
m4_syscmd([test ! -d ]m4_defn([gl_LIBSOURCES_DIR])[ ||
@@ -865,6 +866,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/arpa_inet.in.h
lib/asnprintf.c
lib/basename-lgpl.c
+ lib/binary-io.c
lib/binary-io.h
lib/bind.c
lib/btowc.c
@@ -996,6 +998,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/socket.c
lib/sockets.c
lib/sockets.h
+ lib/stat-time.c
lib/stat-time.h
lib/stat.c
lib/stdalign.in.h
@@ -1040,6 +1043,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/wcrtomb.c
lib/wctype.in.h
lib/write.c
+ lib/xsize.c
lib/xsize.h
m4/00gnulib.m4
m4/absolute-header.m4
@@ -1067,6 +1071,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/exponentf.m4
m4/exponentl.m4
m4/extensions.m4
+ m4/extern-inline.m4
m4/fcntl-o.m4
m4/fcntl_h.m4
m4/float_h.m4
diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4
index 4e1374d..e1feab5 100644
--- a/m4/lib-ld.m4
+++ b/m4/lib-ld.m4
@@ -1,33 +1,39 @@
-# lib-ld.m4 serial 5 (gettext-0.18.2)
+# lib-ld.m4 serial 6
dnl Copyright (C) 1996-2003, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl Subroutines of libtool.m4,
-dnl with replacements s/AC_/AC_LIB/ and s/lt_cv/acl_cv/ to avoid collision
-dnl with libtool.m4.
+dnl with replacements s/_*LT_PATH/AC_LIB_PROG/ and s/lt_/acl_/ to avoid
+dnl collision with libtool.m4.
-dnl From libtool-1.4. Sets the variable with_gnu_ld to yes or no.
+dnl From libtool-2.4. Sets the variable with_gnu_ld to yes or no.
AC_DEFUN([AC_LIB_PROG_LD_GNU],
[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], [acl_cv_prog_gnu_ld],
-[# I'd rather use --version here, but apparently some GNU ld's only accept -v.
+[# I'd rather use --version here, but apparently some GNU lds only accept -v.
case `$LD -v 2>&1 </dev/null` in
*GNU* | *'with BFD'*)
- acl_cv_prog_gnu_ld=yes ;;
+ acl_cv_prog_gnu_ld=yes
+ ;;
*)
- acl_cv_prog_gnu_ld=no ;;
+ acl_cv_prog_gnu_ld=no
+ ;;
esac])
with_gnu_ld=$acl_cv_prog_gnu_ld
])
-dnl From libtool-1.4. Sets the variable LD.
+dnl From libtool-2.4. Sets the variable LD.
AC_DEFUN([AC_LIB_PROG_LD],
-[AC_ARG_WITH([gnu-ld],
-[ --with-gnu-ld assume the C compiler uses GNU ld [default=no]],
-test "$withval" = no || with_gnu_ld=yes, with_gnu_ld=no)
-AC_REQUIRE([AC_PROG_CC])dnl
+[AC_REQUIRE([AC_PROG_CC])dnl
AC_REQUIRE([AC_CANONICAL_HOST])dnl
+
+AC_ARG_WITH([gnu-ld],
+ [AS_HELP_STRING([--with-gnu-ld],
+ [assume the C compiler uses GNU ld [default=no]])],
+ [test "$withval" = no || with_gnu_ld=yes],
+ [with_gnu_ld=no])dnl
+
# Prepare PATH_SEPARATOR.
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
@@ -40,10 +46,11 @@ if test "${PATH_SEPARATOR+set}" != set; then
|| PATH_SEPARATOR=';'
}
fi
+
ac_prog=ld
if test "$GCC" = yes; then
# Check if gcc -print-prog-name=ld gives a path.
- AC_MSG_CHECKING([for ld used by GCC])
+ AC_MSG_CHECKING([for ld used by $CC])
case $host in
*-*-mingw*)
# gcc leaves a trailing carriage return which upsets mingw
@@ -53,11 +60,11 @@ if test "$GCC" = yes; then
esac
case $ac_prog in
# Accept absolute paths.
- [[\\/]* | [A-Za-z]:[\\/]*)]
- [re_direlt='/[^/][^/]*/\.\./']
- # Canonicalize the path of ld
- ac_prog=`echo $ac_prog| sed 's%\\\\%/%g'`
- while echo $ac_prog | grep "$re_direlt" > /dev/null 2>&1; do
+ [[\\/]]* | ?:[[\\/]]*)
+ re_direlt='/[[^/]][[^/]]*/\.\./'
+ # Canonicalize the pathname of ld
+ ac_prog=`echo "$ac_prog"| sed 's%\\\\%/%g'`
+ while echo "$ac_prog" | grep "$re_direlt" > /dev/null 2>&1; do
ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"`
done
test -z "$LD" && LD="$ac_prog"
@@ -78,23 +85,26 @@ else
fi
AC_CACHE_VAL([acl_cv_path_LD],
[if test -z "$LD"; then
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}"
+ acl_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
for ac_dir in $PATH; do
+ IFS="$acl_save_ifs"
test -z "$ac_dir" && ac_dir=.
if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then
acl_cv_path_LD="$ac_dir/$ac_prog"
# Check to see if the program is GNU ld. I'd rather use --version,
- # but apparently some GNU ld's only accept -v.
+ # but apparently some variants of GNU ld only accept -v.
# Break only if it was the GNU/non-GNU ld that we prefer.
- case `"$acl_cv_path_LD" -v 2>&1 < /dev/null` in
+ case `"$acl_cv_path_LD" -v 2>&1 </dev/null` in
*GNU* | *'with BFD'*)
- test "$with_gnu_ld" != no && break ;;
+ test "$with_gnu_ld" != no && break
+ ;;
*)
- test "$with_gnu_ld" != yes && break ;;
+ test "$with_gnu_ld" != yes && break
+ ;;
esac
fi
done
- IFS="$ac_save_ifs"
+ IFS="$acl_save_ifs"
else
acl_cv_path_LD="$LD" # Let the user override the test with a path.
fi])
diff --git a/m4/stat-time.m4 b/m4/stat-time.m4
index 2dbb1f3..9371d7b 100644
--- a/m4/stat-time.m4
+++ b/m4/stat-time.m4
@@ -19,7 +19,6 @@ dnl From Paul Eggert.
AC_DEFUN([gl_STAT_TIME],
[
- AC_REQUIRE([AC_C_INLINE])
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
AC_CHECK_HEADERS_ONCE([sys/time.h])
@@ -70,7 +69,6 @@ AC_DEFUN([gl_STAT_TIME],
#
AC_DEFUN([gl_STAT_BIRTHTIME],
[
- AC_REQUIRE([AC_C_INLINE])
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
AC_CHECK_HEADERS_ONCE([sys/time.h])
AC_CHECK_MEMBERS([struct stat.st_birthtimespec.tv_nsec], [],
diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4
index ab43728..9c69f2e 100644
--- a/m4/stdlib_h.m4
+++ b/m4/stdlib_h.m4
@@ -102,6 +102,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
REPLACE_MALLOC=0; AC_SUBST([REPLACE_MALLOC])
REPLACE_MBTOWC=0; AC_SUBST([REPLACE_MBTOWC])
REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP])
+ REPLACE_PTSNAME=0; AC_SUBST([REPLACE_PTSNAME])
REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R])
REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV])
REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R])
diff --git a/m4/xsize.m4 b/m4/xsize.m4
index b3b7fee..d85a5f1 100644
--- a/m4/xsize.m4
+++ b/m4/xsize.m4
@@ -1,4 +1,4 @@
-# xsize.m4 serial 4
+# xsize.m4 serial 5
dnl Copyright (C) 2003-2004, 2008-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -8,6 +8,5 @@ AC_DEFUN([gl_XSIZE],
[
dnl Prerequisites of lib/xsize.h.
AC_REQUIRE([gl_SIZE_MAX])
- AC_REQUIRE([AC_C_INLINE])
AC_CHECK_HEADERS([stdint.h])
])
diff --git a/maint.mk b/maint.mk
index a1af711..ea44ece 100644
--- a/maint.mk
+++ b/maint.mk
@@ -28,6 +28,28 @@ ifneq ($(build_aux),)
set $$(_build-aux) relative to $$(srcdir) instead of $$(build_aux)")
endif
+# Helper variables.
+_empty =
+_sp = $(_empty) $(_empty)
+
+# _equal,S1,S2
+# ------------
+# If S1 == S2, return S1, otherwise the empty string.
+_equal = $(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))
+
+# member-check,VARIABLE,VALID-VALUES
+# ----------------------------------
+# Check that $(VARIABLE) is in the space-separated list of VALID-VALUES, and
+# return it. Die otherwise.
+member-check = \
+ $(strip \
+ $(if $($(1)), \
+ $(if $(findstring $(_sp),$($(1))), \
+ $(error invalid $(1): '$($(1))', expected $(2)), \
+ $(or $(findstring $(_sp)$($(1))$(_sp),$(_sp)$(2)$(_sp)), \
+ $(error invalid $(1): '$($(1))', expected $(2)))), \
+ $(error $(1) undefined)))
+
# Do not save the original name or timestamp in the .tar.gz file.
# Use --rsyncable if available.
gzip_rsyncable := \
@@ -52,16 +74,16 @@ _dot_escaped_srcdir = $(subst .,\.,$(srcdir))
# Post-process $(VC_LIST) output, prepending $(srcdir)/, but only
# when $(srcdir) is not ".".
ifeq ($(srcdir),.)
-_prepend_srcdir_prefix =
+ _prepend_srcdir_prefix =
else
-_prepend_srcdir_prefix = | sed 's|^|$(srcdir)/|'
+ _prepend_srcdir_prefix = | sed 's|^|$(srcdir)/|'
endif
# In order to be able to consistently filter "."-relative names,
# (i.e., with no $(srcdir) prefix), this definition is careful to
# remove any $(srcdir) prefix, and to restore what it removes.
_sc_excl = \
- $(if $(exclude_file_name_regexp--$@),$(exclude_file_name_regexp--$@),^$$)
+ $(or $(exclude_file_name_regexp--$@),^$$)
VC_LIST_EXCEPT = \
$(VC_LIST) | sed 's|^$(_dot_escaped_srcdir)/||' \
| if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \
@@ -78,32 +100,41 @@ VERSION_REGEXP = $(subst .,\.,$(VERSION))
PREV_VERSION_REGEXP = $(subst .,\.,$(PREV_VERSION))
ifeq ($(VC),$(GIT))
-this-vc-tag = v$(VERSION)
-this-vc-tag-regexp = v$(VERSION_REGEXP)
+ this-vc-tag = v$(VERSION)
+ this-vc-tag-regexp = v$(VERSION_REGEXP)
else
-tag-package = $(shell echo "$(PACKAGE)" | tr '[:lower:]' '[:upper:]')
-tag-this-version = $(subst .,_,$(VERSION))
-this-vc-tag = $(tag-package)-$(tag-this-version)
-this-vc-tag-regexp = $(this-vc-tag)
+ tag-package = $(shell echo "$(PACKAGE)" | tr '[:lower:]' '[:upper:]')
+ tag-this-version = $(subst .,_,$(VERSION))
+ this-vc-tag = $(tag-package)-$(tag-this-version)
+ this-vc-tag-regexp = $(this-vc-tag)
endif
my_distdir = $(PACKAGE)-$(VERSION)
# Old releases are stored here.
release_archive_dir ?= ../release
+# If RELEASE_TYPE is undefined, but RELEASE is, use its second word.
+# But overwrite VERSION.
+ifdef RELEASE
+ VERSION := $(word 1, $(RELEASE))
+ RELEASE_TYPE ?= $(word 2, $(RELEASE))
+endif
+
+# Validate and return $(RELEASE_TYPE), or die.
+RELEASE_TYPES = alpha beta stable
+release-type = $(call member-check,RELEASE_TYPE,$(RELEASE_TYPES))
+
# Override gnu_rel_host and url_dir_list in cfg.mk if these are not right.
# Use alpha.gnu.org for alpha and beta releases.
# Use ftp.gnu.org for stable releases.
gnu_ftp_host-alpha = alpha.gnu.org
gnu_ftp_host-beta = alpha.gnu.org
gnu_ftp_host-stable = ftp.gnu.org
-gnu_rel_host ?= $(gnu_ftp_host-$(RELEASE_TYPE))
+gnu_rel_host ?= $(gnu_ftp_host-$(release-type))
-ifeq ($(gnu_rel_host),ftp.gnu.org)
-url_dir_list ?= http://ftpmirror.gnu.org/$(PACKAGE)
-else
-url_dir_list ?= ftp://$(gnu_rel_host)/gnu/$(PACKAGE)
-endif
+url_dir_list ?= $(if $(call _equal,$(gnu_rel_host),ftp.gnu.org), \
+ http://ftpmirror.gnu.org/$(PACKAGE), \
+ ftp://$(gnu_rel_host)/gnu/$(PACKAGE))
# Override this in cfg.mk if you are using a different format in your
# NEWS file.
@@ -132,9 +163,9 @@ syntax-check-rules := $(sort $(shell sed -n
's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' \
.PHONY: $(syntax-check-rules)
ifeq ($(shell $(VC_LIST) >/dev/null 2>&1; echo $$?),0)
-local-checks-available += $(syntax-check-rules)
+ local-checks-available += $(syntax-check-rules)
else
-local-checks-available += no-vc-detected
+ local-checks-available += no-vc-detected
no-vc-detected:
@echo "No version control files detected; skipping syntax check"
endif
@@ -187,9 +218,11 @@ syntax-check: $(local-check)
#
# in_vc_files | in_files
#
-# grep-E-style regexp denoting the files to check. If no files
-# are specified the default are all the files that are under
-# version control.
+# grep-E-style regexp selecting the files to check. For in_vc_files,
+# the regexp is used to select matching files from the list of all
+# version-controlled files; for in_files, it's from the names printed
+# by "find $(srcdir)". When neither is specified, use all files that
+# are under version control.
#
# containing | non_containing
#
@@ -261,7 +294,7 @@ define _sc_search_regexp
: Filter by file name; \
if test -n "$$in_files"; then \
files=$$(find $(srcdir) | grep -E "$$in_files" \
- | grep -Ev '$(exclude_file_name_regexp--$@)'); \
+ | grep -Ev '$(_sc_excl)'); \
else
\
files=$$($(VC_LIST_EXCEPT)); \
if test -n "$$in_vc_files"; then \
@@ -328,8 +361,8 @@ sc_prohibit_atoi_atof:
sp_ = strcmp *\(.+\)
sc_prohibit_strcmp:
@prohibit='! *strcmp *\(|\<$(sp_) *[!=]=|[!=]= *$(sp_)' \
- exclude=':# *define STRN?EQ\(' \
- halt='$(ME): replace strcmp calls above with STREQ/STRNEQ' \
+ exclude='# *define STRN?EQ\(' \
+ halt='replace strcmp calls above with STREQ/STRNEQ' \
$(_sc_search_regexp)
# Really. You don't want to use this function.
@@ -351,8 +384,9 @@ sc_prohibit_strncpy:
# | xargs --no-run-if-empty \
# perl -pi -e 's/(^|[^.])\b(exit ?)\(0\)/$1$2(EXIT_SUCCESS)/'
sc_prohibit_magic_number_exit:
- @prohibit='(^|[^.])\<(usage|exit) ?\([0-9]|\<error ?\([1-9][0-9]*,'
\
- halt='use EXIT_* values rather than magic number'
\
+ @prohibit='(^|[^.])\<(usage|exit|error) ?\(-?[0-9]+[,)]' \
+ exclude='exit \(77\)|error ?\(((0|77),|[^,]*)' \
+ halt='use EXIT_* values rather than magic number' \
$(_sc_search_regexp)
# Using EXIT_SUCCESS as the first argument to error is misleading,
@@ -567,8 +601,6 @@ sc_prohibit_c_ctype_without_use:
@h='c-ctype.h' re='\<c_($(ctype_re)) *\(' \
$(_sc_header_without_use)
-_empty =
-_sp = $(_empty) $(_empty)
# The following list was generated by running:
# man signal.h|col -b|perl -ne '/bsd_signal.*;/.../sigwaitinfo.*;/ and print' \
# | perl -lne '/^\s+(?:int|void).*?(\w+).*/ and print $1' | fmt
@@ -721,6 +753,7 @@ sc_require_test_exit_idiom:
sc_trailing_blank:
@prohibit='[ ]$$' \
halt='found trailing blank(s)' \
+ exclude='^Binary file .* matches$$' \
$(_sc_search_regexp)
# Match lines like the following, but where there is only one space
@@ -741,7 +774,7 @@ _gl_translatable_diag_func_re ?= error
sc_unmarked_diagnostics:
@prohibit='\<$(_gl_translatable_diag_func_re) *\([^"]*"[^"]*[a-z]{3}' \
exclude='(_|ngettext ?)\(' \
- halt='$(ME): found unmarked diagnostic(s)' \
+ halt='found unmarked diagnostic(s)' \
$(_sc_search_regexp)
# Avoid useless parentheses like those in this example:
@@ -775,6 +808,11 @@ sc_prohibit_always_true_header_tests:
' with the corresponding gnulib module, they are always true') \
$(_sc_search_regexp)
+sc_prohibit_defined_have_decl_tests:
+ @prohibit='#[ ]*if(n?def|.*\<defined)\>[ (]+HAVE_DECL_' \
+ halt='HAVE_DECL macros are always defined' \
+ $(_sc_search_regexp)
+
# ==================================================================
gl_other_headers_ ?= \
intprops.h \
@@ -1012,7 +1050,7 @@ sc_redundant_const:
sc_const_long_option:
@prohibit='^ *static.*struct option ' \
exclude='const struct option|struct option const' \
- halt='$(ME): add "const" to the above declarations' \
+ halt='add "const" to the above declarations' \
$(_sc_search_regexp)
NEWS_hash = \
@@ -1059,7 +1097,7 @@ sc_makefile_at_at_check:
&& { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || :
news-check: NEWS
- if sed -n $(news-check-lines-spec)p $< \
+ $(AM_V_GEN)if sed -n $(news-check-lines-spec)p $< \
| grep -E $(news-check-regexp) >/dev/null; then \
:; \
else \
@@ -1083,9 +1121,11 @@ fix_po_file_diag = \
'you have changed the set of files with translatable diagnostics;\n\
apply the above patch\n'
-# Verify that all source files using _() are listed in po/POTFILES.in.
+# Verify that all source files using _() (more specifically, files that
+# match $(_gl_translatable_string_re)) are listed in po/POTFILES.in.
po_file ?= $(srcdir)/po/POTFILES.in
generated_files ?= $(srcdir)/lib/*.[ch]
+_gl_translatable_string_re ?= \b(N?_|gettext *)\([^)"]*("|$$)
sc_po_check:
@if test -f $(po_file); then \
grep -E -v '^(#|$$)' $(po_file) \
@@ -1105,7 +1145,7 @@ sc_po_check:
esac; \
files="$$files $$file"; \
done; \
- grep -E -l '\b(N?_|gettext *)\([^)"]*("|$$)' $$files \
+ grep -E -l '$(_gl_translatable_string_re)' $$files \
| sed 's|^$(_dot_escaped_srcdir)/||' | sort -u > address@hidden;
\
diff -u -L $(po_file) -L $(po_file) address@hidden address@hidden
\
|| { printf '$(ME): '$(fix_po_file_diag) 1>&2; exit 1; }; \
@@ -1115,7 +1155,7 @@ sc_po_check:
# Sometimes it is useful to change the PATH environment variable
# in Makefiles. When doing so, it's better not to use the Unix-centric
# path separator of ':', but rather the automake-provided '$(PATH_SEPARATOR)'.
-msg = '$(ME): Do not use ":" above; use $$(PATH_SEPARATOR) instead'
+msg = 'Do not use ":" above; use $$(PATH_SEPARATOR) instead'
sc_makefile_path_separator_check:
@prohibit='PATH[=].*:' \
in_vc_files='akefile|\.mk$$' \
@@ -1126,7 +1166,7 @@ sc_makefile_path_separator_check:
# i.e., when pkg-M.N.tar.xz already exists (either in "." or in ../release)
# and is read-only.
writable-files:
- if test -d $(release_archive_dir); then \
+ $(AM_V_GEN)if test -d $(release_archive_dir); then \
for file in $(DIST_ARCHIVES); do \
for p in ./ $(release_archive_dir)/; do \
test -e $$p$$file || continue; \
@@ -1208,22 +1248,31 @@ sc_Wundef_boolean:
# 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' \
+ @prohibit='(\balloca *\([^)]*|\[[^]]*)\bPATH_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) \
+ in_files='(^|/)Makefile\.in$$' \
halt=$$(printf '%s\n' \
'the above files are vulnerable; beware of running' \
' "make dist*" rules, and upgrade to fixed automake' \
' see http://bugzilla.redhat.com/542609 for details') \
$(_sc_search_regexp)
+sc_vulnerable_makefile_CVE-2012-3386:
+ @prohibit='chmod a\+w \$$\(distdir\)' \
+ in_files='(^|/)Makefile\.in$$' \
+ halt=$$(printf '%s\n' \
+ 'the above files are vulnerable; beware of running' \
+ ' "make distcheck", and upgrade to fixed automake' \
+ ' see http://bugzilla.redhat.com/CVE-2012-3386 for details') \
+ $(_sc_search_regexp)
+
vc-diff-check:
- (unset CDPATH; cd $(srcdir) && $(VC) diff) > vc-diffs || :
- if test -s vc-diffs; then \
+ $(AM_V_GEN)(unset CDPATH; cd $(srcdir) && $(VC) diff) > vc-diffs || :
+ $(AM_V_at)if test -s vc-diffs; then \
cat vc-diffs; \
echo "Some files are locally modified:" 1>&2; \
exit 1; \
@@ -1239,31 +1288,37 @@ bootstrap-tools ?= autoconf,automake,gnulib
# If it's not already specified, derive the GPG key ID from
# the signed tag we've just applied to mark this release.
-gpg_key_ID ?= \
- $$(git cat-file tag v$(VERSION) \
- | gpgv --status-fd 1 --keyring /dev/null - - 2>/dev/null \
- | awk '/^\[GNUPG:\] ERRSIG / {print $$3; exit}')
+gpg_key_ID ?= \
+ $$(cd $(srcdir) \
+ && git cat-file tag v$(VERSION) \
+ | gpgv --status-fd 1 --keyring /dev/null - - 2>/dev/null \
+ | awk '/^\[GNUPG:\] ERRSIG / {print $$3; exit}')
translation_project_ ?= address@hidden
# Make info-gnu the default only for a stable release.
-ifeq ($(RELEASE_TYPE),stable)
- announcement_Cc_ ?= $(translation_project_), $(PACKAGE_BUGREPORT)
- announcement_mail_headers_ ?=
\
- To: address@hidden \
- Cc: $(announcement_Cc_) \
- Mail-Followup-To: $(PACKAGE_BUGREPORT)
-else
- announcement_Cc_ ?= $(translation_project_)
- announcement_mail_headers_ ?=
\
- To: $(PACKAGE_BUGREPORT) \
- Cc: $(announcement_Cc_)
-endif
-
+announcement_Cc_stable = $(translation_project_), $(PACKAGE_BUGREPORT)
+announcement_mail_headers_stable = \
+ To: address@hidden \
+ Cc: $(announcement_Cc_) \
+ Mail-Followup-To: $(PACKAGE_BUGREPORT)
+
+announcement_Cc_alpha = $(translation_project_)
+announcement_mail_headers_alpha = \
+ To: $(PACKAGE_BUGREPORT) \
+ Cc: $(announcement_Cc_)
+
+announcement_mail_Cc_beta = $(announcement_mail_Cc_alpha)
+announcement_mail_headers_beta = $(announcement_mail_headers_alpha)
+
+announcement_mail_Cc_ ?= $(announcement_mail_Cc_$(release-type))
+announcement_mail_headers_ ?= $(announcement_mail_headers_$(release-type))
announcement: NEWS ChangeLog $(rel-files)
- @$(srcdir)/$(_build-aux)/announce-gen \
+# Not $(AM_V_GEN) since the output of this command serves as
+# annoucement message: it would start with " GEN announcement".
+ $(AM_V_at)$(srcdir)/$(_build-aux)/announce-gen \
--mail-headers='$(announcement_mail_headers_)' \
- --release-type=$(RELEASE_TYPE) \
+ --release-type=$(release-type) \
--package=$(PACKAGE) \
--prev=$(PREV_VERSION) \
--curr=$(VERSION) \
@@ -1276,6 +1331,12 @@ announcement: NEWS ChangeLog $(rel-files)
--no-print-checksums \
$(addprefix --url-dir=, $(url_dir_list))
+.PHONY: release-commit
+release-commit:
+ $(AM_V_GEN)cd $(srcdir) \
+ && $(_build-aux)/do-release-commit-and-tag \
+ -C $(abs_builddir) $(RELEASE)
+
## ---------------- ##
## Updating files. ##
## ---------------- ##
@@ -1284,16 +1345,22 @@ ftp-gnu = ftp://ftp.gnu.org/gnu
www-gnu = http://www.gnu.org
upload_dest_dir_ ?= $(PACKAGE)
+upload_command = \
+ $(srcdir)/$(_build-aux)/gnupload $(GNUPLOADFLAGS) \
+ --to $(gnu_rel_host):$(upload_dest_dir_) \
+ $(rel-files)
emit_upload_commands:
@echo =====================================
@echo =====================================
- @echo "$(srcdir)/$(_build-aux)/gnupload $(GNUPLOADFLAGS) \\"
- @echo " --to $(gnu_rel_host):$(upload_dest_dir_) \\"
- @echo " $(rel-files)"
+ @echo '$(upload_command)'
@echo '# send the ~/announce-$(my_distdir) e-mail'
@echo =====================================
@echo =====================================
+.PHONY: upload
+upload:
+ $(AM_V_GEN)$(upload_command)
+
define emit-commit-log
printf '%s\n' 'maint: post-release administrivia' '' \
'* NEWS: Add header line for next release.'
\
@@ -1303,7 +1370,7 @@ endef
.PHONY: no-submodule-changes
no-submodule-changes:
- if test -d $(srcdir)/.git; then \
+ $(AM_V_GEN)if test -d $(srcdir)/.git; then \
diff=$$(cd $(srcdir) && git submodule -q foreach \
git diff-index --name-only HEAD) \
|| exit 1; \
@@ -1339,19 +1406,22 @@ public-submodule-commit:
gl_public_submodule_commit ?= public-submodule-commit
check: $(gl_public_submodule_commit)
-.PHONY: alpha beta stable
+.PHONY: alpha beta stable release
ALL_RECURSIVE_TARGETS += alpha beta stable
alpha beta stable: $(local-check) writable-files $(submodule-checks)
- test $@ = stable \
+ $(AM_V_GEN)test $@ = stable \
&& { echo $(VERSION) | grep -E '^[0-9]+(\.[0-9]+)+$$' \
|| { echo "invalid version string: $(VERSION)" 1>&2; exit 1;};}\
|| :
- $(MAKE) vc-diff-check
- $(MAKE) news-check
- $(MAKE) distcheck
- $(MAKE) dist
- $(MAKE) $(release-prep-hook) RELEASE_TYPE=$@
- $(MAKE) -s emit_upload_commands RELEASE_TYPE=$@
+ $(AM_V_at)$(MAKE) vc-diff-check
+ $(AM_V_at)$(MAKE) news-check
+ $(AM_V_at)$(MAKE) distcheck
+ $(AM_V_at)$(MAKE) dist
+ $(AM_V_at)$(MAKE) $(release-prep-hook) RELEASE_TYPE=$@
+ $(AM_V_at)$(MAKE) -s emit_upload_commands RELEASE_TYPE=$@
+
+release:
+ $(AM_V_GEN)$(MAKE) $(release-type)
# Override this in cfg.mk if you follow different procedures.
release-prep-hook ?= release-prep
@@ -1359,19 +1429,19 @@ release-prep-hook ?= release-prep
gl_noteworthy_news_ = * Noteworthy changes in release ?.? (????-??-??) [?]
.PHONY: release-prep
release-prep:
- case $$RELEASE_TYPE in alpha|beta|stable) ;; \
- *) echo "invalid RELEASE_TYPE: $$RELEASE_TYPE" 1>&2; exit 1;; esac
- $(MAKE) --no-print-directory -s announcement > ~/announce-$(my_distdir)
- if test -d $(release_archive_dir); then \
+ $(AM_V_GEN)$(MAKE) --no-print-directory -s announcement \
+ > ~/announce-$(my_distdir)
+ $(AM_V_at)if test -d $(release_archive_dir); then \
ln $(rel-files) $(release_archive_dir); \
chmod a-w $(rel-files); \
fi
- echo $(VERSION) > $(prev_version_file)
- $(MAKE) update-NEWS-hash
- perl -pi -e '$$. == 3 and print "$(gl_noteworthy_news_)\n\n\n"'
$(srcdir)/NEWS
- $(emit-commit-log) > .ci-msg
- $(VC) commit -F .ci-msg -a
- rm .ci-msg
+ $(AM_V_at)echo $(VERSION) > $(prev_version_file)
+ $(AM_V_at)$(MAKE) update-NEWS-hash
+ $(AM_V_at)perl -pi \
+ -e '$$. == 3 and print "$(gl_noteworthy_news_)\n\n\n"' \
+ $(srcdir)/NEWS
+ $(AM_V_at)msg=$$($(emit-commit-log)) || exit 1; \
+ cd $(srcdir) && $(VC) commit -m "$$msg" -a
# Override this with e.g., -s $(srcdir)/some_other_name.texi
# if the default $(PACKAGE)-derived name doesn't apply.
@@ -1379,14 +1449,20 @@ gendocs_options_ ?=
.PHONY: web-manual
web-manual:
- @test -z "$(manual_title)" \
+ $(AM_V_GEN)test -z "$(manual_title)" \
&& { echo define manual_title in cfg.mk 1>&2; exit 1; } || :
- @cd '$(srcdir)/doc'; \
+ $(AM_V_at)cd '$(srcdir)/doc'; \
$(SHELL) ../$(_build-aux)/gendocs.sh $(gendocs_options_) \
-o '$(abs_builddir)/doc/manual' \
--email $(PACKAGE_BUGREPORT) $(PACKAGE) \
"$(PACKAGE_NAME) - $(manual_title)"
- @echo " *** Upload the doc/manual directory to web-cvs."
+ $(AM_V_at)echo " *** Upload the doc/manual directory to web-cvs."
+
+.PHONY: web-manual-update
+web-manual-update:
+ $(AM_V_GEN)cd $(srcdir) \
+ && $(_build-aux)/gnu-web-doc-update -C $(abs_builddir)
+
# Code Coverage
@@ -1412,6 +1488,31 @@ gen-coverage:
coverage: init-coverage build-coverage gen-coverage
+# Some projects carry local adjustments for gnulib modules via patches in
+# a gnulib patch directory whose default name is gl/ (defined in bootstrap
+# via local_gl_dir=gl). Those patches become stale as the originals evolve
+# in gnulib. Use this rule to refresh any stale patches. It applies each
+# patch to the original in $(gnulib_dir) and uses the temporary result to
+# generate a fuzz-free .diff file. If you customize the name of your local
+# gnulib patch directory via bootstrap.conf, this rule detects that name.
+# Run this from a non-VPATH (i.e., srcdir) build directory.
+.PHONY: refresh-gnulib-patches
+refresh-gnulib-patches:
+ gl=gl; \
+ if test -f bootstrap.conf; then \
+ t=$$(perl -lne '/^\s*local_gl_dir=(\S+)/ and $$d=$$1;' \
+ -e 'END{defined $$d and print $$d}' bootstrap.conf); \
+ test -n "$$t" && gl=$$t; \
+ fi; \
+ for diff in $$(cd $$gl; git ls-files | grep '\.diff$$'); do \
+ b=$$(printf %s "$$diff"|sed 's/\.diff$$//'); \
+ VERSION_CONTROL=none \
+ patch "$(gnulib_dir)/$$b" "$$gl/$$diff" || exit 1; \
+ ( cd $(gnulib_dir) || exit 1; \
+ git diff "$$b" > "../$$gl/$$diff"; \
+ git checkout $$b ) || exit 1; \
+ done
+
# Update gettext files.
PACKAGE ?= $(shell basename $(PWD))
PO_DOMAIN ?= $(PACKAGE)
@@ -1445,7 +1546,7 @@ update-copyright-env ?=
# in the file .x-update-copyright.
.PHONY: update-copyright
update-copyright:
- grep -l -w Copyright \
+ $(AM_V_GEN)grep -l -w Copyright \
$$(export VC_LIST_EXCEPT_DEFAULT=COPYING && $(VC_LIST_EXCEPT)) \
| $(update-copyright-env) xargs $(srcdir)/$(_build-aux)/$@
@@ -1518,6 +1619,7 @@ _gl_TS_obj_files ?= *.$(OBJEXT)
# Files in which to search for the one-line style extern declarations.
# $(_gl_TS_dir)-relative.
_gl_TS_headers ?= $(noinst_HEADERS)
+_gl_TS_other_headers ?= *.h
.PHONY: _gl_tight_scope
_gl_tight_scope: $(bin_PROGRAMS)
@@ -1540,7 +1642,8 @@ _gl_tight_scope: $(bin_PROGRAMS)
&& { echo the above functions should have static scope >&2; \
exit 1; } || : ; \
( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \
- perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' $$hdr *.h \
+ perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \
+ $$hdr $(_gl_TS_other_headers) \
) | sort -u > $$t; \
nm -e $(_gl_TS_obj_files) | sed -n 's/.* [BCDGRS] //p' \
| sort -u | grep -Ev -f $$t
\
diff --git a/module/Makefile.am b/module/Makefile.am
index 2226d5b..0998703 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -219,7 +219,6 @@ ICE_9_SOURCES = \
ice-9/optargs.scm \
ice-9/poe.scm \
ice-9/poll.scm \
- ice-9/popen.scm \
ice-9/posix.scm \
ice-9/q.scm \
ice-9/rdelim.scm \
@@ -251,6 +250,13 @@ ICE_9_SOURCES = \
ice-9/serialize.scm \
ice-9/local-eval.scm
+if HAVE_FORK
+
+# This functionality is missing on systems without `fork'---i.e., Windows.
+ICE_9_SOURCES += ice-9/popen.scm
+
+endif HAVE_FORK
+
SRFI_SOURCES = \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1285c83..a846c5f 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3753,9 +3753,14 @@ module '(ice-9 q) '(make-q q-length))}."
(define %auto-compilation-options
;; Default `compile-file' option when auto-compiling.
- '(#:warnings (unbound-variable arity-mismatch format)))
+ '(#:warnings (unbound-variable arity-mismatch format
+ duplicate-case-datum bad-case-datum)))
(define* (load-in-vicinity dir path #:optional reader)
+ "Load source file PATH in vicinity of directory DIR. Use a pre-compiled
+version of PATH when available, and auto-compile one when none is available,
+reading PATH with READER."
+
(define (canonical->suffix canon)
(cond
((string-prefix? "/" canon) canon)
@@ -3765,6 +3770,49 @@ module '(ice-9 q) '(make-q q-length))}."
(string-append "/" (substring canon 0 1) (substring canon 2)))
(else canon)))
+ (define compiled-extension
+ ;; File name extension of compiled files.
+ (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions))))
+
+ (define (more-recent? stat1 stat2)
+ ;; Return #t when STAT1 has an mtime greater than that of STAT2.
+ (or (> (stat:mtime stat1) (stat:mtime stat2))
+ (and (= (stat:mtime stat1) (stat:mtime stat2))
+ (>= (stat:mtimensec stat1)
+ (stat:mtimensec stat2)))))
+
+ (define (fallback-file-name canon-path)
+ ;; Return the in-cache compiled file name for source file 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
+ (canonical->suffix canon-path)
+ compiled-extension)))
+
+ (define (compile file)
+ ;; Compile source FILE, lazily loading the compiler.
+ ((module-ref (resolve-interface '(system base compile))
+ 'compile-file)
+ file
+ #:opts %auto-compilation-options
+ #:env (current-module)))
+
+ (define (warn-about-exception key args)
+ (for-each (lambda (s)
+ (if (not (string-null? s))
+ (format (current-warning-port) ";;; ~a\n" s)))
+ (string-split
+ (call-with-output-string
+ (lambda (port) (print-exception port #f key args)))
+ #\newline)))
+
;; 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
@@ -3774,32 +3822,15 @@ module '(ice-9 q) '(make-q q-length))}."
;; NB: Unless we need to compile the file, this function should not cause
;; (system base compile) to be loaded up. For that reason compiled-file-name
;; 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
- (canonical->suffix canon-path)
- (cond ((or (null? %load-compiled-extensions)
- (string-null? (car %load-compiled-extensions)))
- (warn "invalid %load-compiled-extensions"
- %load-compiled-extensions)
- ".go")
- (else (car %load-compiled-extensions))))))
-
- (define (fresh-compiled-file-name name go-path)
+
+ (define (fresh-compiled-file-name name scmstat go-path)
+ ;; Return GO-PATH after making sure that it contains a freshly compiled
+ ;; version of source file NAME with stat SCMSTAT; return #f on failure.
(catch #t
(lambda ()
- (let* ((scmstat (stat name))
- (gostat (and (not %fresh-auto-compile)
- (stat go-path #f))))
- (if (and gostat
- (or (> (stat:mtime gostat) (stat:mtime scmstat))
- (and (= (stat:mtime gostat) (stat:mtime scmstat))
- (>= (stat:mtimensec gostat)
- (stat:mtimensec scmstat)))))
+ (let ((gostat (and (not %fresh-auto-compile)
+ (stat go-path #f))))
+ (if (and gostat (more-recent? gostat scmstat))
go-path
(begin
(if gostat
@@ -3810,51 +3841,66 @@ module '(ice-9 q) '(make-q q-length))}."
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
(format (current-warning-port) ";;; compiling ~a\n" name)
- (let ((cfn
- ((module-ref
- (resolve-interface '(system base compile))
- 'compile-file)
- name
- #:opts %auto-compilation-options
- #:env (current-module))))
+ (let ((cfn (compile name)))
(format (current-warning-port) ";;; compiled ~a\n" cfn)
cfn))
(else #f))))))
(lambda (k . args)
(format (current-warning-port)
";;; WARNING: compilation of ~a failed:\n" name)
- (for-each (lambda (s)
- (if (not (string-null? s))
- (format (current-warning-port) ";;; ~a\n" s)))
- (string-split
- (call-with-output-string
- (lambda (port) (print-exception port #f k args)))
- #\newline))
+ (warn-about-exception k args)
#f)))
(define (absolute-path? path)
(string-prefix? "/" path))
+ (define (sans-extension file)
+ (let ((dot (string-rindex file #\.)))
+ (if dot
+ (substring file 0 dot)
+ file)))
+
(define (load-absolute abs-path)
- (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
- (and canon
- (let ((go-path (compiled-file-name canon)))
- (and go-path
- (fresh-compiled-file-name abs-path go-path)))))))
- (if cfn
+ ;; Load from ABS-PATH, using a compiled file or auto-compiling if needed.
+ (define scmstat
+ (catch #t
+ (lambda ()
+ (stat abs-path))
+ (lambda (key . args)
+ (warn-about-exception key args)
+ #f)))
+
+ (define (pre-compiled)
+ (let ((go-path (search-path %load-compiled-path (sans-extension path)
+ %load-compiled-extensions #t)))
+ (and go-path
+ (let ((gostat (stat go-path #f)))
+ (and gostat (more-recent? gostat scmstat)
+ go-path)))))
+
+ (define (fallback)
+ (let ((canon (false-if-exception (canonicalize-path abs-path))))
+ (and canon
+ (let ((go-path (fallback-file-name canon)))
+ (and go-path
+ (fresh-compiled-file-name abs-path scmstat go-path))))))
+
+ (let ((compiled (and scmstat
+ (or (pre-compiled) (fallback)))))
+ (if compiled
(begin
(if %load-hook
(%load-hook abs-path))
- (load-compiled cfn))
+ (load-compiled compiled))
(start-stack 'load-stack
(primitive-load abs-path)))))
-
+
(save-module-excursion
(lambda ()
(with-fluids ((current-reader reader)
(%file-port-name-canonicalization 'relative))
(cond
- ((or (absolute-path? path))
+ ((absolute-path? path)
(load-absolute path))
((absolute-path? dir)
(load-absolute (in-vicinity dir path)))
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 7098d4f..d9a4d59 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,7 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2011
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 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
@@ -65,7 +64,7 @@
(define (make-formals n)
(map (lambda (i)
(datum->syntax
- x
+ x
(string->symbol
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
@@ -225,11 +224,12 @@
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc
- (and alt
+ (and alt ; (body docstring nreq ...)
(let* ((body (car alt))
- (nreq (cadr alt))
- (rest (if (null? (cddr alt)) #f (caddr alt)))
- (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
+ (spec (cddr alt))
+ (nreq (car spec))
+ (rest (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr
spec)))
(nopt (if tail (car tail) 0))
(kw (and tail (cadr tail)))
(inits (if tail (caddr tail) '()))
@@ -246,9 +246,10 @@
(and kw (car kw))
(and rest? '_)))
(set-procedure-minimum-arity! proc nreq nopt rest?))
- (let* ((nreq* (cadr alt))
- (rest?* (if (null? (cddr alt)) #f (caddr alt)))
- (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
+ (let* ((spec (cddr alt))
+ (nreq* (car spec))
+ (rest?* (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr
spec)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (cadddr tail))))
(if (or (< nreq* nreq)
@@ -397,14 +398,20 @@
(eval body new-env)
(lp (cdr inits)
(cons (eval (car inits) env) new-env)))))
-
- (('lambda (body nreq . tail))
- (if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
- (if (null? (cdr tail))
- (make-general-closure (capture-env env) body nreq (car tail)
- 0 #f '() #f)
- (apply make-general-closure (capture-env env) body nreq
tail))))
+
+ (('lambda (body docstring nreq . tail))
+ (let ((proc
+ (if (null? tail)
+ (make-fixed-closure eval nreq body (capture-env env))
+ (if (null? (cdr tail))
+ (make-general-closure (capture-env env) body
+ nreq (car tail)
+ 0 #f '() #f)
+ (apply make-general-closure (capture-env env)
+ body nreq tail)))))
+ (when docstring
+ (set-procedure-property! proc 'documentation docstring))
+ proc))
(('seq (head . tail))
(begin
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 7fbccf6..6ff104d 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -19,8 +19,10 @@
(define-module (ice-9 futures)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
- #:use-module (ice-9 threads)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (ice-9 q)
+ #:use-module (ice-9 match)
#:export (future make-future future? touch))
;;; Author: Ludovic Courtès <address@hidden>
@@ -44,19 +46,29 @@
;;;
(define-record-type <future>
- (%make-future thunk done? mutex)
+ (%make-future thunk state mutex completion)
future?
- (thunk future-thunk)
- (done? future-done? set-future-done?!)
- (result future-result set-future-result!)
- (mutex future-mutex))
+ (thunk future-thunk set-future-thunk!)
+ (state future-state set-future-state!) ; done | started | queued
+ (result future-result set-future-result!)
+ (mutex future-mutex)
+ (completion future-completion)) ; completion cond. var.
+
+(set-record-type-printer!
+ <future>
+ (lambda (future port)
+ (simple-format port "#<future ~a ~a ~s>"
+ (number->string (object-address future) 16)
+ (future-state future)
+ (future-thunk future))))
(define (make-future thunk)
"Return a new future for THUNK. Execution may start at any point
concurrently, or it can start at the time when the returned future is
touched."
(create-workers!)
- (let ((future (%make-future thunk #f (make-mutex))))
+ (let ((future (%make-future thunk 'queued
+ (make-mutex) (make-condition-variable))))
(register-future! future)
future))
@@ -65,10 +77,44 @@ touched."
;;; Future queues.
;;;
+;; Global queue of pending futures.
+;; TODO: Use per-worker queues to reduce contention.
(define %futures (make-q))
+
+;; Lock for %FUTURES and %FUTURES-WAITING.
(define %futures-mutex (make-mutex))
(define %futures-available (make-condition-variable))
+;; A mapping of nested futures to futures waiting for them to complete.
+(define %futures-waiting '())
+
+;; Whether currently running within a future.
+(define %within-future? (make-parameter #f))
+
+(define-syntax-rule (with-mutex m e0 e1 ...)
+ ;; Copied from (ice-9 threads) to avoid circular dependency.
+ (let ((x m))
+ (dynamic-wind
+ (lambda () (lock-mutex x))
+ (lambda () (begin e0 e1 ...))
+ (lambda () (unlock-mutex x)))))
+
+(define-syntax-rule (let/ec k e e* ...) ; TODO: move to core
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (let ((k (lambda args (apply abort-to-prompt tag args))))
+ e e* ...))
+ (lambda (_ res) res))))
+
+
+(define %future-prompt
+ ;; The prompt futures abort to when they want to wait for another
+ ;; future.
+ (make-prompt-tag))
+
+
(define (register-future! future)
;; Register FUTURE as being processable.
(lock-mutex %futures-mutex)
@@ -77,66 +123,146 @@ touched."
(unlock-mutex %futures-mutex))
(define (process-future! future)
- ;; Process FUTURE, assuming its mutex is already taken.
- (set-future-result! future
- (catch #t
- (lambda ()
- (call-with-values (future-thunk future)
- (lambda results
+ "Process FUTURE. When FUTURE completes, return #t and update its
+result; otherwise, when FUTURE touches a nested future that has not
+completed yet, then suspend it and return #f. Suspending a future
+consists in capturing its continuation, marking it as `queued', and
+adding it to the waiter queue."
+ (let/ec return
+ (let* ((suspend
+ (lambda (cont future-to-wait)
+ ;; FUTURE wishes to wait for the completion of FUTURE-TO-WAIT.
+ ;; At this point, FUTURE is unlocked and in `started' state,
+ ;; and FUTURE-TO-WAIT is unlocked.
+ (with-mutex %futures-mutex
+ (with-mutex (future-mutex future)
+ (set-future-thunk! future cont)
+ (set-future-state! future 'queued))
+
+ (with-mutex (future-mutex future-to-wait)
+ ;; If FUTURE-TO-WAIT completed in the meantime, then
+ ;; reschedule FUTURE directly; otherwise, add it to the
+ ;; waiter queue.
+ (if (eq? 'done (future-state future-to-wait))
+ (begin
+ (enq! %futures future)
+ (signal-condition-variable %futures-available))
+ (set! %futures-waiting
+ (alist-cons future-to-wait future
+ %futures-waiting))))
+
+ (return #f))))
+ (thunk (lambda ()
+ (call-with-prompt %future-prompt
+ (lambda ()
+ (parameterize ((%within-future? #t))
+ ((future-thunk future))))
+ suspend))))
+ (set-future-result! future
+ (catch #t
+ (lambda ()
+ (call-with-values thunk
+ (lambda results
+ (lambda ()
+ (apply values results)))))
+ (lambda args
(lambda ()
- (apply values results)))))
- (lambda args
- (lambda ()
- (apply throw args)))))
- (set-future-done?! future #t))
+ (apply throw args)))))
+ #t)))
+
+(define (process-one-future)
+ "Attempt to pick one future from the queue and process it."
+ ;; %FUTURES-MUTEX must be locked on entry, and is locked on exit.
+ (or (q-empty? %futures)
+ (let ((future (deq! %futures)))
+ (lock-mutex (future-mutex future))
+ (case (future-state future)
+ ((done started)
+ ;; Nothing to do.
+ (unlock-mutex (future-mutex future)))
+ (else
+ ;; Do the actual work.
+
+ ;; We want to release %FUTURES-MUTEX so that other workers can
+ ;; progress. However, to avoid deadlocks, we have to unlock
+ ;; FUTURE as well, to preserve lock ordering.
+ (unlock-mutex (future-mutex future))
+ (unlock-mutex %futures-mutex)
+
+ (lock-mutex (future-mutex future))
+ (if (eq? (future-state future) 'queued) ; lost the race?
+ (begin ; no, so let's process it
+ (set-future-state! future 'started)
+ (unlock-mutex (future-mutex future))
+
+ (let ((done? (process-future! future)))
+ (when done?
+ (with-mutex %futures-mutex
+ (with-mutex (future-mutex future)
+ (set-future-state! future 'done)
+ (notify-completion future))))))
+ (unlock-mutex (future-mutex future))) ; yes
+
+ (lock-mutex %futures-mutex))))))
(define (process-futures)
- ;; Wait for futures to be available and process them.
+ "Continuously process futures from the queue."
(lock-mutex %futures-mutex)
(let loop ()
(when (q-empty? %futures)
(wait-condition-variable %futures-available
%futures-mutex))
- (or (q-empty? %futures)
- (let ((future (deq! %futures)))
- (lock-mutex (future-mutex future))
- (or (and (future-done? future)
- (unlock-mutex (future-mutex future)))
- (begin
- ;; Do the actual work.
-
- ;; We want to release %FUTURES-MUTEX so that other workers
- ;; can progress. However, to avoid deadlocks, we have to
- ;; unlock FUTURE as well, to preserve lock ordering.
- (unlock-mutex (future-mutex future))
- (unlock-mutex %futures-mutex)
-
- (lock-mutex (future-mutex future))
- (or (future-done? future) ; lost the race?
- (process-future! future))
- (unlock-mutex (future-mutex future))
-
- (lock-mutex %futures-mutex)))))
+ (process-one-future)
(loop)))
+(define (notify-completion future)
+ "Notify futures and callers waiting that FUTURE completed."
+ ;; FUTURE and %FUTURES-MUTEX are locked.
+ (broadcast-condition-variable (future-completion future))
+ (let-values (((waiting remaining)
+ (partition (match-lambda ; TODO: optimize
+ ((waitee . _)
+ (eq? waitee future)))
+ %futures-waiting)))
+ (set! %futures-waiting remaining)
+ (for-each (match-lambda
+ ((_ . waiter)
+ (enq! %futures waiter)))
+ waiting)))
+
(define (touch future)
"Return the result of FUTURE, computing it if not already done."
- (lock-mutex (future-mutex future))
- (or (future-done? future)
- (begin
- ;; Do the actual work. Unlock FUTURE first to preserve lock
- ;; ordering.
- (unlock-mutex (future-mutex future))
-
- (lock-mutex %futures-mutex)
- (q-remove! %futures future)
- (unlock-mutex %futures-mutex)
+ (define (work)
+ ;; Do some work while waiting for FUTURE to complete.
+ (lock-mutex %futures-mutex)
+ (if (q-empty? %futures)
+ (begin
+ (unlock-mutex %futures-mutex)
+ (with-mutex (future-mutex future)
+ (unless (eq? 'done (future-state future))
+ (wait-condition-variable (future-completion future)
+ (future-mutex future)))))
+ (begin
+ (process-one-future)
+ (unlock-mutex %futures-mutex))))
- (lock-mutex (future-mutex future))
- (or (future-done? future) ; lost the race?
- (process-future! future))))
- (unlock-mutex (future-mutex future))
+ (let loop ()
+ (lock-mutex (future-mutex future))
+ (case (future-state future)
+ ((done)
+ (unlock-mutex (future-mutex future)))
+ ((started)
+ (unlock-mutex (future-mutex future))
+ (if (%within-future?)
+ (abort-to-prompt %future-prompt future)
+ (begin
+ (work)
+ (loop))))
+ (else
+ (unlock-mutex (future-mutex future))
+ (work)
+ (loop))))
((future-result future)))
@@ -184,3 +310,7 @@ touched."
(define-syntax-rule (future body)
"Return a new future for BODY."
(make-future (lambda () body)))
+
+;;; Local Variables:
+;;; eval: (put 'with-mutex 'scheme-indent-function 1)
+;;; End:
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index 019a6a7..428d951 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -40,7 +40,13 @@
(substring (symbol->string (syntax->datum #'colon-n))
1)))))
(resolve-r6rs-interface
- #`(library (srfi #,srfi-n rest ... (version ...))))))
+ (syntax-case #'(rest ...) ()
+ (()
+ #`(library (srfi #,srfi-n (version ...))))
+ ((name rest ...)
+ ;; SRFI 97 says that the first identifier after the colon-n
+ ;; is used for the libraries name, so it must be ignored.
+ #`(library (srfi #,srfi-n rest ... (version ...))))))))
((library (name name* ... (version ...)))
(and-map sym? #'(name name* ...))
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 047a733..9f9e1bf 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -1,4 +1,5 @@
-;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011,
+;;;; 2012 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
@@ -33,6 +34,7 @@
(define-module (ice-9 threads)
#:use-module (ice-9 futures)
+ #:use-module (ice-9 match)
#:export (begin-thread
parallel
letpar
@@ -87,16 +89,19 @@
(with-mutex (make-mutex)
first rest ...))
-(define (par-mapper mapper)
- (lambda (proc . arglists)
- (mapper touch
- (apply map
- (lambda args
- (future (apply proc args)))
- arglists))))
-
-(define par-map (par-mapper map))
-(define par-for-each (par-mapper for-each))
+(define (par-mapper mapper cons)
+ (lambda (proc . lists)
+ (let loop ((lists lists))
+ (match lists
+ (((heads tails ...) ...)
+ (let ((tail (future (loop tails)))
+ (head (apply proc heads)))
+ (cons head (touch tail))))
+ (_
+ '())))))
+
+(define par-map (par-mapper map cons))
+(define par-for-each (par-mapper for-each (const *unspecified*)))
(define (n-par-map n proc . arglists)
(let* ((m (make-mutex))
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index a09b374..0c0906c 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -208,7 +208,7 @@
(make-vlist base 0))))))
(define (vlist-cons item vlist)
- "Return a new vlist with @var{item} as its head and @var{vlist} as its
+ "Return a new vlist with ITEM as its head and VLIST as its
tail."
;; Note: Although the result of `vlist-cons' on a vhash is a valid
;; vlist, it is not a valid vhash. The new item does not get a hash
@@ -219,14 +219,14 @@ tail."
(block-cons item vlist #f))
(define (vlist-head vlist)
- "Return the head of @var{vlist}."
+ "Return the head of VLIST."
(assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(block-ref (block-content base) offset)))
(define (vlist-tail vlist)
- "Return the tail of @var{vlist}."
+ "Return the tail of VLIST."
(assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
@@ -236,7 +236,7 @@ tail."
(block-offset base)))))
(define (vlist-null? vlist)
- "Return true if @var{vlist} is empty."
+ "Return true if VLIST is empty."
(assert-vlist vlist)
(let ((base (vlist-base vlist)))
(and (not (block-base base))
@@ -248,11 +248,11 @@ tail."
;;;
(define (list->vlist lst)
- "Return a new vlist whose contents correspond to @var{lst}."
+ "Return a new vlist whose contents correspond to LST."
(vlist-reverse (fold vlist-cons vlist-null lst)))
(define (vlist-fold proc init vlist)
- "Fold over @var{vlist}, calling @var{proc} for each element."
+ "Fold over VLIST, calling PROC for each element."
;; FIXME: Handle multiple lists.
(assert-vlist vlist)
(let loop ((base (vlist-base vlist))
@@ -267,7 +267,7 @@ tail."
(proc (block-ref (block-content base) offset) result))))))
(define (vlist-fold-right proc init vlist)
- "Fold over @var{vlist}, calling @var{proc} for each element, starting from
+ "Fold over VLIST, calling PROC for each element, starting from
the last element."
(assert-vlist vlist)
(let loop ((index (1- (vlist-length vlist)))
@@ -278,23 +278,23 @@ the last element."
(proc (vlist-ref vlist index) result)))))
(define (vlist-reverse vlist)
- "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
+ "Return a new VLIST whose content are those of VLIST in reverse
order."
(vlist-fold vlist-cons vlist-null vlist))
(define (vlist-map proc vlist)
- "Map @var{proc} over the elements of @var{vlist} and return a new vlist."
+ "Map PROC over the elements of VLIST and return a new vlist."
(vlist-fold (lambda (item result)
(vlist-cons (proc item) result))
vlist-null
(vlist-reverse vlist)))
(define (vlist->list vlist)
- "Return a new list whose contents match those of @var{vlist}."
+ "Return a new list whose contents match those of VLIST."
(vlist-fold-right cons '() vlist))
(define (vlist-ref vlist index)
- "Return the element at index @var{index} in @var{vlist}."
+ "Return the element at index INDEX in VLIST."
(assert-vlist vlist)
(let loop ((index index)
(base (vlist-base vlist))
@@ -306,8 +306,8 @@ order."
(block-offset base)))))
(define (vlist-drop vlist count)
- "Return a new vlist that does not contain the @var{count} first elements of
address@hidden"
+ "Return a new vlist that does not contain the COUNT first elements of
+VLIST."
(assert-vlist vlist)
(let loop ((count count)
(base (vlist-base vlist))
@@ -319,8 +319,8 @@ order."
(block-offset base)))))
(define (vlist-take vlist count)
- "Return a new vlist that contains only the @var{count} first elements of
address@hidden"
+ "Return a new vlist that contains only the COUNT first elements of
+VLIST."
(let loop ((count count)
(vlist vlist)
(result vlist-null))
@@ -331,8 +331,8 @@ order."
(vlist-cons (vlist-head vlist) result)))))
(define (vlist-filter pred vlist)
- "Return a new vlist containing all the elements from @var{vlist} that
-satisfy @var{pred}."
+ "Return a new vlist containing all the elements from VLIST that
+satisfy PRED."
(vlist-fold-right (lambda (e v)
(if (pred e)
(vlist-cons e v)
@@ -341,14 +341,14 @@ satisfy @var{pred}."
vlist))
(define* (vlist-delete x vlist #:optional (equal? equal?))
- "Return a new vlist corresponding to @var{vlist} without the elements
address@hidden to @var{x}."
+ "Return a new vlist corresponding to VLIST without the elements
+EQUAL? to X."
(vlist-filter (lambda (e)
(not (equal? e x)))
vlist))
(define (vlist-length vlist)
- "Return the length of @var{vlist}."
+ "Return the length of VLIST."
(assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(len (vlist-offset vlist)))
@@ -387,7 +387,7 @@ details."
vlists)))
(define (vlist-for-each proc vlist)
- "Call @var{proc} on each element of @var{vlist}. The result is unspecified."
+ "Call PROC on each element of VLIST. The result is unspecified."
(vlist-fold (lambda (item x)
(proc item))
(if #f #f)
@@ -442,13 +442,13 @@ details."
;; pass a hash function or equality predicate.
(define (vhash? obj)
- "Return true if @var{obj} is a hash list."
+ "Return true if OBJ is a hash list."
(and (vlist? obj)
(block-hash-table? (vlist-base obj))))
(define* (vhash-cons key value vhash #:optional (hash hash))
- "Return a new hash list based on @var{vhash} where @var{key} is associated
-with @var{value}. Use @var{hash} to compute @var{key}'s hash."
+ "Return a new hash list based on VHASH where KEY is associated
+with VALUE. Use HASH to compute KEY's hash."
(assert-vlist vhash)
;; We should also assert that it is a hash table. Need to check the
;; performance impacts of that. Also, vlist-null is a valid hash
@@ -493,18 +493,18 @@ with @var{value}. Use @var{hash} to compute @var{key}'s
hash."
(define* (vhash-fold* proc init key vhash
#:optional (equal? equal?) (hash hash))
- "Fold over all the values associated with @var{key} in @var{vhash}, with each
-call to @var{proc} having the form @code{(proc value result)}, where
address@hidden is the result of the previous call to @var{proc} and @var{init}
the
-value of @var{result} for the first call to @var{proc}."
+ "Fold over all the values associated with KEY in VHASH, with each
+call to PROC having the form â(proc value result)â, where
+RESULT is the result of the previous call to PROC and INIT the
+value of RESULT for the first call to PROC."
(%vhash-fold* proc init key vhash equal? hash))
(define (vhash-foldq* proc init key vhash)
- "Same as @code{vhash-fold*}, but using @code{hashq} and @code{eq?}."
+ "Same as âvhash-fold*â, but using âhashqâ and âeq?â."
(%vhash-fold* proc init key vhash eq? hashq))
(define (vhash-foldv* proc init key vhash)
- "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
+ "Same as âvhash-fold*â, but using âhashvâ and âeqv?â."
(%vhash-fold* proc init key vhash eqv? hashv))
(define-inlinable (%vhash-assoc key vhash equal? hash)
@@ -532,23 +532,23 @@ value of @var{result} for the first call to @var{proc}."
(vlist-offset vhash))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
- "Return the first key/value pair from @var{vhash} whose key is equal to
address@hidden according to the @var{equal?} equality predicate."
+ "Return the first key/value pair from VHASH whose key is equal to
+KEY according to the EQUAL? equality predicate."
(%vhash-assoc key vhash equal? hash))
(define (vhash-assq key vhash)
- "Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
address@hidden"
+ "Return the first key/value pair from VHASH whose key is âeq?â to
+KEY."
(%vhash-assoc key vhash eq? hashq))
(define (vhash-assv key vhash)
- "Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
address@hidden"
+ "Return the first key/value pair from VHASH whose key is âeqv?â to
+KEY."
(%vhash-assoc key vhash eqv? hashv))
(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
- "Remove all associations from @var{vhash} with @var{key}, comparing keys
-with @var{equal?}."
+ "Remove all associations from VHASH with KEY, comparing keys
+with EQUAL?."
(if (vhash-assoc key vhash equal? hash)
(vlist-fold (lambda (k+v result)
(let ((k (car k+v))
@@ -564,10 +564,10 @@ with @var{equal?}."
(define vhash-delv (cut vhash-delete <> <> eqv? hashv))
(define (vhash-fold proc init vhash)
- "Fold over the key/pair elements of @var{vhash} from left to right, with
-each call to @var{proc} having the form @code{(@var{proc} key value result)},
-where @var{result} is the result of the previous call to @var{proc} and
address@hidden the value of @var{result} for the first call to @var{proc}."
+ "Fold over the key/pair elements of VHASH from left to right, with
+each call to PROC having the form â(PROC key value result)â,
+where RESULT is the result of the previous call to PROC and
+INIT the value of RESULT for the first call to PROC."
(vlist-fold (lambda (key+value result)
(proc (car key+value) (cdr key+value)
result))
@@ -575,10 +575,10 @@ where @var{result} is the result of the previous call to
@var{proc} and
vhash))
(define (vhash-fold-right proc init vhash)
- "Fold over the key/pair elements of @var{vhash} from right to left, with
-each call to @var{proc} having the form @code{(@var{proc} key value result)},
-where @var{result} is the result of the previous call to @var{proc} and
address@hidden the value of @var{result} for the first call to @var{proc}."
+ "Fold over the key/pair elements of VHASH from right to left, with
+each call to PROC having the form â(PROC key value result)â,
+where RESULT is the result of the previous call to PROC and
+INIT the value of RESULT for the first call to PROC."
(vlist-fold-right (lambda (key+value result)
(proc (car key+value) (cdr key+value)
result))
@@ -586,7 +586,7 @@ where @var{result} is the result of the previous call to
@var{proc} and
vhash))
(define* (alist->vhash alist #:optional (hash hash))
- "Return the vhash corresponding to @var{alist}, an association list."
+ "Return the vhash corresponding to ALIST, an association list."
(fold-right (lambda (pair result)
(vhash-cons (car pair) (cdr pair) result hash))
vlist-null
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 40f6419..f8fd1cd 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -324,10 +324,11 @@
(and (< n env-len)
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
- (and (unroll db m (- db-len db-len*))
- (if (and (= h h*) (tree-il=? exp* exp))
- (make-lexical-ref (tree-il-src exp) name sym)
- (lp (1+ n) (- db-len db-len*))))))))))))
+ (let ((niter (- (- db-len db-len*) m)))
+ (and (unroll db m niter)
+ (if (and (= h h*) (tree-il=? exp* exp))
+ (make-lexical-ref (tree-il-src exp) name sym)
+ (lp (1+ n) (- db-len db-len*)))))))))))))
(define (lookup-lexical sym env)
(let ((env-len (vlist-length env)))
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 499a224..9fedac0 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -73,7 +73,7 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (rename (except (guile) error raise map)
+ (import (rename (except (guile) error raise map string-for-each)
(log log-internal)
(euclidean-quotient div)
(euclidean-remainder mod)
@@ -86,6 +86,43 @@
(inexact->exact exact))
(srfi srfi-11))
+ (define string-for-each
+ (case-lambda
+ ((proc string)
+ (let ((end (string-length string)))
+ (let loop ((i 0))
+ (unless (= i end)
+ (proc (string-ref string i))
+ (loop (+ i 1))))))
+ ((proc string1 string2)
+ (let ((end1 (string-length string1))
+ (end2 (string-length string2)))
+ (unless (= end1 end2)
+ (assertion-violation 'string-for-each
+ "string arguments must all have the same length"
+ string1 string2))
+ (let loop ((i 0))
+ (unless (= i end1)
+ (proc (string-ref string1 i)
+ (string-ref string2 i))
+ (loop (+ i 1))))))
+ ((proc string . strings)
+ (let ((end (string-length string))
+ (ends (map string-length strings)))
+ (for-each (lambda (x)
+ (unless (= end x)
+ (apply assertion-violation
+ 'string-for-each
+ "string arguments must all have the same length"
+ string strings)))
+ ends)
+ (let loop ((i 0))
+ (unless (= i end)
+ (apply proc
+ (string-ref string i)
+ (map (lambda (s) (string-ref s i)) strings))
+ (loop (+ i 1))))))))
+
(define map
(case-lambda
((f l)
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index eb35064..219bcde 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -30,9 +30,9 @@
set-field
set-fields))
-(define (set-record-type-printer! type thunk)
- "Set a custom printer THUNK for TYPE."
- (struct-set! type vtable-index-printer thunk))
+(define (set-record-type-printer! type proc)
+ "Set PROC as the custom printer for TYPE."
+ (struct-set! type vtable-index-printer proc))
(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
((@@ (srfi srfi-9) %define-record-type)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 346ba99..3f3e785 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -119,6 +119,11 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
((thunk? prompt) (lambda (repl) (prompt)))
((procedure? prompt) prompt)
(else (error "Invalid prompt" prompt)))))
+ (print #f ,(lambda (print)
+ (cond
+ ((not print) #f)
+ ((procedure? print) print)
+ (else (error "Invalid print procedure" print)))))
(value-history
,(value-history-enabled?)
,(lambda (x)
@@ -209,12 +214,16 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
(if (not (eq? val *unspecified*))
(begin
(run-hook before-print-hook val)
- ;; The result of an evaluation is representable in scheme, and
- ;; should be printed with the generic printer, `write'. The
- ;; language-printer is something else: it prints expressions of
- ;; a given language, not the result of evaluation.
- (write val)
- (newline))))
+ (cond
+ ((repl-option-ref repl 'print)
+ => (lambda (print) (print repl val)))
+ (else
+ ;; The result of an evaluation is representable in scheme, and
+ ;; should be printed with the generic printer, `write'. The
+ ;; language-printer is something else: it prints expressions of
+ ;; a given language, not the result of evaluation.
+ (write val)
+ (newline))))))
(define (repl-option-ref repl key)
(cadr (or (assq key (repl-options repl))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 02d5ec4..1d01001 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -1,6 +1,6 @@
;;; Guile VM program functions
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -227,7 +227,7 @@
rest? rest (1+ n)))
(rest?
(lp nreq req nopt opt
- #f (var-by-index n)
+ #f (var-by-index (+ n (length (arity:kw arity))))
(1+ n)))
(else
`((required . ,(reverse req))
@@ -238,11 +238,13 @@
;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip)
+ "Returns the signature of the given procedure in the form of an association
list."
(let ((arity (program-arity prog ip)))
(and arity
(arity->arguments-alist prog arity))))
(define* (program-lambda-list prog #:optional ip)
+ "Returns the signature of the given procedure in the form of an argument
list."
(and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
(define (arguments-alist->lambda-list arguments-alist)
diff --git a/module/web/client.scm b/module/web/client.scm
index cf7ea53..6aedb75 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -38,26 +38,30 @@
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
+ #:use-module (srfi srfi-1)
#:export (open-socket-for-uri
- http-get))
+ http-get
+ http-get*))
(define (open-socket-for-uri uri)
"Return an open input/output port for a connection to URI."
(define addresses
(let ((port (uri-port uri)))
- (getaddrinfo (uri-host uri)
- (cond (port => number->string)
- (else (symbol->string (uri-scheme uri))))
- (if port
- AI_NUMERICSERV
- 0))))
+ (delete-duplicates
+ (getaddrinfo (uri-host uri)
+ (cond (port => number->string)
+ (else (symbol->string (uri-scheme uri))))
+ (if port
+ AI_NUMERICSERV
+ 0))
+ (lambda (ai1 ai2)
+ (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))
(let loop ((addresses addresses))
(let* ((ai (car addresses))
- (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
- (addrinfo:protocol ai))))
- (set-port-encoding! s "ISO-8859-1")
-
+ (s (with-fluids ((%default-port-encoding #f))
+ ;; Restrict ourselves to TCP.
+ (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
(catch 'system-error
(lambda ()
(connect s (addrinfo:addr ai))
@@ -70,7 +74,7 @@
(lambda args
;; Connection failed, so try one of the other addresses.
(close s)
- (if (null? addresses)
+ (if (null? (cdr addresses))
(apply throw args)
(loop (cdr addresses))))))))
@@ -83,12 +87,6 @@
(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)
@@ -104,7 +102,7 @@
((response-content-type response)
=> (lambda (type)
(cond
- ((text-type? (car type))
+ ((text-content-type? (car type))
(decode-string body (or (assq-ref (cdr type) 'charset)
"iso-8859-1")))
(else body))))
@@ -115,6 +113,15 @@
(define* (http-get uri #:key (port (open-socket-for-uri uri))
(version '(1 . 1)) (keep-alive? #f) (extra-headers '())
(decode-body? #t))
+ "Connect to the server corresponding to URI and ask for the
+resource, using the âGETâ method. If you already have a port open,
+pass it as PORT. The port will be closed at the end of the
+request unless KEEP-ALIVE? is true. Any extra headers in the
+alist EXTRA-HEADERS will be added to the request.
+
+If DECODE-BODY? is true, as is the default, the body of the
+response will be decoded to string, if it is a textual content-type.
+Otherwise it will be returned as a bytevector."
(let ((req (build-request uri #:version version
#:headers (if keep-alive?
extra-headers
@@ -132,3 +139,25 @@
(if decode-body?
(decode-response-body res body)
body)))))
+
+(define* (http-get* uri #:key (port (open-socket-for-uri uri))
+ (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
+ (decode-body? #t))
+ "Like âhttp-getâ, but return an input port from which to read. When
+DECODE-BODY? is true, as is the default, the returned port has its
+encoding set appropriately if the data at URI is textual. Closing the
+returned port closes PORT, unless KEEP-ALIVE? is true."
+ (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)
+ (unless keep-alive?
+ (shutdown port 1))
+ (let* ((res (read-response port))
+ (body (response-body-port res
+ #:keep-alive? keep-alive?
+ #:decode? decode-body?)))
+ (values res body))))
diff --git a/module/web/http.scm b/module/web/http.scm
index cc5dd5a..216fddd 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -77,7 +77,7 @@
(define (string->header name)
- "Parse @var{name} to a symbolic header name."
+ "Parse NAME to a symbolic header name."
(string->symbol (string-downcase name)))
(define-record-type <header-decl>
@@ -100,12 +100,7 @@
validator
writer
#:key multiple?)
- "Define a parser, validator, and writer for the HTTP header, @var{name}.
-
address@hidden should be a procedure that takes a string and returns a
-Scheme value. @var{validator} is a predicate for whether the given
-Scheme value is valid for this header. @var{writer} takes a value and a
-port, and writes the value to the port."
+ "Declare a parser, validator, and writer for a given header."
(if (and (string? name) parser validator writer)
(let ((decl (make-header-decl name parser validator writer multiple?)))
(hashq-set! *declared-headers* (string->header name) decl)
@@ -113,34 +108,40 @@ port, and writes the value to the port."
(error "bad header decl" name parser validator writer multiple?)))
(define (header->string sym)
- "Return the string form for the header named @var{sym}."
+ "Return the string form for the header named SYM."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-name decl)
(string-titlecase (symbol->string sym)))))
(define (known-header? sym)
- "Return @code{#t} if there are parsers and writers registered for this
-header, otherwise @code{#f}."
+ "Return â#tâ iff SYM is a known header, with associated
+parsers and serialization procedures."
(and (lookup-header-decl sym) #t))
(define (header-parser sym)
- "Returns a procedure to parse values for the given header."
+ "Return the value parser for headers named SYM. The result is a
+procedure that takes one argument, a string, and returns the parsed
+value. If the header isn't known to Guile, a default parser is returned
+that passes through the string unchanged."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-parser decl)
(lambda (x) x))))
(define (header-validator sym)
- "Returns a procedure to validate values for the given header."
+ "Return a predicate which returns â#tâ if the given value is valid
+for headers named SYM. The default validator for unknown headers
+is âstring?â."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-validator decl)
string?)))
(define (header-writer sym)
- "Returns a procedure to write values for the given header to a given
-port."
+ "Return a procedure that writes values for headers named SYM to a
+port. The resulting procedure takes two arguments: a value and a port.
+The default writer is âdisplayâ."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-writer decl)
@@ -173,7 +174,7 @@ port."
(define *eof* (call-with-input-string "" read))
(define (read-header port)
- "Reads one HTTP header from @var{port}. Returns two values: the header
+ "Reads one HTTP header from PORT. Returns two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.
@@ -195,32 +196,28 @@ body was reached (i.e., a blank line)."
(string-trim-both line char-set:whitespace (1+ delim)))))))))
(define (parse-header sym val)
- "Parse @var{val}, a string, with the parser registered for the header
-named @var{sym}.
-
-Returns the parsed value. If a parser was not found, the value is
-returned as a string."
+ "Parse VAL, a string, with the parser registered for the header
+named SYM. Returns the parsed value."
((header-parser sym) val))
(define (valid-header? sym val)
- "Returns a true value iff @var{val} is a valid Scheme value for the
-header with name @var{sym}."
+ "Returns a true value iff VAL is a valid Scheme value for the
+header with name SYM."
(if (symbol? sym)
((header-validator sym) val)
(error "header name not a symbol" sym)))
(define (write-header sym val port)
- "Writes the given header name and value to @var{port}. If @var{sym}
-is a known header, uses the specific writer registered for that header.
-Otherwise the value is written using @code{display}."
+ "Write the given header name and value to PORT, using the writer
+from âheader-writerâ."
(display (header->string sym) port)
(display ": " port)
((header-writer sym) val port)
(display "\r\n" port))
(define (read-headers port)
- "Read an HTTP message from @var{port}, returning the headers as an
-ordered alist."
+ "Read the headers of an HTTP message from PORT, returning them
+as an ordered alist."
(let lp ((headers '()))
(call-with-values (lambda () (read-header port))
(lambda (k v)
@@ -229,8 +226,8 @@ ordered alist."
(lp (acons k v headers)))))))
(define (write-headers headers port)
- "Write the given header alist to @var{port}. Doesn't write the final
-\\r\\n, as the user might want to add another header."
+ "Write the given header alist to PORT. Doesn't write the final
address@hidden, as the user might want to add another header."
(let lp ((headers headers))
(if (pair? headers)
(begin
@@ -981,9 +978,9 @@ ordered alist."
(define *known-versions* '())
(define* (parse-http-version str #:optional (start 0) (end (string-length
str)))
- "Parse an HTTP version from @var{str}, returning it as a major-minor
-pair. For example, @code{HTTP/1.1} parses as the pair of integers,
address@hidden(1 . 1)}."
+ "Parse an HTTP version from STR, returning it as a major-minor
+pair. For example, âHTTP/1.1â parses as the pair of integers,
+â(1 . 1)â."
(or (let lp ((known *known-versions*))
(and (pair? known)
(if (string= str (caar known) start end)
@@ -998,7 +995,7 @@ pair. For example, @code{HTTP/1.1} parses as the pair of
integers,
(bad-header-component 'http-version (substring str start end))))))
(define (write-http-version val port)
- "Write the given major-minor version pair to @var{port}."
+ "Write the given major-minor version pair to PORT."
(display "HTTP/" port)
(display (car val) port)
(display #\. port)
@@ -1019,8 +1016,8 @@ pair. For example, @code{HTTP/1.1} parses as the pair of
integers,
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP method from @var{str}. The result is an upper-case
-symbol, like @code{GET}."
+ "Parse an HTTP method from STR. The result is an upper-case
+symbol, like âGETâ."
(cond
((string= str "GET" start end) 'GET)
((string= str "HEAD" start end) 'HEAD)
@@ -1052,7 +1049,7 @@ not have to have a scheme or host name. The result is a
URI object."
(bad-request "Invalid URI: ~a" (substring str start end))))))
(define (read-request-line port)
- "Read the first line of an HTTP request from @var{port}, returning
+ "Read the first line of an HTTP request from PORT, returning
three values: the method, the URI, and the version."
(let* ((line (read-line* port))
(d0 (string-index line char-set:whitespace)) ; "delimiter zero"
@@ -1093,7 +1090,7 @@ three values: the method, the URI, and the version."
(display (uri-query uri) port))))
(define (write-request-line method uri version port)
- "Write the first line of an HTTP request to @var{port}."
+ "Write the first line of an HTTP request to PORT."
(display method port)
(display #\space port)
(let ((path (uri-path uri))
@@ -1113,7 +1110,7 @@ three values: the method, the URI, and the version."
(display "\r\n" port))
(define (read-response-line port)
- "Read the first line of an HTTP response from @var{port}, returning
+ "Read the first line of an HTTP response from PORT, returning
three values: the HTTP version, the response code, and the \"reason
phrase\"."
(let* ((line (read-line* port))
@@ -1128,7 +1125,7 @@ phrase\"."
(bad-response "Bad Response-Line: ~s" line))))
(define (write-response-line version code reason-phrase port)
- "Write the first line of an HTTP response to @var{port}."
+ "Write the first line of an HTTP response to PORT."
(write-http-version version port)
(display #\space port)
(display code port)
@@ -1185,6 +1182,15 @@ treated specially, and is just returned as a plain
string."
(define (declare-uri-header! name)
(declare-header! name
(lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
+ (@@ (web uri) absolute-uri?)
+ write-uri))
+
+;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
+(define (declare-relative-uri-header! name)
+ (declare-header! name
+ (lambda (str)
+ (or ((@@ (web uri) string->uri*) str)
+ (bad-header-component 'uri str)))
uri?
write-uri))
@@ -1440,7 +1446,7 @@ treated specially, and is just returned as a plain
string."
;; Content-Location = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Content-Location")
+(declare-relative-uri-header! "Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
@@ -1729,7 +1735,7 @@ treated specially, and is just returned as a plain
string."
;; Referer = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Referer")
+(declare-relative-uri-header! "Referer")
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
@@ -1833,10 +1839,10 @@ treated specially, and is just returned as a plain
string."
(define* (make-chunked-input-port port #:key (keep-alive? #f))
"Returns a new port which translates HTTP chunked transfer encoded
-data from @var{port} into a non-encoded format. Returns eof when it has
-read the final chunk from @var{port}. This does not necessarily mean
-that there is no more data on @var{port}. When the returned port is
-closed it will also close @var{port}, unless the KEEP-ALIVE? is true."
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
(define (next-chunk)
(read-chunk port))
(define finished? #f)
@@ -1872,11 +1878,11 @@ closed it will also close @var{port}, unless the
KEEP-ALIVE? is true."
(define* (make-chunked-output-port port #:key (keep-alive? #f))
"Returns a new port which translates non-encoded data into a HTTP
-chunked transfer encoded data and writes this to @var{port}. Data
+chunked transfer encoded data and writes this to PORT. Data
written to this port is buffered until the port is flushed, at which
point it is all sent as one chunk. Take care to close the port when
done, as it will output the remaining data, and encode the final zero
-chunk. When the port is closed it will also close @var{port}, unless
+chunk. When the port is closed it will also close PORT, unless
KEEP-ALIVE? is true."
(define (q-for-each f q)
(while (not (q-empty? q))
diff --git a/module/web/request.scm b/module/web/request.scm
index 40d4a66..7ced076 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -160,7 +160,7 @@
(define* (build-request uri #:key (method 'GET) (version '(1 . 1))
(headers '()) port (meta '())
(validate-headers? #t))
- "Construct an HTTP request object. If @var{validate-headers?} is true,
+ "Construct an HTTP request object. If VALIDATE-HEADERS? is true,
the headers are each run through their respective validators."
(let ((needs-host? (and (equal? version '(1 . 1))
(not (assq-ref headers 'host)))))
@@ -189,13 +189,17 @@ the headers are each run through their respective
validators."
meta port)))
(define* (read-request port #:optional (meta '()))
- "Read an HTTP request from @var{port}, optionally attaching the given
-metadata, @var{meta}.
+ "Read an HTTP request from PORT, optionally attaching the given
+metadata, META.
-As a side effect, sets the encoding on @var{port} to
+As a side effect, sets the encoding on PORT to
ISO-8859-1 (latin-1), so that reading one character reads one byte. See
the discussion of character sets in \"HTTP Requests\" in the manual, for
-more information."
+more information.
+
+Note that the body is not part of the request. Once you have read a
+request, you may read the body separately, and likewise for writing
+requests."
(set-port-encoding! port "ISO-8859-1")
(call-with-values (lambda () (read-request-line port))
(lambda (method uri version)
@@ -203,10 +207,10 @@ more information."
;; FIXME: really return a new request?
(define (write-request r port)
- "Write the given HTTP request to @var{port}.
+ "Write the given HTTP request to PORT.
-Returns a new request, whose @code{request-port} will continue writing
-on @var{port}, perhaps using some transfer encoding."
+Return a new request, whose ârequest-portâ will continue writing
+on PORT, perhaps using some transfer encoding."
(write-request-line (request-method r) (request-uri r)
(request-version r) port)
(write-headers (request-headers r) port)
@@ -217,8 +221,8 @@ on @var{port}, perhaps using some transfer encoding."
(request-headers r) (request-meta r) port)))
(define (read-request-body r)
- "Reads the request body from @var{r}, as a bytevector. Returns
address@hidden if there was no request body."
+ "Reads the request body from R, as a bytevector. Return â#fâ
+if there was no request body."
(let ((nbytes (request-content-length r)))
(and nbytes
(let ((bv (get-bytevector-n (request-port r) nbytes)))
@@ -228,8 +232,8 @@ on @var{port}, perhaps using some transfer encoding."
(bytevector-length bv) nbytes))))))
(define (write-request-body r bv)
- "Write @var{bv}, a bytevector, to the port corresponding to the HTTP
-request @var{r}."
+ "Write BV, a bytevector, to the port corresponding to the HTTP
+request R."
(put-bytevector (request-port r) bv))
(define-syntax define-request-accessor
@@ -297,6 +301,8 @@ request @var{r}."
;; Misc accessors
(define* (request-absolute-uri r #:optional default-host default-port)
+ "A helper routine to determine the absolute URI of a request, using the
+âhostâ header and the default host and port."
(let ((uri (request-uri r)))
(if (uri-host uri)
uri
diff --git a/module/web/response.scm b/module/web/response.scm
index 6eba69d..5ca7274 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -23,6 +23,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (web http)
#:export (response?
@@ -37,6 +38,7 @@
write-response
response-must-not-include-body?
+ response-body-port
read-response-body
write-response-body
@@ -62,6 +64,7 @@
response-content-md5
response-content-range
response-content-type
+ text-content-type?
response-expires
response-last-modified
@@ -107,7 +110,7 @@
(define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase
(headers '()) port (validate-headers? #t))
- "Construct an HTTP response object. If @var{validate-headers?} is true,
+ "Construct an HTTP response object. If VALIDATE-HEADERS? is true,
the headers are each run through their respective validators."
(cond
((not (and (pair? version)
@@ -170,15 +173,23 @@ the headers are each run through their respective
validators."
"(Unknown)"))
(define (response-reason-phrase response)
- "Return the reason phrase given in @var{response}, or the standard
+ "Return the reason phrase given in RESPONSE, or the standard
reason phrase for the response's code."
(or (%response-reason-phrase response)
(code->reason-phrase (response-code response))))
+(define (text-content-type? type)
+ "Return #t if TYPE, a symbol as returned by `response-content-type',
+represents a textual type such as `text/plain'."
+ (let ((type (symbol->string type)))
+ (or (string-prefix? "text/" type)
+ (string-suffix? "/xml" type)
+ (string-suffix? "+xml" type))))
+
(define (read-response port)
- "Read an HTTP response from @var{port}.
+ "Read an HTTP response from PORT.
-As a side effect, sets the encoding on @var{port} to
+As a side effect, sets the encoding on PORT to
ISO-8859-1 (latin-1), so that reading one character reads one byte. See
the discussion of character sets in \"HTTP Responses\" in the manual,
for more information."
@@ -202,10 +213,10 @@ the version field."
#:port (response-port response)))
(define (write-response r port)
- "Write the given HTTP response to @var{port}.
+ "Write the given HTTP response to PORT.
-Returns a new response, whose @code{response-port} will continue writing
-on @var{port}, perhaps using some transfer encoding."
+Returns a new response, whose âresponse-portâ will continue writing
+on PORT, perhaps using some transfer encoding."
(write-response-line (response-version r) (response-code r)
(response-reason-phrase r) port)
(write-headers (response-headers r) port)
@@ -216,7 +227,7 @@ on @var{port}, perhaps using some transfer encoding."
(response-reason-phrase r) (response-headers r) port)))
(define (response-must-not-include-body? r)
- "Returns @code{#t} if the response @var{r} is not permitted to have a body.
+ "Returns â#tâ if the response R is not permitted to have a body.
This is true for some response types, like those with code 304."
;; RFC 2616, section 4.3.
@@ -224,24 +235,70 @@ This is true for some response types, like those with
code 304."
(= (response-code r) 204)
(= (response-code r) 304)))
+(define (make-delimited-input-port port len keep-alive?)
+ "Return an input port that reads from PORT, and makes sure that
+exactly LEN bytes are available from PORT. Closing the returned port
+closes PORT, unless KEEP-ALIVE? is true."
+ (define bytes-read 0)
+
+ (define (fail)
+ (bad-response "EOF while reading response body: ~a bytes of ~a"
+ bytes-read len))
+
+ (define (read! bv start count)
+ (let ((ret (get-bytevector-n! port bv start count)))
+ (if (eof-object? ret)
+ (if (= bytes-read len)
+ 0
+ (fail))
+ (begin
+ (set! bytes-read (+ bytes-read ret))
+ (if (> bytes-read len)
+ (fail)
+ ret)))))
+
+ (define close
+ (and (not keep-alive?)
+ (lambda ()
+ (close port))))
+
+ (make-custom-binary-input-port "delimited input port" read! #f #f close))
+
+(define* (response-body-port r #:key (decode? #t) (keep-alive? #t))
+ "Return an input port from which the body of R can be read. The
+encoding of the returned port is set according to R's âcontent-typeâ
+header, when it's textual, except if DECODE? is #f. Return #f when no
+body is available.
+
+When KEEP-ALIVE? is #f, closing the returned port also closes R's
+response port."
+ (define port
+ (if (member '(chunked) (response-transfer-encoding r))
+ (make-chunked-input-port (response-port r)
+ #:keep-alive? keep-alive?)
+ (let ((len (response-content-length r)))
+ (and len
+ (make-delimited-input-port (response-port r)
+ len keep-alive?)))))
+
+ (when (and decode? port)
+ (match (response-content-type r)
+ (((? text-content-type?) . props)
+ (set-port-encoding! port
+ (or (assq-ref props 'charset)
+ "ISO-8859-1")))
+ (_ #f)))
+
+ port)
+
(define (read-response-body r)
- "Reads the response body from @var{r}, as a bytevector. Returns
address@hidden if there was no response body."
- (if (member '(chunked) (response-transfer-encoding r))
- (let ((chunk-port (make-chunked-input-port (response-port r)
- #:keep-alive? #t)))
- (get-bytevector-all chunk-port))
- (let ((nbytes (response-content-length r)))
- (and nbytes
- (let ((bv (get-bytevector-n (response-port r) nbytes)))
- (if (= (bytevector-length bv) nbytes)
- bv
- (bad-response "EOF while reading response body: ~a bytes of
~a"
- (bytevector-length bv) nbytes)))))))
+ "Reads the response body from R, as a bytevector. Returns
+â#fâ if there was no response body."
+ (and=> (response-body-port r #:decode? #f) get-bytevector-all))
(define (write-response-body r bv)
- "Write @var{bv}, a bytevector, to the port corresponding to the HTTP
-response @var{r}."
+ "Write BV, a bytevector, to the port corresponding to the HTTP
+response R."
(put-bytevector (response-port r) bv))
(define-syntax define-response-accessor
diff --git a/module/web/server.scm b/module/web/server.scm
index fbd5d95..0e34179 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -123,14 +123,14 @@
(make-server-impl 'name open read write close)))
(define (lookup-server-impl impl)
- "Look up a server implementation. If @var{impl} is a server
+ "Look up a server implementation. If IMPL is a server
implementation already, it is returned directly. If it is a symbol, the
-binding named @var{impl} in the @code{(web server @var{impl})} module is
+binding named IMPL in the â(web server IMPL)â module is
looked up. Otherwise an error is signaled.
Currently a server implementation is a somewhat opaque type, useful only
for passing to other procedures in this module, like
address@hidden"
+âread-clientâ."
(cond
((server-impl? impl) impl)
((symbol? impl)
@@ -143,17 +143,17 @@ for passing to other procedures in this module, like
;; -> server
(define (open-server impl open-params)
- "Open a server for the given implementation. Returns one value, the
-new server object. The implementation's @code{open} procedure is
-applied to @var{open-params}, which should be a list."
+ "Open a server for the given implementation. Return one value, the
+new server object. The implementation's âopenâ procedure is
+applied to OPEN-PARAMS, which should be a list."
(apply (server-impl-open impl) open-params))
;; -> (client request body | #f #f #f)
(define (read-client impl server)
- "Read a new client from @var{server}, by applying the implementation's
address@hidden procedure to the server. If successful, returns three
+ "Read a new client from SERVER, by applying the implementation's
+âreadâ procedure to the server. If successful, return three
values: an object corresponding to the client, a request object, and the
-request body. If any exception occurs, returns @code{#f} for all three
+request body. If any exception occurs, return â#fâ for all three
values."
(call-with-error-handling
(lambda ()
@@ -215,14 +215,14 @@ values."
"\"Sanitize\" the given response and body, making them appropriate for
the given request.
-As a convenience to web handler authors, @var{response} may be given as
+As a convenience to web handler authors, RESPONSE may be given as
an alist of headers, in which case it is used to construct a default
response. Ensures that the response version corresponds to the request
-version. If @var{body} is a string, encodes the string to a bytevector,
-in an encoding appropriate for @var{response}. Adds a
address@hidden and @code{content-type} header, as necessary.
+version. If BODY is a string, encodes the string to a bytevector,
+in an encoding appropriate for RESPONSE. Adds a
+âcontent-lengthâ and âcontent-typeâ header, as necessary.
-If @var{body} is a procedure, it is called with a port as an argument,
+If BODY is a procedure, it is called with a port as an argument,
and the output collected as a bytevector. In the future we might try to
instead use a compressing, chunk-encoded port, and call this procedure
later, in the write-client procedure. Authors are advised not to rely
@@ -292,11 +292,11 @@ on the procedure being called at any particular time."
"Handle a given request, returning the response and body.
The response and response body are produced by calling the given
address@hidden with @var{request} and @var{body} as arguments.
+HANDLER with REQUEST and BODY as arguments.
-The elements of @var{state} are also passed to @var{handler} as
+The elements of STATE are also passed to HANDLER as
arguments, and may be returned as additional values. The new
address@hidden, collected from the @var{handler}'s return values, is then
+STATE, collected from the HANDLER's return values, is then
returned as a list. The idea is that a server loop receives a handler
from the user, along with whatever state values the user is interested
in, allowing the user's handler to explicitly manage its state."
@@ -320,10 +320,10 @@ in, allowing the user's handler to explicitly manage its
state."
;; -> unspecified values
(define (write-client impl server client response body)
- "Write an HTTP response and body to @var{client}. If the server and
+ "Write an HTTP response and body to CLIENT. If the server and
client support persistent connections, it is the implementation's
responsibility to keep track of the client thereafter, presumably by
-attaching it to the @var{server} argument somehow."
+attaching it to the SERVER argument somehow."
(call-with-error-handling
(lambda ()
((server-impl-write impl) server client response body))
@@ -334,7 +334,7 @@ attaching it to the @var{server} argument somehow."
;; -> unspecified values
(define (close-server impl server)
"Release resources allocated by a previous invocation of
address@hidden"
+âopen-serverâ."
((server-impl-close impl) server))
(define call-with-sigint
@@ -365,8 +365,8 @@ attaching it to the @var{server} argument somehow."
;; -> new-state
(define (serve-one-client handler impl server state)
- "Read one request from @var{server}, call @var{handler} on the request
-and body, and write the response to the client. Returns the new state
+ "Read one request from SERVER, call HANDLER on the request
+and body, and write the response to the client. Return the new state
produced by the handler procedure."
(debug-elapsed 'serve-again)
(call-with-values
@@ -389,7 +389,7 @@ produced by the handler procedure."
. state)
"Run Guile's built-in web server.
address@hidden should be a procedure that takes two or more arguments,
+HANDLER should be a procedure that takes two or more arguments,
the HTTP request and request body, and returns two or more values, the
response and response body.
@@ -402,16 +402,16 @@ For example, here is a simple \"Hello, World!\" server:
(run-server handler)
@end example
-The response and body will be run through @code{sanitize-response}
+The response and body will be run through âsanitize-responseâ
before sending back to the client.
-Additional arguments to @var{handler} are taken from
address@hidden Additional return values are accumulated into a new
address@hidden, which will be used for subsequent requests. In this way a
+Additional arguments to HANDLER are taken from
+STATE. Additional return values are accumulated into a new
+STATE, which will be used for subsequent requests. In this way a
handler can explicitly manage its state.
-The default server implementation is @code{http}, which accepts
address@hidden like @code{(#:port 8081)}, among others. See \"Web
+The default server implementation is âhttpâ, which accepts
+OPEN-PARAMS like â(#:port 8081)â, among others. See \"Web
Server\" in the manual, for more information."
(let* ((impl (lookup-server-impl impl))
(server (open-server impl open-params)))
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 78614a5..b688ea8 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -53,6 +53,9 @@
(query uri-query)
(fragment uri-fragment))
+(define (absolute-uri? x)
+ (and (uri? x) (uri-scheme x) #t))
+
(define (uri-error message . args)
(throw 'uri-error message args))
@@ -79,8 +82,11 @@
(define* (build-uri scheme #:key userinfo host port (path "") query fragment
(validate? #t))
- "Construct a URI object. If @var{validate?} is true, also run some
-consistency checks to make sure that the constructed URI is valid."
+ "Construct a URI object. SCHEME should be a symbol, PORT
+either a positive, exact integer or â#fâ, and the rest of the
+fields are either strings or â#fâ. If VALIDATE? is true,
+also run some consistency checks to make sure that the constructed URI
+is valid."
(if validate?
(validate-uri scheme userinfo host port path query fragment))
(make-uri scheme userinfo host port path query fragment))
@@ -162,21 +168,21 @@ consistency checks to make sure that the constructed URI
is valid."
(define fragment-pat
".*")
(define uri-pat
- (format #f "^(~a):(//~a)?(~a)(\\?(~a))?(#(~a))?$"
+ (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$"
scheme-pat authority-pat path-pat query-pat fragment-pat))
(define uri-regexp
(make-regexp uri-pat))
-(define (string->uri string)
- "Parse @var{string} into a URI object. Returns @code{#f} if the string
+(define (string->uri* string)
+ "Parse STRING into a URI object. Return â#fâ if the string
could not be parsed."
(% (let ((m (regexp-exec uri-regexp string)))
(if (not m) (abort))
- (let ((scheme (string->symbol
- (string-downcase (match:substring m 1))))
- (authority (match:substring m 2))
- (path (match:substring m 3))
- (query (match:substring m 5))
+ (let ((scheme (let ((str (match:substring m 2)))
+ (and str (string->symbol (string-downcase str)))))
+ (authority (match:substring m 3))
+ (path (match:substring m 4))
+ (query (match:substring m 6))
(fragment (match:substring m 7)))
(call-with-values
(lambda ()
@@ -188,13 +194,16 @@ could not be parsed."
(lambda (k)
#f)))
+(define (string->uri string)
+ "Parse STRING into a URI object. Return â#fâ if the string
+could not be parsed."
+ (let ((uri (string->uri* string)))
+ (and uri (uri-scheme uri) uri)))
+
(define *default-ports* (make-hash-table))
(define (declare-default-port! scheme port)
- "Declare a default port for the given URI scheme.
-
-Default ports are for printing URI objects: a default port is not
-printed."
+ "Declare a default port for the given URI scheme."
(hashq-set! *default-ports* scheme port))
(define (default-port? scheme port)
@@ -205,9 +214,10 @@ printed."
(declare-default-port! 'https 443)
(define (uri->string uri)
- "Serialize @var{uri} to a string."
- (let* ((scheme-str (string-append
- (symbol->string (uri-scheme uri)) ":"))
+ "Serialize URI to a string. If the URI has a port that is the
+default port for its scheme, the port is not included in the
+serialization."
+ (let* ((scheme (uri-scheme uri))
(userinfo (uri-userinfo uri))
(host (uri-host uri))
(port (uri-port uri))
@@ -215,7 +225,9 @@ printed."
(query (uri-query uri))
(fragment (uri-fragment uri)))
(string-append
- scheme-str
+ (if scheme
+ (string-append (symbol->string scheme) ":")
+ "")
(if host
(string-append "//"
(if userinfo (string-append userinfo "@")
@@ -285,26 +297,32 @@ printed."
;; characters in other character sets.
;;
-;; Return a new string made from uri-decoding @var{str}. Specifically,
-;; turn @code{+} into space, and hex-encoded @code{%XX} strings into
+;; Return a new string made from uri-decoding STR. Specifically,
+;; turn â+â into space, and hex-encoded â%XXâ strings into
;; their eight-bit characters.
;;
(define hex-chars
(string->char-set "0123456789abcdefABCDEF"))
(define* (uri-decode str #:key (encoding "utf-8"))
- "Percent-decode the given @var{str}, according to @var{encoding}.
+ "Percent-decode the given STR, according to ENCODING,
+which should be the name of a character encoding.
Note that this function should not generally be applied to a full URI
string. For paths, use split-and-decode-uri-path instead. For query
-strings, split the query on @code{&} and @code{=} boundaries, and decode
+strings, split the query on â&â and â=â boundaries, and decode
the components separately.
-Note that percent-encoded strings encode @emph{bytes}, not characters.
-There is no guarantee that a given byte sequence is a valid string
-encoding. Therefore this routine may signal an error if the decoded
-bytes are not valid for the given encoding. Pass @code{#f} for
address@hidden if you want decoded bytes as a bytevector directly."
+Note also that percent-encoded strings encode @emph{bytes}, not
+characters. There is no guarantee that a given byte sequence is a valid
+string encoding. Therefore this routine may signal an error if the
+decoded bytes are not valid for the given encoding. Pass â#fâ for
+ENCODING if you want decoded bytes as a bytevector directly.
address@hidden, âset-port-encoding!â}, for more information on
+character encodings.
+
+Returns a string of the decoded characters, or a bytevector if
+ENCODING was â#fâ."
(let* ((len (string-length str))
(bv
(call-with-output-bytevector*
@@ -353,16 +371,19 @@ bytes are not valid for the given encoding. Pass
@code{#f} for
(char-set-union ascii-alnum-chars
(string->char-set "-._~")))
-;; Return a new string made from uri-encoding @var{str}, unconditionally
-;; transforming any characters not in @var{unescaped-chars}.
+;; Return a new string made from uri-encoding STR, unconditionally
+;; transforming any characters not in UNESCAPED-CHARS.
;;
(define* (uri-encode str #:key (encoding "utf-8")
(unescaped-chars unreserved-chars))
- "Percent-encode any character not in the character set,
@var{unescaped-chars}.
-
-Percent-encoding first writes out the given character to a bytevector
-within the given @var{encoding}, then encodes each byte as
address@hidden@var{HH}}, where @var{HH} is the hexadecimal representation of
+ "Percent-encode any character not in the character set,
+UNESCAPED-CHARS.
+
+The default character set includes alphanumerics from ASCII, as well as
+the special characters @samp{-}, @samp{.}, @samp{_}, and @samp{~}. Any
+other character will be percent-encoded, by writing out the character to
+a bytevector within the given ENCODING, then encoding each byte as
+â%HHâ, where HH is the hexadecimal representation of
the byte."
(define (needs-escaped? ch)
(not (char-set-contains? unescaped-chars ch)))
@@ -387,15 +408,18 @@ the byte."
str))
(define (split-and-decode-uri-path path)
- "Split @var{path} into its components, and decode each
-component, removing empty components.
+ "Split PATH into its components, and decode each component,
+removing empty components.
-For example, @code{\"/foo/bar/\"} decodes to the two-element list,
address@hidden(\"foo\" \"bar\")}."
+For example, â\"/foo/bar%20baz/\"â decodes to the two-element list,
+â(\"foo\" \"bar baz\")â."
(filter (lambda (x) (not (string-null? x)))
(map uri-decode (string-split path #\/))))
(define (encode-and-join-uri-path parts)
- "URI-encode each element of @var{parts}, which should be a list of
-strings, and join the parts together with @code{/} as a delimiter."
+ "URI-encode each element of PARTS, which should be a list of
+strings, and join the parts together with â/â as a delimiter.
+
+For example, the list â(\"scrambled eggs\" \"biscuits&gravy\")â
+encodes as â\"scrambled%20eggs/biscuits%26gravy\"â."
(string-join (map uri-encode parts) "/"))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index b356852..f9b85d4 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -287,4 +287,21 @@
(begin (cons 1 2 3) 4)
(seq
(primcall cons (const 1) (const 2) (const 3))
- (const 4))))
+ (const 4)))
+
+ (pass-if "http://bugs.gnu.org/12883";
+ ;; In 2.0.6, compiling this code would trigger an out-of-bounds
+ ;; vlist access in CSE's traversal of its "database".
+ (glil-program?
+ (compile '(define (proc v)
+ (let ((failure (lambda () (bail-out 'match))))
+ (if (and (pair? v)
+ (null? (cdr v)))
+ (let ((w foo)
+ (x (cdr w)))
+ (if (and (pair? x) (null? w))
+ #t
+ (failure)))
+ (failure))))
+ #:from 'scheme
+ #:to 'glil))))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index f8218ad..24afe2d 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -442,6 +442,36 @@
(call-with-vm vm thunk))))
;;;
+;;; docstrings
+;;;
+
+(with-test-prefix "docstrings"
+
+ (pass-if-equal "fixed closure"
+ '("hello" "world")
+ (map procedure-documentation
+ (list (eval '(lambda (a b) "hello" (+ a b))
+ (current-module))
+ (eval '(lambda (a b) "world" (- a b))
+ (current-module)))))
+
+ (pass-if-equal "fixed closure with many args"
+ "So many args."
+ (procedure-documentation
+ (eval '(lambda (a b c d e f g h i j k)
+ "So many args."
+ (+ a b))
+ (current-module))))
+
+ (pass-if-equal "general closure"
+ "How general."
+ (procedure-documentation
+ (eval '(lambda* (a b #:key k #:rest r)
+ "How general."
+ (+ a b))
+ (current-module)))))
+
+;;;
;;; local-eval
;;;
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index 2a203de..7cd88e4 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -214,18 +214,22 @@
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((error ,name ,ENOENT)))))
- (pass-if "EACCES"
- (with-file-tree %top-builddir '(directory "test-EACCES" #o000
- (("a") ("b")))
- (let ((enter? (lambda (n s r) #t))
- (leaf (lambda (n s r) (cons `(leaf ,n) r)))
- (down (lambda (n s r) (cons `(down ,n) r)))
- (up (lambda (n s r) (cons `(up ,n) r)))
- (skip (lambda (n s r) (cons `(skip ,n) r)))
- (error (lambda (n s e r) (cons `(error ,n ,e) r)))
- (name (string-append %top-builddir "/test-EACCES")))
- (equal? (file-system-fold enter? leaf down up skip error '() name)
- `((error ,name ,EACCES))))))
+ (let ((name (string-append %top-builddir "/test-EACCES")))
+ (pass-if-equal "EACCES"
+ `((error ,name ,EACCES))
+ (if (zero? (getuid))
+ ;; When run as root, this test would fail because root can
+ ;; list the contents of #o000 directories.
+ (throw 'unresolved)
+ (with-file-tree %top-builddir '(directory "test-EACCES" #o000
+ (("a") ("b")))
+ (let ((enter? (lambda (n s r) #t))
+ (leaf (lambda (n s r) (cons `(leaf ,n) r)))
+ (down (lambda (n s r) (cons `(down ,n) r)))
+ (up (lambda (n s r) (cons `(up ,n) r)))
+ (skip (lambda (n s r) (cons `(skip ,n) r)))
+ (error (lambda (n s e r) (cons `(error ,n ,e) r))))
+ (file-system-fold enter? leaf down up skip error '() name))))))
(pass-if "dangling symlink and lstat"
(with-file-tree %top-builddir '(directory "test-dangling"
diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test
index e82b4e3..b8bacb2 100644
--- a/test-suite/tests/future.test
+++ b/test-suite/tests/future.test
@@ -2,7 +2,7 @@
;;;;
;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,7 +22,8 @@
#:use-module (test-suite lib)
#:use-module (ice-9 futures)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26))
+ #:use-module (srfi srfi-26)
+ #:use-module (system base compile))
(define specific-exception-key (gensym))
@@ -90,3 +91,18 @@
(pass-if-exception "exception"
specific-exception
(touch (future (throw specific-exception-key 'test "thrown!")))))
+
+(with-test-prefix "nested futures"
+
+ (pass-if-equal "simple" 2
+ (touch (future (1+ (touch (future (1+ (touch (future 0)))))))))
+
+ (pass-if-equal "loop" (map - (iota 1000))
+ ;; Compile to avoid stack overflows.
+ (compile '(let loop ((list (iota 1000)))
+ (if (null? list)
+ '()
+ (cons (- (car list))
+ (touch (future (loop (cdr list)))))))
+ #:to 'value
+ #:env (current-module))))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index ddbd209..66aa01a 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -3070,6 +3070,16 @@
(pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1)))
(pass-if (equal? fixnum-min (* (* fixnum-min -1) -1))))
+ (with-test-prefix "signed fixnum overflow"
+ (pass-if (eqv? (* 65536 65536) 4294967296))
+ (pass-if (eqv? (* -65536 65536) -4294967296))
+ (pass-if (eqv? (* 65536 -65536) -4294967296))
+ (pass-if (eqv? (* -65536 -65536) 4294967296))
+ (pass-if (eqv? (* 4294967296 4294967296) 18446744073709551616))
+ (pass-if (eqv? (* -4294967296 4294967296) -18446744073709551616))
+ (pass-if (eqv? (* 4294967296 -4294967296) -18446744073709551616))
+ (pass-if (eqv? (* -4294967296 -4294967296) 18446744073709551616)))
+
(with-test-prefix "signed zeroes"
(pass-if (eqv? +0.0 (* +0.0 +0.0)))
(pass-if (eqv? -0.0 (* -0.0 +0.0)))
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index 9679042..00e9c68 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -1,6 +1,6 @@
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2004, 2006, 2007, 2010 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012 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
@@ -198,3 +198,16 @@
(setaffinity (getpid) mask)
(equal? mask (getaffinity (getpid))))
(throw 'unresolved))))
+
+;;
+;; system*
+;;
+
+(with-test-prefix "system*"
+
+ (pass-if "http://bugs.gnu.org/13166";
+ ;; With Guile up to 2.0.7 included, the child process launched by
+ ;; `system*' would remain alive after an `execvp' failure.
+ (let ((me (getpid)))
+ (and (not (zero? (system* "something-that-does-not-exist")))
+ (= me (getpid))))))
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index df11d67..fb49141 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -196,3 +196,43 @@
(guard (condition ((assertion-violation? condition) #t))
(assert #f)
#f)))
+
+(with-test-prefix "string-for-each"
+ (pass-if "reverse string"
+ (let ((s "reverse me") (l '()))
+ (string-for-each (lambda (x) (set! l (cons x l))) s)
+ (equal? "em esrever" (list->string l))))
+ (pass-if "two strings good"
+ (let ((s1 "two legs good")
+ (s2 "four legs bad")
+ (c '()))
+ (string-for-each (lambda (c1 c2)
+ (set! c (cons* c2 c1 c)))
+ s1 s2)
+ (equal? (list->string c)
+ "ddaobo gs gsegle lr uoowft")))
+ (pass-if "two strings bad"
+ (let ((s1 "frotz")
+ (s2 "veeblefetzer"))
+ (guard (condition ((assertion-violation? condition) #t))
+ (string-for-each (lambda (s1 s2) #f) s1 s2)
+ #f)))
+ (pass-if "many strings good"
+ (let ((s1 "foo")
+ (s2 "bar")
+ (s3 "baz")
+ (s4 "zot")
+ (c '()))
+ (string-for-each (lambda (c1 c2 c3 c4)
+ (set! c (cons* c4 c3 c2 c1 c)))
+ s1 s2 s3 s4)
+ (equal? (list->string c)
+ "tzrooaaozbbf")))
+ (pass-if "many strings bad"
+ (let ((s1 "foo")
+ (s2 "bar")
+ (s3 "baz")
+ (s4 "quux"))
+ (guard (condition ((assertion-violation? condition) #t))
+ (string-for-each (lambda _ #f) s1 s2 s3 s4)
+ #f))))
diff --git a/test-suite/tests/rnrs-libraries.test
b/test-suite/tests/rnrs-libraries.test
index e961c28..9add98a 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -183,7 +183,9 @@
(with-test-prefix "srfi"
(pass-if "renaming works"
(eq? (resolve-interface '(srfi srfi-1))
- (resolve-r6rs-interface '(srfi :1)))))
+ (resolve-r6rs-interface '(srfi :1)))
+ (eq? (resolve-interface '(srfi srfi-1))
+ (resolve-r6rs-interface '(srfi :1 lists)))))
(with-test-prefix "macro"
(pass-if "multiple clauses"
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
index ec992f1..c9aa4a0 100644
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@@ -1,7 +1,7 @@
;;;; session.test --- test suite for (ice-9 session) -*- scheme -*-
;;;; Jose Antonio Ortega Ruiz <address@hidden> -- August 2010
;;;;
-;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -88,7 +88,7 @@
(lambda* (a b #:optional o p #:key k l #:rest r) #f)
((required . (a b)) (optional . (o p))
(keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
- (rest . k)))
+ (rest . r)))
(pass-if "aok? is preserved"
;; See <http://bugs.gnu.org/10938>.
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 4767d62..c344795 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -776,6 +776,12 @@
(define %opts-w-format
'(#:warnings (format)))
+(define %opts-w-duplicate-case-datum
+ '(#:warnings (duplicate-case-datum)))
+
+(define %opts-w-bad-case-datum
+ '(#:warnings (bad-case-datum)))
+
(with-test-prefix "warnings"
@@ -1780,7 +1786,71 @@
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
- (number? (string-contains (car w) "unsupported format
option"))))))))
+ (number? (string-contains (car w) "unsupported format
option")))))))
+
+ (with-test-prefix "duplicate-case-datum"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(case x ((1) 'one) ((2) 'two))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+
+ (pass-if "one duplicate"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1) 'one)
+ ((2) 'two)
+ ((1) 'one-again))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "duplicate")))))
+
+ (pass-if "one duplicate"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1 2 3) 'a)
+ ((1) 'one))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "duplicate"))))))
+
+ (with-test-prefix "bad-case-datum"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(case x ((1) 'one) ((2) 'two))
+ #:opts %opts-w-bad-case-datum
+ #:to 'assembly)))))
+
+ (pass-if "not eqv?"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1) 'one)
+ (("bad") 'bad))
+ #:opts %opts-w-bad-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "cannot be meaningfully compared")))))
+
+ (pass-if "one clause element not eqv?"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1 (2) 3) 'a))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "cannot be meaningfully
compared")))))))
;; Local Variables:
;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
diff --git a/test-suite/tests/web-response.test
b/test-suite/tests/web-response.test
index ddd55a7..f9679f5 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding:
utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -21,6 +21,7 @@
#:use-module (web uri)
#:use-module (web response)
#:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
#:use-module (srfi srfi-19)
#:use-module (test-suite lib))
@@ -66,37 +67,33 @@ consectetur adipisicing elit,\r
(begin
(set! r (read-response (open-input-string example-1)))
(response? r)))
-
+
(pass-if "read-response-body"
(begin
(set! body (read-response-body r))
#t))
-
- (pass-if (equal? (response-version r) '(1 . 1)))
-
- (pass-if (equal? (response-code r) 200))
-
- (pass-if (equal? (response-reason-phrase r) "OK"))
-
- (pass-if (equal? body
- (string->utf8
- "abcdefghijklmnopqrstuvwxyz0123456789")))
-
- (pass-if "checking all headers"
- (equal?
- (response-headers r)
- `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
- "~a, ~d ~b ~Y ~H:~M:~S ~z"))
- (server . "Apache/2.0.55")
- (accept-ranges . (bytes))
- (cache-control . ((max-age . 543234)))
- (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
- "~a, ~d ~b ~Y ~H:~M:~S ~z"))
- (vary . (accept-encoding))
- (content-encoding . (gzip))
- (content-length . 36)
- (content-type . (text/html (charset . "utf-8"))))))
-
+
+ (pass-if-equal '(1 . 1) (response-version r))
+ (pass-if-equal 200 (response-code r))
+ (pass-if-equal "OK" (response-reason-phrase r))
+
+ (pass-if-equal (string->utf8 "abcdefghijklmnopqrstuvwxyz0123456789")
+ body)
+
+ (pass-if-equal "checking all headers"
+ `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (server . "Apache/2.0.55")
+ (accept-ranges . (bytes))
+ (cache-control . ((max-age . 543234)))
+ (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (vary . (accept-encoding))
+ (content-encoding . (gzip))
+ (content-length . 36)
+ (content-type . (text/html (charset . "utf-8"))))
+ (response-headers r))
+
(pass-if "write then read"
(call-with-values
(lambda ()
@@ -111,16 +108,31 @@ consectetur adipisicing elit,\r
(lambda (r* body*)
(responses-equal? r body r* body*))))
- (pass-if "by accessor"
- (equal? (response-content-encoding r) '(gzip)))))
+ (pass-if-equal "by accessor"
+ '(gzip)
+ (response-content-encoding r))
+
+ (pass-if-equal "response-body-port"
+ `("utf-8" ,body)
+ (with-fluids ((%default-port-encoding #f))
+ (let* ((r (read-response (open-input-string example-1)))
+ (p (response-body-port r)))
+ (list (port-encoding p) (get-bytevector-all p)))))))
(with-test-prefix "example-2"
- (let* ((r (read-response (open-input-string example-2)))
- (b (read-response-body r)))
- (pass-if (equal? '((chunked))
- (response-transfer-encoding r)))
- (pass-if (equal? b
- (string->utf8
- (string-append
- "Lorem ipsum dolor sit amet, consectetur adipisicing
elit,"
- " sed do eiusmod tempor incididunt ut labore et dolore
magna aliqua."))))))
+ (let* ((r (read-response (open-input-string example-2)))
+ (b (read-response-body r)))
+ (pass-if-equal '((chunked))
+ (response-transfer-encoding r))
+ (pass-if-equal
+ (string->utf8
+ (string-append
+ "Lorem ipsum dolor sit amet, consectetur adipisicing elit,"
+ " sed do eiusmod tempor incididunt ut labore et dolore magna
aliqua."))
+ b)
+ (pass-if-equal "response-body-port"
+ `("ISO-8859-1" ,(utf8->string b)) ; no `charset', hence ISO-8859-1
+ (with-fluids ((%default-port-encoding #f))
+ (let* ((r (read-response (open-input-string example-2)))
+ (p (response-body-port r)))
+ (list (port-encoding p) (get-string-all p)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-522-ge0c211b,
Mark H Weaver <=