mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

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

Browse source 
Conflicts:
	GUILE-VERSION
	libguile/posix.c
	module/ice-9/eval.scm
	test-suite/tests/cse.test
This commit is contained in:
Mark H Weaver 2013-01-07 17:23:26 -05:00
commit e0c211bb2e
89 changed files with 2766 additions and 1435 deletions
Download patch file Download diff file Expand all files Collapse all files

5
.dir-locals.el
View file

@ -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))))

1
Makefile.am
View file

@ -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

188
NEWS
View file

@ -5,6 +5,194 @@ See the end for copying conditions.
Please send Guile bug reports to bug-guile@gnu.org.
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

2
THANKS
View file

@ -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

167
build-aux/gendocs.sh
View file

@ -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 bug-texinfo@gnu.org.
"
calcsize()
{
size=`ls -ksl $1 | awk '{print $1}'`
echo $size
}
MANUAL_TITLE=
PACKAGE=
EMAIL=webmasters@gnu.org # 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" \

35
build-aux/gitlog-to-changelog
View file

@ -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"

83
build-aux/gnu-web-doc-update
View file

@ -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 $USER@cvs.sv.gnu.org:/webcvs/$pkg co $pkg )
rsync -avP "$builddir"/doc/manual/ $tmp/$pkg/manual
&& $CVS -d $USER@cvs.sv.gnu.org:/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:

11
configure.ac
View file

@ -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

2
doc/gendocs_template
View file

@ -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

59
doc/ref/api-compound.texi
View file

@ -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
@code{set-car!} 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.
@code{set-car!} 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.
@deffn {Scheme Syntax} set-record-type-printer! name thunk
@deffn {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
@result{}
#(() () () () () () ())
;; 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
@result{}
#(((braz . "zonk")) ((foo . "bar")) () () () () ((frob . #f)))
(hashq 'frob 7)
@result{}
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
@emph{is} 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
@code{(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

30
doc/ref/api-evaluation.texi
View file

@ -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},
@code{unbound-variable}, @code{arity-mismatch}, and @code{format}.
@code{unbound-variable}, @code{arity-mismatch}, @code{format},
@code{duplicate-case-datum}, and @code{bad-case-datum}.
@item -f @var{lang}
@itemx --from=@var{lang}
@ -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.
@cindex @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
@code{(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}).
@xref{Build 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
@deffn {Scheme Procedure} parse-path-with-ellipsis path base
@deffnx {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.
@end 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

29
doc/ref/api-procedures.texi
View file

@ -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,
@c 2011, 2012 Free Software Foundation, Inc.
@c 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
@deffn {Scheme Procedure} program-arguments-alist program [ip]
Return an association list describing the arguments that @var{program} accepts, or
@code{#f} if the information cannot be obtained.
For example:
@example
(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))
@end example
The alist keys that are currently defined are `required', `optional',
`keyword', `allow-other-keys?', and `rest'.
@deffnx {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)
@code{program-arguments-alist} 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.
@end deffn
@node Optional Arguments
@subsection Optional Arguments

30
doc/ref/api-scheduling.texi
View file

@ -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:
@lisp
(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))))))
@end 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

25
doc/ref/guile-invoke.texi
View file

