diff options
89 files changed, 2769 insertions, 1438 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 364053094..ce2af7a77 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -5,7 +5,10 @@ (c-mode . ((c-file-style . "gnu"))) (scheme-mode . ((indent-tabs-mode . nil) - (eval . (put 'pass-if-equal 'scheme-indent-function 2)))) + (eval . (put 'pass-if 'scheme-indent-function 1)) + (eval . (put 'pass-if-exception 'scheme-indent-function 2)) + (eval . (put 'pass-if-equal 'scheme-indent-function 2)) + (eval . (put 'with-test-prefix 'scheme-indent-function 1)))) (emacs-lisp-mode . ((indent-tabs-mode . nil))) (texinfo-mode . ((indent-tabs-mode . nil) (fill-column . 72)))) diff --git a/Makefile.am b/Makefile.am index 446bb3c27..3aa5ddd76 100644 --- a/Makefile.am +++ b/Makefile.am @@ -50,7 +50,6 @@ EXTRA_DIST = LICENSE HACKING GUILE-VERSION \ gnulib-local/lib/localcharset.h.diff \ gnulib-local/lib/localcharset.c.diff \ gnulib-local/m4/clock_time.m4.diff \ - gnulib-local/m4/canonicalize.m4.diff \ gnulib-local/build-aux/git-version-gen.diff TESTS = check-guile @@ -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 @@ -48,6 +48,7 @@ For fixes or providing information which led to a fix: Rob Browning Adrian Bunk Michael Carmack + Jozef Chraplewski R Clayton Tristan Colgate Stephen Compall @@ -156,6 +157,7 @@ For fixes or providing information which led to a fix: Panagiotis Vossos Neil W. Van Dyke Aaron VanDevender + Sjoerd Van Leent Andreas Vögele Michael Talbot-Wilson Michael Tuexen diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh index c8abd55fb..0c0bc4b0f 100755 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh @@ -2,10 +2,10 @@ # gendocs.sh -- generate a GNU manual in many formats. This script is # mentioned in maintain.texi. See the help message below for usage details. -scriptversion=2011-04-08.14 +scriptversion=2012-10-27.11 -# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. +# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 +# Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -30,6 +30,12 @@ scriptversion=2011-04-08.14 # # An up-to-date copy is also maintained in Gnulib (gnu.org/software/gnulib). +# TODO: +# - image importation was only implemented for HTML generated by +# makeinfo. But it should be simple enough to adjust. +# - images are not imported in the source tarball. All the needed +# formats (PDF, PNG, etc.) should be included. + prog=`basename "$0"` srcdir=`pwd` @@ -39,35 +45,37 @@ templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/ : ${SETLANG="env LANG= LC_MESSAGES= LC_ALL= LANGUAGE="} : ${MAKEINFO="makeinfo"} : ${TEXI2DVI="texi2dvi -t @finalout"} -: ${DVIPS="dvips"} : ${DOCBOOK2HTML="docbook2html"} : ${DOCBOOK2PDF="docbook2pdf"} -: ${DOCBOOK2PS="docbook2ps"} : ${DOCBOOK2TXT="docbook2txt"} : ${GENDOCS_TEMPLATE_DIR="."} +: ${PERL='perl'} : ${TEXI2HTML="texi2html"} unset CDPATH unset use_texi2html version="gendocs.sh $scriptversion -Copyright 2010 Free Software Foundation, Inc. +Copyright 2012 Free Software Foundation, Inc. There is NO warranty. You may redistribute this software under the terms of the GNU General Public License. For more information about these matters, see the files named COPYING." usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE -Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source. -See the GNU Maintainers document for a more extensive discussion: +Generate output in various formats from PACKAGE.texinfo (or .texi or +.txi) source. See the GNU Maintainers document for a more extensive +discussion: http://www.gnu.org/prep/maintain_toc.html Options: -s SRCFILE read Texinfo from SRCFILE, instead of PACKAGE.{texinfo|texi|txi} -o OUTDIR write files into OUTDIR, instead of manual/. + -I DIR append DIR to the Texinfo search path. --email ADR use ADR as contact in generated web pages. - --docbook convert to DocBook too (xml, txt, html, pdf and ps). + --docbook convert through DocBook too (xml, txt, html, pdf). --html ARG pass indicated ARG to makeinfo or texi2html for HTML targets. + --info ARG pass indicated ARG to makeinfo for Info, instead of --no-split. --texi2html use texi2html to generate HTML targets. --help display this help and exit successfully. --version display version information and exit successfully. @@ -80,11 +88,11 @@ Typical sequence: wget \"$templateurl\" $prog --email BUGLIST MANUAL \"GNU MANUAL - One-line description\" -Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR -to override). Move all the new files into your web CVS tree, as -explained in the Web Pages node of maintain.texi. +Output will be in a new subdirectory \"manual\" (by default; +use -o OUTDIR to override). Move all the new files into your web CVS +tree, as explained in the Web Pages node of maintain.texi. -Please use the --email ADDRESS option to specify your bug-reporting +Please do use the --email ADDRESS option to specify your bug-reporting address in the generated HTML pages. MANUAL-TITLE is included as part of the HTML <title> of the overall @@ -102,11 +110,14 @@ If a manual's Texinfo sources are spread across several directories, first copy or symlink all Texinfo sources into a single directory. (Part of the script's work is to make a tar.gz of the sources.) -You can set the environment variables MAKEINFO, TEXI2DVI, TEXI2HTML, and -DVIPS to control the programs that get executed, and +As implied above, by default monolithic Info files are generated. +If you want split Info, or other Info options, use --info to override. + +You can set the environment variables MAKEINFO, TEXI2DVI, TEXI2HTML, +and PERL to control the programs that get executed, and GENDOCS_TEMPLATE_DIR to control where the gendocs_template file is looked for. With --docbook, the environment variables DOCBOOK2HTML, -DOCBOOK2PDF, DOCBOOK2PS, and DOCBOOK2TXT are also respected. +DOCBOOK2PDF, and DOCBOOK2TXT are also respected. By default, makeinfo and texi2dvi are run in the default (English) locale, since that's the language of most Texinfo manuals. If you @@ -116,16 +127,13 @@ SETLANG setting in the source. Email bug reports or enhancement requests to 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" \ diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index 17c456271..5184edc7d 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -3,7 +3,7 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' if 0; # Convert git log output to ChangeLog format. -my $VERSION = '2012-05-22 09:40'; # UTC +my $VERSION = '2012-07-29 06:11'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook @@ -68,6 +68,8 @@ OPTIONS: header; the default is to cluster adjacent commit messages if their headers are the same and neither commit message contains multiple paragraphs. + --srcdir=DIR the root of the source tree, from which the .git/ + directory can be derived. --since=DATE convert only the logs since DATE; the default is to convert all log entries. --format=FMT set format string for commit subject and body; @@ -192,6 +194,30 @@ sub parse_amend_file($) return $h; } +# git_dir_option $SRCDIR +# +# From $SRCDIR, the --git-dir option to pass to git (none if $SRCDIR +# is undef). Return as a list (0 or 1 element). +sub git_dir_option($) +{ + my ($srcdir) = @_; + my @res = (); + if (defined $srcdir) + { + my $qdir = shell_quote $srcdir; + my $cmd = "cd $qdir && git rev-parse --show-toplevel"; + my $qcmd = shell_quote $cmd; + my $git_dir = qx($cmd); + defined $git_dir + or die "$ME: cannot run $qcmd: $!\n"; + $? == 0 + or die "$ME: $qcmd had unexpected exit code or signal ($?)\n"; + chomp $git_dir; + push @res, "--git-dir=$git_dir/.git"; + } + @res; +} + { my $since_date; my $format_string = '%s%n%b%n'; @@ -200,6 +226,7 @@ sub parse_amend_file($) my $cluster = 1; my $strip_tab = 0; my $strip_cherry_pick = 0; + my $srcdir; GetOptions ( help => sub { usage 0 }, @@ -211,9 +238,9 @@ sub parse_amend_file($) 'cluster!' => \$cluster, 'strip-tab' => \$strip_tab, 'strip-cherry-pick' => \$strip_cherry_pick, + 'srcdir=s' => \$srcdir, ) or usage 1; - defined $since_date and unshift @ARGV, "--since=$since_date"; @@ -221,7 +248,9 @@ sub parse_amend_file($) # that makes a correction in the log or attribution of that commit. my $amend_code = defined $amend_file ? parse_amend_file $amend_file : {}; - my @cmd = (qw (git log --log-size), + my @cmd = ('git', + git_dir_option $srcdir, + qw(log --log-size), '--pretty=format:%H:%ct %an <%ae>%n%n'.$format_string, @ARGV); open PIPE, '-|', @cmd or die ("$ME: failed to run '". quoted_cmd (@cmd) ."': $!\n" diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update index 851f8b899..4acd69d15 100755 --- a/build-aux/gnu-web-doc-update +++ b/build-aux/gnu-web-doc-update @@ -24,9 +24,6 @@ VERSION=2009-07-21.16; # UTC # You should have received a copy of the GNU General Public License # along with this program. If not, see <http://www.gnu.org/licenses/>. -# Requirements: everything required to bootstrap your package, -# plus these: git, cvs, cvsu, rsync, mktemp - ME=$(basename "$0") warn() { printf '%s: %s\n' "$ME" "$*" >&2; } die() { warn "$*"; exit 1; } @@ -36,10 +33,9 @@ help() cat <<EOF Usage: $ME -Run this script from top_srcdir (no options or arguments) after each -non-alpha release, to update the web documentation at -http://www.gnu.org/software/\$pkg/manual/ Run it from your project's -the top-level directory. +Run this script from top_srcdir (no arguments) after each non-alpha +release, to update the web documentation at +http://www.gnu.org/software/\$pkg/manual/ Options: -C, --builddir=DIR location of (configured) Makefile (default: .) @@ -64,6 +60,51 @@ EOF exit } +# find_tool ENVVAR NAMES... +# ------------------------- +# Search for a required program. Use the value of ENVVAR, if set, +# otherwise find the first of the NAMES that can be run (i.e., +# supports --version). If found, set ENVVAR to the program name, +# die otherwise. +# +# FIXME: code duplication, see also bootstrap. +find_tool () +{ + find_tool_envvar=$1 + shift + find_tool_names=$@ + eval "find_tool_res=\$$find_tool_envvar" + if test x"$find_tool_res" = x; then + for i + do + if ($i --version </dev/null) >/dev/null 2>&1; then + find_tool_res=$i + break + fi + done + else + find_tool_error_prefix="\$$find_tool_envvar: " + fi + test x"$find_tool_res" != x \ + || die "one of these is required: $find_tool_names" + ($find_tool_res --version </dev/null) >/dev/null 2>&1 \ + || die "${find_tool_error_prefix}cannot run $find_tool_res --version" + eval "$find_tool_envvar=\$find_tool_res" + eval "export $find_tool_envvar" +} + +## ------ ## +## Main. ## +## ------ ## + +# Requirements: everything required to bootstrap your package, plus +# these. +find_tool CVS cvs +find_tool CVSU cvsu +find_tool GIT git +find_tool RSYNC rsync +find_tool XARGS gxargs xargs + builddir=. while test $# != 0 do @@ -86,22 +127,22 @@ do done test $# = 0 \ - || die "$ME: too many arguments" + || die "too many arguments" prev=.prev-version -version=$(cat $prev) || die "$ME: no $prev file?" +version=$(cat $prev) || die "no $prev file?" pkg=$(sed -n 's/^PACKAGE = \(.*\)/\1/p' $builddir/Makefile) \ - || die "$ME: no Makefile?" + || die "no Makefile?" tmp_branch=web-doc-$version-$$ -current_branch=$(git branch | sed -ne '/^\* /{s///;p;q;}') +current_branch=$($GIT branch | sed -ne '/^\* /{s///;p;q;}') cleanup() { __st=$? rm -rf "$tmp" - git checkout "$current_branch" - git submodule update --recursive - git branch -d $tmp_branch + $GIT checkout "$current_branch" + $GIT submodule update --recursive + $GIT branch -d $tmp_branch exit $__st } trap cleanup 0 @@ -111,8 +152,8 @@ trap 'exit $?' 1 2 13 15 # just-released version number, not some string like 7.6.18-20761. # That version string propagates into all documentation. set -e -git checkout -b $tmp_branch v$version -git submodule update --recursive +$GIT checkout -b $tmp_branch v$version +$GIT submodule update --recursive ./bootstrap srcdir=$(pwd) cd "$builddir" @@ -125,16 +166,18 @@ set +e tmp=$(mktemp -d web-doc-update.XXXXXX) || exit 1 ( cd $tmp \ - && cvs -d $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: diff --git a/configure.ac b/configure.ac index 8adfd471c..e5002b0bd 100644 --- a/configure.ac +++ b/configure.ac @@ -35,8 +35,8 @@ AC_CONFIG_AUX_DIR([build-aux]) AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_SRCDIR(GUILE-VERSION) -dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11. -AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override color-tests dist-xz]) +dnl `AM_PROG_AR' was introduced in Automake 1.11.2. +AM_INIT_AUTOMAKE([1.11.2 gnu no-define -Wall -Wno-override color-tests dist-xz]) m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)]) AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT) @@ -79,10 +79,6 @@ AC_PROG_LIBTOOL AM_CONDITIONAL([HAVE_SHARED_LIBRARIES], [test "x$enable_shared" = "xyes"]) -AC_DEFINE_UNQUOTED([SHARED_LIBRARY_PATH_VARIABLE], ["$shlibpath_var"], - [Name of the environment variable that tells the dynamic linker where -to find shared libraries.]) - dnl Check for libltdl. AC_LIB_HAVE_LINKFLAGS([ltdl], [], [#include <ltdl.h>], [lt_dlopenext ("foo");]) @@ -748,11 +744,14 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific # strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin +# fork - unavailable on Windows # utimensat: posix.1-2008 # sched_getaffinity, sched_setaffinity: GNU extensions (glibc) # AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale utimensat sched_getaffinity sched_setaffinity]) +AM_CONDITIONAL([HAVE_FORK], [test "x$ac_cv_func_fork" = "xyes"]) + # Reasons for testing: # netdb.h - not in mingw # sys/param.h - not in mingw diff --git a/doc/gendocs_template b/doc/gendocs_template index f3a3ff64c..a62ad6167 100644 --- a/doc/gendocs_template +++ b/doc/gendocs_template @@ -45,8 +45,6 @@ (%%ASCII_GZ_SIZE%%K bytes gzipped)</a>.</li> <li><a href="%%PACKAGE%%.dvi.gz">TeX dvi file (%%DVI_GZ_SIZE%%K bytes gzipped)</a>.</li> -<li><a href="%%PACKAGE%%.ps.gz">PostScript file - (%%PS_GZ_SIZE%%K bytes gzipped)</a>.</li> <li><a href="%%PACKAGE%%.pdf">PDF file (%%PDF_SIZE%%K bytes)</a>.</li> <li><a href="%%PACKAGE%%.texi.tar.gz">Texinfo source diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 0b2106540..be3d65f4e 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -105,10 +105,14 @@ Return 1 when @var{x} is a pair; otherwise return 0. The two parts of a pair are traditionally called @dfn{car} and @dfn{cdr}. They can be retrieved with procedures of the same name (@code{car} and @code{cdr}), and can be modified with the procedures -@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 diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index c471f643b..2e5a3d251 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -661,7 +661,8 @@ name is as for @code{compile-file} (see below). Emit warnings of type @var{warning}; use @code{--warn=help} for a list of available warnings and their description. Currently recognized warnings include @code{unused-variable}, @code{unused-toplevel}, -@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 diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index 02d777155..d77a2bdcc 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, -@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 diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index a30166394..9c2b4132a 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -982,6 +982,24 @@ machine, though, the computation of @code{(find prime? lst2)} may be done in parallel with that of the other @code{find} call, which can reduce the execution time of @code{find-prime}. +Futures may be nested: a future can itself spawn and then @code{touch} +other futures, leading to a directed acyclic graph of futures. Using +this facility, a parallel @code{map} procedure can be defined along +these lines: + +@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 diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 08c169864..5a9a3f7ef 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -295,8 +295,10 @@ variable. By default, the history file is @file{$HOME/.guile_history}. @vindex GUILE_LOAD_COMPILED_PATH This variable may be used to augment the path that is searched for compiled Scheme files (@file{.go} files) when loading. Its value should -be a colon-separated list of directories, which will be prefixed to the -value of the default search path stored in @code{%load-compiled-path}. +be a colon-separated list of directories. If it contains the special +path component @code{...} (ellipsis), then the default path is put in +place of the ellipsis, otherwise the default path is placed at the end. +The result is stored in @code{%load-compiled-path} (@pxref{Load Paths}). Here is an example using the Bash shell that adds the current directory, @file{.}, and the relative directory @file{../my-library} to @@ -312,18 +314,23 @@ $ guile -c '(display %load-compiled-path) (newline)' @vindex GUILE_LOAD_PATH This variable may be used to augment the path that is searched for Scheme files when loading. Its value should be a colon-separated list -of directories, which will be prefixed to the value of the default -search path stored in @code{%load-path}. +of directories. If it contains the special path component @code{...} +(ellipsis), then the default path is put in place of the ellipsis, +otherwise the default path is placed at the end. The result is stored +in @code{%load-path} (@pxref{Load Paths}). -Here is an example using the Bash shell that adds the current directory -and the parent of the current directory to @code{%load-path}: +Here is an example using the Bash shell that prepends the current +directory to @code{%load-path}, and adds the relative directory +@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 diff --git a/doc/ref/match.texi b/doc/ref/match.texi index 40b5be899..12e3814ae 100644 --- a/doc/ref/match.texi +++ b/doc/ref/match.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@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: diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index f9bc9e977..2028ada2a 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -2101,8 +2101,8 @@ immutable. @deffn {Scheme Procedure} hashtable-copy hashtable @deffnx {Scheme Procedure} hashtable-copy hashtable mutable Returns a copy of the hash table @var{hashtable}. If the optional -argument @var{mutable} is a true value, the new hash table will be -immutable. +argument @var{mutable} is provided and is a true value, the new hash +table will be mutable. @end deffn @deffn {Scheme Procedure} hashtable-clear! hashtable diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 7eb84de0a..4f9e6db82 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -445,6 +445,10 @@ choice is available. Off by default (indicating compilation). @item prompt A customized REPL prompt. @code{#f} by default, indicating the default prompt. +@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 diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 161a28d59..e892453e3 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -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 diff --git a/doc/release.org b/doc/release.org index 462c7057d..95ba12e3b 100644 --- a/doc/release.org +++ b/doc/release.org @@ -50,8 +50,8 @@ builds on 11 architectures). It also has FreeBSD and NetBSD boxes. *** Use porter boxes If you're still in a good mood, you may also want to check on porter -boxes for other OSes. The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], so does -the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]]. +boxes for other OSes. The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], and so do +the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]] and the [[http://lists.gnu.org/archive/html/autoconf/2012-11/msg00039.html][Snakebite]] project. *** Post a pre-release announcement to `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 diff --git a/gnulib-local/m4/canonicalize.m4.diff b/gnulib-local/m4/canonicalize.m4.diff deleted file mode 100644 index 57f44726f..000000000 --- a/gnulib-local/m4/canonicalize.m4.diff +++ /dev/null @@ -1,67 +0,0 @@ -Fix `canonicalize_file_name' replacement handling when cross-compiling. -Without this patch, we end up with: - - ./.libs/libguile-2.0.so: undefined reference to `rpl_canonicalize_file_name' - -See <http://hydra.nixos.org/build/2765567> for details. - -index 69b3f4c..3c4c5ee 100644 ---- a/m4/canonicalize.m4 -+++ b/m4/canonicalize.m4 -@@ -16,8 +16,11 @@ AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE], - AC_REQUIRE([gl_FUNC_REALPATH_WORKS]) - if test $ac_cv_func_canonicalize_file_name = no; then - HAVE_CANONICALIZE_FILE_NAME=0 -- elif test "$gl_cv_func_realpath_works" != yes; then -- REPLACE_CANONICALIZE_FILE_NAME=1 -+ else -+ case "$gl_cv_func_realpath_works" in -+ *yes) ;; -+ *) REPLACE_CANONICALIZE_FILE_NAME=1 ;; -+ esac - fi - ]) - -@@ -30,12 +33,21 @@ AC_DEFUN([gl_CANONICALIZE_LGPL], - HAVE_CANONICALIZE_FILE_NAME=0 - if test $ac_cv_func_realpath = no; then - HAVE_REALPATH=0 -- elif test "$gl_cv_func_realpath_works" != yes; then -- REPLACE_REALPATH=1 -+ else -+ case "$gl_cv_func_realpath_works" in -+ *yes) ;; -+ *) REPLACE_REALPATH=1 ;; -+ esac - fi -- elif test "$gl_cv_func_realpath_works" != yes; then -- REPLACE_CANONICALIZE_FILE_NAME=1 -- REPLACE_REALPATH=1 -+ else -+ case "$gl_cv_func_realpath_works" in -+ *yes) -+ ;; -+ *) -+ REPLACE_CANONICALIZE_FILE_NAME=1 -+ REPLACE_REALPATH=1 -+ ;; -+ esac - fi - ]) - - -Now, work around a second bug: fix default value when cross-compiling -for GNU/Hurd. - -index 69b3f4c..111ddf8 100644 ---- a/m4/canonicalize.m4 -+++ b/m4/canonicalize.m4 -@@ -95,7 +95,7 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS], - [gl_cv_func_realpath_works=no], - [case "$host_os" in - # Guess yes on glibc systems. -- *-gnu*) gl_cv_func_realpath_works="guessing yes" ;; -+ *gnu*) gl_cv_func_realpath_works="guessing yes" ;; - # If we don't know, assume the worst. - *) gl_cv_func_realpath_works="guessing no" ;; - esac diff --git a/lib/Makefile.am b/lib/Makefile.am index 8602e1340..49c5140f2 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -155,7 +155,7 @@ EXTRA_DIST += arpa_inet.in.h ## begin gnulib module binary-io -libgnu_la_SOURCES += binary-io.h +libgnu_la_SOURCES += binary-io.h binary-io.c ## end gnulib module binary-io @@ -614,7 +614,7 @@ EXTRA_DIST += $(top_srcdir)/build-aux/gnu-web-doc-update distclean-local: clean-GNUmakefile clean-GNUmakefile: - test x'$(VPATH)' != x && rm -f $(top_builddir)/GNUmakefile || : + test '$(srcdir)' = . || rm -f $(top_builddir)/GNUmakefile EXTRA_DIST += $(top_srcdir)/GNUmakefile @@ -1795,6 +1795,7 @@ EXTRA_libgnu_la_SOURCES += stat.c ## begin gnulib module stat-time +libgnu_la_SOURCES += stat-time.c EXTRA_DIST += stat-time.h @@ -2133,6 +2134,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''REPLACE_MALLOC''@|$(REPLACE_MALLOC)|g' \ -e 's|@''REPLACE_MBTOWC''@|$(REPLACE_MBTOWC)|g' \ -e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \ + -e 's|@''REPLACE_PTSNAME''@|$(REPLACE_PTSNAME)|g' \ -e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \ -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \ -e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \ @@ -3008,7 +3010,7 @@ EXTRA_libgnu_la_SOURCES += write.c ## begin gnulib module xsize -libgnu_la_SOURCES += xsize.h +libgnu_la_SOURCES += xsize.h xsize.c ## end gnulib module xsize diff --git a/lib/binary-io.c b/lib/binary-io.c new file mode 100644 index 000000000..8bbdb44d1 --- /dev/null +++ b/lib/binary-io.c @@ -0,0 +1,3 @@ +#include <config.h> +#define BINARY_IO_INLINE _GL_EXTERN_INLINE +#include "binary-io.h" diff --git a/lib/binary-io.h b/lib/binary-io.h index 77cbd4ec9..30315e10c 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -25,6 +25,11 @@ so we include it here first. */ #include <stdio.h> +_GL_INLINE_HEADER_BEGIN +#ifndef BINARY_IO_INLINE +# define BINARY_IO_INLINE _GL_INLINE +#endif + /* set_binary_mode (fd, mode) sets the binary/text I/O mode of file descriptor fd to the given mode (must be O_BINARY or O_TEXT) and returns the previous mode. */ @@ -39,9 +44,9 @@ # endif #else /* On reasonable systems, binary I/O is the only choice. */ - /* Use an inline function rather than a macro, to avoid gcc warnings + /* Use a function rather than a macro, to avoid gcc warnings "warning: statement with no effect". */ -static inline int +BINARY_IO_INLINE int set_binary_mode (int fd, int mode) { (void) fd; @@ -62,4 +67,6 @@ set_binary_mode (int fd, int mode) # define SET_BINARY(fd) ((void) set_binary_mode (fd, O_BINARY)) #endif +_GL_INLINE_HEADER_END + #endif /* _BINARY_H */ diff --git a/lib/errno.in.h b/lib/errno.in.h index 21ba05b5f..774c786ba 100644 --- a/lib/errno.in.h +++ b/lib/errno.in.h @@ -270,5 +270,10 @@ # define GNULIB_defined_ENOTRECOVERABLE 1 # endif +# ifndef EILSEQ +# define EILSEQ 2015 +# define GNULIB_defined_EILSEQ 1 +# endif + #endif /* _@GUARD_PREFIX@_ERRNO_H */ #endif /* _@GUARD_PREFIX@_ERRNO_H */ diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index f39dfe51d..5c934c025 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -216,6 +216,10 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " # define O_EXEC O_RDONLY /* This is often close enough in older systems. */ #endif +#ifndef O_IGNORE_CTTY +# define O_IGNORE_CTTY 0 +#endif + #ifndef O_NDELAY # define O_NDELAY 0 #endif @@ -249,10 +253,18 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " # define O_NOFOLLOW 0 #endif +#ifndef O_NOLINK +# define O_NOLINK 0 +#endif + #ifndef O_NOLINKS # define O_NOLINKS 0 #endif +#ifndef O_NOTRANS +# define O_NOTRANS 0 +#endif + #ifndef O_RSYNC # define O_RSYNC 0 #endif @@ -269,7 +281,7 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " # define O_TTY_INIT 0 #endif -#if O_ACCMODE != (O_RDONLY | O_WRONLY | O_RDWR | O_EXEC | O_SEARCH) +#if ~O_ACCMODE & (O_RDONLY | O_WRONLY | O_RDWR | O_EXEC | O_SEARCH) # undef O_ACCMODE # define O_ACCMODE (O_RDONLY | O_WRONLY | O_RDWR | O_EXEC | O_SEARCH) #endif diff --git a/lib/gettext.h b/lib/gettext.h index c7d974078..d130faa2b 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -183,9 +183,12 @@ npgettext_aux (const char *domain, #include <string.h> -#define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS \ - (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \ - /* || __STDC_VERSION__ >= 199901L */ ) +#if (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \ + /* || __STDC_VERSION__ >= 199901L */ ) +# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 1 +#else +# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 0 +#endif #if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS #include <stdlib.h> diff --git a/lib/localcharset.c b/lib/localcharset.c index ad28ec673..c4a0596be 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -542,6 +542,13 @@ locale_charset (void) if (codeset[0] == '\0') codeset = "ASCII"; +#ifdef DARWIN7 + /* Mac OS X sets MB_CUR_MAX to 1 when LC_ALL=C, and "UTF-8" + (the default codeset) does not work when MB_CUR_MAX is 1. */ + if (strcmp (codeset, "UTF-8") == 0 && MB_CUR_MAX <= 1) + codeset = "ASCII"; +#endif + return codeset; } diff --git a/lib/malloca.h b/lib/malloca.h index c9bc15b8c..deb9bdaa0 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -42,7 +42,7 @@ extern "C" { and a page size can be as small as 4096 bytes. So we cannot safely allocate anything larger than 4096 bytes. Also care for the possibility of a few compiler-allocated temporary stack slots. - This must be a macro, not an inline function. */ + This must be a macro, not a function. */ # define safe_alloca(N) ((N) < 4032 ? alloca (N) : NULL) #else # define safe_alloca(N) ((void) (N), NULL) diff --git a/lib/regexec.c b/lib/regexec.c index b2c174f05..13c3f15d6 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -735,7 +735,7 @@ re_search_internal (const regex_t *preg, mctx.input.tip_context = (eflags & REG_NOTBOL) ? CONTEXT_BEGBUF : CONTEXT_NEWLINE | CONTEXT_BEGBUF; - /* Check incrementally whether of not the input string match. */ + /* Check incrementally whether the input string matches. */ incr = (last_start < start) ? -1 : 1; left_lim = (last_start < start) ? last_start : start; right_lim = (last_start < start) ? start : last_start; diff --git a/lib/stat-time.c b/lib/stat-time.c new file mode 100644 index 000000000..81b83ddb4 --- /dev/null +++ b/lib/stat-time.c @@ -0,0 +1,3 @@ +#include <config.h> +#define _GL_STAT_TIME_INLINE _GL_EXTERN_INLINE +#include "stat-time.h" diff --git a/lib/stat-time.h b/lib/stat-time.h index 1aae18a30..daf2ca6ee 100644 --- a/lib/stat-time.h +++ b/lib/stat-time.h @@ -23,6 +23,11 @@ #include <sys/stat.h> #include <time.h> +_GL_INLINE_HEADER_BEGIN +#ifndef _GL_STAT_TIME_INLINE +# define _GL_STAT_TIME_INLINE _GL_INLINE +#endif + /* STAT_TIMESPEC (ST, ST_XTIM) is the ST_XTIM member for *ST of type struct timespec, if available. If not, then STAT_TIMESPEC_NS (ST, ST_XTIM) is the nanosecond component of the ST_XTIM member for *ST, @@ -46,7 +51,7 @@ #endif /* Return the nanosecond component of *ST's access time. */ -static inline long int +_GL_STAT_TIME_INLINE long int get_stat_atime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -59,7 +64,7 @@ get_stat_atime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's status change time. */ -static inline long int +_GL_STAT_TIME_INLINE long int get_stat_ctime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -72,7 +77,7 @@ get_stat_ctime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's data modification time. */ -static inline long int +_GL_STAT_TIME_INLINE long int get_stat_mtime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -85,7 +90,7 @@ get_stat_mtime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's birth time. */ -static inline long int +_GL_STAT_TIME_INLINE long int get_stat_birthtime_ns (struct stat const *st) { # if defined HAVE_STRUCT_STAT_ST_BIRTHTIMESPEC_TV_NSEC @@ -100,7 +105,7 @@ get_stat_birthtime_ns (struct stat const *st) } /* Return *ST's access time. */ -static inline struct timespec +_GL_STAT_TIME_INLINE struct timespec get_stat_atime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -114,7 +119,7 @@ get_stat_atime (struct stat const *st) } /* Return *ST's status change time. */ -static inline struct timespec +_GL_STAT_TIME_INLINE struct timespec get_stat_ctime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -128,7 +133,7 @@ get_stat_ctime (struct stat const *st) } /* Return *ST's data modification time. */ -static inline struct timespec +_GL_STAT_TIME_INLINE struct timespec get_stat_mtime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -143,7 +148,7 @@ get_stat_mtime (struct stat const *st) /* Return *ST's birth time, if available; otherwise return a value with tv_sec and tv_nsec both equal to -1. */ -static inline struct timespec +_GL_STAT_TIME_INLINE struct timespec get_stat_birthtime (struct stat const *st) { struct timespec t; @@ -186,4 +191,6 @@ get_stat_birthtime (struct stat const *st) return t; } +_GL_INLINE_HEADER_END + #endif diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h index 6ea7f7001..419342993 100644 --- a/lib/stdbool.in.h +++ b/lib/stdbool.in.h @@ -66,24 +66,19 @@ # undef true #endif -/* For the sake of symbolic names in gdb, we define true and false as - enum constants, not only as macros. - It is tempting to write - typedef enum { false = 0, true = 1 } _Bool; - so that gdb prints values of type 'bool' symbolically. But if we do - this, values of type '_Bool' may promote to 'int' or 'unsigned int' - (see ISO C 99 6.7.2.2.(4)); however, '_Bool' must promote to 'int' - (see ISO C 99 6.3.1.1.(2)). So we add a negative value to the - enum; this ensures that '_Bool' promotes to 'int'. */ -#if defined __cplusplus || (defined __BEOS__ && !defined __HAIKU__) +#ifdef __cplusplus +# define _Bool bool +# define bool bool +#else +# if defined __BEOS__ && !defined __HAIKU__ /* A compiler known to have 'bool'. */ /* If the compiler already has both 'bool' and '_Bool', we can assume they are the same types. */ -# if !@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 */ diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index 72c9dd1ca..b67a3484e 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -457,10 +457,19 @@ _GL_WARN_ON_USE (posix_openpt, "posix_openpt is not portable - " #if @GNULIB_PTSNAME@ /* Return the pathname of the pseudo-terminal slave associated with the master FD is open on, or NULL on errors. */ -# if !@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 diff --git a/lib/verify.h b/lib/verify.h index 6c4bd43fd..780b55e1d 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -125,7 +125,7 @@ extern int (*dummy (void)) [sizeof (struct {...})]; * GCC warns about duplicate declarations of the dummy function if - -Wredundant_decls is used. GCC 4.3 and later have a builtin + -Wredundant-decls is used. GCC 4.3 and later have a builtin __COUNTER__ macro that can let us generate unique identifiers for each dummy function, to suppress this warning. @@ -133,6 +133,10 @@ which do not support _Static_assert, also do not warn about the last declaration mentioned above. + * GCC warns if -Wnested-externs is enabled and verify() is used + within a function body; but inside a function, you can always + arrange to use verify_expr() instead. + * In C++, any struct definition inside sizeof is invalid. Use a template type to work around the problem. */ diff --git a/lib/xsize.c b/lib/xsize.c new file mode 100644 index 000000000..4b4914c2c --- /dev/null +++ b/lib/xsize.c @@ -0,0 +1,3 @@ +#include <config.h> +#define XSIZE_INLINE _GL_EXTERN_INLINE +#include "xsize.h" diff --git a/lib/xsize.h b/lib/xsize.h index 38d1afd3f..831224398 100644 --- a/lib/xsize.h +++ b/lib/xsize.h @@ -27,6 +27,11 @@ # include <stdint.h> #endif +_GL_INLINE_HEADER_BEGIN +#ifndef XSIZE_INLINE +# define XSIZE_INLINE _GL_INLINE +#endif + /* The size of memory objects is often computed through expressions of type size_t. Example: void* p = malloc (header_size + n * element_size). @@ -48,7 +53,7 @@ ((N) <= SIZE_MAX ? (size_t) (N) : SIZE_MAX) /* Sum of two sizes, with overflow check. */ -static inline size_t +XSIZE_INLINE size_t #if __GNUC__ >= 3 __attribute__ ((__pure__)) #endif @@ -59,7 +64,7 @@ xsum (size_t size1, size_t size2) } /* Sum of three sizes, with overflow check. */ -static inline size_t +XSIZE_INLINE size_t #if __GNUC__ >= 3 __attribute__ ((__pure__)) #endif @@ -69,7 +74,7 @@ xsum3 (size_t size1, size_t size2, size_t size3) } /* Sum of four sizes, with overflow check. */ -static inline size_t +XSIZE_INLINE size_t #if __GNUC__ >= 3 __attribute__ ((__pure__)) #endif @@ -79,7 +84,7 @@ xsum4 (size_t size1, size_t size2, size_t size3, size_t size4) } /* Maximum of two sizes, with overflow check. */ -static inline size_t +XSIZE_INLINE size_t #if __GNUC__ >= 3 __attribute__ ((__pure__)) #endif @@ -92,7 +97,7 @@ xmax (size_t size1, size_t size2) /* Multiplication of a count with an element size, with overflow check. The count must be >= 0 and the element size must be > 0. - This is a macro, not an inline function, so that it works correctly even + This is a macro, not a function, so that it works correctly even when N is of a wider type and N > SIZE_MAX. */ #define xtimes(N, ELSIZE) \ ((N) <= SIZE_MAX / (ELSIZE) ? (size_t) (N) * (ELSIZE) : SIZE_MAX) @@ -104,4 +109,6 @@ xmax (size_t size1, size_t size2) #define size_in_bounds_p(SIZE) \ ((SIZE) != SIZE_MAX) +_GL_INLINE_HEADER_END + #endif /* _XSIZE_H */ diff --git a/libguile/dynl.c b/libguile/dynl.c index 72305a41b..79198e64c 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -26,6 +26,7 @@ #endif #include <alloca.h> +#include <string.h> /* "dynl.c" dynamically link&load object files. Author: Aubrey Jaffer @@ -61,6 +62,7 @@ maybe_drag_in_eprintf () #include "libguile/validate.h" #include "libguile/dynwind.h" #include "libguile/foreign.h" +#include "libguile/gc.h" #include <ltdl.h> @@ -75,18 +77,78 @@ maybe_drag_in_eprintf () */ /* njrev: not threadsafe, protection needed as described above */ + +/* LT_PATH_SEP-separated extension library search path, searched last */ +static char *system_extensions_path; + static void * sysdep_dynl_link (const char *fname, const char *subr) { lt_dlhandle handle; - if (fname != NULL) - handle = lt_dlopenext (fname); - else + if (fname == NULL) /* Return a handle for the program as a whole. */ handle = lt_dlopen (NULL); + else + { + handle = lt_dlopenext (fname); - if (NULL == handle) + if (handle == NULL +#ifdef LT_DIRSEP_CHAR + && strchr (fname, LT_DIRSEP_CHAR) == NULL +#endif + && strchr (fname, '/') == NULL) + { + /* FNAME contains no directory separators and was not in the + usual library search paths, so now we search for it in + SYSTEM_EXTENSIONS_PATH. */ + char *fname_attempt + = scm_gc_malloc_pointerless (strlen (system_extensions_path) + + strlen (fname) + 2, + "dynl fname_attempt"); + char *path; /* remaining path to search */ + char *end; /* end of current path component */ + char *s; + + /* Iterate over the components of SYSTEM_EXTENSIONS_PATH */ + for (path = system_extensions_path; + *path != '\0'; + path = (*end == '\0') ? end : (end + 1)) + { + /* Find end of path component */ + end = strchr (path, LT_PATHSEP_CHAR); + if (end == NULL) + end = strchr (path, '\0'); + + /* Skip empty path components */ + if (path == end) + continue; + + /* Construct FNAME_ATTEMPT, starting with path component */ + s = fname_attempt; + memcpy (s, path, end - path); + s += end - path; + + /* Append directory separator, but avoid duplicates */ + if (s[-1] != '/' +#ifdef LT_DIRSEP_CHAR + && s[-1] != LT_DIRSEP_CHAR +#endif + ) + *s++ = '/'; + + /* Finally, append FNAME (including null terminator) */ + strcpy (s, fname); + + /* Try to load it, and terminate the search if successful */ + handle = lt_dlopenext (fname_attempt); + if (handle != NULL) + break; + } + } + } + + if (handle == NULL) { SCM fn; SCM msg; @@ -120,30 +182,6 @@ sysdep_dynl_value (const char *symb, void *handle, const char *subr) return fptr; } -/* Augment environment variable VARIABLE with VALUE, assuming VARIABLE - is a path kind of variable. */ -static void -augment_env (const char *variable, const char *value) -{ - const char *env; - - env = getenv (variable); - if (env != NULL) - { - char *new_value; - static const char path_sep[] = { LT_PATHSEP_CHAR, 0 }; - - new_value = alloca (strlen (env) + strlen (value) + 2); - strcpy (new_value, env); - strcat (new_value, path_sep); - strcat (new_value, value); - - setenv (variable, new_value, 1); - } - else - setenv (variable, value, 1); -} - static void sysdep_dynl_init () { @@ -151,26 +189,32 @@ sysdep_dynl_init () lt_dlinit (); + /* Initialize 'system_extensions_path' from + $GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set: + <SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>. + + 'lt_dladdsearchdir' can't be used because it is searched before + the system-dependent search path, which is the one 'libtool + --mode=execute -dlopen' fiddles with (info "(libtool) Libltdl + Interface"). See + <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>. + + The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH + can't be used because they would be propagated to subprocesses + which may cause problems for other programs. See + <http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */ + env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH"); - if (env && strcmp (env, "") == 0) - /* special-case interpret system-ltdl-path=="" as meaning no system path, - which is the case during the build */ - ; - else if (env) - /* FIXME: should this be a colon-separated path? Or is the only point to - allow the build system to turn off the installed extensions path? */ - lt_dladdsearchdir (env); + if (env) + system_extensions_path = env; else { - /* Add SCM_LIB_DIR and SCM_EXTENSIONS_DIR to the loader's search - path. `lt_dladdsearchdir' and $LTDL_LIBRARY_PATH can't be used - for that because they are searched before the system-dependent - search path, which is the one `libtool --mode=execute -dlopen' - fiddles with (info "(libtool) Libltdl Interface"). See - <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html> - for details. */ - augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_LIB_DIR); - augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_EXTENSIONS_DIR); + system_extensions_path + = scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR) + + strlen (SCM_EXTENSIONS_DIR) + 2, + "system_extensions_path"); + sprintf (system_extensions_path, "%s%c%s", + SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR); } } diff --git a/libguile/eval.c b/libguile/eval.c index d7ab5627f..4076d16b7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -109,16 +109,16 @@ static scm_t_bits scm_tc16_boot_closure; #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x) #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x) #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x)) -#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x))) -#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x)))) +#define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))) /* NB: One may only call the following accessors if the closure is not FIXED. */ -#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x))) -#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x)))) +#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x)))) /* NB: One may only call the following accessors if the closure is not REST. */ #define BOOT_CLOSURE_IS_FULL(x) (1) #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \ do { SCM fu = fu_; \ - body = CAR (fu); fu = CDR (fu); \ + body = CAR (fu); fu = CDDR (fu); \ \ rest = kw = alt = SCM_BOOL_F; \ inits = SCM_EOL; \ diff --git a/libguile/load.c b/libguile/load.c index 86d7e53fb..3b11a7c98 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -221,6 +221,9 @@ static SCM *scm_loc_fresh_auto_compile; /* The fallback path for auto-compilation */ static SCM *scm_loc_compile_fallback_path; +/* Ellipsis: "..." */ +static SCM scm_ellipsis; + SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, (SCM path, SCM tail), "Parse @var{path}, which is expected to be a colon-separated\n" @@ -243,6 +246,32 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0, + (SCM path, SCM base), + "Parse @var{path}, which is expected to be a colon-separated\n" + "string, into a list and return the resulting list with\n" + "@var{base} (a list) spliced in place of the @code{...} path\n" + "component, if present, or else @var{base} is added to the end.\n" + "If @var{path} is @code{#f}, @var{base} is returned.") +#define FUNC_NAME s_scm_parse_path_with_ellipsis +{ + SCM lst = scm_parse_path (path, SCM_EOL); + SCM walk = lst; + SCM *prev = &lst; + + while (!scm_is_null (walk) && + scm_is_false (scm_equal_p (scm_car (walk), scm_ellipsis))) + { + prev = SCM_CDRLOC (walk); + walk = *prev; + } + *prev = scm_is_null (walk) + ? base + : scm_append (scm_list_2 (base, scm_cdr (walk))); + return lst; +} +#undef FUNC_NAME + /* Initialize the global variable %load-path, given the value of the SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the @@ -316,11 +345,11 @@ scm_init_load_path () env = getenv ("GUILE_LOAD_PATH"); if (env) - path = scm_parse_path (scm_from_locale_string (env), path); + path = scm_parse_path_with_ellipsis (scm_from_locale_string (env), path); env = getenv ("GUILE_LOAD_COMPILED_PATH"); if (env) - cpath = scm_parse_path (scm_from_locale_string (env), cpath); + cpath = scm_parse_path_with_ellipsis (scm_from_locale_string (env), cpath); *scm_loc_load_path = path; *scm_loc_load_compiled_path = cpath; @@ -1047,6 +1076,8 @@ scm_init_load () scm_loc_fresh_auto_compile = SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F)); + scm_ellipsis = scm_from_latin1_string ("..."); + the_reader = scm_make_fluid_with_default (SCM_BOOL_F); scm_c_define("current-reader", the_reader); diff --git a/libguile/load.h b/libguile/load.h index 0bddac2b4..698bbaf6c 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -27,6 +27,7 @@ SCM_API SCM scm_parse_path (SCM path, SCM tail); +SCM_API SCM scm_parse_path_with_ellipsis (SCM path, SCM base); SCM_API SCM scm_primitive_load (SCM filename); SCM_API SCM scm_c_primitive_load (const char *filename); SCM_API SCM scm_sys_package_data_dir (void); diff --git a/libguile/memoize.c b/libguile/memoize.c index 1be276b36..af6861001 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -1,6 +1,7 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 - * Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 + * Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of @@ -78,8 +79,9 @@ scm_t_bits scm_tc16_memoized; #define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \ scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \ alt, SCM_UNDEFINED) -#define MAKMEMO_LAMBDA(body, arity) \ - MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity))) +#define MAKMEMO_LAMBDA(body, arity, docstring) \ + MAKMEMO (SCM_M_LAMBDA, \ + scm_cons (body, scm_cons (docstring, arity))) #define MAKMEMO_LET(inits, body) \ MAKMEMO (SCM_M_LET, scm_cons (inits, body)) #define MAKMEMO_QUOTE(exp) \ @@ -283,7 +285,21 @@ memoize (SCM exp, SCM env) case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case. */ - return memoize (REF (exp, LAMBDA, BODY), env); + { + SCM meta, docstring, proc; + + meta = REF (exp, LAMBDA, META); + docstring = scm_assoc_ref (meta, scm_sym_documentation); + + proc = memoize (REF (exp, LAMBDA, BODY), env); + if (scm_is_string (docstring)) + { + SCM args = SCM_MEMOIZED_ARGS (proc); + SCM_SETCAR (SCM_CDR (args), docstring); + } + + return proc; + } case SCM_EXPANDED_LAMBDA_CASE: { @@ -365,7 +381,8 @@ memoize (SCM exp, SCM env) else arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); - return MAKMEMO_LAMBDA (memoize (body, new_env), arity); + return MAKMEMO_LAMBDA (memoize (body, new_env), arity, + SCM_BOOL_F /* docstring */); } case SCM_EXPANDED_LET: @@ -667,39 +684,43 @@ unmemoize (const SCM expr) return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)), unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args))); case SCM_M_LAMBDA: - if (scm_is_null (CDDR (args))) - return scm_list_3 (scm_sym_lambda, - scm_make_list (CADR (args), sym_placeholder), - unmemoize (CAR (args))); - else if (scm_is_null (CDDDR (args))) - { - SCM formals = scm_make_list (CADR (args), sym_placeholder); - return scm_list_3 (scm_sym_lambda, - scm_is_true (CADDR (args)) - ? scm_cons_star (sym_placeholder, formals) - : formals, - unmemoize (CAR (args))); - } - else - { - SCM body = CAR (args), spec = CDR (args), alt, tail; - - alt = CADDR (CDDDR (spec)); - if (scm_is_true (alt)) - tail = CDR (unmemoize (alt)); - else - tail = SCM_EOL; - - return scm_cons - (sym_case_lambda_star, - scm_cons (scm_list_2 (scm_list_5 (CAR (spec), - CADR (spec), - CADDR (spec), - CADDDR (spec), - unmemoize_exprs (CADR (CDDDR (spec)))), - unmemoize (body)), - tail)); - } + { + SCM body = CAR (args), spec = CDDR (args); + + if (scm_is_null (CDR (spec))) + return scm_list_3 (scm_sym_lambda, + scm_make_list (CAR (spec), sym_placeholder), + unmemoize (CAR (args))); + else if (scm_is_null (SCM_CDDR (spec))) + { + SCM formals = scm_make_list (CAR (spec), sym_placeholder); + return scm_list_3 (scm_sym_lambda, + scm_is_true (CADR (spec)) + ? scm_cons_star (sym_placeholder, formals) + : formals, + unmemoize (CAR (args))); + } + else + { + SCM alt, tail; + + alt = CADDR (CDDDR (spec)); + if (scm_is_true (alt)) + tail = CDR (unmemoize (alt)); + else + tail = SCM_EOL; + + return scm_cons + (sym_case_lambda_star, + scm_cons (scm_list_2 (scm_list_5 (CAR (spec), + CADR (spec), + CADDR (spec), + CADDDR (spec), + unmemoize_exprs (CADR (CDDDR (spec)))), + unmemoize (body)), + tail)); + } + } case SCM_M_LET: return scm_list_3 (scm_sym_let, unmemoize_bindings (CAR (args)), diff --git a/libguile/numbers.c b/libguile/numbers.c index 63a6501dd..01f8e05ac 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -7643,10 +7643,16 @@ scm_product (SCM x, SCM y) if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - scm_t_inum kk = xx * yy; - SCM k = SCM_I_MAKINUM (kk); - if ((kk == SCM_I_INUM (k)) && (kk / xx == yy)) - return k; +#if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64 + scm_t_int64 kk = xx * (scm_t_int64) yy; + if (SCM_FIXABLE (kk)) + return SCM_I_MAKINUM (kk); +#else + scm_t_inum axx = (xx > 0) ? xx : -xx; + scm_t_inum ayy = (yy > 0) ? yy : -yy; + if (SCM_MOST_POSITIVE_FIXNUM / axx >= ayy) + return SCM_I_MAKINUM (xx * yy); +#endif else { SCM result = scm_i_inum2big (xx); diff --git a/libguile/posix.c b/libguile/posix.c index 25476e513..baa711b8b 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of @@ -2388,10 +2389,12 @@ scm_init_posix () #include "libguile/cpp-SIG.c" #include "libguile/posix.x" +#ifdef HAVE_FORK scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_popen", (scm_t_extension_init_func) scm_init_popen, NULL); +#endif /* HAVE_FORK */ } /* diff --git a/libguile/procs.c b/libguile/procs.c index 7a2f491d9..5899df035 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009, + * 2010, 2011, 2012 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of @@ -64,7 +65,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, } #undef FUNC_NAME -SCM_SYMBOL (sym_documentation, "documentation"); +SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation"); SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, (SCM proc), @@ -75,7 +76,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, #define FUNC_NAME s_scm_procedure_documentation { SCM_VALIDATE_PROC (SCM_ARG1, proc); - return scm_procedure_property (proc, sym_documentation); + return scm_procedure_property (proc, scm_sym_documentation); } #undef FUNC_NAME diff --git a/libguile/procs.h b/libguile/procs.h index a4dfaff3c..a35872e3d 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -3,7 +3,8 @@ #ifndef SCM_PROCS_H #define SCM_PROCS_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009, + * 2012 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -36,6 +37,8 @@ SCM_API SCM scm_procedure (SCM proc); SCM_API SCM scm_setter (SCM proc); SCM_INTERNAL void scm_init_procs (void); +SCM_INTERNAL SCM scm_sym_documentation; + #endif /* SCM_PROCS_H */ /* diff --git a/libguile/simpos.c b/libguile/simpos.c index 5c8fe9623..8859d4f15 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,6 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009, 2010 Free Software - * Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009, + * 2010, 2012 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of @@ -26,6 +26,7 @@ #include <errno.h> #include <signal.h> /* for SIG constants */ #include <stdlib.h> /* for getenv */ +#include <stdio.h> #include "libguile/_scm.h" @@ -137,10 +138,17 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, if (pid == 0) { /* child */ - execvp (execargv[0], execargv); - SCM_SYSERROR; - /* not reached. */ - return SCM_BOOL_F; + execvp (execargv[0], execargv); + + /* Something went wrong. */ + fprintf (stderr, "In execvp of %s: %s\n", + execargv[0], strerror (errno)); + + /* Exit directly instead of throwing, because otherwise this + process may keep on running. Use exit status 127, like + shells in this case, as per POSIX + <http://pubs.opengroup.org/onlinepubs/007904875/utilities/xcu_chap02.html#tag_02_09_01_01>. */ + _exit (127); } else { diff --git a/libguile/socket.c b/libguile/socket.c index 149ec005f..232041479 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, - * 2006, 2007, 2009, 2011 Free Software Foundation, Inc. + * 2006, 2007, 2009, 2011, 2012 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -26,6 +26,7 @@ #include <errno.h> #include <gmp.h> +#include <verify.h> #include "libguile/_scm.h" #include "libguile/arrays.h" @@ -738,6 +739,11 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, } #undef FUNC_NAME +/* Our documentation hard-codes this mapping, so make sure it holds. */ +verify (SHUT_RD == 0); +verify (SHUT_WR == 1); +verify (SHUT_RDWR == 2); + SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, (SCM sock, SCM how), "Sockets can be closed simply by using @code{close-port}. The\n" diff --git a/libguile/values.c b/libguile/values.c index d135da01f..670e22294 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -97,8 +97,8 @@ scm_c_value_ref (SCM obj, size_t idx) scm_error (scm_out_of_range_key, "scm_c_value_ref", "Too few values in ~S to access index ~S", - scm_list_2 (obj, scm_from_unsigned_integer (idx)), - scm_list_1 (scm_from_unsigned_integer (idx))); + scm_list_2 (obj, scm_from_size_t (idx)), + scm_list_1 (scm_from_size_t (idx))); } SCM_DEFINE (scm_values, "values", 0, 0, 1, diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index 37df6fc5f..ea51ac420 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,4 +1,4 @@ -# canonicalize.m4 serial 24 +# canonicalize.m4 serial 26 dnl Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc. @@ -106,10 +106,10 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS], [gl_cv_func_realpath_works=yes], [gl_cv_func_realpath_works=no], [case "$host_os" in - # Guess yes on glibc systems. - *gnu*) gl_cv_func_realpath_works="guessing yes" ;; - # If we don't know, assume the worst. - *) gl_cv_func_realpath_works="guessing no" ;; + # Guess yes on glibc systems. + *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_realpath_works="guessing no" ;; esac ]) rm -rf conftest.a conftest.d diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 index 75f17e2f1..9e5df45d3 100644 --- a/m4/eealloc.m4 +++ b/m4/eealloc.m4 @@ -1,4 +1,4 @@ -# eealloc.m4 serial 2 +# eealloc.m4 serial 3 dnl Copyright (C) 2003, 2009-2012 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -8,7 +8,6 @@ AC_DEFUN([gl_EEALLOC], [ AC_REQUIRE([gl_EEMALLOC]) AC_REQUIRE([gl_EEREALLOC]) - AC_REQUIRE([AC_C_INLINE]) ]) AC_DEFUN([gl_EEMALLOC], diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index 1e76ba270..4e33ba853 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,4 +1,4 @@ -# errno_h.m4 serial 11 +# errno_h.m4 serial 12 dnl Copyright (C) 2004, 2006, 2008-2012 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -58,6 +58,9 @@ booboo #if !defined ENOTRECOVERABLE booboo #endif +#if !defined EILSEQ +booboo +#endif ], [gl_cv_header_errno_h_complete=no], [gl_cv_header_errno_h_complete=yes]) diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4 new file mode 100644 index 000000000..600c8d3fa --- /dev/null +++ b/m4/extern-inline.m4 @@ -0,0 +1,57 @@ +dnl 'extern inline' a la ISO C99. + +dnl Copyright 2012 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_EXTERN_INLINE], +[ + AC_REQUIRE([AC_C_INLINE]) + AH_VERBATIM([extern_inline], +[/* _GL_INLINE is a portable alternative to ISO C99 plain 'inline'. + _GL_EXTERN_INLINE is a portable alternative to 'extern inline'. + _GL_INLINE_HEADER_BEGIN contains useful stuff to put + in an include file, before uses of _GL_INLINE. + It suppresses GCC's bogus "no previous prototype for 'FOO'" diagnostic, + when FOO is an inline function in the header; see + <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=54113>. + _GL_INLINE_HEADER_END contains useful stuff to put + in the same include file, after uses of _GL_INLINE. */ +#if (__GNUC__ \ + ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \ + : 199901L <= __STDC_VERSION__) +# define _GL_INLINE inline +# define _GL_EXTERN_INLINE extern inline +#elif 2 < __GNUC__ + (7 <= __GNUC_MINOR__) +# if __GNUC_GNU_INLINE__ + /* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */ +# define _GL_INLINE extern inline __attribute__ ((__gnu_inline__)) +# else +# define _GL_INLINE extern inline +# endif +# define _GL_EXTERN_INLINE extern +#else +# define _GL_INLINE static inline +# define _GL_EXTERN_INLINE static inline +#endif + +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +# if defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ +# define _GL_INLINE_HEADER_CONST_PRAGMA +# else +# define _GL_INLINE_HEADER_CONST_PRAGMA \ + _Pragma ("GCC diagnostic ignored \"-Wsuggest-attribute=const\"") +# endif +# define _GL_INLINE_HEADER_BEGIN \ + _Pragma ("GCC diagnostic push") \ + _Pragma ("GCC diagnostic ignored \"-Wmissing-prototypes\"") \ + _Pragma ("GCC diagnostic ignored \"-Wmissing-declarations\"") \ + _GL_INLINE_HEADER_CONST_PRAGMA +# define _GL_INLINE_HEADER_END \ + _Pragma ("GCC diagnostic pop") +#else +# define _GL_INLINE_HEADER_BEGIN +# define _GL_INLINE_HEADER_END +#endif]) +]) diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4 index 9862741f3..740e78b68 100644 --- a/m4/fcntl-o.m4 +++ b/m4/fcntl-o.m4 @@ -50,7 +50,18 @@ AC_DEFUN([gl_FCNTL_O_FLAGS], #if HAVE_SYMLINK { static char const sym[] = "conftest.sym"; - if (symlink (".", sym) != 0) + if (symlink ("/dev/null", sym) != 0) + result |= 2; + else + { + int fd = open (sym, O_WRONLY | O_NOFOLLOW | O_CREAT, 0); + if (fd >= 0) + { + close (fd); + result |= 4; + } + } + if (unlink (sym) != 0 || symlink (".", sym) != 0) result |= 2; else { diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 1b6406025..50102b260 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -121,5 +121,5 @@ gl_MAKEFILE_NAME([]) gl_LIBTOOL gl_MACRO_PREFIX([gl]) gl_PO_DOMAIN([]) -gl_WITNESS_C_DOMAIN([]) +gl_WITNESS_C_MACRO([]) gl_VC_FILES([false]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 13bf4e8ad..b52b97285 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -70,6 +70,7 @@ AC_DEFUN([gl_EARLY], # Code from module errno: # Code from module extensions: AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + # Code from module extern-inline: # Code from module fcntl-h: # Code from module fd-hook: # Code from module float: @@ -232,482 +233,482 @@ AC_DEFUN([gl_INIT], m4_pushdef([gl_LIBSOURCES_DIR], []) gl_COMMON gl_source_base='lib' -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([accept]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([accept]) -gl_FUNC_ALLOCA -gl_HEADER_ARPA_INET -AC_PROG_MKDIR_P -AC_REQUIRE([AC_C_INLINE]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([bind]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([bind]) -gl_FUNC_BTOWC -if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then - AC_LIBOBJ([btowc]) - gl_PREREQ_BTOWC -fi -gl_WCHAR_MODULE_INDICATOR([btowc]) -gl_BYTESWAP -gl_CANONICALIZE_LGPL -if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then - AC_LIBOBJ([canonicalize-lgpl]) -fi -gl_MODULE_INDICATOR([canonicalize-lgpl]) -gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name]) -gl_STDLIB_MODULE_INDICATOR([realpath]) -gl_FUNC_CEIL -if test $REPLACE_CEIL = 1; then - AC_LIBOBJ([ceil]) -fi -gl_MATH_MODULE_INDICATOR([ceil]) -gl_UNISTD_MODULE_INDICATOR([chdir]) -gl_CLOCK_TIME -gl_FUNC_CLOSE -if test $REPLACE_CLOSE = 1; then - AC_LIBOBJ([close]) -fi -gl_UNISTD_MODULE_INDICATOR([close]) -gl_CONFIGMAKE_PREP -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([connect]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([connect]) -gl_DIRENT_H -gl_FUNC_DIRFD -if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then - AC_LIBOBJ([dirfd]) - gl_PREREQ_DIRFD -fi -gl_DIRENT_MODULE_INDICATOR([dirfd]) -gl_DIRNAME_LGPL -gl_DOUBLE_SLASH_ROOT -gl_FUNC_DUPLOCALE -if test $REPLACE_DUPLOCALE = 1; then - AC_LIBOBJ([duplocale]) - gl_PREREQ_DUPLOCALE -fi -gl_LOCALE_MODULE_INDICATOR([duplocale]) -gl_ENVIRON -gl_UNISTD_MODULE_INDICATOR([environ]) -gl_HEADER_ERRNO_H -gl_FCNTL_H -gl_FLOAT_H -if test $REPLACE_FLOAT_LDBL = 1; then - AC_LIBOBJ([float]) -fi -if test $REPLACE_ITOLD = 1; then - AC_LIBOBJ([itold]) -fi -gl_FUNC_FLOCK -if test $HAVE_FLOCK = 0; then - AC_LIBOBJ([flock]) - gl_PREREQ_FLOCK -fi -gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) -gl_FUNC_FLOOR -if test $REPLACE_FLOOR = 1; then - AC_LIBOBJ([floor]) -fi -gl_MATH_MODULE_INDICATOR([floor]) -gl_FUNC_FREXP -if test $gl_func_frexp != yes; then - AC_LIBOBJ([frexp]) -fi -gl_MATH_MODULE_INDICATOR([frexp]) -gl_FUNC_FSTAT -if test $REPLACE_FSTAT = 1; then - AC_LIBOBJ([fstat]) - gl_PREREQ_FSTAT -fi -gl_SYS_STAT_MODULE_INDICATOR([fstat]) -gl_FUNC -gl_GETADDRINFO -if test $HAVE_GETADDRINFO = 0; then - AC_LIBOBJ([getaddrinfo]) -fi -if test $HAVE_DECL_GAI_STRERROR = 0 || test $REPLACE_GAI_STRERROR = 1; then - AC_LIBOBJ([gai_strerror]) -fi -gl_NETDB_MODULE_INDICATOR([getaddrinfo]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([getpeername]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([getpeername]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([getsockname]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([getsockname]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([getsockopt]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([getsockopt]) -AC_SUBST([LIBINTL]) -AC_SUBST([LTLIBINTL]) -# Autoconf 2.61a.99 and earlier don't support linking a file only -# in VPATH builds. But since GNUmakefile is for maintainer use -# only, it does not matter if we skip the link with older autoconf. -# Automake 1.10.1 and earlier try to remove GNUmakefile in non-VPATH -# builds, so use a shell variable to bypass this. -GNUmakefile=GNUmakefile -m4_if(m4_version_compare([2.61a.100], - m4_defn([m4_PACKAGE_VERSION])), [1], [], - [AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [], - [GNUmakefile=$GNUmakefile])]) -gl_HOSTENT -AM_ICONV -m4_ifdef([gl_ICONV_MODULE_INDICATOR], - [gl_ICONV_MODULE_INDICATOR([iconv])]) -gl_ICONV_H -gl_FUNC_ICONV_OPEN -if test $REPLACE_ICONV_OPEN = 1; then - AC_LIBOBJ([iconv_open]) -fi -if test $REPLACE_ICONV = 1; then - AC_LIBOBJ([iconv]) - AC_LIBOBJ([iconv_close]) -fi -gl_FUNC_ICONV_OPEN_UTF -gl_FUNC_INET_NTOP -if test $HAVE_INET_NTOP = 0 || test $REPLACE_INET_NTOP = 1; then - AC_LIBOBJ([inet_ntop]) - gl_PREREQ_INET_NTOP -fi -gl_ARPA_INET_MODULE_INDICATOR([inet_ntop]) -gl_FUNC_INET_PTON -if test $HAVE_INET_PTON = 0 || test $REPLACE_INET_NTOP = 1; then - AC_LIBOBJ([inet_pton]) - gl_PREREQ_INET_PTON -fi -gl_ARPA_INET_MODULE_INDICATOR([inet_pton]) -gl_INLINE -gl_ISINF -if test $REPLACE_ISINF = 1; then - AC_LIBOBJ([isinf]) -fi -gl_MATH_MODULE_INDICATOR([isinf]) -gl_ISNAN -gl_MATH_MODULE_INDICATOR([isnan]) -gl_FUNC_ISNAND -m4_ifdef([gl_ISNAN], [ - AC_REQUIRE([gl_ISNAN]) -]) -if test $HAVE_ISNAND = 0 || test $REPLACE_ISNAN = 1; then - AC_LIBOBJ([isnand]) - gl_PREREQ_ISNAND -fi -gl_MATH_MODULE_INDICATOR([isnand]) -gl_FUNC_ISNAND_NO_LIBM -if test $gl_func_isnand_no_libm != yes; then - AC_LIBOBJ([isnand]) - gl_PREREQ_ISNAND -fi -gl_FUNC_ISNANF -m4_ifdef([gl_ISNAN], [ - AC_REQUIRE([gl_ISNAN]) -]) -if test $HAVE_ISNANF = 0 || test $REPLACE_ISNAN = 1; then - AC_LIBOBJ([isnanf]) - gl_PREREQ_ISNANF -fi -gl_MATH_MODULE_INDICATOR([isnanf]) -gl_FUNC_ISNANL -m4_ifdef([gl_ISNAN], [ - AC_REQUIRE([gl_ISNAN]) -]) -if test $HAVE_ISNANL = 0 || test $REPLACE_ISNAN = 1; then - AC_LIBOBJ([isnanl]) - gl_PREREQ_ISNANL -fi -gl_MATH_MODULE_INDICATOR([isnanl]) -gl_LANGINFO_H -AC_REQUIRE([gl_LARGEFILE]) -gl_FUNC_LDEXP -gl_LD_VERSION_SCRIPT -gl_VISIBILITY -gl_LIBUNISTRING -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([listen]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([listen]) -gl_LOCALCHARSET -LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(abs_top_builddir)/$gl_source_base\"" -AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) -gl_LOCALE_H -gl_FUNC_LOCALECONV -if test $REPLACE_LOCALECONV = 1; then - AC_LIBOBJ([localeconv]) - gl_PREREQ_LOCALECONV -fi -gl_LOCALE_MODULE_INDICATOR([localeconv]) -AC_REQUIRE([gl_FUNC_LOG]) -if test $REPLACE_LOG = 1; then - AC_LIBOBJ([log]) -fi -gl_MATH_MODULE_INDICATOR([log]) -gl_FUNC_LOG1P -if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then - AC_LIBOBJ([log1p]) -fi -gl_MATH_MODULE_INDICATOR([log1p]) -gl_FUNC_LSTAT -if test $REPLACE_LSTAT = 1; then - AC_LIBOBJ([lstat]) - gl_PREREQ_LSTAT -fi -gl_SYS_STAT_MODULE_INDICATOR([lstat]) -AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER], - [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])]) -gl_FUNC_MALLOC_GNU -if test $REPLACE_MALLOC = 1; then - AC_LIBOBJ([malloc]) -fi -gl_MODULE_INDICATOR([malloc-gnu]) -gl_FUNC_MALLOC_POSIX -if test $REPLACE_MALLOC = 1; then - AC_LIBOBJ([malloc]) -fi -gl_STDLIB_MODULE_INDICATOR([malloc-posix]) -gl_MALLOCA -gl_MATH_H -gl_FUNC_MBRTOWC -if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then - AC_LIBOBJ([mbrtowc]) - gl_PREREQ_MBRTOWC -fi -gl_WCHAR_MODULE_INDICATOR([mbrtowc]) -gl_FUNC_MBSINIT -if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then - AC_LIBOBJ([mbsinit]) - gl_PREREQ_MBSINIT -fi -gl_WCHAR_MODULE_INDICATOR([mbsinit]) -gl_FUNC_MBTOWC -if test $REPLACE_MBTOWC = 1; then - AC_LIBOBJ([mbtowc]) - gl_PREREQ_MBTOWC -fi -gl_STDLIB_MODULE_INDICATOR([mbtowc]) -gl_FUNC_MEMCHR -if test $HAVE_MEMCHR = 0 || test $REPLACE_MEMCHR = 1; then - AC_LIBOBJ([memchr]) - gl_PREREQ_MEMCHR -fi -gl_STRING_MODULE_INDICATOR([memchr]) -gl_MSVC_INVAL -if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then - AC_LIBOBJ([msvc-inval]) -fi -gl_MSVC_NOTHROW -if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then - AC_LIBOBJ([msvc-nothrow]) -fi -gl_MULTIARCH -gl_HEADER_NETDB -gl_HEADER_NETINET_IN -AC_PROG_MKDIR_P -gl_FUNC_NL_LANGINFO -if test $HAVE_NL_LANGINFO = 0 || test $REPLACE_NL_LANGINFO = 1; then - AC_LIBOBJ([nl_langinfo]) -fi -gl_LANGINFO_MODULE_INDICATOR([nl_langinfo]) -gl_NPROC -gl_FUNC_OPEN -if test $REPLACE_OPEN = 1; then - AC_LIBOBJ([open]) - gl_PREREQ_OPEN -fi -gl_FCNTL_MODULE_INDICATOR([open]) -gl_PATHMAX -gl_FUNC_PIPE2 -gl_UNISTD_MODULE_INDICATOR([pipe2]) -gl_FUNC_PUTENV -if test $REPLACE_PUTENV = 1; then - AC_LIBOBJ([putenv]) -fi -gl_STDLIB_MODULE_INDICATOR([putenv]) -gl_FUNC_RAISE -if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then - AC_LIBOBJ([raise]) - gl_PREREQ_RAISE -fi -gl_SIGNAL_MODULE_INDICATOR([raise]) -gl_FUNC_READ -if test $REPLACE_READ = 1; then - AC_LIBOBJ([read]) - gl_PREREQ_READ -fi -gl_UNISTD_MODULE_INDICATOR([read]) -gl_FUNC_READLINK -if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then - AC_LIBOBJ([readlink]) - gl_PREREQ_READLINK -fi -gl_UNISTD_MODULE_INDICATOR([readlink]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([recv]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([recv]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([recvfrom]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([recvfrom]) -gl_REGEX -if test $ac_use_included_regex = yes; then - AC_LIBOBJ([regex]) - gl_PREREQ_REGEX -fi -gl_FUNC_RENAME -if test $REPLACE_RENAME = 1; then - AC_LIBOBJ([rename]) -fi -gl_STDIO_MODULE_INDICATOR([rename]) -gl_FUNC_RMDIR -if test $REPLACE_RMDIR = 1; then - AC_LIBOBJ([rmdir]) -fi -gl_UNISTD_MODULE_INDICATOR([rmdir]) -gl_FUNC_ROUND -if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then - AC_LIBOBJ([round]) -fi -gl_MATH_MODULE_INDICATOR([round]) -gl_PREREQ_SAFE_READ -gl_PREREQ_SAFE_WRITE -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([send]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([send]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([sendto]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([sendto]) -gl_SERVENT -gl_FUNC_SETENV -if test $HAVE_SETENV = 0 || test $REPLACE_SETENV = 1; then - AC_LIBOBJ([setenv]) -fi -gl_STDLIB_MODULE_INDICATOR([setenv]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([setsockopt]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([setsockopt]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([shutdown]) -fi -gl_SYS_SOCKET_MODULE_INDICATOR([shutdown]) -gl_SIGNAL_H -gl_SIZE_MAX -gl_FUNC_SNPRINTF -gl_STDIO_MODULE_INDICATOR([snprintf]) -gl_MODULE_INDICATOR([snprintf]) -AC_REQUIRE([gl_HEADER_SYS_SOCKET]) -if test "$ac_cv_header_winsock2_h" = yes; then - AC_LIBOBJ([socket]) -fi -# When this module is used, sockets may actually occur as file descriptors, -# hence it is worth warning if the modules 'close' and 'ioctl' are not used. -m4_ifdef([gl_UNISTD_H_DEFAULTS], [AC_REQUIRE([gl_UNISTD_H_DEFAULTS])]) -m4_ifdef([gl_SYS_IOCTL_H_DEFAULTS], [AC_REQUIRE([gl_SYS_IOCTL_H_DEFAULTS])]) -AC_REQUIRE([gl_PREREQ_SYS_H_WINSOCK2]) -if test "$ac_cv_header_winsock2_h" = yes; then - UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 - SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 -fi -gl_SYS_SOCKET_MODULE_INDICATOR([socket]) -gl_SOCKETLIB -gl_SOCKETS -gl_TYPE_SOCKLEN_T -gt_TYPE_SSIZE_T -gl_FUNC_STAT -if test $REPLACE_STAT = 1; then - AC_LIBOBJ([stat]) - gl_PREREQ_STAT -fi -gl_SYS_STAT_MODULE_INDICATOR([stat]) -gl_STAT_TIME -gl_STAT_BIRTHTIME -gl_STDALIGN_H -AM_STDBOOL_H -gl_STDDEF_H -gl_STDINT_H -gl_STDIO_H -gl_STDLIB_H -gl_FUNC_GNU_STRFTIME -if test $gl_cond_libtool = false; then - gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" - gl_libdeps="$gl_libdeps $LIBICONV" -fi -gl_HEADER_STRING_H -gl_HEADER_SYS_FILE_H -AC_PROG_MKDIR_P -gl_HEADER_SYS_SOCKET -AC_PROG_MKDIR_P -gl_HEADER_SYS_STAT_H -AC_PROG_MKDIR_P -gl_HEADER_SYS_TIME_H -AC_PROG_MKDIR_P -gl_SYS_TYPES_H -AC_PROG_MKDIR_P -gl_HEADER_SYS_UIO -AC_PROG_MKDIR_P -gl_HEADER_TIME_H -gl_TIME_R -if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then - AC_LIBOBJ([time_r]) - gl_PREREQ_TIME_R -fi -gl_TIME_MODULE_INDICATOR([time_r]) -gl_FUNC_TRUNC -if test $HAVE_DECL_TRUNC = 0 || test $REPLACE_TRUNC = 1; then - AC_LIBOBJ([trunc]) -fi -gl_MATH_MODULE_INDICATOR([trunc]) -gl_UNISTD_H -gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h]) -gl_MODULE_INDICATOR([unistr/u8-mbtouc]) -gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc]) -gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) -gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc-unsafe]) -gl_MODULE_INDICATOR([unistr/u8-mbtoucr]) -gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-mbtoucr]) -gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev]) -gl_MODULE_INDICATOR([unistr/u8-uctomb]) -gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb]) -gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h]) -gl_FUNC_VASNPRINTF -gl_FUNC_VSNPRINTF -gl_STDIO_MODULE_INDICATOR([vsnprintf]) -gl_WCHAR_H -gl_FUNC_WCRTOMB -if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then - AC_LIBOBJ([wcrtomb]) - gl_PREREQ_WCRTOMB -fi -gl_WCHAR_MODULE_INDICATOR([wcrtomb]) -gl_WCTYPE_H -gl_FUNC_WRITE -if test $REPLACE_WRITE = 1; then - AC_LIBOBJ([write]) - gl_PREREQ_WRITE -fi -gl_UNISTD_MODULE_INDICATOR([write]) -gl_XSIZE + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([accept]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([accept]) + gl_FUNC_ALLOCA + gl_HEADER_ARPA_INET + AC_PROG_MKDIR_P + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([bind]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([bind]) + gl_FUNC_BTOWC + if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then + AC_LIBOBJ([btowc]) + gl_PREREQ_BTOWC + fi + gl_WCHAR_MODULE_INDICATOR([btowc]) + gl_BYTESWAP + gl_CANONICALIZE_LGPL + if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then + AC_LIBOBJ([canonicalize-lgpl]) + fi + gl_MODULE_INDICATOR([canonicalize-lgpl]) + gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name]) + gl_STDLIB_MODULE_INDICATOR([realpath]) + gl_FUNC_CEIL + if test $REPLACE_CEIL = 1; then + AC_LIBOBJ([ceil]) + fi + gl_MATH_MODULE_INDICATOR([ceil]) + gl_UNISTD_MODULE_INDICATOR([chdir]) + gl_CLOCK_TIME + gl_FUNC_CLOSE + if test $REPLACE_CLOSE = 1; then + AC_LIBOBJ([close]) + fi + gl_UNISTD_MODULE_INDICATOR([close]) + gl_CONFIGMAKE_PREP + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([connect]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([connect]) + gl_DIRENT_H + gl_FUNC_DIRFD + if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then + AC_LIBOBJ([dirfd]) + gl_PREREQ_DIRFD + fi + gl_DIRENT_MODULE_INDICATOR([dirfd]) + gl_DIRNAME_LGPL + gl_DOUBLE_SLASH_ROOT + gl_FUNC_DUPLOCALE + if test $REPLACE_DUPLOCALE = 1; then + AC_LIBOBJ([duplocale]) + gl_PREREQ_DUPLOCALE + fi + gl_LOCALE_MODULE_INDICATOR([duplocale]) + gl_ENVIRON + gl_UNISTD_MODULE_INDICATOR([environ]) + gl_HEADER_ERRNO_H + AC_REQUIRE([gl_EXTERN_INLINE]) + gl_FCNTL_H + gl_FLOAT_H + if test $REPLACE_FLOAT_LDBL = 1; then + AC_LIBOBJ([float]) + fi + if test $REPLACE_ITOLD = 1; then + AC_LIBOBJ([itold]) + fi + gl_FUNC_FLOCK + if test $HAVE_FLOCK = 0; then + AC_LIBOBJ([flock]) + gl_PREREQ_FLOCK + fi + gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) + gl_FUNC_FLOOR + if test $REPLACE_FLOOR = 1; then + AC_LIBOBJ([floor]) + fi + gl_MATH_MODULE_INDICATOR([floor]) + gl_FUNC_FREXP + if test $gl_func_frexp != yes; then + AC_LIBOBJ([frexp]) + fi + gl_MATH_MODULE_INDICATOR([frexp]) + gl_FUNC_FSTAT + if test $REPLACE_FSTAT = 1; then + AC_LIBOBJ([fstat]) + gl_PREREQ_FSTAT + fi + gl_SYS_STAT_MODULE_INDICATOR([fstat]) + gl_FUNC + gl_GETADDRINFO + if test $HAVE_GETADDRINFO = 0; then + AC_LIBOBJ([getaddrinfo]) + fi + if test $HAVE_DECL_GAI_STRERROR = 0 || test $REPLACE_GAI_STRERROR = 1; then + AC_LIBOBJ([gai_strerror]) + fi + gl_NETDB_MODULE_INDICATOR([getaddrinfo]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([getpeername]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([getpeername]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([getsockname]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([getsockname]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([getsockopt]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([getsockopt]) + AC_SUBST([LIBINTL]) + AC_SUBST([LTLIBINTL]) + # Autoconf 2.61a.99 and earlier don't support linking a file only + # in VPATH builds. But since GNUmakefile is for maintainer use + # only, it does not matter if we skip the link with older autoconf. + # Automake 1.10.1 and earlier try to remove GNUmakefile in non-VPATH + # builds, so use a shell variable to bypass this. + GNUmakefile=GNUmakefile + m4_if(m4_version_compare([2.61a.100], + m4_defn([m4_PACKAGE_VERSION])), [1], [], + [AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [], + [GNUmakefile=$GNUmakefile])]) + gl_HOSTENT + AM_ICONV + m4_ifdef([gl_ICONV_MODULE_INDICATOR], + [gl_ICONV_MODULE_INDICATOR([iconv])]) + gl_ICONV_H + gl_FUNC_ICONV_OPEN + if test $REPLACE_ICONV_OPEN = 1; then + AC_LIBOBJ([iconv_open]) + fi + if test $REPLACE_ICONV = 1; then + AC_LIBOBJ([iconv]) + AC_LIBOBJ([iconv_close]) + fi + gl_FUNC_ICONV_OPEN_UTF + gl_FUNC_INET_NTOP + if test $HAVE_INET_NTOP = 0 || test $REPLACE_INET_NTOP = 1; then + AC_LIBOBJ([inet_ntop]) + gl_PREREQ_INET_NTOP + fi + gl_ARPA_INET_MODULE_INDICATOR([inet_ntop]) + gl_FUNC_INET_PTON + if test $HAVE_INET_PTON = 0 || test $REPLACE_INET_NTOP = 1; then + AC_LIBOBJ([inet_pton]) + gl_PREREQ_INET_PTON + fi + gl_ARPA_INET_MODULE_INDICATOR([inet_pton]) + gl_INLINE + gl_ISINF + if test $REPLACE_ISINF = 1; then + AC_LIBOBJ([isinf]) + fi + gl_MATH_MODULE_INDICATOR([isinf]) + gl_ISNAN + gl_MATH_MODULE_INDICATOR([isnan]) + gl_FUNC_ISNAND + m4_ifdef([gl_ISNAN], [ + AC_REQUIRE([gl_ISNAN]) + ]) + if test $HAVE_ISNAND = 0 || test $REPLACE_ISNAN = 1; then + AC_LIBOBJ([isnand]) + gl_PREREQ_ISNAND + fi + gl_MATH_MODULE_INDICATOR([isnand]) + gl_FUNC_ISNAND_NO_LIBM + if test $gl_func_isnand_no_libm != yes; then + AC_LIBOBJ([isnand]) + gl_PREREQ_ISNAND + fi + gl_FUNC_ISNANF + m4_ifdef([gl_ISNAN], [ + AC_REQUIRE([gl_ISNAN]) + ]) + if test $HAVE_ISNANF = 0 || test $REPLACE_ISNAN = 1; then + AC_LIBOBJ([isnanf]) + gl_PREREQ_ISNANF + fi + gl_MATH_MODULE_INDICATOR([isnanf]) + gl_FUNC_ISNANL + m4_ifdef([gl_ISNAN], [ + AC_REQUIRE([gl_ISNAN]) + ]) + if test $HAVE_ISNANL = 0 || test $REPLACE_ISNAN = 1; then + AC_LIBOBJ([isnanl]) + gl_PREREQ_ISNANL + fi + gl_MATH_MODULE_INDICATOR([isnanl]) + gl_LANGINFO_H + AC_REQUIRE([gl_LARGEFILE]) + gl_FUNC_LDEXP + gl_LD_VERSION_SCRIPT + gl_VISIBILITY + gl_LIBUNISTRING + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([listen]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([listen]) + gl_LOCALCHARSET + LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(abs_top_builddir)/$gl_source_base\"" + AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) + gl_LOCALE_H + gl_FUNC_LOCALECONV + if test $REPLACE_LOCALECONV = 1; then + AC_LIBOBJ([localeconv]) + gl_PREREQ_LOCALECONV + fi + gl_LOCALE_MODULE_INDICATOR([localeconv]) + AC_REQUIRE([gl_FUNC_LOG]) + if test $REPLACE_LOG = 1; then + AC_LIBOBJ([log]) + fi + gl_MATH_MODULE_INDICATOR([log]) + gl_FUNC_LOG1P + if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then + AC_LIBOBJ([log1p]) + fi + gl_MATH_MODULE_INDICATOR([log1p]) + gl_FUNC_LSTAT + if test $REPLACE_LSTAT = 1; then + AC_LIBOBJ([lstat]) + gl_PREREQ_LSTAT + fi + gl_SYS_STAT_MODULE_INDICATOR([lstat]) + AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER], + [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])]) + gl_FUNC_MALLOC_GNU + if test $REPLACE_MALLOC = 1; then + AC_LIBOBJ([malloc]) + fi + gl_MODULE_INDICATOR([malloc-gnu]) + gl_FUNC_MALLOC_POSIX + if test $REPLACE_MALLOC = 1; then + AC_LIBOBJ([malloc]) + fi + gl_STDLIB_MODULE_INDICATOR([malloc-posix]) + gl_MALLOCA + gl_MATH_H + gl_FUNC_MBRTOWC + if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then + AC_LIBOBJ([mbrtowc]) + gl_PREREQ_MBRTOWC + fi + gl_WCHAR_MODULE_INDICATOR([mbrtowc]) + gl_FUNC_MBSINIT + if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then + AC_LIBOBJ([mbsinit]) + gl_PREREQ_MBSINIT + fi + gl_WCHAR_MODULE_INDICATOR([mbsinit]) + gl_FUNC_MBTOWC + if test $REPLACE_MBTOWC = 1; then + AC_LIBOBJ([mbtowc]) + gl_PREREQ_MBTOWC + fi + gl_STDLIB_MODULE_INDICATOR([mbtowc]) + gl_FUNC_MEMCHR + if test $HAVE_MEMCHR = 0 || test $REPLACE_MEMCHR = 1; then + AC_LIBOBJ([memchr]) + gl_PREREQ_MEMCHR + fi + gl_STRING_MODULE_INDICATOR([memchr]) + gl_MSVC_INVAL + if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then + AC_LIBOBJ([msvc-inval]) + fi + gl_MSVC_NOTHROW + if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then + AC_LIBOBJ([msvc-nothrow]) + fi + gl_MULTIARCH + gl_HEADER_NETDB + gl_HEADER_NETINET_IN + AC_PROG_MKDIR_P + gl_FUNC_NL_LANGINFO + if test $HAVE_NL_LANGINFO = 0 || test $REPLACE_NL_LANGINFO = 1; then + AC_LIBOBJ([nl_langinfo]) + fi + gl_LANGINFO_MODULE_INDICATOR([nl_langinfo]) + gl_NPROC + gl_FUNC_OPEN + if test $REPLACE_OPEN = 1; then + AC_LIBOBJ([open]) + gl_PREREQ_OPEN + fi + gl_FCNTL_MODULE_INDICATOR([open]) + gl_PATHMAX + gl_FUNC_PIPE2 + gl_UNISTD_MODULE_INDICATOR([pipe2]) + gl_FUNC_PUTENV + if test $REPLACE_PUTENV = 1; then + AC_LIBOBJ([putenv]) + fi + gl_STDLIB_MODULE_INDICATOR([putenv]) + gl_FUNC_RAISE + if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then + AC_LIBOBJ([raise]) + gl_PREREQ_RAISE + fi + gl_SIGNAL_MODULE_INDICATOR([raise]) + gl_FUNC_READ + if test $REPLACE_READ = 1; then + AC_LIBOBJ([read]) + gl_PREREQ_READ + fi + gl_UNISTD_MODULE_INDICATOR([read]) + gl_FUNC_READLINK + if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then + AC_LIBOBJ([readlink]) + gl_PREREQ_READLINK + fi + gl_UNISTD_MODULE_INDICATOR([readlink]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([recv]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([recv]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([recvfrom]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([recvfrom]) + gl_REGEX + if test $ac_use_included_regex = yes; then + AC_LIBOBJ([regex]) + gl_PREREQ_REGEX + fi + gl_FUNC_RENAME + if test $REPLACE_RENAME = 1; then + AC_LIBOBJ([rename]) + fi + gl_STDIO_MODULE_INDICATOR([rename]) + gl_FUNC_RMDIR + if test $REPLACE_RMDIR = 1; then + AC_LIBOBJ([rmdir]) + fi + gl_UNISTD_MODULE_INDICATOR([rmdir]) + gl_FUNC_ROUND + if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then + AC_LIBOBJ([round]) + fi + gl_MATH_MODULE_INDICATOR([round]) + gl_PREREQ_SAFE_READ + gl_PREREQ_SAFE_WRITE + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([send]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([send]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([sendto]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([sendto]) + gl_SERVENT + gl_FUNC_SETENV + if test $HAVE_SETENV = 0 || test $REPLACE_SETENV = 1; then + AC_LIBOBJ([setenv]) + fi + gl_STDLIB_MODULE_INDICATOR([setenv]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([setsockopt]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([setsockopt]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([shutdown]) + fi + gl_SYS_SOCKET_MODULE_INDICATOR([shutdown]) + gl_SIGNAL_H + gl_SIZE_MAX + gl_FUNC_SNPRINTF + gl_STDIO_MODULE_INDICATOR([snprintf]) + gl_MODULE_INDICATOR([snprintf]) + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + if test "$ac_cv_header_winsock2_h" = yes; then + AC_LIBOBJ([socket]) + fi + # When this module is used, sockets may actually occur as file descriptors, + # hence it is worth warning if the modules 'close' and 'ioctl' are not used. + m4_ifdef([gl_UNISTD_H_DEFAULTS], [AC_REQUIRE([gl_UNISTD_H_DEFAULTS])]) + m4_ifdef([gl_SYS_IOCTL_H_DEFAULTS], [AC_REQUIRE([gl_SYS_IOCTL_H_DEFAULTS])]) + AC_REQUIRE([gl_PREREQ_SYS_H_WINSOCK2]) + if test "$ac_cv_header_winsock2_h" = yes; then + UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 + SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 + fi + gl_SYS_SOCKET_MODULE_INDICATOR([socket]) + gl_SOCKETLIB + gl_SOCKETS + gl_TYPE_SOCKLEN_T + gt_TYPE_SSIZE_T + gl_FUNC_STAT + if test $REPLACE_STAT = 1; then + AC_LIBOBJ([stat]) + gl_PREREQ_STAT + fi + gl_SYS_STAT_MODULE_INDICATOR([stat]) + gl_STAT_TIME + gl_STAT_BIRTHTIME + gl_STDALIGN_H + AM_STDBOOL_H + gl_STDDEF_H + gl_STDINT_H + gl_STDIO_H + gl_STDLIB_H + gl_FUNC_GNU_STRFTIME + if test $gl_cond_libtool = false; then + gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" + gl_libdeps="$gl_libdeps $LIBICONV" + fi + gl_HEADER_STRING_H + gl_HEADER_SYS_FILE_H + AC_PROG_MKDIR_P + gl_HEADER_SYS_SOCKET + AC_PROG_MKDIR_P + gl_HEADER_SYS_STAT_H + AC_PROG_MKDIR_P + gl_HEADER_SYS_TIME_H + AC_PROG_MKDIR_P + gl_SYS_TYPES_H + AC_PROG_MKDIR_P + gl_HEADER_SYS_UIO + AC_PROG_MKDIR_P + gl_HEADER_TIME_H + gl_TIME_R + if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then + AC_LIBOBJ([time_r]) + gl_PREREQ_TIME_R + fi + gl_TIME_MODULE_INDICATOR([time_r]) + gl_FUNC_TRUNC + if test $HAVE_DECL_TRUNC = 0 || test $REPLACE_TRUNC = 1; then + AC_LIBOBJ([trunc]) + fi + gl_MATH_MODULE_INDICATOR([trunc]) + gl_UNISTD_H + gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h]) + gl_MODULE_INDICATOR([unistr/u8-mbtouc]) + gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc]) + gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) + gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc-unsafe]) + gl_MODULE_INDICATOR([unistr/u8-mbtoucr]) + gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-mbtoucr]) + gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev]) + gl_MODULE_INDICATOR([unistr/u8-uctomb]) + gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb]) + gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h]) + gl_FUNC_VASNPRINTF + gl_FUNC_VSNPRINTF + gl_STDIO_MODULE_INDICATOR([vsnprintf]) + gl_WCHAR_H + gl_FUNC_WCRTOMB + if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then + AC_LIBOBJ([wcrtomb]) + gl_PREREQ_WCRTOMB + fi + gl_WCHAR_MODULE_INDICATOR([wcrtomb]) + gl_WCTYPE_H + gl_FUNC_WRITE + if test $REPLACE_WRITE = 1; then + AC_LIBOBJ([write]) + gl_PREREQ_WRITE + fi + gl_UNISTD_MODULE_INDICATOR([write]) + gl_XSIZE # End of code from modules m4_ifval(gl_LIBSOURCES_LIST, [ m4_syscmd([test ! -d ]m4_defn([gl_LIBSOURCES_DIR])[ || @@ -865,6 +866,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/arpa_inet.in.h lib/asnprintf.c lib/basename-lgpl.c + lib/binary-io.c lib/binary-io.h lib/bind.c lib/btowc.c @@ -996,6 +998,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/socket.c lib/sockets.c lib/sockets.h + lib/stat-time.c lib/stat-time.h lib/stat.c lib/stdalign.in.h @@ -1040,6 +1043,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/wcrtomb.c lib/wctype.in.h lib/write.c + lib/xsize.c lib/xsize.h m4/00gnulib.m4 m4/absolute-header.m4 @@ -1067,6 +1071,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/exponentf.m4 m4/exponentl.m4 m4/extensions.m4 + m4/extern-inline.m4 m4/fcntl-o.m4 m4/fcntl_h.m4 m4/float_h.m4 diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4 index 4e1374d9b..e1feab540 100644 --- a/m4/lib-ld.m4 +++ b/m4/lib-ld.m4 @@ -1,33 +1,39 @@ -# lib-ld.m4 serial 5 (gettext-0.18.2) +# lib-ld.m4 serial 6 dnl Copyright (C) 1996-2003, 2009-2012 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. dnl Subroutines of libtool.m4, -dnl with replacements s/AC_/AC_LIB/ and s/lt_cv/acl_cv/ to avoid collision -dnl with libtool.m4. +dnl with replacements s/_*LT_PATH/AC_LIB_PROG/ and s/lt_/acl_/ to avoid +dnl collision with libtool.m4. -dnl From libtool-1.4. Sets the variable with_gnu_ld to yes or no. +dnl From libtool-2.4. Sets the variable with_gnu_ld to yes or no. AC_DEFUN([AC_LIB_PROG_LD_GNU], [AC_CACHE_CHECK([if the linker ($LD) is GNU ld], [acl_cv_prog_gnu_ld], -[# I'd rather use --version here, but apparently some GNU ld's only accept -v. +[# I'd rather use --version here, but apparently some GNU lds only accept -v. case `$LD -v 2>&1 </dev/null` in *GNU* | *'with BFD'*) - acl_cv_prog_gnu_ld=yes ;; + acl_cv_prog_gnu_ld=yes + ;; *) - acl_cv_prog_gnu_ld=no ;; + acl_cv_prog_gnu_ld=no + ;; esac]) with_gnu_ld=$acl_cv_prog_gnu_ld ]) -dnl From libtool-1.4. Sets the variable LD. +dnl From libtool-2.4. Sets the variable LD. AC_DEFUN([AC_LIB_PROG_LD], -[AC_ARG_WITH([gnu-ld], -[ --with-gnu-ld assume the C compiler uses GNU ld [default=no]], -test "$withval" = no || with_gnu_ld=yes, with_gnu_ld=no) -AC_REQUIRE([AC_PROG_CC])dnl +[AC_REQUIRE([AC_PROG_CC])dnl AC_REQUIRE([AC_CANONICAL_HOST])dnl + +AC_ARG_WITH([gnu-ld], + [AS_HELP_STRING([--with-gnu-ld], + [assume the C compiler uses GNU ld [default=no]])], + [test "$withval" = no || with_gnu_ld=yes], + [with_gnu_ld=no])dnl + # Prepare PATH_SEPARATOR. # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then @@ -40,10 +46,11 @@ if test "${PATH_SEPARATOR+set}" != set; then || PATH_SEPARATOR=';' } fi + ac_prog=ld if test "$GCC" = yes; then # Check if gcc -print-prog-name=ld gives a path. - AC_MSG_CHECKING([for ld used by GCC]) + AC_MSG_CHECKING([for ld used by $CC]) case $host in *-*-mingw*) # gcc leaves a trailing carriage return which upsets mingw @@ -53,11 +60,11 @@ if test "$GCC" = yes; then esac case $ac_prog in # Accept absolute paths. - [[\\/]* | [A-Za-z]:[\\/]*)] - [re_direlt='/[^/][^/]*/\.\./'] - # Canonicalize the path of ld - ac_prog=`echo $ac_prog| sed 's%\\\\%/%g'` - while echo $ac_prog | grep "$re_direlt" > /dev/null 2>&1; do + [[\\/]]* | ?:[[\\/]]*) + re_direlt='/[[^/]][[^/]]*/\.\./' + # Canonicalize the pathname of ld + ac_prog=`echo "$ac_prog"| sed 's%\\\\%/%g'` + while echo "$ac_prog" | grep "$re_direlt" > /dev/null 2>&1; do ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"` done test -z "$LD" && LD="$ac_prog" @@ -78,23 +85,26 @@ else fi AC_CACHE_VAL([acl_cv_path_LD], [if test -z "$LD"; then - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}" + acl_save_ifs="$IFS"; IFS=$PATH_SEPARATOR for ac_dir in $PATH; do + IFS="$acl_save_ifs" test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then acl_cv_path_LD="$ac_dir/$ac_prog" # Check to see if the program is GNU ld. I'd rather use --version, - # but apparently some GNU ld's only accept -v. + # but apparently some variants of GNU ld only accept -v. # Break only if it was the GNU/non-GNU ld that we prefer. - case `"$acl_cv_path_LD" -v 2>&1 < /dev/null` in + case `"$acl_cv_path_LD" -v 2>&1 </dev/null` in *GNU* | *'with BFD'*) - test "$with_gnu_ld" != no && break ;; + test "$with_gnu_ld" != no && break + ;; *) - test "$with_gnu_ld" != yes && break ;; + test "$with_gnu_ld" != yes && break + ;; esac fi done - IFS="$ac_save_ifs" + IFS="$acl_save_ifs" else acl_cv_path_LD="$LD" # Let the user override the test with a path. fi]) diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index 2dbb1f3c7..9371d7bb9 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -19,7 +19,6 @@ dnl From Paul Eggert. AC_DEFUN([gl_STAT_TIME], [ - AC_REQUIRE([AC_C_INLINE]) AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_CHECK_HEADERS_ONCE([sys/time.h]) @@ -70,7 +69,6 @@ AC_DEFUN([gl_STAT_TIME], # AC_DEFUN([gl_STAT_BIRTHTIME], [ - AC_REQUIRE([AC_C_INLINE]) AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_CHECK_HEADERS_ONCE([sys/time.h]) AC_CHECK_MEMBERS([struct stat.st_birthtimespec.tv_nsec], [], diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index ab43728ac..9c69f2e4d 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -102,6 +102,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], REPLACE_MALLOC=0; AC_SUBST([REPLACE_MALLOC]) REPLACE_MBTOWC=0; AC_SUBST([REPLACE_MBTOWC]) REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP]) + REPLACE_PTSNAME=0; AC_SUBST([REPLACE_PTSNAME]) REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R]) REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV]) REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R]) diff --git a/m4/xsize.m4 b/m4/xsize.m4 index b3b7feebf..d85a5f10f 100644 --- a/m4/xsize.m4 +++ b/m4/xsize.m4 @@ -1,4 +1,4 @@ -# xsize.m4 serial 4 +# xsize.m4 serial 5 dnl Copyright (C) 2003-2004, 2008-2012 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -8,6 +8,5 @@ AC_DEFUN([gl_XSIZE], [ dnl Prerequisites of lib/xsize.h. AC_REQUIRE([gl_SIZE_MAX]) - AC_REQUIRE([AC_C_INLINE]) AC_CHECK_HEADERS([stdint.h]) ]) @@ -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 \ diff --git a/module/Makefile.am b/module/Makefile.am index 2226d5b0f..099870399 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -219,7 +219,6 @@ ICE_9_SOURCES = \ ice-9/optargs.scm \ ice-9/poe.scm \ ice-9/poll.scm \ - ice-9/popen.scm \ ice-9/posix.scm \ ice-9/q.scm \ ice-9/rdelim.scm \ @@ -251,6 +250,13 @@ ICE_9_SOURCES = \ ice-9/serialize.scm \ ice-9/local-eval.scm +if HAVE_FORK + +# This functionality is missing on systems without `fork'---i.e., Windows. +ICE_9_SOURCES += ice-9/popen.scm + +endif HAVE_FORK + SRFI_SOURCES = \ srfi/srfi-2.scm \ srfi/srfi-4.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 1285c8364..a846c5f64 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3753,9 +3753,14 @@ module '(ice-9 q) '(make-q q-length))}." (define %auto-compilation-options ;; Default `compile-file' option when auto-compiling. - '(#:warnings (unbound-variable arity-mismatch format))) + '(#:warnings (unbound-variable arity-mismatch format + duplicate-case-datum bad-case-datum))) (define* (load-in-vicinity dir path #:optional reader) + "Load source file PATH in vicinity of directory DIR. Use a pre-compiled +version of PATH when available, and auto-compile one when none is available, +reading PATH with READER." + (define (canonical->suffix canon) (cond ((string-prefix? "/" canon) canon) @@ -3765,6 +3770,49 @@ module '(ice-9 q) '(make-q q-length))}." (string-append "/" (substring canon 0 1) (substring canon 2))) (else canon))) + (define compiled-extension + ;; File name extension of compiled files. + (cond ((or (null? %load-compiled-extensions) + (string-null? (car %load-compiled-extensions))) + (warn "invalid %load-compiled-extensions" + %load-compiled-extensions) + ".go") + (else (car %load-compiled-extensions)))) + + (define (more-recent? stat1 stat2) + ;; Return #t when STAT1 has an mtime greater than that of STAT2. + (or (> (stat:mtime stat1) (stat:mtime stat2)) + (and (= (stat:mtime stat1) (stat:mtime stat2)) + (>= (stat:mtimensec stat1) + (stat:mtimensec stat2))))) + + (define (fallback-file-name canon-path) + ;; Return the in-cache compiled file name for source file CANON-PATH. + + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. + (and %compile-fallback-path + (string-append %compile-fallback-path + (canonical->suffix canon-path) + compiled-extension))) + + (define (compile file) + ;; Compile source FILE, lazily loading the compiler. + ((module-ref (resolve-interface '(system base compile)) + 'compile-file) + file + #:opts %auto-compilation-options + #:env (current-module))) + + (define (warn-about-exception key args) + (for-each (lambda (s) + (if (not (string-null? s)) + (format (current-warning-port) ";;; ~a\n" s))) + (string-split + (call-with-output-string + (lambda (port) (print-exception port #f key args))) + #\newline))) + ;; Returns the .go file corresponding to `name'. Does not search load ;; paths, only the fallback path. If the .go file is missing or out of ;; date, and auto-compilation is enabled, will try auto-compilation, just @@ -3774,32 +3822,15 @@ module '(ice-9 q) '(make-q q-length))}." ;; NB: Unless we need to compile the file, this function should not cause ;; (system base compile) to be loaded up. For that reason compiled-file-name ;; partially duplicates functionality from (system base compile). - ;; - (define (compiled-file-name canon-path) - ;; FIXME: would probably be better just to append SHA1(canon-path) - ;; to the %compile-fallback-path, to avoid deep directory stats. - (and %compile-fallback-path - (string-append - %compile-fallback-path - (canonical->suffix canon-path) - (cond ((or (null? %load-compiled-extensions) - (string-null? (car %load-compiled-extensions))) - (warn "invalid %load-compiled-extensions" - %load-compiled-extensions) - ".go") - (else (car %load-compiled-extensions)))))) - - (define (fresh-compiled-file-name name go-path) + + (define (fresh-compiled-file-name name scmstat go-path) + ;; Return GO-PATH after making sure that it contains a freshly compiled + ;; version of source file NAME with stat SCMSTAT; return #f on failure. (catch #t (lambda () - (let* ((scmstat (stat name)) - (gostat (and (not %fresh-auto-compile) - (stat go-path #f)))) - (if (and gostat - (or (> (stat:mtime gostat) (stat:mtime scmstat)) - (and (= (stat:mtime gostat) (stat:mtime scmstat)) - (>= (stat:mtimensec gostat) - (stat:mtimensec scmstat))))) + (let ((gostat (and (not %fresh-auto-compile) + (stat go-path #f)))) + (if (and gostat (more-recent? gostat scmstat)) go-path (begin (if gostat @@ -3810,51 +3841,66 @@ module '(ice-9 q) '(make-q q-length))}." (%load-should-auto-compile (%warn-auto-compilation-enabled) (format (current-warning-port) ";;; compiling ~a\n" name) - (let ((cfn - ((module-ref - (resolve-interface '(system base compile)) - 'compile-file) - name - #:opts %auto-compilation-options - #:env (current-module)))) + (let ((cfn (compile name))) (format (current-warning-port) ";;; compiled ~a\n" cfn) cfn)) (else #f)))))) (lambda (k . args) (format (current-warning-port) ";;; WARNING: compilation of ~a failed:\n" name) - (for-each (lambda (s) - (if (not (string-null? s)) - (format (current-warning-port) ";;; ~a\n" s))) - (string-split - (call-with-output-string - (lambda (port) (print-exception port #f k args))) - #\newline)) + (warn-about-exception k args) #f))) (define (absolute-path? path) (string-prefix? "/" path)) + (define (sans-extension file) + (let ((dot (string-rindex file #\.))) + (if dot + (substring file 0 dot) + file))) + (define (load-absolute abs-path) - (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path)))) - (and canon - (let ((go-path (compiled-file-name canon))) - (and go-path - (fresh-compiled-file-name abs-path go-path))))))) - (if cfn + ;; Load from ABS-PATH, using a compiled file or auto-compiling if needed. + (define scmstat + (catch #t + (lambda () + (stat abs-path)) + (lambda (key . args) + (warn-about-exception key args) + #f))) + + (define (pre-compiled) + (let ((go-path (search-path %load-compiled-path (sans-extension path) + %load-compiled-extensions #t))) + (and go-path + (let ((gostat (stat go-path #f))) + (and gostat (more-recent? gostat scmstat) + go-path))))) + + (define (fallback) + (let ((canon (false-if-exception (canonicalize-path abs-path)))) + (and canon + (let ((go-path (fallback-file-name canon))) + (and go-path + (fresh-compiled-file-name abs-path scmstat go-path)))))) + + (let ((compiled (and scmstat + (or (pre-compiled) (fallback))))) + (if compiled (begin (if %load-hook (%load-hook abs-path)) - (load-compiled cfn)) + (load-compiled compiled)) (start-stack 'load-stack (primitive-load abs-path))))) - + (save-module-excursion (lambda () (with-fluids ((current-reader reader) (%file-port-name-canonicalization 'relative)) (cond - ((or (absolute-path? path)) + ((absolute-path? path) (load-absolute path)) ((absolute-path? dir) (load-absolute (in-vicinity dir path))) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 7098d4f82..d9a4d594d 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -1,7 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 2009, 2010, 2011 -;;;; Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -65,7 +64,7 @@ (define (make-formals n) (map (lambda (i) (datum->syntax - x + x (string->symbol (string (integer->char (+ (char->integer #\a) i)))))) (iota n))) @@ -225,11 +224,12 @@ ;; multiple arities, as with case-lambda. (define (make-general-closure env body nreq rest? nopt kw inits alt) (define alt-proc - (and alt + (and alt ; (body docstring nreq ...) (let* ((body (car alt)) - (nreq (cadr alt)) - (rest (if (null? (cddr alt)) #f (caddr alt))) - (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt))) + (spec (cddr alt)) + (nreq (car spec)) + (rest (if (null? (cdr spec)) #f (cadr spec))) + (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) (nopt (if tail (car tail) 0)) (kw (and tail (cadr tail))) (inits (if tail (caddr tail) '())) @@ -246,9 +246,10 @@ (and kw (car kw)) (and rest? '_))) (set-procedure-minimum-arity! proc nreq nopt rest?)) - (let* ((nreq* (cadr alt)) - (rest?* (if (null? (cddr alt)) #f (caddr alt))) - (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt))) + (let* ((spec (cddr alt)) + (nreq* (car spec)) + (rest?* (if (null? (cdr spec)) #f (cadr spec))) + (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) (nopt* (if tail (car tail) 0)) (alt* (and tail (cadddr tail)))) (if (or (< nreq* nreq) @@ -397,14 +398,20 @@ (eval body new-env) (lp (cdr inits) (cons (eval (car inits) env) new-env))))) - - (('lambda (body nreq . tail)) - (if (null? tail) - (make-fixed-closure eval nreq body (capture-env env)) - (if (null? (cdr tail)) - (make-general-closure (capture-env env) body nreq (car tail) - 0 #f '() #f) - (apply make-general-closure (capture-env env) body nreq tail)))) + + (('lambda (body docstring nreq . tail)) + (let ((proc + (if (null? tail) + (make-fixed-closure eval nreq body (capture-env env)) + (if (null? (cdr tail)) + (make-general-closure (capture-env env) body + nreq (car tail) + 0 #f '() #f) + (apply make-general-closure (capture-env env) + body nreq tail))))) + (when docstring + (set-procedure-property! proc 'documentation docstring)) + proc)) (('seq (head . tail)) (begin diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm index 7fbccf63f..6ff104d73 100644 --- a/module/ice-9/futures.scm +++ b/module/ice-9/futures.scm @@ -19,8 +19,10 @@ (define-module (ice-9 futures) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (ice-9 threads) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (ice-9 q) + #:use-module (ice-9 match) #:export (future make-future future? touch)) ;;; Author: Ludovic Courtès <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)) - - (lock-mutex %futures-mutex) - (q-remove! %futures future) - (unlock-mutex %futures-mutex) + (define (work) + ;; Do some work while waiting for FUTURE to complete. + (lock-mutex %futures-mutex) + (if (q-empty? %futures) + (begin + (unlock-mutex %futures-mutex) + (with-mutex (future-mutex future) + (unless (eq? 'done (future-state future)) + (wait-condition-variable (future-completion future) + (future-mutex future))))) + (begin + (process-one-future) + (unlock-mutex %futures-mutex)))) - (lock-mutex (future-mutex future)) - (or (future-done? future) ; lost the race? - (process-future! future)))) - (unlock-mutex (future-mutex future)) + (let loop () + (lock-mutex (future-mutex future)) + (case (future-state future) + ((done) + (unlock-mutex (future-mutex future))) + ((started) + (unlock-mutex (future-mutex future)) + (if (%within-future?) + (abort-to-prompt %future-prompt future) + (begin + (work) + (loop)))) + (else + (unlock-mutex (future-mutex future)) + (work) + (loop)))) ((future-result future))) @@ -184,3 +310,7 @@ touched." (define-syntax-rule (future body) "Return a new future for BODY." (make-future (lambda () body))) + +;;; Local Variables: +;;; eval: (put 'with-mutex 'scheme-indent-function 1) +;;; End: diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm index 019a6a734..428d951ed 100644 --- a/module/ice-9/r6rs-libraries.scm +++ b/module/ice-9/r6rs-libraries.scm @@ -40,7 +40,13 @@ (substring (symbol->string (syntax->datum #'colon-n)) 1))))) (resolve-r6rs-interface - #`(library (srfi #,srfi-n rest ... (version ...)))))) + (syntax-case #'(rest ...) () + (() + #`(library (srfi #,srfi-n (version ...)))) + ((name rest ...) + ;; SRFI 97 says that the first identifier after the colon-n + ;; is used for the libraries name, so it must be ignored. + #`(library (srfi #,srfi-n rest ... (version ...)))))))) ((library (name name* ... (version ...))) (and-map sym? #'(name name* ...)) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 047a73373..9f9e1bf8e 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -1,4 +1,5 @@ -;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011, +;;;; 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -33,6 +34,7 @@ (define-module (ice-9 threads) #:use-module (ice-9 futures) + #:use-module (ice-9 match) #:export (begin-thread parallel letpar @@ -87,16 +89,19 @@ (with-mutex (make-mutex) first rest ...)) -(define (par-mapper mapper) - (lambda (proc . arglists) - (mapper touch - (apply map - (lambda args - (future (apply proc args))) - arglists)))) - -(define par-map (par-mapper map)) -(define par-for-each (par-mapper for-each)) +(define (par-mapper mapper cons) + (lambda (proc . lists) + (let loop ((lists lists)) + (match lists + (((heads tails ...) ...) + (let ((tail (future (loop tails))) + (head (apply proc heads))) + (cons head (touch tail)))) + (_ + '()))))) + +(define par-map (par-mapper map cons)) +(define par-for-each (par-mapper for-each (const *unspecified*))) (define (n-par-map n proc . arglists) (let* ((m (make-mutex)) diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm index a09b374bc..0c0906c3c 100644 --- a/module/ice-9/vlist.scm +++ b/module/ice-9/vlist.scm @@ -208,7 +208,7 @@ (make-vlist base 0)))))) (define (vlist-cons item vlist) - "Return a new vlist with @var{item} as its head and @var{vlist} as its + "Return a new vlist with ITEM as its head and VLIST as its tail." ;; Note: Although the result of `vlist-cons' on a vhash is a valid ;; vlist, it is not a valid vhash. The new item does not get a hash @@ -219,14 +219,14 @@ tail." (block-cons item vlist #f)) (define (vlist-head vlist) - "Return the head of @var{vlist}." + "Return the head of VLIST." (assert-vlist vlist) (let ((base (vlist-base vlist)) (offset (vlist-offset vlist))) (block-ref (block-content base) offset))) (define (vlist-tail vlist) - "Return the tail of @var{vlist}." + "Return the tail of VLIST." (assert-vlist vlist) (let ((base (vlist-base vlist)) (offset (vlist-offset vlist))) @@ -236,7 +236,7 @@ tail." (block-offset base))))) (define (vlist-null? vlist) - "Return true if @var{vlist} is empty." + "Return true if VLIST is empty." (assert-vlist vlist) (let ((base (vlist-base vlist))) (and (not (block-base base)) @@ -248,11 +248,11 @@ tail." ;;; (define (list->vlist lst) - "Return a new vlist whose contents correspond to @var{lst}." + "Return a new vlist whose contents correspond to LST." (vlist-reverse (fold vlist-cons vlist-null lst))) (define (vlist-fold proc init vlist) - "Fold over @var{vlist}, calling @var{proc} for each element." + "Fold over VLIST, calling PROC for each element." ;; FIXME: Handle multiple lists. (assert-vlist vlist) (let loop ((base (vlist-base vlist)) @@ -267,7 +267,7 @@ tail." (proc (block-ref (block-content base) offset) result)))))) (define (vlist-fold-right proc init vlist) - "Fold over @var{vlist}, calling @var{proc} for each element, starting from + "Fold over VLIST, calling PROC for each element, starting from the last element." (assert-vlist vlist) (let loop ((index (1- (vlist-length vlist))) @@ -278,23 +278,23 @@ the last element." (proc (vlist-ref vlist index) result))))) (define (vlist-reverse vlist) - "Return a new @var{vlist} whose content are those of @var{vlist} in reverse + "Return a new VLIST whose content are those of VLIST in reverse order." (vlist-fold vlist-cons vlist-null vlist)) (define (vlist-map proc vlist) - "Map @var{proc} over the elements of @var{vlist} and return a new vlist." + "Map PROC over the elements of VLIST and return a new vlist." (vlist-fold (lambda (item result) (vlist-cons (proc item) result)) vlist-null (vlist-reverse vlist))) (define (vlist->list vlist) - "Return a new list whose contents match those of @var{vlist}." + "Return a new list whose contents match those of VLIST." (vlist-fold-right cons '() vlist)) (define (vlist-ref vlist index) - "Return the element at index @var{index} in @var{vlist}." + "Return the element at index INDEX in VLIST." (assert-vlist vlist) (let loop ((index index) (base (vlist-base vlist)) @@ -306,8 +306,8 @@ order." (block-offset base))))) (define (vlist-drop vlist count) - "Return a new vlist that does not contain the @var{count} first elements of -@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 diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index 40f6419e2..f8fd1cd9c 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -324,10 +324,11 @@ (and (< n env-len) (match (vlist-ref env n) ((#(exp* name sym db-len*) . h*) - (and (unroll db m (- db-len db-len*)) - (if (and (= h h*) (tree-il=? exp* exp)) - (make-lexical-ref (tree-il-src exp) name sym) - (lp (1+ n) (- db-len db-len*)))))))))))) + (let ((niter (- (- db-len db-len*) m))) + (and (unroll db m niter) + (if (and (= h h*) (tree-il=? exp* exp)) + (make-lexical-ref (tree-il-src exp) name sym) + (lp (1+ n) (- db-len db-len*))))))))))))) (define (lookup-lexical sym env) (let ((env-len (vlist-length env))) diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 499a22444..9fedac01d 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -73,7 +73,7 @@ let-syntax letrec-syntax syntax-rules identifier-syntax) - (import (rename (except (guile) error raise map) + (import (rename (except (guile) error raise map string-for-each) (log log-internal) (euclidean-quotient div) (euclidean-remainder mod) @@ -86,6 +86,43 @@ (inexact->exact exact)) (srfi srfi-11)) + (define string-for-each + (case-lambda + ((proc string) + (let ((end (string-length string))) + (let loop ((i 0)) + (unless (= i end) + (proc (string-ref string i)) + (loop (+ i 1)))))) + ((proc string1 string2) + (let ((end1 (string-length string1)) + (end2 (string-length string2))) + (unless (= end1 end2) + (assertion-violation 'string-for-each + "string arguments must all have the same length" + string1 string2)) + (let loop ((i 0)) + (unless (= i end1) + (proc (string-ref string1 i) + (string-ref string2 i)) + (loop (+ i 1)))))) + ((proc string . strings) + (let ((end (string-length string)) + (ends (map string-length strings))) + (for-each (lambda (x) + (unless (= end x) + (apply assertion-violation + 'string-for-each + "string arguments must all have the same length" + string strings))) + ends) + (let loop ((i 0)) + (unless (= i end) + (apply proc + (string-ref string i) + (map (lambda (s) (string-ref s i)) strings)) + (loop (+ i 1)))))))) + (define map (case-lambda ((f l) diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm index eb3506487..219bcdebb 100644 --- a/module/srfi/srfi-9/gnu.scm +++ b/module/srfi/srfi-9/gnu.scm @@ -30,9 +30,9 @@ set-field set-fields)) -(define (set-record-type-printer! type thunk) - "Set a custom printer THUNK for TYPE." - (struct-set! type vtable-index-printer thunk)) +(define (set-record-type-printer! type proc) + "Set PROC as the custom printer for TYPE." + (struct-set! type vtable-index-printer proc)) (define-syntax-rule (define-immutable-record-type name ctor pred fields ...) ((@@ (srfi srfi-9) %define-record-type) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 346ba990f..3f3e7854a 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -119,6 +119,11 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.") ((thunk? prompt) (lambda (repl) (prompt))) ((procedure? prompt) prompt) (else (error "Invalid prompt" prompt))))) + (print #f ,(lambda (print) + (cond + ((not print) #f) + ((procedure? print) print) + (else (error "Invalid print procedure" print))))) (value-history ,(value-history-enabled?) ,(lambda (x) @@ -209,12 +214,16 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.") (if (not (eq? val *unspecified*)) (begin (run-hook before-print-hook val) - ;; The result of an evaluation is representable in scheme, and - ;; should be printed with the generic printer, `write'. The - ;; language-printer is something else: it prints expressions of - ;; a given language, not the result of evaluation. - (write val) - (newline)))) + (cond + ((repl-option-ref repl 'print) + => (lambda (print) (print repl val))) + (else + ;; The result of an evaluation is representable in scheme, and + ;; should be printed with the generic printer, `write'. The + ;; language-printer is something else: it prints expressions of + ;; a given language, not the result of evaluation. + (write val) + (newline)))))) (define (repl-option-ref repl key) (cadr (or (assq key (repl-options repl)) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 02d5ec409..1d0100180 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -1,6 +1,6 @@ ;;; Guile VM program functions -;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -227,7 +227,7 @@ rest? rest (1+ n))) (rest? (lp nreq req nopt opt - #f (var-by-index n) + #f (var-by-index (+ n (length (arity:kw arity)))) (1+ n))) (else `((required . ,(reverse req)) @@ -238,11 +238,13 @@ ;; the name "program-arguments" is taken by features.c... (define* (program-arguments-alist prog #:optional ip) + "Returns the signature of the given procedure in the form of an association list." (let ((arity (program-arity prog ip))) (and arity (arity->arguments-alist prog arity)))) (define* (program-lambda-list prog #:optional ip) + "Returns the signature of the given procedure in the form of an argument list." (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list)) (define (arguments-alist->lambda-list arguments-alist) diff --git a/module/web/client.scm b/module/web/client.scm index cf7ea5325..6aedb751e 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -38,26 +38,30 @@ #:use-module (web request) #:use-module (web response) #:use-module (web uri) + #:use-module (srfi srfi-1) #:export (open-socket-for-uri - http-get)) + http-get + http-get*)) (define (open-socket-for-uri uri) "Return an open input/output port for a connection to URI." (define addresses (let ((port (uri-port uri))) - (getaddrinfo (uri-host uri) - (cond (port => number->string) - (else (symbol->string (uri-scheme uri)))) - (if port - AI_NUMERICSERV - 0)))) + (delete-duplicates + (getaddrinfo (uri-host uri) + (cond (port => number->string) + (else (symbol->string (uri-scheme uri)))) + (if port + AI_NUMERICSERV + 0)) + (lambda (ai1 ai2) + (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) (let loop ((addresses addresses)) (let* ((ai (car addresses)) - (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) - (addrinfo:protocol ai)))) - (set-port-encoding! s "ISO-8859-1") - + (s (with-fluids ((%default-port-encoding #f)) + ;; Restrict ourselves to TCP. + (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) (catch 'system-error (lambda () (connect s (addrinfo:addr ai)) @@ -70,7 +74,7 @@ (lambda args ;; Connection failed, so try one of the other addresses. (close s) - (if (null? addresses) + (if (null? (cdr addresses)) (apply throw args) (loop (cdr addresses)))))))) @@ -83,12 +87,6 @@ (close-port p) res)))) -(define (text-type? type) - (let ((type (symbol->string type))) - (or (string-prefix? "text/" type) - (string-suffix? "/xml" type) - (string-suffix? "+xml" type)))) - ;; Logically the inverse of (web server)'s `sanitize-response'. ;; (define (decode-response-body response body) @@ -104,7 +102,7 @@ ((response-content-type response) => (lambda (type) (cond - ((text-type? (car type)) + ((text-content-type? (car type)) (decode-string body (or (assq-ref (cdr type) 'charset) "iso-8859-1"))) (else body)))) @@ -115,6 +113,15 @@ (define* (http-get uri #:key (port (open-socket-for-uri uri)) (version '(1 . 1)) (keep-alive? #f) (extra-headers '()) (decode-body? #t)) + "Connect to the server corresponding to URI and ask for the +resource, using the ‘GET’ method. If you already have a port open, +pass it as PORT. The port will be closed at the end of the +request unless KEEP-ALIVE? is true. Any extra headers in the +alist EXTRA-HEADERS will be added to the request. + +If DECODE-BODY? is true, as is the default, the body of the +response will be decoded to string, if it is a textual content-type. +Otherwise it will be returned as a bytevector." (let ((req (build-request uri #:version version #:headers (if keep-alive? extra-headers @@ -132,3 +139,25 @@ (if decode-body? (decode-response-body res body) body))))) + +(define* (http-get* uri #:key (port (open-socket-for-uri uri)) + (version '(1 . 1)) (keep-alive? #f) (extra-headers '()) + (decode-body? #t)) + "Like ‘http-get’, but return an input port from which to read. When +DECODE-BODY? is true, as is the default, the returned port has its +encoding set appropriately if the data at URI is textual. Closing the +returned port closes PORT, unless KEEP-ALIVE? is true." + (let ((req (build-request uri #:version version + #:headers (if keep-alive? + extra-headers + (cons '(connection close) + extra-headers))))) + (write-request req port) + (force-output port) + (unless keep-alive? + (shutdown port 1)) + (let* ((res (read-response port)) + (body (response-body-port res + #:keep-alive? keep-alive? + #:decode? decode-body?))) + (values res body)))) diff --git a/module/web/http.scm b/module/web/http.scm index cc5dd5a4b..216fddd3e 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -77,7 +77,7 @@ (define (string->header name) - "Parse @var{name} to a symbolic header name." + "Parse NAME to a symbolic header name." (string->symbol (string-downcase name))) (define-record-type <header-decl> @@ -100,12 +100,7 @@ validator writer #:key multiple?) - "Define a parser, validator, and writer for the HTTP header, @var{name}. - -@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)) diff --git a/module/web/request.scm b/module/web/request.scm index 40d4a668f..7ced076fa 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -160,7 +160,7 @@ (define* (build-request uri #:key (method 'GET) (version '(1 . 1)) (headers '()) port (meta '()) (validate-headers? #t)) - "Construct an HTTP request object. If @var{validate-headers?} is true, + "Construct an HTTP request object. If VALIDATE-HEADERS? is true, the headers are each run through their respective validators." (let ((needs-host? (and (equal? version '(1 . 1)) (not (assq-ref headers 'host))))) @@ -189,13 +189,17 @@ the headers are each run through their respective validators." meta port))) (define* (read-request port #:optional (meta '())) - "Read an HTTP request from @var{port}, optionally attaching the given -metadata, @var{meta}. + "Read an HTTP request from PORT, optionally attaching the given +metadata, META. -As a side effect, sets the encoding on @var{port} to +As a side effect, sets the encoding on PORT to ISO-8859-1 (latin-1), so that reading one character reads one byte. See the discussion of character sets in \"HTTP Requests\" in the manual, for -more information." +more information. + +Note that the body is not part of the request. Once you have read a +request, you may read the body separately, and likewise for writing +requests." (set-port-encoding! port "ISO-8859-1") (call-with-values (lambda () (read-request-line port)) (lambda (method uri version) @@ -203,10 +207,10 @@ more information." ;; FIXME: really return a new request? (define (write-request r port) - "Write the given HTTP request to @var{port}. + "Write the given HTTP request to PORT. -Returns a new request, whose @code{request-port} will continue writing -on @var{port}, perhaps using some transfer encoding." +Return a new request, whose ‘request-port’ will continue writing +on PORT, perhaps using some transfer encoding." (write-request-line (request-method r) (request-uri r) (request-version r) port) (write-headers (request-headers r) port) @@ -217,8 +221,8 @@ on @var{port}, perhaps using some transfer encoding." (request-headers r) (request-meta r) port))) (define (read-request-body r) - "Reads the request body from @var{r}, as a bytevector. Returns -@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 diff --git a/module/web/response.scm b/module/web/response.scm index 6eba69d8d..5ca727409 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -23,6 +23,7 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) #:use-module (srfi srfi-9) #:use-module (web http) #:export (response? @@ -37,6 +38,7 @@ write-response response-must-not-include-body? + response-body-port read-response-body write-response-body @@ -62,6 +64,7 @@ response-content-md5 response-content-range response-content-type + text-content-type? response-expires response-last-modified @@ -107,7 +110,7 @@ (define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase (headers '()) port (validate-headers? #t)) - "Construct an HTTP response object. If @var{validate-headers?} is true, + "Construct an HTTP response object. If VALIDATE-HEADERS? is true, the headers are each run through their respective validators." (cond ((not (and (pair? version) @@ -170,15 +173,23 @@ the headers are each run through their respective validators." "(Unknown)")) (define (response-reason-phrase response) - "Return the reason phrase given in @var{response}, or the standard + "Return the reason phrase given in RESPONSE, or the standard reason phrase for the response's code." (or (%response-reason-phrase response) (code->reason-phrase (response-code response)))) +(define (text-content-type? type) + "Return #t if TYPE, a symbol as returned by `response-content-type', +represents a textual type such as `text/plain'." + (let ((type (symbol->string type))) + (or (string-prefix? "text/" type) + (string-suffix? "/xml" type) + (string-suffix? "+xml" type)))) + (define (read-response port) - "Read an HTTP response from @var{port}. + "Read an HTTP response from PORT. -As a side effect, sets the encoding on @var{port} to +As a side effect, sets the encoding on PORT to ISO-8859-1 (latin-1), so that reading one character reads one byte. See the discussion of character sets in \"HTTP Responses\" in the manual, for more information." @@ -202,10 +213,10 @@ the version field." #:port (response-port response))) (define (write-response r port) - "Write the given HTTP response to @var{port}. + "Write the given HTTP response to PORT. -Returns a new response, whose @code{response-port} will continue writing -on @var{port}, perhaps using some transfer encoding." +Returns a new response, whose ‘response-port’ will continue writing +on PORT, perhaps using some transfer encoding." (write-response-line (response-version r) (response-code r) (response-reason-phrase r) port) (write-headers (response-headers r) port) @@ -216,7 +227,7 @@ on @var{port}, perhaps using some transfer encoding." (response-reason-phrase r) (response-headers r) port))) (define (response-must-not-include-body? r) - "Returns @code{#t} if the response @var{r} is not permitted to have a body. + "Returns ‘#t’ if the response R is not permitted to have a body. This is true for some response types, like those with code 304." ;; RFC 2616, section 4.3. @@ -224,24 +235,70 @@ This is true for some response types, like those with code 304." (= (response-code r) 204) (= (response-code r) 304))) +(define (make-delimited-input-port port len keep-alive?) + "Return an input port that reads from PORT, and makes sure that +exactly LEN bytes are available from PORT. Closing the returned port +closes PORT, unless KEEP-ALIVE? is true." + (define bytes-read 0) + + (define (fail) + (bad-response "EOF while reading response body: ~a bytes of ~a" + bytes-read len)) + + (define (read! bv start count) + (let ((ret (get-bytevector-n! port bv start count))) + (if (eof-object? ret) + (if (= bytes-read len) + 0 + (fail)) + (begin + (set! bytes-read (+ bytes-read ret)) + (if (> bytes-read len) + (fail) + ret))))) + + (define close + (and (not keep-alive?) + (lambda () + (close port)))) + + (make-custom-binary-input-port "delimited input port" read! #f #f close)) + +(define* (response-body-port r #:key (decode? #t) (keep-alive? #t)) + "Return an input port from which the body of R can be read. The +encoding of the returned port is set according to R's ‘content-type’ +header, when it's textual, except if DECODE? is #f. Return #f when no +body is available. + +When KEEP-ALIVE? is #f, closing the returned port also closes R's +response port." + (define port + (if (member '(chunked) (response-transfer-encoding r)) + (make-chunked-input-port (response-port r) + #:keep-alive? keep-alive?) + (let ((len (response-content-length r))) + (and len + (make-delimited-input-port (response-port r) + len keep-alive?))))) + + (when (and decode? port) + (match (response-content-type r) + (((? text-content-type?) . props) + (set-port-encoding! port + (or (assq-ref props 'charset) + "ISO-8859-1"))) + (_ #f))) + + port) + (define (read-response-body r) - "Reads the response body from @var{r}, as a bytevector. Returns -@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 diff --git a/module/web/server.scm b/module/web/server.scm index fbd5d95ab..0e341794b 100644 --- a/module/web/server.scm +++ b/module/web/server.scm @@ -123,14 +123,14 @@ (make-server-impl 'name open read write close))) (define (lookup-server-impl impl) - "Look up a server implementation. If @var{impl} is a server + "Look up a server implementation. If IMPL is a server implementation already, it is returned directly. If it is a symbol, the -binding named @var{impl} in the @code{(web server @var{impl})} module is +binding named IMPL in the ‘(web server IMPL)’ module is looked up. Otherwise an error is signaled. Currently a server implementation is a somewhat opaque type, useful only for passing to other procedures in this module, like -@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))) diff --git a/module/web/uri.scm b/module/web/uri.scm index 78614a520..b688ea8cb 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -53,6 +53,9 @@ (query uri-query) (fragment uri-fragment)) +(define (absolute-uri? x) + (and (uri? x) (uri-scheme x) #t)) + (define (uri-error message . args) (throw 'uri-error message args)) @@ -79,8 +82,11 @@ (define* (build-uri scheme #:key userinfo host port (path "") query fragment (validate? #t)) - "Construct a URI object. If @var{validate?} is true, also run some -consistency checks to make sure that the constructed URI is valid." + "Construct a URI object. SCHEME should be a symbol, PORT +either a positive, exact integer or ‘#f’, and the rest of the +fields are either strings or ‘#f’. If VALIDATE? is true, +also run some consistency checks to make sure that the constructed URI +is valid." (if validate? (validate-uri scheme userinfo host port path query fragment)) (make-uri scheme userinfo host port path query fragment)) @@ -162,21 +168,21 @@ consistency checks to make sure that the constructed URI is valid." (define fragment-pat ".*") (define uri-pat - (format #f "^(~a):(//~a)?(~a)(\\?(~a))?(#(~a))?$" + (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$" scheme-pat authority-pat path-pat query-pat fragment-pat)) (define uri-regexp (make-regexp uri-pat)) -(define (string->uri string) - "Parse @var{string} into a URI object. Returns @code{#f} if the string +(define (string->uri* string) + "Parse STRING into a URI object. Return ‘#f’ if the string could not be parsed." (% (let ((m (regexp-exec uri-regexp string))) (if (not m) (abort)) - (let ((scheme (string->symbol - (string-downcase (match:substring m 1)))) - (authority (match:substring m 2)) - (path (match:substring m 3)) - (query (match:substring m 5)) + (let ((scheme (let ((str (match:substring m 2))) + (and str (string->symbol (string-downcase str))))) + (authority (match:substring m 3)) + (path (match:substring m 4)) + (query (match:substring m 6)) (fragment (match:substring m 7))) (call-with-values (lambda () @@ -188,13 +194,16 @@ could not be parsed." (lambda (k) #f))) +(define (string->uri string) + "Parse STRING into a URI object. Return ‘#f’ if the string +could not be parsed." + (let ((uri (string->uri* string))) + (and uri (uri-scheme uri) uri))) + (define *default-ports* (make-hash-table)) (define (declare-default-port! scheme port) - "Declare a default port for the given URI scheme. - -Default ports are for printing URI objects: a default port is not -printed." + "Declare a default port for the given URI scheme." (hashq-set! *default-ports* scheme port)) (define (default-port? scheme port) @@ -205,9 +214,10 @@ printed." (declare-default-port! 'https 443) (define (uri->string uri) - "Serialize @var{uri} to a string." - (let* ((scheme-str (string-append - (symbol->string (uri-scheme uri)) ":")) + "Serialize URI to a string. If the URI has a port that is the +default port for its scheme, the port is not included in the +serialization." + (let* ((scheme (uri-scheme uri)) (userinfo (uri-userinfo uri)) (host (uri-host uri)) (port (uri-port uri)) @@ -215,7 +225,9 @@ printed." (query (uri-query uri)) (fragment (uri-fragment uri))) (string-append - scheme-str + (if scheme + (string-append (symbol->string scheme) ":") + "") (if host (string-append "//" (if userinfo (string-append userinfo "@") @@ -285,26 +297,32 @@ printed." ;; characters in other character sets. ;; -;; Return a new string made from uri-decoding @var{str}. Specifically, -;; turn @code{+} into space, and hex-encoded @code{%XX} strings into +;; Return a new string made from uri-decoding STR. Specifically, +;; turn ‘+’ into space, and hex-encoded ‘%XX’ strings into ;; their eight-bit characters. ;; (define hex-chars (string->char-set "0123456789abcdefABCDEF")) (define* (uri-decode str #:key (encoding "utf-8")) - "Percent-decode the given @var{str}, according to @var{encoding}. + "Percent-decode the given STR, according to ENCODING, +which should be the name of a character encoding. Note that this function should not generally be applied to a full URI string. For paths, use split-and-decode-uri-path instead. For query -strings, split the query on @code{&} and @code{=} boundaries, and decode +strings, split the query on ‘&’ and ‘=’ boundaries, and decode the components separately. -Note that percent-encoded strings encode @emph{bytes}, not characters. -There is no guarantee that a given byte sequence is a valid string -encoding. Therefore this routine may signal an error if the decoded -bytes are not valid for the given encoding. Pass @code{#f} for -@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-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 + "Percent-encode any character not in the character set, +UNESCAPED-CHARS. + +The default character set includes alphanumerics from ASCII, as well as +the special characters @samp{-}, @samp{.}, @samp{_}, and @samp{~}. Any +other character will be percent-encoded, by writing out the character to +a bytevector within the given ENCODING, then encoding each byte as +‘%HH’, where HH is the hexadecimal representation of the byte." (define (needs-escaped? ch) (not (char-set-contains? unescaped-chars ch))) @@ -387,15 +408,18 @@ the byte." str)) (define (split-and-decode-uri-path path) - "Split @var{path} into its components, and decode each -component, removing empty components. + "Split PATH into its components, and decode each component, +removing empty components. -For example, @code{\"/foo/bar/\"} decodes to the two-element list, -@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) "/")) diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test index b356852c1..f9b85d495 100644 --- a/test-suite/tests/cse.test +++ b/test-suite/tests/cse.test @@ -287,4 +287,21 @@ (begin (cons 1 2 3) 4) (seq (primcall cons (const 1) (const 2) (const 3)) - (const 4)))) + (const 4))) + + (pass-if "http://bugs.gnu.org/12883" + ;; In 2.0.6, compiling this code would trigger an out-of-bounds + ;; vlist access in CSE's traversal of its "database". + (glil-program? + (compile '(define (proc v) + (let ((failure (lambda () (bail-out 'match)))) + (if (and (pair? v) + (null? (cdr v))) + (let ((w foo) + (x (cdr w))) + (if (and (pair? x) (null? w)) + #t + (failure))) + (failure)))) + #:from 'scheme + #:to 'glil)))) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index f8218ad61..24afe2da0 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -442,6 +442,36 @@ (call-with-vm vm thunk)))) ;;; +;;; docstrings +;;; + +(with-test-prefix "docstrings" + + (pass-if-equal "fixed closure" + '("hello" "world") + (map procedure-documentation + (list (eval '(lambda (a b) "hello" (+ a b)) + (current-module)) + (eval '(lambda (a b) "world" (- a b)) + (current-module))))) + + (pass-if-equal "fixed closure with many args" + "So many args." + (procedure-documentation + (eval '(lambda (a b c d e f g h i j k) + "So many args." + (+ a b)) + (current-module)))) + + (pass-if-equal "general closure" + "How general." + (procedure-documentation + (eval '(lambda* (a b #:key k #:rest r) + "How general." + (+ a b)) + (current-module))))) + +;;; ;;; local-eval ;;; diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index 2a203def1..7cd88e470 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -214,18 +214,22 @@ (equal? (file-system-fold enter? leaf down up skip error '() name) `((error ,name ,ENOENT))))) - (pass-if "EACCES" - (with-file-tree %top-builddir '(directory "test-EACCES" #o000 - (("a") ("b"))) - (let ((enter? (lambda (n s r) #t)) - (leaf (lambda (n s r) (cons `(leaf ,n) r))) - (down (lambda (n s r) (cons `(down ,n) r))) - (up (lambda (n s r) (cons `(up ,n) r))) - (skip (lambda (n s r) (cons `(skip ,n) r))) - (error (lambda (n s e r) (cons `(error ,n ,e) r))) - (name (string-append %top-builddir "/test-EACCES"))) - (equal? (file-system-fold enter? leaf down up skip error '() name) - `((error ,name ,EACCES)))))) + (let ((name (string-append %top-builddir "/test-EACCES"))) + (pass-if-equal "EACCES" + `((error ,name ,EACCES)) + (if (zero? (getuid)) + ;; When run as root, this test would fail because root can + ;; list the contents of #o000 directories. + (throw 'unresolved) + (with-file-tree %top-builddir '(directory "test-EACCES" #o000 + (("a") ("b"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r)))) + (file-system-fold enter? leaf down up skip error '() name)))))) (pass-if "dangling symlink and lstat" (with-file-tree %top-builddir '(directory "test-dangling" diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test index e82b4e306..b8bacb2f0 100644 --- a/test-suite/tests/future.test +++ b/test-suite/tests/future.test @@ -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)))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index ddbd2097e..66aa01ae0 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3070,6 +3070,16 @@ (pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1))) (pass-if (equal? fixnum-min (* (* fixnum-min -1) -1)))) + (with-test-prefix "signed fixnum overflow" + (pass-if (eqv? (* 65536 65536) 4294967296)) + (pass-if (eqv? (* -65536 65536) -4294967296)) + (pass-if (eqv? (* 65536 -65536) -4294967296)) + (pass-if (eqv? (* -65536 -65536) 4294967296)) + (pass-if (eqv? (* 4294967296 4294967296) 18446744073709551616)) + (pass-if (eqv? (* -4294967296 4294967296) -18446744073709551616)) + (pass-if (eqv? (* 4294967296 -4294967296) -18446744073709551616)) + (pass-if (eqv? (* -4294967296 -4294967296) 18446744073709551616))) + (with-test-prefix "signed zeroes" (pass-if (eqv? +0.0 (* +0.0 +0.0))) (pass-if (eqv? -0.0 (* -0.0 +0.0))) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 9679042a6..00e9c682e 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -1,6 +1,6 @@ ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004, 2006, 2007, 2010 Free Software Foundation, Inc. +;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -198,3 +198,16 @@ (setaffinity (getpid) mask) (equal? mask (getaffinity (getpid)))) (throw 'unresolved)))) + +;; +;; system* +;; + +(with-test-prefix "system*" + + (pass-if "http://bugs.gnu.org/13166" + ;; With Guile up to 2.0.7 included, the child process launched by + ;; `system*' would remain alive after an `execvp' failure. + (let ((me (getpid))) + (and (not (zero? (system* "something-that-does-not-exist"))) + (= me (getpid)))))) diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test index df11d67b3..fb491419a 100644 --- a/test-suite/tests/r6rs-base.test +++ b/test-suite/tests/r6rs-base.test @@ -196,3 +196,43 @@ (guard (condition ((assertion-violation? condition) #t)) (assert #f) #f))) + +(with-test-prefix "string-for-each" + (pass-if "reverse string" + (let ((s "reverse me") (l '())) + (string-for-each (lambda (x) (set! l (cons x l))) s) + (equal? "em esrever" (list->string l)))) + (pass-if "two strings good" + (let ((s1 "two legs good") + (s2 "four legs bad") + (c '())) + (string-for-each (lambda (c1 c2) + (set! c (cons* c2 c1 c))) + s1 s2) + (equal? (list->string c) + "ddaobo gs gsegle lr uoowft"))) + (pass-if "two strings bad" + (let ((s1 "frotz") + (s2 "veeblefetzer")) + (guard (condition ((assertion-violation? condition) #t)) + (string-for-each (lambda (s1 s2) #f) s1 s2) + #f))) + (pass-if "many strings good" + (let ((s1 "foo") + (s2 "bar") + (s3 "baz") + (s4 "zot") + (c '())) + (string-for-each (lambda (c1 c2 c3 c4) + (set! c (cons* c4 c3 c2 c1 c))) + s1 s2 s3 s4) + (equal? (list->string c) + "tzrooaaozbbf"))) + (pass-if "many strings bad" + (let ((s1 "foo") + (s2 "bar") + (s3 "baz") + (s4 "quux")) + (guard (condition ((assertion-violation? condition) #t)) + (string-for-each (lambda _ #f) s1 s2 s3 s4) + #f)))) diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test index e961c2877..9add98af6 100644 --- a/test-suite/tests/rnrs-libraries.test +++ b/test-suite/tests/rnrs-libraries.test @@ -183,7 +183,9 @@ (with-test-prefix "srfi" (pass-if "renaming works" (eq? (resolve-interface '(srfi srfi-1)) - (resolve-r6rs-interface '(srfi :1))))) + (resolve-r6rs-interface '(srfi :1))) + (eq? (resolve-interface '(srfi srfi-1)) + (resolve-r6rs-interface '(srfi :1 lists))))) (with-test-prefix "macro" (pass-if "multiple clauses" diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test index ec992f1c8..c9aa4a06c 100644 --- a/test-suite/tests/session.test +++ b/test-suite/tests/session.test @@ -1,7 +1,7 @@ ;;;; session.test --- test suite for (ice-9 session) -*- scheme -*- ;;;; Jose Antonio Ortega Ruiz <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>. diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 4767d624a..c344795ca 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -776,6 +776,12 @@ (define %opts-w-format '(#:warnings (format))) +(define %opts-w-duplicate-case-datum + '(#:warnings (duplicate-case-datum))) + +(define %opts-w-bad-case-datum + '(#:warnings (bad-case-datum))) + (with-test-prefix "warnings" @@ -1780,7 +1786,71 @@ #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) - (number? (string-contains (car w) "unsupported format option")))))))) + (number? (string-contains (car w) "unsupported format option"))))))) + + (with-test-prefix "duplicate-case-datum" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '(case x ((1) 'one) ((2) 'two)) + #:opts %opts-w-duplicate-case-datum + #:to 'assembly))))) + + (pass-if "one duplicate" + (let ((w (call-with-warnings + (lambda () + (compile '(case x + ((1) 'one) + ((2) 'two) + ((1) 'one-again)) + #:opts %opts-w-duplicate-case-datum + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) "duplicate"))))) + + (pass-if "one duplicate" + (let ((w (call-with-warnings + (lambda () + (compile '(case x + ((1 2 3) 'a) + ((1) 'one)) + #:opts %opts-w-duplicate-case-datum + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) "duplicate")))))) + + (with-test-prefix "bad-case-datum" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '(case x ((1) 'one) ((2) 'two)) + #:opts %opts-w-bad-case-datum + #:to 'assembly))))) + + (pass-if "not eqv?" + (let ((w (call-with-warnings + (lambda () + (compile '(case x + ((1) 'one) + (("bad") 'bad)) + #:opts %opts-w-bad-case-datum + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "cannot be meaningfully compared"))))) + + (pass-if "one clause element not eqv?" + (let ((w (call-with-warnings + (lambda () + (compile '(case x + ((1 (2) 3) 'a)) + #:opts %opts-w-duplicate-case-datum + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "cannot be meaningfully compared"))))))) ;; Local Variables: ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1) diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index ddd55a750..f9679f5e2 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -1,6 +1,6 @@ ;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -21,6 +21,7 @@ #:use-module (web uri) #:use-module (web response) #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) #:use-module (srfi srfi-19) #:use-module (test-suite lib)) @@ -66,37 +67,33 @@ consectetur adipisicing elit,\r (begin (set! r (read-response (open-input-string example-1))) (response? r))) - + (pass-if "read-response-body" (begin (set! body (read-response-body r)) #t)) - - (pass-if (equal? (response-version r) '(1 . 1))) - - (pass-if (equal? (response-code r) 200)) - - (pass-if (equal? (response-reason-phrase r) "OK")) - - (pass-if (equal? body - (string->utf8 - "abcdefghijklmnopqrstuvwxyz0123456789"))) - - (pass-if "checking all headers" - (equal? - (response-headers r) - `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000" - "~a, ~d ~b ~Y ~H:~M:~S ~z")) - (server . "Apache/2.0.55") - (accept-ranges . (bytes)) - (cache-control . ((max-age . 543234))) - (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000" - "~a, ~d ~b ~Y ~H:~M:~S ~z")) - (vary . (accept-encoding)) - (content-encoding . (gzip)) - (content-length . 36) - (content-type . (text/html (charset . "utf-8")))))) - + + (pass-if-equal '(1 . 1) (response-version r)) + (pass-if-equal 200 (response-code r)) + (pass-if-equal "OK" (response-reason-phrase r)) + + (pass-if-equal (string->utf8 "abcdefghijklmnopqrstuvwxyz0123456789") + body) + + (pass-if-equal "checking all headers" + `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (server . "Apache/2.0.55") + (accept-ranges . (bytes)) + (cache-control . ((max-age . 543234))) + (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (vary . (accept-encoding)) + (content-encoding . (gzip)) + (content-length . 36) + (content-type . (text/html (charset . "utf-8")))) + (response-headers r)) + (pass-if "write then read" (call-with-values (lambda () @@ -111,16 +108,31 @@ consectetur adipisicing elit,\r (lambda (r* body*) (responses-equal? r body r* body*)))) - (pass-if "by accessor" - (equal? (response-content-encoding r) '(gzip))))) + (pass-if-equal "by accessor" + '(gzip) + (response-content-encoding r)) + + (pass-if-equal "response-body-port" + `("utf-8" ,body) + (with-fluids ((%default-port-encoding #f)) + (let* ((r (read-response (open-input-string example-1))) + (p (response-body-port r))) + (list (port-encoding p) (get-bytevector-all p))))))) (with-test-prefix "example-2" - (let* ((r (read-response (open-input-string example-2))) - (b (read-response-body r))) - (pass-if (equal? '((chunked)) - (response-transfer-encoding r))) - (pass-if (equal? b - (string->utf8 - (string-append - "Lorem ipsum dolor sit amet, consectetur adipisicing elit," - " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.")))))) + (let* ((r (read-response (open-input-string example-2))) + (b (read-response-body r))) + (pass-if-equal '((chunked)) + (response-transfer-encoding r)) + (pass-if-equal + (string->utf8 + (string-append + "Lorem ipsum dolor sit amet, consectetur adipisicing elit," + " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.")) + b) + (pass-if-equal "response-body-port" + `("ISO-8859-1" ,(utf8->string b)) ; no `charset', hence ISO-8859-1 + (with-fluids ((%default-port-encoding #f)) + (let* ((r (read-response (open-input-string example-2))) + (p (response-body-port r))) + (list (port-encoding p) (get-string-all p))))))) |