@ -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
@file{../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

29
doc/ref/match.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2010, 2011 Free Software Foundation, Inc.
@c 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
@var{l} 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:
@example
(match lst
(((heads tails ...) ...)
heads))
@end example
@noindent
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
@var{lst} 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
@code{cdr} 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:

4
doc/ref/r6rs.texi
View file

@ -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

4
doc/ref/scheme-using.texi
View file

@ -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.
@item 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

71
doc/ref/web.texi
View file

@ -209,10 +209,11 @@ access to them.
@deffn {Scheme Procedure} build-uri scheme [#:userinfo=@code{#f}] [#:host=@code{#f}] @
[#:port=@code{#f}] [#:path=@code{""}] [#:query=@code{#f}] @
[#:fragment=@code{#f}] [#:validate?=@code{#t}]
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
@deffn {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
@var{r}'s response port.
@end 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
@deffn {Scheme Procedure} text-content-type? @var{type}
Return @code{#t} if @var{type}, a symbol as returned by
@code{response-content-type}, represents a textual type such as
@code{text/plain}.
@end 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
@deffn {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
@var{decode-body?} 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.
@end 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:
@deffn {Scheme Procedure} define-server-impl name open read write close
@deffn {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

23
doc/release.org
View file

@ -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 `platform-testers@gnu.org'
@ -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):
- guile-user@gnu.org, guile-devel@gnu.org, guile-sources@gnu.org
- info-gnu@gnu.org (for stable releases only!)
- comp.lang.scheme
** Post a news on [[http://sv.gnu.org/p/guile/][Savannah]]
** 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

67
gnulib-local/m4/canonicalize.m4.diff
View file

@ -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

8
lib/Makefile.am
View file

@ -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

3
lib/binary-io.c Normal file
View file

@ -0,0 +1,3 @@
#include <config.h>
#define BINARY_IO_INLINE _GL_EXTERN_INLINE
#include "binary-io.h"

11
lib/binary-io.h
View file

@ -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 */

5
lib/errno.in.h
View file

@ -270,5 +270,10 @@
# define GNULIB_defined_ENOTRECOVERABLE 1
# endif
# ifndef EILSEQ
# define EILSEQ 2015
# define GNULIB_defined_EILSEQ 1
# endif
#endif /* _@GUARD_PREFIX@_ERRNO_H */
#endif /* _@GUARD_PREFIX@_ERRNO_H */

14
lib/fcntl.in.h
View file

@ -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

9
lib/gettext.h
View file

@ -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>

7
lib/localcharset.c
View file

@ -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;
}

2
lib/malloca.h
View file

@ -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)

2
lib/regexec.c
View file

@ -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;

3
lib/stat-time.c Normal file
View file

@ -0,0 +1,3 @@
#include <config.h>
#define _GL_STAT_TIME_INLINE _GL_EXTERN_INLINE
#include "stat-time.h"

23
lib/stat-time.h
View file

@ -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

51
lib/stdbool.in.h
View file

@ -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 !@HAVE__BOOL@
# if !@HAVE__BOOL@
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 !@HAVE__BOOL@
# if !@HAVE__BOOL@
/* 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 */

13
lib/stdlib.in.h
View file

@ -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 !@HAVE_PTSNAME@
# 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 !@HAVE_PTSNAME@
_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

6
lib/verify.h
View file

@ -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. */

3
lib/xsize.c Normal file
View file

@ -0,0 +1,3 @@
#include <config.h>
#define XSIZE_INLINE _GL_EXTERN_INLINE
#include "xsize.h"

17
lib/xsize.h
View file

@ -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 */

134
libguile/dynl.c
View file

@ -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);
}
}

10
libguile/eval.c
View file

@ -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; \

35
libguile/load.c
View file

@ -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);

1
libguile/load.h
View file

@ -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);

101
libguile/memoize.c
View file

@ -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)),

14
libguile/numbers.c
View file

@ -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);

7
libguile/posix.c
View file

@ -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 */
}
/*

9
libguile/procs.c
View file

@ -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

5
libguile/procs.h
View file

@ -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 */
/*

22
libguile/simpos.c
View file

@ -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
{

8
libguile/socket.c
View file

@ -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"

4
libguile/values.c
View file

@ -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,

10
m4/canonicalize.m4
View file

@ -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

3
m4/eealloc.m4
View file

@ -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],

5
m4/errno_h.m4
View file

@ -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,
@ -57,6 +57,9 @@ booboo
#endif
#if !defined ENOTRECOVERABLE
booboo
#endif
#if !defined EILSEQ
booboo
#endif
],
[gl_cv_header_errno_h_complete=no],

57
m4/extern-inline.m4 Normal file
View file

@ -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])
])

13
m4/fcntl-o.m4
View file

@ -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
{

2
m4/gnulib-cache.m4
View file

@ -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])

957
m4/gnulib-comp.m4
View file

@ -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

58
m4/lib-ld.m4
View file

@ -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])

2
m4/stat-time.m4
View file

@ -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], [],

1
m4/stdlib_h.m4
View file

@ -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])

3
m4/xsize.m4
View file

@ -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])
])

269
maint.mk
View file

@ -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 > $@-2; \
diff -u -L $(po_file) -L $(po_file) $@-1 $@-2 \
|| { 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_ ?= coordinator@translationproject.org
# Make info-gnu the default only for a stable release.
ifeq ($(RELEASE_TYPE),stable)
announcement_Cc_ ?= $(translation_project_), $(PACKAGE_BUGREPORT)
announcement_mail_headers_ ?= \
To: info-gnu@gnu.org \
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: info-gnu@gnu.org \
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 \

8
module/Makefile.am
View file

@ -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 \

140
module/ice-9/boot-9.scm
View file

@ -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)))

43
module/ice-9/eval.scm
View file

@ -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

236
module/ice-9/futures.scm
View file

@ -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 <ludo@gnu.org>
@ -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))
(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 %futures-mutex)
(q-remove! %futures 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:

8
module/ice-9/r6rs-libraries.scm
View file

@ -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* ...))

25
module/ice-9/threads.scm
View file

@ -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-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))
(define par-for-each (par-mapper for-each))
(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))

94
module/ice-9/vlist.scm
View file

@ -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
@var{vlist}."
"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
@var{vlist}."
"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
@var{equal?} 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
@var{result} 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
@var{key} 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
@var{key}."
"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
@var{key}."
"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
@var{init} 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
@var{init} 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

9
module/language/tree-il/cse.scm
View file

@ -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)))

39
module/rnrs/base.scm
View file

@ -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)

6
module/srfi/srfi-9/gnu.scm
View file

@ -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)

21
module/system/repl/common.scm
View file

@ -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))

6
module/system/vm/program.scm
View file

@ -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)

67
module/web/client.scm
View file

@ -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))))

100
module/web/http.scm
View file

@ -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}.
@var{parser} 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
@samp{\\r\\n}, 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,
@code{(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))

30
module/web/request.scm
View file

@ -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
@code{#f} 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

105
module/web/response.scm
View file

@ -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 (read-response port)
"Read an HTTP response from @var{port}.
(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))))
As a side effect, sets the encoding on @var{port} to
(define (read-response port)
"Read an HTTP response from PORT.
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
@code{#f} 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

58
module/web/server.scm
View file

@ -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
@code{read-client}."
‘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
@code{read} 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
@code{content-length} 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
@var{handler} 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
@var{state}, 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
@code{open-server}."
‘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.
@var{handler} 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
@var{state}. Additional return values are accumulated into a new
@var{state}, 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
@var{open-params} 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)))

102
module/web/uri.scm
View file

@ -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
@var{encoding} 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.
@xref{Ports, ‘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-encode any character not in the character set,
UNESCAPED-CHARS.
Percent-encoding first writes out the given character to a bytevector
within the given @var{encoding}, then encodes each byte as
@code{%@var{HH}}, where @var{HH} is the hexadecimal representation of
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,
@code{(\"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) "/"))

19
test-suite/tests/cse.test
View file

@ -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))))

30
test-suite/tests/eval.test
View file

@ -441,6 +441,36 @@
(thunk (let loop () (cons 's (loop)))))
(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
;;;

28
test-suite/tests/ftw.test
View file

@ -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"

20
test-suite/tests/future.test
View file

@ -2,7 +2,7 @@
;;;;
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; 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))))

10
test-suite/tests/numbers.test
View file

@ -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)))

15
test-suite/tests/posix.test
View file

@ -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))))))

40
test-suite/tests/r6rs-base.test
View file

@ -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))))

4
test-suite/tests/rnrs-libraries.test
View file

@ -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"

4
test-suite/tests/session.test
View file

@ -1,7 +1,7 @@
;;;; session.test --- test suite for (ice-9 session) -*- scheme -*-
;;;; Jose Antonio Ortega Ruiz <jao@gnu.org> -- 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>.

72
test-suite/tests/tree-il.test
View file

@ -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)

90
test-suite/tests/web-response.test
View file

@ -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)))))))