From af07e10429c1513c2348289888b240926264b32b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 18 Feb 2013 18:48:48 +0100 Subject: [PATCH 001/147] Update to gnulib 0.0.7865-a828. --- GNUmakefile | 2 +- build-aux/announce-gen | 2 +- build-aux/config.rpath | 2 +- build-aux/gendocs.sh | 160 +++++++++------- build-aux/git-version-gen | 38 ++-- build-aux/gitlog-to-changelog | 2 +- build-aux/gnu-web-doc-update | 33 ++-- build-aux/gnupload | 19 +- build-aux/snippet/arg-nonnull.h | 2 +- build-aux/snippet/c++defs.h | 2 +- build-aux/snippet/unused-parameter.h | 2 +- build-aux/snippet/warn-on-use.h | 4 +- build-aux/useless-if-before-free | 2 +- build-aux/vc-list-files | 2 +- doc/gendocs_template | 2 +- gnulib-local/build-aux/git-version-gen.diff | 47 ++--- lib/Makefile.am | 8 +- lib/accept.c | 2 +- lib/alignof.h | 2 +- lib/alloca.in.h | 2 +- lib/arpa_inet.in.h | 2 +- lib/asnprintf.c | 2 +- lib/basename-lgpl.c | 2 +- lib/binary-io.h | 2 +- lib/bind.c | 2 +- lib/btowc.c | 2 +- lib/byteswap.in.h | 2 +- lib/c-ctype.c | 2 +- lib/c-ctype.h | 2 +- lib/c-strcase.h | 2 +- lib/c-strcasecmp.c | 2 +- lib/c-strcaseeq.h | 2 +- lib/c-strncasecmp.c | 2 +- lib/canonicalize-lgpl.c | 78 +++++--- lib/ceil.c | 2 +- lib/close.c | 2 +- lib/config.charset | 2 +- lib/connect.c | 2 +- lib/dirent.in.h | 2 +- lib/dirfd.c | 2 +- lib/dirname-lgpl.c | 2 +- lib/dirname.h | 2 +- lib/dosname.h | 2 +- lib/duplocale.c | 2 +- lib/errno.in.h | 2 +- lib/fcntl.in.h | 2 +- lib/fd-hook.c | 2 +- lib/fd-hook.h | 2 +- lib/float+.h | 2 +- lib/float.c | 2 +- lib/float.in.h | 2 +- lib/flock.c | 2 +- lib/floor.c | 2 +- lib/frexp.c | 2 +- lib/fstat.c | 6 +- lib/full-read.c | 2 +- lib/full-read.h | 2 +- lib/full-write.c | 2 +- lib/full-write.h | 2 +- lib/gai_strerror.c | 2 +- lib/getaddrinfo.c | 8 +- lib/getpeername.c | 2 +- lib/getsockname.c | 2 +- lib/getsockopt.c | 2 +- lib/gettext.h | 2 +- lib/iconv.c | 2 +- lib/iconv.in.h | 2 +- lib/iconv_close.c | 2 +- lib/iconv_open.c | 2 +- lib/iconveh.h | 2 +- lib/inet_ntop.c | 2 +- lib/inet_pton.c | 2 +- lib/isinf.c | 2 +- lib/isnan.c | 2 +- lib/isnand-nolibm.h | 2 +- lib/isnand.c | 2 +- lib/isnanf.c | 2 +- lib/isnanl.c | 2 +- lib/itold.c | 2 +- lib/langinfo.in.h | 2 +- lib/listen.c | 2 +- lib/localcharset.c | 2 +- lib/localcharset.h | 2 +- lib/locale.in.h | 21 ++- lib/localeconv.c | 2 +- lib/log.c | 2 +- lib/log1p.c | 2 +- lib/lstat.c | 4 +- lib/malloc.c | 2 +- lib/malloca.c | 2 +- lib/malloca.h | 2 +- lib/math.c | 3 + lib/math.in.h | 15 +- lib/mbrtowc.c | 2 +- lib/mbsinit.c | 2 +- lib/mbtowc-impl.h | 2 +- lib/mbtowc.c | 2 +- lib/memchr.c | 2 +- lib/msvc-inval.c | 2 +- lib/msvc-inval.h | 2 +- lib/msvc-nothrow.c | 2 +- lib/msvc-nothrow.h | 2 +- lib/netdb.in.h | 2 +- lib/netinet_in.in.h | 2 +- lib/nl_langinfo.c | 2 +- lib/nproc.c | 2 +- lib/nproc.h | 2 +- lib/open.c | 4 +- lib/pathmax.h | 2 +- lib/pipe2.c | 2 +- lib/printf-args.c | 2 +- lib/printf-args.h | 2 +- lib/printf-parse.c | 2 +- lib/printf-parse.h | 2 +- lib/putenv.c | 34 +++- lib/raise.c | 4 +- lib/read.c | 4 +- lib/readlink.c | 2 +- lib/recv.c | 2 +- lib/recvfrom.c | 2 +- lib/ref-add.sin | 2 +- lib/ref-del.sin | 2 +- lib/regcomp.c | 64 +++---- lib/regex.c | 21 ++- lib/regex.h | 23 +-- lib/regex_internal.c | 31 ++- lib/regex_internal.h | 70 +++---- lib/regexec.c | 49 +++-- lib/rename.c | 2 +- lib/rmdir.c | 2 +- lib/round.c | 2 +- lib/safe-read.c | 2 +- lib/safe-read.h | 2 +- lib/safe-write.c | 2 +- lib/safe-write.h | 2 +- lib/same-inode.h | 2 +- lib/send.c | 2 +- lib/sendto.c | 2 +- lib/setenv.c | 10 +- lib/setsockopt.c | 2 +- lib/shutdown.c | 2 +- lib/signal.in.h | 2 +- lib/size_max.h | 2 +- lib/snprintf.c | 2 +- lib/socket.c | 2 +- lib/sockets.c | 2 +- lib/sockets.h | 2 +- lib/stat-time.h | 2 +- lib/stat.c | 4 +- lib/stdalign.in.h | 2 +- lib/stdbool.in.h | 2 +- lib/stddef.in.h | 2 +- lib/stdint.in.h | 4 +- lib/stdio.in.h | 23 +-- lib/stdlib.in.h | 23 ++- lib/streq.h | 2 +- lib/strftime.c | 16 +- lib/strftime.h | 2 +- lib/striconveh.c | 2 +- lib/striconveh.h | 2 +- lib/string.in.h | 2 +- lib/stripslash.c | 2 +- lib/sys_file.in.h | 2 +- lib/sys_socket.c | 3 + lib/sys_socket.in.h | 11 +- lib/sys_stat.in.h | 8 +- lib/sys_time.in.h | 198 ++++++++++---------- lib/sys_types.in.h | 2 +- lib/sys_uio.in.h | 2 +- lib/time.in.h | 2 +- lib/time_r.c | 2 +- lib/trunc.c | 2 +- lib/unistd.c | 3 + lib/unistd.in.h | 35 ++-- lib/unistr.in.h | 2 +- lib/unistr/u8-mbtouc-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe.c | 2 +- lib/unistr/u8-mbtouc.c | 2 +- lib/unistr/u8-mbtoucr.c | 2 +- lib/unistr/u8-prev.c | 2 +- lib/unistr/u8-uctomb-aux.c | 2 +- lib/unistr/u8-uctomb.c | 2 +- lib/unitypes.in.h | 2 +- lib/vasnprintf.c | 4 +- lib/vasnprintf.h | 2 +- lib/verify.h | 2 +- lib/vsnprintf.c | 2 +- lib/w32sock.h | 2 +- lib/wchar.in.h | 2 +- lib/wcrtomb.c | 2 +- lib/wctype-h.c | 4 + lib/wctype.in.h | 40 ++-- lib/write.c | 4 +- lib/xsize.h | 2 +- m4/00gnulib.m4 | 2 +- m4/absolute-header.m4 | 2 +- m4/alloca.m4 | 2 +- m4/arpa_inet_h.m4 | 2 +- m4/autobuild.m4 | 2 +- m4/btowc.m4 | 2 +- m4/byteswap.m4 | 2 +- m4/canonicalize.m4 | 2 +- m4/ceil.m4 | 2 +- m4/check-math-lib.m4 | 2 +- m4/clock_time.m4 | 2 +- m4/close.m4 | 2 +- m4/codeset.m4 | 2 +- m4/configmake.m4 | 2 +- m4/dirent_h.m4 | 2 +- m4/dirfd.m4 | 2 +- m4/dirname.m4 | 2 +- m4/double-slash-root.m4 | 2 +- m4/duplocale.m4 | 2 +- m4/eealloc.m4 | 2 +- m4/environ.m4 | 2 +- m4/errno_h.m4 | 2 +- m4/exponentd.m4 | 2 +- m4/exponentf.m4 | 2 +- m4/exponentl.m4 | 2 +- m4/extensions.m4 | 49 +++-- m4/extern-inline.m4 | 23 ++- m4/fcntl-o.m4 | 2 +- m4/fcntl_h.m4 | 2 +- m4/float_h.m4 | 2 +- m4/flock.m4 | 2 +- m4/floor.m4 | 2 +- m4/fpieee.m4 | 2 +- m4/frexp.m4 | 2 +- m4/fstat.m4 | 9 +- m4/func.m4 | 2 +- m4/getaddrinfo.m4 | 5 +- m4/glibc21.m4 | 2 +- m4/gnulib-cache.m4 | 2 +- m4/gnulib-common.m4 | 8 +- m4/gnulib-comp.m4 | 7 +- m4/gnulib-tool.m4 | 2 +- m4/hostent.m4 | 2 +- m4/iconv.m4 | 2 +- m4/iconv_h.m4 | 2 +- m4/iconv_open-utf.m4 | 2 +- m4/iconv_open.m4 | 2 +- m4/include_next.m4 | 2 +- m4/inet_ntop.m4 | 2 +- m4/inet_pton.m4 | 2 +- m4/inline.m4 | 2 +- m4/intmax_t.m4 | 2 +- m4/inttypes_h.m4 | 2 +- m4/isinf.m4 | 2 +- m4/isnan.m4 | 2 +- m4/isnand.m4 | 2 +- m4/isnanf.m4 | 2 +- m4/isnanl.m4 | 2 +- m4/langinfo_h.m4 | 2 +- m4/largefile.m4 | 25 ++- m4/ld-version-script.m4 | 2 +- m4/ldexp.m4 | 2 +- m4/lib-ld.m4 | 2 +- m4/lib-link.m4 | 2 +- m4/lib-prefix.m4 | 2 +- m4/libunistring-base.m4 | 2 +- m4/libunistring.m4 | 2 +- m4/localcharset.m4 | 2 +- m4/locale-fr.m4 | 2 +- m4/locale-ja.m4 | 2 +- m4/locale-zh.m4 | 2 +- m4/locale_h.m4 | 2 +- m4/localeconv.m4 | 2 +- m4/log.m4 | 2 +- m4/log1p.m4 | 2 +- m4/longlong.m4 | 2 +- m4/lstat.m4 | 10 +- m4/malloc.m4 | 2 +- m4/malloca.m4 | 2 +- m4/math_h.m4 | 5 +- m4/mathfunc.m4 | 2 +- m4/mbrtowc.m4 | 2 +- m4/mbsinit.m4 | 2 +- m4/mbstate_t.m4 | 2 +- m4/mbtowc.m4 | 2 +- m4/memchr.m4 | 2 +- m4/mmap-anon.m4 | 2 +- m4/mode_t.m4 | 2 +- m4/msvc-inval.m4 | 2 +- m4/msvc-nothrow.m4 | 2 +- m4/multiarch.m4 | 2 +- m4/netdb_h.m4 | 2 +- m4/netinet_in_h.m4 | 2 +- m4/nl_langinfo.m4 | 2 +- m4/nocrash.m4 | 2 +- m4/nproc.m4 | 2 +- m4/off_t.m4 | 2 +- m4/open.m4 | 5 +- m4/pathmax.m4 | 2 +- m4/pipe2.m4 | 2 +- m4/printf.m4 | 2 +- m4/putenv.m4 | 8 +- m4/raise.m4 | 8 +- m4/read.m4 | 9 +- m4/readlink.m4 | 2 +- m4/regex.m4 | 85 ++++++--- m4/rename.m4 | 2 +- m4/rmdir.m4 | 2 +- m4/round.m4 | 2 +- m4/safe-read.m4 | 2 +- m4/safe-write.m4 | 2 +- m4/servent.m4 | 2 +- m4/setenv.m4 | 2 +- m4/signal_h.m4 | 2 +- m4/size_max.m4 | 2 +- m4/snprintf.m4 | 2 +- m4/socketlib.m4 | 2 +- m4/sockets.m4 | 2 +- m4/socklen.m4 | 2 +- m4/sockpfaf.m4 | 2 +- m4/ssize_t.m4 | 2 +- m4/stat-time.m4 | 2 +- m4/stat.m4 | 10 +- m4/stdalign.m4 | 2 +- m4/stdbool.m4 | 2 +- m4/stddef_h.m4 | 2 +- m4/stdint.m4 | 2 +- m4/stdint_h.m4 | 2 +- m4/stdio_h.m4 | 5 +- m4/stdlib_h.m4 | 8 +- m4/strftime.m4 | 2 +- m4/string_h.m4 | 2 +- m4/sys_file_h.m4 | 2 +- m4/sys_socket_h.m4 | 5 +- m4/sys_stat_h.m4 | 7 +- m4/sys_time_h.m4 | 2 +- m4/sys_types_h.m4 | 2 +- m4/sys_uio_h.m4 | 2 +- m4/time_h.m4 | 2 +- m4/time_r.m4 | 2 +- m4/tm_gmtoff.m4 | 2 +- m4/trunc.m4 | 2 +- m4/unistd_h.m4 | 5 +- m4/vasnprintf.m4 | 5 +- m4/visibility.m4 | 2 +- m4/vsnprintf.m4 | 2 +- m4/warn-on-use.m4 | 2 +- m4/warnings.m4 | 2 +- m4/wchar_h.m4 | 2 +- m4/wchar_t.m4 | 2 +- m4/wcrtomb.m4 | 2 +- m4/wctype_h.m4 | 6 +- m4/wint_t.m4 | 2 +- m4/write.m4 | 9 +- m4/xsize.m4 | 2 +- maint.mk | 17 +- 351 files changed, 1114 insertions(+), 931 deletions(-) mode change 100755 => 100644 build-aux/gendocs.sh create mode 100644 lib/math.c create mode 100644 lib/sys_socket.c create mode 100644 lib/unistd.c create mode 100644 lib/wctype-h.c diff --git a/GNUmakefile b/GNUmakefile index 58f2ead46..8759034e0 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -5,7 +5,7 @@ # It is necessary if you want to build targets usually of interest # only to the maintainer. -# Copyright (C) 2001, 2003, 2006-2012 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2006-2013 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 diff --git a/build-aux/announce-gen b/build-aux/announce-gen index ec7c22a28..3a64ec659 100755 --- a/build-aux/announce-gen +++ b/build-aux/announce-gen @@ -9,7 +9,7 @@ my $VERSION = '2012-06-08 06:53'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2002-2012 Free Software Foundation, Inc. +# Copyright (C) 2002-2013 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 diff --git a/build-aux/config.rpath b/build-aux/config.rpath index 1a0701828..c38b914d6 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -2,7 +2,7 @@ # Output a system dependent set of variables, describing how to set the # run time search path of shared libraries in an executable. # -# Copyright 1996-2012 Free Software Foundation, Inc. +# Copyright 1996-2013 Free Software Foundation, Inc. # Taken from GNU libtool, 2001 # Originally by Gordon Matzigkeit , 1996 # diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh old mode 100755 new mode 100644 index 0c0bc4b0f..e4bfc9fd2 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh @@ -2,9 +2,9 @@ # 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=2012-10-27.11 +scriptversion=2013-02-03.15 -# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 +# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 # Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify @@ -56,7 +56,7 @@ unset use_texi2html version="gendocs.sh $scriptversion -Copyright 2012 Free Software Foundation, Inc. +Copyright 2013 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." @@ -69,16 +69,23 @@ 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 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. + --email ADR use ADR as contact in generated web pages; always give this. + + -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. + --common ARG pass ARG in all invocations. + --html ARG pass ARG to makeinfo or texi2html for HTML targets. + --info ARG pass ARG to makeinfo for Info, instead of --no-split. + --no-ascii skip generating the plain text output. + --source ARG include ARG in tar archive of sources. + --split HOW make split HTML by node, section, chapter; default node. + + --texi2html use texi2html to make HTML target, with all split versions. + --docbook convert through DocBook too (xml, txt, html, pdf). + + --help display this help and exit successfully. + --version display version information and exit successfully. Simple example: $prog --email bug-gnu-emacs@gnu.org emacs \"GNU Emacs Manual\" @@ -92,8 +99,8 @@ 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 do use the --email ADDRESS option to specify your bug-reporting -address in the generated HTML pages. +Please use the --email ADDRESS option so your own bug-reporting +address will be used in the generated HTML pages. MANUAL-TITLE is included as part of the HTML of the overall manual/index.html file. It should include the name of the package being @@ -117,7 +124,7 @@ 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, and DOCBOOK2TXT are also respected. +DOCBOOK2PDF, and DOCBOOK2TXT are also consulted. By default, makeinfo and texi2dvi are run in the default (English) locale, since that's the language of most Texinfo manuals. If you @@ -130,25 +137,34 @@ Email bug reports or enhancement requests to bug-texinfo@gnu.org. MANUAL_TITLE= PACKAGE= EMAIL=webmasters@gnu.org # please override with --email -commonarg= # Options passed to all the tools (-I dir). +commonarg= # passed to all makeinfo/texi2html invcations. +dirargs= # passed to all tools (-I dir). dirs= # -I's directories. htmlarg= infoarg=--no-split +generate_ascii=true outdir=manual +source_extra= +split=node srcfile= while test $# -gt 0; do case $1 in - --email) shift; EMAIL=$1;; - --help) echo "$usage"; exit 0;; - --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;; + -s) shift; srcfile=$1;; + -o) shift; outdir=$1;; + -I) shift; dirargs="$dirargs -I '$1'"; dirs="$dirs $1";; + --common) shift; commonarg=$1;; + --docbook) docbook=yes;; + --email) shift; EMAIL=$1;; + --html) shift; htmlarg=$1;; + --info) shift; infoarg=$1;; + --no-ascii) generate_ascii=false;; + --source) shift; source_extra=$1;; + --split) shift; split=$1;; --texi2html) use_texi2html=1;; + + --help) echo "$usage"; exit 0;; + --version) echo "$version"; exit 0;; -*) echo "$0: Unknown option \`$1'." >&2 echo "$0: Try \`--help' for more information." >&2 @@ -166,6 +182,9 @@ while test $# -gt 0; do shift done +# makeinfo uses the dirargs, but texi2dvi doesn't. +commonarg=" $dirargs $commonarg" + # For most of the following, the base name is just $PACKAGE base=$PACKAGE @@ -247,46 +266,52 @@ case $outdir in *) abs_outdir=$srcdir/$outdir;; esac -echo "Generating output formats for $srcfile" +echo "Making output for $srcfile" +echo " in `pwd`" +mkdir -p "$outdir/" cmd="$SETLANG $MAKEINFO -o $PACKAGE.info $commonarg $infoarg \"$srcfile\"" -echo "Generating info file(s)... ($cmd)" +echo "Generating info... ($cmd)" eval "$cmd" -mkdir -p "$outdir/" tar czf "$outdir/$PACKAGE.info.tar.gz" $PACKAGE.info* +ls -l "$outdir/$PACKAGE.info.tar.gz" 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 $commonarg \"$srcfile\"" -echo "Generating dvi ... ($cmd)" +cmd="$SETLANG $TEXI2DVI $dirargs \"$srcfile\"" +printf "\nGenerating dvi... ($cmd)\n" eval "$cmd" - # compress/finish dvi: gzip -f -9 $PACKAGE.dvi dvi_gz_size=`calcsize $PACKAGE.dvi.gz` mv $PACKAGE.dvi.gz "$outdir/" +ls -l "$outdir/$PACKAGE.dvi.gz" -cmd="$SETLANG $TEXI2DVI --pdf $commonarg \"$srcfile\"" -echo "Generating pdf ... ($cmd)" +cmd="$SETLANG $TEXI2DVI --pdf $dirargs \"$srcfile\"" +printf "\nGenerating pdf... ($cmd)\n" eval "$cmd" pdf_size=`calcsize $PACKAGE.pdf` mv $PACKAGE.pdf "$outdir/" +ls -l "$outdir/$PACKAGE.pdf" -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` -gzip -f -9 -c $PACKAGE.txt >"$outdir/$PACKAGE.txt.gz" -ascii_gz_size=`calcsize "$outdir/$PACKAGE.txt.gz"` -mv $PACKAGE.txt "$outdir/" +if $generate_ascii; then + opt="-o $PACKAGE.txt --no-split --no-headers $commonarg" + cmd="$SETLANG $MAKEINFO $opt \"$srcfile\"" + printf "\nGenerating ascii... ($cmd)\n" + eval "$cmd" + ascii_size=`calcsize $PACKAGE.txt` + gzip -f -9 -c $PACKAGE.txt >"$outdir/$PACKAGE.txt.gz" + ascii_gz_size=`calcsize "$outdir/$PACKAGE.txt.gz"` + mv $PACKAGE.txt "$outdir/" + ls -l "$outdir/$PACKAGE.txt" "$outdir/$PACKAGE.txt.gz" +fi html_split() { - opt="--split=$1 $commonarg $htmlarg --node-files" + opt="--split=$1 --node-files $commonarg $htmlarg" cmd="$SETLANG $TEXI2HTML --output $PACKAGE.html $opt \"$srcfile\"" - echo "Generating html by $1... ($cmd)" + printf "\nGenerating html by $1... ($cmd)\n" eval "$cmd" split_html_dir=$PACKAGE.html ( @@ -304,7 +329,7 @@ html_split() if test -z "$use_texi2html"; then opt="--no-split --html -o $PACKAGE.html $commonarg $htmlarg" cmd="$SETLANG $MAKEINFO $opt \"$srcfile\"" - echo "Generating monolithic html... ($cmd)" + printf "\nGenerating monolithic html... ($cmd)\n" rm -rf $PACKAGE.html # in case a directory is left over eval "$cmd" html_mono_size=`calcsize $PACKAGE.html` @@ -312,24 +337,29 @@ if test -z "$use_texi2html"; then html_mono_gz_size=`calcsize "$outdir/$PACKAGE.html.gz"` copy_images "$outdir/" $PACKAGE.html mv $PACKAGE.html "$outdir/" + ls -l "$outdir/$PACKAGE.html" "$outdir/$PACKAGE.html.gz" - opt="--html -o $PACKAGE.html $commonarg $htmlarg" + opt="--html -o $PACKAGE.html --split=$split $commonarg $htmlarg" cmd="$SETLANG $MAKEINFO $opt \"$srcfile\"" - echo "Generating html by node... ($cmd)" + printf "\nGenerating html by $split... ($cmd)\n" 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" -- * + tar -czf "$abs_outdir/$PACKAGE.html_$split.tar.gz" -- * ) - html_node_tgz_size=`calcsize "$outdir/$PACKAGE.html_node.tar.gz"` - rm -rf "$outdir/html_node/" - mv $split_html_dir "$outdir/html_node/" -else + eval \ + html_${split}_tgz_size=`calcsize "$outdir/$PACKAGE.html_$split.tar.gz"` + rm -rf "$outdir/html_$split/" + mv $split_html_dir "$outdir/html_$split/" + du -s "$outdir/html_$split/" + ls -l "$outdir/$PACKAGE.html_$split.tar.gz" + +else # use texi2html: opt="--output $PACKAGE.html $commonarg $htmlarg" cmd="$SETLANG $TEXI2HTML $opt \"$srcfile\"" - echo "Generating monolithic html... ($cmd)" + printf "\nGenerating monolithic html with texi2html... ($cmd)\n" rm -rf $PACKAGE.html # in case a directory is left over eval "$cmd" html_mono_size=`calcsize $PACKAGE.html` @@ -342,19 +372,20 @@ else html_split section fi -echo Making .tar.gz for sources... +printf "\nMaking .tar.gz for sources...\n" d=`dirname $srcfile` ( cd "$d" - srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null` || true - tar cvzfh "$abs_outdir/$PACKAGE.texi.tar.gz" $srcfiles + srcfiles=`ls -d *.texinfo *.texi *.txi *.eps $source_extra 2>/dev/null` || true + tar czfh "$abs_outdir/$PACKAGE.texi.tar.gz" $srcfiles + ls -l "$abs_outdir/$PACKAGE.texi.tar.gz" ) texi_tgz_size=`calcsize "$outdir/$PACKAGE.texi.tar.gz"` if test -n "$docbook"; then opt="-o - --docbook $commonarg" cmd="$SETLANG $MAKEINFO $opt \"$srcfile\" >${srcdir}/$PACKAGE-db.xml" - echo "Generating docbook XML... ($cmd)" + printf "\nGenerating docbook XML... ($cmd)\n" eval "$cmd" docbook_xml_size=`calcsize $PACKAGE-db.xml` gzip -f -9 -c $PACKAGE-db.xml >"$outdir/$PACKAGE-db.xml.gz" @@ -364,7 +395,7 @@ if test -n "$docbook"; then split_html_db_dir=html_node_db opt="$commonarg -o $split_html_db_dir" cmd="$DOCBOOK2HTML $opt \"${outdir}/$PACKAGE-db.xml\"" - echo "Generating docbook HTML... ($cmd)" + printf "\nGenerating docbook HTML... ($cmd)\n" eval "$cmd" ( cd ${split_html_db_dir} || exit 1 @@ -377,24 +408,25 @@ if test -n "$docbook"; then rmdir ${split_html_db_dir} cmd="$DOCBOOK2TXT \"${outdir}/$PACKAGE-db.xml\"" - echo "Generating docbook ASCII... ($cmd)" + printf "\nGenerating docbook ASCII... ($cmd)\n" eval "$cmd" docbook_ascii_size=`calcsize $PACKAGE-db.txt` mv $PACKAGE-db.txt "$outdir/" cmd="$DOCBOOK2PDF \"${outdir}/$PACKAGE-db.xml\"" - echo "Generating docbook PDF... ($cmd)" + printf "\nGenerating docbook PDF... ($cmd)\n" eval "$cmd" docbook_pdf_size=`calcsize $PACKAGE-db.pdf` mv $PACKAGE-db.pdf "$outdir/" fi -echo "Writing index file..." +printf "\nMaking index file...\n" if test -z "$use_texi2html"; then - CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\ - /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d" + CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\ + /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d" else - CONDS="/%%ENDIF.*%%/d;/%%IF *HTML_SECTION%%/d;/%%IF *HTML_CHAPTER%%/d" + # should take account of --split here. + CONDS="/%%ENDIF.*%%/d;/%%IF *HTML_SECTION%%/d;/%%IF *HTML_CHAPTER%%/d" fi curdate=`$SETLANG date '+%B %d, %Y'` diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen index 0b5115443..223a61e2b 100755 --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen @@ -1,8 +1,8 @@ #!/bin/sh # Print a version string. -scriptversion=2012-07-06.14; # UTC +scriptversion=2012-12-31.23; # UTC -# Copyright (C) 2007-2012 Free Software Foundation, Inc. +# Copyright (C) 2007-2013 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 @@ -85,16 +85,18 @@ Print a version string. Options: - --prefix prefix of git tags to strip from version (default 'v') - --match pattern for git tags to match (default: '\$prefix*') + --prefix prefix of git tags (default 'v') + --match pattern for git tags to match (default: '\$prefix*') + --fallback fallback version to use if \"git --version\" fails - --help display this help and exit - --version output version information and exit + --help display this help and exit + --version output version information and exit -Running without arguments will suffice in most cases. If no --match -argument is given, only match tags that begin with the --prefix." +Running without arguments will suffice in most cases." prefix=v +fallback= + unset match unset tag_sed_script @@ -104,14 +106,15 @@ while test $# -gt 0; do --version) echo "$version"; exit 0;; --prefix) shift; prefix="$1";; --match) shift; match="$1";; + --fallback) shift; fallback="$1";; -*) echo "$0: Unknown option '$1'." >&2 echo "$0: Try '--help' for more information." >&2 exit 1;; *) - if test -z "$tarball_version_file"; then + if test "x$tarball_version_file" = x; then tarball_version_file="$1" - elif test -z "$tag_sed_script"; then + elif test "x$tag_sed_script" = x; then tag_sed_script="$1" else echo "$0: extra non-option argument '$1'." >&2 @@ -121,7 +124,7 @@ while test $# -gt 0; do shift done -if test -z "$tarball_version_file"; then +if test "x$tarball_version_file" = x; then echo "$usage" exit 1 fi @@ -146,18 +149,19 @@ then [0-9]*) ;; *) v= ;; esac - test -z "$v" \ + test "x$v" = x \ && echo "$0: WARNING: $tarball_version_file is missing or damaged" 1>&2 fi -if test -n "$v" +if test "x$v" != x then : # use $v # Otherwise, if there is at least one git commit involving the working # directory, and "git describe" output looks sensible, use that to # derive a version string. elif test "`git log -1 --pretty=format:x . 2>&1`" = x \ - && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \ + && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null \ + || git describe --abbrev=4 HEAD 2>/dev/null` \ && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \ && case $v in $prefix[0-9]*) ;; @@ -189,8 +193,10 @@ then # Remove the "g" in git describe's output string, to save a byte. v=`echo "$v" | sed 's/-/./;s/\(.*\)-g/\1-/'`; v_from_git=1 -else +elif test "x$fallback" = x || git --version >/dev/null 2>&1; then v=UNKNOWN +else + v=$fallback fi v=`echo "$v" |sed "s/^$prefix//"` @@ -198,7 +204,7 @@ v=`echo "$v" |sed "s/^$prefix//"` # Test whether to append the "-dirty" suffix only if the version # string we're using came from git. I.e., skip the test if it's "UNKNOWN" # or if it came from .tarball-version. -if test -n "$v_from_git"; then +if test "x$v_from_git" != x; then # Don't declare a version "dirty" merely because a time stamp has changed. git update-index --refresh > /dev/null 2>&1 diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index 5184edc7d..e02d34c21 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -9,7 +9,7 @@ my $VERSION = '2012-07-29 06:11'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2012 Free Software Foundation, Inc. +# Copyright (C) 2008-2013 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 diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update index 4acd69d15..268ecc068 100755 --- a/build-aux/gnu-web-doc-update +++ b/build-aux/gnu-web-doc-update @@ -1,15 +1,10 @@ #!/bin/sh # Run this after each non-alpha release, to update the web documentation at # http://www.gnu.org/software/$pkg/manual/ -# This script must be run from the top-level directory, -# assumes you're using git for revision control, -# and requires a .prev-version file as well as a Makefile, -# from which it extracts the version number and package name, respectively. -# Also, it assumes all documentation is in the doc/ sub-directory. -VERSION=2009-07-21.16; # UTC +VERSION=2012-12-16.14; # UTC -# Copyright (C) 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2009-2013 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 @@ -37,8 +32,14 @@ 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/ +This script assumes you're using git for revision control, and +requires a .prev-version file as well as a Makefile, from which it +extracts the version number and package name, respectively. Also, it +assumes all documentation is in the doc/ sub-directory. + Options: -C, --builddir=DIR location of (configured) Makefile (default: .) + -n, --dry-run don't actually commit anything --help print this help, then exit --version print version number, then exit @@ -100,12 +101,12 @@ find_tool () # 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=. +dryrun= while test $# != 0 do # Handle --option=value by splitting apart and putting back on argv. @@ -121,6 +122,7 @@ do case $1 in --help|--version) ${1#--};; -C|--builddir) shift; builddir=$1; shift ;; + -n|--dry-run) dryrun=echo; shift;; --*) die "unrecognized option: $1";; *) break;; esac @@ -139,7 +141,7 @@ current_branch=$($GIT branch | sed -ne '/^\* /{s///;p;q;}') cleanup() { __st=$? - rm -rf "$tmp" + $dryrun rm -rf "$tmp" $GIT checkout "$current_branch" $GIT submodule update --recursive $GIT branch -d $tmp_branch @@ -172,12 +174,15 @@ $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 + # Add all the files. This is simpler than trying to add only the + # new ones because of new directories: it would require iterating on + # adding the outer directories, and then their contents. + # + # find guarantees that we add outer directories first. + find . -name CVS -prune -o -print \ + | $XARGS --no-run-if-empty -- $dryrun $CVS add -ko - $CVS ci -m $version + $dryrun $CVS ci -m $version ) # Local variables: diff --git a/build-aux/gnupload b/build-aux/gnupload index a0e5c7b60..782dd6fda 100755 --- a/build-aux/gnupload +++ b/build-aux/gnupload @@ -1,9 +1,9 @@ #!/bin/sh # Sign files and upload them. -scriptversion=2012-06-11.00; # UTC +scriptversion=2012-12-11.16; # UTC -# Copyright (C) 2004-2012 Free Software Foundation, Inc. +# Copyright (C) 2004-2013 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 @@ -242,6 +242,8 @@ fi # Make sure passphrase is not exported in the environment. unset passphrase +unset passphrase_fd_0 +GNUPGHOME=${GNUPGHOME:-$HOME/.gnupg} # Reset PATH to be sure that echo is a built-in. We will later use # 'echo $passphrase' to output the passphrase, so it is important that @@ -249,12 +251,13 @@ unset passphrase # listings with their arguments...). # Remember this script runs with 'set -e', so if echo is not built-in # it will exit now. -if $dry_run; then :; else +if $dry_run || grep -q "^use-agent" $GNUPGHOME/gpg.conf; then :; else PATH=/empty echo -n "Enter GPG passphrase: " stty -echo read -r passphrase stty echo echo + passphrase_fd_0="--passphrase-fd 0" fi if test $# -ne 0; then @@ -262,7 +265,7 @@ if test $# -ne 0; then do echo "Signing $file ..." rm -f $file.sig - echo "$passphrase" | $dbg $GPG --passphrase-fd 0 -ba -o $file.sig $file + echo "$passphrase" | $dbg $GPG $passphrase_fd_0 -ba -o $file.sig $file done fi @@ -320,12 +323,12 @@ upload () case $dest in alpha.gnu.org:*) mkdirective "$destdir" "$base" "$file" "$stmt" - echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive + echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign $base.directive $dbg ncftpput ftp-upload.gnu.org /incoming/alpha $files $base.directive.asc ;; ftp.gnu.org:*) mkdirective "$destdir" "$base" "$file" "$stmt" - echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive + echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign $base.directive $dbg ncftpput ftp-upload.gnu.org /incoming/ftp $files $base.directive.asc ;; savannah.gnu.org:*) @@ -344,7 +347,7 @@ upload () destdir_p1=`echo "$destdir" | sed 's,^[^/]*/,,'` destdir_topdir=`echo "$destdir" | sed 's,/.*,,'` mkdirective "$destdir_p1" "$base" "$file" "$stmt" - echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive + echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign $base.directive for f in $files $base.directive.asc do echo put $f @@ -353,7 +356,7 @@ upload () /*) dest_host=`echo "$dest" | sed 's,:.*,,'` mkdirective "$destdir" "$base" "$file" "$stmt" - echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign $base.directive + echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign $base.directive $dbg cp $files $base.directive.asc $dest_host ;; *) diff --git a/build-aux/snippet/arg-nonnull.h b/build-aux/snippet/arg-nonnull.h index 3a9dd2664..8ea2a4747 100644 --- a/build-aux/snippet/arg-nonnull.h +++ b/build-aux/snippet/arg-nonnull.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific arguments must not be NULL. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 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 diff --git a/build-aux/snippet/c++defs.h b/build-aux/snippet/c++defs.h index 96da94b97..b35b933cd 100644 --- a/build-aux/snippet/c++defs.h +++ b/build-aux/snippet/c++defs.h @@ -1,5 +1,5 @@ /* C++ compatible function declaration macros. - Copyright (C) 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2010-2013 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 diff --git a/build-aux/snippet/unused-parameter.h b/build-aux/snippet/unused-parameter.h index 1c8d61f28..1347c2787 100644 --- a/build-aux/snippet/unused-parameter.h +++ b/build-aux/snippet/unused-parameter.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific function parameters are not used. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 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 diff --git a/build-aux/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h index d4cb94f35..1736a1bd7 100644 --- a/build-aux/snippet/warn-on-use.h +++ b/build-aux/snippet/warn-on-use.h @@ -1,5 +1,5 @@ /* A C macro for emitting warnings if a function is used. - Copyright (C) 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2010-2013 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 @@ -55,7 +55,7 @@ rather than issue the nice warning, but the end result of informing the developer about their portability problem is still achieved): #if HAVE_RAW_DECL_ENVIRON - static inline char ***rpl_environ (void) { return &environ; } + static char ***rpl_environ (void) { return &environ; } _GL_WARN_ON_USE (rpl_environ, "environ is not always properly declared"); # undef environ # define environ (*rpl_environ ()) diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free index 2b646308e..663347a3a 100755 --- a/build-aux/useless-if-before-free +++ b/build-aux/useless-if-before-free @@ -10,7 +10,7 @@ my $VERSION = '2012-01-06 07:23'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2012 Free Software Foundation, Inc. +# Copyright (C) 2008-2013 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 diff --git a/build-aux/vc-list-files b/build-aux/vc-list-files index d477da8e9..7ec335fbd 100755 --- a/build-aux/vc-list-files +++ b/build-aux/vc-list-files @@ -4,7 +4,7 @@ # Print a version string. scriptversion=2011-05-16.22; # UTC -# Copyright (C) 2006-2012 Free Software Foundation, Inc. +# Copyright (C) 2006-2013 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 diff --git a/doc/gendocs_template b/doc/gendocs_template index a62ad6167..63fbe539a 100644 --- a/doc/gendocs_template +++ b/doc/gendocs_template @@ -75,7 +75,7 @@ the FSF.<br /> Please send broken links and other corrections or suggestions to <a href="mailto:%%EMAIL%%"><%%EMAIL%%></a>.</p> -<p>Copyright © 2012 Free Software Foundation, Inc.</p> +<p>Copyright © 2013 Free Software Foundation, Inc.</p> <p>Verbatim copying and distribution of this entire article are permitted worldwide, without royalty, in any medium, provided this diff --git a/gnulib-local/build-aux/git-version-gen.diff b/gnulib-local/build-aux/git-version-gen.diff index c222a99a1..f875f49d9 100644 --- a/gnulib-local/build-aux/git-version-gen.diff +++ b/gnulib-local/build-aux/git-version-gen.diff @@ -2,47 +2,33 @@ This patch is being discussed at <http://lists.gnu.org/archive/html/bug-gnulib/2012-07/msg00079.html>. Remove when integrated in Gnulib. ---- a/build-aux/git-version-gen 2012-06-12 21:25:48.000000000 +0200 -+++ b/build-aux/git-version-gen 2012-07-07 01:52:08.000000000 +0200 -@@ -1,6 +1,6 @@ - #!/bin/sh - # Print a version string. --scriptversion=2012-03-18.17; # UTC -+scriptversion=2012-07-06.14; # UTC - - # Copyright (C) 2007-2012 Free Software Foundation, Inc. - # -@@ -85,20 +85,25 @@ - +--- a/build-aux/git-version-gen ++++ b/build-aux/git-version-gen +@@ -86,6 +86,7 @@ Print a version string. Options: -- --prefix prefix of git tags (default 'v') -+ --prefix prefix of git tags to strip from version (default 'v') -+ --match pattern for git tags to match (default: '\$prefix*') - -- --help display this help and exit -- --version output version information and exit -+ --help display this help and exit -+ --version output version information and exit - --Running without arguments will suffice in most cases." -+Running without arguments will suffice in most cases. If no --match -+argument is given, only match tags that begin with the --prefix." + --prefix prefix of git tags (default 'v') ++ --match pattern for git tags to match (default: '\$prefix*') + --fallback fallback version to use if \"git --version\" fails + --help display this help and exit +@@ -96,11 +97,15 @@ Running without arguments will suffice in most cases." prefix=v + fallback= + +unset match +unset tag_sed_script - ++ while test $# -gt 0; do case $1 in --help) echo "$usage"; exit 0;; --version) echo "$version"; exit 0;; --prefix) shift; prefix="$1";; + --match) shift; match="$1";; + --fallback) shift; fallback="$1";; -*) echo "$0: Unknown option '$1'." >&2 - echo "$0: Try '--help' for more information." >&2 -@@ -121,6 +126,7 @@ +@@ -124,6 +129,7 @@ if test "x$tarball_version_file" = x; then exit 1 fi @@ -50,13 +36,12 @@ Remove when integrated in Gnulib. tag_sed_script="${tag_sed_script:-s/x/x/}" nl=' -@@ -151,8 +157,7 @@ +@@ -154,7 +160,7 @@ then # directory, and "git describe" output looks sensible, use that to # derive a version string. elif test "`git log -1 --pretty=format:x . 2>&1`" = x \ - && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \ -- || git describe --abbrev=4 HEAD 2>/dev/null` \ -+ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \ ++ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null \ + || git describe --abbrev=4 HEAD 2>/dev/null` \ && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \ && case $v in - $prefix[0-9]*) ;; diff --git a/lib/Makefile.am b/lib/Makefile.am index 49c5140f2..1714cbb8c 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -1,6 +1,6 @@ ## DO NOT EDIT! GENERATED AUTOMATICALLY! ## Process this file with automake to produce Makefile.in. -# Copyright (C) 2002-2012 Free Software Foundation, Inc. +# Copyright (C) 2002-2013 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -1006,6 +1006,7 @@ EXTRA_DIST += malloca.h malloca.valgrind ## begin gnulib module math BUILT_SOURCES += math.h +libgnu_la_SOURCES += math.c # We need the following in order to create <math.h> when the system # doesn't have one that works with the given compiler. @@ -2093,6 +2094,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's/@''GNULIB_REALLOC_POSIX''@/$(GNULIB_REALLOC_POSIX)/g' \ -e 's/@''GNULIB_REALPATH''@/$(GNULIB_REALPATH)/g' \ -e 's/@''GNULIB_RPMATCH''@/$(GNULIB_RPMATCH)/g' \ + -e 's/@''GNULIB_SECURE_GETENV''@/$(GNULIB_SECURE_GETENV)/g' \ -e 's/@''GNULIB_SETENV''@/$(GNULIB_SETENV)/g' \ -e 's/@''GNULIB_STRTOD''@/$(GNULIB_STRTOD)/g' \ -e 's/@''GNULIB_STRTOLL''@/$(GNULIB_STRTOLL)/g' \ @@ -2121,6 +2123,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''HAVE_RANDOM_R''@|$(HAVE_RANDOM_R)|g' \ -e 's|@''HAVE_REALPATH''@|$(HAVE_REALPATH)|g' \ -e 's|@''HAVE_RPMATCH''@|$(HAVE_RPMATCH)|g' \ + -e 's|@''HAVE_SECURE_GETENV''@|$(HAVE_SECURE_GETENV)|g' \ -e 's|@''HAVE_DECL_SETENV''@|$(HAVE_DECL_SETENV)|g' \ -e 's|@''HAVE_STRTOD''@|$(HAVE_STRTOD)|g' \ -e 's|@''HAVE_STRTOLL''@|$(HAVE_STRTOLL)|g' \ @@ -2314,6 +2317,7 @@ EXTRA_DIST += sys_file.in.h ## begin gnulib module sys_socket BUILT_SOURCES += sys/socket.h +libgnu_la_SOURCES += sys_socket.c # We need the following in order to create <sys/socket.h> when the system # doesn't have one that works with the given compiler. @@ -2572,6 +2576,7 @@ EXTRA_libgnu_la_SOURCES += trunc.c ## begin gnulib module unistd BUILT_SOURCES += unistd.h +libgnu_la_SOURCES += unistd.c # We need the following in order to create an empty placeholder for # <unistd.h> when the system doesn't have one. @@ -2963,6 +2968,7 @@ EXTRA_libgnu_la_SOURCES += wcrtomb.c ## begin gnulib module wctype-h BUILT_SOURCES += wctype.h +libgnu_la_SOURCES += wctype-h.c # We need the following in order to create <wctype.h> when the system # doesn't have one that works with the given compiler. diff --git a/lib/accept.c b/lib/accept.c index 78bb8220c..0c8e52e66 100644 --- a/lib/accept.c +++ b/lib/accept.c @@ -1,6 +1,6 @@ /* accept.c --- wrappers for Windows accept function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alignof.h b/lib/alignof.h index b6d866694..2bf3820ee 100644 --- a/lib/alignof.h +++ b/lib/alignof.h @@ -1,5 +1,5 @@ /* Determine alignment of types. - Copyright (C) 2003-2004, 2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2003-2004, 2006, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alloca.in.h b/lib/alloca.in.h index c36bdf9ae..19aea41d6 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,6 +1,6 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2012 Free Software Foundation, + Copyright (C) 1995, 1999, 2001-2004, 2006-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h index e58072362..5344a924f 100644 --- a/lib/arpa_inet.in.h +++ b/lib/arpa_inet.in.h @@ -1,6 +1,6 @@ /* A GNU-like <arpa/inet.h>. - Copyright (C) 2005-2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/asnprintf.c b/lib/asnprintf.c index 778068fd9..8c399b2a1 100644 --- a/lib/asnprintf.c +++ b/lib/asnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999, 2002, 2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1999, 2002, 2006, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/basename-lgpl.c b/lib/basename-lgpl.c index 8ddbfc327..5e89d2688 100644 --- a/lib/basename-lgpl.c +++ b/lib/basename-lgpl.c @@ -1,6 +1,6 @@ /* basename.c -- return the last element in a file name - Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2012 Free Software + Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/binary-io.h b/lib/binary-io.h index 30315e10c..b2095a21a 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,5 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2005, 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/bind.c b/lib/bind.c index 1a2a3b6e0..e26f88e15 100644 --- a/lib/bind.c +++ b/lib/bind.c @@ -1,6 +1,6 @@ /* bind.c --- wrappers for Windows bind function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/btowc.c b/lib/btowc.c index 485e99554..aca574291 100644 --- a/lib/btowc.c +++ b/lib/btowc.c @@ -1,5 +1,5 @@ /* Convert unibyte character to wide character. - Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2008, 2010-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h index a9baa6882..6c7ab6d57 100644 --- a/lib/byteswap.in.h +++ b/lib/byteswap.in.h @@ -1,5 +1,5 @@ /* byteswap.h - Byte swapping - Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2013 Free Software Foundation, Inc. Written by Oskar Liljeblad <oskar@osk.mine.nu>, 2005. This program is free software: you can redistribute it and/or modify diff --git a/lib/c-ctype.c b/lib/c-ctype.c index 6b388faea..ccd8d94ed 100644 --- a/lib/c-ctype.c +++ b/lib/c-ctype.c @@ -1,6 +1,6 @@ /* Character handling in C locale. - Copyright 2000-2003, 2006, 2009-2012 Free Software Foundation, Inc. + Copyright 2000-2003, 2006, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-ctype.h b/lib/c-ctype.h index 6ef055022..64bae0649 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,7 +5,7 @@ <ctype.h> functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2006, 2008-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-strcase.h b/lib/c-strcase.h index 4d8b60c30..e484aa89c 100644 --- a/lib/c-strcase.h +++ b/lib/c-strcase.h @@ -1,5 +1,5 @@ /* Case-insensitive string comparison functions in C locale. - Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2012 Free Software + Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index 69831953e..765b25a32 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,5 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h index 25e6e07e4..53ce1e159 100644 --- a/lib/c-strcaseeq.h +++ b/lib/c-strcaseeq.h @@ -1,5 +1,5 @@ /* Optimized case-insensitive string comparison in C locale. - Copyright (C) 2001-2002, 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index dbec89ee1..ad5f4f6b2 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,5 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index 16550cf19..5451791cc 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -1,5 +1,5 @@ /* Return the canonical absolute name of a given file. - Copyright (C) 1996-2012 Free Software Foundation, Inc. + Copyright (C) 1996-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify @@ -16,16 +16,16 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. */ #ifndef _LIBC +/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc + optimizes away the name == NULL test below. */ +# define _GL_ARG_NONNULL(params) + # define _GL_USE_STDLIB_ALLOC 1 # include <config.h> #endif #if !HAVE_CANONICALIZE_FILE_NAME || !FUNC_REALPATH_WORKS || defined _LIBC -/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc - optimizes away the name == NULL test below. */ -#define _GL_ARG_NONNULL(params) - /* Specification. */ #include <stdlib.h> @@ -51,6 +51,7 @@ # define __realpath realpath # include "pathmax.h" # include "malloca.h" +# include "dosname.h" # if HAVE_GETCWD # if IN_RELOCWRAPPER /* When building the relocatable program wrapper, use the system's getcwd @@ -101,6 +102,7 @@ __realpath (const char *name, char *resolved) const char *start, *end, *rpath_limit; long int path_max; int num_links = 0; + size_t prefix_len; if (name == NULL) { @@ -143,7 +145,11 @@ __realpath (const char *name, char *resolved) rpath = resolved; rpath_limit = rpath + path_max; - if (name[0] != '/') + /* This is always zero for Posix hosts, but can be 2 for MS-Windows + and MS-DOS X:/foo/bar file names. */ + prefix_len = FILE_SYSTEM_PREFIX_LEN (name); + + if (!IS_ABSOLUTE_FILE_NAME (name)) { if (!__getcwd (rpath, path_max)) { @@ -151,20 +157,28 @@ __realpath (const char *name, char *resolved) goto error; } dest = strchr (rpath, '\0'); + start = name; + prefix_len = FILE_SYSTEM_PREFIX_LEN (rpath); } else { - rpath[0] = '/'; - dest = rpath + 1; + dest = rpath; + if (prefix_len) + { + memcpy (rpath, name, prefix_len); + dest += prefix_len; + } + *dest++ = '/'; if (DOUBLE_SLASH_IS_DISTINCT_ROOT) { - if (name[1] == '/' && name[2] != '/') + if (ISSLASH (name[1]) && !ISSLASH (name[2]) && !prefix_len) *dest++ = '/'; *dest = '\0'; } + start = name + prefix_len; } - for (start = end = name; *start; start = end) + for (end = start; *start; start = end) { #ifdef _LIBC struct stat64 st; @@ -174,11 +188,11 @@ __realpath (const char *name, char *resolved) int n; /* Skip sequence of multiple path-separators. */ - while (*start == '/') + while (ISSLASH (*start)) ++start; /* Find end of path component. */ - for (end = start; *end && *end != '/'; ++end) + for (end = start; *end && !ISSLASH (*end); ++end) /* Nothing. */; if (end - start == 0) @@ -188,17 +202,19 @@ __realpath (const char *name, char *resolved) else if (end - start == 2 && start[0] == '.' && start[1] == '.') { /* Back up to previous component, ignore if at root already. */ - if (dest > rpath + 1) - while ((--dest)[-1] != '/'); - if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 - && *dest == '/' && dest[1] != '/') + if (dest > rpath + prefix_len + 1) + for (--dest; dest > rpath && !ISSLASH (dest[-1]); --dest) + continue; + if (DOUBLE_SLASH_IS_DISTINCT_ROOT + && dest == rpath + 1 && !prefix_len + && ISSLASH (*dest) && !ISSLASH (dest[1])) dest++; } else { size_t new_size; - if (dest[-1] != '/') + if (!ISSLASH (dest[-1])) *dest++ = '/'; if (dest + (end - start) >= rpath_limit) @@ -209,7 +225,7 @@ __realpath (const char *name, char *resolved) if (resolved) { __set_errno (ENAMETOOLONG); - if (dest > rpath + 1) + if (dest > rpath + prefix_len + 1) dest--; *dest = '\0'; goto error; @@ -299,24 +315,32 @@ __realpath (const char *name, char *resolved) memmove (&extra_buf[n], end, len + 1); name = end = memcpy (extra_buf, buf, n); - if (buf[0] == '/') + if (IS_ABSOLUTE_FILE_NAME (buf)) { - dest = rpath + 1; /* It's an absolute symlink */ + size_t pfxlen = FILE_SYSTEM_PREFIX_LEN (buf); + + if (pfxlen) + memcpy (rpath, buf, pfxlen); + dest = rpath + pfxlen; + *dest++ = '/'; /* It's an absolute symlink */ if (DOUBLE_SLASH_IS_DISTINCT_ROOT) { - if (buf[1] == '/' && buf[2] != '/') + if (ISSLASH (buf[1]) && !ISSLASH (buf[2]) && !pfxlen) *dest++ = '/'; *dest = '\0'; } + /* Install the new prefix to be in effect hereafter. */ + prefix_len = pfxlen; } else { /* Back up to previous component, ignore if at root already: */ - if (dest > rpath + 1) - while ((--dest)[-1] != '/'); + if (dest > rpath + prefix_len + 1) + for (--dest; dest > rpath && !ISSLASH (dest[-1]); --dest) + continue; if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 - && *dest == '/' && dest[1] != '/') + && ISSLASH (*dest) && !ISSLASH (dest[1]) && !prefix_len) dest++; } } @@ -327,10 +351,10 @@ __realpath (const char *name, char *resolved) } } } - if (dest > rpath + 1 && dest[-1] == '/') + if (dest > rpath + prefix_len + 1 && ISSLASH (dest[-1])) --dest; - if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 - && *dest == '/' && dest[1] != '/') + if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 && !prefix_len + && ISSLASH (*dest) && !ISSLASH (dest[1])) dest++; *dest = '\0'; diff --git a/lib/ceil.c b/lib/ceil.c index 810179ca7..3a264ae1b 100644 --- a/lib/ceil.c +++ b/lib/ceil.c @@ -1,5 +1,5 @@ /* Round towards positive infinity. - Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/close.c b/lib/close.c index 2b6f59803..02ff0b187 100644 --- a/lib/close.c +++ b/lib/close.c @@ -1,5 +1,5 @@ /* close replacement. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/config.charset b/lib/config.charset index 58ac759c4..f15f5bb5b 100644 --- a/lib/config.charset +++ b/lib/config.charset @@ -1,7 +1,7 @@ #! /bin/sh # Output a system dependent table of character encoding aliases. # -# Copyright (C) 2000-2004, 2006-2012 Free Software Foundation, Inc. +# Copyright (C) 2000-2004, 2006-2013 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/connect.c b/lib/connect.c index 303cd0b4d..03746f805 100644 --- a/lib/connect.c +++ b/lib/connect.c @@ -1,6 +1,6 @@ /* connect.c --- wrappers for Windows connect function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirent.in.h b/lib/dirent.in.h index 888241597..aff6af3e1 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -1,5 +1,5 @@ /* A GNU-like <dirent.h>. - Copyright (C) 2006-2012 Free Software Foundation, Inc. + Copyright (C) 2006-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirfd.c b/lib/dirfd.c index 7013010ba..c535b17bc 100644 --- a/lib/dirfd.c +++ b/lib/dirfd.c @@ -1,6 +1,6 @@ /* dirfd.c -- return the file descriptor associated with an open DIR* - Copyright (C) 2001, 2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2001, 2006, 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirname-lgpl.c b/lib/dirname-lgpl.c index 5d0cc074b..90597ac25 100644 --- a/lib/dirname-lgpl.c +++ b/lib/dirname-lgpl.c @@ -1,6 +1,6 @@ /* dirname.c -- return all but the last element in a file name - Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2012 Free Software + Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dirname.h b/lib/dirname.h index ce77baf0e..4b5acd956 100644 --- a/lib/dirname.h +++ b/lib/dirname.h @@ -1,6 +1,6 @@ /* Take file names apart into directory and base names. - Copyright (C) 1998, 2001, 2003-2006, 2009-2012 Free Software Foundation, + Copyright (C) 1998, 2001, 2003-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dosname.h b/lib/dosname.h index f4b14399f..82d62e51b 100644 --- a/lib/dosname.h +++ b/lib/dosname.h @@ -1,6 +1,6 @@ /* File names on MS-DOS/Windows systems. - Copyright (C) 2000-2001, 2004-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2000-2001, 2004-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/duplocale.c b/lib/duplocale.c index dd85efef2..5a291b9e0 100644 --- a/lib/duplocale.c +++ b/lib/duplocale.c @@ -1,5 +1,5 @@ /* Duplicate a locale object. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/errno.in.h b/lib/errno.in.h index 774c786ba..f2295cd2b 100644 --- a/lib/errno.in.h +++ b/lib/errno.in.h @@ -1,6 +1,6 @@ /* A POSIX-like <errno.h>. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index 5c934c025..f71ce2f52 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -1,6 +1,6 @@ /* Like <fcntl.h>, but with non-working flags defined to 0. - Copyright (C) 2006-2012 Free Software Foundation, Inc. + Copyright (C) 2006-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fd-hook.c b/lib/fd-hook.c index 39e25eaf1..cafd91cca 100644 --- a/lib/fd-hook.c +++ b/lib/fd-hook.c @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2009. This program is free software: you can redistribute it and/or modify it diff --git a/lib/fd-hook.h b/lib/fd-hook.h index b3b200dce..397dbb09c 100644 --- a/lib/fd-hook.h +++ b/lib/fd-hook.h @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/float+.h b/lib/float+.h index fd4a9ed08..1bd368c73 100644 --- a/lib/float+.h +++ b/lib/float+.h @@ -1,5 +1,5 @@ /* Supplemental information about the floating-point formats. - Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2007. This program is free software; you can redistribute it and/or modify diff --git a/lib/float.c b/lib/float.c index 94c6cfdab..37b0b4960 100644 --- a/lib/float.c +++ b/lib/float.c @@ -1,5 +1,5 @@ /* Auxiliary definitions for <float.h>. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/float.in.h b/lib/float.in.h index b3740b875..40875a23a 100644 --- a/lib/float.in.h +++ b/lib/float.in.h @@ -1,6 +1,6 @@ /* A correct <float.h>. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/flock.c b/lib/flock.c index 3eb9abb5c..f15fe1235 100644 --- a/lib/flock.c +++ b/lib/flock.c @@ -6,7 +6,7 @@ Written by Richard W.M. Jones <rjones.at.redhat.com> - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-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 diff --git a/lib/floor.c b/lib/floor.c index 7efbe9e30..3dca6f57b 100644 --- a/lib/floor.c +++ b/lib/floor.c @@ -1,5 +1,5 @@ /* Round towards negative infinity. - Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/frexp.c b/lib/frexp.c index baeb46205..eb2b3792a 100644 --- a/lib/frexp.c +++ b/lib/frexp.c @@ -1,5 +1,5 @@ /* Split a double into fraction and mantissa. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fstat.c b/lib/fstat.c index 3f49e9b9b..121f4bfb5 100644 --- a/lib/fstat.c +++ b/lib/fstat.c @@ -1,5 +1,5 @@ /* fstat() replacement. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -31,7 +31,7 @@ #endif #undef __need_system_sys_stat_h -static inline int +static int orig_fstat (int fd, struct stat *buf) { return fstat (fd, buf); @@ -51,7 +51,7 @@ orig_fstat (int fd, struct stat *buf) #endif #if HAVE_MSVC_INVALID_PARAMETER_HANDLER -static inline int +static int fstat_nothrow (int fd, struct stat *buf) { int result; diff --git a/lib/full-read.c b/lib/full-read.c index 68b273d9b..f884bb6bf 100644 --- a/lib/full-read.c +++ b/lib/full-read.c @@ -1,5 +1,5 @@ /* An interface to read that retries after partial reads and interrupts. - Copyright (C) 2002-2003, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-read.h b/lib/full-read.h index fdf2331ff..81f6edfd2 100644 --- a/lib/full-read.h +++ b/lib/full-read.h @@ -1,6 +1,6 @@ /* An interface to read() that reads all it is asked to read. - Copyright (C) 2002, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.c b/lib/full-write.c index 20d99b7b1..8f307987f 100644 --- a/lib/full-write.c +++ b/lib/full-write.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries (if necessary) until complete. - Copyright (C) 1993-1994, 1997-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1993-1994, 1997-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.h b/lib/full-write.h index 018b25cef..cb05bff32 100644 --- a/lib/full-write.h +++ b/lib/full-write.h @@ -1,6 +1,6 @@ /* An interface to write() that writes all it is asked to write. - Copyright (C) 2002-2003, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c index 8b3669455..0205a78a8 100644 --- a/lib/gai_strerror.c +++ b/lib/gai_strerror.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2012 Free Software +/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Philip Blundell <pjb27@cam.ac.uk>, 1997. diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c index e53a69b20..9b0297ce0 100644 --- a/lib/getaddrinfo.c +++ b/lib/getaddrinfo.c @@ -1,5 +1,5 @@ /* Get address information (partial implementation). - Copyright (C) 1997, 2001-2002, 2004-2012 Free Software Foundation, Inc. + Copyright (C) 1997, 2001-2002, 2004-2013 Free Software Foundation, Inc. Contributed by Simon Josefsson <simon@josefsson.org>. This program is free software; you can redistribute it and/or modify @@ -15,12 +15,12 @@ You should have received a copy of the GNU Lesser General Public License along with this program; if not, see <http://www.gnu.org/licenses/>. */ -#include <config.h> - /* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc optimizes away the sa == NULL test below. */ #define _GL_ARG_NONNULL(params) +#include <config.h> + #include <netdb.h> #if HAVE_NETINET_IN_H @@ -109,7 +109,7 @@ use_win32_p (void) } #endif -static inline bool +static bool validate_family (int family) { /* FIXME: Support more families. */ diff --git a/lib/getpeername.c b/lib/getpeername.c index 02e3faddc..307c9e2ca 100644 --- a/lib/getpeername.c +++ b/lib/getpeername.c @@ -1,6 +1,6 @@ /* getpeername.c --- wrappers for Windows getpeername function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockname.c b/lib/getsockname.c index 890c50ead..daac0c0c2 100644 --- a/lib/getsockname.c +++ b/lib/getsockname.c @@ -1,6 +1,6 @@ /* getsockname.c --- wrappers for Windows getsockname function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockopt.c b/lib/getsockopt.c index 0bf74b0d5..c80487fdf 100644 --- a/lib/getsockopt.c +++ b/lib/getsockopt.c @@ -1,6 +1,6 @@ /* getsockopt.c --- wrappers for Windows getsockopt function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gettext.h b/lib/gettext.h index d130faa2b..2cc0e0551 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -1,5 +1,5 @@ /* Convenience header for conditional use of GNU <libintl.h>. - Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2012 Free Software + Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/iconv.c b/lib/iconv.c index de2fb315d..933730b58 100644 --- a/lib/iconv.c +++ b/lib/iconv.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 1999-2001, 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1999-2001, 2007, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv.in.h b/lib/iconv.in.h index e15094764..2e7efbef8 100644 --- a/lib/iconv.in.h +++ b/lib/iconv.in.h @@ -1,6 +1,6 @@ /* A GNU-like <iconv.h>. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_close.c b/lib/iconv_close.c index d8b027a42..3492f283b 100644 --- a/lib/iconv_close.c +++ b/lib/iconv_close.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_open.c b/lib/iconv_open.c index c01124153..eaf7c7d8a 100644 --- a/lib/iconv_open.c +++ b/lib/iconv_open.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconveh.h b/lib/iconveh.h index 4a4f50633..8d792ac3c 100644 --- a/lib/iconveh.h +++ b/lib/iconveh.h @@ -1,5 +1,5 @@ /* Character set conversion handler type. - Copyright (C) 2001-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible. This program is free software: you can redistribute it and/or modify diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c index 0ccd997d0..96202e269 100644 --- a/lib/inet_ntop.c +++ b/lib/inet_ntop.c @@ -1,6 +1,6 @@ /* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form - Copyright (C) 2005-2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/inet_pton.c b/lib/inet_pton.c index 36e981a3e..08f1b20af 100644 --- a/lib/inet_pton.c +++ b/lib/inet_pton.c @@ -1,6 +1,6 @@ /* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form - Copyright (C) 2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2006, 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isinf.c b/lib/isinf.c index 5efaa9dd3..24c32d331 100644 --- a/lib/isinf.c +++ b/lib/isinf.c @@ -1,5 +1,5 @@ /* Test for positive or negative infinity. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnan.c b/lib/isnan.c index 1faa28a5b..18fa5a2ec 100644 --- a/lib/isnan.c +++ b/lib/isnan.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand-nolibm.h b/lib/isnand-nolibm.h index e9e64db4a..35102024b 100644 --- a/lib/isnand-nolibm.h +++ b/lib/isnand-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand.c b/lib/isnand.c index 308caac91..9bd092bb2 100644 --- a/lib/isnand.c +++ b/lib/isnand.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf.c b/lib/isnanf.c index 6376ce09d..503575f84 100644 --- a/lib/isnanf.c +++ b/lib/isnanf.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl.c b/lib/isnanl.c index cfe254506..967eaff6e 100644 --- a/lib/isnanl.c +++ b/lib/isnanl.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/itold.c b/lib/itold.c index 0c41e2d01..ff43bd08d 100644 --- a/lib/itold.c +++ b/lib/itold.c @@ -1,5 +1,5 @@ /* Replacement for 'int' to 'long double' conversion routine. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h index 63b92fd3a..d60a9802a 100644 --- a/lib/langinfo.in.h +++ b/lib/langinfo.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around <langinfo.h>. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/listen.c b/lib/listen.c index 28f3aafcd..ea6eddcbb 100644 --- a/lib/listen.c +++ b/lib/listen.c @@ -1,6 +1,6 @@ /* listen.c --- wrappers for Windows listen function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localcharset.c b/lib/localcharset.c index c4a0596be..e967ee513 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -1,6 +1,6 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2000-2006, 2008-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localcharset.h b/lib/localcharset.h index b4467f6b7..4580edf3c 100644 --- a/lib/localcharset.h +++ b/lib/localcharset.h @@ -1,5 +1,5 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2003, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2009-2013 Free Software Foundation, Inc. This file is part of the GNU CHARSET Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/locale.in.h b/lib/locale.in.h index 89b674507..ca67816af 100644 --- a/lib/locale.in.h +++ b/lib/locale.in.h @@ -1,5 +1,5 @@ /* A POSIX <locale.h>. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -14,16 +14,30 @@ You should have received a copy of the GNU Lesser General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. */ -#ifndef _@GUARD_PREFIX@_LOCALE_H - #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ +#ifdef _GL_ALREADY_INCLUDING_LOCALE_H + +/* Special invocation conventions to handle Solaris header files + (through Solaris 10) when combined with gettext's libintl.h. */ + +#@INCLUDE_NEXT@ @NEXT_LOCALE_H@ + +#else +/* Normal invocation convention. */ + +#ifndef _@GUARD_PREFIX@_LOCALE_H + +#define _GL_ALREADY_INCLUDING_LOCALE_H + /* The include_next requires a split double-inclusion guard. */ #@INCLUDE_NEXT@ @NEXT_LOCALE_H@ +#undef _GL_ALREADY_INCLUDING_LOCALE_H + #ifndef _@GUARD_PREFIX@_LOCALE_H #define _@GUARD_PREFIX@_LOCALE_H @@ -198,4 +212,5 @@ _GL_WARN_ON_USE (duplocale, "duplocale is buggy on some glibc systems - " #endif #endif /* _@GUARD_PREFIX@_LOCALE_H */ +#endif /* ! _GL_ALREADY_INCLUDING_LOCALE_H */ #endif /* _@GUARD_PREFIX@_LOCALE_H */ diff --git a/lib/localeconv.c b/lib/localeconv.c index c22860ca3..41396a008 100644 --- a/lib/localeconv.c +++ b/lib/localeconv.c @@ -1,5 +1,5 @@ /* Query locale dependent information for formatting numbers. - Copyright (C) 2012 Free Software Foundation, Inc. + Copyright (C) 2012-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log.c b/lib/log.c index 9ec5eaee8..892721a56 100644 --- a/lib/log.c +++ b/lib/log.c @@ -1,5 +1,5 @@ /* Logarithm. - Copyright (C) 2012 Free Software Foundation, Inc. + Copyright (C) 2012-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log1p.c b/lib/log1p.c index 397b140e6..8c0788a8d 100644 --- a/lib/log1p.c +++ b/lib/log1p.c @@ -1,5 +1,5 @@ /* Natural logarithm of 1 plus argument. - Copyright (C) 2012 Free Software Foundation, Inc. + Copyright (C) 2012-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/lstat.c b/lib/lstat.c index fe20e61d4..b0873d3fb 100644 --- a/lib/lstat.c +++ b/lib/lstat.c @@ -1,6 +1,6 @@ /* Work around a bug of lstat on some systems - Copyright (C) 1997-2006, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 1997-2006, 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -35,7 +35,7 @@ typedef int dummy; # include <sys/stat.h> # undef __need_system_sys_stat_h -static inline int +static int orig_lstat (const char *filename, struct stat *buf) { return lstat (filename, buf); diff --git a/lib/malloc.c b/lib/malloc.c index 109c65cd8..8124cad70 100644 --- a/lib/malloc.c +++ b/lib/malloc.c @@ -1,6 +1,6 @@ /* malloc() function that is glibc compatible. - Copyright (C) 1997-1998, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1997-1998, 2006-2007, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloca.c b/lib/malloca.c index 2d4c47972..04ddc236e 100644 --- a/lib/malloca.c +++ b/lib/malloca.c @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/malloca.h b/lib/malloca.h index deb9bdaa0..77476793e 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/math.c b/lib/math.c new file mode 100644 index 000000000..ddb2ded53 --- /dev/null +++ b/lib/math.c @@ -0,0 +1,3 @@ +#include <config.h> +#define _GL_MATH_INLINE _GL_EXTERN_INLINE +#include "math.h" diff --git a/lib/math.in.h b/lib/math.in.h index ee0fc9545..46d0cf189 100644 --- a/lib/math.in.h +++ b/lib/math.in.h @@ -1,6 +1,6 @@ /* A GNU-like <math.h>. - Copyright (C) 2002-2003, 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -28,6 +28,10 @@ #ifndef _@GUARD_PREFIX@_MATH_H #define _@GUARD_PREFIX@_MATH_H +_GL_INLINE_HEADER_BEGIN +#ifndef _GL_MATH_INLINE +# define _GL_MATH_INLINE _GL_INLINE +#endif /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ @@ -78,17 +82,17 @@ func (long double l) \ classification macros with an argument of real-floating (that is, one of float, double, or long double). */ #define _GL_WARN_REAL_FLOATING_DECL(func) \ -static inline int \ +_GL_MATH_INLINE int \ rpl_ ## func ## f (float f) \ { \ return func (f); \ } \ -static inline int \ +_GL_MATH_INLINE int \ rpl_ ## func ## d (double d) \ { \ return func (d); \ } \ -static inline int \ +_GL_MATH_INLINE int \ rpl_ ## func ## l (long double l) \ { \ return func (l); \ @@ -124,7 +128,7 @@ static void (*_gl_math_fix_itold) (long double *, int) = _Qp_itoq; /* The Compaq (ex-DEC) C 6.4 compiler and the Microsoft MSVC 9 compiler choke on the expression 0.0 / 0.0. */ # if defined __DECC || defined _MSC_VER -static float +_GL_MATH_INLINE float _NaN () { static float zero = 0.0f; @@ -2265,6 +2269,7 @@ _GL_WARN_REAL_FLOATING_DECL (signbit); # endif #endif +_GL_INLINE_HEADER_END #endif /* _@GUARD_PREFIX@_MATH_H */ #endif /* _@GUARD_PREFIX@_MATH_H */ diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c index 5f2ec0704..75d10bce2 100644 --- a/lib/mbrtowc.c +++ b/lib/mbrtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 1999-2002, 2005-2012 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2005-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbsinit.c b/lib/mbsinit.c index 79278d452..98ae1e633 100644 --- a/lib/mbsinit.c +++ b/lib/mbsinit.c @@ -1,5 +1,5 @@ /* Test for initial conversion state. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc-impl.h b/lib/mbtowc-impl.h index 3183f918a..35b35286c 100644 --- a/lib/mbtowc-impl.h +++ b/lib/mbtowc-impl.h @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc.c b/lib/mbtowc.c index e48b2f276..7777f0aa3 100644 --- a/lib/mbtowc.c +++ b/lib/mbtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/memchr.c b/lib/memchr.c index 7b6e258b5..6b28405d3 100644 --- a/lib/memchr.c +++ b/lib/memchr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2012 +/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2013 Free Software Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c index 7da354128..5e59da70a 100644 --- a/lib/msvc-inval.c +++ b/lib/msvc-inval.c @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-inval.h b/lib/msvc-inval.h index ce6fceebd..3ff749432 100644 --- a/lib/msvc-inval.h +++ b/lib/msvc-inval.h @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.c b/lib/msvc-nothrow.c index 3e791c3a0..c17a9a2fd 100644 --- a/lib/msvc-nothrow.c +++ b/lib/msvc-nothrow.c @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.h b/lib/msvc-nothrow.h index 573bc8e10..80d478568 100644 --- a/lib/msvc-nothrow.h +++ b/lib/msvc-nothrow.h @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/netdb.in.h b/lib/netdb.in.h index 63ebd2d62..dff665c95 100644 --- a/lib/netdb.in.h +++ b/lib/netdb.in.h @@ -1,5 +1,5 @@ /* Provide a netdb.h header file for systems lacking it (read: MinGW). - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h index a93dcdf47..97ec58d0a 100644 --- a/lib/netinet_in.in.h +++ b/lib/netinet_in.in.h @@ -1,5 +1,5 @@ /* Substitute for <netinet/in.h>. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nl_langinfo.c b/lib/nl_langinfo.c index 4b9bdbe1b..2210b7fef 100644 --- a/lib/nl_langinfo.c +++ b/lib/nl_langinfo.c @@ -1,6 +1,6 @@ /* nl_langinfo() replacement: query locale dependent information. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nproc.c b/lib/nproc.c index c4b151a2c..86aefe5f7 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nproc.h b/lib/nproc.h index c5f632215..57689aadf 100644 --- a/lib/nproc.h +++ b/lib/nproc.h @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/open.c b/lib/open.c index 3a74813bb..b4d9c8748 100644 --- a/lib/open.c +++ b/lib/open.c @@ -1,5 +1,5 @@ /* Open a descriptor to a file. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -27,7 +27,7 @@ #include <sys/types.h> #undef __need_system_fcntl_h -static inline int +static int orig_open (const char *filename, int flags, mode_t mode) { return open (filename, flags, mode); diff --git a/lib/pathmax.h b/lib/pathmax.h index 23613217f..105edaed3 100644 --- a/lib/pathmax.h +++ b/lib/pathmax.h @@ -1,5 +1,5 @@ /* Define PATH_MAX somehow. Requires sys/types.h. - Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2012 Free Software + Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/pipe2.c b/lib/pipe2.c index 2c018d5f2..09952eb32 100644 --- a/lib/pipe2.c +++ b/lib/pipe2.c @@ -1,5 +1,5 @@ /* Create a pipe, with specific opening flags. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/printf-args.c b/lib/printf-args.c index c768883fe..73fa7a4ac 100644 --- a/lib/printf-args.c +++ b/lib/printf-args.c @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2012 Free Software + Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-args.h b/lib/printf-args.h index 0bc75ca17..af7e72d9c 100644 --- a/lib/printf-args.h +++ b/lib/printf-args.h @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2012 Free Software + Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-parse.c b/lib/printf-parse.c index fcc302f4b..9a266df7a 100644 --- a/lib/printf-parse.c +++ b/lib/printf-parse.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999-2000, 2002-2003, 2006-2012 Free Software Foundation, Inc. + Copyright (C) 1999-2000, 2002-2003, 2006-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/printf-parse.h b/lib/printf-parse.h index 94883c642..0d535fa5b 100644 --- a/lib/printf-parse.h +++ b/lib/printf-parse.h @@ -1,5 +1,5 @@ /* Parse printf format string. - Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2012 Free Software + Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/putenv.c b/lib/putenv.c index eb3fae375..2abc6acff 100644 --- a/lib/putenv.c +++ b/lib/putenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2012 Free Software +/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2013 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C @@ -115,6 +115,37 @@ putenv (char *string) if (*ep == NULL) { +#if HAVE__PUTENV + /* Rely on _putenv to allocate the new environment. If other + parts of the application use _putenv, the !HAVE__PUTENV code + would fight over who owns the environ vector, causing a crash. */ + if (name_end[1]) + return _putenv (string); + else + { + /* _putenv ("NAME=") unsets NAME, so invoke _putenv ("NAME=x") + to allocate the environ vector and then replace the new + entry with "NAME=". */ + int putenv_result, putenv_errno; + char *name_x = malloc (name_end - string + sizeof "=x"); + if (!name_x) + return -1; + memcpy (name_x, string, name_end - string + 1); + name_x[name_end - string + 1] = 'x'; + name_x[name_end - string + 2] = 0; + putenv_result = _putenv (name_x); + putenv_errno = errno; + for (ep = environ; *ep; ep++) + if (*ep == name_x) + { + *ep = string; + break; + } + free (name_x); + __set_errno (putenv_errno); + return putenv_result; + } +#else static char **last_environ = NULL; char **new_environ = (char **) malloc ((size + 2) * sizeof (char *)); if (new_environ == NULL) @@ -126,6 +157,7 @@ putenv (char *string) free (last_environ); last_environ = new_environ; environ = new_environ; +#endif } else *ep = string; diff --git a/lib/raise.c b/lib/raise.c index 0c3acbb12..3720dfa38 100644 --- a/lib/raise.c +++ b/lib/raise.c @@ -1,6 +1,6 @@ /* Provide a non-threads replacement for the POSIX raise function. - Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2005-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -32,7 +32,7 @@ # undef raise # if HAVE_MSVC_INVALID_PARAMETER_HANDLER -static inline int +static int raise_nothrow (int sig) { int result; diff --git a/lib/read.c b/lib/read.c index 9018bb5f2..155e6d11c 100644 --- a/lib/read.c +++ b/lib/read.c @@ -1,5 +1,5 @@ /* POSIX compatible read() function. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2011. This program is free software: you can redistribute it and/or modify @@ -34,7 +34,7 @@ # undef read # if HAVE_MSVC_INVALID_PARAMETER_HANDLER -static inline ssize_t +static ssize_t read_nothrow (int fd, void *buf, size_t count) { ssize_t result; diff --git a/lib/readlink.c b/lib/readlink.c index c75d79488..ce8a0e843 100644 --- a/lib/readlink.c +++ b/lib/readlink.c @@ -1,5 +1,5 @@ /* Stub for readlink(). - Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recv.c b/lib/recv.c index 7a5946a82..aaa7d00fd 100644 --- a/lib/recv.c +++ b/lib/recv.c @@ -1,6 +1,6 @@ /* recv.c --- wrappers for Windows recv function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recvfrom.c b/lib/recvfrom.c index bfd97acf3..31550711b 100644 --- a/lib/recvfrom.c +++ b/lib/recvfrom.c @@ -1,6 +1,6 @@ /* recvfrom.c --- wrappers for Windows recvfrom function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-add.sin b/lib/ref-add.sin index 8c1a7d0bd..7cbdec527 100644 --- a/lib/ref-add.sin +++ b/lib/ref-add.sin @@ -1,6 +1,6 @@ # Add this package to a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2013 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-del.sin b/lib/ref-del.sin index fd8758898..cf7b492a9 100644 --- a/lib/ref-del.sin +++ b/lib/ref-del.sin @@ -1,6 +1,6 @@ # Remove this package from a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2013 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/regcomp.c b/lib/regcomp.c index 76947c24e..b236f36d3 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -1,20 +1,21 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + The GNU C 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 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see <http://www.gnu.org/licenses/>. */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + <http://www.gnu.org/licenses/>. */ static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, size_t length, reg_syntax_t syntax); @@ -93,20 +94,20 @@ static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, re_charset_t *mbcset, Idx *char_class_alloc, - const unsigned char *class_name, + const char *class_name, reg_syntax_t syntax); #else /* not RE_ENABLE_I18N */ static reg_errcode_t build_equiv_class (bitset_t sbcset, const unsigned char *name); static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - const unsigned char *class_name, + const char *class_name, reg_syntax_t syntax); #endif /* not RE_ENABLE_I18N */ static bin_tree_t *build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, - const unsigned char *class_name, - const unsigned char *extra, + const char *class_name, + const char *extra, bool non_match, reg_errcode_t *err); static bin_tree_t *create_tree (re_dfa_t *dfa, bin_tree_t *left, bin_tree_t *right, @@ -952,10 +953,10 @@ static void internal_function init_word_char (re_dfa_t *dfa) { - dfa->word_ops_used = 1; int i = 0; int j; int ch = 0; + dfa->word_ops_used = 1; if (BE (dfa->map_notascii == 0, 1)) { bitset_word_t bits0 = 0x00000000; @@ -2421,8 +2422,8 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, case OP_WORD: case OP_NOTWORD: tree = build_charclass_op (dfa, regexp->trans, - (const unsigned char *) "alnum", - (const unsigned char *) "_", + "alnum", + "_", token->type == OP_NOTWORD, err); if (BE (*err != REG_NOERROR && tree == NULL, 0)) return NULL; @@ -2430,8 +2431,8 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, case OP_SPACE: case OP_NOTSPACE: tree = build_charclass_op (dfa, regexp->trans, - (const unsigned char *) "space", - (const unsigned char *) "", + "space", + "", token->type == OP_NOTSPACE, err); if (BE (*err != REG_NOERROR && tree == NULL, 0)) return NULL; @@ -2711,7 +2712,6 @@ build_range_exp (const reg_syntax_t syntax, wchar_t wc; wint_t start_wc; wint_t end_wc; - wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] @@ -2725,11 +2725,7 @@ build_range_exp (const reg_syntax_t syntax, ? __btowc (end_ch) : end_elem->opr.wch); if (start_wc == WEOF || end_wc == WEOF) return REG_ECOLLATE; - cmp_buf[0] = start_wc; - cmp_buf[4] = end_wc; - - if (BE ((syntax & RE_NO_EMPTY_RANGES) - && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) + else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) return REG_ERANGE; /* Got valid collation sequence values, add them as a new entry. @@ -2770,9 +2766,7 @@ build_range_exp (const reg_syntax_t syntax, /* Build the table for single byte characters. */ for (wc = 0; wc < SBC_MAX; ++wc) { - cmp_buf[2] = wc; - if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 - && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) + if (start_wc <= wc && wc <= end_wc) bitset_set (sbcset, wc); } } @@ -2969,6 +2963,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, 0)) return REG_ERANGE; + /* FIXME: Implement rational ranges here, too. */ start_collseq = lookup_collation_sequence_value (start_elem); end_collseq = lookup_collation_sequence_value (end_elem); /* Check start/end collation sequence values. */ @@ -3296,7 +3291,8 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, #ifdef RE_ENABLE_I18N mbcset, &char_class_alloc, #endif /* RE_ENABLE_I18N */ - start_elem.opr.name, syntax); + (const char *) start_elem.opr.name, + syntax); if (BE (*err != REG_NOERROR, 0)) goto parse_bracket_exp_free_return; break; @@ -3576,14 +3572,14 @@ static reg_errcode_t #ifdef RE_ENABLE_I18N build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, re_charset_t *mbcset, Idx *char_class_alloc, - const unsigned char *class_name, reg_syntax_t syntax) + const char *class_name, reg_syntax_t syntax) #else /* not RE_ENABLE_I18N */ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - const unsigned char *class_name, reg_syntax_t syntax) + const char *class_name, reg_syntax_t syntax) #endif /* not RE_ENABLE_I18N */ { int i; - const char *name = (const char *) class_name; + const char *name = class_name; /* In case of REG_ICASE "upper" and "lower" match the both of upper and lower cases. */ @@ -3657,8 +3653,8 @@ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, static bin_tree_t * build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, - const unsigned char *class_name, - const unsigned char *extra, bool non_match, + const char *class_name, + const char *extra, bool non_match, reg_errcode_t *err) { re_bitset_ptr_t sbcset; diff --git a/lib/regex.c b/lib/regex.c index c578852c2..ca40e6ec4 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -1,20 +1,21 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + The GNU C 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 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see <http://www.gnu.org/licenses/>. */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + <http://www.gnu.org/licenses/>. */ #ifndef _LIBC # include <config.h> diff --git a/lib/regex.h b/lib/regex.h index 07c1b3da3..74645ca3e 100644 --- a/lib/regex.h +++ b/lib/regex.h @@ -1,21 +1,22 @@ /* Definitions for data structures and routines for the regular expression library. - Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 - Free Software Foundation, Inc. + Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software + Foundation, Inc. This file is part of the GNU C Library. - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + The GNU C 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 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see <http://www.gnu.org/licenses/>. */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + <http://www.gnu.org/licenses/>. */ #ifndef _REGEX_H #define _REGEX_H 1 diff --git a/lib/regex_internal.c b/lib/regex_internal.c index 71ee41e92..e11ad3d56 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -1,20 +1,21 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + The GNU C 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 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see <http://www.gnu.org/licenses/>. */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + <http://www.gnu.org/licenses/>. */ static void re_string_construct_common (const char *str, Idx len, re_string_t *pstr, @@ -973,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx size) set->alloc = size; set->nelem = 0; set->elems = re_malloc (Idx, size); - if (BE (set->elems == NULL, 0)) + if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) return REG_ESPACE; return REG_NOERROR; } @@ -1442,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) dfa->nodes[dfa->nodes_len] = token; dfa->nodes[dfa->nodes_len].constraint = 0; #ifdef RE_ENABLE_I18N - { - int type = token.type; dfa->nodes[dfa->nodes_len].accept_mb = - (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; - } + ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) + || token.type == COMPLEX_BRACKET); #endif dfa->nexts[dfa->nodes_len] = REG_MISSING; re_node_set_init_empty (dfa->edests + dfa->nodes_len); @@ -1454,7 +1453,7 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) return dfa->nodes_len++; } -static inline re_hashval_t +static re_hashval_t internal_function calc_state_hash (const re_node_set *nodes, unsigned int context) { diff --git a/lib/regex_internal.h b/lib/regex_internal.h index fd331b117..fa9338256 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -1,20 +1,21 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + The GNU C 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 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see <http://www.gnu.org/licenses/>. */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + <http://www.gnu.org/licenses/>. */ #ifndef _REGEX_INTERNAL_H #define _REGEX_INTERNAL_H 1 @@ -26,9 +27,6 @@ #include <string.h> #include <langinfo.h> -#ifndef _LIBC -# include "localcharset.h" -#endif #include <locale.h> #include <wchar.h> #include <wctype.h> @@ -37,7 +35,6 @@ #if defined _LIBC # include <bits/libc-lock.h> #else -# define __libc_lock_define(CLASS,NAME) # define __libc_lock_init(NAME) do { } while (0) # define __libc_lock_lock(NAME) do { } while (0) # define __libc_lock_unlock(NAME) do { } while (0) @@ -63,7 +60,7 @@ # ifdef _LIBC # undef gettext # define gettext(msgid) \ - INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) + __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) # endif #else # define gettext(msgid) (msgid) @@ -83,9 +80,6 @@ # define BE(expr, val) __builtin_expect (expr, val) #else # define BE(expr, val) (expr) -# ifdef _LIBC -# define inline -# endif #endif /* Number of ASCII characters. */ @@ -102,6 +96,8 @@ /* Rename to standard API for using out of glibc. */ #ifndef _LIBC +# undef __wctype +# undef __iswctype # define __wctype wctype # define __iswctype iswctype # define __btowc btowc @@ -449,7 +445,9 @@ static unsigned int re_string_context_at (const re_string_t *input, Idx idx, #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) -#include <alloca.h> +#if defined _LIBC || HAVE_ALLOCA +# include <alloca.h> +#endif #ifndef _LIBC # if HAVE_ALLOCA @@ -466,6 +464,12 @@ static unsigned int re_string_context_at (const re_string_t *input, Idx idx, # endif #endif +#ifdef _LIBC +# define MALLOC_0_IS_NONNULL 1 +#elif !defined MALLOC_0_IS_NONNULL +# define MALLOC_0_IS_NONNULL 0 +#endif + #ifndef MAX # define MAX(a,b) ((a) < (b) ? (b) : (a)) #endif @@ -696,7 +700,9 @@ struct re_dfa_t #ifdef DEBUG char* re_str; #endif +#ifdef _LIBC __libc_lock_define (, lock) +#endif }; #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) @@ -727,33 +733,33 @@ typedef struct } bracket_elem_t; -/* Inline functions for bitset_t operation. */ +/* Functions for bitset_t operation. */ -static inline void +static void bitset_set (bitset_t set, Idx i) { set[i / BITSET_WORD_BITS] |= (bitset_word_t) 1 << i % BITSET_WORD_BITS; } -static inline void +static void bitset_clear (bitset_t set, Idx i) { set[i / BITSET_WORD_BITS] &= ~ ((bitset_word_t) 1 << i % BITSET_WORD_BITS); } -static inline bool +static bool bitset_contain (const bitset_t set, Idx i) { return (set[i / BITSET_WORD_BITS] >> i % BITSET_WORD_BITS) & 1; } -static inline void +static void bitset_empty (bitset_t set) { memset (set, '\0', sizeof (bitset_t)); } -static inline void +static void bitset_set_all (bitset_t set) { memset (set, -1, sizeof (bitset_word_t) * (SBC_MAX / BITSET_WORD_BITS)); @@ -762,13 +768,13 @@ bitset_set_all (bitset_t set) ((bitset_word_t) 1 << SBC_MAX % BITSET_WORD_BITS) - 1; } -static inline void +static void bitset_copy (bitset_t dest, const bitset_t src) { memcpy (dest, src, sizeof (bitset_t)); } -static inline void +static void bitset_not (bitset_t set) { int bitset_i; @@ -780,7 +786,7 @@ bitset_not (bitset_t set) & ~set[BITSET_WORDS - 1]); } -static inline void +static void bitset_merge (bitset_t dest, const bitset_t src) { int bitset_i; @@ -788,7 +794,7 @@ bitset_merge (bitset_t dest, const bitset_t src) dest[bitset_i] |= src[bitset_i]; } -static inline void +static void bitset_mask (bitset_t dest, const bitset_t src) { int bitset_i; @@ -797,8 +803,8 @@ bitset_mask (bitset_t dest, const bitset_t src) } #ifdef RE_ENABLE_I18N -/* Inline functions for re_string. */ -static inline int +/* Functions for re_string. */ +static int internal_function __attribute ((pure)) re_string_char_size_at (const re_string_t *pstr, Idx idx) { @@ -811,7 +817,7 @@ re_string_char_size_at (const re_string_t *pstr, Idx idx) return byte_idx; } -static inline wint_t +static wint_t internal_function __attribute ((pure)) re_string_wchar_at (const re_string_t *pstr, Idx idx) { diff --git a/lib/regexec.c b/lib/regexec.c index 13c3f15d6..1bd1640ed 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1,20 +1,21 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + The GNU C 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 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see <http://www.gnu.org/licenses/>. */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + <http://www.gnu.org/licenses/>. */ static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, Idx n) internal_function; @@ -198,7 +199,7 @@ static Idx group_nodes_into_DFAstates (const re_dfa_t *dfa, static bool check_node_accept (const re_match_context_t *mctx, const re_token_t *node, Idx idx) internal_function; -static reg_errcode_t extend_buffers (re_match_context_t *mctx) +static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) internal_function; /* Entry point for POSIX code. */ @@ -1175,7 +1176,7 @@ check_matching (re_match_context_t *mctx, bool fl_longest_match, || (BE (next_char_idx >= mctx->input.valid_len, 0) && mctx->input.valid_len < mctx->input.len)) { - err = extend_buffers (mctx); + err = extend_buffers (mctx, next_char_idx + 1); if (BE (err != REG_NOERROR, 0)) { assert (err == REG_ESPACE); @@ -1755,7 +1756,7 @@ clean_state_log_if_needed (re_match_context_t *mctx, Idx next_state_log_idx) && mctx->input.valid_len < mctx->input.len)) { reg_errcode_t err; - err = extend_buffers (mctx); + err = extend_buffers (mctx, next_state_log_idx + 1); if (BE (err != REG_NOERROR, 0)) return err; } @@ -2812,7 +2813,7 @@ get_subexp (re_match_context_t *mctx, Idx bkref_node, Idx bkref_str_idx) if (bkref_str_off >= mctx->input.len) break; - err = extend_buffers (mctx); + err = extend_buffers (mctx, bkref_str_off + 1); if (BE (err != REG_NOERROR, 0)) return err; @@ -3935,6 +3936,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, in_collseq = find_collation_sequence_value (pin, elem_len); } /* match with range expression? */ + /* FIXME: Implement rational ranges here, too. */ for (i = 0; i < cset->nranges; ++i) if (cset->range_starts[i] <= in_collseq && in_collseq <= cset->range_ends[i]) @@ -3986,18 +3988,9 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, # endif /* _LIBC */ { /* match with range expression? */ -#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) - wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; -#else - wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - cmp_buf[2] = wc; -#endif for (i = 0; i < cset->nranges; ++i) { - cmp_buf[0] = cset->range_starts[i]; - cmp_buf[4] = cset->range_ends[i]; - if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 - && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) + if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) { match_len = char_len; goto check_node_accept_bytes_match; @@ -4135,7 +4128,7 @@ check_node_accept (const re_match_context_t *mctx, const re_token_t *node, static reg_errcode_t internal_function __attribute_warn_unused_result__ -extend_buffers (re_match_context_t *mctx) +extend_buffers (re_match_context_t *mctx, int min_len) { reg_errcode_t ret; re_string_t *pstr = &mctx->input; @@ -4145,8 +4138,10 @@ extend_buffers (re_match_context_t *mctx) <= pstr->bufs_len, 0)) return REG_ESPACE; - /* Double the lengths of the buffers. */ - ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); + /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ + ret = re_string_realloc_buffers (pstr, + MAX (min_len, + MIN (pstr->len, pstr->bufs_len * 2))); if (BE (ret != REG_NOERROR, 0)) return ret; diff --git a/lib/rename.c b/lib/rename.c index 547a6a2c1..eceadecfe 100644 --- a/lib/rename.c +++ b/lib/rename.c @@ -1,6 +1,6 @@ /* Work around rename bugs in some systems. - Copyright (C) 2001-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/rmdir.c b/lib/rmdir.c index 0b536268d..f18acbe54 100644 --- a/lib/rmdir.c +++ b/lib/rmdir.c @@ -1,6 +1,6 @@ /* Work around rmdir bugs. - Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2012 Free Software + Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/round.c b/lib/round.c index 53dfe84ea..4d4e69b94 100644 --- a/lib/round.c +++ b/lib/round.c @@ -1,5 +1,5 @@ /* Round toward nearest, breaking ties away from zero. - Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-read.c b/lib/safe-read.c index d2d85c767..39490ab42 100644 --- a/lib/safe-read.c +++ b/lib/safe-read.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries after interrupts. - Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2012 Free Software + Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/safe-read.h b/lib/safe-read.h index dc739229b..91a86c6f0 100644 --- a/lib/safe-read.h +++ b/lib/safe-read.h @@ -1,5 +1,5 @@ /* An interface to read() that retries after interrupts. - Copyright (C) 2002, 2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.c b/lib/safe-write.c index cd4272238..71f2f3d39 100644 --- a/lib/safe-write.c +++ b/lib/safe-write.c @@ -1,5 +1,5 @@ /* An interface to write that retries after interrupts. - Copyright (C) 2002, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.h b/lib/safe-write.h index 3a7f5091c..779f5d5ba 100644 --- a/lib/safe-write.h +++ b/lib/safe-write.h @@ -1,5 +1,5 @@ /* An interface to write() that retries after interrupts. - Copyright (C) 2002, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/same-inode.h b/lib/same-inode.h index 7ce286d66..94fe3e223 100644 --- a/lib/same-inode.h +++ b/lib/same-inode.h @@ -1,6 +1,6 @@ /* Determine whether two stat buffers refer to the same file. - Copyright (C) 2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/send.c b/lib/send.c index 64d0e8ddf..3e76ce1cd 100644 --- a/lib/send.c +++ b/lib/send.c @@ -1,6 +1,6 @@ /* send.c --- wrappers for Windows send function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sendto.c b/lib/sendto.c index 7a8e9941d..215458248 100644 --- a/lib/sendto.c +++ b/lib/sendto.c @@ -1,6 +1,6 @@ /* sendto.c --- wrappers for Windows sendto function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/setenv.c b/lib/setenv.c index 75f423f49..8076c548a 100644 --- a/lib/setenv.c +++ b/lib/setenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1992, 1995-2003, 2005-2012 Free Software Foundation, Inc. +/* Copyright (C) 1992, 1995-2003, 2005-2013 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify @@ -15,14 +15,14 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. */ #if !_LIBC +/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc + optimizes away the name == NULL test below. */ +# define _GL_ARG_NONNULL(params) + # define _GL_USE_STDLIB_ALLOC 1 # include <config.h> #endif -/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc - optimizes away the name == NULL test below. */ -#define _GL_ARG_NONNULL(params) - #include <alloca.h> /* Specification. */ diff --git a/lib/setsockopt.c b/lib/setsockopt.c index 07e90230d..7a50835ae 100644 --- a/lib/setsockopt.c +++ b/lib/setsockopt.c @@ -1,6 +1,6 @@ /* setsockopt.c --- wrappers for Windows setsockopt function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/shutdown.c b/lib/shutdown.c index 1e646a939..2f5fc54a6 100644 --- a/lib/shutdown.c +++ b/lib/shutdown.c @@ -1,6 +1,6 @@ /* shutdown.c --- wrappers for Windows shutdown function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signal.in.h b/lib/signal.in.h index 627ae17af..6f96f0db4 100644 --- a/lib/signal.in.h +++ b/lib/signal.in.h @@ -1,6 +1,6 @@ /* A GNU-like <signal.h>. - Copyright (C) 2006-2012 Free Software Foundation, Inc. + Copyright (C) 2006-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/size_max.h b/lib/size_max.h index 60d50f1d2..20fb1b7b8 100644 --- a/lib/size_max.h +++ b/lib/size_max.h @@ -1,5 +1,5 @@ /* size_max.h -- declare SIZE_MAX through system headers - Copyright (C) 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2013 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/snprintf.c b/lib/snprintf.c index eb27f5d0f..3cccf48ba 100644 --- a/lib/snprintf.c +++ b/lib/snprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2013 Free Software Foundation, Inc. Written by Simon Josefsson and Paul Eggert. This program is free software; you can redistribute it and/or modify diff --git a/lib/socket.c b/lib/socket.c index 24f16c909..17fecc423 100644 --- a/lib/socket.c +++ b/lib/socket.c @@ -1,6 +1,6 @@ /* socket.c --- wrappers for Windows socket function - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.c b/lib/sockets.c index 635479ad8..d4652a2c5 100644 --- a/lib/sockets.c +++ b/lib/sockets.c @@ -1,6 +1,6 @@ /* sockets.c --- wrappers for Windows socket functions - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.h b/lib/sockets.h index 35d6923e2..4eb4dcbbf 100644 --- a/lib/sockets.h +++ b/lib/sockets.h @@ -1,6 +1,6 @@ /* sockets.h - wrappers for Windows socket functions - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stat-time.h b/lib/stat-time.h index daf2ca6ee..a3dff5406 100644 --- a/lib/stat-time.h +++ b/lib/stat-time.h @@ -1,6 +1,6 @@ /* stat-related time functions. - Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stat.c b/lib/stat.c index f46e31d9b..c42962ba0 100644 --- a/lib/stat.c +++ b/lib/stat.c @@ -1,5 +1,5 @@ /* Work around platform bugs in stat. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -42,7 +42,7 @@ # endif #endif -static inline int +static int orig_stat (const char *filename, struct stat *buf) { return stat (filename, buf); diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h index e04387175..d9b2eec0e 100644 --- a/lib/stdalign.in.h +++ b/lib/stdalign.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C11 <stdalign.h>. - Copyright 2011-2012 Free Software Foundation, Inc. + Copyright 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h index 419342993..bd629ed32 100644 --- a/lib/stdbool.in.h +++ b/lib/stdbool.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2003, 2006-2012 Free Software Foundation, Inc. +/* Copyright (C) 2001-2003, 2006-2013 Free Software Foundation, Inc. Written by Bruno Haible <haible@clisp.cons.org>, 2001. This program is free software; you can redistribute it and/or modify diff --git a/lib/stddef.in.h b/lib/stddef.in.h index e17ef24c2..614c9bc79 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -1,6 +1,6 @@ /* A substitute for POSIX 2008 <stddef.h>, for platforms that have issues. - Copyright (C) 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2009-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdint.in.h b/lib/stdint.in.h index 3a73abff8..889bca753 100644 --- a/lib/stdint.in.h +++ b/lib/stdint.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2002, 2004-2012 Free Software Foundation, Inc. +/* Copyright (C) 2001-2002, 2004-2013 Free Software Foundation, Inc. Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood. This file is part of gnulib. @@ -39,7 +39,7 @@ Ideally we should test __BIONIC__ here, but it is only defined after <sys/cdefs.h> has been included; hence test __ANDROID__ instead. */ #if defined __ANDROID__ \ - && defined _SYS_TYPES_H_ && !defined _SSIZE_T_DEFINED_ + && defined _SYS_TYPES_H_ && !defined __need_size_t # @INCLUDE_NEXT@ @NEXT_STDINT_H@ #else diff --git a/lib/stdio.in.h b/lib/stdio.in.h index f7e06ad87..bc3fccb4a 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -1,6 +1,6 @@ /* A GNU-like <stdio.h>. - Copyright (C) 2004, 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2004, 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -575,21 +575,17 @@ _GL_CXXALIAS_RPL (fwrite, size_t, _GL_CXXALIAS_SYS (fwrite, size_t, (const void *ptr, size_t s, size_t n, FILE *stream)); -/* Work around glibc bug 11959 +/* Work around bug 11959 when fortifying glibc 2.4 through 2.15 <http://sources.redhat.com/bugzilla/show_bug.cgi?id=11959>, which sometimes causes an unwanted diagnostic for fwrite calls. - This affects only function declaration attributes, so it's not - needed for C++. */ -# if !defined __cplusplus && 0 < __USE_FORTIFY_LEVEL -static inline size_t _GL_ARG_NONNULL ((1, 4)) -rpl_fwrite (const void *ptr, size_t s, size_t n, FILE *stream) -{ - size_t r = fwrite (ptr, s, n, stream); - (void) r; - return r; -} + This affects only function declaration attributes under certain + versions of gcc, and is not needed for C++. */ +# if (0 < __USE_FORTIFY_LEVEL \ + && __GLIBC__ == 2 && 4 <= __GLIBC_MINOR__ && __GLIBC_MINOR__ <= 15 \ + && 3 < __GNUC__ + (4 <= __GNUC_MINOR__) \ + && !defined __cplusplus) # undef fwrite -# define fwrite rpl_fwrite +# define fwrite(a, b, c, d) ({size_t __r = fwrite (a, b, c, d); __r; }) # endif # endif _GL_CXXALIASWARN (fwrite); @@ -1333,7 +1329,6 @@ _GL_WARN_ON_USE (vsprintf, "vsprintf is not always POSIX compliant - " "POSIX compliance"); #endif - #endif /* _@GUARD_PREFIX@_STDIO_H */ #endif /* _@GUARD_PREFIX@_STDIO_H */ #endif diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index b67a3484e..552fdf0c7 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,6 +1,6 @@ /* A GNU-like <stdlib.h>. - Copyright (C) 1995, 2001-2004, 2006-2012 Free Software Foundation, Inc. + Copyright (C) 1995, 2001-2004, 2006-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,8 +20,9 @@ #endif @PRAGMA_COLUMNS@ -#if defined __need_malloc_and_calloc -/* Special invocation convention inside glibc header files. */ +#if defined __need_system_stdlib_h || defined __need_malloc_and_calloc +/* Special invocation conventions inside some gnulib header files, + and inside some glibc header files, respectively. */ #@INCLUDE_NEXT@ @NEXT_STDLIB_H@ @@ -766,6 +767,22 @@ _GL_WARN_ON_USE (rpmatch, "rpmatch is unportable - " # endif #endif +#if @GNULIB_SECURE_GETENV@ +/* Look up NAME in the environment, returning 0 in insecure situations. */ +# if !@HAVE_SECURE_GETENV@ +_GL_FUNCDECL_SYS (secure_getenv, char *, + (char const *name) _GL_ARG_NONNULL ((1))); +# endif +_GL_CXXALIAS_SYS (secure_getenv, char *, (char const *name)); +_GL_CXXALIASWARN (secure_getenv); +#elif defined GNULIB_POSIXCHECK +# undef secure_getenv +# if HAVE_RAW_DECL_SECURE_GETENV +_GL_WARN_ON_USE (secure_getenv, "secure_getenv is unportable - " + "use gnulib module secure_getenv for portability"); +# endif +#endif + #if @GNULIB_SETENV@ /* Set NAME to VALUE in the environment. If REPLACE is nonzero, overwrite an existing value. */ diff --git a/lib/streq.h b/lib/streq.h index 7fd07c810..03ede61c0 100644 --- a/lib/streq.h +++ b/lib/streq.h @@ -1,5 +1,5 @@ /* Optimized string comparison. - Copyright (C) 2001-2002, 2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/strftime.c b/lib/strftime.c index f5fc3c997..058ba1194 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991-2001, 2003-2007, 2009-2012 Free Software Foundation, Inc. +/* Copyright (C) 1991-2001, 2003-2007, 2009-2013 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. @@ -26,7 +26,6 @@ #else # include <config.h> # if FPRINTFTIME -# include "ignore-value.h" # include "fprintftime.h" # else # include "strftime.h" @@ -210,13 +209,12 @@ extern char *tzname[]; fwrite_uppcase (p, (s), _n); \ else \ { \ - /* We are ignoring the value of fwrite here, in spite of the \ - fact that technically, that may not be valid: the fwrite \ - specification in POSIX 2008 defers to that of fputc, which \ - is intended to be consistent with the one from ISO C, \ - which permits failure due to ENOMEM *without* setting the \ - stream's error indicator. */ \ - ignore_value (fwrite ((s), _n, 1, p)); \ + /* Ignore the value of fwrite. The caller can determine whether \ + an error occurred by inspecting ferror (P). All known fwrite \ + implementations set the stream's error indicator when they \ + fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \ + not require this. */ \ + fwrite (s, _n, 1, p); \ } \ } \ while (0) \ diff --git a/lib/strftime.h b/lib/strftime.h index 596b0b8ec..a521875ab 100644 --- a/lib/strftime.h +++ b/lib/strftime.h @@ -1,6 +1,6 @@ /* declarations for strftime.c - Copyright (C) 2002, 2004, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/striconveh.c b/lib/striconveh.c index 8a3823607..bc841ebdc 100644 --- a/lib/striconveh.c +++ b/lib/striconveh.c @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2013 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/striconveh.h b/lib/striconveh.h index 77730a0c5..ea6a6dc89 100644 --- a/lib/striconveh.h +++ b/lib/striconveh.h @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/string.in.h b/lib/string.in.h index 0c2352673..5dcf8de73 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -1,6 +1,6 @@ /* A GNU-like <string.h>. - Copyright (C) 1995-1996, 2001-2012 Free Software Foundation, Inc. + Copyright (C) 1995-1996, 2001-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stripslash.c b/lib/stripslash.c index 63b77cd39..16d43391c 100644 --- a/lib/stripslash.c +++ b/lib/stripslash.c @@ -1,6 +1,6 @@ /* stripslash.c -- remove redundant trailing slashes from a file name - Copyright (C) 1990, 2001, 2003-2006, 2009-2012 Free Software Foundation, + Copyright (C) 1990, 2001, 2003-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h index 476f2f616..152311c31 100644 --- a/lib/sys_file.in.h +++ b/lib/sys_file.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/file.h. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_socket.c b/lib/sys_socket.c new file mode 100644 index 000000000..3f017f8fc --- /dev/null +++ b/lib/sys_socket.c @@ -0,0 +1,3 @@ +#include <config.h> +#define _GL_SYS_SOCKET_INLINE _GL_EXTERN_INLINE +#include "sys/socket.h" diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h index a0bcffb5f..31ed042e4 100644 --- a/lib/sys_socket.in.h +++ b/lib/sys_socket.in.h @@ -1,6 +1,6 @@ /* Provide a sys/socket header file for systems lacking it (read: MinGW) and for systems where it is incomplete. - Copyright (C) 2005-2012 Free Software Foundation, Inc. + Copyright (C) 2005-2013 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify @@ -63,6 +63,11 @@ #ifndef _@GUARD_PREFIX@_SYS_SOCKET_H #define _@GUARD_PREFIX@_SYS_SOCKET_H +_GL_INLINE_HEADER_BEGIN +#ifndef _GL_SYS_SOCKET_INLINE +# define _GL_SYS_SOCKET_INLINE _GL_INLINE +#endif + /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ /* The definition of _GL_ARG_NONNULL is copied here. */ @@ -201,7 +206,7 @@ struct msghdr { /* Re-define FD_ISSET to avoid a WSA call while we are not using network sockets. */ -static inline int +_GL_SYS_SOCKET_INLINE int rpl_fd_isset (SOCKET fd, fd_set * set) { u_int i; @@ -677,6 +682,8 @@ _GL_WARN_ON_USE (accept4, "accept4 is unportable - " # endif #endif +_GL_INLINE_HEADER_END + #endif /* _@GUARD_PREFIX@_SYS_SOCKET_H */ #endif /* _@GUARD_PREFIX@_SYS_SOCKET_H */ #endif diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index 97fb3c4ce..12f99da0f 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -1,5 +1,5 @@ /* Provide a more complete sys/stat header file. - Copyright (C) 2005-2012 Free Software Foundation, Inc. + Copyright (C) 2005-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -150,6 +150,10 @@ # endif #endif +#ifndef S_ISMPX /* AIX */ +# define S_ISMPX(m) 0 +#endif + #ifndef S_ISNAM /* Xenix */ # ifdef S_IFNAM # define S_ISNAM(m) (((m) & S_IFMT) == S_IFNAM) @@ -497,7 +501,7 @@ _GL_CXXALIAS_RPL (mkdir, int, (char const *name, mode_t mode)); # if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ # if !GNULIB_defined_rpl_mkdir -static inline int +static int rpl_mkdir (char const *name, mode_t mode) { return _mkdir (name); diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h index 3dbbf91e5..f2398c569 100644 --- a/lib/sys_time.in.h +++ b/lib/sys_time.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/time.h. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -17,37 +17,34 @@ /* Written by Paul Eggert. */ +#ifndef _@GUARD_PREFIX@_SYS_TIME_H + #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ -#if defined _@GUARD_PREFIX@_SYS_TIME_H +/* The include_next requires a split double-inclusion guard. */ +#if @HAVE_SYS_TIME_H@ +# @INCLUDE_NEXT@ @NEXT_SYS_TIME_H@ +#endif -/* Simply delegate to the system's header, without adding anything. */ -# if @HAVE_SYS_TIME_H@ -# @INCLUDE_NEXT@ @NEXT_SYS_TIME_H@ -# endif +#ifndef _@GUARD_PREFIX@_SYS_TIME_H +#define _@GUARD_PREFIX@_SYS_TIME_H -#else - -# define _@GUARD_PREFIX@_SYS_TIME_H - -# if @HAVE_SYS_TIME_H@ -# @INCLUDE_NEXT@ @NEXT_SYS_TIME_H@ -# else -# include <time.h> -# endif +#if ! @HAVE_SYS_TIME_H@ +# include <time.h> +#endif /* On native Windows with MSVC, get the 'struct timeval' type. Also, on native Windows with a 64-bit time_t, where we are overriding the 'struct timeval' type, get all declarations of system functions whose signature contains 'struct timeval'. */ -# if (defined _MSC_VER || @REPLACE_STRUCT_TIMEVAL@) && @HAVE_WINSOCK2_H@ && !defined _GL_INCLUDING_WINSOCK2_H -# define _GL_INCLUDING_WINSOCK2_H -# include <winsock2.h> -# undef _GL_INCLUDING_WINSOCK2_H -# endif +#if (defined _MSC_VER || @REPLACE_STRUCT_TIMEVAL@) && @HAVE_WINSOCK2_H@ && !defined _GL_INCLUDING_WINSOCK2_H +# define _GL_INCLUDING_WINSOCK2_H +# include <winsock2.h> +# undef _GL_INCLUDING_WINSOCK2_H +#endif /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ @@ -55,112 +52,112 @@ /* The definition of _GL_WARN_ON_USE is copied here. */ -# ifdef __cplusplus +#ifdef __cplusplus extern "C" { +#endif + +#if !@HAVE_STRUCT_TIMEVAL@ || @REPLACE_STRUCT_TIMEVAL@ + +# if @REPLACE_STRUCT_TIMEVAL@ +# define timeval rpl_timeval # endif -# if !@HAVE_STRUCT_TIMEVAL@ || @REPLACE_STRUCT_TIMEVAL@ - -# if @REPLACE_STRUCT_TIMEVAL@ -# define timeval rpl_timeval -# endif - -# if !GNULIB_defined_struct_timeval +# if !GNULIB_defined_struct_timeval struct timeval { time_t tv_sec; long int tv_usec; }; -# define GNULIB_defined_struct_timeval 1 -# endif - +# define GNULIB_defined_struct_timeval 1 # endif -# ifdef __cplusplus +#endif + +#ifdef __cplusplus } -# endif +#endif -# if @GNULIB_GETTIMEOFDAY@ -# if @REPLACE_GETTIMEOFDAY@ -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef gettimeofday -# define gettimeofday rpl_gettimeofday -# endif +#if @GNULIB_GETTIMEOFDAY@ +# if @REPLACE_GETTIMEOFDAY@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef gettimeofday +# define gettimeofday rpl_gettimeofday +# endif _GL_FUNCDECL_RPL (gettimeofday, int, (struct timeval *restrict, void *restrict) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (gettimeofday, int, (struct timeval *restrict, void *restrict)); -# else -# if !@HAVE_GETTIMEOFDAY@ +# else +# if !@HAVE_GETTIMEOFDAY@ _GL_FUNCDECL_SYS (gettimeofday, int, (struct timeval *restrict, void *restrict) _GL_ARG_NONNULL ((1))); -# endif +# endif /* Need to cast, because on glibc systems, by default, the second argument is struct timezone *. */ _GL_CXXALIAS_SYS_CAST (gettimeofday, int, (struct timeval *restrict, void *restrict)); -# endif +# endif _GL_CXXALIASWARN (gettimeofday); -# elif defined GNULIB_POSIXCHECK -# undef gettimeofday -# if HAVE_RAW_DECL_GETTIMEOFDAY +#elif defined GNULIB_POSIXCHECK +# undef gettimeofday +# if HAVE_RAW_DECL_GETTIMEOFDAY _GL_WARN_ON_USE (gettimeofday, "gettimeofday is unportable - " "use gnulib module gettimeofday for portability"); -# endif # endif +#endif /* Hide some function declarations from <winsock2.h>. */ -# if defined _MSC_VER && @HAVE_WINSOCK2_H@ -# if !defined _@GUARD_PREFIX@_UNISTD_H -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef close -# define close close_used_without_including_unistd_h -# else +#if defined _MSC_VER && @HAVE_WINSOCK2_H@ +# if !defined _@GUARD_PREFIX@_UNISTD_H +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef close +# define close close_used_without_including_unistd_h +# else _GL_WARN_ON_USE (close, "close() used without including <unistd.h>"); -# endif -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef gethostname -# define gethostname gethostname_used_without_including_unistd_h -# else +# endif +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef gethostname +# define gethostname gethostname_used_without_including_unistd_h +# else _GL_WARN_ON_USE (gethostname, "gethostname() used without including <unistd.h>"); -# endif # endif -# if !defined _@GUARD_PREFIX@_SYS_SOCKET_H -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef socket -# define socket socket_used_without_including_sys_socket_h -# undef connect -# define connect connect_used_without_including_sys_socket_h -# undef accept -# define accept accept_used_without_including_sys_socket_h -# undef bind -# define bind bind_used_without_including_sys_socket_h -# undef getpeername -# define getpeername getpeername_used_without_including_sys_socket_h -# undef getsockname -# define getsockname getsockname_used_without_including_sys_socket_h -# undef getsockopt -# define getsockopt getsockopt_used_without_including_sys_socket_h -# undef listen -# define listen listen_used_without_including_sys_socket_h -# undef recv -# define recv recv_used_without_including_sys_socket_h -# undef send -# define send send_used_without_including_sys_socket_h -# undef recvfrom -# define recvfrom recvfrom_used_without_including_sys_socket_h -# undef sendto -# define sendto sendto_used_without_including_sys_socket_h -# undef setsockopt -# define setsockopt setsockopt_used_without_including_sys_socket_h -# undef shutdown -# define shutdown shutdown_used_without_including_sys_socket_h -# else +# endif +# if !defined _@GUARD_PREFIX@_SYS_SOCKET_H +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef socket +# define socket socket_used_without_including_sys_socket_h +# undef connect +# define connect connect_used_without_including_sys_socket_h +# undef accept +# define accept accept_used_without_including_sys_socket_h +# undef bind +# define bind bind_used_without_including_sys_socket_h +# undef getpeername +# define getpeername getpeername_used_without_including_sys_socket_h +# undef getsockname +# define getsockname getsockname_used_without_including_sys_socket_h +# undef getsockopt +# define getsockopt getsockopt_used_without_including_sys_socket_h +# undef listen +# define listen listen_used_without_including_sys_socket_h +# undef recv +# define recv recv_used_without_including_sys_socket_h +# undef send +# define send send_used_without_including_sys_socket_h +# undef recvfrom +# define recvfrom recvfrom_used_without_including_sys_socket_h +# undef sendto +# define sendto sendto_used_without_including_sys_socket_h +# undef setsockopt +# define setsockopt setsockopt_used_without_including_sys_socket_h +# undef shutdown +# define shutdown shutdown_used_without_including_sys_socket_h +# else _GL_WARN_ON_USE (socket, "socket() used without including <sys/socket.h>"); _GL_WARN_ON_USE (connect, @@ -189,17 +186,18 @@ _GL_WARN_ON_USE (gettimeofday, "gettimeofday is unportable - " "setsockopt() used without including <sys/socket.h>"); _GL_WARN_ON_USE (shutdown, "shutdown() used without including <sys/socket.h>"); -# endif -# endif -# if !defined _@GUARD_PREFIX@_SYS_SELECT_H -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef select -# define select select_used_without_including_sys_select_h -# else - _GL_WARN_ON_USE (select, - "select() used without including <sys/select.h>"); -# endif # endif # endif +# if !defined _@GUARD_PREFIX@_SYS_SELECT_H +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef select +# define select select_used_without_including_sys_select_h +# else + _GL_WARN_ON_USE (select, + "select() used without including <sys/select.h>"); +# endif +# endif +#endif #endif /* _@GUARD_PREFIX@_SYS_TIME_H */ +#endif /* _@GUARD_PREFIX@_SYS_TIME_H */ diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h index 6eedaeb41..520f6c860 100644 --- a/lib/sys_types.in.h +++ b/lib/sys_types.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/types.h. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_uio.in.h b/lib/sys_uio.in.h index 73c34be96..6f605dfd7 100644 --- a/lib/sys_uio.in.h +++ b/lib/sys_uio.in.h @@ -1,5 +1,5 @@ /* Substitute for <sys/uio.h>. - Copyright (C) 2011-2012 Free Software Foundation, Inc. + Copyright (C) 2011-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time.in.h b/lib/time.in.h index 11c6ca1b9..71dcc36f9 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -1,6 +1,6 @@ /* A more-standard <time.h>. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time_r.c b/lib/time_r.c index 267c18d70..9a617946d 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,6 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2010-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/trunc.c b/lib/trunc.c index 3b86ef014..26a784b6d 100644 --- a/lib/trunc.c +++ b/lib/trunc.c @@ -1,5 +1,5 @@ /* Round towards zero. - Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/unistd.c b/lib/unistd.c new file mode 100644 index 000000000..6c6a8e268 --- /dev/null +++ b/lib/unistd.c @@ -0,0 +1,3 @@ +#include <config.h> +#define _GL_UNISTD_INLINE _GL_EXTERN_INLINE +#include "unistd.h" diff --git a/lib/unistd.in.h b/lib/unistd.in.h index e96a39c26..84bed4a6a 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around <unistd.h>. - Copyright (C) 2003-2012 Free Software Foundation, Inc. + Copyright (C) 2003-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -14,29 +14,13 @@ You should have received a copy of the GNU Lesser General Public License along with this program; if not, see <http://www.gnu.org/licenses/>. */ +#ifndef _@GUARD_PREFIX@_UNISTD_H + #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ -/* Special invocation convention: - - On mingw, several headers, including <winsock2.h>, include <unistd.h>, - but we need to ensure that both the system <unistd.h> and <winsock2.h> - are completely included before we replace gethostname. */ -#if @GNULIB_GETHOSTNAME@ && @UNISTD_H_HAVE_WINSOCK2_H@ \ - && !defined _GL_WINSOCK2_H_WITNESS && defined _WINSOCK2_H -/* <unistd.h> is being indirectly included for the first time from - <winsock2.h>; avoid declaring any overrides. */ -# if @HAVE_UNISTD_H@ -# @INCLUDE_NEXT@ @NEXT_UNISTD_H@ -# else -# error unexpected; report this to bug-gnulib@gnu.org -# endif -# define _GL_WINSOCK2_H_WITNESS - -/* Normal invocation. */ -#elif !defined _@GUARD_PREFIX@_UNISTD_H - /* The include_next requires a split double-inclusion guard. */ #if @HAVE_UNISTD_H@ # @INCLUDE_NEXT@ @NEXT_UNISTD_H@ @@ -79,7 +63,9 @@ /* Solaris declares getcwd not only in <unistd.h> but also in <stdlib.h>. */ /* But avoid namespace pollution on glibc systems. */ #ifndef __GLIBC__ +# define __need_system_stdlib_h # include <stdlib.h> +# undef __need_system_stdlib_h #endif /* Native Windows platforms declare chdir, getcwd, rmdir in @@ -124,9 +110,15 @@ /* Get getopt(), optarg, optind, opterr, optopt. But avoid namespace pollution on glibc systems. */ #if @GNULIB_UNISTD_H_GETOPT@ && !defined __GLIBC__ && !defined _GL_SYSTEM_GETOPT +# define __need_getopt # include <getopt.h> #endif +_GL_INLINE_HEADER_BEGIN +#ifndef _GL_UNISTD_INLINE +# define _GL_UNISTD_INLINE _GL_INLINE +#endif + /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ /* The definition of _GL_ARG_NONNULL is copied here. */ @@ -404,7 +396,7 @@ extern char **environ; # endif #elif defined GNULIB_POSIXCHECK # if HAVE_RAW_DECL_ENVIRON -static inline char *** +_GL_UNISTD_INLINE char *** rpl_environ (void) { return &environ; @@ -862,7 +854,7 @@ _GL_CXXALIAS_RPL (getpagesize, int, (void)); # define getpagesize() _gl_getpagesize () # else # if !GNULIB_defined_getpagesize_function -static inline int +_GL_UNISTD_INLINE int getpagesize () { return _gl_getpagesize (); @@ -1530,6 +1522,7 @@ _GL_CXXALIAS_SYS_CAST (write, ssize_t, (int fd, const void *buf, size_t count)); _GL_CXXALIASWARN (write); #endif +_GL_INLINE_HEADER_END #endif /* _@GUARD_PREFIX@_UNISTD_H */ #endif /* _@GUARD_PREFIX@_UNISTD_H */ diff --git a/lib/unistr.in.h b/lib/unistr.in.h index 27067898e..2d28b1fc9 100644 --- a/lib/unistr.in.h +++ b/lib/unistr.in.h @@ -1,5 +1,5 @@ /* Elementary Unicode string functions. - Copyright (C) 2001-2002, 2005-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2005-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c index e68a8e27c..01794986e 100644 --- a/lib/unistr/u8-mbtouc-aux.c +++ b/lib/unistr/u8-mbtouc-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c b/lib/unistr/u8-mbtouc-unsafe-aux.c index 38db03d04..65f792c7f 100644 --- a/lib/unistr/u8-mbtouc-unsafe-aux.c +++ b/lib/unistr/u8-mbtouc-unsafe-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c index 6fbde718d..8aecdd493 100644 --- a/lib/unistr/u8-mbtouc-unsafe.c +++ b/lib/unistr/u8-mbtouc-unsafe.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c index d286c27e1..2e644bbb9 100644 --- a/lib/unistr/u8-mbtouc.c +++ b/lib/unistr/u8-mbtouc.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c index f01cfe983..7b9d8a776 100644 --- a/lib/unistr/u8-mbtoucr.c +++ b/lib/unistr/u8-mbtoucr.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string, returning an error code. - Copyright (C) 1999-2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c index 04def8714..5e9790914 100644 --- a/lib/unistr/u8-prev.c +++ b/lib/unistr/u8-prev.c @@ -1,5 +1,5 @@ /* Iterate over previous character in UTF-8 string. - Copyright (C) 2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c index 1a44ddb79..a6d21a416 100644 --- a/lib/unistr/u8-uctomb-aux.c +++ b/lib/unistr/u8-uctomb-aux.c @@ -1,5 +1,5 @@ /* Conversion UCS-4 to UTF-8. - Copyright (C) 2002, 2006-2007, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c index 4bfe26121..5e6a82593 100644 --- a/lib/unistr/u8-uctomb.c +++ b/lib/unistr/u8-uctomb.c @@ -1,5 +1,5 @@ /* Store a character in UTF-8 string. - Copyright (C) 2002, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unitypes.in.h b/lib/unitypes.in.h index c58858946..50a59f1a0 100644 --- a/lib/unitypes.in.h +++ b/lib/unitypes.in.h @@ -1,5 +1,5 @@ /* Elementary types and macros for the GNU UniString library. - Copyright (C) 2002, 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c index 1da25f5f1..2e6bc8023 100644 --- a/lib/vasnprintf.c +++ b/lib/vasnprintf.c @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 1999, 2002-2012 Free Software Foundation, Inc. + Copyright (C) 1999, 2002-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -1530,7 +1530,7 @@ is_borderline (const char *digits, size_t precision) /* Returns the number of TCHAR_T units needed as temporary space for the result of sprintf or SNPRINTF of a single conversion directive. */ -static inline size_t +static size_t MAX_ROOM_NEEDED (const arguments *ap, size_t arg_index, FCHAR_T conversion, arg_type type, int flags, size_t width, int has_precision, size_t precision, int pad_ourselves) diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h index 277f2707d..8571eb777 100644 --- a/lib/vasnprintf.h +++ b/lib/vasnprintf.h @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 2002-2004, 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2002-2004, 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/verify.h b/lib/verify.h index 780b55e1d..40b8ef5f4 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -1,6 +1,6 @@ /* Compile-time assert-like macros. - Copyright (C) 2005-2006, 2009-2012 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c index 1d8db4e24..4dd428c88 100644 --- a/lib/vsnprintf.c +++ b/lib/vsnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2013 Free Software Foundation, Inc. Written by Simon Josefsson and Yoann Vandoorselaere <yoann@prelude-ids.org>. This program is free software; you can redistribute it and/or modify diff --git a/lib/w32sock.h b/lib/w32sock.h index b397115ac..76c6f9f3b 100644 --- a/lib/w32sock.h +++ b/lib/w32sock.h @@ -1,6 +1,6 @@ /* w32sock.h --- internal auxiliary functions for Windows socket functions - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/wchar.in.h b/lib/wchar.in.h index 5c93616b6..97f7dc81f 100644 --- a/lib/wchar.in.h +++ b/lib/wchar.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 <wchar.h>, for platforms that have issues. - Copyright (C) 2007-2012 Free Software Foundation, Inc. + Copyright (C) 2007-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/wcrtomb.c b/lib/wcrtomb.c index a4d6bcdbd..0aab985f4 100644 --- a/lib/wcrtomb.c +++ b/lib/wcrtomb.c @@ -1,5 +1,5 @@ /* Convert wide character to multibyte character. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/wctype-h.c b/lib/wctype-h.c new file mode 100644 index 000000000..bb5f847e3 --- /dev/null +++ b/lib/wctype-h.c @@ -0,0 +1,4 @@ +/* Normally this would be wctype.c, but that name's already taken. */ +#include <config.h> +#define _GL_WCTYPE_INLINE _GL_EXTERN_INLINE +#include "wctype.h" diff --git a/lib/wctype.in.h b/lib/wctype.in.h index e819d44d2..246ce9d8d 100644 --- a/lib/wctype.in.h +++ b/lib/wctype.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 <wctype.h>, for platforms that lack it. - Copyright (C) 2006-2012 Free Software Foundation, Inc. + Copyright (C) 2006-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -54,6 +54,11 @@ #ifndef _@GUARD_PREFIX@_WCTYPE_H #define _@GUARD_PREFIX@_WCTYPE_H +_GL_INLINE_HEADER_BEGIN +#ifndef _GL_WCTYPE_INLINE +# define _GL_WCTYPE_INLINE _GL_INLINE +#endif + /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ /* The definition of _GL_WARN_ON_USE is copied here. */ @@ -148,7 +153,7 @@ typedef unsigned int rpl_wint_t; # endif # endif -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswalnum # else @@ -160,7 +165,7 @@ iswalnum || ((wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'Z')); } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswalpha # else @@ -171,7 +176,7 @@ iswalpha return (wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'Z'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswblank # else @@ -182,7 +187,7 @@ iswblank return wc == ' ' || wc == '\t'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswcntrl # else @@ -193,7 +198,7 @@ iswcntrl return (wc & ~0x1f) == 0 || wc == 0x7f; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswdigit # else @@ -204,7 +209,7 @@ iswdigit return wc >= '0' && wc <= '9'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswgraph # else @@ -215,7 +220,7 @@ iswgraph return wc >= '!' && wc <= '~'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswlower # else @@ -226,7 +231,7 @@ iswlower return wc >= 'a' && wc <= 'z'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswprint # else @@ -237,7 +242,7 @@ iswprint return wc >= ' ' && wc <= '~'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswpunct # else @@ -250,7 +255,7 @@ iswpunct || ((wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'Z'))); } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswspace # else @@ -262,7 +267,7 @@ iswspace || wc == '\n' || wc == '\v' || wc == '\f' || wc == '\r'); } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswupper # else @@ -273,7 +278,7 @@ iswupper return wc >= 'A' && wc <= 'Z'; } -static inline int +_GL_WCTYPE_INLINE int # if @REPLACE_ISWCNTRL@ rpl_iswxdigit # else @@ -285,7 +290,7 @@ iswxdigit || ((wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'F')); } -static inline wint_t +_GL_WCTYPE_INLINE wint_t # if @REPLACE_TOWLOWER@ rpl_towlower # else @@ -296,7 +301,7 @@ towlower return (wc >= 'A' && wc <= 'Z' ? wc - 'A' + 'a' : wc); } -static inline wint_t +_GL_WCTYPE_INLINE wint_t # if @REPLACE_TOWLOWER@ rpl_towupper # else @@ -336,7 +341,7 @@ _GL_FUNCDECL_SYS (iswblank, int, (wint_t wc)); result register. We need to fix this by adding a zero-extend from wchar_t to wint_t after the call. */ -static inline wint_t +_GL_WCTYPE_INLINE wint_t rpl_towlower (wint_t wc) { return (wint_t) (wchar_t) towlower (wc); @@ -345,7 +350,7 @@ rpl_towlower (wint_t wc) # define towlower rpl_towlower # endif -static inline wint_t +_GL_WCTYPE_INLINE wint_t rpl_towupper (wint_t wc) { return (wint_t) (wchar_t) towupper (wc); @@ -493,6 +498,7 @@ _GL_WARN_ON_USE (towctrans, "towctrans is unportable - " # endif #endif +_GL_INLINE_HEADER_END #endif /* _@GUARD_PREFIX@_WCTYPE_H */ #endif /* _@GUARD_PREFIX@_WCTYPE_H */ diff --git a/lib/write.c b/lib/write.c index 2473cdb6f..d7d00de44 100644 --- a/lib/write.c +++ b/lib/write.c @@ -1,5 +1,5 @@ /* POSIX compatible write() function. - Copyright (C) 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2008-2013 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2008. This program is free software: you can redistribute it and/or modify @@ -40,7 +40,7 @@ # undef write # if HAVE_MSVC_INVALID_PARAMETER_HANDLER -static inline ssize_t +static ssize_t write_nothrow (int fd, const void *buf, size_t count) { ssize_t result; diff --git a/lib/xsize.h b/lib/xsize.h index 831224398..a7a34c582 100644 --- a/lib/xsize.h +++ b/lib/xsize.h @@ -1,6 +1,6 @@ /* xsize.h -- Checked size_t computations. - Copyright (C) 2003, 2008-2012 Free Software Foundation, Inc. + Copyright (C) 2003, 2008-2013 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index d978cb898..d4ad759fd 100644 --- a/m4/00gnulib.m4 +++ b/m4/00gnulib.m4 @@ -1,5 +1,5 @@ # 00gnulib.m4 serial 2 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/absolute-header.m4 b/m4/absolute-header.m4 index 8a91d2057..89ff5beb6 100644 --- a/m4/absolute-header.m4 +++ b/m4/absolute-header.m4 @@ -1,5 +1,5 @@ # absolute-header.m4 serial 16 -dnl Copyright (C) 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2013 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. diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 656924be8..270abd0cd 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,5 +1,5 @@ # alloca.m4 serial 14 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2012 Free Software Foundation, +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4 index 36915d12e..ea69af572 100644 --- a/m4/arpa_inet_h.m4 +++ b/m4/arpa_inet_h.m4 @@ -1,5 +1,5 @@ # arpa_inet_h.m4 serial 13 -dnl Copyright (C) 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2013 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. diff --git a/m4/autobuild.m4 b/m4/autobuild.m4 index 284dc6028..3147b5b05 100644 --- a/m4/autobuild.m4 +++ b/m4/autobuild.m4 @@ -1,5 +1,5 @@ # autobuild.m4 serial 7 -dnl Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006-2013 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. diff --git a/m4/btowc.m4 b/m4/btowc.m4 index e565321ce..978a06e9a 100644 --- a/m4/btowc.m4 +++ b/m4/btowc.m4 @@ -1,5 +1,5 @@ # btowc.m4 serial 10 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 index f3b7ec97d..7566903dc 100644 --- a/m4/byteswap.m4 +++ b/m4/byteswap.m4 @@ -1,5 +1,5 @@ # byteswap.m4 serial 4 -dnl Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2013 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. diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index ea51ac420..cef312441 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,6 +1,6 @@ # canonicalize.m4 serial 26 -dnl Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2007, 2009-2013 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/ceil.m4 b/m4/ceil.m4 index 890517b49..c6175610b 100644 --- a/m4/ceil.m4 +++ b/m4/ceil.m4 @@ -1,5 +1,5 @@ # ceil.m4 serial 9 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/check-math-lib.m4 b/m4/check-math-lib.m4 index 4f370eb49..77570f4b2 100644 --- a/m4/check-math-lib.m4 +++ b/m4/check-math-lib.m4 @@ -1,5 +1,5 @@ # check-math-lib.m4 serial 4 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/clock_time.m4 b/m4/clock_time.m4 index fb3a17a6c..767a1bebe 100644 --- a/m4/clock_time.m4 +++ b/m4/clock_time.m4 @@ -1,5 +1,5 @@ # clock_time.m4 serial 10 -dnl Copyright (C) 2002-2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2013 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. diff --git a/m4/close.m4 b/m4/close.m4 index 379e70d83..bccd9819c 100644 --- a/m4/close.m4 +++ b/m4/close.m4 @@ -1,5 +1,5 @@ # close.m4 serial 8 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/codeset.m4 b/m4/codeset.m4 index cf53d2416..c2761be2a 100644 --- a/m4/codeset.m4 +++ b/m4/codeset.m4 @@ -1,5 +1,5 @@ # codeset.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2000-2002, 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2006, 2008-2013 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. diff --git a/m4/configmake.m4 b/m4/configmake.m4 index 8c82371eb..823ffc0dd 100644 --- a/m4/configmake.m4 +++ b/m4/configmake.m4 @@ -1,5 +1,5 @@ # configmake.m4 serial 1 -dnl Copyright (C) 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2013 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. diff --git a/m4/dirent_h.m4 b/m4/dirent_h.m4 index f6c0fa7ba..54c166343 100644 --- a/m4/dirent_h.m4 +++ b/m4/dirent_h.m4 @@ -1,5 +1,5 @@ # dirent_h.m4 serial 16 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/dirfd.m4 b/m4/dirfd.m4 index fc475d78b..39bc78971 100644 --- a/m4/dirfd.m4 +++ b/m4/dirfd.m4 @@ -2,7 +2,7 @@ dnl Find out how to get the file descriptor associated with an open DIR*. -# Copyright (C) 2001-2006, 2008-2012 Free Software Foundation, Inc. +# Copyright (C) 2001-2006, 2008-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/dirname.m4 b/m4/dirname.m4 index 65639ec89..5897a2a8b 100644 --- a/m4/dirname.m4 +++ b/m4/dirname.m4 @@ -1,5 +1,5 @@ #serial 10 -*- autoconf -*- -dnl Copyright (C) 2002-2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2013 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. diff --git a/m4/double-slash-root.m4 b/m4/double-slash-root.m4 index 1e0375137..bd6f86714 100644 --- a/m4/double-slash-root.m4 +++ b/m4/double-slash-root.m4 @@ -1,5 +1,5 @@ # double-slash-root.m4 serial 4 -*- Autoconf -*- -dnl Copyright (C) 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2013 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. diff --git a/m4/duplocale.m4 b/m4/duplocale.m4 index 6096f5c56..9ef894c9c 100644 --- a/m4/duplocale.m4 +++ b/m4/duplocale.m4 @@ -1,5 +1,5 @@ # duplocale.m4 serial 7 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 index 9e5df45d3..c640ec129 100644 --- a/m4/eealloc.m4 +++ b/m4/eealloc.m4 @@ -1,5 +1,5 @@ # eealloc.m4 serial 3 -dnl Copyright (C) 2003, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2009-2013 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. diff --git a/m4/environ.m4 b/m4/environ.m4 index 8eb57c9d9..593a33ed4 100644 --- a/m4/environ.m4 +++ b/m4/environ.m4 @@ -1,5 +1,5 @@ # environ.m4 serial 6 -dnl Copyright (C) 2001-2004, 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2013 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. diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index 4e33ba853..c813ea583 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,5 +1,5 @@ # errno_h.m4 serial 12 -dnl Copyright (C) 2004, 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2008-2013 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. diff --git a/m4/exponentd.m4 b/m4/exponentd.m4 index 0ae4ccfac..09df468c9 100644 --- a/m4/exponentd.m4 +++ b/m4/exponentd.m4 @@ -1,5 +1,5 @@ # exponentd.m4 serial 3 -dnl Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2013 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. diff --git a/m4/exponentf.m4 b/m4/exponentf.m4 index 94d11679f..55a04e63c 100644 --- a/m4/exponentf.m4 +++ b/m4/exponentf.m4 @@ -1,5 +1,5 @@ # exponentf.m4 serial 2 -dnl Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2013 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. diff --git a/m4/exponentl.m4 b/m4/exponentl.m4 index a7cd13bc9..f877cf140 100644 --- a/m4/exponentl.m4 +++ b/m4/exponentl.m4 @@ -1,5 +1,5 @@ # exponentl.m4 serial 3 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/extensions.m4 b/m4/extensions.m4 index 6d17d8a74..07ba376c0 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,14 +1,14 @@ -# serial 12 -*- Autoconf -*- +# serial 13 -*- Autoconf -*- # Enable extensions on systems that normally disable them. -# Copyright (C) 2003, 2006-2012 Free Software Foundation, Inc. +# Copyright (C) 2003, 2006-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This definition of AC_USE_SYSTEM_EXTENSIONS is stolen from CVS # Autoconf. Perhaps we can remove this once we can assume Autoconf -# 2.62 or later everywhere, but since CVS Autoconf mutates rapidly +# 2.70 or later everywhere, but since Autoconf mutates rapidly # enough in this area it's likely we'll need to redefine # AC_USE_SYSTEM_EXTENSIONS for quite some time. @@ -30,6 +30,7 @@ # ------------------------ # Enable extensions on systems that normally disable them, # typically due to standards-conformance issues. +# # Remember that #undef in AH_VERBATIM gets replaced with #define by # AC_DEFINE. The goal here is to define all known feature-enabling # macros, then, if reports of conflicts are made, disable macros that @@ -38,8 +39,6 @@ AC_DEFUN_ONCE([AC_USE_SYSTEM_EXTENSIONS], [AC_BEFORE([$0], [AC_COMPILE_IFELSE])dnl AC_BEFORE([$0], [AC_RUN_IFELSE])dnl - AC_REQUIRE([AC_CANONICAL_HOST]) - AC_CHECK_HEADER([minix/config.h], [MINIX=yes], [MINIX=]) if test "$MINIX" = yes; then AC_DEFINE([_POSIX_SOURCE], [1], @@ -50,24 +49,18 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl except with this defined.]) AC_DEFINE([_MINIX], [1], [Define to 1 if on MINIX.]) + AC_DEFINE([_NETBSD_SOURCE], [1], + [Define to 1 to make NetBSD features available. MINIX 3 needs this.]) fi - dnl HP-UX 11.11 defines mbstate_t only if _XOPEN_SOURCE is defined to 500, - dnl regardless of whether the flags -Ae or _D_HPUX_SOURCE=1 are already - dnl provided. - case "$host_os" in - hpux*) - AC_DEFINE([_XOPEN_SOURCE], [500], - [Define to 500 only on HP-UX.]) - ;; - esac - - AH_VERBATIM([__EXTENSIONS__], +dnl Use a different key than __EXTENSIONS__, as that name broke existing +dnl configure.ac when using autoheader 2.62. + AH_VERBATIM([USE_SYSTEM_EXTENSIONS], [/* Enable extensions on AIX 3, Interix. */ #ifndef _ALL_SOURCE # undef _ALL_SOURCE #endif -/* Enable general extensions on Mac OS X. */ +/* Enable general extensions on OS X. */ #ifndef _DARWIN_C_SOURCE # undef _DARWIN_C_SOURCE #endif @@ -83,6 +76,12 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl #ifndef _TANDEM_SOURCE # undef _TANDEM_SOURCE #endif +/* Enable X/Open extensions if necessary. HP-UX 11.11 defines + mbstate_t only if _XOPEN_SOURCE is defined to 500, regardless of + whether compiling with -Ae or -D_HPUX_SOURCE=1. */ +#ifndef _XOPEN_SOURCE +# undef _XOPEN_SOURCE +#endif /* Enable general extensions on Solaris. */ #ifndef __EXTENSIONS__ # undef __EXTENSIONS__ @@ -103,6 +102,22 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl AC_DEFINE([_GNU_SOURCE]) AC_DEFINE([_POSIX_PTHREAD_SEMANTICS]) AC_DEFINE([_TANDEM_SOURCE]) + AC_CACHE_CHECK([whether _XOPEN_SOURCE should be defined], + [ac_cv_should_define__xopen_source], + [ac_cv_should_define__xopen_source=no + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[ + #include <wchar.h> + mbstate_t x;]])], + [], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[ + #define _XOPEN_SOURCE 500 + #include <wchar.h> + mbstate_t x;]])], + [ac_cv_should_define__xopen_source=yes])])]) + test $ac_cv_should_define__xopen_source = yes && + AC_DEFINE([_XOPEN_SOURCE], [500]) ])# AC_USE_SYSTEM_EXTENSIONS # gl_USE_SYSTEM_EXTENSIONS diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4 index 600c8d3fa..5880d4f45 100644 --- a/m4/extern-inline.m4 +++ b/m4/extern-inline.m4 @@ -1,13 +1,12 @@ dnl 'extern inline' a la ISO C99. -dnl Copyright 2012 Free Software Foundation, Inc. +dnl Copyright 2012-2013 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'. @@ -17,13 +16,19 @@ AC_DEFUN([gl_EXTERN_INLINE], 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__) + in the same include file, after uses of _GL_INLINE. + + Suppress the use of extern inline on Apple's platforms, + as Libc-825.25 (2012-09-19) is incompatible with it; see + <http://lists.gnu.org/archive/html/bug-gnulib/2012-12/msg00023.html>. + Perhaps Apple will fix this some day. */ +#if ((__GNUC__ \ + ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \ + : 199901L <= __STDC_VERSION__) \ + && !defined __APPLE__) # define _GL_INLINE inline # define _GL_EXTERN_INLINE extern inline -#elif 2 < __GNUC__ + (7 <= __GNUC_MINOR__) +#elif 2 < __GNUC__ + (7 <= __GNUC_MINOR__) && !defined __APPLE__ # if __GNUC_GNU_INLINE__ /* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */ # define _GL_INLINE extern inline __attribute__ ((__gnu_inline__)) @@ -32,8 +37,8 @@ AC_DEFUN([gl_EXTERN_INLINE], # endif # define _GL_EXTERN_INLINE extern #else -# define _GL_INLINE static inline -# define _GL_EXTERN_INLINE static inline +# define _GL_INLINE static _GL_UNUSED +# define _GL_EXTERN_INLINE static _GL_UNUSED #endif #if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4 index 740e78b68..87cc4bd2d 100644 --- a/m4/fcntl-o.m4 +++ b/m4/fcntl-o.m4 @@ -1,5 +1,5 @@ # fcntl-o.m4 serial 4 -dnl Copyright (C) 2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2013 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. diff --git a/m4/fcntl_h.m4 b/m4/fcntl_h.m4 index cac28aeb2..3cff1fd64 100644 --- a/m4/fcntl_h.m4 +++ b/m4/fcntl_h.m4 @@ -1,6 +1,6 @@ # serial 15 # Configure fcntl.h. -dnl Copyright (C) 2006-2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2007, 2009-2013 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. diff --git a/m4/float_h.m4 b/m4/float_h.m4 index 51c9c7b35..397f2d1fa 100644 --- a/m4/float_h.m4 +++ b/m4/float_h.m4 @@ -1,5 +1,5 @@ # float_h.m4 serial 9 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/flock.m4 b/m4/flock.m4 index 774688330..bbcc4f988 100644 --- a/m4/flock.m4 +++ b/m4/flock.m4 @@ -1,5 +1,5 @@ # flock.m4 serial 3 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/floor.m4 b/m4/floor.m4 index a6e7ec811..c176a99c5 100644 --- a/m4/floor.m4 +++ b/m4/floor.m4 @@ -1,5 +1,5 @@ # floor.m4 serial 8 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/fpieee.m4 b/m4/fpieee.m4 index 82fd77832..97941bb47 100644 --- a/m4/fpieee.m4 +++ b/m4/fpieee.m4 @@ -1,5 +1,5 @@ # fpieee.m4 serial 2 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/frexp.m4 b/m4/frexp.m4 index fb8db7046..39097923e 100644 --- a/m4/frexp.m4 +++ b/m4/frexp.m4 @@ -1,5 +1,5 @@ # frexp.m4 serial 14 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/fstat.m4 b/m4/fstat.m4 index 3ab3297b2..b2cf2ad24 100644 --- a/m4/fstat.m4 +++ b/m4/fstat.m4 @@ -1,5 +1,5 @@ -# fstat.m4 serial 3 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +# fstat.m4 serial 4 +dnl Copyright (C) 2011-2013 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. @@ -33,7 +33,4 @@ AC_DEFUN([gl_FUNC_FSTAT], ]) # Prerequisites of lib/fstat.c. -AC_DEFUN([gl_PREREQ_FSTAT], -[ - AC_REQUIRE([AC_C_INLINE]) -]) +AC_DEFUN([gl_PREREQ_FSTAT], [:]) diff --git a/m4/func.m4 b/m4/func.m4 index 13c204d41..5548d5e75 100644 --- a/m4/func.m4 +++ b/m4/func.m4 @@ -1,5 +1,5 @@ # func.m4 serial 2 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/getaddrinfo.m4 b/m4/getaddrinfo.m4 index 9cd3e675e..1d631f8cb 100644 --- a/m4/getaddrinfo.m4 +++ b/m4/getaddrinfo.m4 @@ -1,5 +1,5 @@ -# getaddrinfo.m4 serial 29 -dnl Copyright (C) 2004-2012 Free Software Foundation, Inc. +# getaddrinfo.m4 serial 30 +dnl Copyright (C) 2004-2013 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. @@ -134,7 +134,6 @@ AC_DEFUN([gl_PREREQ_GETADDRINFO], [ AC_REQUIRE([AC_C_RESTRICT]) AC_REQUIRE([gl_SOCKET_FAMILIES]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) - AC_REQUIRE([AC_C_INLINE]) AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) dnl Including sys/socket.h is wrong for Windows, but Windows does not diff --git a/m4/glibc21.m4 b/m4/glibc21.m4 index c938fb1a0..613fb2a41 100644 --- a/m4/glibc21.m4 +++ b/m4/glibc21.m4 @@ -1,5 +1,5 @@ # glibc21.m4 serial 5 -dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2012 Free Software Foundation, +dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index cae4bb732..c0fd22691 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -1,4 +1,4 @@ -# Copyright (C) 2002-2012 Free Software Foundation, Inc. +# Copyright (C) 2002-2013 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 15d2b2b3d..0ae5a9ec6 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,5 +1,5 @@ # gnulib-common.m4 serial 33 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. @@ -294,6 +294,8 @@ Amsterdam # for interoperability with automake-1.9.6 from autoconf-2.62. # Remove this macro when we can assume autoconf >= 2.62 or # autoconf >= 2.60 && automake >= 1.10. +# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness. +m4_ifndef([AC_AUTOCONF_VERSION],[ m4_ifdef([AC_PROG_MKDIR_P], [ dnl For automake-1.9.6 && autoconf < 2.62: Ensure MKDIR_P is AC_SUBSTed. m4_define([AC_PROG_MKDIR_P], @@ -304,13 +306,15 @@ m4_ifdef([AC_PROG_MKDIR_P], [ [AC_REQUIRE([AM_PROG_MKDIR_P])dnl defined by automake MKDIR_P='$(mkdir_p)' AC_SUBST([MKDIR_P])])]) +]) # AC_C_RESTRICT # This definition overrides the AC_C_RESTRICT macro from autoconf 2.60..2.61, # so that mixed use of GNU C and GNU C++ and mixed use of Sun C and Sun C++ # works. # This definition can be removed once autoconf >= 2.62 can be assumed. -m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.62]),[-1],[ +# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness. +m4_ifndef([AC_AUTOCONF_VERSION],[ AC_DEFUN([AC_C_RESTRICT], [AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict], [ac_cv_c_restrict=no diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index b52b97285..ce1be65fe 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -1,5 +1,5 @@ # DO NOT EDIT! GENERATED AUTOMATICALLY! -# Copyright (C) 2002-2012 Free Software Foundation, Inc. +# Copyright (C) 2002-2013 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -534,6 +534,7 @@ AC_DEFUN([gl_INIT], gl_FUNC_PUTENV if test $REPLACE_PUTENV = 1; then AC_LIBOBJ([putenv]) + gl_PREREQ_PUTENV fi gl_STDLIB_MODULE_INDICATOR([putenv]) gl_FUNC_RAISE @@ -942,6 +943,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/malloca.c lib/malloca.h lib/malloca.valgrind + lib/math.c lib/math.in.h lib/mbrtowc.c lib/mbsinit.c @@ -1015,6 +1017,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/string.in.h lib/stripslash.c lib/sys_file.in.h + lib/sys_socket.c lib/sys_socket.in.h lib/sys_stat.in.h lib/sys_time.in.h @@ -1023,6 +1026,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/time.in.h lib/time_r.c lib/trunc.c + lib/unistd.c lib/unistd.in.h lib/unistr.in.h lib/unistr/u8-mbtouc-aux.c @@ -1041,6 +1045,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/w32sock.h lib/wchar.in.h lib/wcrtomb.c + lib/wctype-h.c lib/wctype.in.h lib/write.c lib/xsize.c diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4 index a09ffc1d1..f3dea1a9f 100644 --- a/m4/gnulib-tool.m4 +++ b/m4/gnulib-tool.m4 @@ -1,5 +1,5 @@ # gnulib-tool.m4 serial 2 -dnl Copyright (C) 2004-2005, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2005, 2009-2013 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. diff --git a/m4/hostent.m4 b/m4/hostent.m4 index 51347755c..72be876b7 100644 --- a/m4/hostent.m4 +++ b/m4/hostent.m4 @@ -1,5 +1,5 @@ # hostent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2013 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. diff --git a/m4/iconv.m4 b/m4/iconv.m4 index 6a47236c4..a50364656 100644 --- a/m4/iconv.m4 +++ b/m4/iconv.m4 @@ -1,5 +1,5 @@ # iconv.m4 serial 18 (gettext-0.18.2) -dnl Copyright (C) 2000-2002, 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2007-2013 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. diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 index aa86cf8fe..f0519d9c0 100644 --- a/m4/iconv_h.m4 +++ b/m4/iconv_h.m4 @@ -1,5 +1,5 @@ # iconv_h.m4 serial 8 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/iconv_open-utf.m4 b/m4/iconv_open-utf.m4 index f450f5543..0ab3a1806 100644 --- a/m4/iconv_open-utf.m4 +++ b/m4/iconv_open-utf.m4 @@ -1,5 +1,5 @@ # iconv_open-utf.m4 serial 1 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 index 07f484918..1dcf41491 100644 --- a/m4/iconv_open.m4 +++ b/m4/iconv_open.m4 @@ -1,5 +1,5 @@ # iconv_open.m4 serial 14 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/include_next.m4 b/m4/include_next.m4 index a60a2614d..108d94567 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,5 +1,5 @@ # include_next.m4 serial 23 -dnl Copyright (C) 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2013 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. diff --git a/m4/inet_ntop.m4 b/m4/inet_ntop.m4 index 1ebd96031..476f063fe 100644 --- a/m4/inet_ntop.m4 +++ b/m4/inet_ntop.m4 @@ -1,5 +1,5 @@ # inet_ntop.m4 serial 19 -dnl Copyright (C) 2005-2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2006, 2008-2013 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. diff --git a/m4/inet_pton.m4 b/m4/inet_pton.m4 index e7b44e282..e86db827a 100644 --- a/m4/inet_pton.m4 +++ b/m4/inet_pton.m4 @@ -1,5 +1,5 @@ # inet_pton.m4 serial 17 -dnl Copyright (C) 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2013 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. diff --git a/m4/inline.m4 b/m4/inline.m4 index 6fa997246..3a50621e4 100644 --- a/m4/inline.m4 +++ b/m4/inline.m4 @@ -1,5 +1,5 @@ # inline.m4 serial 4 -dnl Copyright (C) 2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2013 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. diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4 index c1a4a75d8..6ea70531c 100644 --- a/m4/intmax_t.m4 +++ b/m4/intmax_t.m4 @@ -1,5 +1,5 @@ # intmax_t.m4 serial 8 -dnl Copyright (C) 1997-2004, 2006-2007, 2009-2012 Free Software Foundation, +dnl Copyright (C) 1997-2004, 2006-2007, 2009-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4 index 91c7bca62..5f05ac58c 100644 --- a/m4/inttypes_h.m4 +++ b/m4/inttypes_h.m4 @@ -1,5 +1,5 @@ # inttypes_h.m4 serial 10 -dnl Copyright (C) 1997-2004, 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2013 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. diff --git a/m4/isinf.m4 b/m4/isinf.m4 index 0f6309e15..513a1bad6 100644 --- a/m4/isinf.m4 +++ b/m4/isinf.m4 @@ -1,5 +1,5 @@ # isinf.m4 serial 9 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/isnan.m4 b/m4/isnan.m4 index 7ad7127e1..ababb254b 100644 --- a/m4/isnan.m4 +++ b/m4/isnan.m4 @@ -1,5 +1,5 @@ # isnan.m4 serial 5 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/isnand.m4 b/m4/isnand.m4 index 54b64a452..ee05e0f93 100644 --- a/m4/isnand.m4 +++ b/m4/isnand.m4 @@ -1,5 +1,5 @@ # isnand.m4 serial 11 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/isnanf.m4 b/m4/isnanf.m4 index 97f638a93..f01886a68 100644 --- a/m4/isnanf.m4 +++ b/m4/isnanf.m4 @@ -1,5 +1,5 @@ # isnanf.m4 serial 14 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/isnanl.m4 b/m4/isnanl.m4 index 81469ab8c..ed5bbf8ba 100644 --- a/m4/isnanl.m4 +++ b/m4/isnanl.m4 @@ -1,5 +1,5 @@ # isnanl.m4 serial 17 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/langinfo_h.m4 b/m4/langinfo_h.m4 index b93fe7066..73bef8bce 100644 --- a/m4/langinfo_h.m4 +++ b/m4/langinfo_h.m4 @@ -1,5 +1,5 @@ # langinfo_h.m4 serial 7 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/largefile.m4 b/m4/largefile.m4 index a88850afe..1e605e3d8 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -1,13 +1,14 @@ # Enable large files on systems where this is not the default. -# Copyright 1992-1996, 1998-2012 Free Software Foundation, Inc. +# Copyright 1992-1996, 1998-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. -# The following implementation works around a problem in autoconf <= 2.68; -# AC_SYS_LARGEFILE does not configure for large inodes on Mac OS X 10.5. -m4_version_prereq([2.69], [] ,[ +# The following implementation works around a problem in autoconf <= 2.69; +# AC_SYS_LARGEFILE does not configure for large inodes on Mac OS X 10.5, +# or configures them incorrectly in some cases. +m4_version_prereq([2.70], [] ,[ # _AC_SYS_LARGEFILE_TEST_INCLUDES # ------------------------------- @@ -25,9 +26,9 @@ m4_define([_AC_SYS_LARGEFILE_TEST_INCLUDES], # _AC_SYS_LARGEFILE_MACRO_VALUE(C-MACRO, VALUE, -# CACHE-VAR, -# DESCRIPTION, -# PROLOGUE, [FUNCTION-BODY]) +# CACHE-VAR, +# DESCRIPTION, +# PROLOGUE, [FUNCTION-BODY]) # -------------------------------------------------------- m4_define([_AC_SYS_LARGEFILE_MACRO_VALUE], [AC_CACHE_CHECK([for $1 value needed for large files], [$3], @@ -93,15 +94,11 @@ if test "$enable_largefile" != no; then [_AC_SYS_LARGEFILE_TEST_INCLUDES]) fi - AH_VERBATIM([_DARWIN_USE_64_BIT_INODE], -[/* Enable large inode numbers on Mac OS X. */ -#ifndef _DARWIN_USE_64_BIT_INODE -# define _DARWIN_USE_64_BIT_INODE 1 -#endif]) + AC_DEFINE([_DARWIN_USE_64_BIT_INODE], [1], + [Enable large inode numbers on Mac OS X 10.5.]) fi ])# AC_SYS_LARGEFILE - -])# m4_version_prereq 2.69 +])# m4_version_prereq 2.70 # Enable large files on systems where this is implemented by Gnulib, not by the # system headers. diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4 index 5ed93efdb..63386f173 100644 --- a/m4/ld-version-script.m4 +++ b/m4/ld-version-script.m4 @@ -1,5 +1,5 @@ # ld-version-script.m4 serial 3 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/ldexp.m4 b/m4/ldexp.m4 index 6d26b564f..7a75b1be2 100644 --- a/m4/ldexp.m4 +++ b/m4/ldexp.m4 @@ -1,5 +1,5 @@ # ldexp.m4 serial 1 -dnl Copyright (C) 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2013 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. diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4 index e1feab540..c145e478e 100644 --- a/m4/lib-ld.m4 +++ b/m4/lib-ld.m4 @@ -1,5 +1,5 @@ # lib-ld.m4 serial 6 -dnl Copyright (C) 1996-2003, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 1996-2003, 2009-2013 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. diff --git a/m4/lib-link.m4 b/m4/lib-link.m4 index d11b4b435..073f04050 100644 --- a/m4/lib-link.m4 +++ b/m4/lib-link.m4 @@ -1,5 +1,5 @@ # lib-link.m4 serial 26 (gettext-0.18.2) -dnl Copyright (C) 2001-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2013 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. diff --git a/m4/lib-prefix.m4 b/m4/lib-prefix.m4 index 007aa0532..60908e8fb 100644 --- a/m4/lib-prefix.m4 +++ b/m4/lib-prefix.m4 @@ -1,5 +1,5 @@ # lib-prefix.m4 serial 7 (gettext-0.18) -dnl Copyright (C) 2001-2005, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2005, 2008-2013 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. diff --git a/m4/libunistring-base.m4 b/m4/libunistring-base.m4 index d91c42b9f..d105c7217 100644 --- a/m4/libunistring-base.m4 +++ b/m4/libunistring-base.m4 @@ -1,5 +1,5 @@ # libunistring-base.m4 serial 5 -dnl Copyright (C) 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2013 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. diff --git a/m4/libunistring.m4 b/m4/libunistring.m4 index c1bf4d553..fa74d72fc 100644 --- a/m4/libunistring.m4 +++ b/m4/libunistring.m4 @@ -1,5 +1,5 @@ # libunistring.m4 serial 11 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/localcharset.m4 b/m4/localcharset.m4 index 8010379b1..2e93e5818 100644 --- a/m4/localcharset.m4 +++ b/m4/localcharset.m4 @@ -1,5 +1,5 @@ # localcharset.m4 serial 7 -dnl Copyright (C) 2002, 2004, 2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2004, 2006, 2009-2013 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. diff --git a/m4/locale-fr.m4 b/m4/locale-fr.m4 index 71b68476c..ef199e397 100644 --- a/m4/locale-fr.m4 +++ b/m4/locale-fr.m4 @@ -1,5 +1,5 @@ # locale-fr.m4 serial 17 -dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2013 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. diff --git a/m4/locale-ja.m4 b/m4/locale-ja.m4 index 5ba0e4381..132a3e779 100644 --- a/m4/locale-ja.m4 +++ b/m4/locale-ja.m4 @@ -1,5 +1,5 @@ # locale-ja.m4 serial 12 -dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2013 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. diff --git a/m4/locale-zh.m4 b/m4/locale-zh.m4 index e5502b29e..4eed73f40 100644 --- a/m4/locale-zh.m4 +++ b/m4/locale-zh.m4 @@ -1,5 +1,5 @@ # locale-zh.m4 serial 12 -dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2013 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. diff --git a/m4/locale_h.m4 b/m4/locale_h.m4 index c0f4d524a..8bd12e80e 100644 --- a/m4/locale_h.m4 +++ b/m4/locale_h.m4 @@ -1,5 +1,5 @@ # locale_h.m4 serial 19 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/localeconv.m4 b/m4/localeconv.m4 index 5fae06d88..b8bb5964b 100644 --- a/m4/localeconv.m4 +++ b/m4/localeconv.m4 @@ -1,5 +1,5 @@ # localeconv.m4 serial 1 -dnl Copyright (C) 2012 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2013 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. diff --git a/m4/log.m4 b/m4/log.m4 index a04362ae5..31a6adf89 100644 --- a/m4/log.m4 +++ b/m4/log.m4 @@ -1,5 +1,5 @@ # log.m4 serial 4 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2013 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. diff --git a/m4/log1p.m4 b/m4/log1p.m4 index 4bca324e9..8a8151129 100644 --- a/m4/log1p.m4 +++ b/m4/log1p.m4 @@ -1,5 +1,5 @@ # log1p.m4 serial 3 -dnl Copyright (C) 2012 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2013 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. diff --git a/m4/longlong.m4 b/m4/longlong.m4 index b9c65c756..3af6ab5aa 100644 --- a/m4/longlong.m4 +++ b/m4/longlong.m4 @@ -1,5 +1,5 @@ # longlong.m4 serial 17 -dnl Copyright (C) 1999-2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 1999-2007, 2009-2013 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. diff --git a/m4/lstat.m4 b/m4/lstat.m4 index b7335bda1..5f4db64a4 100644 --- a/m4/lstat.m4 +++ b/m4/lstat.m4 @@ -1,6 +1,6 @@ -# serial 25 +# serial 26 -# Copyright (C) 1997-2001, 2003-2012 Free Software Foundation, Inc. +# Copyright (C) 1997-2001, 2003-2013 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -27,11 +27,7 @@ AC_DEFUN([gl_FUNC_LSTAT], ]) # Prerequisites of lib/lstat.c. -AC_DEFUN([gl_PREREQ_LSTAT], -[ - AC_REQUIRE([AC_C_INLINE]) - : -]) +AC_DEFUN([gl_PREREQ_LSTAT], [:]) AC_DEFUN([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK], [ diff --git a/m4/malloc.m4 b/m4/malloc.m4 index 8fa48e93b..4b24a0b11 100644 --- a/m4/malloc.m4 +++ b/m4/malloc.m4 @@ -1,5 +1,5 @@ # malloc.m4 serial 14 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/malloca.m4 b/m4/malloca.m4 index 7841979f3..791ce10d5 100644 --- a/m4/malloca.m4 +++ b/m4/malloca.m4 @@ -1,5 +1,5 @@ # malloca.m4 serial 1 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2012 Free Software Foundation, +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/math_h.m4 b/m4/math_h.m4 index 90d248aec..bf0845fd1 100644 --- a/m4/math_h.m4 +++ b/m4/math_h.m4 @@ -1,5 +1,5 @@ -# math_h.m4 serial 113 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +# math_h.m4 serial 114 +dnl Copyright (C) 2007-2013 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. @@ -8,7 +8,6 @@ AC_DEFUN([gl_MATH_H], [ AC_REQUIRE([gl_MATH_H_DEFAULTS]) gl_CHECK_NEXT_HEADERS([math.h]) - AC_REQUIRE([AC_C_INLINE]) AC_CACHE_CHECK([whether NAN macro works], [gl_cv_header_math_nan_works], [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[@%:@include <math.h>]], diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4 index 7147f7e71..67b601fe4 100644 --- a/m4/mathfunc.m4 +++ b/m4/mathfunc.m4 @@ -1,5 +1,5 @@ # mathfunc.m4 serial 11 -dnl Copyright (C) 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2013 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. diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index 8f829c8ea..4c9f38861 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,5 +1,5 @@ # mbrtowc.m4 serial 25 -dnl Copyright (C) 2001-2002, 2004-2005, 2008-2012 Free Software Foundation, +dnl Copyright (C) 2001-2002, 2004-2005, 2008-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4 index da56c3d11..2e6d0921a 100644 --- a/m4/mbsinit.m4 +++ b/m4/mbsinit.m4 @@ -1,5 +1,5 @@ # mbsinit.m4 serial 8 -dnl Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2013 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. diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4 index 61a8190ce..ed0011798 100644 --- a/m4/mbstate_t.m4 +++ b/m4/mbstate_t.m4 @@ -1,5 +1,5 @@ # mbstate_t.m4 serial 13 -dnl Copyright (C) 2000-2002, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2008-2013 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. diff --git a/m4/mbtowc.m4 b/m4/mbtowc.m4 index fec0d2582..e47946196 100644 --- a/m4/mbtowc.m4 +++ b/m4/mbtowc.m4 @@ -1,5 +1,5 @@ # mbtowc.m4 serial 2 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2013 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. diff --git a/m4/memchr.m4 b/m4/memchr.m4 index 004029450..2d8abe75d 100644 --- a/m4/memchr.m4 +++ b/m4/memchr.m4 @@ -1,5 +1,5 @@ # memchr.m4 serial 12 -dnl Copyright (C) 2002-2004, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2009-2013 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. diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 index 748b17d97..9b60ddfa4 100644 --- a/m4/mmap-anon.m4 +++ b/m4/mmap-anon.m4 @@ -1,5 +1,5 @@ # mmap-anon.m4 serial 10 -dnl Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2013 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. diff --git a/m4/mode_t.m4 b/m4/mode_t.m4 index 40f612a61..d5b66d45b 100644 --- a/m4/mode_t.m4 +++ b/m4/mode_t.m4 @@ -1,5 +1,5 @@ # mode_t.m4 serial 2 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/msvc-inval.m4 b/m4/msvc-inval.m4 index 8db461759..9a6a47a74 100644 --- a/m4/msvc-inval.m4 +++ b/m4/msvc-inval.m4 @@ -1,5 +1,5 @@ # msvc-inval.m4 serial 1 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2013 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. diff --git a/m4/msvc-nothrow.m4 b/m4/msvc-nothrow.m4 index 012505070..a39618a41 100644 --- a/m4/msvc-nothrow.m4 +++ b/m4/msvc-nothrow.m4 @@ -1,5 +1,5 @@ # msvc-nothrow.m4 serial 1 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2013 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. diff --git a/m4/multiarch.m4 b/m4/multiarch.m4 index 0c288b8d2..552ec7e71 100644 --- a/m4/multiarch.m4 +++ b/m4/multiarch.m4 @@ -1,5 +1,5 @@ # multiarch.m4 serial 7 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/netdb_h.m4 b/m4/netdb_h.m4 index e0f3ee865..2c69f999f 100644 --- a/m4/netdb_h.m4 +++ b/m4/netdb_h.m4 @@ -1,5 +1,5 @@ # netdb_h.m4 serial 11 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/netinet_in_h.m4 b/m4/netinet_in_h.m4 index e1813886a..21971b29e 100644 --- a/m4/netinet_in_h.m4 +++ b/m4/netinet_in_h.m4 @@ -1,5 +1,5 @@ # netinet_in_h.m4 serial 5 -dnl Copyright (C) 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2013 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. diff --git a/m4/nl_langinfo.m4 b/m4/nl_langinfo.m4 index 80fe60d57..25e210155 100644 --- a/m4/nl_langinfo.m4 +++ b/m4/nl_langinfo.m4 @@ -1,5 +1,5 @@ # nl_langinfo.m4 serial 5 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/nocrash.m4 b/m4/nocrash.m4 index c2638df62..105b884f1 100644 --- a/m4/nocrash.m4 +++ b/m4/nocrash.m4 @@ -1,5 +1,5 @@ # nocrash.m4 serial 4 -dnl Copyright (C) 2005, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2009-2013 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. diff --git a/m4/nproc.m4 b/m4/nproc.m4 index a94b97f3c..0261938de 100644 --- a/m4/nproc.m4 +++ b/m4/nproc.m4 @@ -1,5 +1,5 @@ # nproc.m4 serial 4 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/off_t.m4 b/m4/off_t.m4 index dfca2dfd2..d355d0131 100644 --- a/m4/off_t.m4 +++ b/m4/off_t.m4 @@ -1,5 +1,5 @@ # off_t.m4 serial 1 -dnl Copyright (C) 2012 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2013 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. diff --git a/m4/open.m4 b/m4/open.m4 index c85971dc1..a6cb1019a 100644 --- a/m4/open.m4 +++ b/m4/open.m4 @@ -1,5 +1,5 @@ -# open.m4 serial 13 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +# open.m4 serial 14 +dnl Copyright (C) 2007-2013 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. @@ -86,7 +86,6 @@ changequote([,])dnl # Prerequisites of lib/open.c. AC_DEFUN([gl_PREREQ_OPEN], [ - AC_REQUIRE([AC_C_INLINE]) AC_REQUIRE([gl_PROMOTED_TYPE_MODE_T]) : ]) diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index 011786129..e11bf57a0 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,5 +1,5 @@ # pathmax.m4 serial 10 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/pipe2.m4 b/m4/pipe2.m4 index 00ad82b31..6ccee1052 100644 --- a/m4/pipe2.m4 +++ b/m4/pipe2.m4 @@ -1,5 +1,5 @@ # pipe2.m4 serial 2 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/printf.m4 b/m4/printf.m4 index 751e8966f..ef44f7851 100644 --- a/m4/printf.m4 +++ b/m4/printf.m4 @@ -1,5 +1,5 @@ # printf.m4 serial 50 -dnl Copyright (C) 2003, 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007-2013 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. diff --git a/m4/putenv.m4 b/m4/putenv.m4 index b971b1204..03ed4f97d 100644 --- a/m4/putenv.m4 +++ b/m4/putenv.m4 @@ -1,5 +1,5 @@ # putenv.m4 serial 19 -dnl Copyright (C) 2002-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2013 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. @@ -48,3 +48,9 @@ AC_DEFUN([gl_FUNC_PUTENV], ;; esac ]) + +# Prerequisites of lib/putenv.c. +AC_DEFUN([gl_PREREQ_PUTENV], +[ + AC_CHECK_FUNCS([_putenv]) +]) diff --git a/m4/raise.m4 b/m4/raise.m4 index 18eb8b914..7df3317df 100644 --- a/m4/raise.m4 +++ b/m4/raise.m4 @@ -1,5 +1,5 @@ -# raise.m4 serial 2 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +# raise.m4 serial 3 +dnl Copyright (C) 2011-2013 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. @@ -31,6 +31,4 @@ AC_DEFUN([gl_FUNC_RAISE], ]) # Prerequisites of lib/raise.c. -AC_DEFUN([gl_PREREQ_RAISE], [ - AC_REQUIRE([AC_C_INLINE]) -]) +AC_DEFUN([gl_PREREQ_RAISE], [:]) diff --git a/m4/read.m4 b/m4/read.m4 index 69aeb0963..81f0f3a9d 100644 --- a/m4/read.m4 +++ b/m4/read.m4 @@ -1,5 +1,5 @@ -# read.m4 serial 3 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +# read.m4 serial 4 +dnl Copyright (C) 2011-2013 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. @@ -23,7 +23,4 @@ AC_DEFUN([gl_FUNC_READ], ]) # Prerequisites of lib/read.c. -AC_DEFUN([gl_PREREQ_READ], -[ - AC_REQUIRE([AC_C_INLINE]) -]) +AC_DEFUN([gl_PREREQ_READ], [:]) diff --git a/m4/readlink.m4 b/m4/readlink.m4 index ccf5141d4..96e50425a 100644 --- a/m4/readlink.m4 +++ b/m4/readlink.m4 @@ -1,5 +1,5 @@ # readlink.m4 serial 12 -dnl Copyright (C) 2003, 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007, 2009-2013 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. diff --git a/m4/regex.m4 b/m4/regex.m4 index 41be5e8d3..ae89e3113 100644 --- a/m4/regex.m4 +++ b/m4/regex.m4 @@ -1,6 +1,6 @@ -# serial 61 +# serial 63 -# Copyright (C) 1996-2001, 2003-2012 Free Software Foundation, Inc. +# Copyright (C) 1996-2001, 2003-2013 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -27,15 +27,21 @@ AC_DEFUN([gl_REGEX], # following run test, then default to *not* using the included regex.c. # If cross compiling, assume the test would fail and use the included # regex.c. + AC_CHECK_FUNCS_ONCE([alarm]) AC_CACHE_CHECK([for working re_compile_pattern], [gl_cv_func_re_compile_pattern_working], [AC_RUN_IFELSE( [AC_LANG_PROGRAM( - [AC_INCLUDES_DEFAULT[ - #include <locale.h> - #include <limits.h> - #include <regex.h> - ]], + [[#include <regex.h> + + #include <locale.h> + #include <limits.h> + #include <string.h> + #if HAVE_ALARM + # include <unistd.h> + # include <signal.h> + #endif + ]], [[int result = 0; static struct re_pattern_buffer regex; unsigned char folded_chars[UCHAR_MAX + 1]; @@ -43,26 +49,54 @@ AC_DEFUN([gl_REGEX], const char *s; struct re_registers regs; - /* http://sourceware.org/ml/libc-hacker/2006-09/msg00008.html - This test needs valgrind to catch the bug on Debian - GNU/Linux 3.1 x86, but it might catch the bug better - on other platforms and it shouldn't hurt to try the - test here. */ +#if HAVE_ALARM + /* Some builds of glibc go into an infinite loop on this test. */ + signal (SIGALRM, SIG_DFL); + alarm (2); +#endif if (setlocale (LC_ALL, "en_US.UTF-8")) { - static char const pat[] = "insert into"; - static char const data[] = - "\xFF\0\x12\xA2\xAA\xC4\xB1,K\x12\xC4\xB1*\xACK"; - re_set_syntax (RE_SYNTAX_GREP | RE_HAT_LISTS_NOT_NEWLINE - | RE_ICASE); - memset (®ex, 0, sizeof regex); - s = re_compile_pattern (pat, sizeof pat - 1, ®ex); - if (s) - result |= 1; - else if (re_search (®ex, data, sizeof data - 1, - 0, sizeof data - 1, ®s) - != -1) - result |= 1; + { + /* http://sourceware.org/ml/libc-hacker/2006-09/msg00008.html + This test needs valgrind to catch the bug on Debian + GNU/Linux 3.1 x86, but it might catch the bug better + on other platforms and it shouldn't hurt to try the + test here. */ + static char const pat[] = "insert into"; + static char const data[] = + "\xFF\0\x12\xA2\xAA\xC4\xB1,K\x12\xC4\xB1*\xACK"; + re_set_syntax (RE_SYNTAX_GREP | RE_HAT_LISTS_NOT_NEWLINE + | RE_ICASE); + memset (®ex, 0, sizeof regex); + s = re_compile_pattern (pat, sizeof pat - 1, ®ex); + if (s) + result |= 1; + else if (re_search (®ex, data, sizeof data - 1, + 0, sizeof data - 1, ®s) + != -1) + result |= 1; + } + + { + /* This test is from glibc bug 15078. + The test case is from Andreas Schwab in + <http://www.sourceware.org/ml/libc-alpha/2013-01/msg00967.html>. + */ + static char const pat[] = "[^x]x"; + static char const data[] = + "\xe1\x80\x80\xe1\x80\xbb\xe1\x80\xbd\xe1\x80\x94\xe1\x80" + "\xba\xe1\x80\xaf\xe1\x80\x95\xe1\x80\xbax"; + re_set_syntax (0); + memset (®ex, 0, sizeof regex); + s = re_compile_pattern (pat, sizeof pat - 1, ®ex); + if (s) + result |= 1; + else if (re_search (®ex, data, sizeof data - 1, + 0, sizeof data - 1, 0) + != 21) + result |= 1; + } + if (! setlocale (LC_ALL, "C")) return 1; } @@ -220,6 +254,7 @@ AC_DEFUN([gl_PREREQ_REGEX], AC_REQUIRE([AC_C_INLINE]) AC_REQUIRE([AC_C_RESTRICT]) AC_REQUIRE([AC_TYPE_MBSTATE_T]) + AC_REQUIRE([gl_EEMALLOC]) AC_CHECK_HEADERS([libintl.h]) AC_CHECK_FUNCS_ONCE([isblank iswctype wcscoll]) AC_CHECK_DECLS([isblank], [], [], [[#include <ctype.h>]]) diff --git a/m4/rename.m4 b/m4/rename.m4 index 378b5ecfc..66430aa87 100644 --- a/m4/rename.m4 +++ b/m4/rename.m4 @@ -1,6 +1,6 @@ # serial 26 -# Copyright (C) 2001, 2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2005-2006, 2009-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/rmdir.m4 b/m4/rmdir.m4 index 34ca87639..f6a02dd24 100644 --- a/m4/rmdir.m4 +++ b/m4/rmdir.m4 @@ -1,5 +1,5 @@ # rmdir.m4 serial 13 -dnl Copyright (C) 2002, 2005, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005, 2009-2013 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. diff --git a/m4/round.m4 b/m4/round.m4 index 514c4f73e..aab67acd2 100644 --- a/m4/round.m4 +++ b/m4/round.m4 @@ -1,5 +1,5 @@ # round.m4 serial 16 -dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2013 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. diff --git a/m4/safe-read.m4 b/m4/safe-read.m4 index c82acdb94..be5207a5c 100644 --- a/m4/safe-read.m4 +++ b/m4/safe-read.m4 @@ -1,5 +1,5 @@ # safe-read.m4 serial 6 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2013 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/safe-write.m4 b/m4/safe-write.m4 index c1eff6e2c..bc2a33f87 100644 --- a/m4/safe-write.m4 +++ b/m4/safe-write.m4 @@ -1,5 +1,5 @@ # safe-write.m4 serial 4 -dnl Copyright (C) 2002, 2005-2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2013 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. diff --git a/m4/servent.m4 b/m4/servent.m4 index 21da957f3..01c037a87 100644 --- a/m4/servent.m4 +++ b/m4/servent.m4 @@ -1,5 +1,5 @@ # servent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2013 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. diff --git a/m4/setenv.m4 b/m4/setenv.m4 index e1931e7eb..cb5351a07 100644 --- a/m4/setenv.m4 +++ b/m4/setenv.m4 @@ -1,5 +1,5 @@ # setenv.m4 serial 26 -dnl Copyright (C) 2001-2004, 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2013 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. diff --git a/m4/signal_h.m4 b/m4/signal_h.m4 index ed4d7306e..3de9f27ad 100644 --- a/m4/signal_h.m4 +++ b/m4/signal_h.m4 @@ -1,5 +1,5 @@ # signal_h.m4 serial 18 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/size_max.m4 b/m4/size_max.m4 index 5a8162bc1..4b247abc0 100644 --- a/m4/size_max.m4 +++ b/m4/size_max.m4 @@ -1,5 +1,5 @@ # size_max.m4 serial 10 -dnl Copyright (C) 2003, 2005-2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2006, 2008-2013 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. diff --git a/m4/snprintf.m4 b/m4/snprintf.m4 index de94eddfd..3698e8440 100644 --- a/m4/snprintf.m4 +++ b/m4/snprintf.m4 @@ -1,5 +1,5 @@ # snprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2013 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. diff --git a/m4/socketlib.m4 b/m4/socketlib.m4 index 92a1af224..b08a72f63 100644 --- a/m4/socketlib.m4 +++ b/m4/socketlib.m4 @@ -1,5 +1,5 @@ # socketlib.m4 serial 1 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/sockets.m4 b/m4/sockets.m4 index e3738d906..b407391cd 100644 --- a/m4/sockets.m4 +++ b/m4/sockets.m4 @@ -1,5 +1,5 @@ # sockets.m4 serial 7 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/socklen.m4 b/m4/socklen.m4 index a4ab43b33..e3efd6ef7 100644 --- a/m4/socklen.m4 +++ b/m4/socklen.m4 @@ -1,5 +1,5 @@ # socklen.m4 serial 10 -dnl Copyright (C) 2005-2007, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2007, 2009-2013 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. diff --git a/m4/sockpfaf.m4 b/m4/sockpfaf.m4 index 5f97c3e3d..89557b18d 100644 --- a/m4/sockpfaf.m4 +++ b/m4/sockpfaf.m4 @@ -1,5 +1,5 @@ # sockpfaf.m4 serial 8 -dnl Copyright (C) 2004, 2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2009-2013 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. diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index 209d64c82..633813434 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,5 +1,5 @@ # ssize_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2001-2003, 2006, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2013 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. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index 9371d7bb9..d777f742a 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,6 +1,6 @@ # Checks for stat-related time functions. -# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2012 Free Software +# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2013 Free Software # Foundation, Inc. # This file is free software; the Free Software Foundation diff --git a/m4/stat.m4 b/m4/stat.m4 index a8b79f5bc..2456297ac 100644 --- a/m4/stat.m4 +++ b/m4/stat.m4 @@ -1,6 +1,6 @@ -# serial 10 +# serial 11 -# Copyright (C) 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2009-2013 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -68,8 +68,4 @@ AC_DEFUN([gl_FUNC_STAT], ]) # Prerequisites of lib/stat.c. -AC_DEFUN([gl_PREREQ_STAT], -[ - AC_REQUIRE([AC_C_INLINE]) - : -]) +AC_DEFUN([gl_PREREQ_STAT], [:]) diff --git a/m4/stdalign.m4 b/m4/stdalign.m4 index 6659c9c3e..3d7993dbe 100644 --- a/m4/stdalign.m4 +++ b/m4/stdalign.m4 @@ -1,6 +1,6 @@ # Check for stdalign.h that conforms to C11. -dnl Copyright 2011-2012 Free Software Foundation, Inc. +dnl Copyright 2011-2013 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. diff --git a/m4/stdbool.m4 b/m4/stdbool.m4 index eabfa6457..80d5559ab 100644 --- a/m4/stdbool.m4 +++ b/m4/stdbool.m4 @@ -1,6 +1,6 @@ # Check for stdbool.h that conforms to C99. -dnl Copyright (C) 2002-2006, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2013 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. diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index cc1160960..5da8ab1ec 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,6 +1,6 @@ dnl A placeholder for POSIX 2008 <stddef.h>, for platforms that have issues. # stddef_h.m4 serial 4 -dnl Copyright (C) 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2013 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. diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 28d342ea2..27cdcdb9a 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,5 +1,5 @@ # stdint.m4 serial 43 -dnl Copyright (C) 2001-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2013 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. diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4 index 581de9604..511ab4e9c 100644 --- a/m4/stdint_h.m4 +++ b/m4/stdint_h.m4 @@ -1,5 +1,5 @@ # stdint_h.m4 serial 9 -dnl Copyright (C) 1997-2004, 2006, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2013 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. diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 index 5298dd6d9..ebade067d 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,5 +1,5 @@ -# stdio_h.m4 serial 42 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +# stdio_h.m4 serial 43 +dnl Copyright (C) 2007-2013 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. @@ -7,7 +7,6 @@ dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_STDIO_H], [ AC_REQUIRE([gl_STDIO_H_DEFAULTS]) - AC_REQUIRE([AC_C_INLINE]) gl_NEXT_HEADERS([stdio.h]) dnl No need to create extra modules for these functions. Everyone who uses diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index 9c69f2e4d..2027ab3c1 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,5 +1,5 @@ -# stdlib_h.m4 serial 41 -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +# stdlib_h.m4 serial 42 +dnl Copyright (C) 2007-2013 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. @@ -22,7 +22,7 @@ AC_DEFUN([gl_STDLIB_H], ]], [_Exit atoll canonicalize_file_name getloadavg getsubopt grantpt initstate initstate_r mkdtemp mkostemp mkostemps mkstemp mkstemps posix_openpt ptsname ptsname_r random random_r realpath rpmatch - setenv setstate setstate_r srandom srandom_r + secure_getenv setenv setstate setstate_r srandom srandom_r strtod strtoll strtoull unlockpt unsetenv]) ]) @@ -60,6 +60,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX]) GNULIB_REALPATH=0; AC_SUBST([GNULIB_REALPATH]) GNULIB_RPMATCH=0; AC_SUBST([GNULIB_RPMATCH]) + GNULIB_SECURE_GETENV=0; AC_SUBST([GNULIB_SECURE_GETENV]) GNULIB_SETENV=0; AC_SUBST([GNULIB_SETENV]) GNULIB_STRTOD=0; AC_SUBST([GNULIB_STRTOD]) GNULIB_STRTOLL=0; AC_SUBST([GNULIB_STRTOLL]) @@ -88,6 +89,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], HAVE_RANDOM_R=1; AC_SUBST([HAVE_RANDOM_R]) HAVE_REALPATH=1; AC_SUBST([HAVE_REALPATH]) HAVE_RPMATCH=1; AC_SUBST([HAVE_RPMATCH]) + HAVE_SECURE_GETENV=1; AC_SUBST([HAVE_SECURE_GETENV]) HAVE_SETENV=1; AC_SUBST([HAVE_SETENV]) HAVE_DECL_SETENV=1; AC_SUBST([HAVE_DECL_SETENV]) HAVE_STRTOD=1; AC_SUBST([HAVE_STRTOD]) diff --git a/m4/strftime.m4 b/m4/strftime.m4 index 42043019b..b31f4956f 100644 --- a/m4/strftime.m4 +++ b/m4/strftime.m4 @@ -1,6 +1,6 @@ # serial 33 -# Copyright (C) 1996-1997, 1999-2007, 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2007, 2009-2013 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 5677e092d..cc5fbbb32 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -1,6 +1,6 @@ # Configure a GNU-like replacement for <string.h>. -# Copyright (C) 2007-2012 Free Software Foundation, Inc. +# Copyright (C) 2007-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4 index 89272f1a8..0cec95828 100644 --- a/m4/sys_file_h.m4 +++ b/m4/sys_file_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for <sys/file.h>. # serial 6 -# Copyright (C) 2008-2012 Free Software Foundation, Inc. +# Copyright (C) 2008-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index 8d4e7e1eb..94863776d 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,5 +1,5 @@ -# sys_socket_h.m4 serial 22 -dnl Copyright (C) 2005-2012 Free Software Foundation, Inc. +# sys_socket_h.m4 serial 23 +dnl Copyright (C) 2005-2013 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. @@ -10,7 +10,6 @@ AC_DEFUN([gl_HEADER_SYS_SOCKET], [ AC_REQUIRE([gl_SYS_SOCKET_H_DEFAULTS]) AC_REQUIRE([AC_CANONICAL_HOST]) - AC_REQUIRE([AC_C_INLINE]) dnl On OSF/1, the functions recv(), send(), recvfrom(), sendto() have dnl old-style declarations (with return type 'int' instead of 'ssize_t') diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index f45dee1dc..6dd3d99b1 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,5 +1,5 @@ -# sys_stat_h.m4 serial 27 -*- Autoconf -*- -dnl Copyright (C) 2006-2012 Free Software Foundation, Inc. +# sys_stat_h.m4 serial 28 -*- Autoconf -*- +dnl Copyright (C) 2006-2013 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. @@ -11,9 +11,6 @@ AC_DEFUN([gl_HEADER_SYS_STAT_H], [ AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) - dnl For the mkdir substitute. - AC_REQUIRE([AC_C_INLINE]) - dnl Check for broken stat macros. AC_REQUIRE([AC_HEADER_STAT]) diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4 index c4a30cda7..0ac71ac5e 100644 --- a/m4/sys_time_h.m4 +++ b/m4/sys_time_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for <sys/time.h>. # serial 8 -# Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2007, 2009-2013 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4 index f11eef2fe..6132727f8 100644 --- a/m4/sys_types_h.m4 +++ b/m4/sys_types_h.m4 @@ -1,5 +1,5 @@ # sys_types_h.m4 serial 4 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2013 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. diff --git a/m4/sys_uio_h.m4 b/m4/sys_uio_h.m4 index ddf844b72..c75cbbd0b 100644 --- a/m4/sys_uio_h.m4 +++ b/m4/sys_uio_h.m4 @@ -1,5 +1,5 @@ # sys_uio_h.m4 serial 1 -dnl Copyright (C) 2011-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2013 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. diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 6415bfbcb..3b8390053 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,6 +1,6 @@ # Configure a more-standard replacement for <time.h>. -# Copyright (C) 2000-2001, 2003-2007, 2009-2012 Free Software Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2013 Free Software Foundation, Inc. # serial 7 diff --git a/m4/time_r.m4 b/m4/time_r.m4 index 9ddbd0199..c388a8312 100644 --- a/m4/time_r.m4 +++ b/m4/time_r.m4 @@ -1,6 +1,6 @@ dnl Reentrant time functions: localtime_r, gmtime_r. -dnl Copyright (C) 2003, 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2006-2013 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. diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4 index c12e6cefd..55e7ea325 100644 --- a/m4/tm_gmtoff.m4 +++ b/m4/tm_gmtoff.m4 @@ -1,5 +1,5 @@ # tm_gmtoff.m4 serial 3 -dnl Copyright (C) 2002, 2009-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2009-2013 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. diff --git a/m4/trunc.m4 b/m4/trunc.m4 index 278384d9b..079cbcb91 100644 --- a/m4/trunc.m4 +++ b/m4/trunc.m4 @@ -1,5 +1,5 @@ # trunc.m4 serial 9 -dnl Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2010-2013 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. diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index 7e7651b9d..32dcfa582 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,5 +1,5 @@ -# unistd_h.m4 serial 65 -dnl Copyright (C) 2006-2012 Free Software Foundation, Inc. +# unistd_h.m4 serial 66 +dnl Copyright (C) 2006-2013 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. @@ -11,7 +11,6 @@ AC_DEFUN([gl_UNISTD_H], dnl Use AC_REQUIRE here, so that the default behavior below is expanded dnl once only, before all statements that occur in other macros. AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) - AC_REQUIRE([AC_C_INLINE]) gl_CHECK_NEXT_HEADERS([unistd.h]) if test $ac_cv_header_unistd_h = yes; then diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4 index 0ce11da13..d730e435a 100644 --- a/m4/vasnprintf.m4 +++ b/m4/vasnprintf.m4 @@ -1,5 +1,5 @@ -# vasnprintf.m4 serial 35 -dnl Copyright (C) 2002-2004, 2006-2012 Free Software Foundation, Inc. +# vasnprintf.m4 serial 36 +dnl Copyright (C) 2002-2004, 2006-2013 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. @@ -55,7 +55,6 @@ AC_DEFUN([gl_PREREQ_PRINTF_PARSE], # Prerequisites of lib/vasnprintf.c. AC_DEFUN_ONCE([gl_PREREQ_VASNPRINTF], [ - AC_REQUIRE([AC_C_INLINE]) AC_REQUIRE([AC_FUNC_ALLOCA]) AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) AC_REQUIRE([gt_TYPE_WCHAR_T]) diff --git a/m4/visibility.m4 b/m4/visibility.m4 index a7d4d8c1d..6cbd7e5f2 100644 --- a/m4/visibility.m4 +++ b/m4/visibility.m4 @@ -1,5 +1,5 @@ # visibility.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2005, 2008, 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2008, 2010-2013 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. diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4 index 22ec57be5..4900764ee 100644 --- a/m4/vsnprintf.m4 +++ b/m4/vsnprintf.m4 @@ -1,5 +1,5 @@ # vsnprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2013 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. diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4 index a77802eb9..e43beebd9 100644 --- a/m4/warn-on-use.m4 +++ b/m4/warn-on-use.m4 @@ -1,5 +1,5 @@ # warn-on-use.m4 serial 5 -dnl Copyright (C) 2010-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2013 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. diff --git a/m4/warnings.m4 b/m4/warnings.m4 index 28b8294ef..4b2ac3850 100644 --- a/m4/warnings.m4 +++ b/m4/warnings.m4 @@ -1,5 +1,5 @@ # warnings.m4 serial 7 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/wchar_h.m4 b/m4/wchar_h.m4 index c7a8b2d78..bedb15a44 100644 --- a/m4/wchar_h.m4 +++ b/m4/wchar_h.m4 @@ -1,6 +1,6 @@ dnl A placeholder for ISO C99 <wchar.h>, for platforms that have issues. -dnl Copyright (C) 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2013 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. diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4 index 534735d8c..e1e1e699d 100644 --- a/m4/wchar_t.m4 +++ b/m4/wchar_t.m4 @@ -1,5 +1,5 @@ # wchar_t.m4 serial 4 (gettext-0.18.2) -dnl Copyright (C) 2002-2003, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2003, 2008-2013 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. diff --git a/m4/wcrtomb.m4 b/m4/wcrtomb.m4 index 00d7302e8..f56b5bae9 100644 --- a/m4/wcrtomb.m4 +++ b/m4/wcrtomb.m4 @@ -1,5 +1,5 @@ # wcrtomb.m4 serial 11 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2013 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. diff --git a/m4/wctype_h.m4 b/m4/wctype_h.m4 index 4b19f643d..82ada0eee 100644 --- a/m4/wctype_h.m4 +++ b/m4/wctype_h.m4 @@ -1,8 +1,8 @@ -# wctype_h.m4 serial 17 +# wctype_h.m4 serial 18 dnl A placeholder for ISO C99 <wctype.h>, for platforms that lack it. -dnl Copyright (C) 2006-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2013 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. @@ -22,8 +22,6 @@ AC_DEFUN([gl_WCTYPE_H], fi AC_SUBST([HAVE_ISWCNTRL]) - AC_REQUIRE([AC_C_INLINE]) - AC_REQUIRE([gt_TYPE_WINT_T]) if test $gt_cv_c_wint_t = yes; then HAVE_WINT_T=1 diff --git a/m4/wint_t.m4 b/m4/wint_t.m4 index 3260cce32..d7cd3db93 100644 --- a/m4/wint_t.m4 +++ b/m4/wint_t.m4 @@ -1,5 +1,5 @@ # wint_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2003, 2007-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007-2013 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. diff --git a/m4/write.m4 b/m4/write.m4 index a6b122982..a79b2cc92 100644 --- a/m4/write.m4 +++ b/m4/write.m4 @@ -1,5 +1,5 @@ -# write.m4 serial 4 -dnl Copyright (C) 2008-2012 Free Software Foundation, Inc. +# write.m4 serial 5 +dnl Copyright (C) 2008-2013 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. @@ -29,7 +29,4 @@ AC_DEFUN([gl_FUNC_WRITE], ]) # Prerequisites of lib/write.c. -AC_DEFUN([gl_PREREQ_WRITE], -[ - AC_REQUIRE([AC_C_INLINE]) -]) +AC_DEFUN([gl_PREREQ_WRITE], [:]) diff --git a/m4/xsize.m4 b/m4/xsize.m4 index d85a5f10f..8ea9f2cd3 100644 --- a/m4/xsize.m4 +++ b/m4/xsize.m4 @@ -1,5 +1,5 @@ # xsize.m4 serial 5 -dnl Copyright (C) 2003-2004, 2008-2012 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2004, 2008-2013 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. diff --git a/maint.mk b/maint.mk index ea44eceb1..2b454a15c 100644 --- a/maint.mk +++ b/maint.mk @@ -2,7 +2,7 @@ # This Makefile fragment tries to be general-purpose enough to be # used by many projects via the gnulib maintainer-makefile module. -## Copyright (C) 2001-2012 Free Software Foundation, Inc. +## Copyright (C) 2001-2013 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 @@ -155,7 +155,7 @@ export LC_ALL = C ## Sanity checks. ## ## --------------- ## -_cfg_mk := $(shell test -f $(srcdir)/cfg.mk && echo '$(srcdir)/cfg.mk') +_cfg_mk := $(wildcard $(srcdir)/cfg.mk) # Collect the names of rules starting with 'sc_'. syntax-check-rules := $(sort $(shell sed -n 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' \ @@ -1315,7 +1315,7 @@ announcement_mail_Cc_ ?= $(announcement_mail_Cc_$(release-type)) announcement_mail_headers_ ?= $(announcement_mail_headers_$(release-type)) announcement: NEWS ChangeLog $(rel-files) # Not $(AM_V_GEN) since the output of this command serves as -# annoucement message: it would start with " GEN announcement". +# announcement message: it would start with " GEN announcement". $(AM_V_at)$(srcdir)/$(_build-aux)/announce-gen \ --mail-headers='$(announcement_mail_headers_)' \ --release-type=$(release-type) \ @@ -1370,7 +1370,8 @@ endef .PHONY: no-submodule-changes no-submodule-changes: - $(AM_V_GEN)if test -d $(srcdir)/.git; then \ + $(AM_V_GEN)if test -d $(srcdir)/.git \ + && git --version >/dev/null 2>&1; then \ diff=$$(cd $(srcdir) && git submodule -q foreach \ git diff-index --name-only HEAD) \ || exit 1; \ @@ -1388,10 +1389,12 @@ submodule-checks ?= no-submodule-changes public-submodule-commit # cannot be built from a fresh clone. .PHONY: public-submodule-commit public-submodule-commit: - $(AM_V_GEN)if test -d $(srcdir)/.git; then \ + $(AM_V_GEN)if test -d $(srcdir)/.git \ + && git --version >/dev/null 2>&1; then \ cd $(srcdir) && \ - git submodule --quiet foreach test '$$(git rev-parse $$sha1)' \ - = '$$(git merge-base origin $$sha1)' \ + git submodule --quiet foreach \ + test '"$$(git rev-parse "$$sha1")"' \ + = '"$$(git merge-base origin "$$sha1")"' \ || { echo '$(ME): found non-public submodule commit' >&2; \ exit 1; }; \ else \ From 3dac6181c18508a194f240d633c8c3f7304adb3f Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Mon, 18 Feb 2013 18:53:46 +0100 Subject: [PATCH 002/147] Add gnulib `select' module. Should fix fport_input_waiting when neither poll nor select nor FIONREAD are available, which is the case on MinGW. Thanks to Eli Zaretskii for the report. --- lib/Makefile.am | 66 +++++- lib/alloca.c | 478 ++++++++++++++++++++++++++++++++++++++ lib/dup2.c | 160 +++++++++++++ lib/select.c | 547 ++++++++++++++++++++++++++++++++++++++++++++ lib/sys_select.in.h | 309 +++++++++++++++++++++++++ m4/dup2.m4 | 84 +++++++ m4/gnulib-cache.m4 | 3 +- m4/gnulib-comp.m4 | 28 +++ m4/select.m4 | 113 +++++++++ m4/sys_select_h.m4 | 95 ++++++++ 10 files changed, 1881 insertions(+), 2 deletions(-) create mode 100644 lib/alloca.c create mode 100644 lib/dup2.c create mode 100644 lib/select.c create mode 100644 lib/sys_select.in.h create mode 100644 m4/dup2.m4 create mode 100644 m4/select.m4 create mode 100644 m4/sys_select_h.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 1714cbb8c..c99a7550b 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -62,6 +62,7 @@ libgnu_la_LDFLAGS += $(ISNANL_LIBM) libgnu_la_LDFLAGS += $(LDEXP_LIBM) libgnu_la_LDFLAGS += $(LIBSOCKET) libgnu_la_LDFLAGS += $(LIB_CLOCK_GETTIME) +libgnu_la_LDFLAGS += $(LIB_SELECT) libgnu_la_LDFLAGS += $(LOG1P_LIBM) libgnu_la_LDFLAGS += $(LOG_LIBM) libgnu_la_LDFLAGS += $(LTLIBICONV) @@ -87,6 +88,17 @@ EXTRA_DIST += alignof.h ## end gnulib module alignof +## begin gnulib module alloca + + +libgnu_la_LIBADD += @LTALLOCA@ +libgnu_la_DEPENDENCIES += @LTALLOCA@ +EXTRA_DIST += alloca.c + +EXTRA_libgnu_la_SOURCES += alloca.c + +## end gnulib module alloca + ## begin gnulib module alloca-opt BUILT_SOURCES += $(ALLOCA_H) @@ -371,6 +383,15 @@ EXTRA_DIST += dosname.h ## end gnulib module dosname +## begin gnulib module dup2 + + +EXTRA_DIST += dup2.c + +EXTRA_libgnu_la_SOURCES += dup2.c + +## end gnulib module dup2 + ## begin gnulib module duplocale @@ -1560,6 +1581,15 @@ EXTRA_DIST += same-inode.h ## end gnulib module same-inode +## begin gnulib module select + + +EXTRA_DIST += select.c + +EXTRA_libgnu_la_SOURCES += select.c + +## end gnulib module select + ## begin gnulib module send @@ -2314,6 +2344,40 @@ EXTRA_DIST += sys_file.in.h ## end gnulib module sys_file +## begin gnulib module sys_select + +BUILT_SOURCES += sys/select.h + +# We need the following in order to create <sys/select.h> when the system +# doesn't have one that works with the given compiler. +sys/select.h: sys_select.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H) + $(AM_V_at)$(MKDIR_P) sys + $(AM_V_GEN)rm -f $@-t $@ && \ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + sed -e 's|@''GUARD_PREFIX''@|GL|g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ + -e 's|@''NEXT_SYS_SELECT_H''@|$(NEXT_SYS_SELECT_H)|g' \ + -e 's|@''HAVE_SYS_SELECT_H''@|$(HAVE_SYS_SELECT_H)|g' \ + -e 's/@''GNULIB_PSELECT''@/$(GNULIB_PSELECT)/g' \ + -e 's/@''GNULIB_SELECT''@/$(GNULIB_SELECT)/g' \ + -e 's|@''HAVE_WINSOCK2_H''@|$(HAVE_WINSOCK2_H)|g' \ + -e 's|@''HAVE_PSELECT''@|$(HAVE_PSELECT)|g' \ + -e 's|@''REPLACE_PSELECT''@|$(REPLACE_PSELECT)|g' \ + -e 's|@''REPLACE_SELECT''@|$(REPLACE_SELECT)|g' \ + -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ + -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ + < $(srcdir)/sys_select.in.h; \ + } > $@-t && \ + mv $@-t $@ +MOSTLYCLEANFILES += sys/select.h sys/select.h-t +MOSTLYCLEANDIRS += sys + +EXTRA_DIST += sys_select.in.h + +## end gnulib module sys_select + ## begin gnulib module sys_socket BUILT_SOURCES += sys/socket.h diff --git a/lib/alloca.c b/lib/alloca.c new file mode 100644 index 000000000..ee0f01886 --- /dev/null +++ b/lib/alloca.c @@ -0,0 +1,478 @@ +/* alloca.c -- allocate automatically reclaimed memory + (Mostly) portable public-domain implementation -- D A Gwyn + + This implementation of the PWB library alloca function, + which is used to allocate space off the run-time stack so + that it is automatically reclaimed upon procedure exit, + was inspired by discussions with J. Q. Johnson of Cornell. + J.Otto Tennant <jot@cray.com> contributed the Cray support. + + There are some preprocessor constants that can + be defined when compiling for your specific system, for + improved efficiency; however, the defaults should be okay. + + The general concept of this implementation is to keep + track of all alloca-allocated blocks, and reclaim any + that are found to be deeper in the stack than the current + invocation. This heuristic does not reclaim storage as + soon as it becomes invalid, but it will do so eventually. + + As a special case, alloca(0) reclaims storage without + allocating any. It is a good idea to use alloca(0) in + your main control loop, etc. to force garbage collection. */ + +#include <config.h> + +#include <alloca.h> + +#include <string.h> +#include <stdlib.h> + +#ifdef emacs +# include "lisp.h" +# include "blockinput.h" +# ifdef EMACS_FREE +# undef free +# define free EMACS_FREE +# endif +#else +# define memory_full() abort () +#endif + +/* If compiling with GCC 2, this file's not needed. */ +#if !defined (__GNUC__) || __GNUC__ < 2 + +/* If someone has defined alloca as a macro, + there must be some other way alloca is supposed to work. */ +# ifndef alloca + +# ifdef emacs +# ifdef static +/* actually, only want this if static is defined as "" + -- this is for usg, in which emacs must undefine static + in order to make unexec workable + */ +# ifndef STACK_DIRECTION +you +lose +-- must know STACK_DIRECTION at compile-time +/* Using #error here is not wise since this file should work for + old and obscure compilers. */ +# endif /* STACK_DIRECTION undefined */ +# endif /* static */ +# endif /* emacs */ + +/* If your stack is a linked list of frames, you have to + provide an "address metric" ADDRESS_FUNCTION macro. */ + +# if defined (CRAY) && defined (CRAY_STACKSEG_END) +long i00afunc (); +# define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg)) +# else +# define ADDRESS_FUNCTION(arg) &(arg) +# endif + +/* Define STACK_DIRECTION if you know the direction of stack + growth for your system; otherwise it will be automatically + deduced at run-time. + + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown */ + +# ifndef STACK_DIRECTION +# define STACK_DIRECTION 0 /* Direction unknown. */ +# endif + +# if STACK_DIRECTION != 0 + +# define STACK_DIR STACK_DIRECTION /* Known at compile-time. */ + +# else /* STACK_DIRECTION == 0; need run-time code. */ + +static int stack_dir; /* 1 or -1 once known. */ +# define STACK_DIR stack_dir + +static int +find_stack_direction (int *addr, int depth) +{ + int dir, dummy = 0; + if (! addr) + addr = &dummy; + *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; + dir = depth ? find_stack_direction (addr, depth - 1) : 0; + return dir + dummy; +} + +# endif /* STACK_DIRECTION == 0 */ + +/* An "alloca header" is used to: + (a) chain together all alloca'ed blocks; + (b) keep track of stack depth. + + It is very important that sizeof(header) agree with malloc + alignment chunk size. The following default should work okay. */ + +# ifndef ALIGN_SIZE +# define ALIGN_SIZE sizeof(double) +# endif + +typedef union hdr +{ + char align[ALIGN_SIZE]; /* To force sizeof(header). */ + struct + { + union hdr *next; /* For chaining headers. */ + char *deep; /* For stack depth measure. */ + } h; +} header; + +static header *last_alloca_header = NULL; /* -> last alloca header. */ + +/* Return a pointer to at least SIZE bytes of storage, + which will be automatically reclaimed upon exit from + the procedure that called alloca. Originally, this space + was supposed to be taken from the current stack frame of the + caller, but that method cannot be made to work for some + implementations of C, for example under Gould's UTX/32. */ + +void * +alloca (size_t size) +{ + auto char probe; /* Probes stack depth: */ + register char *depth = ADDRESS_FUNCTION (probe); + +# if STACK_DIRECTION == 0 + if (STACK_DIR == 0) /* Unknown growth direction. */ + STACK_DIR = find_stack_direction (NULL, (size & 1) + 20); +# endif + + /* Reclaim garbage, defined as all alloca'd storage that + was allocated from deeper in the stack than currently. */ + + { + register header *hp; /* Traverses linked list. */ + +# ifdef emacs + BLOCK_INPUT; +# endif + + for (hp = last_alloca_header; hp != NULL;) + if ((STACK_DIR > 0 && hp->h.deep > depth) + || (STACK_DIR < 0 && hp->h.deep < depth)) + { + register header *np = hp->h.next; + + free (hp); /* Collect garbage. */ + + hp = np; /* -> next header. */ + } + else + break; /* Rest are not deeper. */ + + last_alloca_header = hp; /* -> last valid storage. */ + +# ifdef emacs + UNBLOCK_INPUT; +# endif + } + + if (size == 0) + return NULL; /* No allocation required. */ + + /* Allocate combined header + user data storage. */ + + { + /* Address of header. */ + register header *new; + + size_t combined_size = sizeof (header) + size; + if (combined_size < sizeof (header)) + memory_full (); + + new = malloc (combined_size); + + if (! new) + memory_full (); + + new->h.next = last_alloca_header; + new->h.deep = depth; + + last_alloca_header = new; + + /* User storage begins just after header. */ + + return (void *) (new + 1); + } +} + +# if defined (CRAY) && defined (CRAY_STACKSEG_END) + +# ifdef DEBUG_I00AFUNC +# include <stdio.h> +# endif + +# ifndef CRAY_STACK +# define CRAY_STACK +# ifndef CRAY2 +/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */ +struct stack_control_header + { + long shgrow:32; /* Number of times stack has grown. */ + long shaseg:32; /* Size of increments to stack. */ + long shhwm:32; /* High water mark of stack. */ + long shsize:32; /* Current size of stack (all segments). */ + }; + +/* The stack segment linkage control information occurs at + the high-address end of a stack segment. (The stack + grows from low addresses to high addresses.) The initial + part of the stack segment linkage control information is + 0200 (octal) words. This provides for register storage + for the routine which overflows the stack. */ + +struct stack_segment_linkage + { + long ss[0200]; /* 0200 overflow words. */ + long sssize:32; /* Number of words in this segment. */ + long ssbase:32; /* Offset to stack base. */ + long:32; + long sspseg:32; /* Offset to linkage control of previous + segment of stack. */ + long:32; + long sstcpt:32; /* Pointer to task common address block. */ + long sscsnm; /* Private control structure number for + microtasking. */ + long ssusr1; /* Reserved for user. */ + long ssusr2; /* Reserved for user. */ + long sstpid; /* Process ID for pid based multi-tasking. */ + long ssgvup; /* Pointer to multitasking thread giveup. */ + long sscray[7]; /* Reserved for Cray Research. */ + long ssa0; + long ssa1; + long ssa2; + long ssa3; + long ssa4; + long ssa5; + long ssa6; + long ssa7; + long sss0; + long sss1; + long sss2; + long sss3; + long sss4; + long sss5; + long sss6; + long sss7; + }; + +# else /* CRAY2 */ +/* The following structure defines the vector of words + returned by the STKSTAT library routine. */ +struct stk_stat + { + long now; /* Current total stack size. */ + long maxc; /* Amount of contiguous space which would + be required to satisfy the maximum + stack demand to date. */ + long high_water; /* Stack high-water mark. */ + long overflows; /* Number of stack overflow ($STKOFEN) calls. */ + long hits; /* Number of internal buffer hits. */ + long extends; /* Number of block extensions. */ + long stko_mallocs; /* Block allocations by $STKOFEN. */ + long underflows; /* Number of stack underflow calls ($STKRETN). */ + long stko_free; /* Number of deallocations by $STKRETN. */ + long stkm_free; /* Number of deallocations by $STKMRET. */ + long segments; /* Current number of stack segments. */ + long maxs; /* Maximum number of stack segments so far. */ + long pad_size; /* Stack pad size. */ + long current_address; /* Current stack segment address. */ + long current_size; /* Current stack segment size. This + number is actually corrupted by STKSTAT to + include the fifteen word trailer area. */ + long initial_address; /* Address of initial segment. */ + long initial_size; /* Size of initial segment. */ + }; + +/* The following structure describes the data structure which trails + any stack segment. I think that the description in 'asdef' is + out of date. I only describe the parts that I am sure about. */ + +struct stk_trailer + { + long this_address; /* Address of this block. */ + long this_size; /* Size of this block (does not include + this trailer). */ + long unknown2; + long unknown3; + long link; /* Address of trailer block of previous + segment. */ + long unknown5; + long unknown6; + long unknown7; + long unknown8; + long unknown9; + long unknown10; + long unknown11; + long unknown12; + long unknown13; + long unknown14; + }; + +# endif /* CRAY2 */ +# endif /* not CRAY_STACK */ + +# ifdef CRAY2 +/* Determine a "stack measure" for an arbitrary ADDRESS. + I doubt that "lint" will like this much. */ + +static long +i00afunc (long *address) +{ + struct stk_stat status; + struct stk_trailer *trailer; + long *block, size; + long result = 0; + + /* We want to iterate through all of the segments. The first + step is to get the stack status structure. We could do this + more quickly and more directly, perhaps, by referencing the + $LM00 common block, but I know that this works. */ + + STKSTAT (&status); + + /* Set up the iteration. */ + + trailer = (struct stk_trailer *) (status.current_address + + status.current_size + - 15); + + /* There must be at least one stack segment. Therefore it is + a fatal error if "trailer" is null. */ + + if (trailer == 0) + abort (); + + /* Discard segments that do not contain our argument address. */ + + while (trailer != 0) + { + block = (long *) trailer->this_address; + size = trailer->this_size; + if (block == 0 || size == 0) + abort (); + trailer = (struct stk_trailer *) trailer->link; + if ((block <= address) && (address < (block + size))) + break; + } + + /* Set the result to the offset in this segment and add the sizes + of all predecessor segments. */ + + result = address - block; + + if (trailer == 0) + { + return result; + } + + do + { + if (trailer->this_size <= 0) + abort (); + result += trailer->this_size; + trailer = (struct stk_trailer *) trailer->link; + } + while (trailer != 0); + + /* We are done. Note that if you present a bogus address (one + not in any segment), you will get a different number back, formed + from subtracting the address of the first block. This is probably + not what you want. */ + + return (result); +} + +# else /* not CRAY2 */ +/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP. + Determine the number of the cell within the stack, + given the address of the cell. The purpose of this + routine is to linearize, in some sense, stack addresses + for alloca. */ + +static long +i00afunc (long address) +{ + long stkl = 0; + + long size, pseg, this_segment, stack; + long result = 0; + + struct stack_segment_linkage *ssptr; + + /* Register B67 contains the address of the end of the + current stack segment. If you (as a subprogram) store + your registers on the stack and find that you are past + the contents of B67, you have overflowed the segment. + + B67 also points to the stack segment linkage control + area, which is what we are really interested in. */ + + stkl = CRAY_STACKSEG_END (); + ssptr = (struct stack_segment_linkage *) stkl; + + /* If one subtracts 'size' from the end of the segment, + one has the address of the first word of the segment. + + If this is not the first segment, 'pseg' will be + nonzero. */ + + pseg = ssptr->sspseg; + size = ssptr->sssize; + + this_segment = stkl - size; + + /* It is possible that calling this routine itself caused + a stack overflow. Discard stack segments which do not + contain the target address. */ + + while (!(this_segment <= address && address <= stkl)) + { +# ifdef DEBUG_I00AFUNC + fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl); +# endif + if (pseg == 0) + break; + stkl = stkl - pseg; + ssptr = (struct stack_segment_linkage *) stkl; + size = ssptr->sssize; + pseg = ssptr->sspseg; + this_segment = stkl - size; + } + + result = address - this_segment; + + /* If you subtract pseg from the current end of the stack, + you get the address of the previous stack segment's end. + This seems a little convoluted to me, but I'll bet you save + a cycle somewhere. */ + + while (pseg != 0) + { +# ifdef DEBUG_I00AFUNC + fprintf (stderr, "%011o %011o\n", pseg, size); +# endif + stkl = stkl - pseg; + ssptr = (struct stack_segment_linkage *) stkl; + size = ssptr->sssize; + pseg = ssptr->sspseg; + result += size; + } + return (result); +} + +# endif /* not CRAY2 */ +# endif /* CRAY */ + +# endif /* no alloca */ +#endif /* not GCC 2 */ diff --git a/lib/dup2.c b/lib/dup2.c new file mode 100644 index 000000000..89b40c466 --- /dev/null +++ b/lib/dup2.c @@ -0,0 +1,160 @@ +/* Duplicate an open file descriptor to a specified file descriptor. + + Copyright (C) 1999, 2004-2007, 2009-2013 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. */ + +/* written by Paul Eggert */ + +#include <config.h> + +/* Specification. */ +#include <unistd.h> + +#include <errno.h> +#include <fcntl.h> + +#if HAVE_DUP2 + +# undef dup2 + +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +/* Get declarations of the native Windows API functions. */ +# define WIN32_LEAN_AND_MEAN +# include <windows.h> + +# include "msvc-inval.h" + +/* Get _get_osfhandle. */ +# include "msvc-nothrow.h" + +static int +ms_windows_dup2 (int fd, int desired_fd) +{ + int result; + + /* If fd is closed, mingw hangs on dup2 (fd, fd). If fd is open, + dup2 (fd, fd) returns 0, but all further attempts to use fd in + future dup2 calls will hang. */ + if (fd == desired_fd) + { + if ((HANDLE) _get_osfhandle (fd) == INVALID_HANDLE_VALUE) + { + errno = EBADF; + return -1; + } + return fd; + } + + /* Wine 1.0.1 return 0 when desired_fd is negative but not -1: + http://bugs.winehq.org/show_bug.cgi?id=21289 */ + if (desired_fd < 0) + { + errno = EBADF; + return -1; + } + + TRY_MSVC_INVAL + { + result = dup2 (fd, desired_fd); + } + CATCH_MSVC_INVAL + { + errno = EBADF; + result = -1; + } + DONE_MSVC_INVAL; + + if (result == 0) + result = desired_fd; + + return result; +} + +# define dup2 ms_windows_dup2 + +# endif + +int +rpl_dup2 (int fd, int desired_fd) +{ + int result; + +# ifdef F_GETFL + /* On Linux kernels 2.6.26-2.6.29, dup2 (fd, fd) returns -EBADF. + On Cygwin 1.5.x, dup2 (1, 1) returns 0. + On Cygwin 1.7.17, dup2 (1, -1) dumps core. + On Haiku, dup2 (fd, fd) mistakenly clears FD_CLOEXEC. */ + if (desired_fd < 0) + fd = desired_fd; + if (fd == desired_fd) + return fcntl (fd, F_GETFL) == -1 ? -1 : fd; +# endif + + result = dup2 (fd, desired_fd); + + /* Correct an errno value on FreeBSD 6.1 and Cygwin 1.5.x. */ + if (result == -1 && errno == EMFILE) + errno = EBADF; +# if REPLACE_FCHDIR + if (fd != desired_fd && result != -1) + result = _gl_register_dup (fd, result); +# endif + return result; +} + +#else /* !HAVE_DUP2 */ + +/* On older platforms, dup2 did not exist. */ + +# ifndef F_DUPFD +static int +dupfd (int fd, int desired_fd) +{ + int duplicated_fd = dup (fd); + if (duplicated_fd < 0 || duplicated_fd == desired_fd) + return duplicated_fd; + else + { + int r = dupfd (fd, desired_fd); + int e = errno; + close (duplicated_fd); + errno = e; + return r; + } +} +# endif + +int +dup2 (int fd, int desired_fd) +{ + int result = fcntl (fd, F_GETFL) < 0 ? -1 : fd; + if (result == -1 || fd == desired_fd) + return result; + close (desired_fd); +# ifdef F_DUPFD + result = fcntl (fd, F_DUPFD, desired_fd); +# if REPLACE_FCHDIR + if (0 <= result) + result = _gl_register_dup (fd, result); +# endif +# else + result = dupfd (fd, desired_fd); +# endif + if (result == -1 && (errno == EMFILE || errno == EINVAL)) + errno = EBADF; + return result; +} +#endif /* !HAVE_DUP2 */ diff --git a/lib/select.c b/lib/select.c new file mode 100644 index 000000000..13ca15006 --- /dev/null +++ b/lib/select.c @@ -0,0 +1,547 @@ +/* Emulation for select(2) + Contributed by Paolo Bonzini. + + Copyright 2008-2013 Free Software Foundation, Inc. + + This file is part of gnulib. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> +#include <alloca.h> +#include <assert.h> + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +/* Native Windows. */ + +#include <sys/types.h> +#include <errno.h> +#include <limits.h> + +#include <winsock2.h> +#include <windows.h> +#include <io.h> +#include <stdio.h> +#include <conio.h> +#include <time.h> + +/* Get the overridden 'struct timeval'. */ +#include <sys/time.h> + +#include "msvc-nothrow.h" + +#undef select + +struct bitset { + unsigned char in[FD_SETSIZE / CHAR_BIT]; + unsigned char out[FD_SETSIZE / CHAR_BIT]; +}; + +/* Declare data structures for ntdll functions. */ +typedef struct _FILE_PIPE_LOCAL_INFORMATION { + ULONG NamedPipeType; + ULONG NamedPipeConfiguration; + ULONG MaximumInstances; + ULONG CurrentInstances; + ULONG InboundQuota; + ULONG ReadDataAvailable; + ULONG OutboundQuota; + ULONG WriteQuotaAvailable; + ULONG NamedPipeState; + ULONG NamedPipeEnd; +} FILE_PIPE_LOCAL_INFORMATION, *PFILE_PIPE_LOCAL_INFORMATION; + +typedef struct _IO_STATUS_BLOCK +{ + union { + DWORD Status; + PVOID Pointer; + } u; + ULONG_PTR Information; +} IO_STATUS_BLOCK, *PIO_STATUS_BLOCK; + +typedef enum _FILE_INFORMATION_CLASS { + FilePipeLocalInformation = 24 +} FILE_INFORMATION_CLASS, *PFILE_INFORMATION_CLASS; + +typedef DWORD (WINAPI *PNtQueryInformationFile) + (HANDLE, IO_STATUS_BLOCK *, VOID *, ULONG, FILE_INFORMATION_CLASS); + +#ifndef PIPE_BUF +#define PIPE_BUF 512 +#endif + +/* Optimized test whether a HANDLE refers to a console. + See <http://lists.gnu.org/archive/html/bug-gnulib/2009-08/msg00065.html>. */ +#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) + +static BOOL +IsSocketHandle (HANDLE h) +{ + WSANETWORKEVENTS ev; + + if (IsConsoleHandle (h)) + return FALSE; + + /* Under Wine, it seems that getsockopt returns 0 for pipes too. + WSAEnumNetworkEvents instead distinguishes the two correctly. */ + ev.lNetworkEvents = 0xDEADBEEF; + WSAEnumNetworkEvents ((SOCKET) h, NULL, &ev); + return ev.lNetworkEvents != 0xDEADBEEF; +} + +/* Compute output fd_sets for libc descriptor FD (whose Windows handle is + H). */ + +static int +windows_poll_handle (HANDLE h, int fd, + struct bitset *rbits, + struct bitset *wbits, + struct bitset *xbits) +{ + BOOL read, write, except; + int i, ret; + INPUT_RECORD *irbuffer; + DWORD avail, nbuffer; + BOOL bRet; + IO_STATUS_BLOCK iosb; + FILE_PIPE_LOCAL_INFORMATION fpli; + static PNtQueryInformationFile NtQueryInformationFile; + static BOOL once_only; + + read = write = except = FALSE; + switch (GetFileType (h)) + { + case FILE_TYPE_DISK: + read = TRUE; + write = TRUE; + break; + + case FILE_TYPE_PIPE: + if (!once_only) + { + NtQueryInformationFile = (PNtQueryInformationFile) + GetProcAddress (GetModuleHandle ("ntdll.dll"), + "NtQueryInformationFile"); + once_only = TRUE; + } + + if (PeekNamedPipe (h, NULL, 0, NULL, &avail, NULL) != 0) + { + if (avail) + read = TRUE; + } + else if (GetLastError () == ERROR_BROKEN_PIPE) + ; + + else + { + /* It was the write-end of the pipe. Check if it is writable. + If NtQueryInformationFile fails, optimistically assume the pipe is + writable. This could happen on Windows 9x, where + NtQueryInformationFile is not available, or if we inherit a pipe + that doesn't permit FILE_READ_ATTRIBUTES access on the write end + (I think this should not happen since Windows XP SP2; WINE seems + fine too). Otherwise, ensure that enough space is available for + atomic writes. */ + memset (&iosb, 0, sizeof (iosb)); + memset (&fpli, 0, sizeof (fpli)); + + if (!NtQueryInformationFile + || NtQueryInformationFile (h, &iosb, &fpli, sizeof (fpli), + FilePipeLocalInformation) + || fpli.WriteQuotaAvailable >= PIPE_BUF + || (fpli.OutboundQuota < PIPE_BUF && + fpli.WriteQuotaAvailable == fpli.OutboundQuota)) + write = TRUE; + } + break; + + case FILE_TYPE_CHAR: + write = TRUE; + if (!(rbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1))))) + break; + + ret = WaitForSingleObject (h, 0); + if (ret == WAIT_OBJECT_0) + { + if (!IsConsoleHandle (h)) + { + read = TRUE; + break; + } + + nbuffer = avail = 0; + bRet = GetNumberOfConsoleInputEvents (h, &nbuffer); + + /* Screen buffers handles are filtered earlier. */ + assert (bRet); + if (nbuffer == 0) + { + except = TRUE; + break; + } + + irbuffer = (INPUT_RECORD *) alloca (nbuffer * sizeof (INPUT_RECORD)); + bRet = PeekConsoleInput (h, irbuffer, nbuffer, &avail); + if (!bRet || avail == 0) + { + except = TRUE; + break; + } + + for (i = 0; i < avail; i++) + if (irbuffer[i].EventType == KEY_EVENT) + read = TRUE; + } + break; + + default: + ret = WaitForSingleObject (h, 0); + write = TRUE; + if (ret == WAIT_OBJECT_0) + read = TRUE; + + break; + } + + ret = 0; + if (read && (rbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1))))) + { + rbits->out[fd / CHAR_BIT] |= (1 << (fd & (CHAR_BIT - 1))); + ret++; + } + + if (write && (wbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1))))) + { + wbits->out[fd / CHAR_BIT] |= (1 << (fd & (CHAR_BIT - 1))); + ret++; + } + + if (except && (xbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1))))) + { + xbits->out[fd / CHAR_BIT] |= (1 << (fd & (CHAR_BIT - 1))); + ret++; + } + + return ret; +} + +int +rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, + struct timeval *timeout) +#undef timeval +{ + static struct timeval tv0; + static HANDLE hEvent; + HANDLE h, handle_array[FD_SETSIZE + 2]; + fd_set handle_rfds, handle_wfds, handle_xfds; + struct bitset rbits, wbits, xbits; + unsigned char anyfds_in[FD_SETSIZE / CHAR_BIT]; + DWORD ret, wait_timeout, nhandles, nsock, nbuffer; + MSG msg; + int i, fd, rc; + + if (nfds > FD_SETSIZE) + nfds = FD_SETSIZE; + + if (!timeout) + wait_timeout = INFINITE; + else + { + wait_timeout = timeout->tv_sec * 1000 + timeout->tv_usec / 1000; + + /* select is also used as a portable usleep. */ + if (!rfds && !wfds && !xfds) + { + Sleep (wait_timeout); + return 0; + } + } + + if (!hEvent) + hEvent = CreateEvent (NULL, FALSE, FALSE, NULL); + + handle_array[0] = hEvent; + nhandles = 1; + nsock = 0; + + /* Copy descriptors to bitsets. At the same time, eliminate + bits in the "wrong" direction for console input buffers + and screen buffers, because screen buffers are waitable + and they will block until a character is available. */ + memset (&rbits, 0, sizeof (rbits)); + memset (&wbits, 0, sizeof (wbits)); + memset (&xbits, 0, sizeof (xbits)); + memset (anyfds_in, 0, sizeof (anyfds_in)); + if (rfds) + for (i = 0; i < rfds->fd_count; i++) + { + fd = rfds->fd_array[i]; + h = (HANDLE) _get_osfhandle (fd); + if (IsConsoleHandle (h) + && !GetNumberOfConsoleInputEvents (h, &nbuffer)) + continue; + + rbits.in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1)); + anyfds_in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1)); + } + else + rfds = (fd_set *) alloca (sizeof (fd_set)); + + if (wfds) + for (i = 0; i < wfds->fd_count; i++) + { + fd = wfds->fd_array[i]; + h = (HANDLE) _get_osfhandle (fd); + if (IsConsoleHandle (h) + && GetNumberOfConsoleInputEvents (h, &nbuffer)) + continue; + + wbits.in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1)); + anyfds_in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1)); + } + else + wfds = (fd_set *) alloca (sizeof (fd_set)); + + if (xfds) + for (i = 0; i < xfds->fd_count; i++) + { + fd = xfds->fd_array[i]; + xbits.in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1)); + anyfds_in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1)); + } + else + xfds = (fd_set *) alloca (sizeof (fd_set)); + + /* Zero all the fd_sets, including the application's. */ + FD_ZERO (rfds); + FD_ZERO (wfds); + FD_ZERO (xfds); + FD_ZERO (&handle_rfds); + FD_ZERO (&handle_wfds); + FD_ZERO (&handle_xfds); + + /* Classify handles. Create fd sets for sockets, poll the others. */ + for (i = 0; i < nfds; i++) + { + if ((anyfds_in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) == 0) + continue; + + h = (HANDLE) _get_osfhandle (i); + if (!h) + { + errno = EBADF; + return -1; + } + + if (IsSocketHandle (h)) + { + int requested = FD_CLOSE; + + /* See above; socket handles are mapped onto select, but we + need to map descriptors to handles. */ + if (rbits.in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + { + requested |= FD_READ | FD_ACCEPT; + FD_SET ((SOCKET) h, rfds); + FD_SET ((SOCKET) h, &handle_rfds); + } + if (wbits.in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + { + requested |= FD_WRITE | FD_CONNECT; + FD_SET ((SOCKET) h, wfds); + FD_SET ((SOCKET) h, &handle_wfds); + } + if (xbits.in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + { + requested |= FD_OOB; + FD_SET ((SOCKET) h, xfds); + FD_SET ((SOCKET) h, &handle_xfds); + } + + WSAEventSelect ((SOCKET) h, hEvent, requested); + nsock++; + } + else + { + handle_array[nhandles++] = h; + + /* Poll now. If we get an event, do not wait below. */ + if (wait_timeout != 0 + && windows_poll_handle (h, i, &rbits, &wbits, &xbits)) + wait_timeout = 0; + } + } + + /* Place a sentinel at the end of the array. */ + handle_array[nhandles] = NULL; + +restart: + if (wait_timeout == 0 || nsock == 0) + rc = 0; + else + { + /* See if we need to wait in the loop below. If any select is ready, + do MsgWaitForMultipleObjects anyway to dispatch messages, but + no need to call select again. */ + rc = select (0, &handle_rfds, &handle_wfds, &handle_xfds, &tv0); + if (rc == 0) + { + /* Restore the fd_sets for the other select we do below. */ + memcpy (&handle_rfds, rfds, sizeof (fd_set)); + memcpy (&handle_wfds, wfds, sizeof (fd_set)); + memcpy (&handle_xfds, xfds, sizeof (fd_set)); + } + else + wait_timeout = 0; + } + + for (;;) + { + ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE, + wait_timeout, QS_ALLINPUT); + + if (ret == WAIT_OBJECT_0 + nhandles) + { + /* new input of some other kind */ + BOOL bRet; + while ((bRet = PeekMessage (&msg, NULL, 0, 0, PM_REMOVE)) != 0) + { + TranslateMessage (&msg); + DispatchMessage (&msg); + } + } + else + break; + } + + /* If we haven't done it yet, check the status of the sockets. */ + if (rc == 0 && nsock > 0) + rc = select (0, &handle_rfds, &handle_wfds, &handle_xfds, &tv0); + + if (nhandles > 1) + { + /* Count results that are not counted in the return value of select. */ + nhandles = 1; + for (i = 0; i < nfds; i++) + { + if ((anyfds_in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) == 0) + continue; + + h = (HANDLE) _get_osfhandle (i); + if (h == handle_array[nhandles]) + { + /* Not a socket. */ + nhandles++; + windows_poll_handle (h, i, &rbits, &wbits, &xbits); + if (rbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))) + || wbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))) + || xbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + rc++; + } + } + + if (rc == 0 && wait_timeout == INFINITE) + { + /* Sleep 1 millisecond to avoid busy wait and retry with the + original fd_sets. */ + memcpy (&handle_rfds, rfds, sizeof (fd_set)); + memcpy (&handle_wfds, wfds, sizeof (fd_set)); + memcpy (&handle_xfds, xfds, sizeof (fd_set)); + SleepEx (1, TRUE); + goto restart; + } + } + + /* Now fill in the results. */ + FD_ZERO (rfds); + FD_ZERO (wfds); + FD_ZERO (xfds); + nhandles = 1; + for (i = 0; i < nfds; i++) + { + if ((anyfds_in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) == 0) + continue; + + h = (HANDLE) _get_osfhandle (i); + if (h != handle_array[nhandles]) + { + /* Perform handle->descriptor mapping. */ + WSAEventSelect ((SOCKET) h, NULL, 0); + if (FD_ISSET (h, &handle_rfds)) + FD_SET (i, rfds); + if (FD_ISSET (h, &handle_wfds)) + FD_SET (i, wfds); + if (FD_ISSET (h, &handle_xfds)) + FD_SET (i, xfds); + } + else + { + /* Not a socket. */ + nhandles++; + if (rbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + FD_SET (i, rfds); + if (wbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + FD_SET (i, wfds); + if (xbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) + FD_SET (i, xfds); + } + } + + return rc; +} + +#else /* ! Native Windows. */ + +#include <sys/select.h> +#include <stddef.h> /* NULL */ +#include <errno.h> +#include <unistd.h> + +#undef select + +int +rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, + struct timeval *timeout) +{ + int i; + + /* FreeBSD 8.2 has a bug: it does not always detect invalid fds. */ + if (nfds < 0 || nfds > FD_SETSIZE) + { + errno = EINVAL; + return -1; + } + for (i = 0; i < nfds; i++) + { + if (((rfds && FD_ISSET (i, rfds)) + || (wfds && FD_ISSET (i, wfds)) + || (xfds && FD_ISSET (i, xfds))) + && dup2 (i, i) != i) + return -1; + } + + /* Interix 3.5 has a bug: it does not support nfds == 0. */ + if (nfds == 0) + { + nfds = 1; + rfds = NULL; + wfds = NULL; + xfds = NULL; + } + return select (nfds, rfds, wfds, xfds, timeout); +} + +#endif diff --git a/lib/sys_select.in.h b/lib/sys_select.in.h new file mode 100644 index 000000000..0e3e32d82 --- /dev/null +++ b/lib/sys_select.in.h @@ -0,0 +1,309 @@ +/* Substitute for <sys/select.h>. + Copyright (C) 2007-2013 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see <http://www.gnu.org/licenses/>. */ + +# if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +# endif +@PRAGMA_COLUMNS@ + +/* On OSF/1 and Solaris 2.6, <sys/types.h> and <sys/time.h> + both include <sys/select.h>. + Simply delegate to the system's header in this case. */ +#if (@HAVE_SYS_SELECT_H@ \ + && ((defined __osf__ && defined _SYS_TYPES_H_ && defined _OSF_SOURCE) \ + || (defined __sun && defined _SYS_TYPES_H \ + && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ + || defined __EXTENSIONS__))) \ + && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H) + +# define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H +# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ + +#elif (@HAVE_SYS_SELECT_H@ \ + && ((defined __osf__ && defined _SYS_TIME_H_ && defined _OSF_SOURCE) \ + || (defined __sun && defined _SYS_TIME_H \ + && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ + || defined __EXTENSIONS__))) \ + && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H) + +# define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H +# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ + +/* On IRIX 6.5, <sys/timespec.h> includes <sys/types.h>, which includes + <sys/bsd_types.h>, which includes <sys/select.h>. At this point we cannot + include <signal.h>, because that includes <internal/signal_core.h>, which + gives a syntax error because <sys/timespec.h> has not been completely + processed. Simply delegate to the system's header in this case. */ +#elif @HAVE_SYS_SELECT_H@ && defined __sgi && (defined _SYS_BSD_TYPES_H && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_BSD_TYPES_H) + +# define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_BSD_TYPES_H +# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ + +/* On OpenBSD 5.0, <pthread.h> includes <sys/types.h>, which includes + <sys/select.h>. At this point we cannot include <signal.h>, because that + includes gnulib's pthread.h override, which gives a syntax error because + /usr/include/pthread.h has not been completely processed. Simply delegate + to the system's header in this case. */ +#elif @HAVE_SYS_SELECT_H@ && defined __OpenBSD__ && (defined _PTHREAD_H_ && !defined PTHREAD_MUTEX_INITIALIZER) + +# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ + +#else + +#ifndef _@GUARD_PREFIX@_SYS_SELECT_H + +/* On many platforms, <sys/select.h> assumes prior inclusion of + <sys/types.h>. Also, mingw defines sigset_t there, instead of + in <signal.h> where it belongs. */ +#include <sys/types.h> + +#if @HAVE_SYS_SELECT_H@ + +/* On OSF/1 4.0, <sys/select.h> provides only a forward declaration + of 'struct timeval', and no definition of this type. + Also, Mac OS X, AIX, HP-UX, IRIX, Solaris, Interix declare select() + in <sys/time.h>. + But avoid namespace pollution on glibc systems. */ +# ifndef __GLIBC__ +# include <sys/time.h> +# endif + +/* On AIX 7 and Solaris 10, <sys/select.h> provides an FD_ZERO implementation + that relies on memset(), but without including <string.h>. + But in any case avoid namespace pollution on glibc systems. */ +# if (defined __OpenBSD__ || defined _AIX || defined __sun || defined __osf__ || defined __BEOS__) \ + && ! defined __GLIBC__ +# include <string.h> +# endif + +/* The include_next requires a split double-inclusion guard. */ +# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ + +#endif + +/* Get definition of 'sigset_t'. + But avoid namespace pollution on glibc systems. + Do this after the include_next (for the sake of OpenBSD 5.0) but before + the split double-inclusion guard (for the sake of Solaris). */ +#if !(defined __GLIBC__ && !defined __UCLIBC__) +# include <signal.h> +#endif + +#ifndef _@GUARD_PREFIX@_SYS_SELECT_H +#define _@GUARD_PREFIX@_SYS_SELECT_H + +#if !@HAVE_SYS_SELECT_H@ +/* A platform that lacks <sys/select.h>. */ +/* Get the 'struct timeval' and 'fd_set' types and the FD_* macros + on most platforms. */ +# include <sys/time.h> +/* On HP-UX 11, <sys/time.h> provides an FD_ZERO implementation + that relies on memset(), but without including <string.h>. */ +# if defined __hpux +# include <string.h> +# endif +/* On native Windows platforms: + Get the 'fd_set' type. + Get the close() declaration before we override it. */ +# if @HAVE_WINSOCK2_H@ +# if !defined _GL_INCLUDING_WINSOCK2_H +# define _GL_INCLUDING_WINSOCK2_H +# include <winsock2.h> +# undef _GL_INCLUDING_WINSOCK2_H +# endif +# include <io.h> +# endif +#endif + +/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ + +/* The definition of _GL_WARN_ON_USE is copied here. */ + + +/* Fix some definitions from <winsock2.h>. */ + +#if @HAVE_WINSOCK2_H@ + +# if !GNULIB_defined_rpl_fd_isset + +/* Re-define FD_ISSET to avoid a WSA call while we are not using + network sockets. */ +static int +rpl_fd_isset (SOCKET fd, fd_set * set) +{ + u_int i; + if (set == NULL) + return 0; + + for (i = 0; i < set->fd_count; i++) + if (set->fd_array[i] == fd) + return 1; + + return 0; +} + +# define GNULIB_defined_rpl_fd_isset 1 +# endif + +# undef FD_ISSET +# define FD_ISSET(fd, set) rpl_fd_isset(fd, set) + +#endif + +/* Hide some function declarations from <winsock2.h>. */ + +#if @HAVE_WINSOCK2_H@ +# if !defined _@GUARD_PREFIX@_UNISTD_H +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef close +# define close close_used_without_including_unistd_h +# else + _GL_WARN_ON_USE (close, + "close() used without including <unistd.h>"); +# endif +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef gethostname +# define gethostname gethostname_used_without_including_unistd_h +# else + _GL_WARN_ON_USE (gethostname, + "gethostname() used without including <unistd.h>"); +# endif +# endif +# if !defined _@GUARD_PREFIX@_SYS_SOCKET_H +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef socket +# define socket socket_used_without_including_sys_socket_h +# undef connect +# define connect connect_used_without_including_sys_socket_h +# undef accept +# define accept accept_used_without_including_sys_socket_h +# undef bind +# define bind bind_used_without_including_sys_socket_h +# undef getpeername +# define getpeername getpeername_used_without_including_sys_socket_h +# undef getsockname +# define getsockname getsockname_used_without_including_sys_socket_h +# undef getsockopt +# define getsockopt getsockopt_used_without_including_sys_socket_h +# undef listen +# define listen listen_used_without_including_sys_socket_h +# undef recv +# define recv recv_used_without_including_sys_socket_h +# undef send +# define send send_used_without_including_sys_socket_h +# undef recvfrom +# define recvfrom recvfrom_used_without_including_sys_socket_h +# undef sendto +# define sendto sendto_used_without_including_sys_socket_h +# undef setsockopt +# define setsockopt setsockopt_used_without_including_sys_socket_h +# undef shutdown +# define shutdown shutdown_used_without_including_sys_socket_h +# else + _GL_WARN_ON_USE (socket, + "socket() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (connect, + "connect() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (accept, + "accept() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (bind, + "bind() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (getpeername, + "getpeername() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (getsockname, + "getsockname() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (getsockopt, + "getsockopt() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (listen, + "listen() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (recv, + "recv() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (send, + "send() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (recvfrom, + "recvfrom() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (sendto, + "sendto() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (setsockopt, + "setsockopt() used without including <sys/socket.h>"); + _GL_WARN_ON_USE (shutdown, + "shutdown() used without including <sys/socket.h>"); +# endif +# endif +#endif + + +#if @GNULIB_PSELECT@ +# if @REPLACE_PSELECT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef pselect +# define pselect rpl_pselect +# endif +_GL_FUNCDECL_RPL (pselect, int, + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timespec const *restrict, const sigset_t *restrict)); +_GL_CXXALIAS_RPL (pselect, int, + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timespec const *restrict, const sigset_t *restrict)); +# else +# if !@HAVE_PSELECT@ +_GL_FUNCDECL_SYS (pselect, int, + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timespec const *restrict, const sigset_t *restrict)); +# endif +_GL_CXXALIAS_SYS (pselect, int, + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timespec const *restrict, const sigset_t *restrict)); +# endif +_GL_CXXALIASWARN (pselect); +#elif defined GNULIB_POSIXCHECK +# undef pselect +# if HAVE_RAW_DECL_PSELECT +_GL_WARN_ON_USE (pselect, "pselect is not portable - " + "use gnulib module pselect for portability"); +# endif +#endif + +#if @GNULIB_SELECT@ +# if @REPLACE_SELECT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef select +# define select rpl_select +# endif +_GL_FUNCDECL_RPL (select, int, + (int, fd_set *, fd_set *, fd_set *, struct timeval *)); +_GL_CXXALIAS_RPL (select, int, + (int, fd_set *, fd_set *, fd_set *, struct timeval *)); +# else +_GL_CXXALIAS_SYS (select, int, + (int, fd_set *, fd_set *, fd_set *, struct timeval *)); +# endif +_GL_CXXALIASWARN (select); +#elif @HAVE_WINSOCK2_H@ +# undef select +# define select select_used_without_requesting_gnulib_module_select +#elif defined GNULIB_POSIXCHECK +# undef select +# if HAVE_RAW_DECL_SELECT +_GL_WARN_ON_USE (select, "select is not always POSIX compliant - " + "use gnulib module select for portability"); +# endif +#endif + + +#endif /* _@GUARD_PREFIX@_SYS_SELECT_H */ +#endif /* _@GUARD_PREFIX@_SYS_SELECT_H */ +#endif /* OSF/1 */ diff --git a/m4/dup2.m4 b/m4/dup2.m4 new file mode 100644 index 000000000..269cfdc11 --- /dev/null +++ b/m4/dup2.m4 @@ -0,0 +1,84 @@ +#serial 19 +dnl Copyright (C) 2002, 2005, 2007, 2009-2013 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_FUNC_DUP2], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) + m4_ifdef([gl_FUNC_DUP2_OBSOLETE], [ + AC_CHECK_FUNCS_ONCE([dup2]) + if test $ac_cv_func_dup2 = no; then + HAVE_DUP2=0 + fi + ], [ + AC_DEFINE([HAVE_DUP2], [1], [Define to 1 if you have the 'dup2' function.]) + ]) + if test $HAVE_DUP2 = 1; then + AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works], + [AC_RUN_IFELSE([ + AC_LANG_PROGRAM([[#include <unistd.h> +#include <fcntl.h> +#include <errno.h>]], + [int result = 0; +#ifdef FD_CLOEXEC + if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) + result |= 1; +#endif + if (dup2 (1, 1) == 0) + result |= 2; +#ifdef FD_CLOEXEC + if (fcntl (1, F_GETFD) != FD_CLOEXEC) + result |= 4; +#endif + close (0); + if (dup2 (0, 0) != -1) + result |= 8; + /* Many gnulib modules require POSIX conformance of EBADF. */ + if (dup2 (2, 1000000) == -1 && errno != EBADF) + result |= 16; + /* Flush out a cygwin core dump. */ + if (dup2 (2, -1) != -1 || errno != EBADF) + result |= 32; + return result; + ]) + ], + [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no], + [case "$host_os" in + mingw*) # on this platform, dup2 always returns 0 for success + gl_cv_func_dup2_works="guessing no" ;; + cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0 + gl_cv_func_dup2_works="guessing no" ;; + linux*) # On linux between 2008-07-27 and 2009-05-11, dup2 of a + # closed fd may yield -EBADF instead of -1 / errno=EBADF. + gl_cv_func_dup2_works="guessing no" ;; + freebsd*) # on FreeBSD 6.1, dup2(1,1000000) gives EMFILE, not EBADF. + gl_cv_func_dup2_works="guessing no" ;; + haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC. + gl_cv_func_dup2_works="guessing no" ;; + *) gl_cv_func_dup2_works="guessing yes" ;; + esac]) + ]) + case "$gl_cv_func_dup2_works" in + *yes) ;; + *) + REPLACE_DUP2=1 + ;; + esac + fi + dnl Replace dup2() for supporting the gnulib-defined fchdir() function, + dnl to keep fchdir's bookkeeping up-to-date. + m4_ifdef([gl_FUNC_FCHDIR], [ + gl_TEST_FCHDIR + if test $HAVE_FCHDIR = 0; then + if test $HAVE_DUP2 = 1; then + REPLACE_DUP2=1 + fi + fi + ]) +]) + +# Prerequisites of lib/dup2.c. +AC_DEFUN([gl_PREREQ_DUP2], []) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index c0fd22691..9fb3a9096 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -90,6 +90,7 @@ gl_MODULES([ recvfrom regex rename + select send sendto setenv diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index ce1be65fe..ef150cb3c 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -41,6 +41,7 @@ AC_DEFUN([gl_EARLY], AC_REQUIRE([AM_PROG_CC_C_O]) # Code from module accept: # Code from module alignof: + # Code from module alloca: # Code from module alloca-opt: # Code from module announce-gen: # Code from module arpa_inet: @@ -65,6 +66,7 @@ AC_DEFUN([gl_EARLY], # Code from module dirname-lgpl: # Code from module dosname: # Code from module double-slash-root: + # Code from module dup2: # Code from module duplocale: # Code from module environ: # Code from module errno: @@ -158,6 +160,7 @@ AC_DEFUN([gl_EARLY], # Code from module safe-read: # Code from module safe-write: # Code from module same-inode: + # Code from module select: # Code from module send: # Code from module sendto: # Code from module servent: @@ -190,6 +193,7 @@ AC_DEFUN([gl_EARLY], # Code from module striconveh: # Code from module string: # Code from module sys_file: + # Code from module sys_select: # Code from module sys_socket: # Code from module sys_stat: # Code from module sys_time: @@ -238,6 +242,10 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([accept]) fi gl_SYS_SOCKET_MODULE_INDICATOR([accept]) +changequote(,)dnl +LTALLOCA=`echo "$ALLOCA" | sed -e 's/\.[^.]* /.lo /g;s/\.[^.]*$/.lo/'` +changequote([, ])dnl +AC_SUBST([LTALLOCA]) gl_FUNC_ALLOCA gl_HEADER_ARPA_INET AC_PROG_MKDIR_P @@ -287,6 +295,12 @@ AC_DEFUN([gl_INIT], gl_DIRENT_MODULE_INDICATOR([dirfd]) gl_DIRNAME_LGPL gl_DOUBLE_SLASH_ROOT + gl_FUNC_DUP2 + if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then + AC_LIBOBJ([dup2]) + gl_PREREQ_DUP2 + fi + gl_UNISTD_MODULE_INDICATOR([dup2]) gl_FUNC_DUPLOCALE if test $REPLACE_DUPLOCALE = 1; then AC_LIBOBJ([duplocale]) @@ -587,6 +601,11 @@ AC_DEFUN([gl_INIT], gl_MATH_MODULE_INDICATOR([round]) gl_PREREQ_SAFE_READ gl_PREREQ_SAFE_WRITE + gl_FUNC_SELECT + if test $REPLACE_SELECT = 1; then + AC_LIBOBJ([select]) + fi + gl_SYS_SELECT_MODULE_INDICATOR([select]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) if test "$ac_cv_header_winsock2_h" = yes; then AC_LIBOBJ([send]) @@ -658,6 +677,8 @@ AC_DEFUN([gl_INIT], gl_HEADER_STRING_H gl_HEADER_SYS_FILE_H AC_PROG_MKDIR_P + gl_HEADER_SYS_SELECT + AC_PROG_MKDIR_P gl_HEADER_SYS_SOCKET AC_PROG_MKDIR_P gl_HEADER_SYS_STAT_H @@ -863,6 +884,7 @@ AC_DEFUN([gl_FILE_LIST], [ doc/gendocs_template lib/accept.c lib/alignof.h + lib/alloca.c lib/alloca.in.h lib/arpa_inet.in.h lib/asnprintf.c @@ -888,6 +910,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/dirname-lgpl.c lib/dirname.h lib/dosname.h + lib/dup2.c lib/duplocale.c lib/errno.in.h lib/fcntl.in.h @@ -989,6 +1012,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/safe-write.c lib/safe-write.h lib/same-inode.h + lib/select.c lib/send.c lib/sendto.c lib/setenv.c @@ -1017,6 +1041,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/string.in.h lib/stripslash.c lib/sys_file.in.h + lib/sys_select.in.h lib/sys_socket.c lib/sys_socket.in.h lib/sys_stat.in.h @@ -1068,6 +1093,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/dirfd.m4 m4/dirname.m4 m4/double-slash-root.m4 + m4/dup2.m4 m4/duplocale.m4 m4/eealloc.m4 m4/environ.m4 @@ -1158,6 +1184,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/round.m4 m4/safe-read.m4 m4/safe-write.m4 + m4/select.m4 m4/servent.m4 m4/setenv.m4 m4/signal_h.m4 @@ -1180,6 +1207,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/strftime.m4 m4/string_h.m4 m4/sys_file_h.m4 + m4/sys_select_h.m4 m4/sys_socket_h.m4 m4/sys_stat_h.m4 m4/sys_time_h.m4 diff --git a/m4/select.m4 b/m4/select.m4 new file mode 100644 index 000000000..d025355f9 --- /dev/null +++ b/m4/select.m4 @@ -0,0 +1,113 @@ +# select.m4 serial 7 +dnl Copyright (C) 2009-2013 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_FUNC_SELECT], +[ + AC_REQUIRE([gl_HEADER_SYS_SELECT]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_REQUIRE([gl_SOCKETS]) + if test "$ac_cv_header_winsock2_h" = yes; then + REPLACE_SELECT=1 + else + dnl On Interix 3.5, select(0, NULL, NULL, NULL, timeout) fails with error + dnl EFAULT. + AC_CHECK_HEADERS_ONCE([sys/select.h]) + AC_CACHE_CHECK([whether select supports a 0 argument], + [gl_cv_func_select_supports0], + [ + AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include <sys/types.h> +#include <sys/time.h> +#if HAVE_SYS_SELECT_H +#include <sys/select.h> +#endif +int main () +{ + struct timeval timeout; + timeout.tv_sec = 0; + timeout.tv_usec = 5; + return select (0, (fd_set *)0, (fd_set *)0, (fd_set *)0, &timeout) < 0; +}]])], [gl_cv_func_select_supports0=yes], [gl_cv_func_select_supports0=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess no on Interix. + interix*) gl_cv_func_select_supports0="guessing no";; + # Guess yes otherwise. + *) gl_cv_func_select_supports0="guessing yes";; + esac +changequote([,])dnl + ]) + ]) + case "$gl_cv_func_select_supports0" in + *yes) ;; + *) REPLACE_SELECT=1 ;; + esac + + dnl On FreeBSD 8.2, select() doesn't always reject bad fds. + AC_CACHE_CHECK([whether select detects invalid fds], + [gl_cv_func_select_detects_ebadf], + [ + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +#include <sys/types.h> +#include <sys/time.h> +#if HAVE_SYS_SELECT_H +# include <sys/select.h> +#endif +#include <unistd.h> +#include <errno.h> +]],[[ + fd_set set; + dup2(0, 16); + FD_ZERO(&set); + FD_SET(16, &set); + close(16); + struct timeval timeout; + timeout.tv_sec = 0; + timeout.tv_usec = 5; + return select (17, &set, NULL, NULL, &timeout) != -1 || errno != EBADF; +]])], [gl_cv_func_select_detects_ebadf=yes], + [gl_cv_func_select_detects_ebadf=no], + [ + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_select_detects_ebadf="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_select_detects_ebadf="guessing no" ;; + esac + ]) + ]) + case $gl_cv_func_select_detects_ebadf in + *yes) ;; + *) REPLACE_SELECT=1 ;; + esac + fi + + dnl Determine the needed libraries. + LIB_SELECT="$LIBSOCKET" + if test $REPLACE_SELECT = 1; then + case "$host_os" in + mingw*) + dnl On the MSVC platform, the function MsgWaitForMultipleObjects + dnl (used in lib/select.c) requires linking with -luser32. On mingw, + dnl it is implicit. + AC_LINK_IFELSE( + [AC_LANG_SOURCE([[ +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +int +main () +{ + MsgWaitForMultipleObjects (0, NULL, 0, 0, 0); + return 0; +}]])], + [], + [LIB_SELECT="$LIB_SELECT -luser32"]) + ;; + esac + fi + AC_SUBST([LIB_SELECT]) +]) diff --git a/m4/sys_select_h.m4 b/m4/sys_select_h.m4 new file mode 100644 index 000000000..496232851 --- /dev/null +++ b/m4/sys_select_h.m4 @@ -0,0 +1,95 @@ +# sys_select_h.m4 serial 20 +dnl Copyright (C) 2006-2013 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_HEADER_SYS_SELECT], +[ + AC_REQUIRE([AC_C_RESTRICT]) + AC_REQUIRE([gl_SYS_SELECT_H_DEFAULTS]) + AC_CACHE_CHECK([whether <sys/select.h> is self-contained], + [gl_cv_header_sys_select_h_selfcontained], + [ + dnl Test against two bugs: + dnl 1. On many platforms, <sys/select.h> assumes prior inclusion of + dnl <sys/types.h>. + dnl 2. On OSF/1 4.0, <sys/select.h> provides only a forward declaration + dnl of 'struct timeval', and no definition of this type. + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/select.h>]], + [[struct timeval b;]])], + [gl_cv_header_sys_select_h_selfcontained=yes], + [gl_cv_header_sys_select_h_selfcontained=no]) + dnl Test against another bug: + dnl 3. On Solaris 10, <sys/select.h> provides an FD_ZERO implementation + dnl that relies on memset(), but without including <string.h>. + if test $gl_cv_header_sys_select_h_selfcontained = yes; then + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[#include <sys/select.h>]], + [[int memset; int bzero;]]) + ], + [AC_LINK_IFELSE( + [AC_LANG_PROGRAM([[#include <sys/select.h>]], [[ + #undef memset + #define memset nonexistent_memset + extern + #ifdef __cplusplus + "C" + #endif + void *memset (void *, int, unsigned long); + #undef bzero + #define bzero nonexistent_bzero + extern + #ifdef __cplusplus + "C" + #endif + void bzero (void *, unsigned long); + fd_set fds; + FD_ZERO (&fds); + ]]) + ], + [], + [gl_cv_header_sys_select_h_selfcontained=no]) + ]) + fi + ]) + dnl <sys/select.h> is always overridden, because of GNULIB_POSIXCHECK. + gl_CHECK_NEXT_HEADERS([sys/select.h]) + if test $ac_cv_header_sys_select_h = yes; then + HAVE_SYS_SELECT_H=1 + else + HAVE_SYS_SELECT_H=0 + fi + AC_SUBST([HAVE_SYS_SELECT_H]) + gl_PREREQ_SYS_H_WINSOCK2 + + dnl Check for declarations of anything we want to poison if the + dnl corresponding gnulib module is not in use. + gl_WARN_ON_USE_PREPARE([[ +/* Some systems require prerequisite headers. */ +#include <sys/types.h> +#if !(defined __GLIBC__ && !defined __UCLIBC__) && HAVE_SYS_TIME_H +# include <sys/time.h> +#endif +#include <sys/select.h> + ]], [pselect select]) +]) + +AC_DEFUN([gl_SYS_SELECT_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_SYS_SELECT_H_DEFAULTS]) + gl_MODULE_INDICATOR_SET_VARIABLE([$1]) + dnl Define it also as a C macro, for the benefit of the unit tests. + gl_MODULE_INDICATOR_FOR_TESTS([$1]) +]) + +AC_DEFUN([gl_SYS_SELECT_H_DEFAULTS], +[ + GNULIB_PSELECT=0; AC_SUBST([GNULIB_PSELECT]) + GNULIB_SELECT=0; AC_SUBST([GNULIB_SELECT]) + dnl Assume proper GNU behavior unless another module says otherwise. + HAVE_PSELECT=1; AC_SUBST([HAVE_PSELECT]) + REPLACE_PSELECT=0; AC_SUBST([REPLACE_PSELECT]) + REPLACE_SELECT=0; AC_SUBST([REPLACE_SELECT]) +]) From 84ebfef4e69130288d68d68c9e872402aa91363d Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Mon, 18 Feb 2013 19:06:34 +0100 Subject: [PATCH 003/147] add gnulib `times' module * lib: Add `times' module. Should fix socket.c on MinGW. Thanks to Eli Zaretskii for the report. --- lib/Makefile.am | 42 +++++++++++++++++++++++- lib/sys_times.in.h | 80 ++++++++++++++++++++++++++++++++++++++++++++++ lib/times.c | 66 ++++++++++++++++++++++++++++++++++++++ m4/gnulib-cache.m4 | 3 +- m4/gnulib-comp.m4 | 13 ++++++++ m4/sys_times_h.m4 | 51 +++++++++++++++++++++++++++++ m4/times.m4 | 14 ++++++++ 7 files changed, 267 insertions(+), 2 deletions(-) create mode 100644 lib/sys_times.in.h create mode 100644 lib/times.c create mode 100644 m4/sys_times_h.m4 create mode 100644 m4/times.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index c99a7550b..2fe0e8288 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -2526,6 +2526,37 @@ EXTRA_DIST += sys_time.in.h ## end gnulib module sys_time +## begin gnulib module sys_times + +BUILT_SOURCES += sys/times.h + +# We need the following in order to create <sys/times.h> when the system +# doesn't have one that works with the given compiler. +sys/times.h: sys_times.in.h $(top_builddir)/config.status $(WARN_ON_USE_H) $(ARG_NONNULL_H) + $(AM_V_at)$(MKDIR_P) sys + $(AM_V_GEN)rm -f $@-t $@ && \ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + sed -e 's|@''GUARD_PREFIX''@|GL|g' \ + -e 's/@''HAVE_SYS_TIMES_H''@/$(HAVE_SYS_TIMES_H)/g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ + -e 's|@''NEXT_SYS_TIMES_H''@|$(NEXT_SYS_TIMES_H)|g' \ + -e 's/@''GNULIB_TIMES''@/$(GNULIB_TIMES)/g' \ + -e 's|@''HAVE_STRUCT_TMS''@|$(HAVE_STRUCT_TMS)|g' \ + -e 's|@''HAVE_TIMES''@|$(HAVE_TIMES)|g' \ + -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ + -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ + < $(srcdir)/sys_times.in.h; \ + } > $@-t && \ + mv $@-t $@ +MOSTLYCLEANFILES += sys/times.h sys/times.h-t +MOSTLYCLEANDIRS += sys + +EXTRA_DIST += sys_times.in.h + +## end gnulib module sys_times + ## begin gnulib module sys_types BUILT_SOURCES += sys/types.h @@ -2628,6 +2659,15 @@ EXTRA_libgnu_la_SOURCES += time_r.c ## end gnulib module time_r +## begin gnulib module times + + +EXTRA_DIST += times.c + +EXTRA_libgnu_la_SOURCES += times.c + +## end gnulib module times + ## begin gnulib module trunc diff --git a/lib/sys_times.in.h b/lib/sys_times.in.h new file mode 100644 index 000000000..8ea8088c4 --- /dev/null +++ b/lib/sys_times.in.h @@ -0,0 +1,80 @@ +/* Provide a sys/times.h header file. + Copyright (C) 2008-2013 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see <http://www.gnu.org/licenses/>. */ + +/* Written by Simon Josefsson <simon@josefsson.org>, 2008. */ + +/* This file is supposed to be used on platforms where <sys/times.h> + is missing. */ + +#ifndef _@GUARD_PREFIX@_SYS_TIMES_H + +# if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +# endif +@PRAGMA_COLUMNS@ + +# if @HAVE_SYS_TIMES_H@ +# @INCLUDE_NEXT@ @NEXT_SYS_TIMES_H@ +# endif + +# define _@GUARD_PREFIX@_SYS_TIMES_H + +/* Get clock_t. + But avoid namespace pollution on glibc systems. */ +# ifndef __GLIBC__ +# include <time.h> +# endif + +/* The definition of _GL_ARG_NONNULL is copied here. */ + +/* The definition of _GL_WARN_ON_USE is copied here. */ + +# ifdef __cplusplus +extern "C" { +# endif + +# if !@HAVE_STRUCT_TMS@ +# if !GNULIB_defined_struct_tms + /* Structure describing CPU time used by a process and its children. */ + struct tms + { + clock_t tms_utime; /* User CPU time. */ + clock_t tms_stime; /* System CPU time. */ + + clock_t tms_cutime; /* User CPU time of dead children. */ + clock_t tms_cstime; /* System CPU time of dead children. */ + }; +# define GNULIB_defined_struct_tms 1 +# endif +# endif + +# if @GNULIB_TIMES@ +# if !@HAVE_TIMES@ + extern clock_t times (struct tms *buffer) _GL_ARG_NONNULL ((1)); +# endif +# elif defined GNULIB_POSIXCHECK +# undef times +# if HAVE_RAW_DECL_TIMES +_GL_WARN_ON_USE (times, "times is unportable - " + "use gnulib module times for portability"); +# endif +# endif + +# ifdef __cplusplus +} +# endif + +#endif /* _@GUARD_PREFIX@_SYS_TIMES_H */ diff --git a/lib/times.c b/lib/times.c new file mode 100644 index 000000000..cf2fa1df9 --- /dev/null +++ b/lib/times.c @@ -0,0 +1,66 @@ +/* Get process times + + Copyright (C) 2008-2013 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see <http://www.gnu.org/licenses/>. */ + +/* Written by Simon Josefsson <simon@josefsson.org>, 2008. */ + +#include <config.h> + +/* Get times prototype. */ +#include <sys/times.h> + +/* Get round. */ +#include <math.h> + +/* Get GetProcessTimes etc. */ +#include <windows.h> + +static clock_t +filetime2clock (FILETIME time) +{ + float f; + + /* We have a 64-bit value, in the form of two DWORDS aka unsigned + int, counting the number of 100-nanosecond intervals. We need to + convert these to clock ticks. Older POSIX uses CLK_TCK to + indicate the number of clock ticks per second while modern POSIX + uses sysconf(_SC_CLK_TCK). Mingw32 does not appear to have + sysconf(_SC_CLK_TCK), but appears to have CLK_TCK = 1000 so we + use it. Note that CLOCKS_PER_SEC constant does not apply here, + it is for use with the clock function. */ + + f = (unsigned long long) time.dwHighDateTime << 32; + f += time.dwLowDateTime; + f = f * CLK_TCK / 10000000; + return (clock_t) round (f); +} + +clock_t +times (struct tms * buffer) +{ + FILETIME creation_time, exit_time, kernel_time, user_time; + + if (GetProcessTimes (GetCurrentProcess (), &creation_time, &exit_time, + &kernel_time, &user_time) == 0) + return (clock_t) -1; + + buffer->tms_utime = filetime2clock (user_time); + buffer->tms_stime = filetime2clock (kernel_time); + buffer->tms_cutime = 0; + buffer->tms_cstime = 0; + + return filetime2clock (creation_time); +} diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 9fb3a9096..f8a973759 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -103,6 +103,7 @@ gl_MODULES([ striconveh string sys_stat + times trunc verify vsnprintf diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index ef150cb3c..8dc269161 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -197,10 +197,12 @@ AC_DEFUN([gl_EARLY], # Code from module sys_socket: # Code from module sys_stat: # Code from module sys_time: + # Code from module sys_times: # Code from module sys_types: # Code from module sys_uio: # Code from module time: # Code from module time_r: + # Code from module times: # Code from module trunc: # Code from module unistd: # Code from module unistr/base: @@ -685,6 +687,8 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_TIME_H AC_PROG_MKDIR_P + gl_SYS_TIMES_H + AC_PROG_MKDIR_P gl_SYS_TYPES_H AC_PROG_MKDIR_P gl_HEADER_SYS_UIO @@ -696,6 +700,11 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_TIME_R fi gl_TIME_MODULE_INDICATOR([time_r]) + gl_FUNC_TIMES + if test $HAVE_TIMES = 0; then + AC_LIBOBJ([times]) + fi + gl_SYS_TIMES_MODULE_INDICATOR([times]) gl_FUNC_TRUNC if test $HAVE_DECL_TRUNC = 0 || test $REPLACE_TRUNC = 1; then AC_LIBOBJ([trunc]) @@ -1046,10 +1055,12 @@ AC_DEFUN([gl_FILE_LIST], [ lib/sys_socket.in.h lib/sys_stat.in.h lib/sys_time.in.h + lib/sys_times.in.h lib/sys_types.in.h lib/sys_uio.in.h lib/time.in.h lib/time_r.c + lib/times.c lib/trunc.c lib/unistd.c lib/unistd.in.h @@ -1211,10 +1222,12 @@ AC_DEFUN([gl_FILE_LIST], [ m4/sys_socket_h.m4 m4/sys_stat_h.m4 m4/sys_time_h.m4 + m4/sys_times_h.m4 m4/sys_types_h.m4 m4/sys_uio_h.m4 m4/time_h.m4 m4/time_r.m4 + m4/times.m4 m4/tm_gmtoff.m4 m4/trunc.m4 m4/unistd_h.m4 diff --git a/m4/sys_times_h.m4 b/m4/sys_times_h.m4 new file mode 100644 index 000000000..60069850d --- /dev/null +++ b/m4/sys_times_h.m4 @@ -0,0 +1,51 @@ +# Configure a replacement for <sys/times.h>. +# serial 8 + +# Copyright (C) 2008-2013 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# Written by Simon Josefsson. + +AC_DEFUN([gl_SYS_TIMES_H], +[ + AC_REQUIRE([gl_SYS_TIMES_H_DEFAULTS]) + + dnl <sys/times.h> is always overridden, because of GNULIB_POSIXCHECK. + gl_CHECK_NEXT_HEADERS([sys/times.h]) + if test $ac_cv_header_sys_times_h = yes; then + HAVE_SYS_TIMES_H=1 + AC_CHECK_TYPES([struct tms], [], [HAVE_STRUCT_TMS=0], [[ +#include <sys/times.h> + ]]) + else + HAVE_SYS_TIMES_H=0 + HAVE_STRUCT_TMS=0 + fi + AC_SUBST([HAVE_SYS_TIMES_H]) + + dnl Check for declarations of anything we want to poison if the + dnl corresponding gnulib module is not in use. + gl_WARN_ON_USE_PREPARE([[ +/* Some systems have incomplete headers. */ +#if !(defined __GLIBC__ && !defined __UCLIBC__) +# include <time.h> +#endif +#include <sys/times.h> + ]], [times]) +]) + +AC_DEFUN([gl_SYS_TIMES_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_SYS_TIMES_H_DEFAULTS]) + gl_MODULE_INDICATOR_SET_VARIABLE([$1]) +]) + +AC_DEFUN([gl_SYS_TIMES_H_DEFAULTS], +[ + GNULIB_TIMES=0; AC_SUBST([GNULIB_TIMES]) + HAVE_STRUCT_TMS=1; AC_SUBST([HAVE_STRUCT_TMS]) + HAVE_TIMES=1; AC_SUBST([HAVE_TIMES]) +]) diff --git a/m4/times.m4 b/m4/times.m4 new file mode 100644 index 000000000..a0c86677a --- /dev/null +++ b/m4/times.m4 @@ -0,0 +1,14 @@ +# times.m4 serial 2 +dnl Copyright (C) 2009-2013 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_FUNC_TIMES], +[ + AC_REQUIRE([gl_SYS_TIMES_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([times]) + if test $ac_cv_func_times = no; then + HAVE_TIMES=0 + fi +]) From 6f160a6e99a68347d11864d4a9bf15da851c9202 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 18 Feb 2013 21:43:30 +0100 Subject: [PATCH 004/147] build: Fix compilation of `c-tokenize.c' with latest Gnulib. * libguile/c-tokenize.lex: Include <config.h>, to pull in Gnulib macro definitions now required. --- libguile/c-tokenize.lex | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index dc7225778..856224e46 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -14,7 +14,8 @@ FLOQUAL (f|F|l|L) INTQUAL (l|L|ll|LL|lL|Ll|u|U) %{ - +#include <config.h> + #include <stdio.h> #include <stdlib.h> #include <string.h> From 90a162323251bfda86d82b2a3c0c7b12ce8a0bb7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 18 Feb 2013 18:44:15 -0500 Subject: [PATCH 005/147] Remove flawed test that assumed (eq? 1/2 2/4) would return false. * test-suite/tests/hash.test ("hash-count"): Remove flawed test. --- test-suite/tests/hash.test | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 72aa0c478..cb6b5cc26 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -148,7 +148,7 @@ (hashq-set! table 1 'foo) (hashq-ref table 1)))) - ;; 1/2 and 2/4 are equal? and eqv? but not eq? + ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?) (pass-if (equal? 'foo (let ((table (make-hash-table))) (hash-set! table 1/2 'foo) @@ -157,10 +157,6 @@ (let ((table (make-hash-table))) (hashv-set! table 1/2 'foo) (hashv-ref table 2/4)))) - (pass-if (equal? #f - (let ((table (make-hash-table))) - (hashq-set! table 1/2 'foo) - (hashq-ref table 2/4)))) ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2) (pass-if (equal? 'foo From 9b6316eabcd3438ca01d1bf7269702af24c3ec5f Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Tue, 19 Feb 2013 11:41:44 +0100 Subject: [PATCH 006/147] better handling of windows file name conventions * libguile/filesys.c (scm_system_file_name_convention): New function. Exported to Scheme only. * module/ice-9/boot-9.scm (file-name-separator?, absolute-file-name?): New predicates. (file-name-separator-string): New global variable. (in-vicinity): Use the new procedures. (load-user-init, try-module-autoload): Use file-name-separator-string. (load-in-vicinity): Update canonical->suffix. Consistently use the term "file name" throughout. * module/ice-9/psyntax.scm (include): Use global `absolute-file-name?'. * module/ice-9/psyntax-pp.scm: Regenerate. --- libguile/filesys.c | 20 +++- module/ice-9/boot-9.scm | 202 ++++++++++++++++++++++++------------ module/ice-9/psyntax-pp.scm | 6 +- module/ice-9/psyntax.scm | 5 +- 4 files changed, 159 insertions(+), 74 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 9c39307b6..94d824e85 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006, - * 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 2009, 2010, 2011, 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 License @@ -1434,6 +1434,24 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, SCM scm_dot_string; +#ifdef __MINGW32__ +SCM_SYMBOL (sym_file_name_convention, "windows"); +#else +SCM_SYMBOL (sym_file_name_convention, "posix"); +#endif + +SCM_INTERNAL SCM scm_system_file_name_convention (void); + +SCM_DEFINE (scm_system_file_name_convention, + "system-file-name-convention", 0, 0, 0, (void), + "Return either @code{posix} or @code{windows}, depending on\n" + "what kind of system this Guile is running on.") +#define FUNC_NAME s_scm_system_file_name_convention +{ + return sym_file_name_convention; +} +#undef FUNC_NAME + SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, (SCM filename), "Return the directory name component of the file name\n" diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 31d4523d5..991eb3b40 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -296,6 +296,12 @@ If there is no handler at all, Guile prints an error and then exits." (apply f (car l1) (map car rest)) (lp (cdr l1) (map cdr rest)))))))) +;; Temporary definition used in the include-from-path expansion; +;; replaced later. + +(define (absolute-file-name? file-name) + #t) + ;;; {and-map and or-map} ;;; ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) @@ -1411,16 +1417,68 @@ VALUE." ;;; {Load Paths} ;;; +(let-syntax ((compile-time-case + (lambda (stx) + (syntax-case stx () + ((_ exp clauses ...) + (let ((val (primitive-eval (syntax->datum #'exp)))) + (let next-clause ((clauses #'(clauses ...))) + (syntax-case clauses (else) + (() + (syntax-violation 'compile-time-case + "all clauses failed to match" stx)) + (((else form ...)) + #'(begin form ...)) + ((((k ...) form ...) clauses ...) + (if (memv val (syntax->datum #'(k ...))) + #'(begin form ...) + (next-clause #'(clauses ...)))))))))))) + ;; emacs: (put 'compile-time-case 'scheme-indent-function 1) + (compile-time-case (system-file-name-convention) + ((posix) + (define (file-name-separator? c) + (char=? c #\/)) + + (define file-name-separator-string "/") + + (define (absolute-file-name? file-name) + (string-prefix? "/" file-name))) + + ((windows) + (define (file-name-separator? c) + (or (char=? c #\/) + (char=? c #\\))) + + (define file-name-separator-string "\\") + + (define (absolute-file-name? file-name) + (define (unc-file-name?) + ;; Universal Naming Convention (UNC) file-names start with \\, + ;; and are always absolute. + (string-prefix? "\\\\" file-name)) + (define (has-drive-specifier?) + (and (>= (string-length file-name) 2) + (let ((drive (string-ref file-name 0))) + (or (char<=? #\a drive #\z) + (char<=? #\A drive #\Z))) + (eqv? (string-ref file-name 1) #\:))) + (define (file-name-separator-at-index? idx) + (and (> (string-length file-name) idx) + (file-name-separator? (string-ref file-name idx)))) + (or (unc-file-name?) + (if (has-drive-specifier?) + (file-name-separator-at-index? 2) + (file-name-separator-at-index? 0))))))) + (define (in-vicinity vicinity file) (let ((tail (let ((len (string-length vicinity))) (if (zero? len) #f (string-ref vicinity (- len 1)))))) (string-append vicinity - (if (or (not tail) - (eq? tail #\/)) + (if (or (not tail) (file-name-separator? tail)) "" - "/") + file-name-separator-string) file))) @@ -1440,7 +1498,7 @@ VALUE." (define (load-user-init) (let* ((home (or (getenv "HOME") (false-if-exception (passwd:dir (getpwuid (getuid)))) - "/")) ;; fallback for cygwin etc. + file-name-separator-string)) ;; fallback for cygwin etc. (init-file (in-vicinity home ".guile"))) (if (file-exists? init-file) (primitive-load init-file)))) @@ -2777,7 +2835,8 @@ but it fails to load." (dir-hint-module-name (reverse (cdr reverse-name))) (dir-hint (apply string-append (map (lambda (elt) - (string-append (symbol->string elt) "/")) + (string-append (symbol->string elt) + file-name-separator-string)) dir-hint-module-name)))) (resolve-module dir-hint-module-name #f) (and (not (autoload-done-or-in-progress? dir-hint name)) @@ -3606,16 +3665,17 @@ CONV is not applied to the initial value." ;;; {`load'.} ;;; -;;; Load is tricky when combined with relative paths, compilation, and -;;; the file system. If a path is relative, what is it relative to? The -;;; path of the source file at the time it was compiled? The path of -;;; the compiled file? What if both or either were installed? And how -;;; do you get that information? Tricky, I say. +;;; Load is tricky when combined with relative file names, compilation, +;;; and the file system. If a file name is relative, what is it +;;; relative to? The name of the source file at the time it was +;;; compiled? The name of the compiled file? What if both or either +;;; were installed? And how do you get that information? Tricky, I +;;; say. ;;; ;;; To get around all of this, we're going to do something nasty, and -;;; turn `load' into a macro. That way it can know the path of the +;;; turn `load' into a macro. That way it can know the name of the ;;; source file with respect to which it was invoked, so it can resolve -;;; relative paths with respect to the original source path. +;;; relative file names with respect to the original source file. ;;; ;;; There is an exception, and that is that if the source file was in ;;; the load path when it was compiled, instead of looking up against @@ -3628,18 +3688,24 @@ CONV is not applied to the initial value." '(#: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* (load-in-vicinity dir file-name #:optional reader) + "Load source file FILE-NAME in vicinity of directory DIR. Use a +pre-compiled version of FILE-NAME when available, and auto-compile one +when none is available, reading FILE-NAME with READER." (define (canonical->suffix canon) (cond - ((string-prefix? "/" canon) canon) - ((and (> (string-length canon) 2) - (eqv? (string-ref canon 1) #\:)) - ;; Paths like C:... transform to /C... - (string-append "/" (substring canon 0 1) (substring canon 2))) + ((and (not (string-null? canon)) + (file-name-separator? (string-ref canon 0))) + canon) + ((and (eq? (system-file-name-convention) 'windows) + (absolute-file-name? canon)) + ;; An absolute file name that doesn't start with a separator + ;; starts with a drive component. Transform the drive component + ;; to a file name element: c:\foo -> \c\foo. + (string-append file-name-separator-string + (substring canon 0 1) + (substring canon 2))) (else canon))) (define compiled-extension @@ -3658,14 +3724,16 @@ reading PATH with READER." (>= (stat:mtimensec stat1) (stat:mtimensec stat2))))) - (define (fallback-file-name canon-path) - ;; Return the in-cache compiled file name for source file CANON-PATH. + (define (fallback-file-name canon-file-name) + ;; Return the in-cache compiled file name for source file + ;; CANON-FILE-NAME. - ;; FIXME: would probably be better just to append SHA1(canon-path) - ;; to the %compile-fallback-path, to avoid deep directory stats. + ;; FIXME: would probably be better just to append + ;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid + ;; deep directory stats. (and %compile-fallback-path (string-append %compile-fallback-path - (canonical->suffix canon-path) + (canonical->suffix canon-file-name) compiled-extension))) (define (compile file) @@ -3685,30 +3753,33 @@ reading PATH with READER." (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 - ;; as primitive-load-path does internally. primitive-load is - ;; unaffected. Returns #f if auto-compilation failed or was disabled. + ;; 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 as primitive-load-path does internally. + ;; primitive-load is unaffected. Returns #f if auto-compilation + ;; failed or was disabled. ;; - ;; 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). + ;; 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 (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. + (define (fresh-compiled-file-name name scmstat go-file-name) + ;; Return GO-FILE-NAME 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 ((gostat (and (not %fresh-auto-compile) - (stat go-path #f)))) + (stat go-file-name #f)))) (if (and gostat (more-recent? gostat scmstat)) - go-path + go-file-name (begin (if gostat (format (current-warning-port) ";;; note: source file ~a\n;;; newer than compiled ~a\n" - name go-path)) + name go-file-name)) (cond (%load-should-auto-compile (%warn-auto-compilation-enabled) @@ -3723,61 +3794,60 @@ reading PATH with READER." (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) - ;; Load from ABS-PATH, using a compiled file or auto-compiling if needed. + (define (load-absolute abs-file-name) + ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling + ;; if needed. (define scmstat (catch #t (lambda () - (stat abs-path)) + (stat abs-file-name)) (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))))) + (and=> (search-path %load-compiled-path (sans-extension file-name) + %load-compiled-extensions #t) + (lambda (go-file-name) + (let ((gostat (stat go-file-name #f))) + (and gostat (more-recent? gostat scmstat) + go-file-name))))) (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)))))) + (and=> (false-if-exception (canonicalize-path abs-file-name)) + (lambda (canon) + (and=> (fallback-file-name canon) + (lambda (go-file-name) + (fresh-compiled-file-name abs-file-name + scmstat + go-file-name)))))) - (let ((compiled (and scmstat - (or (pre-compiled) (fallback))))) + (let ((compiled (and scmstat (or (pre-compiled) (fallback))))) (if compiled (begin (if %load-hook - (%load-hook abs-path)) + (%load-hook abs-file-name)) (load-compiled compiled)) (start-stack 'load-stack - (primitive-load abs-path))))) + (primitive-load abs-file-name))))) (save-module-excursion (lambda () (with-fluids ((current-reader reader) (%file-port-name-canonicalization 'relative)) (cond - ((absolute-path? path) - (load-absolute path)) - ((absolute-path? dir) - (load-absolute (in-vicinity dir path))) + ((absolute-file-name? file-name) + (load-absolute file-name)) + ((absolute-file-name? dir) + (load-absolute (in-vicinity dir file-name))) (else - (load-from-path (in-vicinity dir path)))))))) + (load-from-path (in-vicinity dir file-name)))))))) (define-syntax load (make-variable-transformer diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index a0d338cb0..2adb83ec6 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2955,10 +2955,10 @@ 'macro (lambda (x) (letrec* - ((absolute-path? (lambda (path) (string-prefix? "/" path))) - (read-file + ((read-file (lambda (fn dir k) - (let ((p (open-input-file (if (absolute-path? fn) fn (in-vicinity dir fn))))) + (let ((p (open-input-file + (if (absolute-file-name? fn) fn (in-vicinity dir fn))))) (let f ((x (read p)) (result '())) (if (eof-object? x) (begin (close-input-port p) (reverse result)) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 565c91199..336c8da96 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2929,13 +2929,10 @@ (define-syntax include (lambda (x) - (define (absolute-path? path) - (string-prefix? "/" path)) - (define read-file (lambda (fn dir k) (let ((p (open-input-file - (if (absolute-path? fn) + (if (absolute-file-name? fn) fn (in-vicinity dir fn))))) (let f ((x (read p)) From 0725031fe3a95d4e61e76ffa7aa1c79d4bebb00f Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Tue, 19 Feb 2013 15:09:32 +0100 Subject: [PATCH 007/147] add link to doc about UNC names * module/ice-9/boot-9.scm (compile-time-case): Add link to docs about UNC names. --- module/ice-9/boot-9.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 991eb3b40..e748eddb4 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1454,7 +1454,8 @@ VALUE." (define (absolute-file-name? file-name) (define (unc-file-name?) ;; Universal Naming Convention (UNC) file-names start with \\, - ;; and are always absolute. + ;; and are always absolute. See: + ;; http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#fully_qualified_vs._relative_paths (string-prefix? "\\\\" file-name)) (define (has-drive-specifier?) (and (>= (string-length file-name) 2) From 854ada4f1af8d72859b77e8764729f3cca45460a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii <eliz@gnu.org> Date: Tue, 19 Feb 2013 16:34:32 +0100 Subject: [PATCH 008/147] Fix startup of guile.exe on MS-Windows. * module/system/base/compile.scm (call-with-output-file/atomic): Call close-port before deleting the temporary file name, otherwise deletion fails on MS-Windows (cannot delete a file that is still open). --- module/system/base/compile.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index f3e464182..db05d1790 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -48,7 +48,7 @@ thunk (lambda () #t)))) -;; (put 'call-with-output-file/atomic 'scheme-indent-function 1) +;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1) (define* (call-with-output-file/atomic filename proc #:optional reference) (let* ((template (string-append filename ".XXXXXX")) (tmp (mkstemp! template))) @@ -61,6 +61,7 @@ (close-port tmp) (rename-file template filename)) (lambda args + (close-port tmp) (delete-file template))))))) (define (ensure-language x) From 5a4a4454c5302ed511eafde5a7759ebf00fbee17 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Tue, 19 Feb 2013 22:36:22 +0100 Subject: [PATCH 009/147] copy-file and load-objcode use O_BINARY * libguile/filesys.c (scm_copy_file): * libguile/objcodes.c (scm_load_objcode): Use O_BINARY. Thanks to Eli Zaretskii for the patch. --- libguile/filesys.c | 2 +- libguile/objcodes.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 94d824e85..2c4168eea 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1095,7 +1095,7 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, c_newfile = scm_to_locale_string (newfile); scm_dynwind_free (c_newfile); - oldfd = open_or_open64 (c_oldfile, O_RDONLY); + oldfd = open_or_open64 (c_oldfile, O_RDONLY | O_BINARY); if (oldfd == -1) SCM_SYSERROR; diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 004dd6118..a8515a7a2 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 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 License @@ -363,7 +363,7 @@ SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, SCM_VALIDATE_STRING (1, file); c_file = scm_to_locale_string (file); - fd = open (c_file, O_RDONLY | O_CLOEXEC); + fd = open (c_file, O_RDONLY | O_BINARY | O_CLOEXEC); free (c_file); if (fd < 0) SCM_SYSERROR; From e716f4410fb3f6c614def5a9b33a39185f637002 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Tue, 19 Feb 2013 23:03:19 +0100 Subject: [PATCH 010/147] fix an error message loading invalid bytecode * libguile/objcodes.c (make_objcode_from_file): Add correct error message if full_read failed without an errno. --- libguile/objcodes.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index a8515a7a2..e315f3e6e 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -220,7 +220,9 @@ make_objcode_from_file (int fd) int errno_save = errno; (void) close (fd); errno = errno_save; - SCM_SYSERROR; + if (errno) + SCM_SYSERROR; + scm_misc_error (FUNC_NAME, "file truncated while reading", SCM_EOL); } (void) close (fd); From 90f51aba0d2b28ac4819f8800f2dcf8d67edbd28 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Wed, 20 Feb 2013 16:02:30 +0100 Subject: [PATCH 011/147] fix compilation of functions with more than 255 local variables. * module/language/glil/compile-assembly.scm (glil->assembly): Fix case where there are more than 255 local variables. Whoops! --- module/language/glil/compile-assembly.scm | 53 +++++++++++------------ 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 767fda347..463348504 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -597,33 +597,32 @@ (else (error "what" op))) (let ((a (quotient index 256)) (b (modulo index 256))) - `((,(case op - ((ref) - (if boxed? - `((long-local-ref ,a ,b) - (variable-ref)) - `((long-local-ref ,a ,b)))) - ((set) - (if boxed? - `((long-local-ref ,a ,b) - (variable-set)) - `((long-local-set ,a ,b)))) - ((box) - `((make-variable) - (variable-set) - (long-local-set ,a ,b))) - ((empty-box) - `((make-variable) - (long-local-set ,a ,b))) - ((fix) - `((fix-closure ,a ,b))) - ((bound?) - (if boxed? - `((long-local-ref ,a ,b) - (variable-bound?)) - `((long-local-bound? ,a ,b)))) - (else (error "what" op))) - ,index)))) + (case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + ((fix) + `((fix-closure ,a ,b))) + ((bound?) + (if boxed? + `((long-local-ref ,a ,b) + (variable-bound?)) + `((long-local-bound? ,a ,b)))) + (else (error "what" op))))) `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) From 0e4288608896eeda4ad6f18cfe91d45be7c87c35 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Wed, 20 Feb 2013 21:20:55 +0100 Subject: [PATCH 012/147] mkstemp uses O_BINARY * libguile/mkstemp.c (mkstemp): Add O_BINARY. Since temp files are empty at the beginning, we're not changing the behavior for reading files. For writing files `newline' and ~% can add \r elements as needed. So this is a reasonable thing to do, and it prevents mangling of temp files for the compiler. --- libguile/mkstemp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c index 6a573c695..a7eaf105b 100644 --- a/libguile/mkstemp.c +++ b/libguile/mkstemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013 Free Software Foundation, Inc. This file is derived from mkstemps.c from the GNU Libiberty Library which in turn is derived from the GNU C Library. @@ -112,7 +112,7 @@ mkstemp (template) v /= 62; XXXXXX[5] = letters[v % 62]; - fd = open (template, O_RDWR|O_CREAT|O_EXCL, 0600); + fd = open (template, O_RDWR|O_CREAT|O_EXCL|O_BINARY, 0600); if (fd >= 0) /* The file does not exist. */ return fd; From f5ea559aa04186534ea6771e3c15d5201fe85c67 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Wed, 20 Feb 2013 22:57:02 +0100 Subject: [PATCH 013/147] net_db.c doesn't import winsock2.h * libguile/net_db.c: Don't include winsock2.h; gnulib handles this for us as necessary. --- libguile/net_db.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/libguile/net_db.c b/libguile/net_db.c index 4d63aabcc..8dccb723a 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -1,6 +1,6 @@ /* "net_db.c" network database support * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2006, 2009, - * 2010, 2011, 2012 Free Software Foundation, Inc. + * 2010, 2011, 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 License @@ -50,14 +50,10 @@ #include <sys/types.h> -#ifdef HAVE_WINSOCK2_H -#include <winsock2.h> -#else #include <sys/socket.h> #include <netdb.h> #include <netinet/in.h> #include <arpa/inet.h> -#endif #ifdef __MINGW32__ #include "win32-socket.h" From 99d1843e2a06f422cbe349804a67d2972c4dedd9 Mon Sep 17 00:00:00 2001 From: Mike Gran <spk121@yahoo.com> Date: Thu, 21 Feb 2013 06:44:42 -0800 Subject: [PATCH 014/147] Update predefined character sets to Unicode 6.2 * libguile/srfi-14.i.c (cs_graphic_ranges, cs_printing_ranges, cs_symbol_ranges) (cs_designated_ranges): modified --- libguile/srfi-14.i.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c index f59a8071c..42a1c2cf2 100644 --- a/libguile/srfi-14.i.c +++ b/libguile/srfi-14.i.c @@ -4790,7 +4790,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x2090, 0x209c} , - {0x20a0, 0x20b9} + {0x20a0, 0x20ba} , {0x20d0, 0x20f0} , @@ -5906,7 +5906,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x2090, 0x209c} , - {0x20a0, 0x20b9} + {0x20a0, 0x20ba} , {0x20d0, 0x20f0} , @@ -6897,7 +6897,7 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x208a, 0x208c} , - {0x20a0, 0x20b9} + {0x20a0, 0x20ba} , {0x2100, 0x2101} , @@ -7728,7 +7728,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x2090, 0x209c} , - {0x20a0, 0x20b9} + {0x20a0, 0x20ba} , {0x20d0, 0x20f0} , From eaf21539d4afb8df5d1b549215fd397b23004947 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 12:46:48 +0100 Subject: [PATCH 015/147] random_state_of_last_resort doesn't rely on HAVE_POSIX * libguile/random.c (random_state_of_last_resort): Add the PID as a seed only if we have scm_getpid(). --- libguile/random.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/libguile/random.c b/libguile/random.c index 2db19f729..a85ee8147 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 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 License * as published by the Free Software Foundation; either version 3 of @@ -665,15 +665,18 @@ random_state_of_last_resort (void) SCM time_of_day = scm_gettimeofday (); SCM sources = scm_list_n (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */ - scm_getpid (), /* process ID */ scm_get_internal_real_time (), /* high-resolution process timer */ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */ scm_cdr (time_of_day), /* microsecond component of the above clock */ SCM_UNDEFINED); + SCM seed = SCM_INUM0; + +#ifdef HAVE_POSIX + sources = scm_cons (scm_getpid (), sources); /* process ID */ +#endif /* Concatenate the sources bitwise to form the seed */ - SCM seed = SCM_INUM0; while (scm_is_pair (sources)) { seed = scm_logxor (seed, scm_ash (scm_car (sources), From 65fa3923060dd66b166fd858bcd6f462f37ee8c0 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 13:03:42 +0100 Subject: [PATCH 016/147] allow '/' in the prefix of UNC file names on windows * module/ice-9/boot-9.scm (absolute-file-name?) [WINDOWS]: Allow '/' as well as '\' when detecting UNC names. (load-in-vicinity): Add a comment about the purpose of canonical->suffix. --- module/ice-9/boot-9.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index e748eddb4..067d672cf 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1452,20 +1452,21 @@ VALUE." (define file-name-separator-string "\\") (define (absolute-file-name? file-name) + (define (file-name-separator-at-index? idx) + (and (> (string-length file-name) idx) + (file-name-separator? (string-ref file-name idx)))) (define (unc-file-name?) ;; Universal Naming Convention (UNC) file-names start with \\, ;; and are always absolute. See: ;; http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#fully_qualified_vs._relative_paths - (string-prefix? "\\\\" file-name)) + (and (file-name-separator-at-index? 0) + (file-name-separator-at-index? 1))) (define (has-drive-specifier?) (and (>= (string-length file-name) 2) (let ((drive (string-ref file-name 0))) (or (char<=? #\a drive #\z) (char<=? #\A drive #\Z))) (eqv? (string-ref file-name 1) #\:))) - (define (file-name-separator-at-index? idx) - (and (> (string-length file-name) idx) - (file-name-separator? (string-ref file-name idx)))) (or (unc-file-name?) (if (has-drive-specifier?) (file-name-separator-at-index? 2) @@ -3694,6 +3695,10 @@ CONV is not applied to the initial value." pre-compiled version of FILE-NAME when available, and auto-compile one when none is available, reading FILE-NAME with READER." + ;; The auto-compilation code will residualize a .go file in the cache + ;; dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This + ;; function determines the PATH to use as a key into the compilation + ;; cache. (define (canonical->suffix canon) (cond ((and (not (string-null? canon)) From 4bab7f01be8a1ce321f1e30235e1077f1ea0804c Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 13:48:02 +0100 Subject: [PATCH 017/147] load.c uses same logic as boot-9 for file names * libguile/load.c (is_file_name_separator, is_drive_letter): (is_absolute_file_name): New helpers, like the ones in boot-9. Perhaps we should just define them in C. (search_path, scm_try_auto_compile, canonical_suffix): Rewrite using the new helpers. --- libguile/load.c | 112 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 80 insertions(+), 32 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 84b670549..f2af6c83b 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -447,6 +447,58 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) return 0; } +#ifdef __MINGW32__ +#define FILE_NAME_SEPARATOR_STRING "\\" +#else +#define FILE_NAME_SEPARATOR_STRING "/" +#endif + +static int +is_file_name_separator (SCM c) +{ + if (c == SCM_MAKE_CHAR ('/')) + return 1; +#ifdef __MINGW32__ + if (c == SCM_MAKE_CHAR ('\\')) + return 1; +#endif + return 0; +} + +static int +is_drive_letter (SCM c) +{ +#ifdef __MINGW32__ + if (SCM_CHAR (c) >= 'a' && SCM_CHAR (c) <= 'z') + return 1; + else if (SCM_CHAR (c) >= 'A' && SCM_CHAR (c) <= 'Z') + return 1; +#endif + return 0; +} + +static int +is_absolute_file_name (const char *filename_chars, size_t filename_len) +{ + if (filename_len >= 1 + && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[0])) +#ifdef __MINGW32__ + /* On Windows, one initial separator indicates a drive-relative + path. Two separators indicate a Universal Naming Convention + (UNC) path. UNC paths are always absolute. */ + && filename_len >= 2 + && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[1])) +#endif + ) + return 1; + if (filename_len >= 3 + && is_drive_letter (SCM_MAKE_CHAR (filename_chars[0])) + && filename_chars[1] == ':' + && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[2]))) + return 1; + return 0; +} + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full pathname; otherwise, return #f. @@ -477,16 +529,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, scm_dynwind_free (filename_chars); /* If FILENAME is absolute and is still valid, return it unchanged. */ -#ifdef __MINGW32__ - if (((filename_len >= 1) && - (filename_chars[0] == '/' || filename_chars[0] == '\\')) || - ((filename_len >= 3) && filename_chars[1] == ':' && - ((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') || - (filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) && - (filename_chars[2] == '/' || filename_chars[2] == '\\'))) -#else - if (filename_len >= 1 && filename_chars[0] == '/') -#endif + if (is_absolute_file_name (filename_chars, filename_len)) { if ((scm_is_false (require_exts) || scm_c_string_has_an_ext (filename_chars, filename_len, @@ -520,11 +563,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, extensions = SCM_EOL; break; } -#ifdef __MINGW32__ - else if (*endp == '/' || *endp == '\\') -#else - else if (*endp == '/') -#endif + else if (is_file_name_separator (SCM_MAKE_CHAR (*endp))) /* This filename has no extension, so keep the current list of extensions. */ break; @@ -553,12 +592,9 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, /* Concatenate the path name and the filename. */ -#ifdef __MINGW32__ - if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\')) -#else - if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/')) -#endif - stringbuf_cat (&buf, "/"); + if (buf.ptr > buf.buf + && !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1]))) + stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING); stringbuf_cat (&buf, filename_chars); sans_ext_len = buf.ptr - buf.buf; @@ -823,24 +859,36 @@ scm_try_auto_compile (SCM source) NULL, NULL); } -/* See also (system base compile):compiled-file-name. */ +/* The auto-compilation code will residualize a .go file in the cache + dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This + function determines the PATH to use as a key into the compilation + cache. See also (system base compile):compiled-file-name. */ static SCM canonical_suffix (SCM fname) { SCM canon; - size_t len; + /* CANON should be absolute. */ canon = scm_canonicalize_path (fname); - len = scm_c_string_length (canon); - if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/'))) - return canon; - else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':'))) - return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"), - scm_c_substring (canon, 0, 1), - scm_c_substring (canon, 2, len))); - else - return canon; +#ifdef __MINGW32__ + { + size_t len = scm_c_string_length (canon); + + /* On Windows, an absolute file name that doesn't start with a + separator starts with a drive component. Transform the drive + component to a file name element: c:\foo -> \c\foo. */ + if (len >= 2 + && is_absolute_file_name (canon) + && !is_file_name_separator (scm_c_string_ref (canon, 0))) + return scm_string_append + (scm_list_3 (scm_from_latin1_string (FILE_NAME_SEPARATOR_STRING), + scm_c_substring (canon, 0, 1), + scm_c_substring (canon, 2, len))); + } +#endif + + return canon; } SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, From c21939bc247e2e36a5d698c60ba4a03cd3bbaf38 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 14:07:13 +0100 Subject: [PATCH 018/147] simplify scm_stat on mingw * libguile/filesys.c (scm_stat): Don't munge the filename on MinGW; gnulib does that for us. --- libguile/filesys.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 2c4168eea..422a44cac 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -541,12 +541,6 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, else if (scm_is_string (object)) { char *file = scm_to_locale_string (object); -#ifdef __MINGW32__ - char *p; - p = file + strlen (file) - 1; - while (p > file && (*p == '/' || *p == '\\')) - *p-- = '\0'; -#endif SCM_SYSCALL (rv = stat_or_stat64 (file, &stat_temp)); free (file); } From 7a17979ea4ae769c60ca4ca291cca877701c08e1 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 14:15:06 +0100 Subject: [PATCH 019/147] cleanup to filesys.c's handling of file name separators * libguile/filesys.c (is_file_name_separator): New helper, as in load.c. (scm_dirname, scm_basename, scm_i_relativize_path): Use is_file_name_separator. --- libguile/filesys.c | 71 ++++++++++++++-------------------------------- 1 file changed, 22 insertions(+), 49 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 422a44cac..f7c83e00f 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -460,6 +460,18 @@ static int fstat_Win32 (int fdes, struct stat *buf) } #endif /* __MINGW32__ */ +static int +is_file_name_separator (SCM c) +{ + if (c == SCM_MAKE_CHAR ('/')) + return 1; +#ifdef __MINGW32__ + if (c == SCM_MAKE_CHAR ('\\')) + return 1; +#endif + return 0; +} + SCM_DEFINE (scm_stat, "stat", 1, 1, 0, (SCM object, SCM exception_on_error), "Return an object containing various information about the file\n" @@ -1461,32 +1473,17 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, len = scm_i_string_length (filename); i = len - 1; -#ifdef __MINGW32__ - while (i >= 0 && (scm_i_string_ref (filename, i) == '/' - || scm_i_string_ref (filename, i) == '\\')) + + while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i))) --i; - while (i >= 0 && (scm_i_string_ref (filename, i) != '/' - && scm_i_string_ref (filename, i) != '\\')) + while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i))) --i; - while (i >= 0 && (scm_i_string_ref (filename, i) == '/' - || scm_i_string_ref (filename, i) == '\\')) + while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i))) --i; -#else - while (i >= 0 && scm_i_string_ref (filename, i) == '/') - --i; - while (i >= 0 && scm_i_string_ref (filename, i) != '/') - --i; - while (i >= 0 && scm_i_string_ref (filename, i) == '/') - --i; -#endif /* ndef __MINGW32__ */ + if (i < 0) { -#ifdef __MINGW32__ - if (len > 0 && (scm_i_string_ref (filename, 0) == '/' - || scm_i_string_ref (filename, 0) == '\\')) -#else - if (len > 0 && scm_i_string_ref (filename, 0) == '/') -#endif /* ndef __MINGW32__ */ + if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0))) return scm_c_substring (filename, 0, 1); else return scm_dot_string; @@ -1517,14 +1514,8 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, j = scm_i_string_length (suffix) - 1; } i = len - 1; -#ifdef __MINGW32__ - while (i >= 0 && (scm_i_string_ref (filename, i) == '/' - || scm_i_string_ref (filename, i) == '\\')) + while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i))) --i; -#else - while (i >= 0 && scm_i_string_ref (filename, i) == '/') - --i; -#endif /* ndef __MINGW32__ */ end = i; while (i >= 0 && j >= 0 && (scm_i_string_ref (filename, i) @@ -1535,22 +1526,11 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, } if (j == -1) end = i; -#ifdef __MINGW32__ - while (i >= 0 && (scm_i_string_ref (filename, i) != '/' - && scm_i_string_ref (filename, i) != '\\')) + while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i))) --i; -#else - while (i >= 0 && scm_i_string_ref (filename, i) != '/') - --i; -#endif /* ndef __MINGW32__ */ if (i == end) { -#ifdef __MINGW32__ - if (len > 0 && (scm_i_string_ref (filename, 0) == '/' - || scm_i_string_ref (filename, 0) == '\\')) -#else - if (len > 0 && scm_i_string_ref (filename, 0) == '/') -#endif /* ndef __MINGW32__ */ + if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0))) return scm_c_substring (filename, 0, 1); else return scm_dot_string; @@ -1617,14 +1597,7 @@ scm_i_relativize_path (SCM path, SCM in_path) will be delimited by single delimiters. When DIR does not have a trailing delimiter, add one to the length to strip off the delimiter within SCANON. */ - if ( -#ifdef __MINGW32__ - (scm_i_string_ref (dir, len - 1) != '/' - && scm_i_string_ref (dir, len - 1) != '\\') -#else - scm_i_string_ref (dir, len - 1) != '/' -#endif - ) + if (!is_file_name_separator (scm_c_string_ref (dir, len - 1))) len++; if (scm_c_string_length (scanon) > len) From 1746b8ffdba174fde4a8e293309a18d112750588 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig <mandyke@gmail.com> Date: Thu, 29 Nov 2012 00:17:26 +0800 Subject: [PATCH 020/147] fix and update (ice-9 mapping) * module/ice-9/mapping.scm (mapping-create-handle!): INIT is required. (mapping-ref): Rewrite. Fix problem with DFLT. (hash-table-mapping-hooks): Drop DELETE-PROC, hash-table accessors only use ASSOC-PROC. Add INIT to create-handle hook. Use correct hash-table accessors. (make-hash-table-mapping): Drop DELETE-PROC. (hash-table-mapping): Rewrite. Drop DELETE-PROC. --- module/ice-9/mapping.scm | 73 +++++++++++++++++----------------------- 1 file changed, 30 insertions(+), 43 deletions(-) diff --git a/module/ice-9/mapping.scm b/module/ice-9/mapping.scm index 2907a8d89..74e98e783 100644 --- a/module/ice-9/mapping.scm +++ b/module/ice-9/mapping.scm @@ -50,16 +50,15 @@ (define (mapping-get-handle map key) ((mapping-hooks-get-handle (mapping-hooks map)) map key)) -(define (mapping-create-handle! map key . opts) - (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts)) +(define (mapping-create-handle! map key init) + ((mapping-hooks-create-handle (mapping-hooks map)) map key init)) (define (mapping-remove! map key) ((mapping-hooks-remove (mapping-hooks map)) map key)) -(define (mapping-ref map key . dflt) +(define* (mapping-ref map key #:optional dflt) (cond - ((mapping-get-handle map key) => cdr) - (dflt => car) - (else #f))) + ((mapping-get-handle map key) => cdr) + (else dflt))) (define (mapping-set! map key val) (set-cdr! (mapping-create-handle! map key #f) val)) @@ -70,18 +69,18 @@ (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest))))) (perfect-funcq 17 - (lambda (hash-proc assoc-proc delete-proc) - (let ((procs (list hash-proc assoc-proc delete-proc))) + (lambda (hash-proc assoc-proc) + (let ((procs (list hash-proc assoc-proc))) (cond - ((equal? procs `(,hashq ,assq ,delq!)) + ((equal? procs `(,hashq ,assq)) (make-mapping-hooks (wrap hashq-get-handle) (wrap hashq-create-handle!) (wrap hashq-remove!))) - ((equal? procs `(,hashv ,assv ,delv!)) + ((equal? procs `(,hashv ,assv)) (make-mapping-hooks (wrap hashv-get-handle) (wrap hashv-create-handle!) (wrap hashv-remove!))) - ((equal? procs `(,hash ,assoc ,delete!)) + ((equal? procs `(,hash ,assoc)) (make-mapping-hooks (wrap hash-get-handle) (wrap hash-create-handle!) (wrap hash-remove!))) @@ -90,39 +89,27 @@ (lambda (table key) (hashx-get-handle hash-proc assoc-proc table key))) (wrap - (lambda (table key) - (hashx-create-handle hash-proc assoc-proc table key))) + (lambda (table key init) + (hashx-create-handle! hash-proc assoc-proc table key init))) (wrap (lambda (table key) - (hashx-get-handle hash-proc assoc-proc delete-proc table key))))))))))) + (hashx-remove! hash-proc assoc-proc table key))))))))))) -(define (make-hash-table-mapping table hash-proc assoc-proc delete-proc) - (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table)) - -(define (hash-table-mapping . options) - (let* ((size (or (and options (number? (car options)) (car options)) - 71)) - (hash-proc (or (kw-arg-ref options #:hash-proc) hash)) - (assoc-proc (or (kw-arg-ref options #:assoc-proc) - (cond - ((eq? hash-proc hash) assoc) - ((eq? hash-proc hashv) assv) - ((eq? hash-proc hashq) assq) - (else (error 'hash-table-mapping - "Hash-procedure specified with no known assoc function." - hash-proc))))) - (delete-proc (or (kw-arg-ref options #:delete-proc) - (cond - ((eq? hash-proc hash) delete!) - ((eq? hash-proc hashv) delv!) - ((eq? hash-proc hashq) delq!) - (else (error 'hash-table-mapping - "Hash-procedure specified with no known delete function." - hash-proc))))) - (table-constructor (or (kw-arg-ref options #:table-constructor) - (lambda (len) (make-vector len '()))))) - (make-hash-table-mapping (table-constructor size) - hash-proc - assoc-proc - delete-proc))) +(define (make-hash-table-mapping table hash-proc assoc-proc) + (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc) table)) +(define* (hash-table-mapping #:optional (size 71) #:key + (hash-proc hash) + (assoc-proc + (or (assq-ref `((,hashq . ,assq) + (,hashv . ,assv) + (,hash . ,assoc)) + hash-proc) + (error 'hash-table-mapping + "Hash-procedure specified with no known assoc function." + hash-proc))) + (table-constructor + (lambda (len) (make-vector len '())))) + (make-hash-table-mapping (table-constructor size) + hash-proc + assoc-proc)) From 72ad03fcbddb3b87de5577b7225f6dc6f892ac93 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 15:11:14 +0100 Subject: [PATCH 021/147] deprecate (ice-9 mapping) * module/ice-9/mapping.scm: Add deprecation warning. --- module/ice-9/mapping.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/module/ice-9/mapping.scm b/module/ice-9/mapping.scm index 74e98e783..bd4dbfbd3 100644 --- a/module/ice-9/mapping.scm +++ b/module/ice-9/mapping.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1996, 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 2001, 2006, 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 @@ -29,6 +29,9 @@ mapping-ref mapping-set! hash-table-mapping-hooks make-hash-table-mapping hash-table-mapping)) +(issue-deprecation-warning + "(ice-9 mapping) is deprecated. Use srfi-69 or rnrs hash tables instead.") + (define mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle create-handle remove))) From c085589b1c34fa88d28c23cb5e3659fecdb09f33 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sun, 24 Feb 2013 15:45:26 +0100 Subject: [PATCH 022/147] remove language/glil/decompile-assembly.scm * module/language/glil/decompile-assembly.scm: Remove. This module never worked, and even failed to compile. * module/language/glil/spec.scm: * module/Makefile.am: Remove references to (language glil decompile-assembly). --- module/Makefile.am | 3 +- module/language/glil/decompile-assembly.scm | 191 -------------------- module/language/glil/spec.scm | 2 - 3 files changed, 1 insertion(+), 195 deletions(-) delete mode 100644 module/language/glil/decompile-assembly.scm diff --git a/module/Makefile.am b/module/Makefile.am index 472bc4838..79957c1b8 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -112,8 +112,7 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/spec.scm GLIL_LANG_SOURCES = \ - language/glil/spec.scm language/glil/compile-assembly.scm \ - language/glil/decompile-assembly.scm + language/glil/spec.scm language/glil/compile-assembly.scm ASSEMBLY_LANG_SOURCES = \ language/assembly/spec.scm \ diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm deleted file mode 100644 index a50b640ec..000000000 --- a/module/language/glil/decompile-assembly.scm +++ /dev/null @@ -1,191 +0,0 @@ -;;; Guile VM code converters - -;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language glil decompile-assembly) - #:use-module (system base pmatch) - #:use-module (system vm program) - #:use-module (language assembly) - #:use-module (language glil) - #:export (decompile-assembly)) - -(define (decompile-assembly x env opts) - (values (decompile-toplevel x) - env)) - -(define (decompile-toplevel x) - (pmatch x - ((load-program ,labels ,len ,meta . ,body) - (decompile-load-program (decompile-meta meta) - body labels #f)) - (else - (error "invalid assembly" x)))) - -(define (decompile-meta meta) - (and meta - (let ((prog (decompile-toplevel meta))) - (if (and (glil-program? prog) - (= (length (glil-program-body prog)) 2) - (glil-const? (car (glil-program-body prog)))) - (glil-const-obj (car (glil-program-body prog))) - (error "metadata not a thunk returning a const" prog))))) - -(define *placeholder* (list 'placeholder)) - -(define (emit-constants l out) - (let lp ((in (reverse l)) (out out)) - (cond ((null? in) out) - ((eq? (car in) *placeholder*) (lp (cdr in) out)) - ((glil-program? (car in)) (lp (cdr in) (cons (car in) out))) - (else (lp (cdr in) (cons (make-glil-const (car l)) out)))))) - -(define (decompile-load-program meta body labels - objects) - (let ((glil-labels (sort (map (lambda (x) - (cons (cdr x) (make-glil-label (car x)))) - labels) - (lambda (x y) (< (car x) (car y))))) - (bindings (sort (if meta (car meta) '()) - (lambda (x y) (< (binding:start x) (binding:start y))))) - (unbindings (sort (if meta (car meta) '()) - (lambda (x y) (< (binding:end x) (binding:end y))))) - (sources (if meta (cadr meta) '())) - (filename #f) - (props (if meta (cddr meta) '()))) - (define (pop-bindings! addr) - (let lp ((in bindings) (out '())) - (if (or (null? in) (> (binding:start (car in)) addr)) - (begin - (set! bindings in) - (if (null? out) #f (reverse out))) - (lp (cdr in) (cons (car in) out))))) - (define (pop-unbindings! addr) - (let lp ((in unbindings) (out '())) - (if (or (null? in) (> (binding:end (car in)) addr)) - (begin - (set! unbindings in) - (if (null? out) #f (reverse out))) - (lp (cdr in) (cons (car in) out))))) - (define (pop-source! addr) - ;; a fragile algorithm. - (cond ((null? sources) #f) - ((eq? (caar sources) 'filename) - (set! filename (cdar sources)) - (pop-source! addr)) - ((eqv? (caar sources) addr) - (let ((x (car sources))) - (set! sources (cdr sources)) - `((filename . ,filename) - (line . ,(cadr x)) - (column . ,(cddr x))))) - (else #f))) - (let lp ((in body) (stack '()) (out '()) (pos 0)) - (cond - ((null? in) - (or (null? stack) (error "leftover stack insts" stack body)) - (make-glil-program props (reverse out))) - ((pop-bindings! pos) - => (lambda (bindings) - (lp in stack - (cons (make-glil-bind bindings) - out) - pos))) - ((pop-unbindings! pos) - => (lambda (bindings) - (lp in stack (cons (make-glil-unbind) out) pos))) - ((pop-source! pos) - => (lambda (s) - (lp in stack (cons (make-glil-source s) out) pos))) - ((and (or (null? out) (not (glil-label? (car out)))) - (assv-ref glil-labels pos)) - => (lambda (label) - (lp in stack (cons label out) pos))) - (else - (pmatch (car in) - ((nop) - (lp (cdr in) stack out (1+ pos))) - ((make-false) - (lp (cdr in) (cons #f stack) out (1+ pos))) - ((make-nil) - (lp (cdr in) (cons #nil stack) out (1+ pos))) - ((load-program ,labels ,sublen ,meta . ,body) - (lp (cdr in) - (cons (decompile-load-program (decompile-meta meta) - body labels (car stack)) - (cdr stack)) - out - (+ pos (byte-length (car in))))) - ((load-symbol ,str) - (lp (cdr in) (cons (string->symbol str) stack) out - (+ pos 1 (string-length str)))) - ((make-int8:0) - (lp (cdr in) (cons 0 stack) out (1+ pos))) - ((make-int8:1) - (lp (cdr in) (cons 1 stack) out (1+ pos))) - ((make-int8 ,n) - (lp (cdr in) (cons n stack) out (+ pos 2))) - ((cons) - (let ((head (list-head stack 2)) - (stack (list-tail stack 2))) - (if (memq *placeholder* head) - (lp (cdr in) (cons *placeholder* stack) - (cons (make-glil-call 'cons 2) (emit-constants head out)) - (+ pos 1)) - (lp (cdr in) (cons (cons (cadr head) (car head)) stack) - out (+ pos 3))))) - ((list ,a ,b) - (let* ((len (+ (ash a 8) b)) - (head (list-head stack len)) - (stack (list-tail stack len))) - (if (memq *placeholder* head) - (lp (cdr in) (cons *placeholder* stack) - (cons (make-glil-call 'list len) (emit-constants head out)) - (+ pos 3)) - (lp (cdr in) (cons (reverse head) stack) out (+ pos 3))))) - ((make-eol) - (lp (cdr in) (cons '() stack) out (1+ pos))) - ((return) - (lp (cdr in) (cdr stack) - (cons (make-glil-call 'return 1) - (emit-constants (list-head stack 1) out)) - (1+ pos))) - ((local-ref ,n) - (lp (cdr in) (cons *placeholder* stack) - (cons (make-glil-local 'ref n) - out) (+ pos 2))) - ((local-set ,n) - (lp (cdr in) (cdr stack) - (cons (make-glil-local 'set n) - (emit-constants (list-head stack 1) out)) - (+ pos 2))) - ((br-if-not ,l) - (lp (cdr in) (cdr stack) - (cons (make-glil-branch 'br-if-not l) out) - (+ pos 3))) - ((mul) - (lp (cdr in) (cons *placeholder* (cddr stack)) - (cons (make-glil-call 'mul 2) - (emit-constants (list-head stack 2) out)) - (+ pos 1))) - ((tail-call ,n) - (lp (cdr in) (list-tail stack (1+ n)) - (cons (make-glil-call 'tail-call n) - (emit-constants (list-head stack (1+ n)) out)) - (+ pos 2))) - (else (error "unsupported decompilation" (car in))))))))) diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index 3679e2166..81e06af5d 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -22,7 +22,6 @@ #:use-module (system base language) #:use-module (language glil) #:use-module (language glil compile-assembly) - #:use-module (language glil decompile-assembly) #:export (glil)) (define (write-glil exp . port) @@ -37,6 +36,5 @@ #:printer write-glil #:parser parse-glil #:compilers `((assembly . ,compile-asm)) - #:decompilers `((assembly . ,decompile-assembly)) #:for-humans? #f ) From 08904661a2b1c6d461b2f5abfe3226a4023453fb Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sun, 24 Feb 2013 19:57:00 -0500 Subject: [PATCH 023/147] random-state-from-platform: simplify pid conditional, and clarify docs. * libguile/random.c (random_state_of_last_resort): Simplify optional inclusion of PID in the random state. Clarify in the comments that the PID is only included where scm_getpid is present. * doc/ref/api-data.texi (Random): Clarify that 'random-state-from-platform' includes the PID in the random state only if scm_getpid is present. --- doc/ref/api-data.texi | 6 +++--- libguile/random.c | 17 ++++++++--------- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 9da17d8c3..e17c0c27d 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1872,9 +1872,9 @@ read back with the Scheme reader. Construct a new random state seeded from a platform-specific source of entropy, appropriate for use in non-security-critical applications. Currently @file{/dev/urandom} is tried first, or else the seed is based -on the time, date, process ID, an address from a freshly allocated heap -cell, an address from the local stack frame, and a high-resolution timer -if available. +on the time, date, process ID (if scm_getpid is present), an address +from a freshly allocated heap cell, an address from the local stack +frame, and a high-resolution timer if available. @end deffn @defvar *random-state* diff --git a/libguile/random.c b/libguile/random.c index a85ee8147..9cb5e6937 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -653,11 +653,11 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, } #undef FUNC_NAME -/* Return a new random-state seeded from the time, date, process ID, an - address from a freshly allocated heap cell, an address from the local - stack frame, and a high-resolution timer if available. This is only - to be used as a last resort, when no better source of entropy is - available. */ +/* Return a new random-state seeded from the time, date, process ID (if + scm_getpid is present), an address from a freshly allocated heap + cell, an address from the local stack frame, and a high-resolution + timer if available. This is only to be used as a last resort, when + no better source of entropy is available. */ static SCM random_state_of_last_resort (void) { @@ -665,6 +665,9 @@ random_state_of_last_resort (void) SCM time_of_day = scm_gettimeofday (); SCM sources = scm_list_n (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */ +#ifdef HAVE_POSIX + scm_getpid (), /* process ID */ +#endif scm_get_internal_real_time (), /* high-resolution process timer */ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */ @@ -672,10 +675,6 @@ random_state_of_last_resort (void) SCM_UNDEFINED); SCM seed = SCM_INUM0; -#ifdef HAVE_POSIX - sources = scm_cons (scm_getpid (), sources); /* process ID */ -#endif - /* Concatenate the sources bitwise to form the seed */ while (scm_is_pair (sources)) { From 444b26f739d88ab410d561f1abda67b3d6c0f491 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 25 Feb 2013 13:33:14 -0500 Subject: [PATCH 024/147] Revert "random-state-from-platform: simplify pid conditional, and clarify docs." This reverts commit 08904661a2b1c6d461b2f5abfe3226a4023453fb. --- doc/ref/api-data.texi | 6 +++--- libguile/random.c | 17 +++++++++-------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index e17c0c27d..9da17d8c3 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1872,9 +1872,9 @@ read back with the Scheme reader. Construct a new random state seeded from a platform-specific source of entropy, appropriate for use in non-security-critical applications. Currently @file{/dev/urandom} is tried first, or else the seed is based -on the time, date, process ID (if scm_getpid is present), an address -from a freshly allocated heap cell, an address from the local stack -frame, and a high-resolution timer if available. +on the time, date, process ID, an address from a freshly allocated heap +cell, an address from the local stack frame, and a high-resolution timer +if available. @end deffn @defvar *random-state* diff --git a/libguile/random.c b/libguile/random.c index 9cb5e6937..a85ee8147 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -653,11 +653,11 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, } #undef FUNC_NAME -/* Return a new random-state seeded from the time, date, process ID (if - scm_getpid is present), an address from a freshly allocated heap - cell, an address from the local stack frame, and a high-resolution - timer if available. This is only to be used as a last resort, when - no better source of entropy is available. */ +/* Return a new random-state seeded from the time, date, process ID, an + address from a freshly allocated heap cell, an address from the local + stack frame, and a high-resolution timer if available. This is only + to be used as a last resort, when no better source of entropy is + available. */ static SCM random_state_of_last_resort (void) { @@ -665,9 +665,6 @@ random_state_of_last_resort (void) SCM time_of_day = scm_gettimeofday (); SCM sources = scm_list_n (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */ -#ifdef HAVE_POSIX - scm_getpid (), /* process ID */ -#endif scm_get_internal_real_time (), /* high-resolution process timer */ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */ @@ -675,6 +672,10 @@ random_state_of_last_resort (void) SCM_UNDEFINED); SCM seed = SCM_INUM0; +#ifdef HAVE_POSIX + sources = scm_cons (scm_getpid (), sources); /* process ID */ +#endif + /* Concatenate the sources bitwise to form the seed */ while (scm_is_pair (sources)) { From 3ec19a7884ba789a9b4f91f61415aa4b84642690 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 25 Feb 2013 13:33:28 -0500 Subject: [PATCH 025/147] Revert "random_state_of_last_resort doesn't rely on HAVE_POSIX" This reverts commit eaf21539d4afb8df5d1b549215fd397b23004947. --- libguile/random.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/libguile/random.c b/libguile/random.c index a85ee8147..2db19f729 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 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 @@ -665,18 +665,15 @@ random_state_of_last_resort (void) SCM time_of_day = scm_gettimeofday (); SCM sources = scm_list_n (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */ + scm_getpid (), /* process ID */ scm_get_internal_real_time (), /* high-resolution process timer */ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */ scm_cdr (time_of_day), /* microsecond component of the above clock */ SCM_UNDEFINED); - SCM seed = SCM_INUM0; - -#ifdef HAVE_POSIX - sources = scm_cons (scm_getpid (), sources); /* process ID */ -#endif /* Concatenate the sources bitwise to form the seed */ + SCM seed = SCM_INUM0; while (scm_is_pair (sources)) { seed = scm_logxor (seed, scm_ash (scm_car (sources), From 587f4edd3947880fb0235f84cc18b62f133a9255 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 25 Feb 2013 13:38:55 -0500 Subject: [PATCH 026/147] random_state_of_last_resort: use getpid directly, instead of scm_getpid * libguile/random.c: Include <sys/types.h> and <unistd.h> (if present). (random_state_of_last_resort): Use getpid directly. --- libguile/random.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/libguile/random.c b/libguile/random.c index 2db19f729..f97213b86 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -17,7 +17,7 @@ -/* Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */ +/* Original Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */ #ifdef HAVE_CONFIG_H # include <config.h> @@ -29,6 +29,12 @@ #include <stdio.h> #include <math.h> #include <string.h> +#include <sys/types.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + #include "libguile/smob.h" #include "libguile/numbers.h" #include "libguile/feature.h" @@ -665,7 +671,8 @@ random_state_of_last_resort (void) SCM time_of_day = scm_gettimeofday (); SCM sources = scm_list_n (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */ - scm_getpid (), /* process ID */ + /* Avoid scm_getpid, since it depends on HAVE_POSIX. */ + scm_from_unsigned_integer (getpid ()), /* process ID */ scm_get_internal_real_time (), /* high-resolution process timer */ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */ From be6a36a05d79662243c384212032783cffab5316 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 25 Feb 2013 22:14:41 -0500 Subject: [PATCH 027/147] Update copyright dates on random.c * libguile/random.c: Add 2012 and 2013 to the copyright notice. --- libguile/random.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/random.c b/libguile/random.c index f97213b86..c0b04bc05 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1999, 2000, 2001, 2003, 2005, 2006, 2009, 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 License * as published by the Free Software Foundation; either version 3 of From 94a7029acf5ca59615bb486b1e9e196e572df6f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Feb 2013 19:25:39 +0100 Subject: [PATCH 028/147] Fix cross-compilation of `c-tokenize.o'. * libguile/Makefile.am (c-tokenize.$(OBJEXT)): Pass -I$(top_builddir) when cross-compiling. --- libguile/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index f020595e2..0a401206f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -93,7 +93,7 @@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c c-tokenize.$(OBJEXT): c-tokenize.c $(AM_V_GEN) \ if [ "$(cross_compiling)" = "yes" ]; then \ - $(CC_FOR_BUILD) -c -o $@ $<; \ + $(CC_FOR_BUILD) -I$(top_builddir) -c -o $@ $<; \ else \ $(COMPILE) -c -o $@ $<; \ fi From 4124994771e8fe54557a7af85e2af9c68e6ea2a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Feb 2013 19:59:09 +0100 Subject: [PATCH 029/147] tests: Avoid missing missing-prototype warning with <fenv.h> on glibc 2.17. * test-suite/standalone/test-round.c: Avoid missing-prototype warning with <fenv.h> on glibc 2.17. --- test-suite/standalone/test-round.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index f1458af29..150c8816e 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -25,7 +25,16 @@ #include <stdio.h> #if HAVE_FENV_H -#include <fenv.h> +# if defined __GNUC__ && defined __GLIBC__ +/* In Glibc 2.17, <bits/fenv.h> defines `feraiseexcept' as an inline + without declaring it first, so ignore the warning. */ +# pragma GCC diagnostic push +# pragma GCC diagnostic ignored "-Wmissing-prototypes" +# endif +# include <fenv.h> +# if defined __GNUC__ && defined __GLIBC__ +# pragma GCC diagnostic pop +# endif #elif defined HAVE_MACHINE_FPU_H /* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>. On NetBSD, this header has to be included along with <sys/types.h>. */ From cc2948aa3189b7bd29c23e7a93ccb1217a1b4eff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Feb 2013 20:07:12 +0100 Subject: [PATCH 030/147] Recognize mips64* as having 32-bit pointers by default. * module/system/base/target.scm (cpu-word-size): Consider MIPS64 to default to n32 or o32. * test-suite/tests/asm-to-bytecode.test ("cross-compilation") ["mips64el-unknown-linux-gnu"]: New test. --- module/system/base/target.scm | 7 ++++++- test-suite/tests/asm-to-bytecode.test | 5 ++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 304056de2..93c644a08 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2011, 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 @@ -80,6 +80,11 @@ (if (string=? cpu (triplet-cpu %host-type)) %native-word-size (cond ((string-match "^i[0-9]86$" cpu) 4) + + ;; See <http://www.linux-mips.org/wiki/WhatsWrongWithO32N32N64> + ;; for details on the MIPS ABIs. + ((string-match "^mips64" cpu) 4) ; n32 or o32 + ((string-match "64$" cpu) 8) ((string-match "64[lbe][lbe]$" cpu) 8) ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 4ea3dd309..41707b26a 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -1,6 +1,6 @@ ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 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 @@ -194,6 +194,9 @@ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4) (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8) + (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI + (endianness little) 4) + (pass-if-exception "unknown target" exception:miscellaneous-error (call-with-values (lambda () From 9130ec74cf55a2531a364ef16b6608489b583f16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Feb 2013 20:36:52 +0100 Subject: [PATCH 031/147] Check whether a triplet's OS part specifies an ABI. * module/system/base/target.scm (cpu-word-size): Rename to... (triplet-pointer-size): ... this. Update caller. Take a triplet as the argument. Check the `triplet-os' part when checking for equality with the host. Add support "mips64.*-gnuabi64". * test-suite/tests/asm-to-bytecode.test ("cross-compilation") [ "mips64el-unknown-linux-gnuabi64"]: New test. --- module/system/base/target.scm | 35 ++++++++++++++++----------- test-suite/tests/asm-to-bytecode.test | 2 ++ 2 files changed, 23 insertions(+), 14 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 93c644a08..5cc0c1d75 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -55,7 +55,7 @@ (let ((cpu (triplet-cpu target))) (with-fluids ((%target-type target) (%target-endianness (cpu-endianness cpu)) - (%target-word-size (cpu-word-size cpu))) + (%target-word-size (triplet-pointer-size target))) (thunk)))) (define (cpu-endianness cpu) @@ -75,21 +75,28 @@ (else (error "unknown CPU endianness" cpu))))) -(define (cpu-word-size cpu) - "Return the word size for CPU." - (if (string=? cpu (triplet-cpu %host-type)) - %native-word-size - (cond ((string-match "^i[0-9]86$" cpu) 4) +(define (triplet-pointer-size triplet) + "Return the size of pointers in bytes for TRIPLET." + (let ((cpu (triplet-cpu triplet))) + (cond ((and (string=? cpu (triplet-cpu %host-type)) + (string=? (triplet-os triplet) (triplet-os %host-type))) + %native-word-size) - ;; See <http://www.linux-mips.org/wiki/WhatsWrongWithO32N32N64> - ;; for details on the MIPS ABIs. - ((string-match "^mips64" cpu) 4) ; n32 or o32 + ((string-match "^i[0-9]86$" cpu) 4) - ((string-match "64$" cpu) 8) - ((string-match "64[lbe][lbe]$" cpu) 8) - ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) - ((string-match "^arm.*" cpu) 4) - (else (error "unknown CPU word size" cpu))))) + ;; Although GNU config.guess doesn't yet recognize them, + ;; Debian (ab)uses the OS part to denote the specific ABI + ;; being used: <http://wiki.debian.org/Multiarch/Tuples>. + ;; See <http://www.linux-mips.org/wiki/WhatsWrongWithO32N32N64> + ;; for details on the MIPS ABIs. + ((string-match "^mips64.*-gnuabi64" triplet) 8) ; n64 ABI + ((string-match "^mips64" cpu) 4) ; n32 or o32 + + ((string-match "64$" cpu) 8) + ((string-match "64[lbe][lbe]$" cpu) 8) + ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) + ((string-match "^arm.*" cpu) 4) + (else (error "unknown CPU word size" cpu))))) (define (triplet-cpu t) (substring t 0 (string-index t #\-))) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 41707b26a..6b1449d6e 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -196,6 +196,8 @@ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI (endianness little) 4) + (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet) + (endianness little) 8) (pass-if-exception "unknown target" exception:miscellaneous-error From b946e08a6ae6e73bda1f76017fcb75f41cd4b288 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Feb 2013 20:39:51 +0100 Subject: [PATCH 032/147] Recognize the `x86_64.*-gnux32' triplet. * module/system/base/target.scm (triplet-pointer-size): Add case for "^x64_64-.*-gnux32". * test-suite/tests/asm-to-bytecode.test ("cross-compilation"): ["x86_64-unknown-linux-gnux32"]: New test. --- module/system/base/target.scm | 2 ++ test-suite/tests/asm-to-bytecode.test | 2 ++ 2 files changed, 4 insertions(+) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 5cc0c1d75..762894ca3 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -92,6 +92,8 @@ ((string-match "^mips64.*-gnuabi64" triplet) 8) ; n64 ABI ((string-match "^mips64" cpu) 4) ; n32 or o32 + ((string-match "^x64_64-.*-gnux32" triplet) 4) ; x32 + ((string-match "64$" cpu) 8) ((string-match "64[lbe][lbe]$" cpu) 8) ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 6b1449d6e..3bd8a929b 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -198,6 +198,8 @@ (endianness little) 4) (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet) (endianness little) 8) + (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet) + (endianness little) 4) (pass-if-exception "unknown target" exception:miscellaneous-error From a5d8f98c60344548f0b6a70828b95f2b2e1f7553 Mon Sep 17 00:00:00 2001 From: David Kastrup <dak@gnu.org> Date: Wed, 27 Feb 2013 20:45:08 -0500 Subject: [PATCH 033/147] Let reverse! accept arbitrary types as second argument (new_tail) * libguile/list.c (scm_reverse_x): remove typecheck for 2nd arg. Signed-off-by: Mark H Weaver <mhw@netris.org> --- libguile/list.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/list.c b/libguile/list.c index 6c8f8bef2..d30f9e847 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -377,8 +377,6 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, SCM_VALIDATE_LIST (1, lst); if (SCM_UNBNDP (new_tail)) new_tail = SCM_EOL; - else - SCM_VALIDATE_LIST (2, new_tail); while (!SCM_NULL_OR_NIL_P (lst)) { From aacc689677316ebb1ea45bb8fb22f921ebaf97d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 28 Feb 2013 09:42:31 +0100 Subject: [PATCH 034/147] Fix handling of the *-gnux32 target. * module/system/base/target.scm (triplet-pointer-size): Fix typo in the x32 triplet name. * test-suite/tests/asm-to-bytecode.test (native-os): New procedure. (test-target): Use (native-word-size) only when both the CPU and OS match. --- module/system/base/target.scm | 2 +- test-suite/tests/asm-to-bytecode.test | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 762894ca3..c74ae679d 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -92,7 +92,7 @@ ((string-match "^mips64.*-gnuabi64" triplet) 8) ; n64 ABI ((string-match "^mips64" cpu) 4) ; n32 or o32 - ((string-match "^x64_64-.*-gnux32" triplet) 4) ; x32 + ((string-match "^x86_64-.*-gnux32" triplet) 4) ; x32 ((string-match "64$" cpu) 8) ((string-match "64[lbe][lbe]$" cpu) 8) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 3bd8a929b..6d2f20e02 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -132,6 +132,9 @@ (define (native-cpu) (with-target %host-type target-cpu)) +(define (native-os) + (with-target %host-type target-os)) + (define (native-word-size) ((@ (system foreign) sizeof) '*)) @@ -152,7 +155,8 @@ ;; actually has a 32-bit user-land, for instance (see ;; <http://www.debian.org/ports/sparc/#sparc64bit> ;; for details.) - (if (string=? (native-cpu) (target-cpu)) + (if (and (string=? (native-cpu) (target-cpu)) + (string=? (native-os) (target-os))) (native-word-size) word-size)) (b (compile-bytecode From 5ccc3764b3e17a328dad515d9a74123653f1fef9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 26 Feb 2013 17:25:51 -0500 Subject: [PATCH 035/147] Support calling foreign functions of 10 arguments or more. * libguile/foreign.c (OBJCODE_HEADER, META_HEADER, META): Change these into higher-order macros. (GEN_CODE): New higher-order macro based on 'CODE'. (M_STATIC, M_DYNAMIC): New macros. (CODE): Reimplement using 'GEN_CODE' and 'M_STATIC'. (make_objcode_trampoline): New static function. (large_objcode_trampolines, large_objcode_trampolines_mutex): New static variables. (get_objcode_trampoline): New static function. (cif_to_procedure): Use 'get_objcode_trampoline'. * test-suite/standalone/test-ffi-lib.c (test_ffi_sum_many): New function. * test-suite/standalone/test-ffi: Add test. --- libguile/foreign.c | 113 +++++++++++++++++++-------- test-suite/standalone/test-ffi | 15 ++++ test-suite/standalone/test-ffi-lib.c | 17 ++++ 3 files changed, 111 insertions(+), 34 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index f5819c455..90a4fcab4 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -772,37 +772,40 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, /* Pre-generate trampolines for less than 10 arguments. */ #ifdef WORDS_BIGENDIAN -#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40 -#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0 +#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40) +#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0) #else -#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0 -#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0 +#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0) +#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0) #endif -#define CODE(nreq) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \ - /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \ - /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \ - /* 7 */ scm_op_nop, \ - /* 8 */ META (3, 7, nreq) +#define GEN_CODE(M, nreq) \ + OBJCODE_HEADER (M), \ + /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \ + /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \ + /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \ + /* 7 */ M (scm_op_nop), \ + /* 8 */ META (M, 3, 7, nreq) -#define META(start, end, nreq) \ - META_HEADER, \ - /* 0 */ scm_op_make_eol, /* bindings */ \ - /* 1 */ scm_op_make_eol, /* sources */ \ - /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \ - /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \ - /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \ - /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \ - /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \ - /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \ - /* 24 */ scm_op_cons, /* make a pair for the properties */ \ - /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \ - /* 28 */ scm_op_return, /* and return */ \ - /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \ +#define META(M, start, end, nreq) \ + META_HEADER (M), \ + /* 0 */ M (scm_op_make_eol), /* bindings */ \ + /* 1 */ M (scm_op_make_eol), /* sources */ \ + /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \ + /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \ + /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \ + /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \ + /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \ + /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \ + /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \ + /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \ + /* 28 */ M (scm_op_return), /* and return */ \ + /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \ /* 32 */ +#define M_STATIC(x) (x) +#define CODE(nreq) GEN_CODE (M_STATIC, nreq) + static const struct { scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ @@ -816,8 +819,28 @@ static const struct } }; -#undef CODE +static SCM +make_objcode_trampoline (unsigned int nargs) +{ + const int size = sizeof (struct scm_objcode) + 8 + + sizeof (struct scm_objcode) + 32; + SCM bytecode = scm_c_make_bytevector (size); + scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode); + int i = 0; + +#define M_DYNAMIC(x) (bytes[i++] = (x)) + GEN_CODE (M_DYNAMIC, nargs); +#undef M_DYNAMIC + + if (i != size) + scm_syserror ("make_objcode_trampoline"); + return scm_bytecode_to_native_objcode (bytecode); +} + +#undef GEN_CODE #undef META +#undef M_STATIC +#undef CODE #undef OBJCODE_HEADER #undef META_HEADER @@ -880,21 +903,43 @@ static const SCM objcode_trampolines[10] = { SCM_PACK (objcode_cells.cells+18), }; +static SCM large_objcode_trampolines = SCM_UNDEFINED; +static scm_i_pthread_mutex_t large_objcode_trampolines_mutex = + SCM_I_PTHREAD_MUTEX_INITIALIZER; + +static SCM +get_objcode_trampoline (unsigned int nargs) +{ + SCM objcode; + + if (nargs < 10) + objcode = objcode_trampolines[nargs]; + else if (nargs < 128) + { + scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex); + if (SCM_UNBNDP (large_objcode_trampolines)) + large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED); + objcode = scm_c_vector_ref (large_objcode_trampolines, nargs); + if (SCM_UNBNDP (objcode)) + scm_c_vector_set_x (large_objcode_trampolines, nargs, + objcode = make_objcode_trampoline (nargs)); + scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex); + } + else + scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented", + SCM_EOL); + + return objcode; +} + static SCM cif_to_procedure (SCM cif, SCM func_ptr) { ffi_cif *c_cif; - unsigned int nargs; SCM objcode, table, ret; c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); - nargs = c_cif->nargs; - - if (nargs < 10) - objcode = objcode_trampolines[nargs]; - else - scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented", - SCM_EOL); + objcode = get_objcode_trampoline (c_cif->nargs); table = scm_c_make_vector (2, SCM_UNDEFINED); SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr)); diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi index ad686603e..0a91f63f9 100755 --- a/test-suite/standalone/test-ffi +++ b/test-suite/standalone/test-ffi @@ -169,6 +169,21 @@ exec guile -q -s "$0" "$@" (test (f-sum -1 2000 -30000 40000000000) (+ -1 2000 -30000 40000000000)) +;; +;; More than ten arguments +;; +(define f-sum-many + (pointer->procedure int64 (dynamic-func "test_ffi_sum_many" lib) + (list uint8 uint16 uint32 uint64 + int8 int16 int32 int64 + int8 int16 int32 int64))) +(test (f-sum-many 255 65535 4294967295 1844674407370955161 + -1 2000 -30000 40000000000 + 5 -6000 70000 -80000000000) + (+ 255 65535 4294967295 1844674407370955161 + -1 2000 -30000 40000000000 + 5 -6000 70000 -80000000000)) + ;; ;; Structs ;; diff --git a/test-suite/standalone/test-ffi-lib.c b/test-suite/standalone/test-ffi-lib.c index 37d6e43cc..f26533958 100644 --- a/test-suite/standalone/test-ffi-lib.c +++ b/test-suite/standalone/test-ffi-lib.c @@ -194,6 +194,23 @@ scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b, } +scm_t_int64 test_ffi_sum_many (scm_t_uint8 a, scm_t_uint16 b, + scm_t_uint32 c, scm_t_uint64 d, + scm_t_int8 e, scm_t_int16 f, + scm_t_int32 g, scm_t_int64 h, + scm_t_int8 i, scm_t_int16 j, + scm_t_int32 k, scm_t_int64 l); +scm_t_int64 test_ffi_sum_many (scm_t_uint8 a, scm_t_uint16 b, + scm_t_uint32 c, scm_t_uint64 d, + scm_t_int8 e, scm_t_int16 f, + scm_t_int32 g, scm_t_int64 h, + scm_t_int8 i, scm_t_int16 j, + scm_t_int32 k, scm_t_int64 l) +{ + return l + k + j + i + h + g + f + e + d + c + b + a; +} + + struct foo { scm_t_int8 a; From b8d8f8b9292a4755d2c63bc7a955d75d96eb05e0 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Thu, 28 Feb 2013 06:26:22 -0500 Subject: [PATCH 036/147] Fix duplicate removal of with-fluids. Based on a patch by David Kastrup <dak@gnu.org>. Fixes <http://bugs.gnu.org/13838>. * libguile/fluids.c (scm_i_make_with_fluids): Remove the duplicate binding instead of the last binding. * test-suite/tests/fluids.test: Add test, and fix existing duplicate tests. * THANKS: Thanks David Kastrup. --- THANKS | 1 + libguile/fluids.c | 5 ++++- test-suite/tests/fluids.test | 30 ++++++++++++++++++++++-------- 3 files changed, 27 insertions(+), 9 deletions(-) diff --git a/THANKS b/THANKS index fc2bf4924..a39473f31 100644 --- a/THANKS +++ b/THANKS @@ -94,6 +94,7 @@ For fixes or providing information which led to a fix: David Jaquay Paul Jarc Steve Juranich + David Kastrup Richard Kim Bruce Korb René Köcher diff --git a/libguile/fluids.c b/libguile/fluids.c index f1c09cb30..277246e35 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, + * 2011, 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 License @@ -326,6 +327,8 @@ scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals) { vals[i] = vals[j]; /* later bindings win */ n--; + fluids[j] = fluids[n]; + vals[j] = vals[n]; break; } } diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index 9ed846c05..5552fd936 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -18,7 +18,8 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-fluids) - :use-module (test-suite lib)) + :use-module (test-suite lib) + :use-module (system base compile)) (define exception:syntax-error @@ -78,16 +79,29 @@ (not (fluid-ref a)))))) (with-test-prefix "with-fluids with duplicate fluid" + ;; These tests must be compiled, because the evaluator + ;; effectively transforms (with-fluids ((a 1) (b 2)) ...) + ;; into (with-fluids ((a 1)) (with-fluids ((b 2)) ...)) + (pass-if "last value wins" - (with-fluids ((a 1) - (a 2)) - (eqv? (fluid-ref a) 2))) + (compile '(with-fluids ((a 1) + (a 2)) + (eqv? (fluid-ref a) 2)) + #:env (current-module))) + (pass-if "remove the duplicate, not the last binding" + (compile '(with-fluids ((a 1) + (a 2) + (b 3)) + (eqv? (fluid-ref b) 3)) + #:env (current-module))) + (pass-if "original value restored" - (and (with-fluids ((a 1) - (a 2)) - (eqv? (fluid-ref a) 2)) - (eqv? (fluid-ref a) #f)))) + (compile '(and (with-fluids ((a 1) + (a 2)) + (eqv? (fluid-ref a) 2)) + (eqv? (fluid-ref a) #f)) + #:env (current-module)))) (pass-if "fluid values are thread-local" (if (provided? 'threads) From 8dd01861a9a0331b912a1ae6310e64eb6b47c29c Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Thu, 28 Feb 2013 18:43:09 -0500 Subject: [PATCH 037/147] Fix later-bindings-win logic in with-fluids. Based on a patch by David Kastrup <dak@gnu.org>. Fixes <http://bugs.gnu.org/13843>. * libguile/fluids.c (scm_i_make_with_fluids): Reverse direction of inner loop that checks for duplicates, to properly handle more than two bindings to the same fluid. --- libguile/fluids.c | 6 +++--- test-suite/tests/fluids.test | 10 ++++++---- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/libguile/fluids.c b/libguile/fluids.c index 277246e35..327d12f4c 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -319,10 +319,10 @@ scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals) /* Ensure that there are no duplicates in the fluids set -- an N^2 operation, but N will usually be small, so perhaps that's OK. */ { - size_t i, j = n; + size_t i, j; - while (j--) - for (i = 0; i < j; i++) + for (j = n; j--;) + for (i = j; i--;) if (scm_is_eq (fluids[i], fluids[j])) { vals[i] = vals[j]; /* later bindings win */ diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index 5552fd936..9ad9e81f8 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -85,15 +85,17 @@ (pass-if "last value wins" (compile '(with-fluids ((a 1) - (a 2)) - (eqv? (fluid-ref a) 2)) + (a 2) + (a 3)) + (eqv? (fluid-ref a) 3)) #:env (current-module))) (pass-if "remove the duplicate, not the last binding" (compile '(with-fluids ((a 1) (a 2) - (b 3)) - (eqv? (fluid-ref b) 3)) + (a 3) + (b 4)) + (eqv? (fluid-ref b) 4)) #:env (current-module))) (pass-if "original value restored" From 764246cfbbfff21b3127fff500e972e1dc4314e3 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig <mandyke@gmail.com> Date: Tue, 19 Feb 2013 09:55:14 +0800 Subject: [PATCH 038/147] test-suite: eq-ness of numbers, characters is unspecified * test-suite/tests/00-socket.test: * test-suite/tests/alist.test: * test-suite/tests/elisp.test: * test-suite/tests/encoding-iso88591.test: * test-suite/tests/encoding-iso88597.test: * test-suite/tests/encoding-utf8.test: * test-suite/tests/hash.test: * test-suite/tests/i18n.test: * test-suite/tests/modules.test: * test-suite/tests/ports.test: * test-suite/tests/srfi-35.test: Make tests use eqv? instead of eq? when comparing numbers, characters. Checked also for similar uses of assq[-ref]. * test-suite/tests/vlist.test ("vhash-delete honors HASH"): Change test to use eqv-ness, not eq-ness, which should not impact its purpose as these two are equivalent for strings. --- test-suite/tests/00-socket.test | 6 +++--- test-suite/tests/alist.test | 4 ++-- test-suite/tests/elisp.test | 8 ++++---- test-suite/tests/encoding-iso88591.test | 10 +++++----- test-suite/tests/encoding-iso88597.test | 10 +++++----- test-suite/tests/encoding-utf8.test | 10 +++++----- test-suite/tests/hash.test | 6 +----- test-suite/tests/i18n.test | 20 ++++++++++---------- test-suite/tests/modules.test | 2 +- test-suite/tests/ports.test | 8 ++++---- test-suite/tests/srfi-35.test | 16 ++++++++-------- test-suite/tests/vlist.test | 8 ++++---- 12 files changed, 52 insertions(+), 56 deletions(-) diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test index 6deb28542..8079cf548 100644 --- a/test-suite/tests/00-socket.test +++ b/test-suite/tests/00-socket.test @@ -336,7 +336,7 @@ (if (not server-pid) (throw 'unresolved) (let ((status (cdr (waitpid server-pid)))) - (eq? 0 (status:exit-val status))))) + (eqv? 0 (status:exit-val status))))) (false-if-exception (delete-file path)) @@ -409,7 +409,7 @@ (if (not server-pid) (throw 'unresolved) (let ((status (cdr (waitpid server-pid)))) - (eq? 0 (status:exit-val status))))) + (eqv? 0 (status:exit-val status))))) (false-if-exception (delete-file path)) @@ -505,7 +505,7 @@ (if (not server-pid) (throw 'unresolved) (let ((status (cdr (waitpid server-pid)))) - (eq? 0 (status:exit-val status))))) + (eqv? 0 (status:exit-val status))))) #t))) diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index 699c10ef4..0ed5d22c8 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -124,8 +124,8 @@ (pass-if "assoc-ref" (let ((x (assoc-ref b "one"))) (and (list? x) - (eq? (car x) 2) - (eq? (cadr x) 3)))) + (eqv? (car x) 2) + (eqv? (cadr x) 3)))) (pass-if-not "assoc-ref not" (assoc-ref a 'testing)) diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 41800fd9e..baf85467b 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -124,8 +124,8 @@ (with-fluids* (cons f (cons g #nil)) '(3 4) (lambda () - (and (eq? (fluid-ref f) 3) - (eq? (fluid-ref g) 4)))))) + (and (eqv? (fluid-ref f) 3) + (eqv? (fluid-ref g) 4)))))) (pass-if "append!" (let ((a (copy-tree '(1 2 3))) @@ -150,11 +150,11 @@ '(5 4 3 2 1))) ; Ditto. (pass-if "list-ref" - (eq? (list-ref '(0 1 2 3 4 . #nil) 4) 4)) + (eqv? (list-ref '(0 1 2 3 4 . #nil) 4) 4)) (pass-if-exception "list-ref" exception:out-of-range - (eq? (list-ref '(0 1 2 3 4 . #nil) 6) 6)) + (eqv? (list-ref '(0 1 2 3 4 . #nil) 6) 6)) (pass-if "list-set!" (let ((l (copy-tree '(0 1 2 3 4 . #nil)))) diff --git a/test-suite/tests/encoding-iso88591.test b/test-suite/tests/encoding-iso88591.test index f7bec5ef5..8265ff14f 100644 --- a/test-suite/tests/encoding-iso88591.test +++ b/test-suite/tests/encoding-iso88591.test @@ -106,16 +106,16 @@ (with-test-prefix "string length" (pass-if "ltima" - (eq? (string-length s1) 6)) + (eqv? (string-length s1) 6)) (pass-if "cdula" - (eq? (string-length s2) 6)) + (eqv? (string-length s2) 6)) (pass-if "aos" - (eq? (string-length s3) 4)) + (eqv? (string-length s3) 4)) (pass-if "Cmo?" - (eq? (string-length s4) 6))) + (eqv? (string-length s4) 6))) (with-test-prefix "internal encoding" @@ -168,7 +168,7 @@ (pass-if "1" (let (( 1) ( 2)) - (eq? (+ ) 3)))) + (eqv? (+ ) 3)))) (with-test-prefix "output errors" diff --git a/test-suite/tests/encoding-iso88597.test b/test-suite/tests/encoding-iso88597.test index f11619459..a577b2a60 100644 --- a/test-suite/tests/encoding-iso88597.test +++ b/test-suite/tests/encoding-iso88597.test @@ -95,16 +95,16 @@ (with-test-prefix "string length" (pass-if "s1" - (eq? (string-length s1) 4)) + (eqv? (string-length s1) 4)) (pass-if "s2" - (eq? (string-length s2) 3)) + (eqv? (string-length s2) 3)) (pass-if "s3" - (eq? (string-length s3) 8)) + (eqv? (string-length s3) 8)) (pass-if "s4" - (eq? (string-length s4) 3))) + (eqv? (string-length s4) 3))) (with-test-prefix "internal encoding" @@ -157,7 +157,7 @@ (pass-if "1" (let (( 1) ( 2)) - (eq? (+ ) 3)))) + (eqv? (+ ) 3)))) (with-test-prefix "output errors" diff --git a/test-suite/tests/encoding-utf8.test b/test-suite/tests/encoding-utf8.test index 966a04dde..1de3fa7ef 100644 --- a/test-suite/tests/encoding-utf8.test +++ b/test-suite/tests/encoding-utf8.test @@ -126,16 +126,16 @@ (with-test-prefix "string length" (pass-if "última" - (eq? (string-length s1) 6)) + (eqv? (string-length s1) 6)) (pass-if "cédula" - (eq? (string-length s2) 6)) + (eqv? (string-length s2) 6)) (pass-if "años" - (eq? (string-length s3) 4)) + (eqv? (string-length s3) 4)) (pass-if "羅生門" - (eq? (string-length s4) 3))) + (eqv? (string-length s4) 3))) (with-test-prefix "internal encoding" @@ -188,7 +188,7 @@ (pass-if "1" (let ((芥川龍之介 1) (ñ 2)) - (eq? (+ 芥川龍之介 ñ) 3)))) + (eqv? (+ 芥川龍之介 ñ) 3)))) (if (defined? 'setlocale) (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index cb6b5cc26..3bd400425 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -134,7 +134,7 @@ (with-output-to-string (lambda () (write table))))))) - ;; 1 and 1 are equal? and eqv? and eq? + ;; 1 and 1 are equal? and eqv? (but not necessarily eq?) (pass-if (equal? 'foo (let ((table (make-hash-table))) (hash-set! table 1 'foo) @@ -143,10 +143,6 @@ (let ((table (make-hash-table))) (hashv-set! table 1 'foo) (hashv-ref table 1)))) - (pass-if (equal? 'foo - (let ((table (make-hash-table))) - (hashq-set! table 1 'foo) - (hashq-ref table 1)))) ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?) (pass-if (equal? 'foo diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index ef08dd4b4..ad65b73f0 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -255,30 +255,30 @@ (with-test-prefix "character mapping" (pass-if "char-locale-downcase" - (and (eq? #\a (char-locale-downcase #\A)) - (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C"))))) + (and (eqv? #\a (char-locale-downcase #\A)) + (eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C"))))) (pass-if "char-locale-upcase" - (and (eq? #\Z (char-locale-upcase #\z)) - (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C"))))) + (and (eqv? #\Z (char-locale-upcase #\z)) + (eqv? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C"))))) (pass-if "char-locale-titlecase" - (and (eq? #\T (char-locale-titlecase #\t)) - (eq? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C"))))) + (and (eqv? #\T (char-locale-titlecase #\t)) + (eqv? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C"))))) (pass-if "char-locale-titlecase Dž" - (and (eq? #\762 (char-locale-titlecase #\763)) - (eq? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C"))))) + (and (eqv? #\762 (char-locale-titlecase #\763)) + (eqv? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C"))))) (pass-if "char-locale-upcase Turkish" (under-turkish-utf8-locale-or-unresolved (lambda () - (eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale))))) + (eqv? #\İ (char-locale-upcase #\i %turkish-utf8-locale))))) (pass-if "char-locale-downcase Turkish" (under-turkish-utf8-locale-or-unresolved (lambda () - (eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale)))))) + (eqv? #\i (char-locale-downcase #\İ %turkish-utf8-locale)))))) (with-test-prefix "string mapping" diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 79e3c98e9..fb540610a 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -345,7 +345,7 @@ (set-module-binder! m (lambda args (set! invoked? #t) #f)) (module-define! m 'something 2) (and invoked? - (eq? (module-ref m 'something) 2)))) + (eqv? (module-ref m 'something) 2)))) (pass-if "honored (ref)" (let ((m (make-module)) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 613d2693f..372993032 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -482,7 +482,7 @@ (display str)))) #f) ; so the test really fails here (lambda (key subr message errno port chr) - (and (eq? chr #\ĉ) + (and (eqv? chr #\ĉ) (string? (strerror errno))))))) (pass-if "wrong encoding, substitute" @@ -548,12 +548,12 @@ ((_ port (proc -> error)) (if (eq? 'substitute (port-conversion-strategy port)) - (eq? (proc port) #\?) + (eqv? (proc port) #\?) (decoding-error? port (proc port)))) ((_ port (proc -> eof)) (eof-object? (proc port))) ((_ port (proc -> char)) - (eq? (proc port) char)))) + (eqv? (proc port) char)))) (make-checks (syntax-rules () ((_ port check ...) @@ -1136,7 +1136,7 @@ (display "This is GNU Guile.\nWelcome." p))) (call-with-input-file (test-file) (lambda (p) - (and (eq? #\T (read-char p)) + (and (eqv? #\T (read-char p)) (let ((line (port-line p)) (col (port-column p))) (and (= line 0) (= col 1) diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test index 6d725dc15..5e4cb271e 100644 --- a/test-suite/tests/srfi-35.test +++ b/test-suite/tests/srfi-35.test @@ -65,17 +65,17 @@ (pass-if "condition-ref" (let* ((ct (make-condition-type 'chbouib &condition '(a b))) (c (make-condition ct 'b 1 'a 0))) - (and (eq? (condition-ref c 'a) 0) - (eq? (condition-ref c 'b) 1)))) + (and (eqv? (condition-ref c 'a) 0) + (eqv? (condition-ref c 'b) 1)))) (pass-if "condition-ref with inheritance" (let* ((top (make-condition-type 'foo &condition '(a b))) (ct (make-condition-type 'bar top '(c d))) (c (make-condition ct 'b 1 'a 0 'd 3 'c 2))) - (and (eq? (condition-ref c 'a) 0) - (eq? (condition-ref c 'b) 1) - (eq? (condition-ref c 'c) 2) - (eq? (condition-ref c 'd) 3)))) + (and (eqv? (condition-ref c 'a) 0) + (eqv? (condition-ref c 'b) 1) + (eqv? (condition-ref c 'c) 2) + (eqv? (condition-ref c 'd) 3)))) (pass-if "extract-condition" (let* ((ct (make-condition-type 'chbouib &condition '(a b))) @@ -149,8 +149,8 @@ (let ((c (make-condition &chbouib 'one 1 'two 2))) (and (condition? c) (chbouib? c) - (eq? (chbouib-one c) 1) - (eq? (chbouib-two c) 2)))) + (eqv? (chbouib-one c) 1) + (eqv? (chbouib-two c) 2)))) m))) (pass-if "condition" diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test index d939284c1..a37be5e46 100644 --- a/test-suite/tests/vlist.test +++ b/test-suite/tests/vlist.test @@ -287,12 +287,12 @@ ;; using the supplied hash procedure, which could lead to ;; inconsistencies. (let* ((s "hello") - (vh (fold vhash-consq - (vhash-consq s "world" vlist-null) + (vh (fold vhash-consv + (vhash-consv s "world" vlist-null) (iota 300) (iota 300)))) - (and (vhash-assq s vh) - (pair? (vhash-assq s (vhash-delete 123 vh eq? hashq)))))) + (and (vhash-assv s vh) + (pair? (vhash-assv s (vhash-delete 123 vh eqv? hashv)))))) (pass-if "vhash-fold" (let* ((keys '(a b c d e f g d h i)) From 0f595d7d1d57b12036bef801538163d3773567c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 1 Mar 2013 17:36:21 +0100 Subject: [PATCH 039/147] Use accessors instead of symbols deprecated in libgc 7.3. * configure.ac: Check for `GC_set_all_interior_pointers', `GC_get_gc_no', and `GC_set_java_finalization'. * libguile/gc.c (scm_gc_stats)[HAVE_GC_GET_GC_NO]: Use `GC_get_gc_no'. (scm_storage_prehistory)[HAVE_GC_SET_ALL_INTERIOR_POINTERS]: Use `GC_set_all_interior_pointers'. * libguile/guardians.c (scm_init_guardians)[HAVE_GC_SET_JAVA_FINALIZATION]: Use `GC_set_java_finalization'. --- configure.ac | 7 ++++++- libguile/gc.c | 16 +++++++++++++++- libguile/guardians.c | 8 +++++++- 3 files changed, 28 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index 8848339f8..cbad0a162 100644 --- a/configure.ac +++ b/configure.ac @@ -1229,7 +1229,12 @@ save_LIBS="$LIBS" LIBS="$BDW_GC_LIBS $LIBS" CFLAGS="$BDW_GC_CFLAGS $CFLAGS" -AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier GC_set_finalize_on_demand]) +AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit \ + GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask \ + GC_set_start_callback GC_get_heap_usage_safe \ + GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes \ + GC_set_finalizer_notifier GC_set_finalize_on_demand \ + GC_set_all_interior_pointers GC_get_gc_no GC_set_java_finalization]) # Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not # declared, and has a different type (returning void instead of diff --git a/libguile/gc.c b/libguile/gc.c index 06b5044e5..6e459c3f9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, + * 2008, 2009, 2010, 2011, 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 License @@ -317,7 +318,13 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes, &bytes_since_gc, &total_bytes); +#ifdef HAVE_GC_GET_GC_NO + /* This function was added in 7.2alpha2 (June 2009). */ + gc_times = GC_get_gc_no (); +#else + /* This symbol is deprecated as of 7.3. */ gc_times = GC_gc_no; +#endif answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)), @@ -629,7 +636,14 @@ GC_set_finalize_on_demand (int foo) void scm_storage_prehistory () { +#ifdef HAVE_GC_SET_ALL_INTERIOR_POINTERS + /* This function was added in 7.2alpha2 (June 2009). */ + GC_set_all_interior_pointers (0); +#else + /* This symbol is deprecated in 7.3. */ GC_all_interior_pointers = 0; +#endif + free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3); minimum_free_space_divisor = free_space_divisor; target_free_space_divisor = free_space_divisor; diff --git a/libguile/guardians.c b/libguile/guardians.c index 022f54e63..6ba8c0b59 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -1,5 +1,5 @@ /* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011, - * 2012 Free Software Foundation, Inc. + * 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 License @@ -351,7 +351,13 @@ void scm_init_guardians () { /* We use unordered finalization `a la Java. */ +#ifdef HAVE_GC_SET_JAVA_FINALIZATION + /* This function was added in 7.2alpha2 (June 2009). */ + GC_set_java_finalization (1); +#else + /* This symbol is deprecated as of 7.3. */ GC_java_finalization = 1; +#endif tc16_guardian = scm_make_smob_type ("guardian", 0); From 01b69e79f617db3c68b117512b6fe29978ba0ebb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 1 Mar 2013 17:45:17 +0100 Subject: [PATCH 040/147] Allow the SMOB mark procedures to be called when libgc uses parallel markers. Fixes <http://bugs.gnu.org/13611>. Reported by Mike Gran <spk121@yahoo.com>. * libguile/smob.c (current_mark_stack_pointer, current_mark_stack_limit): New variables. (smob_mark): Use CURRENT_MARK_STACK_POINTER and CURRENT_MARK_STACK_LIMIT instead of the same-named fields of `SCM_I_CURRENT_THREAD'. (scm_gc_mark): Likewise. (scm_smob_prehistory): Initialize CURRENT_MARK_STACK_LIMIT and CURRENT_MARK_STACK_POINTER. * libguile/threads.h (scm_i_thread): Add comment that `current_mark_stack_ptr' and `current_mark_stack_limit' are no longer used. --- libguile/smob.c | 49 +++++++++++++++++++++++----------------------- libguile/threads.h | 7 ++++--- 2 files changed, 29 insertions(+), 27 deletions(-) diff --git a/libguile/smob.c b/libguile/smob.c index c2e8f2481..90849a89d 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006, + * 2009, 2010, 2011, 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 License * as published by the Free Software Foundation; either version 3 of @@ -284,6 +285,10 @@ scm_make_smob (scm_t_bits tc) /* The GC kind used for SMOB types that provide a custom mark procedure. */ static int smob_gc_kind; +/* Mark stack pointer and limit, used by `scm_gc_mark'. */ +static scm_i_pthread_key_t current_mark_stack_pointer; +static scm_i_pthread_key_t current_mark_stack_limit; + /* The generic SMOB mark procedure that gets called for SMOBs allocated with smob_gc_kind. */ @@ -322,14 +327,14 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, { SCM obj; - SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; - SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit; + scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr); + scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit); /* Invoke the SMOB's mark procedure, which will in turn invoke - `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */ + `scm_gc_mark', which may modify `current_mark_stack_pointer'. */ obj = scm_smobs[smobnum].mark (cell); - mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr; + mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer); if (SCM_NIMP (obj)) /* Mark the returned object. */ @@ -337,42 +342,35 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, mark_stack_ptr, mark_stack_limit, NULL); - SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL; - SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL; + scm_i_pthread_setspecific (current_mark_stack_pointer, NULL); + scm_i_pthread_setspecific (current_mark_stack_limit, NULL); } return mark_stack_ptr; } -/* Mark object O. We assume that this function is only called during the - mark phase, i.e., from within `smob_mark ()' or one of its - descendents. */ +/* Mark object O. We assume that this function is only called during the mark + phase, i.e., from within `smob_mark' or one of its descendants. */ void scm_gc_mark (SCM o) { -#define CURRENT_MARK_PTR \ - ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr)) -#define CURRENT_MARK_LIMIT \ - ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit)) - if (SCM_NIMP (o)) { - /* At this point, the `current_mark_*' fields of the current thread - must be defined (they are set in `smob_mark ()'). */ - register struct GC_ms_entry *mark_stack_ptr; + void *mark_stack_ptr, *mark_stack_limit; - if (!CURRENT_MARK_PTR) + mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer); + mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit); + + if (mark_stack_ptr == NULL) /* The function was not called from a mark procedure. */ abort (); mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o), - CURRENT_MARK_PTR, CURRENT_MARK_LIMIT, + mark_stack_ptr, mark_stack_limit, NULL); - SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; + scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr); } -#undef CURRENT_MARK_PTR -#undef CURRENT_MARK_LIMIT } @@ -473,6 +471,9 @@ scm_smob_prehistory () { long i; + scm_i_pthread_key_create (¤t_mark_stack_pointer, NULL); + scm_i_pthread_key_create (¤t_mark_stack_limit, NULL); + smob_gc_kind = GC_new_kind (GC_new_free_list (), GC_MAKE_PROC (GC_new_proc (smob_mark), 0), 0, diff --git a/libguile/threads.h b/libguile/threads.h index ec129bc72..901c37bb2 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -3,7 +3,8 @@ #ifndef SCM_THREADS_H #define SCM_THREADS_H -/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, + * 2007, 2008, 2009, 2011, 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 License @@ -71,8 +72,8 @@ typedef struct scm_i_thread { scm_i_pthread_cond_t sleep_cond; int sleep_fd, sleep_pipe[2]; - /* Information about the Boehm-GC mark stack during the mark phase. This - is used by `scm_gc_mark ()'. */ + /* XXX: These two fields used to hold information about the BDW-GC + mark stack during the mark phase. They are no longer used. */ void *current_mark_stack_ptr; void *current_mark_stack_limit; From 183d2ace576710079a2bcf2a8bfcbc39b7d9becc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 1 Mar 2013 17:49:24 +0100 Subject: [PATCH 041/147] doc: Fix build with Texinfo 5.0. * doc/ref/api-control.texi (Handling Errors): Move misplaced description for `scm_memory_error' & co. * doc/ref/r6rs.texi (rnrs base): Change `deffnx' of `let-syntax' and `letrec-syntax' to fit on one line. --- doc/ref/api-control.texi | 6 +++--- doc/ref/r6rs.texi | 8 +++----- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 95c4925a9..ea943d360 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.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, 2011, 2012 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, +@c 2011, 2012, 2013 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Control Mechanisms @@ -1732,8 +1732,8 @@ and the call to these routines doesn't change @code{errno}. @deftypefnx {C Function} void scm_wrong_type_arg (char *@var{subr}, int @var{argnum}, SCM @var{bad_value}) @deftypefnx {C Function} void scm_wrong_type_arg_msg (char *@var{subr}, int @var{argnum}, SCM @var{bad_value}, const char *@var{expected}) @deftypefnx {C Function} void scm_memory_error (char *@var{subr}) -Throw an error with the various keys described above. @deftypefnx {C Function} void scm_misc_error (const char *@var{subr}, const char *@var{message}, SCM @var{args}) +Throw an error with the various keys described above. In @code{scm_wrong_num_args}, @var{proc} should be a Scheme symbol which is the name of the procedure incorrectly invoked. The other diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index 2028ada2a..13f9e2078 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2010, 2011, 2012 +@c Copyright (C) 2010, 2011, 2012, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -273,10 +273,8 @@ grouped below by the existing manual sections to which they correspond. @end deffn @deffn {Scheme Syntax} define-syntax keyword expression -@deffnx {Scheme Syntax} let-syntax ((keyword transformer) @dots{}) - exp1 exp2 @dots{} -@deffnx {Scheme Syntax} letrec-syntax ((keyword transformer) @dots{}) - exp1 exp2 @dots{} +@deffnx {Scheme Syntax} let-syntax ((keyword transformer) @dots{}) exp1 exp2 @dots{} +@deffnx {Scheme Syntax} letrec-syntax ((keyword transformer) @dots{}) exp1 exp2 @dots{} @xref{Defining Macros}, for documentation. @end deffn From 994d87be35769480b04c9f96085a7a0b41040c9d Mon Sep 17 00:00:00 2001 From: Bake Timmons <b3timmons@speedymail.org> Date: Sat, 2 Mar 2013 20:33:56 +0100 Subject: [PATCH 042/147] Improve keyword notation of Texinfo function definitions. * doc/ref/api-debug.texi: * doc/ref/api-evaluation.texi: * doc/ref/api-modules.texi: * doc/ref/compiler.texi: * doc/ref/web.texi: Make Texinfo function headers more consistent. Change lesser used keyword notation to the predominant form. * doc/ref/api-procedures.texi: Fix an argument name in a header that should use repeated argument notation. * doc/ref/srfi-modules.texi: Update references in Texinfo function definition body to match previously updated variable notation in definition header. --- doc/ref/api-debug.texi | 6 ++++-- doc/ref/api-evaluation.texi | 18 ++++++++++++------ doc/ref/api-modules.texi | 9 ++++++--- doc/ref/api-procedures.texi | 6 +++++- doc/ref/compiler.texi | 9 +++++---- doc/ref/srfi-modules.texi | 7 ++++--- doc/ref/web.texi | 18 ++++++++++++------ 7 files changed, 48 insertions(+), 25 deletions(-) diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index dd2a3d19d..f6c706c78 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011, 2012 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011, 2012, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1175,7 +1175,9 @@ calls to @var{proc}. In addition, Guile defines a procedure to call a thunk, tracing all procedure calls and returns within the thunk. -@deffn {Scheme Procedure} call-with-trace thunk #:key (calls? #t) (instructions? #f) (width 80) (vm (the-vm)) +@deffn {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @ + [#:instructions?=#f] @ + [#:width=80] [#:vm=(the-vm)] Call @var{thunk}, tracing all execution within its dynamic extent. If @var{calls?} is true, Guile will print a brief report at each diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 0ffb5014e..5c932a720 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -488,7 +488,10 @@ procedure in the default environment, but you really want the one from (use-modules (ice-9 eval-string)) @end example -@deffn {Scheme Procedure} eval-string string [module=#f] [file=#f] [line=#f] [column=#f] [lang=(current-language)] [compile?=#f] +@deffn {Scheme Procedure} eval-string string [#:module=#f] [#:file=#f] @ + [#:line=#f] [#:column=#f] @ + [#:lang=(current-language)] @ + [#:compile?=#f] Parse @var{string} according to the current language, normally Scheme. Evaluate or compile the expressions it contains, in order, returning the last expression. @@ -691,7 +694,9 @@ coding declaration as recognized by @code{file-encoding} The compiler can also be invoked directly by Scheme code using the procedures below: -@deffn {Scheme Procedure} compile exp [env=#f] [from=(current-language)] [to=value] [opts=()] +@deffn {Scheme Procedure} compile exp [#:env=#f] @ + [#:from=(current-language)] @ + [#:to=value] [#:opts=()] Compile the expression @var{exp} in the environment @var{env}. If @var{exp} is a procedure, the result will be a compiled procedure; otherwise @code{compile} is mostly equivalent to @code{eval}. @@ -700,10 +705,11 @@ For a discussion of languages and compiler options, @xref{Compiling to the Virtual Machine}. @end deffn -@deffn {Scheme Procedure} compile-file file [output-file=#f] @ - [from=(current-language)] [to='objcode] @ - [env=(default-environment from)] [opts='()] @ - [canonicalization 'relative] +@deffn {Scheme Procedure} compile-file file [#:output-file=#f] @ + [#:from=(current-language)] [#:to='objcode] @ + [#:env=(default-environment from)] @ + [#:opts='()] @ + [#:canonicalization='relative] Compile the file named @var{file}. Output will be written to a @var{output-file}. If you do not supply an diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 17ab46277..b9befc00c 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010, 2011, 2012 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010, 2011, 2012, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -827,7 +827,8 @@ the time @var{thunk}'s dynamic extent was last entered) is restored. If saved, and the previously saved inner module is set current again. @end deffn -@deffn {Scheme Procedure} resolve-module name [autoload=#t] [version=#f] [#:ensure=#t] +@deffn {Scheme Procedure} resolve-module name [autoload=#t] [version=#f] @ + [#:ensure=#t] @deffnx {C Function} scm_resolve_module (name) Find the module named @var{name} and return it. When it has not already been defined and @var{autoload} is true, try to auto-load it. When it @@ -837,7 +838,9 @@ that the resulting module is compatible with the given version reference (@pxref{R6RS Version References}). The name is a list of symbols. @end deffn -@deffn {Scheme Procedure} resolve-interface name [#:select=#f] [#:hide='()] [#:select=()] [#:prefix=#f] [#:renamer] [#:version=#f] +@deffn {Scheme Procedure} resolve-interface name [#:select=#f] @ + [#:hide='()] [#:prefix=#f] @ + [#:renamer=#f] [#:version=#f] Find the module named @var{name} as with @code{resolve-module} and return its interface. The interface of a module is also a module object, but it contains only the exported bindings. diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index bef3386e8..38ae1bb69 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -333,7 +333,11 @@ cheaply, without allocating a rest list. @code{lambda*} is like @code{lambda}, except with some extensions to allow optional and keyword arguments. -@deffn {library syntax} lambda* ([var@dots{}] @* [#:optional vardef@dots{}] @* [#:key vardef@dots{} [#:allow-other-keys]] @* [#:rest var | . var]) @* body +@deffn {library syntax} lambda* ([var@dots{}] @* @ + [#:optional vardef@dots{}] @* @ + [#:key vardef@dots{} [#:allow-other-keys]] @* @ + [#:rest var | . var]) @* @ + body1 body2 @dots{} @sp 1 Create a procedure which takes optional and/or keyword arguments specified with @code{#:optional} and @code{#:key}. For example, diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 0fe75e3e3..400814080 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -53,10 +53,11 @@ Languages are registered in the module, @code{(system base language)}: They are registered with the @code{define-language} form. @deffn {Scheme Syntax} define-language @ -name title reader printer @ -[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] @ -[joiner=#f] [for-humans?=#t] @ -[make-default-environment=make-fresh-user-module] + [#:name] [#:title] [#:reader] [#:printer] @ + [#:parser=#f] [#:compilers='()] @ + [#:decompilers='()] [#:evaluator=#f] @ + [#:joiner=#f] [#:for-humans?=#t] @ + [#:make-default-environment=make-fresh-user-module] Define a language. This syntax defines a @code{#<language>} object, bound to @var{name} diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index dff8ca986..af1afc013 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3429,9 +3429,10 @@ Note that all fields of @var{type} and its supertypes must be specified. @end deffn @deffn {Scheme Procedure} make-compound-condition condition1 condition2 @dots{} -Return a new compound condition composed of @var{conditions}. The -returned condition has the type of each condition of @var{conditions} -(per @code{condition-has-type?}). +Return a new compound condition composed of @var{condition1} +@var{condition2} @enddots{}. The returned condition has the type of +each condition of condition1 condition2 @dots{} (per +@code{condition-has-type?}). @end deffn @deffn {Scheme Procedure} condition-has-type? c type diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 6c33f3225..ae387ce14 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1615,7 +1615,9 @@ and body, and write the response to the client. Return the new state produced by the handler procedure. @end deffn -@deffn {Scheme Procedure} run-server handler [impl='http] [open-params='()] . state +@deffn {Scheme Procedure} run-server handler @ + [impl='http] [open-params='()] @ + arg @dots{} Run Guile's built-in web server. @var{handler} should be a procedure that takes two or more arguments, @@ -1627,16 +1629,20 @@ For examples, skip ahead to the next section, @ref{Web Examples}. The response and body will be run through @code{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 handler can -explicitly manage its state. +Additional arguments to @var{handler} are taken from @var{arg} +@enddots{}. These arguments comprise a @dfn{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. @end deffn The default web server implementation is @code{http}, which binds to a socket, listening for request on that port. -@deffn {HTTP Implementation} http [#:host=#f] [#:family=AF_INET] [#:addr=INADDR_LOOPBACK] [#:port 8080] [#:socket] +@deffn {HTTP Implementation} http [#:host=#f] @ + [#:family=AF_INET] @ + [#:addr=INADDR_LOOPBACK] @ + [#:port 8080] [#:socket] The default HTTP implementation. We document it as a function with keyword arguments, because that is precisely the way that it is -- all of the @var{open-params} to @code{run-server} get passed to the From 69b6da07c386446d16a11cc41cb64b486199413c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 4 Mar 2013 08:56:47 +0100 Subject: [PATCH 043/147] Use `scm_is_eq' in filesys.c. * libguile/filesys.c (is_file_name_separator): Use `scm_is_eq' instead of `=='. Fixes <http://hydra.nixos.org/build/4261579>. --- libguile/filesys.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index f7c83e00f..cd4be792f 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -463,10 +463,10 @@ static int fstat_Win32 (int fdes, struct stat *buf) static int is_file_name_separator (SCM c) { - if (c == SCM_MAKE_CHAR ('/')) + if (scm_is_eq (c, SCM_MAKE_CHAR ('/'))) return 1; #ifdef __MINGW32__ - if (c == SCM_MAKE_CHAR ('\\')) + if (scm_is_eq (c, SCM_MAKE_CHAR ('\\'))) return 1; #endif return 0; From 29ace173b170a5d77e6becb30fb1d9f253a373d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 4 Mar 2013 09:04:16 +0100 Subject: [PATCH 044/147] doc: Rename "Texinfo" node to "Texinfo Processing". * doc/ref/texinfo.texi (Texinfo): Rename to... (Texinfo Processing): ... this. * doc/ref/guile.texi (Guile Modules): Update menu. --- doc/ref/guile.texi | 2 +- doc/ref/texinfo.texi | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index a6e3e7d0c..1e4a95a99 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -372,7 +372,7 @@ available through both Scheme and C interfaces. * Curried Definitions:: Extended @code{define} syntax. * Statprof:: An easy-to-use statistical profiler. * SXML:: Parsing, transforming, and serializing XML. -* Texinfo:: Munging documents written in Texinfo. +* Texinfo Processing:: Munging documents written in Texinfo. @end menu @include slib.texi diff --git a/doc/ref/texinfo.texi b/doc/ref/texinfo.texi index b5ef393c1..ec0686388 100644 --- a/doc/ref/texinfo.texi +++ b/doc/ref/texinfo.texi @@ -3,8 +3,12 @@ @c Copyright (C) 2013 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. -@node Texinfo -@section Texinfo +@c Note: Don't use "Texinfo" as the node name here because this leads to +@c a clash in the HTML output between texinfo.html (from the "texinfo" +@c node) and Texinfo.html on case-insensitive file systems such as +@c HFS+ (MacOS X). +@node Texinfo Processing +@section Texinfo Processing @menu * texinfo:: Parse texinfo files or fragments into @code{stexi}, a scheme representation From f57ea23ac8e1436f37ceeda3ea8625243c20e645 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Thu, 28 Feb 2013 17:56:58 -0500 Subject: [PATCH 045/147] Fix thread-unsafe lazy initializations. * libguile/debug.c (scm_local_eval): libguile/ports.c (scm_current_warning_port): libguile/strports.c (scm_eval_string_in_module): Perform lazy-initialization while holding a mutex. Use SCM_UNDEFINED as the uninitialized value. Use 'scm_c_*_variable'. * doc/ref/api-modules.texi (Accessing Modules from C): Fix 'my_eval_string' example to be thread-safe. --- doc/ref/api-modules.texi | 16 ++++++++++------ libguile/debug.c | 8 ++++++-- libguile/ports.c | 10 +++++++--- libguile/strports.c | 9 ++++++--- 4 files changed, 29 insertions(+), 14 deletions(-) diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index b9befc00c..47b81601b 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -945,14 +945,18 @@ the @var{name} is not bound in the module, signals an error. Returns a variable, always. @example +static SCM eval_string_var; + +/* NOTE: It is important that the call to 'my_init' + happens-before all calls to 'my_eval_string'. */ +void my_init (void) +@{ + eval_string_var = scm_c_public_lookup ("ice-9 eval-string", + "eval-string"); +@} + SCM my_eval_string (SCM str) @{ - static SCM eval_string_var = SCM_BOOL_F; - - if (scm_is_false (eval_string_var)) - eval_string_var = - scm_c_public_lookup ("ice-9 eval-string", "eval-string"); - return scm_call_1 (scm_variable_ref (eval_string_var), str); @} @end example diff --git a/libguile/debug.c b/libguile/debug.c index b1a90d84d..9e6328b3a 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -211,10 +211,14 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, SCM scm_local_eval (SCM exp, SCM env) { - static SCM local_eval_var = SCM_BOOL_F; + static SCM local_eval_var = SCM_UNDEFINED; + static scm_i_pthread_mutex_t local_eval_var_mutex + = SCM_I_PTHREAD_MUTEX_INITIALIZER; - if (scm_is_false (local_eval_var)) + scm_i_scm_pthread_mutex_lock (&local_eval_var_mutex); + if (SCM_UNBNDP (local_eval_var)) local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval"); + scm_i_pthread_mutex_unlock (&local_eval_var_mutex); return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env); } diff --git a/libguile/ports.c b/libguile/ports.c index 55808e272..8737a7672 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -418,10 +418,14 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0, SCM scm_current_warning_port (void) { - static SCM cwp_var = SCM_BOOL_F; + static SCM cwp_var = SCM_UNDEFINED; + static scm_i_pthread_mutex_t cwp_var_mutex + = SCM_I_PTHREAD_MUTEX_INITIALIZER; - if (scm_is_false (cwp_var)) - cwp_var = scm_c_private_lookup ("guile", "current-warning-port"); + scm_i_scm_pthread_mutex_lock (&cwp_var_mutex); + if (SCM_UNBNDP (cwp_var)) + cwp_var = scm_c_private_variable ("guile", "current-warning-port"); + scm_i_pthread_mutex_unlock (&cwp_var_mutex); return scm_call_0 (scm_variable_ref (cwp_var)); } diff --git a/libguile/strports.c b/libguile/strports.c index 14cc93f81..d1b293c21 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -534,13 +534,16 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, "procedure returns.") #define FUNC_NAME s_scm_eval_string_in_module { - static SCM eval_string = SCM_BOOL_F, k_module = SCM_BOOL_F; + static SCM eval_string = SCM_UNDEFINED, k_module = SCM_UNDEFINED; + static scm_i_pthread_mutex_t init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - if (scm_is_false (eval_string)) + scm_i_scm_pthread_mutex_lock (&init_mutex); + if (SCM_UNBNDP (eval_string)) { - eval_string = scm_c_public_lookup ("ice-9 eval-string", "eval-string"); + eval_string = scm_c_public_variable ("ice-9 eval-string", "eval-string"); k_module = scm_from_locale_keyword ("module"); } + scm_i_pthread_mutex_unlock (&init_mutex); if (SCM_UNBNDP (module)) module = scm_current_module (); From a2dead1b0fb6523598e3acbbe91127eaf47fe98c Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sun, 3 Mar 2013 04:34:17 -0500 Subject: [PATCH 046/147] Improve code in scm_gcd for inum/inum case * libguile/numbers.c (scm_gcd): Improve implementation of inum/inum case to be more clear and efficient. --- libguile/numbers.c | 54 +++++++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 66c95db90..9c28a792b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3889,52 +3889,58 @@ SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1, SCM scm_gcd (SCM x, SCM y) { - if (SCM_UNBNDP (y)) + if (SCM_UNLIKELY (SCM_UNBNDP (y))) return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x); - if (SCM_I_INUMP (x)) + if (SCM_LIKELY (SCM_I_INUMP (x))) { - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum xx = SCM_I_INUM (x); scm_t_inum yy = SCM_I_INUM (y); scm_t_inum u = xx < 0 ? -xx : xx; scm_t_inum v = yy < 0 ? -yy : yy; scm_t_inum result; - if (xx == 0) + if (SCM_UNLIKELY (xx == 0)) result = v; - else if (yy == 0) + else if (SCM_UNLIKELY (yy == 0)) result = u; else { - scm_t_inum k = 1; - scm_t_inum t; + int k = 0; /* Determine a common factor 2^k */ - while (!(1 & (u | v))) + while (((u | v) & 1) == 0) { - k <<= 1; + k++; u >>= 1; v >>= 1; } /* Now, any factor 2^n can be eliminated */ - if (u & 1) - t = -v; + if ((u & 1) == 0) + while ((u & 1) == 0) + u >>= 1; else + while ((v & 1) == 0) + v >>= 1; + /* Both u and v are now odd. Subtract the smaller one + from the larger one to produce an even number, remove + more factors of two, and repeat. */ + while (u != v) { - t = u; - b3: - t = SCM_SRS (t, 1); + if (u > v) + { + u -= v; + while ((u & 1) == 0) + u >>= 1; + } + else + { + v -= u; + while ((v & 1) == 0) + v >>= 1; + } } - if (!(1 & t)) - goto b3; - if (t > 0) - u = t; - else - v = -t; - t = u - v; - if (t != 0) - goto b3; - result = u * k; + result = u << k; } return (SCM_POSFIXABLE (result) ? SCM_I_MAKINUM (result) From cba521fe42484b6689769a484408de56545d8678 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 4 Mar 2013 18:37:23 -0500 Subject: [PATCH 047/147] Verify that FLT_RADIX is 2. * libguile/numbers.c: Trigger a compilation error if FLT_RADIX is not 2. This has long been assumed by code in numbers.c. --- libguile/numbers.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9c28a792b..393cf649d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -81,6 +81,9 @@ #define M_PI 3.14159265358979323846 #endif +/* FIXME: We assume that FLT_RADIX is 2 */ +verify (FLT_RADIX == 2); + typedef scm_t_signed_bits scm_t_inum; #define scm_from_inum(x) (scm_from_signed_integer (x)) From 0c8a2c380d705a5113f01d5f8e042897969ca844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 4 Mar 2013 21:24:52 +0100 Subject: [PATCH 048/147] doc: Allow compilation of r5rs.texi with Texinfo 5.0. * doc/r5rs/r5rs.texi: Remove extraneous @author. Change @unnumbered to @majorheading within @titlepage. --- doc/r5rs/r5rs.texi | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/r5rs/r5rs.texi b/doc/r5rs/r5rs.texi index b7722c1b6..775c93094 100644 --- a/doc/r5rs/r5rs.texi +++ b/doc/r5rs/r5rs.texi @@ -106,7 +106,6 @@ @author C. H@sc{ANSON} @author K. M. P@sc{ITMAN} @author M. W@sc{AND} -@author @c {\it Dedicated to the Memory of ALGOL 60} @@ -116,7 +115,7 @@ -@unnumbered Summary +@majorheading Summary The report gives a defining description of the programming language From e6a7a86d7ec9fe1dcb77686ca549766e1641a961 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 7 Mar 2013 00:03:36 +0100 Subject: [PATCH 049/147] Use `scm_is_eq' in load.c. * libguile/load.c (is_file_name_separator): Use `scm_is_eq' instead of `=='. --- libguile/load.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index f2af6c83b..8d50b21b0 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -456,10 +456,10 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) static int is_file_name_separator (SCM c) { - if (c == SCM_MAKE_CHAR ('/')) + if (scm_is_eq (c, SCM_MAKE_CHAR ('/'))) return 1; #ifdef __MINGW32__ - if (c == SCM_MAKE_CHAR ('\\')) + if (scm_is_eq (c, SCM_MAKE_CHAR ('\\'))) return 1; #endif return 0; From 6db7ee7b3ae8a7dbd6dc194921024287bed40a0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 7 Mar 2013 00:05:23 +0100 Subject: [PATCH 050/147] Make `SCM_LONG_BIT' usable in preprocessor conditionals. Reported by Jan Schukat <shookie@email.de>. Partly fixes <http://bugs.gnu.org/13848>. * libguile/__scm.h (SCM_LONG_BIT)[!defined LONG_BIT]: Use SCM_SIZEOF_LONG since `sizeof' cannot be used in #if directives as found in numbers.c. --- libguile/__scm.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index 47ed12b75..ed35d531b 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -433,7 +433,7 @@ #ifdef LONG_BIT # define SCM_LONG_BIT LONG_BIT #else -# define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char)) +# define SCM_LONG_BIT (SCM_SIZEOF_LONG * 8) #endif #define SCM_I_UTYPE_MAX(type) ((type)-1) From e20cec744fad8299afd9bbb6ac49505b15437618 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Tue, 5 Mar 2013 14:42:32 +0100 Subject: [PATCH 051/147] fix compilation under mingw * libguile/load.c (is_absolute_file_name, search_path): Fix compilation under mingw. --- libguile/load.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 8d50b21b0..da75a5a71 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -478,23 +478,25 @@ is_drive_letter (SCM c) } static int -is_absolute_file_name (const char *filename_chars, size_t filename_len) +is_absolute_file_name (SCM filename) { + size_t filename_len = scm_c_string_length (filename); + if (filename_len >= 1 - && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[0])) + && is_file_name_separator (scm_c_string_ref (filename, 0)) #ifdef __MINGW32__ /* On Windows, one initial separator indicates a drive-relative path. Two separators indicate a Universal Naming Convention (UNC) path. UNC paths are always absolute. */ && filename_len >= 2 - && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[1])) + && is_file_name_separator (scm_c_string_ref (filename, 1)) #endif ) return 1; if (filename_len >= 3 - && is_drive_letter (SCM_MAKE_CHAR (filename_chars[0])) - && filename_chars[1] == ':' - && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[2]))) + && is_drive_letter (scm_c_string_ref (filename, 0)) + && scm_is_eq (scm_c_string_ref (filename, 1), SCM_MAKE_CHAR (':')) + && is_file_name_separator (scm_c_string_ref (filename, 2))) return 1; return 0; } @@ -529,7 +531,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, scm_dynwind_free (filename_chars); /* If FILENAME is absolute and is still valid, return it unchanged. */ - if (is_absolute_file_name (filename_chars, filename_len)) + if (is_absolute_file_name (filename)) { if ((scm_is_false (require_exts) || scm_c_string_has_an_ext (filename_chars, filename_len, From 1b787ef9ec3a08f12d7b46403f4d508e583499a2 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Tue, 5 Mar 2013 18:22:11 +0100 Subject: [PATCH 052/147] structs with tail arrays are not simple * libguile/struct.h (SCM_VTABLE_FLAG_SIMPLE, SCM_VTABLE_FLAG_SIMPLE_RW): * libguile/struct.c (set_vtable_layout_flags): Vtable whose layouts include a tail array are not simple. Fixes bug 12808. --- libguile/struct.c | 9 ++++----- libguile/struct.h | 6 +++--- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index db1687ef8..3906a42cf 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 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 License @@ -153,8 +153,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, #undef FUNC_NAME -/* Check whether VTABLE instances have a simple layout (i.e., either only "pr" - or only "pw" fields) and update its flags accordingly. */ +/* Check whether VTABLE instances have a simple layout (i.e., either + only "pr" or only "pw" fields and no tail array) and update its flags + accordingly. */ static void set_vtable_layout_flags (SCM vtable) { @@ -180,13 +181,11 @@ set_vtable_layout_flags (SCM vtable) switch (c_layout[field + 1]) { case 'w': - case 'W': if (field == 0) flags |= SCM_VTABLE_FLAG_SIMPLE_RW; break; case 'r': - case 'R': flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW; break; diff --git a/libguile/struct.h b/libguile/struct.h index 643fd9dc9..0b31cf52e 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -3,7 +3,7 @@ #ifndef SCM_STRUCT_H #define SCM_STRUCT_H -/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 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 License @@ -108,8 +108,8 @@ #define SCM_VTABLE_FLAG_APPLICABLE (1L << 3) /* instances of this vtable are applicable? */ #define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 4) /* instances of this vtable are applicable-with-setter vtables? */ #define SCM_VTABLE_FLAG_SETTER (1L << 5) /* instances of this vtable are applicable-with-setters? */ -#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only "p" fields */ -#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields */ +#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only "p" fields and no tail array*/ +#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields and no tail array */ #define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8) #define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9) #define SCM_VTABLE_FLAG_RESERVED_2 (1L << 10) From 7f893030abaf49711f948d76f124e18bfa9e4181 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Tue, 22 Nov 2011 12:11:48 +0100 Subject: [PATCH 053/147] Install the current locale if GUILE_INSTALL_LOCALE is nonzero. * libguile/guile.c (get_integer_from_environment) (should_install_locale): New functions. (main): Add `setlocale' call. * doc/ref/guile-invoke.texi (Environment Variables): Add documentation. --- doc/ref/guile-invoke.texi | 18 ++++++++++++++++- libguile/guile.c | 41 +++++++++++++++++++++++++++++++++++++-- 2 files changed, 56 insertions(+), 3 deletions(-) diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 5a9a3f7ef..7cf4c9f88 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -291,6 +291,22 @@ This variable names the file that holds the Guile REPL command history. You can specify a different history file by setting this environment variable. By default, the history file is @file{$HOME/.guile_history}. +@item GUILE_INSTALL_LOCALE +@vindex GUILE_INSTALL_LOCALE +This is a flag that can be used to tell Guile whether or not to install +the current locale at startup, via a call to @code{(setlocale LC_ALL +"")}. @xref{Locales}, for more information on locales. + +You may explicitly indicate that you do not want to install +the locale by setting @env{GUILE_INSTALL_LOCALE} to @code{0}, or +explicitly enable it by setting the variable to @code{1}. + +Usually, installing the current locale is the right thing to do. It +allows Guile to correctly parse and print strings with non-ASCII +characters. However, for compatibility with previous Guile 2.0 +releases, this option is off by default. The next stable release series +of Guile (the 2.2 series) will install locales by default. + @item GUILE_LOAD_COMPILED_PATH @vindex GUILE_LOAD_COMPILED_PATH This variable may be used to augment the path that is searched for diff --git a/libguile/guile.c b/libguile/guile.c index ac22b83df..2c3be8e2f 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1996,1997,2000,2001, 2006, 2008, 2011 Free Software Foundation, Inc. - * +/* Copyright (C) 1996, 1997, 2000, 2001, 2006, 2008, + * 2011, 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 License * as published by the Free Software Foundation; either version 3 of @@ -36,6 +37,7 @@ #include <libguile/scmconfig.h> #endif #include <ltdl.h> +#include <locale.h> #ifdef HAVE_WINSOCK2_H #include <winsock2.h> @@ -64,9 +66,44 @@ inner_main (void *closure SCM_UNUSED, int argc, char **argv) #endif /* __MINGW32__ */ } +static int +get_integer_from_environment (const char *var, int def) +{ + char *end = 0; + char *val = getenv (var); + long res = def; + if (!val) + return def; + res = strtol (val, &end, 10); + if (end == val) + { + fprintf (stderr, "guile: warning: invalid %s: %s\n", var, val); + return def; + } + return res; +} + +static int +should_install_locale (void) +{ + /* If the GUILE_INSTALL_LOCALE environment variable is set to a + nonzero value, we should install the locale via setlocale(). This + behavior is off by default for compatibility with previous 2.0.x + releases. It will be on by default in 2.2. */ + return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 0); +} + int main (int argc, char **argv) { + /* If we should install a locale, do it right at the beginning so that + string conversion for command-line arguments, along with possible + error messages, use the right locale. See + <https://lists.gnu.org/archive/html/guile-devel/2011-11/msg00041.html> + for the rationale. */ + if (should_install_locale () && setlocale (LC_ALL, "") == NULL) + fprintf (stderr, "guile: warning: failed to install locale\n"); + scm_install_gmp_memory_functions = 1; scm_boot_guile (argc, argv, inner_main, 0); return 0; /* never reached */ From 83dce818ec912def820808c059ee6f9c3801585e Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Thu, 7 Mar 2013 11:02:33 +0100 Subject: [PATCH 054/147] GUILE_INSTALL_LOCALE=1 during build * doc/ref/Makefile.am (autoconf-macros.texi): * libguile/Makefile.am (snarf2checkedtexi): * module/Makefile.am (ice-9/psyntax-pp.scm.gen, ice-9/psyntax-pp.go): * test-suite/Makefile.am (GUILE_AUTO_COMPILE): * test-suite/standalone/Makefile.am (GUILE_INSTALL_LOCALE): * test-suite/vm/Makefile.am (TESTS_ENVIRONMENT): * am/guilec (.scm.go): Set GUILE_INSTALL_LOCALE to 1 during the build. Fixes bug 12887. --- am/guilec | 2 +- doc/ref/Makefile.am | 3 ++- libguile/Makefile.am | 3 ++- module/Makefile.am | 5 +++-- test-suite/Makefile.am | 4 +++- test-suite/standalone/Makefile.am | 4 ++-- test-suite/vm/Makefile.am | 3 ++- 7 files changed, 15 insertions(+), 9 deletions(-) diff --git a/am/guilec b/am/guilec index 7634a9716..f5849d079 100644 --- a/am/guilec +++ b/am/guilec @@ -26,7 +26,7 @@ AM_V_GUILEC_0 = @echo " GUILEC" $@; SUFFIXES = .scm .go .scm.go: - $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ + $(AM_V_GUILEC)GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \ $(top_builddir)/meta/uninstalled-env \ guild compile --target="$(host)" $(GUILE_WARNINGS) \ -L "$(abs_srcdir)" -L "$(abs_builddir)" \ diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 260bb1448..4b1706e2b 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -118,7 +118,8 @@ EXTRA_DIST = ChangeLog-2008 $(PICTURES) libguile-autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/meta/guile.m4 - GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guild \ + GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \ + $(top_builddir)/meta/uninstalled-env guild \ snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ > $(srcdir)/$@ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 0a401206f..8df2f7c4a 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -703,7 +703,8 @@ load.x: libpath.h dynl.x: libpath.h alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) -snarf2checkedtexi = GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guild snarf-check-and-output-texi +snarf2checkedtexi = GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \ + $(top_builddir)/meta/uninstalled-env guild snarf-check-and-output-texi dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi) guile.texi: $(alldotdocfiles) guile$(EXEEXT) diff --git a/module/Makefile.am b/module/Makefile.am index 79957c1b8..c47d0b476 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -80,14 +80,15 @@ ETAGS_ARGS += \ ice-9/ChangeLog-2008 ice-9/psyntax-pp.scm.gen: - $(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \ + GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \ + $(top_builddir_absolute)/meta/guile -s $(srcdir)/ice-9/compile-psyntax.scm \ $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm .PHONY: ice-9/psyntax-pp.scm.gen # Keep this rule in sync with that in `am/guilec'. ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm - $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ + $(AM_V_GUILEC)GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \ $(top_builddir)/meta/uninstalled-env \ guild compile --target="$(host)" $(GUILE_WARNINGS) \ -L "$(abs_srcdir)" -L "$(abs_builddir)" \ diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 9fba7b8b3..e7c8c4177 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -214,7 +214,9 @@ LALR_EXTRA += \ TESTS = $(LALR_TESTS) TESTS_ENVIRONMENT = \ + GUILE_INSTALL_LOCALE=1 \ + GUILE_AUTO_COMPILE=0 \ @LOCALCHARSET_TESTS_ENVIRONMENT@ \ - $(top_builddir)/meta/guile --no-auto-compile + $(top_builddir)/meta/guile EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS) tests/sxml-match-tests.ss diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index be5d91380..4b1c8227c 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -35,9 +35,9 @@ TESTS_ENVIRONMENT = \ srcdir="$(srcdir)" \ builddir="$(builddir)" \ @LOCALCHARSET_TESTS_ENVIRONMENT@ \ - GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env" + GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env" -## Check for headers in $(srcdir) and bulid dir before $(CPPFLAGS), which +## Check for headers in $(srcdir) and build dir before $(CPPFLAGS), which ## may point us to an old, installed version of guile. AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \ -I$(top_srcdir)/lib -I$(top_builddir)/lib diff --git a/test-suite/vm/Makefile.am b/test-suite/vm/Makefile.am index 0e6e974e2..2a3e38f87 100644 --- a/test-suite/vm/Makefile.am +++ b/test-suite/vm/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright 2005, 2006, 2008, 2009, 2010 Software Foundation, Inc. +## Copyright 2005, 2006, 2008, 2009, 2010, 2013 Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -20,6 +20,7 @@ ## Fifth Floor, Boston, MA 02110-1301 USA TESTS_ENVIRONMENT = \ + GUILE_INSTALL_LOCALE=1 \ $(top_builddir)/meta/guile \ -l $(srcdir)/run-vm-tests.scm -e run-vm-tests From 8d48877d2cacebeb1352404b0e2514a60416c8a4 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Thu, 7 Mar 2013 11:29:01 +0100 Subject: [PATCH 055/147] ,option evaluates its right-hand-side * doc/ref/scheme-using.texi (System Commands): Better documentation for ,option. * module/system/repl/command.scm (option): Evaluate the RHS when setting an option. Fixes bug 13076. --- doc/ref/scheme-using.texi | 7 +++++-- module/system/repl/command.scm | 12 +++++++----- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index e0f91af02..81576605b 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -430,8 +430,11 @@ Garbage collection. Display statistics. @end deffn -@deffn {REPL Command} option [key value] -List/show/set options. +@deffn {REPL Command} option [name] [exp] +With no arguments, lists all options. With one argument, shows the +current value of the @var{name} option. With two arguments, sets the +@var{name} option to the result of evaluating the Scheme expression +@var{exp}. @end deffn @deffn {REPL Command} quit diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index c4e9e2ce5..8ad00da08 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -351,18 +351,20 @@ Show description/documentation." (newline)) (define-meta-command (option repl . args) - "option [KEY VALUE] + "option [NAME] [EXP] List/show/set options." (pmatch args (() (for-each (lambda (spec) (format #t " ~A~24t~A\n" (car spec) (cadr spec))) (repl-options repl))) - ((,key) - (display (repl-option-ref repl key)) + ((,name) + (display (repl-option-ref repl name)) (newline)) - ((,key ,val) - (repl-option-set! repl key val)))) + ((,name ,exp) + ;; Would be nice to evaluate in the current language, but the REPL + ;; option parser doesn't permit that, currently. + (repl-option-set! repl name (eval exp (current-module)))))) (define-meta-command (quit repl) "quit From d0ecf8eb9e154dcc253b1ea302d67d41bcc4ee36 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Thu, 7 Mar 2013 13:59:18 +0100 Subject: [PATCH 056/147] support calls and tail-calls with more than 255 formals * module/language/tree-il/compile-glil.scm (flatten-lambda-case): Support calls and tail-calls with more than 255 formals. * test-suite/tests/tree-il.test ("many args"): Add a test. --- module/language/tree-il/compile-glil.scm | 17 ++++++++++++++--- test-suite/tests/tree-il.test | 18 +++++++++++++++++- 2 files changed, 31 insertions(+), 4 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index a9f6df938..e4df6e1bd 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -1,6 +1,6 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc. +;; Copyright (C) 2001,2008,2009,2010,2011,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 @@ -527,9 +527,20 @@ (for-each comp-push args) (let ((len (length args))) (case context - ((tail) (emit-code src (make-glil-call 'tail-call len))) - ((push) (emit-code src (make-glil-call 'call len)) + ((tail) (if (<= len #xff) + (emit-code src (make-glil-call 'tail-call len)) + (begin + (comp-push (make-const #f len)) + (emit-code src (make-glil-call 'tail-call/nargs 0))))) + ((push) (if (<= len #xff) + (emit-code src (make-glil-call 'call len)) + (begin + (comp-push (make-const #f len)) + (emit-code src (make-glil-call 'call/nargs 0)))) (maybe-emit-return)) + ;; FIXME: mv-call doesn't have a /nargs variant, so it is + ;; limited to 255 args. Can work around it with a + ;; trampoline and tail-call/nargs, but it's not so nice. ((vals) (emit-code src (make-glil-mv-call len MVRA)) (maybe-emit-return)) ((drop) (let ((MV (make-label)) (POST (make-label))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 2217ffcf2..ddc3e7633 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 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 @@ -701,6 +701,22 @@ ;; reduce the entire thing to #t. #:opts '(#:partial-eval? #f))))) + +(define (sum . args) + (apply + args)) + +(with-test-prefix "many args" + (pass-if "call with > 256 args" + (equal? (compile `(1+ (sum ,@(iota 1000))) + #:env (current-module)) + (1+ (apply sum (iota 1000))))) + + (pass-if "tail call with > 256 args" + (equal? (compile `(sum ,@(iota 1000)) + #:env (current-module)) + (apply sum (iota 1000))))) + + (with-test-prefix "tree-il-fold" From aab9d46c83c2ad03abb0a2dc000167e552de2c29 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe <stefan.itampe@gmail.com> Date: Wed, 12 Dec 2012 17:37:44 +0100 Subject: [PATCH 057/147] add GUILE_STACK_SIZE environment variable * libguile/vm.c (initialize_default_stack_size): New helper. (scm_bootstrap_vm): Call initialize_default_stack_size. * doc/ref/guile-invoke.texi (Environment Variables): Add docs. Based on a patch by Stefan Israelsson Tampe. --- doc/ref/guile-invoke.texi | 12 ++++++++++++ libguile/vm.c | 18 ++++++++++++++++-- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 7cf4c9f88..397bc47e4 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -307,6 +307,18 @@ characters. However, for compatibility with previous Guile 2.0 releases, this option is off by default. The next stable release series of Guile (the 2.2 series) will install locales by default. +@item GUILE_STACK_SIZE +@vindex GUILE_STACK_SIZE +Guile currently has a limited stack size for Scheme computations. +Attempting to call too many nested functions will signal an error. This +is good to detect infinite recursion, but sometimes the limit is reached +for normal computations. This environment variable, if set to a +positive integer, specifies the number of Scheme value slots to allocate +for the stack. + +In the future we will implement stacks that can grow and shrink, but for +now this hack will have to do. + @item GUILE_LOAD_COMPILED_PATH @vindex GUILE_LOAD_COMPILED_PATH This variable may be used to augment the path that is searched for diff --git a/libguile/vm.c b/libguile/vm.c index 5dec106a5..6a4ecd8e4 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 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 License @@ -37,6 +37,8 @@ #include "programs.h" #include "vm.h" +#include "private-gc.h" /* scm_getenv_int */ + static int vm_default_engine = SCM_VM_REGULAR_ENGINE; /* Unfortunately we can't snarf these: snarfed things are only loaded up from @@ -633,7 +635,17 @@ resolve_variable (SCM what, SCM program_module) } } +#define VM_MIN_STACK_SIZE (1024) #define VM_DEFAULT_STACK_SIZE (64 * 1024) +static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE; + +static void +initialize_default_stack_size (void) +{ + int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size); + if (size >= VM_MIN_STACK_SIZE) + vm_stack_size = size; +} #define VM_NAME vm_regular_engine #define FUNC_NAME "vm-regular-engine" @@ -670,7 +682,7 @@ make_vm (void) vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); - vp->stack_size = VM_DEFAULT_STACK_SIZE; + vp->stack_size= vm_stack_size; #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN vp->stack_base = (SCM *) @@ -1086,6 +1098,8 @@ scm_bootstrap_vm (void) "scm_init_vm", (scm_t_extension_init_func)scm_init_vm, NULL); + initialize_default_stack_size (); + sym_vm_run = scm_from_latin1_symbol ("vm-run"); sym_vm_error = scm_from_latin1_symbol ("vm-error"); sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); From 929d11b2c1e1060a51bf7e395ab0ddd48e599144 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 6 Mar 2013 12:52:39 -0500 Subject: [PATCH 058/147] Improve standards conformance of string->number. Fixes <http://bugs.gnu.org/11887>. * libguile/numbers.c (mem2ureal): New argument 'allow_inf_or_nan'. Accept infinities and NaNs only if 'allow_inf_or_nan' is true and "#e" is not present. Check for "inf.0" or "nan." case-insensitively. Do not accept rationals with zero divisors. (mem2complex): Pass new 'allow_inf_or_nan' argument to 'mem2ureal', which is set if and only if a explicit sign was present. * test-suite/tests/numbers.test ("string->number"): Add tests. --- libguile/numbers.c | 76 +++++++++++++++++++++++------------ test-suite/tests/numbers.test | 12 +++++- 2 files changed, 61 insertions(+), 27 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 393cf649d..bb1ecf5ed 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5749,7 +5749,8 @@ mem2decimal_from_point (SCM result, SCM mem, static SCM mem2ureal (SCM mem, unsigned int *p_idx, - unsigned int radix, enum t_exactness forced_x) + unsigned int radix, enum t_exactness forced_x, + int allow_inf_or_nan) { unsigned int idx = *p_idx; SCM result; @@ -5762,30 +5763,53 @@ mem2ureal (SCM mem, unsigned int *p_idx, if (idx == len) return SCM_BOOL_F; - if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0")) - { - *p_idx = idx+5; - return scm_inf (); - } - - if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan.")) - { - /* Cobble up the fractional part. We might want to set the - NaN's mantissa from it. */ - idx += 4; - if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0)) - { + if (allow_inf_or_nan && forced_x != EXACT && idx+5 <= len) + switch (scm_i_string_ref (mem, idx)) + { + case 'i': case 'I': + switch (scm_i_string_ref (mem, idx + 1)) + { + case 'n': case 'N': + switch (scm_i_string_ref (mem, idx + 2)) + { + case 'f': case 'F': + if (scm_i_string_ref (mem, idx + 3) == '.' + && scm_i_string_ref (mem, idx + 4) == '0') + { + *p_idx = idx+5; + return scm_inf (); + } + } + } + case 'n': case 'N': + switch (scm_i_string_ref (mem, idx + 1)) + { + case 'a': case 'A': + switch (scm_i_string_ref (mem, idx + 2)) + { + case 'n': case 'N': + if (scm_i_string_ref (mem, idx + 3) == '.') + { + /* Cobble up the fractional part. We might want to + set the NaN's mantissa from it. */ + idx += 4; + if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), + SCM_INUM0)) + { #if SCM_ENABLE_DEPRECATED == 1 - scm_c_issue_deprecation_warning - ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'."); + scm_c_issue_deprecation_warning + ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'."); #else - return SCM_BOOL_F; + return SCM_BOOL_F; #endif - } + } - *p_idx = idx; - return scm_nan (); - } + *p_idx = idx; + return scm_nan (); + } + } + } + } if (scm_i_string_ref (mem, idx) == '.') { @@ -5818,7 +5842,7 @@ mem2ureal (SCM mem, unsigned int *p_idx, return SCM_BOOL_F; divisor = mem2uinteger (mem, &idx, radix, &implicit_x); - if (scm_is_false (divisor)) + if (scm_is_false (divisor) || scm_is_eq (divisor, SCM_INUM0)) return SCM_BOOL_F; /* both are int/big here, I assume */ @@ -5894,7 +5918,7 @@ mem2complex (SCM mem, unsigned int idx, if (idx == len) return SCM_BOOL_F; - ureal = mem2ureal (mem, &idx, radix, forced_x); + ureal = mem2ureal (mem, &idx, radix, forced_x, sign != 0); if (scm_is_false (ureal)) { /* input must be either +i or -i */ @@ -5963,9 +5987,9 @@ mem2complex (SCM mem, unsigned int idx, sign = -1; } else - sign = 1; + sign = 0; - angle = mem2ureal (mem, &idx, radix, forced_x); + angle = mem2ureal (mem, &idx, radix, forced_x, sign != 0); if (scm_is_false (angle)) return SCM_BOOL_F; if (idx != len) @@ -5987,7 +6011,7 @@ mem2complex (SCM mem, unsigned int idx, else { int sign = (c == '+') ? 1 : -1; - SCM imag = mem2ureal (mem, &idx, radix, forced_x); + SCM imag = mem2ureal (mem, &idx, radix, forced_x, sign != 0); if (scm_is_false (imag)) imag = SCM_I_MAKINUM (sign); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 66aa01ae0..be378b724 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1493,7 +1493,9 @@ "#o.2" "3.4q" "15.16e17q" "18.19e+q" ".q" ".17#18" "10q" "#b2" "#b3" "#b4" "#b5" "#b6" "#b7" "#b8" "#b9" "#ba" "#bb" "#bc" "#bd" "#be" "#bf" "#q" "#b#b1" "#o#o1" "#d#d1" "#x#x1" "#e#e1" - "#i#i1" "12@12+0i")) + "#i#i1" "12@12+0i" "3/0" "0/0" "4+3/0i" "4/0-3i" "2+0/0i" + "nan.0" "inf.0" "#e+nan.0" "#e+inf.0" "#e-inf.0" + "3@inf.0" "4@nan.0")) #t) (pass-if "valid number strings" @@ -1532,6 +1534,14 @@ ("1/1" 1) ("1/2" 1/2) ("-1/2" -1/2) ("1#/1" 10.0) ("10/1#" 1.0) ("1#/1#" 1.0) ("#e9/10" 9/10) ("#e10/1#" 1) ("#i6/8" 0.75) ("#i1/1" 1.0) + ;; Infinities and NaNs: + ("+inf.0" ,(inf)) ("-inf.0" ,(- (inf))) + ("+Inf.0" ,(inf)) ("-Inf.0" ,(- (inf))) + ("+InF.0" ,(inf)) ("-InF.0" ,(- (inf))) + ("+INF.0" ,(inf)) ("-INF.0" ,(- (inf))) + ("#i+InF.0" ,(inf)) ("#i-InF.0" ,(- (inf))) + ("+nan.0" ,(nan)) ("-nan.0" ,(nan)) + ("#i+nan.0" ,(nan)) ("#i-nan.0" ,(nan)) ;; Decimal numbers: ;; * <uinteger 10> <suffix> ("1e2" 100.0) ("1E2" 100.0) ("1s2" 100.0) ("1S2" 100.0) From 9ddf06dceee3a2bf5480a3e261ec01aaa91a1f67 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 10:29:57 +0100 Subject: [PATCH 059/147] fix in-tree guile reference * meta/guile.in (GUILE): Add @EXEEXT@ for libguile/guile reference, for MinGW compiles. --- meta/guile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/meta/guile.in b/meta/guile.in index 512582746..3d4cacf97 100644 --- a/meta/guile.in +++ b/meta/guile.in @@ -1,6 +1,6 @@ #!/bin/sh -# Copyright (C) 2002, 2006, 2008, 2009 Free Software Foundation +# Copyright (C) 2002, 2006, 2008, 2009, 2013 Free Software Foundation # # This file is part of GUILE. # @@ -39,7 +39,7 @@ top_builddir="@top_builddir_absolute@" # set GUILE (clobber) -GUILE=${top_builddir}/libguile/guile +GUILE=${top_builddir}/libguile/guile@EXEEXT@ export GUILE XDG_CACHE_HOME=${top_builddir}/cache export XDG_CACHE_HOME From 19113f1ca7a747de06d7b43c6c1eca4cd58d05e5 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 2 Mar 2013 19:04:47 +0100 Subject: [PATCH 060/147] allow case-lambda expressions with no clauses * module/ice-9/psyntax-pp.scm: * module/ice-9/psyntax.scm (case-lambda, case-lambda*): Allow 0 clauses. * module/language/scheme/decompile-tree-il.scm (do-decompile): (choose-output-names): * module/language/tree-il.scm (unparse-tree-il): (tree-il-fold, post-order!, pre-order!): * module/language/tree-il/effects.scm (make-effects-analyzer): * module/language/tree-il/cse.scm (cse): * module/language/tree-il/debug.scm (verify-tree-il): * module/language/tree-il/peval.scm (peval): Allow for lambda-body to be #f. * libguile/memoize.c (memoize): * module/language/tree-il/canonicalize.scm (canonicalize!): Give a body to empty case-lambda before evaluating it or compiling it, respectively. * test-suite/tests/optargs.test ("case-lambda", "case-lambda*"): Add tests. --- libguile/memoize.c | 25 ++++++++++++-- module/ice-9/psyntax-pp.scm | 30 +++++++---------- module/ice-9/psyntax.scm | 8 ++--- module/language/scheme/decompile-tree-il.scm | 35 +++++++++++--------- module/language/tree-il.scm | 22 ++++++++---- module/language/tree-il/canonicalize.scm | 17 +++++++++- module/language/tree-il/cse.scm | 8 +++-- module/language/tree-il/debug.scm | 7 ++-- module/language/tree-il/effects.scm | 9 +++-- module/language/tree-il/peval.scm | 4 +-- test-suite/tests/optargs.test | 13 ++++++++ 11 files changed, 120 insertions(+), 58 deletions(-) diff --git a/libguile/memoize.c b/libguile/memoize.c index 584096fbd..dfbeea781 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -269,14 +269,33 @@ memoize (SCM exp, SCM env) return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env)); case SCM_EXPANDED_LAMBDA: - /* The body will be a lambda-case. */ + /* The body will be a lambda-case or #f. */ { - SCM meta, docstring, proc; + SCM meta, docstring, body, proc; meta = REF (exp, LAMBDA, META); docstring = scm_assoc_ref (meta, scm_sym_documentation); - proc = memoize (REF (exp, LAMBDA, BODY), env); + body = REF (exp, LAMBDA, BODY); + if (scm_is_false (body)) + /* Give a body to case-lambda with no clauses. */ + proc = MAKMEMO_LAMBDA + (MAKMEMO_CALL + (MAKMEMO_MOD_REF (list_of_guile, + scm_from_latin1_symbol ("throw"), + SCM_BOOL_F), + 5, + scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key), + MAKMEMO_QUOTE (SCM_BOOL_F), + MAKMEMO_QUOTE (scm_from_latin1_string + ("Wrong number of arguments")), + MAKMEMO_QUOTE (SCM_EOL), + MAKMEMO_QUOTE (SCM_BOOL_F))), + FIXED_ARITY (0), + SCM_BOOL_F /* docstring */); + else + proc = memoize (body, env); + if (scm_is_string (docstring)) { SCM args = SCM_MEMOIZED_ARGS (proc); diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 2adb83ec6..7b565dbe8 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1743,11 +1743,9 @@ 'case-lambda (lambda (e r w s mod) (let* ((tmp e) - (tmp ($sc-dispatch - tmp - '(_ (any any . each-any) . #(each (any any . each-any)))))) + (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any)))))) (if tmp - (apply (lambda (args e1 e2 args* e1* e2*) + (apply (lambda (args e1 e2) (call-with-values (lambda () (expand-lambda-case @@ -1757,11 +1755,10 @@ s mod lambda-formals - (cons (cons args (cons e1 e2)) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - e2* - e1* - args*)))) + (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + e2 + e1 + args))) (lambda (meta lcase) (build-case-lambda s meta lcase)))) tmp) (syntax-violation 'case-lambda "bad case-lambda" e))))) @@ -1770,11 +1767,9 @@ 'case-lambda* (lambda (e r w s mod) (let* ((tmp e) - (tmp ($sc-dispatch - tmp - '(_ (any any . each-any) . #(each (any any . each-any)))))) + (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any)))))) (if tmp - (apply (lambda (args e1 e2 args* e1* e2*) + (apply (lambda (args e1 e2) (call-with-values (lambda () (expand-lambda-case @@ -1784,11 +1779,10 @@ s mod lambda*-formals - (cons (cons args (cons e1 e2)) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - e2* - e1* - args*)))) + (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + e2 + e1 + args))) (lambda (meta lcase) (build-case-lambda s meta lcase)))) tmp) (syntax-violation 'case-lambda "bad case-lambda*" e))))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 336c8da96..228d8e32a 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2076,12 +2076,12 @@ (global-extend 'core 'case-lambda (lambda (e r w s mod) (syntax-case e () - ((_ (args e1 e2 ...) (args* e1* e2* ...) ...) + ((_ (args e1 e2 ...) ...) (call-with-values (lambda () (expand-lambda-case e r w s mod lambda-formals - #'((args e1 e2 ...) (args* e1* e2* ...) ...))) + #'((args e1 e2 ...) ...))) (lambda (meta lcase) (build-case-lambda s meta lcase)))) (_ (syntax-violation 'case-lambda "bad case-lambda" e))))) @@ -2089,12 +2089,12 @@ (global-extend 'core 'case-lambda* (lambda (e r w s mod) (syntax-case e () - ((_ (args e1 e2 ...) (args* e1* e2* ...) ...) + ((_ (args e1 e2 ...) ...) (call-with-values (lambda () (expand-lambda-case e r w s mod lambda*-formals - #'((args e1 e2 ...) (args* e1* e2* ...) ...))) + #'((args e1 e2 ...) ...))) (lambda (meta lcase) (build-case-lambda s meta lcase)))) (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index 9191b2f96..f94661da4 100644 --- a/module/language/scheme/decompile-tree-il.scm +++ b/module/language/scheme/decompile-tree-il.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 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 @@ -256,20 +256,22 @@ (build-define name (recurse exp))) ((<lambda> meta body) - (let ((body (recurse body)) - (doc (assq-ref meta 'documentation))) - (if (not doc) - body - (match body - (('lambda formals body ...) - `(lambda ,formals ,doc ,@body)) - (('lambda* formals body ...) - `(lambda* ,formals ,doc ,@body)) - (('case-lambda (formals body ...) clauses ...) - `(case-lambda (,formals ,doc ,@body) ,@clauses)) - (('case-lambda* (formals body ...) clauses ...) - `(case-lambda* (,formals ,doc ,@body) ,@clauses)) - (e e))))) + (if body + (let ((body (recurse body)) + (doc (assq-ref meta 'documentation))) + (if (not doc) + body + (match body + (('lambda formals body ...) + `(lambda ,formals ,doc ,@body)) + (('lambda* formals body ...) + `(lambda* ,formals ,doc ,@body)) + (('case-lambda (formals body ...) clauses ...) + `(case-lambda (,formals ,doc ,@body) ,@clauses)) + (('case-lambda* (formals body ...) clauses ...) + `(case-lambda* (,formals ,doc ,@body) ,@clauses)) + (e e)))) + '(case-lambda))) ((<lambda-case> req opt rest kw inits gensyms body alternate) (let ((names (map output-name gensyms))) @@ -694,7 +696,8 @@ (recurse test) (recurse consequent) (recurse alternate)) ((<sequence> exps) (primitive 'begin) (for-each recurse exps)) - ((<lambda> body) (recurse body)) + ((<lambda> body) + (if body (recurse body))) ((<lambda-case> req opt rest kw inits gensyms body alternate) (primitive 'lambda) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 1ac1809fb..aa00b381e 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 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 @@ -287,7 +287,9 @@ `(define ,name ,(unparse-tree-il exp))) ((<lambda> meta body) - `(lambda ,meta ,(unparse-tree-il body))) + (if body + `(lambda ,meta ,(unparse-tree-il body)) + `(lambda ,meta (lambda-case)))) ((<lambda-case> req opt rest kw inits gensyms body alternate) `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) @@ -370,7 +372,11 @@ This is an implementation of `foldts' as described by Andy Wingo in ((<sequence> exps) (up tree (loop exps (down tree result)))) ((<lambda> body) - (up tree (loop body (down tree result)))) + (let ((result (down tree result))) + (up tree + (if body + (loop body result) + result)))) ((<lambda-case> inits body alternate) (up tree (if alternate (loop alternate @@ -442,7 +448,9 @@ This is an implementation of `foldts' as described by Andy Wingo in ((<sequence> exps) (fold-values foldts exps seed ...)) ((<lambda> body) - (foldts body seed ...)) + (if body + (foldts body seed ...) + (values seed ...))) ((<lambda-case> inits body alternate) (let-values (((seed ...) (fold-values foldts inits seed ...))) (if alternate @@ -511,7 +519,8 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (toplevel-define-exp x) (lp exp))) ((<lambda> body) - (set! (lambda-body x) (lp body))) + (if body + (set! (lambda-body x) (lp body)))) ((<lambda-case> inits body alternate) (set! inits (map lp inits)) @@ -595,7 +604,8 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (toplevel-define-exp x) (lp exp))) ((<lambda> body) - (set! (lambda-body x) (lp body))) + (if body + (set! (lambda-body x) (lp body)))) ((<lambda-case> inits body alternate) (set! inits (map lp inits)) diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm index c3229cab1..2fa8c2ec9 100644 --- a/module/language/tree-il/canonicalize.scm +++ b/module/language/tree-il/canonicalize.scm @@ -1,6 +1,6 @@ ;;; Tree-il canonicalizer -;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2011, 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 @@ -54,6 +54,21 @@ body) (($ <dynlet> src () () body) body) + (($ <lambda> src meta #f) + ;; Give a body to case-lambda with no clauses. + (make-lambda + src meta + (make-lambda-case + #f '() #f #f #f '() '() + (make-application + #f + (make-primitive-ref #f 'throw) + (list (make-const #f 'wrong-number-of-args) + (make-const #f #f) + (make-const #f "Wrong number of arguments") + (make-const #f '()) + (make-const #f #f))) + #f))) (($ <prompt> src tag body handler) (define (escape-only? handler) (match handler diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index d8c7e3fc9..b025bcb08 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -1,6 +1,6 @@ ;;; Common Subexpression Elimination (CSE) on Tree-IL -;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2011, 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 @@ -535,8 +535,10 @@ (return (make-application src proc args) (concat db** db*)))) (($ <lambda> src meta body) - (let*-values (((body _) (visit body (control-flow-boundary db) - env 'values))) + (let*-values (((body _) (if body + (visit body (control-flow-boundary db) + env 'values) + (values #f #f)))) (return (make-lambda src meta body) vlist-null))) (($ <lambda-case> src req opt rest kw inits gensyms body alt) diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm index 78f132416..97737c29b 100644 --- a/module/language/tree-il/debug.scm +++ b/module/language/tree-il/debug.scm @@ -1,6 +1,6 @@ ;;; Tree-IL verifier -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011, 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 @@ -115,10 +115,11 @@ (cond ((and meta (not (and (list? meta) (and-map pair? meta)))) (error "meta should be alist" meta)) - ((not (lambda-case? body)) + ((and body (not (lambda-case? body))) (error "lambda body should be lambda-case" exp)) (else - (visit body env)))) + (if body + (visit body env))))) (($ <let> src names gensyms vals body) (cond ((not (and (list? names) (and-map symbol? names))) diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm index 4610f7f8f..1fe4aebb0 100644 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@ -1,6 +1,6 @@ ;;; Effects analysis on Tree-IL -;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2011, 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 @@ -315,7 +315,12 @@ of an expression." (cause &type-check)))) (($ <lambda-case>) (logior (compute-effects body) - (cause &type-check)))))) + (cause &type-check))) + (#f + ;; Calling a case-lambda with no clauses + ;; definitely causes bailout. + (logior (cause &definite-bailout) + (cause &possible-bailout)))))) ;; Bailout primitives. (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name)) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index da3f4a82c..bf96179e0 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1440,14 +1440,14 @@ top-level bindings from ENV and return the resulting expression." ((operator) exp) (else (record-source-expression! exp - (make-lambda src meta (for-values body)))))) + (make-lambda src meta (and body (for-values body))))))) (($ <lambda-case> src req opt rest kw inits gensyms body alt) (define (lift-applied-lambda body gensyms) (and (not opt) rest (not kw) (match body (($ <application> _ ($ <primitive-ref> _ '@apply) - (($ <lambda> _ _ lcase) + (($ <lambda> _ _ (and lcase ($ <lambda-case>))) ($ <lexical-ref> _ _ sym) ...)) (and (equal? sym gensyms) diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 396fdeca8..0be1a541e 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -221,7 +221,20 @@ (equal? (transmogrify quote) 10))) +(with-test-prefix/c&e "case-lambda" + (pass-if-exception "no clauses, no args" exception:wrong-num-args + ((case-lambda))) + + (pass-if-exception "no clauses, args" exception:wrong-num-args + ((case-lambda) 1))) + (with-test-prefix/c&e "case-lambda*" + (pass-if-exception "no clauses, no args" exception:wrong-num-args + ((case-lambda*))) + + (pass-if-exception "no clauses, args" exception:wrong-num-args + ((case-lambda*) 1)) + (pass-if "unambiguous" ((case-lambda* ((a b) #t) From 4c187d46d40aff1601f38675c11f92a73a13a7c9 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 11:56:46 +0100 Subject: [PATCH 061/147] add check for struct pollfd * configure.ac: Add check for struct pollfd. * libguile/fports.c (fport_input_waiting): * libguile/poll.c (scm_primitive_poll): Require struct pollfd. Fixes bug 13903. --- configure.ac | 2 ++ libguile/fports.c | 4 ++-- libguile/poll.c | 8 ++++---- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/configure.ac b/configure.ac index cbad0a162..4157982d3 100644 --- a/configure.ac +++ b/configure.ac @@ -674,6 +674,8 @@ AC_CHECK_TYPE(socklen_t, , AC_CHECK_TYPES([struct ip_mreq], , , [#include <netinet/in.h>]) +AC_CHECK_TYPES([struct pollfd], , , [#include <poll.h>]) + GUILE_HEADER_LIBC_WITH_UNISTD AC_TYPE_GETGROUPS diff --git a/libguile/fports.c b/libguile/fports.c index 10cf6713a..c1a2800a2 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 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 License @@ -609,7 +609,7 @@ fport_input_waiting (SCM port) highest numerical value of file descriptors that can be monitored. Thus, use poll(2) whenever that is possible. */ -#ifdef HAVE_POLL +#if defined(HAVE_POLL) && defined(HAVE_STRUCT_POLLFD) struct pollfd pollfd = { fdes, POLLIN, 0 }; if (poll (&pollfd, 1, 0) < 0) diff --git a/libguile/poll.c b/libguile/poll.c index 1bb75727b..5bfd97b05 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2010 Free Software Foundation, Inc. +/* Copyright (C) 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 License @@ -73,7 +73,7 @@ If timeout is given and is non-negative, the poll will return after that number of milliseconds if no fd became active. */ -#ifdef HAVE_POLL +#if defined(HAVE_POLL) && defined(HAVE_STRUCT_POLLFD) static SCM scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) #define FUNC_NAME "primitive-poll" @@ -174,7 +174,7 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) return scm_from_int (rv); } #undef FUNC_NAME -#endif /* HAVE_POLL */ +#endif /* HAVE_POLL && HAVE_STRUCT_POLLFD */ @@ -182,7 +182,7 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) static void scm_init_poll (void) { -#if HAVE_POLL +#if defined(HAVE_POLL) && defined(HAVE_STRUCT_POLLFD) scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_poll); scm_c_define ("%sizeof-struct-pollfd", scm_from_size_t (sizeof (struct pollfd))); #else From 7e369c38993cc7cf4063a6cadc8496552abf323d Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 15:56:30 +0100 Subject: [PATCH 062/147] remove mingw32 implementations of {get,end,set}{serv,proto}ent * libguile/win32-socket.h: * libguile/win32-socket.c (getservent, endservent, setservent) (getprotoent, endprotoent, setprotoent): Remove mingw32 wrappers. Their place is in gnulib, if anywhere. --- libguile/net_db.c | 24 +++--- libguile/win32-socket.c | 165 +--------------------------------------- libguile/win32-socket.h | 9 +-- 3 files changed, 11 insertions(+), 187 deletions(-) diff --git a/libguile/net_db.c b/libguile/net_db.c index 8dccb723a..f8007a44d 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -55,23 +55,15 @@ #include <netinet/in.h> #include <arpa/inet.h> -#ifdef __MINGW32__ -#include "win32-socket.h" -#endif -#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__) -/* h_errno not found in netdb.h, maybe this will help. */ -extern int h_errno; -#endif +#if defined (HAVE_H_ERRNO) +/* Only wrap gethostbyname / gethostbyaddr if h_errno is available. */ -#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \ - && !defined __MINGW32__ && !defined __CYGWIN__ +#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR /* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */ extern const char *hstrerror (int); #endif - - SCM_SYMBOL (scm_host_not_found_key, "host-not-found"); SCM_SYMBOL (scm_try_again_key, "try-again"); SCM_SYMBOL (scm_no_recovery_key, "no-recovery"); @@ -200,6 +192,8 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, } #undef FUNC_NAME +#endif /* HAVE_H_ERRNO */ + /* In all subsequent getMUMBLE functions, when we're called with no arguments, we're supposed to traverse the tables entry by entry. @@ -263,7 +257,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, #undef FUNC_NAME #endif -#if defined (HAVE_GETPROTOENT) || defined (__MINGW32__) +#if defined (HAVE_GETPROTOENT) SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, (SCM protocol), "@deffnx {Scheme Procedure} getprotobyname name\n" @@ -314,7 +308,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, #undef FUNC_NAME #endif -#if defined (HAVE_GETSERVENT) || defined (__MINGW32__) +#if defined (HAVE_GETSERVENT) static SCM scm_return_entry (struct servent *entry) { @@ -416,7 +410,7 @@ SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0, #undef FUNC_NAME #endif -#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__) +#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0, (SCM stayopen), "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n" @@ -432,7 +426,7 @@ SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0, #undef FUNC_NAME #endif -#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__) +#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0, (SCM stayopen), "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n" diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c index 825b4c499..7ffb9611f 100644 --- a/libguile/win32-socket.c +++ b/libguile/win32-socket.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 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 License @@ -441,169 +441,6 @@ scm_i_socket_uncomment (char *line) return end; } -/* The getservent() function reads the next line from the file `/etc/services' - and returns a structure servent containing the broken out fields from the - line. The `/etc/services' file is opened if necessary. */ -struct servent * -getservent (void) -{ - char line[MAX_NAMLEN], *end, *p; - int done = 0, i, n, a; - struct servent *e = NULL; - - /* Ensure a open file. */ - if (scm_i_servent.fd == NULL || feof (scm_i_servent.fd)) - { - setservent (1); - if (scm_i_servent.fd == NULL) - return NULL; - } - - while (!done) - { - /* Get new line. */ - if (fgets (line, MAX_NAMLEN, scm_i_servent.fd) != NULL) - { - end = scm_i_socket_uncomment (line); - - /* Scan the line. */ - if ((i = sscanf (line, "%s %d/%s%n", - scm_i_servent.name, - &scm_i_servent.port, - scm_i_servent.proto, &n)) != 3) - continue; - - /* Scan the remaining aliases. */ - p = line + n; - for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1; - a++, p += n) - i = sscanf (p, "%s%n", scm_i_servent.alias[a], &n); - - /* Prepare the return value. */ - e = &scm_i_servent.ent; - e->s_name = scm_i_servent.name; - e->s_port = htons (scm_i_servent.port); - e->s_proto = scm_i_servent.proto; - e->s_aliases = scm_i_servent.aliases; - scm_i_servent.aliases[a] = NULL; - while (a--) - scm_i_servent.aliases[a] = scm_i_servent.alias[a]; - done = 1; - } - else - break; - } - return done ? e : NULL; -} - -/* The setservent() function opens and rewinds the `/etc/services' file. - This file can be set from outside with an environment variable specifying - the file name. */ -void -setservent (int stayopen) -{ - char *file = NULL; - - endservent (); - if ((file = getenv (ENVIRON_ETC_SERVICES)) != NULL) - strcpy (scm_i_servent.file, file); - else if ((file = scm_i_socket_filename (FILE_ETC_SERVICES)) != NULL) - strcpy (scm_i_servent.file, file); - scm_i_servent.fd = fopen (scm_i_servent.file, "rt"); -} - -/* The endservent() function closes the `/etc/services' file. */ -void -endservent (void) -{ - if (scm_i_servent.fd != NULL) - { - fclose (scm_i_servent.fd); - scm_i_servent.fd = NULL; - } -} - -/* The getprotoent() function reads the next line from the file - `/etc/protocols' and returns a structure protoent containing the broken - out fields from the line. The `/etc/protocols' file is opened if - necessary. */ -struct protoent * -getprotoent (void) -{ - char line[MAX_NAMLEN], *end, *p; - int done = 0, i, n, a; - struct protoent *e = NULL; - - /* Ensure a open file. */ - if (scm_i_protoent.fd == NULL || feof (scm_i_protoent.fd)) - { - setprotoent (1); - if (scm_i_protoent.fd == NULL) - return NULL; - } - - while (!done) - { - /* Get new line. */ - if (fgets (line, MAX_NAMLEN, scm_i_protoent.fd) != NULL) - { - end = scm_i_socket_uncomment (line); - - /* Scan the line. */ - if ((i = sscanf (line, "%s %d%n", - scm_i_protoent.name, - &scm_i_protoent.proto, &n)) != 2) - continue; - - /* Scan the remaining aliases. */ - p = line + n; - for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1; - a++, p += n) - i = sscanf (p, "%s%n", scm_i_protoent.alias[a], &n); - - /* Prepare the return value. */ - e = &scm_i_protoent.ent; - e->p_name = scm_i_protoent.name; - e->p_proto = scm_i_protoent.proto; - e->p_aliases = scm_i_protoent.aliases; - scm_i_protoent.aliases[a] = NULL; - while (a--) - scm_i_protoent.aliases[a] = scm_i_protoent.alias[a]; - done = 1; - } - else - break; - } - return done ? e : NULL; -} - -/* The setprotoent() function opens and rewinds the `/etc/protocols' file. - As in setservent() the user can modify the location of the file using - an environment variable. */ -void -setprotoent (int stayopen) -{ - char *file = NULL; - - endprotoent (); - if ((file = getenv (ENVIRON_ETC_PROTOCOLS)) != NULL) - strcpy (scm_i_protoent.file, file); - else if ((file = scm_i_socket_filename (FILE_ETC_PROTOCOLS)) != NULL) - strcpy (scm_i_protoent.file, file); - scm_i_protoent.fd = fopen (scm_i_protoent.file, "rt"); -} - -/* The endprotoent() function closes `/etc/protocols'. */ -void -endprotoent (void) -{ - if (scm_i_protoent.fd != NULL) - { - fclose (scm_i_protoent.fd); - scm_i_protoent.fd = NULL; - } -} - /* Define both the original and replacement error symbol is possible. Thus the user is able to check symbolic errors after unsuccessful networking function calls. */ diff --git a/libguile/win32-socket.h b/libguile/win32-socket.h index 4ab9b942a..0168c064c 100644 --- a/libguile/win32-socket.h +++ b/libguile/win32-socket.h @@ -3,7 +3,7 @@ #ifndef SCM_WIN32_SOCKET_H #define SCM_WIN32_SOCKET_H -/* Copyright (C) 2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 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 License @@ -32,11 +32,4 @@ char * scm_i_socket_strerror (int error); void scm_i_init_socket_Win32 (void); char * scm_i_socket_filename (char *file); -struct servent * getservent (void); -void setservent (int stayopen); -void endservent (void); -struct protoent * getprotoent (void); -void setprotoent (int stayopen); -void endprotoent (void); - #endif /* SCM_WIN32_SOCKET_H */ From 09b204d38756f0fa9ab4319874c8ce2838488dd0 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 16:39:47 +0100 Subject: [PATCH 063/147] squish remove some mingw-specific code that is covered by gnulib * libguile/socket.c (scm_init_socket): Remove mingw-specific code. * libguile/fports.c: Remove ftruncate redefine; mingw is fine. (scm_i_fdes_to_port): If we have no F_GETFL, just do an fstat. The right place for an F_GETFL replacement would be in gnulib. (fport_input_waiting): Remove an outdated comment. * libguile/error.c (SCM_I_STRERROR, SCM_I_ERRNO): Remove, replacing uses with strerror and errno. * libguile/win32-socket.c: * libguile/win32-socket.h: Remove. Mingw has suitable replacements. * configure.ac: * libguile/Makefile.am (EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (noinst_HEADERS): Update for win32-socket removal. --- configure.ac | 3 - libguile/Makefile.am | 4 +- libguile/error.c | 17 +- libguile/fports.c | 83 +------ libguile/socket.c | 16 +- libguile/win32-socket.c | 469 ---------------------------------------- libguile/win32-socket.h | 35 --- 7 files changed, 18 insertions(+), 609 deletions(-) delete mode 100644 libguile/win32-socket.c delete mode 100644 libguile/win32-socket.h diff --git a/configure.ac b/configure.ac index 4157982d3..d8919d3a9 100644 --- a/configure.ac +++ b/configure.ac @@ -707,9 +707,6 @@ case $host in [Define if you have the <winsock2.h> header file.])]) AC_CHECK_LIB(ws2_32, main) AC_LIBOBJ([win32-uname]) - if test "$enable_networking" = yes ; then - AC_LIBOBJ([win32-socket]) - fi if test "$enable_shared" = yes ; then EXTRA_DEFS="-DSCM_IMPORT" AC_DEFINE([USE_DLL_IMPORT], 1, diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8df2f7c4a..d77bdfe2d 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -434,7 +434,7 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ dynl.c regex-posix.c \ posix.c net_db.c socket.c \ debug-malloc.c mkstemp.c \ - win32-uname.c win32-socket.c \ + win32-uname.c \ locale-categories.h ## delete guile-snarf.awk from the installation bindir, in case it's @@ -450,7 +450,7 @@ install-exec-hook: noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ srfi-14.i.c \ quicksort.i.c \ - win32-uname.h win32-socket.h \ + win32-uname.h \ private-gc.h private-options.h # vm instructions diff --git a/libguile/error.c b/libguile/error.c index 790ed0571..0df4c737e 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010, - * 2012 Free Software Foundation, Inc. + * 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 License @@ -100,17 +100,6 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, } #undef FUNC_NAME -#if defined __MINGW32__ && defined HAVE_NETWORKING -# include "win32-socket.h" -# define SCM_I_STRERROR(err) \ - ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err)) -# define SCM_I_ERRNO() \ - (errno ? errno : scm_i_socket_errno ()) -#else -# define SCM_I_STRERROR(err) strerror (err) -# define SCM_I_ERRNO() errno -#endif /* __MINGW32__ */ - /* strerror may not be thread safe, for instance in glibc (version 2.3.2) an error number not among the known values results in a string like "Unknown error 9999" formed in a static buffer, which will be overwritten by a @@ -136,7 +125,7 @@ SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0, scm_dynwind_begin (0); scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); - ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err))); + ret = scm_from_locale_string (strerror (scm_to_int (err))); scm_dynwind_end (); return ret; @@ -147,7 +136,7 @@ SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error"); void scm_syserror (const char *subr) { - SCM err = scm_from_int (SCM_I_ERRNO ()); + SCM err = scm_from_int (errno); /* It could be that we're getting here because the syscall was interrupted by a signal. In that case a signal handler might have diff --git a/libguile/fports.c b/libguile/fports.c index c1a2800a2..cdb9f99a9 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -55,32 +55,12 @@ #endif #include <errno.h> #include <sys/types.h> - -#include <full-write.h> +#include <sys/stat.h> #include "libguile/iselect.h" -/* Some defines for Windows (native port, not Cygwin). */ -#ifdef __MINGW32__ -# include <sys/stat.h> -# include <winsock2.h> -#endif /* __MINGW32__ */ - #include <full-write.h> -/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize - already, but have this code here in case that wasn't so in past versions, - or perhaps to help other minimal DOS environments. - - gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which - might be possibilities if we've got other systems without ftruncate. */ - -#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE -# define ftruncate(fd, size) chsize (fd, size) -# undef HAVE_FTRUNCATE -# define HAVE_FTRUNCATE 1 -#endif - #if SIZEOF_OFF_T == SIZEOF_INT #define OFF_T_MAX INT_MAX #define OFF_T_MIN INT_MIN @@ -496,48 +476,6 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, #undef FUNC_NAME -#ifdef __MINGW32__ -/* - * Try getting the appropiate file flags for a given file descriptor - * under Windows. This incorporates some fancy operations because Windows - * differentiates between file, pipe and socket descriptors. - */ -#ifndef O_ACCMODE -# define O_ACCMODE 0x0003 -#endif - -static int getflags (int fdes) -{ - int flags = 0; - struct stat buf; - int error, optlen = sizeof (int); - - /* Is this a socket ? */ - if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0) - flags = O_RDWR; - /* Maybe a regular file ? */ - else if (fstat (fdes, &buf) < 0) - flags = -1; - else - { - /* Or an anonymous pipe handle ? */ - if (buf.st_mode & _S_IFIFO) - flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0, - NULL, NULL, NULL) ? O_RDONLY : O_WRONLY; - /* stdin ? */ - else if (fdes == fileno (stdin) && isatty (fdes)) - flags = O_RDONLY; - /* stdout / stderr ? */ - else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) && - isatty (fdes)) - flags = O_WRONLY; - else - flags = buf.st_mode; - } - return flags; -} -#endif /* __MINGW32__ */ - /* Building Guile ports from a file descriptor. */ /* Build a Scheme port from an open file descriptor `fdes'. @@ -551,14 +489,10 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) { SCM port; scm_t_port *pt; - int flags; - /* test that fdes is valid. */ -#ifdef __MINGW32__ - flags = getflags (fdes); -#else - flags = fcntl (fdes, F_GETFL, 0); -#endif + /* Test that fdes is valid. */ +#ifdef F_GETFL + int flags = fcntl (fdes, F_GETFL, 0); if (flags == -1) SCM_SYSERROR; flags &= O_ACCMODE; @@ -568,6 +502,13 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) { SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL); } +#else + /* If we don't have F_GETFL, as on mingw, at least we can test that + it is a valid file descriptor. */ + struct stat st; + if (fstat (fdes, &st) != 0) + SCM_SYSERROR; +#endif scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); @@ -639,8 +580,6 @@ fport_input_waiting (SCM port) return FD_ISSET (fdes, &read_set) ? 1 : 0; #elif HAVE_IOCTL && defined (FIONREAD) - /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD - (for use with winsock ioctlsocket()) but not ioctl(). */ int fdes = SCM_FSTREAM (port)->fdes; int remir; ioctl(fdes, FIONREAD, &remir); diff --git a/libguile/socket.c b/libguile/socket.c index 5119ce3c6..ecb6754ae 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, 2012 Free Software Foundation, Inc. + * 2006, 2007, 2009, 2011, 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 License @@ -44,11 +44,6 @@ # include "libguile/deprecation.h" #endif -#ifdef __MINGW32__ -#include "win32-socket.h" -#include <netdb.h> -#endif - #ifdef HAVE_STDINT_H #include <stdint.h> #endif @@ -59,9 +54,6 @@ #include <unistd.h> #endif #include <sys/types.h> -#ifdef HAVE_WINSOCK2_H -#include <winsock2.h> -#else #include <sys/socket.h> #ifdef HAVE_UNIX_DOMAIN_SOCKETS #include <sys/un.h> @@ -69,7 +61,7 @@ #include <netinet/in.h> #include <netdb.h> #include <arpa/inet.h> -#endif + #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ @@ -1877,10 +1869,6 @@ scm_init_socket () scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE)); #endif -#ifdef __MINGW32__ - scm_i_init_socket_Win32 (); -#endif - #ifdef IP_ADD_MEMBERSHIP scm_c_define ("IP_ADD_MEMBERSHIP", scm_from_int (IP_ADD_MEMBERSHIP)); scm_c_define ("IP_DROP_MEMBERSHIP", scm_from_int (IP_DROP_MEMBERSHIP)); diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c deleted file mode 100644 index 7ffb9611f..000000000 --- a/libguile/win32-socket.c +++ /dev/null @@ -1,469 +0,0 @@ -/* Copyright (C) 2001, 2006, 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 License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - - -#ifdef HAVE_CONFIG_H -# include <config.h> -#endif - -#include "libguile/__scm.h" -#include "libguile/modules.h" -#include "libguile/numbers.h" - -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#include <ctype.h> -#include <errno.h> -#include <limits.h> - -#ifndef PATH_MAX -#define PATH_MAX 255 -#endif - -#include "win32-socket.h" - -/* Winsock API error description structure. The error description is - necessary because there is no error list available. */ -typedef struct -{ - int error; /* Error code. */ - char *str; /* Error description. */ - int replace; /* Possible error code replacement. */ - char *replace_str; /* Replacement symbol. */ - char *correct_str; /* Original symbol. */ -} -socket_error_t; - -#define FILE_ETC_SERVICES "services" -#define ENVIRON_ETC_SERVICES "SERVICES" -#define FILE_ETC_NETWORKS "networks" -#define ENVIRON_ETC_NETWORKS "NETWORKS" -#define FILE_ETC_PROTOCOLS "protocol" -#define ENVIRON_ETC_PROTOCOLS "PROTOCOLS" -#define MAX_NAMLEN 256 -#define MAX_ALIASES 4 - -/* Internal structure for a thread's M$-Windows servent interface. */ -typedef struct -{ - FILE *fd; /* Current file. */ - char file[PATH_MAX]; /* File name. */ - struct servent ent; /* Return value. */ - char name[MAX_NAMLEN]; /* Service name. */ - char proto[MAX_NAMLEN]; /* Protocol name. */ - char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */ - char *aliases[MAX_ALIASES]; /* Alias pointers. */ - int port; /* Network port. */ -} -scm_i_servent_t; - -static scm_i_servent_t scm_i_servent; - -/* Internal structure for a thread's M$-Windows protoent interface. */ -typedef struct -{ - FILE *fd; /* Current file. */ - char file[PATH_MAX]; /* File name. */ - struct protoent ent; /* Return value. */ - char name[MAX_NAMLEN]; /* Protocol name. */ - char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */ - char *aliases[MAX_ALIASES]; /* Alias pointers. */ - int proto; /* Protocol number. */ -} -scm_i_protoent_t; - -static scm_i_protoent_t scm_i_protoent; - -/* Define replacement symbols for most of the WSA* error codes. */ -#ifndef EWOULDBLOCK -# define EWOULDBLOCK WSAEWOULDBLOCK -#endif -#ifndef EINPROGRESS -# define EINPROGRESS WSAEINPROGRESS -#endif -#ifndef EALREADY -# define EALREADY WSAEALREADY -#endif -#ifndef EDESTADDRREQ -# define EDESTADDRREQ WSAEDESTADDRREQ -#endif -#ifndef EMSGSIZE -# define EMSGSIZE WSAEMSGSIZE -#endif -#ifndef EPROTOTYPE -# define EPROTOTYPE WSAEPROTOTYPE -#endif -#ifndef ENOTSOCK -# define ENOTSOCK WSAENOTSOCK -#endif -#ifndef ENOPROTOOPT -# define ENOPROTOOPT WSAENOPROTOOPT -#endif -#ifndef EPROTONOSUPPORT -# define EPROTONOSUPPORT WSAEPROTONOSUPPORT -#endif -#ifndef ESOCKTNOSUPPORT -# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT -#endif -#ifndef EOPNOTSUPP -# define EOPNOTSUPP WSAEOPNOTSUPP -#endif -#ifndef EPFNOSUPPORT -# define EPFNOSUPPORT WSAEPFNOSUPPORT -#endif -#ifndef EAFNOSUPPORT -# define EAFNOSUPPORT WSAEAFNOSUPPORT -#endif -#ifndef EADDRINUSE -# define EADDRINUSE WSAEADDRINUSE -#endif -#ifndef EADDRNOTAVAIL -# define EADDRNOTAVAIL WSAEADDRNOTAVAIL -#endif -#ifndef ENETDOWN -# define ENETDOWN WSAENETDOWN -#endif -#ifndef ENETUNREACH -# define ENETUNREACH WSAENETUNREACH -#endif -#ifndef ENETRESET -# define ENETRESET WSAENETRESET -#endif -#ifndef ECONNABORTED -# define ECONNABORTED WSAECONNABORTED -#endif -#ifndef ECONNRESET -# define ECONNRESET WSAECONNRESET -#endif -#ifndef ENOBUFS -# define ENOBUFS WSAENOBUFS -#endif -#ifndef EISCONN -# define EISCONN WSAEISCONN -#endif -#ifndef ENOTCONN -# define ENOTCONN WSAENOTCONN -#endif -#ifndef ESHUTDOWN -# define ESHUTDOWN WSAESHUTDOWN -#endif -#ifndef ETOOMANYREFS -# define ETOOMANYREFS WSAETOOMANYREFS -#endif -#ifndef ETIMEDOUT -# define ETIMEDOUT WSAETIMEDOUT -#endif -#ifndef ECONNREFUSED -# define ECONNREFUSED WSAECONNREFUSED -#endif -#ifndef ELOOP -# define ELOOP WSAELOOP -#endif -#ifndef EHOSTDOWN -# define EHOSTDOWN WSAEHOSTDOWN -#endif -#ifndef EHOSTUNREACH -# define EHOSTUNREACH WSAEHOSTUNREACH -#endif -#ifndef EPROCLIM -# define EPROCLIM WSAEPROCLIM -#endif -#ifndef EUSERS -# define EUSERS WSAEUSERS -#endif -#ifndef EDQUOT -# define EDQUOT WSAEDQUOT -#endif -#ifndef ESTALE -# define ESTALE WSAESTALE -#endif -#ifndef EREMOTE -# define EREMOTE WSAEREMOTE -#endif - -/* List of error structures. */ -static socket_error_t socket_errno [] = { - /* 000 */ { 0, NULL, 0, NULL, NULL }, - /* 001 */ { 0, NULL, 0, NULL, NULL }, - /* 002 */ { 0, NULL, 0, NULL, NULL }, - /* 003 */ { 0, NULL, 0, NULL, NULL }, - /* 004 */ { WSAEINTR, "Interrupted function call", EINTR, NULL, "WSAEINTR" }, - /* 005 */ { 0, NULL, 0, NULL, NULL }, - /* 006 */ { 0, NULL, 0, NULL, NULL }, - /* 007 */ { 0, NULL, 0, NULL, NULL }, - /* 008 */ { 0, NULL, 0, NULL, NULL }, - /* 009 */ { WSAEBADF, "Bad file number", EBADF, NULL, "WSAEBADF" }, - /* 010 */ { 0, NULL, 0, NULL, NULL }, - /* 011 */ { 0, NULL, 0, NULL, NULL }, - /* 012 */ { 0, NULL, 0, NULL, NULL }, - /* 013 */ { WSAEACCES, "Permission denied", EACCES, NULL, "WSAEACCES" }, - /* 014 */ { WSAEFAULT, "Bad address", EFAULT, NULL, "WSAEFAULT" }, - /* 015 */ { 0, NULL, 0, NULL, NULL }, - /* 016 */ { 0, NULL, 0, NULL, NULL }, - /* 017 */ { 0, NULL, 0, NULL, NULL }, - /* 018 */ { 0, NULL, 0, NULL, NULL }, - /* 019 */ { 0, NULL, 0, NULL, NULL }, - /* 020 */ { 0, NULL, 0, NULL, NULL }, - /* 021 */ { 0, NULL, 0, NULL, NULL }, - /* 022 */ { WSAEINVAL, "Invalid argument", EINVAL, NULL, "WSAEINVAL" }, - /* 023 */ { 0, NULL, 0, NULL, NULL }, - /* 024 */ { WSAEMFILE, "Too many open files", EMFILE, NULL, "WSAEMFILE" }, - /* 025 */ { 0, NULL, 0, NULL, NULL }, - /* 026 */ { 0, NULL, 0, NULL, NULL }, - /* 027 */ { 0, NULL, 0, NULL, NULL }, - /* 028 */ { 0, NULL, 0, NULL, NULL }, - /* 029 */ { 0, NULL, 0, NULL, NULL }, - /* 030 */ { 0, NULL, 0, NULL, NULL }, - /* 031 */ { 0, NULL, 0, NULL, NULL }, - /* 032 */ { 0, NULL, 0, NULL, NULL }, - /* 033 */ { 0, NULL, 0, NULL, NULL }, - /* 034 */ { 0, NULL, 0, NULL, NULL }, - /* 035 */ { WSAEWOULDBLOCK, "Resource temporarily unavailable", - EWOULDBLOCK, "EWOULDBLOCK", "WSAEWOULDBLOCK" }, - /* 036 */ { WSAEINPROGRESS, "Operation now in progress", - EINPROGRESS, "EINPROGRESS", "WSAEINPROGRESS" }, - /* 037 */ { WSAEALREADY, "Operation already in progress", - EALREADY, "EALREADY", "WSAEALREADY" }, - /* 038 */ { WSAENOTSOCK, "Socket operation on non-socket", - ENOTSOCK, "ENOTSOCK", "WSAENOTSOCK"}, - /* 039 */ { WSAEDESTADDRREQ, "Destination address required", - EDESTADDRREQ, "EDESTADDRREQ", "WSAEDESTADDRREQ" }, - /* 040 */ { WSAEMSGSIZE, "Message too long", - EMSGSIZE, "EMSGSIZE", "WSAEMSGSIZE" }, - /* 041 */ { WSAEPROTOTYPE, "Protocol wrong type for socket", - EPROTOTYPE, "EPROTOTYPE", "WSAEPROTOTYPE" }, - /* 042 */ { WSAENOPROTOOPT, "Bad protocol option", - ENOPROTOOPT, "ENOPROTOOPT", "WSAENOPROTOOPT" }, - /* 043 */ { WSAEPROTONOSUPPORT, "Protocol not supported", - EPROTONOSUPPORT, "EPROTONOSUPPORT", "WSAEPROTONOSUPPORT" }, - /* 044 */ { WSAESOCKTNOSUPPORT, "Socket type not supported", - ESOCKTNOSUPPORT, "ESOCKTNOSUPPORT", "WSAESOCKTNOSUPPORT" }, - /* 045 */ { WSAEOPNOTSUPP, "Operation not supported", - EOPNOTSUPP, "EOPNOTSUPP", "WSAEOPNOTSUPP" }, - /* 046 */ { WSAEPFNOSUPPORT, "Protocol family not supported", - EPFNOSUPPORT, "EPFNOSUPPORT", "WSAEPFNOSUPPORT" }, - /* 047 */ { WSAEAFNOSUPPORT, - "Address family not supported by protocol family", - EAFNOSUPPORT, "EAFNOSUPPORT", "WSAEAFNOSUPPORT" }, - /* 048 */ { WSAEADDRINUSE, "Address already in use", - EADDRINUSE, "EADDRINUSE", "WSAEADDRINUSE" }, - /* 049 */ { WSAEADDRNOTAVAIL, "Cannot assign requested address", - EADDRNOTAVAIL, "EADDRNOTAVAIL", "WSAEADDRNOTAVAIL" }, - /* 050 */ { WSAENETDOWN, "Network is down", - ENETDOWN, "ENETDOWN", "WSAENETDOWN" }, - /* 051 */ { WSAENETUNREACH, "Network is unreachable", - ENETUNREACH, "ENETUNREACH", "WSAENETUNREACH" }, - /* 052 */ { WSAENETRESET, "Network dropped connection on reset", - ENETRESET, "ENETRESET", "WSAENETRESET" }, - /* 053 */ { WSAECONNABORTED, "Software caused connection abort", - ECONNABORTED, "ECONNABORTED", "WSAECONNABORTED" }, - /* 054 */ { WSAECONNRESET, "Connection reset by peer", - ECONNRESET, "ECONNRESET", "WSAECONNRESET" }, - /* 055 */ { WSAENOBUFS, "No buffer space available", - ENOBUFS, "ENOBUFS", "WSAENOBUFS" }, - /* 056 */ { WSAEISCONN, "Socket is already connected", - EISCONN, "EISCONN", "WSAEISCONN" }, - /* 057 */ { WSAENOTCONN, "Socket is not connected", - ENOTCONN, "ENOTCONN", "WSAENOTCONN" }, - /* 058 */ { WSAESHUTDOWN, "Cannot send after socket shutdown", - ESHUTDOWN, "ESHUTDOWN", "WSAESHUTDOWN" }, - /* 059 */ { WSAETOOMANYREFS, "Too many references; can't splice", - ETOOMANYREFS, "ETOOMANYREFS", "WSAETOOMANYREFS" }, - /* 060 */ { WSAETIMEDOUT, "Connection timed out", - ETIMEDOUT, "ETIMEDOUT", "WSAETIMEDOUT" }, - /* 061 */ { WSAECONNREFUSED, "Connection refused", - ECONNREFUSED, "ECONNREFUSED", "WSAECONNREFUSED" }, - /* 062 */ { WSAELOOP, "Too many levels of symbolic links", - ELOOP, "ELOOP", "WSAELOOP" }, - /* 063 */ { WSAENAMETOOLONG, "File name too long", - ENAMETOOLONG, NULL, "WSAENAMETOOLONG" }, - /* 064 */ { WSAEHOSTDOWN, "Host is down", - EHOSTDOWN, "EHOSTDOWN", "WSAEHOSTDOWN" }, - /* 065 */ { WSAEHOSTUNREACH, "No route to host", - EHOSTUNREACH, "EHOSTUNREACH", "WSAEHOSTUNREACH" }, - /* 066 */ { WSAENOTEMPTY, "Directory not empty", - ENOTEMPTY, NULL, "WSAENOTEMPTY" }, - /* 067 */ { WSAEPROCLIM, "Too many processes", - EPROCLIM, "EPROCLIM", "WSAEPROCLIM" }, - /* 068 */ { WSAEUSERS, "Too many users", - EUSERS, "EUSERS", "WSAEUSERS" }, - /* 069 */ { WSAEDQUOT, "Disc quota exceeded", - EDQUOT, "EDQUOT", "WSAEDQUOT" }, - /* 070 */ { WSAESTALE, "Stale NFS file handle", - ESTALE, "ESTALE", "WSAESTALE" }, - /* 071 */ { WSAEREMOTE, "Too many levels of remote in path", - EREMOTE, "EREMOTE", "WSAEREMOTE" }, - /* 072 */ { 0, NULL, 0, NULL, NULL }, - /* 073 */ { 0, NULL, 0, NULL, NULL }, - /* 074 */ { 0, NULL, 0, NULL, NULL }, - /* 075 */ { 0, NULL, 0, NULL, NULL }, - /* 076 */ { 0, NULL, 0, NULL, NULL }, - /* 077 */ { 0, NULL, 0, NULL, NULL }, - /* 078 */ { 0, NULL, 0, NULL, NULL }, - /* 079 */ { 0, NULL, 0, NULL, NULL }, - /* 080 */ { 0, NULL, 0, NULL, NULL }, - /* 081 */ { 0, NULL, 0, NULL, NULL }, - /* 082 */ { 0, NULL, 0, NULL, NULL }, - /* 083 */ { 0, NULL, 0, NULL, NULL }, - /* 084 */ { 0, NULL, 0, NULL, NULL }, - /* 085 */ { 0, NULL, 0, NULL, NULL }, - /* 086 */ { 0, NULL, 0, NULL, NULL }, - /* 087 */ { 0, NULL, 0, NULL, NULL }, - /* 088 */ { 0, NULL, 0, NULL, NULL }, - /* 089 */ { 0, NULL, 0, NULL, NULL }, - /* 090 */ { 0, NULL, 0, NULL, NULL }, - /* 091 */ { WSASYSNOTREADY, "Network subsystem is unavailable", - 0, NULL, "WSASYSNOTREADY" }, - /* 092 */ { WSAVERNOTSUPPORTED, "WINSOCK.DLL version out of range", - 0, NULL, "WSAVERNOTSUPPORTED" }, - /* 093 */ { WSANOTINITIALISED, "Successful WSAStartup not yet performed", - 0, NULL, "WSANOTINITIALISED" }, - /* 094 */ { 0, NULL, 0, NULL, NULL }, - /* 095 */ { 0, NULL, 0, NULL, NULL }, - /* 096 */ { 0, NULL, 0, NULL, NULL }, - /* 097 */ { 0, NULL, 0, NULL, NULL }, - /* 098 */ { 0, NULL, 0, NULL, NULL }, - /* 099 */ { 0, NULL, 0, NULL, NULL }, - /* 100 */ { 0, NULL, 0, NULL, NULL }, - /* 101 */ { WSAEDISCON, "Graceful shutdown in progress", - 0, NULL, "WSAEDISCON" }, - /* 102 */ { WSAENOMORE, "No more services", - 0, NULL, "WSAENOMORE" }, - /* 103 */ { WSAECANCELLED, "Service lookup cancelled", - 0, NULL, "WSAECANCELLED" }, - /* 104 */ { WSAEINVALIDPROCTABLE, "Invalid procedure call table", - 0, NULL, "WSAEINVALIDPROCTABLE" }, - /* 105 */ { WSAEINVALIDPROVIDER, "Invalid service provider", - 0, NULL, "WSAEINVALIDPROVIDER" }, - /* 106 */ { WSAEPROVIDERFAILEDINIT, "Service provider failure", - 0, NULL, "WSAEPROVIDERFAILEDINIT" }, - /* 107 */ { WSASYSCALLFAILURE, "System call failed", - 0, NULL, "WSASYSCALLFAILURE" }, - /* 108 */ { WSASERVICE_NOT_FOUND, "No such service", - 0, NULL, "WSASERVICE_NOT_FOUND" }, - /* 109 */ { WSATYPE_NOT_FOUND, "Class not found", - 0, NULL, "WSATYPE_NOT_FOUND" }, - /* 110 */ { WSA_E_NO_MORE, "No more services", - 0, NULL, "WSA_E_NO_MORE" }, - /* 111 */ { WSA_E_CANCELLED, "Service lookup cancelled", - 0, NULL, "WSA_E_CANCELLED" }, - /* 112 */ { WSAEREFUSED, "Database query refused", - 0, NULL, "WSAEREFUSED" }, - /* end */ { -1, NULL, -1, NULL, NULL } -}; - -/* Extended list of error structures. */ -static socket_error_t socket_h_errno [] = { - /* 000 */ { 0, NULL, 0, NULL, NULL }, - /* 001 */ { WSAHOST_NOT_FOUND, "Host not found", - HOST_NOT_FOUND, "HOST_NOT_FOUND", "WSAHOST_NOT_FOUND" }, - /* 002 */ { WSATRY_AGAIN, "Non-authoritative host not found", - TRY_AGAIN, "TRY_AGAIN", "WSATRY_AGAIN" }, - /* 003 */ { WSANO_RECOVERY, "This is a non-recoverable error", - NO_RECOVERY, "NO_RECOVERY", "WSANO_RECOVERY" }, - /* 004 */ { WSANO_DATA, "Valid name, no data record of requested type", - NO_DATA, "NO_DATA", "WSANO_DATA" }, - /* 005 */ { WSANO_ADDRESS, "No address, look for MX record", - NO_ADDRESS, "NO_ADDRESS", "WSANO_ADDRESS" }, - /* end */ { -1, NULL, -1, NULL, NULL } -}; - -/* Returns the result of @code{WSAGetLastError()}. */ -int -scm_i_socket_errno (void) -{ - return WSAGetLastError (); -} - -/* Returns a valid error message for Winsock-API error codes obtained via - @code{WSAGetLastError()} or NULL otherwise. */ -char * -scm_i_socket_strerror (int error) -{ - if (error >= WSABASEERR && error <= (WSABASEERR + 112)) - return socket_errno[error - WSABASEERR].str; - else if (error >= (WSABASEERR + 1000) && error <= (WSABASEERR + 1005)) - return socket_h_errno[error - (WSABASEERR + 1000)].str; - return NULL; -} - -/* Constructs a valid filename for the given file @var{file} in the M$-Windows - directory. This is usually the default location for the network files. */ -char * -scm_i_socket_filename (char *file) -{ - static char dir[PATH_MAX]; - int len = PATH_MAX; - - len = GetWindowsDirectory (dir, len); - if (dir[len - 1] != '\\') - strcat (dir, "\\"); - strcat (dir, file); - return dir; -} - -/* Removes comments and white spaces at end of line and returns a pointer - to the end of the line. */ -static char * -scm_i_socket_uncomment (char *line) -{ - char *end; - - if ((end = strchr (line, '#')) != NULL) - *end-- = '\0'; - else - { - end = line + strlen (line) - 1; - while (end > line && (*end == '\r' || *end == '\n')) - *end-- = '\0'; - } - while (end > line && isspace ((int) (*end))) - *end-- = '\0'; - - return end; -} - -/* Define both the original and replacement error symbol is possible. Thus - the user is able to check symbolic errors after unsuccessful networking - function calls. */ -static void -scm_socket_symbols_Win32 (socket_error_t * e) -{ - while (e->error != -1) - { - if (e->error) - { - if (e->correct_str) - scm_c_define (e->correct_str, scm_from_int (e->error)); - if (e->replace && e->replace_str) - scm_c_define (e->replace_str, scm_from_int (e->replace)); - } - e++; - } -} - -/* Initialize Winsock API under M$-Windows. */ -void -scm_i_init_socket_Win32 (void) -{ - scm_socket_symbols_Win32 (socket_errno); - scm_socket_symbols_Win32 (socket_h_errno); -} diff --git a/libguile/win32-socket.h b/libguile/win32-socket.h deleted file mode 100644 index 0168c064c..000000000 --- a/libguile/win32-socket.h +++ /dev/null @@ -1,35 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_WIN32_SOCKET_H -#define SCM_WIN32_SOCKET_H - -/* Copyright (C) 2001, 2006, 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 License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - -#include "libguile/__scm.h" - -#ifdef SCM_HAVE_WINSOCK2_H -# include <winsock2.h> -#endif - -int scm_i_socket_errno (void); -char * scm_i_socket_strerror (int error); -void scm_i_init_socket_Win32 (void); -char * scm_i_socket_filename (char *file); - -#endif /* SCM_WIN32_SOCKET_H */ From 1adba49ab20ac283ca62963f115910f1cf7b63ad Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 19:08:51 +0100 Subject: [PATCH 064/147] Import `pipe-posix' module from gnulib. * lib/Makefile.am: * lib/pipe.c: * m4/gnulib-cache.m4: * m4/gnulib-comp.m4: * m4/pipe.m4: Add pipe-posix module. --- lib/Makefile.am | 11 +++++++++- lib/pipe.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++ m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 8 ++++++++ m4/pipe.m4 | 15 ++++++++++++++ 5 files changed, 85 insertions(+), 2 deletions(-) create mode 100644 lib/pipe.c create mode 100644 m4/pipe.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 2fe0e8288..56592868d 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -1460,6 +1460,15 @@ EXTRA_DIST += pathmax.h ## end gnulib module pathmax +## begin gnulib module pipe-posix + + +EXTRA_DIST += pipe.c + +EXTRA_libgnu_la_SOURCES += pipe.c + +## end gnulib module pipe-posix + ## begin gnulib module pipe2 libgnu_la_SOURCES += pipe2.c diff --git a/lib/pipe.c b/lib/pipe.c new file mode 100644 index 000000000..fc1196775 --- /dev/null +++ b/lib/pipe.c @@ -0,0 +1,50 @@ +/* Create a pipe. + Copyright (C) 2009-2013 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> + +/* Specification. */ +#include <unistd.h> + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +/* Native Windows API. */ + +/* Get _pipe(). */ +# include <io.h> + +/* Get _O_BINARY. */ +# include <fcntl.h> + +int +pipe (int fd[2]) +{ + /* Mingw changes fd to {-1,-1} on failure, but this violates + http://austingroupbugs.net/view.php?id=467 */ + int tmp[2]; + int result = _pipe (tmp, 4096, _O_BINARY); + if (!result) + { + fd[0] = tmp[0]; + fd[1] = tmp[1]; + } + return result; +} + +#else + +# error "This platform lacks a pipe function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib." + +#endif diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index f8a973759..fe243f8ee 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -84,6 +84,7 @@ gl_MODULES([ nl_langinfo nproc open + pipe-posix pipe2 putenv recv diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 8dc269161..3a8172b87 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -146,6 +146,7 @@ AC_DEFUN([gl_EARLY], # Code from module nproc: # Code from module open: # Code from module pathmax: + # Code from module pipe-posix: # Code from module pipe2: # Code from module putenv: # Code from module raise: @@ -545,6 +546,11 @@ AC_SUBST([LTALLOCA]) fi gl_FCNTL_MODULE_INDICATOR([open]) gl_PATHMAX + gl_FUNC_PIPE + if test $HAVE_PIPE = 0; then + AC_LIBOBJ([pipe]) + fi + gl_UNISTD_MODULE_INDICATOR([pipe]) gl_FUNC_PIPE2 gl_UNISTD_MODULE_INDICATOR([pipe2]) gl_FUNC_PUTENV @@ -994,6 +1000,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/nproc.h lib/open.c lib/pathmax.h + lib/pipe.c lib/pipe2.c lib/printf-args.c lib/printf-args.h @@ -1183,6 +1190,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/off_t.m4 m4/open.m4 m4/pathmax.m4 + m4/pipe.m4 m4/pipe2.m4 m4/printf.m4 m4/putenv.m4 diff --git a/m4/pipe.m4 b/m4/pipe.m4 new file mode 100644 index 000000000..583128332 --- /dev/null +++ b/m4/pipe.m4 @@ -0,0 +1,15 @@ +# pipe.m4 serial 2 +dnl Copyright (C) 2010-2013 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_FUNC_PIPE], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + + AC_CHECK_FUNCS_ONCE([pipe]) + if test $ac_cv_func_pipe != yes; then + HAVE_PIPE=0 + fi +]) From 4fd38267bca2987c6340c019a498ea6bacc6c5ec Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 21:06:07 +0100 Subject: [PATCH 065/147] add gnulib fstat module explicitly * lib/Makefile.am: * m4/gnulib-cache.m4: Explicitly add fstat module. --- lib/Makefile.am | 2 +- m4/gnulib-cache.m4 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Makefile.am b/lib/Makefile.am index 56592868d..a0d857aa0 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index fe243f8ee..1543626ee 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -52,6 +52,7 @@ gl_MODULES([ floor fpieee frexp + fstat full-read full-write func From cdd125e8d475a6d02606322fb4c54dc76bbc8072 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:25:35 +0100 Subject: [PATCH 066/147] portability simplification with scmsigs.c and alarm * configure.ac (alarm): Check for decl. * libguile/scmsigs.c: Reorder includes to put system includes first. Fixes include order on mingw. Remove #define for alarm, as we will use HAVE_DECL_ALARM. Remove #defines for sleep and usleep, as they are not used. (scm_alarm): Only define if HAVE_DECL_ALARM. --- configure.ac | 2 ++ libguile/scmsigs.c | 34 ++++++++++++++-------------------- 2 files changed, 16 insertions(+), 20 deletions(-) diff --git a/configure.ac b/configure.ac index d8919d3a9..31cb3a038 100644 --- a/configure.ac +++ b/configure.ac @@ -919,6 +919,8 @@ AC_DEFUN([GUILE_FUNC_DECLARED], [ GUILE_FUNC_DECLARED(sleep, unistd.h) GUILE_FUNC_DECLARED(usleep, unistd.h) +AC_CHECK_DECLS([alarm]) + AC_CHECK_DECLS([strptime],,, [#define _GNU_SOURCE /* ask glibc to give strptime prototype */ #include <time.h>]) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 723d6a8c5..701beb56d 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011, 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 License @@ -28,17 +28,6 @@ #include <stdio.h> #include <errno.h> -#include "libguile/_scm.h" - -#include "libguile/async.h" -#include "libguile/eval.h" -#include "libguile/root.h" -#include "libguile/vectors.h" -#include "libguile/threads.h" - -#include "libguile/validate.h" -#include "libguile/scmsigs.h" - #ifdef HAVE_PROCESS_H #include <process.h> /* for mingw */ #endif @@ -51,16 +40,19 @@ #include <sys/time.h> #endif -#ifdef __MINGW32__ -#include <windows.h> -#define alarm(sec) (0) -/* This weird comma expression is because Sleep is void under Windows. */ -#define sleep(sec) (Sleep ((sec) * 1000), 0) -#define usleep(usec) (Sleep ((usec) / 1000), 0) -#endif - #include <full-write.h> +#include "libguile/_scm.h" + +#include "libguile/async.h" +#include "libguile/eval.h" +#include "libguile/root.h" +#include "libguile/vectors.h" +#include "libguile/threads.h" + +#include "libguile/validate.h" +#include "libguile/scmsigs.h" + @@ -499,6 +491,7 @@ SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0, } #undef FUNC_NAME +#if defined HAVE_ALARM && HAVE_DECL_ALARM SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0, (SCM i), "Set a timer to raise a @code{SIGALRM} signal after the specified\n" @@ -514,6 +507,7 @@ SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0, return scm_from_uint (alarm (scm_to_uint (i))); } #undef FUNC_NAME +#endif /* HAVE_ALARM */ #ifdef HAVE_SETITIMER SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0, From 44e30ef241e342406d69c7d9c480c630d6106612 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:26:16 +0100 Subject: [PATCH 067/147] remove init.c iselect include * libguile/init.c: Remove iselect include. --- libguile/init.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index 17791e2c7..57e4902b0 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 2004, 2006, 2009, 2010, 2011, 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 License @@ -75,7 +75,6 @@ #include "libguile/gettext.h" #include "libguile/i18n.h" #include "libguile/instructions.h" -#include "libguile/iselect.h" #include "libguile/ioext.h" #include "libguile/keywords.h" #include "libguile/list.h" From eac7a5d03909291e62c671ead3d1c6a0ff84d4f0 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:27:59 +0100 Subject: [PATCH 068/147] if we have threads on windows, we have pthreads; inform bdw-gc of that * libguile/bdw-gc.h: If we have threads enabled on mingw32, explicitly mark GC_WIN32_PTHREADS. See http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/5564 for more info. --- libguile/bdw-gc.h | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h index 2e1fce27b..7aa757fed 100644 --- a/libguile/bdw-gc.h +++ b/libguile/bdw-gc.h @@ -1,7 +1,7 @@ #ifndef SCM_BDW_GC_H #define SCM_BDW_GC_H -/* Copyright (C) 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2008, 2009, 2011, 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 License @@ -37,6 +37,11 @@ routines. */ # define GC_NO_THREAD_REDIRECTS 1 +#ifdef __MINGW32__ +/* Rely on pthreads-w32. */ +#define GC_WIN32_PTHREADS +#endif + #endif #include <gc/gc.h> From ba59471eeeeb6738f87e1c9c4050ce4698a7c9d8 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:30:26 +0100 Subject: [PATCH 069/147] simplify filesys.c via gnulib's select and fstat modules * libguile/filesys.c: Instead of using scm_std_select, just use select, relying on gnulib to provide it to us. Likewise, rely on fstat. --- libguile/filesys.c | 63 ++++++++-------------------------------------- 1 file changed, 10 insertions(+), 53 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index cd4be792f..282ff31b2 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -45,7 +45,6 @@ #include "libguile/feature.h" #include "libguile/fports.h" #include "libguile/private-gc.h" /* for SCM_MAX */ -#include "libguile/iselect.h" #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" @@ -81,9 +80,7 @@ #include <libc.h> #endif -#ifdef HAVE_SYS_SELECT_H #include <sys/select.h> -#endif #ifdef HAVE_STRING_H #include <string.h> @@ -435,31 +432,6 @@ scm_stat2scm (struct stat_or_stat64 *stat_temp) return ans; } -#ifdef __MINGW32__ -/* - * Try getting the appropiate stat buffer for a given file descriptor - * under Windows. It differentiates between file, pipe and socket - * descriptors. - */ -static int fstat_Win32 (int fdes, struct stat *buf) -{ - int error, optlen = sizeof (int); - - memset (buf, 0, sizeof (struct stat)); - - /* Is this a socket ? */ - if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0) - { - buf->st_mode = _S_IREAD | _S_IWRITE | _S_IEXEC; - buf->st_nlink = 1; - buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL); - return 0; - } - /* Maybe a regular file or pipe ? */ - return fstat (fdes, buf); -} -#endif /* __MINGW32__ */ - static int is_file_name_separator (SCM c) { @@ -544,11 +516,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, if (scm_is_integer (object)) { -#ifdef __MINGW32__ - SCM_SYSCALL (rv = fstat_Win32 (scm_to_int (object), &stat_temp)); -#else SCM_SYSCALL (rv = fstat_or_fstat64 (scm_to_int (object), &stat_temp)); -#endif } else if (scm_is_string (object)) { @@ -561,11 +529,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, object = SCM_COERCE_OUTPORT (object); SCM_VALIDATE_OPFPORT (1, object); fdes = SCM_FPORT_FDES (object); -#ifdef __MINGW32__ - SCM_SYSCALL (rv = fstat_Win32 (fdes, &stat_temp)); -#else SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp)); -#endif } if (rv == -1) @@ -659,15 +623,13 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, -#ifdef HAVE_SELECT - /* check that element is a port or file descriptor. if it's a port and its buffer is ready for use, add it to the ports_ready list. otherwise add its file descriptor to *set. the type of list can be determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes, SCM_ARG3 for excepts. */ static int -set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) +set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) { int fd; @@ -713,7 +675,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes, SCM_ARG3 for excepts. */ static int -fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos) +fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos) { int max_fd = 0; @@ -748,7 +710,7 @@ fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos) /* if element (a file descriptor or port) appears in *set, cons it to list. return list. */ static SCM -get_element (SELECT_TYPE *set, SCM element, SCM list) +get_element (fd_set *set, SCM element, SCM list) { int fd; @@ -774,7 +736,7 @@ get_element (SELECT_TYPE *set, SCM element, SCM list) *set and appending them to ports_ready. result is converted to a vector if list_or_vec is a vector. */ static SCM -retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec) +retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec) { SCM answer_list = ports_ready; @@ -835,9 +797,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, { struct timeval timeout; struct timeval * time_ptr; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; + fd_set read_set; + fd_set write_set; + fd_set except_set; int read_count; int write_count; int except_count; @@ -928,9 +890,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, } { - int rv = scm_std_select (max_fd + 1, - &read_set, &write_set, &except_set, - time_ptr); + int rv = select (max_fd + 1, + &read_set, &write_set, &except_set, + time_ptr); if (rv < 0) SCM_SYSERROR; } @@ -939,7 +901,6 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, retrieve_select_type (&except_set, SCM_EOL, excepts)); } #undef FUNC_NAME -#endif /* HAVE_SELECT */ @@ -1105,11 +1066,7 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, if (oldfd == -1) SCM_SYSERROR; -#ifdef __MINGW32__ - SCM_SYSCALL (rv = fstat_Win32 (oldfd, &oldstat)); -#else SCM_SYSCALL (rv = fstat_or_fstat64 (oldfd, &oldstat)); -#endif if (rv == -1) goto err_close_oldfd; From 629987edfb1d03bcbdb6bf7f15d1ec0ff928e6f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:33:24 +0100 Subject: [PATCH 070/147] fports uses gnulib's select * libguile/fports.c: Reorder includes to put system includes first; fixes windows/winsock2 include error problem. Rely on Gnulib's select module. (fport_input_waiting): Use select instead of scm_std_select. --- libguile/fports.c | 50 ++++++++++++++++++++--------------------------- 1 file changed, 21 insertions(+), 29 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index cdb9f99a9..e0b99b520 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -28,15 +28,6 @@ #include <stdio.h> #include <fcntl.h> -#include "libguile/_scm.h" -#include "libguile/strings.h" -#include "libguile/validate.h" -#include "libguile/gc.h" -#include "libguile/posix.h" -#include "libguile/dynwind.h" -#include "libguile/hashtab.h" - -#include "libguile/fports.h" #ifdef HAVE_STRING_H #include <string.h> @@ -56,11 +47,20 @@ #include <errno.h> #include <sys/types.h> #include <sys/stat.h> - -#include "libguile/iselect.h" +#include <sys/select.h> #include <full-write.h> +#include "libguile/_scm.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/gc.h" +#include "libguile/posix.h" +#include "libguile/dynwind.h" +#include "libguile/hashtab.h" + +#include "libguile/fports.h" + #if SIZEOF_OFF_T == SIZEOF_INT #define OFF_T_MAX INT_MAX #define OFF_T_MIN INT_MIN @@ -558,37 +558,29 @@ fport_input_waiting (SCM port) return pollfd.revents & POLLIN ? 1 : 0; -#elif defined(HAVE_SELECT) +#else struct timeval timeout; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; + fd_set read_set; + fd_set write_set; + fd_set except_set; FD_ZERO (&read_set); FD_ZERO (&write_set); FD_ZERO (&except_set); - FD_SET (fdes, &read_set); - + if (fdes < FD_SETSIZE) + FD_SET (fdes, &read_set); + else + scm_out_of_range ("fport_input_waiting", scm_from_int (fdes)); + timeout.tv_sec = 0; timeout.tv_usec = 0; - if (select (SELECT_SET_SIZE, + if (select (fdes + 1, &read_set, &write_set, &except_set, &timeout) < 0) scm_syserror ("fport_input_waiting"); return FD_ISSET (fdes, &read_set) ? 1 : 0; - -#elif HAVE_IOCTL && defined (FIONREAD) - int fdes = SCM_FSTREAM (port)->fdes; - int remir; - ioctl(fdes, FIONREAD, &remir); - return remir; - -#else - scm_misc_error ("fport_input_waiting", - "Not fully implemented on this platform", - SCM_EOL); #endif } From 14b59d61028c94c8072f2f171fbc987102ad714d Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:34:06 +0100 Subject: [PATCH 071/147] silence mingw32 warning in i18n.c * libguile/i18n.c (scm_make_locale): Silence a warning. --- libguile/i18n.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index 817c66198..dc6d07d12 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 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 License @@ -685,6 +685,8 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, } } + /* silence gcc's unused variable warning */ + (void) c_base_locale; #endif return locale; From ce09e6bd0f2903566c14b4edf2659c19f2eb95b1 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:37:29 +0100 Subject: [PATCH 072/147] fix include-order problem in net_db.c for mingw * libguile/net_db.c: Reorder includes to avoid include-order problem on mingw. --- libguile/net_db.c | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/libguile/net_db.c b/libguile/net_db.c index f8007a44d..95f0040da 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -34,16 +34,6 @@ #include <verify.h> #include <errno.h> -#include "libguile/_scm.h" -#include "libguile/feature.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/dynwind.h" - -#include "libguile/validate.h" -#include "libguile/net_db.h" -#include "libguile/socket.h" - #ifdef HAVE_STRING_H #include <string.h> #endif @@ -55,6 +45,16 @@ #include <netinet/in.h> #include <arpa/inet.h> +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/dynwind.h" + +#include "libguile/validate.h" +#include "libguile/net_db.h" +#include "libguile/socket.h" + #if defined (HAVE_H_ERRNO) /* Only wrap gethostbyname / gethostbyaddr if h_errno is available. */ From b0dbbacbe40fc8aa0b057101f84aed96ac4bea07 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:38:21 +0100 Subject: [PATCH 073/147] mingw include order for socket.c * libguile/socket.c: Reorder includes to fix include order on mingw. --- libguile/socket.c | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/libguile/socket.c b/libguile/socket.c index ecb6754ae..bed069b83 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -25,25 +25,8 @@ #endif #include <errno.h> -#include <gmp.h> #include <verify.h> -#include "libguile/_scm.h" -#include "libguile/arrays.h" -#include "libguile/feature.h" -#include "libguile/fports.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/dynwind.h" -#include "libguile/srfi-13.h" - -#include "libguile/validate.h" -#include "libguile/socket.h" - -#if SCM_ENABLE_DEPRECATED == 1 -# include "libguile/deprecation.h" -#endif - #ifdef HAVE_STDINT_H #include <stdint.h> #endif @@ -62,6 +45,25 @@ #include <netdb.h> #include <arpa/inet.h> +#include <gmp.h> + +#include "libguile/_scm.h" +#include "libguile/arrays.h" +#include "libguile/feature.h" +#include "libguile/fports.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/dynwind.h" +#include "libguile/srfi-13.h" + +#include "libguile/validate.h" +#include "libguile/socket.h" + +#if SCM_ENABLE_DEPRECATED == 1 +# include "libguile/deprecation.h" +#endif + + #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ From 3baf6e8b0577c32610cc6ba97af209185c16845a Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:39:27 +0100 Subject: [PATCH 074/147] simplify stime back-compat shims for tzname * libguile/stime.c: Remove tzname declarations for ancient mingw and SGI RS6000. --- libguile/stime.c | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index 7fdbba9a7..90de697e5 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 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 License @@ -84,13 +84,6 @@ # include <sys/timeb.h> #endif -#ifndef tzname /* For SGI. */ -extern char *tzname[]; /* RS6000 and others reject char **tzname. */ -#endif -#if defined (__MINGW32__) -# define tzname _tzname -#endif - #if ! HAVE_DECL_STRPTIME extern char *strptime (); #endif From 7dfcaf2616f6a6a712aa8cbb454aca00419db08f Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:40:18 +0100 Subject: [PATCH 075/147] simplify readline.c * guile-readline/readline.c: Remove all mingw special-casing, relying instead on mingw / gnulib doing the right thing. --- guile-readline/readline.c | 31 ++++--------------------------- 1 file changed, 4 insertions(+), 27 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 0e4ad2902..68c8e60c5 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -1,6 +1,6 @@ /* readline.c --- line editing support for Guile */ -/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2013 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 @@ -27,19 +27,13 @@ #ifdef HAVE_RL_GETC_FUNCTION #include "libguile.h" -#include "libguile/iselect.h" #include <stdio.h> -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include <readline/readline.h> #include <readline/history.h> -#ifndef __MINGW32__ #include <sys/time.h> -#else -#include <io.h> -#endif +#include <sys/select.h> #include <signal.h> #include "libguile/validate.h" @@ -207,10 +201,8 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, scm_dynwind_end (); -#ifndef __MINGW32__ fclose (rl_instream); fclose (rl_outstream); -#endif --in_readline; return ans; @@ -240,10 +232,8 @@ unwind_readline (void *unused) rl_free_line_state (); rl_cleanup_after_signal (); fputc ('\n', rl_outstream); /* We don't want next output on this line */ -#ifndef __MINGW32__ fclose (rl_instream); fclose (rl_outstream); -#endif --in_readline; } @@ -319,10 +309,8 @@ scm_readline_init_ports (SCM inp, SCM outp) input_port = inp; output_port = outp; -#ifndef __MINGW32__ rl_instream = stream_from_fport (inp, "r", s_scm_readline); rl_outstream = stream_from_fport (outp, "w", s_scm_readline); -#endif } @@ -494,11 +482,9 @@ static int match_paren (int x, int k) { int tmp; -#ifndef __MINGW32__ int fno; - SELECT_TYPE readset; + fd_set readset; struct timeval timeout; -#endif rl_insert (x, k); if (!SCM_READLINE_BOUNCE_PARENS) @@ -509,14 +495,12 @@ match_paren (int x, int k) && rl_line_buffer[rl_point - 2] == '\\') return 0; -#ifndef __MINGW32__ tmp = 1000 * SCM_READLINE_BOUNCE_PARENS; timeout.tv_sec = tmp / 1000000; timeout.tv_usec = tmp % 1000000; FD_ZERO (&readset); fno = fileno (rl_instream); FD_SET (fno, &readset); -#endif if (rl_point > 1) { @@ -525,12 +509,7 @@ match_paren (int x, int k) if (rl_point > -1) { rl_redisplay (); -#ifndef __MINGW32__ - scm_std_select (fno + 1, &readset, NULL, NULL, &timeout); -#else - WaitForSingleObject (GetStdHandle(STD_INPUT_HANDLE), - SCM_READLINE_BOUNCE_PARENS); -#endif + select (fno + 1, &readset, NULL, NULL, &timeout); } rl_point = tmp; } @@ -547,9 +526,7 @@ scm_init_readline () #include "guile-readline/readline.x" scm_readline_completion_function_var = scm_c_define ("*readline-completion-function*", SCM_BOOL_F); -#ifndef __MINGW32__ rl_getc_function = current_input_getc; -#endif #if defined (_RL_FUNCTION_TYPEDEF) rl_completion_entry_function = (rl_compentry_func_t*) completion_function; #else From d3c88f18261b78f1ca9903f2f179b7f812288e1c Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:42:17 +0100 Subject: [PATCH 076/147] simplify posix.c * libguile/posix.c: Reorder includes to fix mingw include-order problem. Remove ttyname shims; gnulib is the place to fix that. Remove winsock2 include, as gnulib seems to handle that OK. Rely on the new pipe-posix gnulib module. Don't bother shimming getlogin, etc on mingw; gnulib is the place for shims. --- libguile/posix.c | 61 ++++++++++++++---------------------------------- 1 file changed, 17 insertions(+), 44 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 39661a0f6..e7a3da775 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -32,23 +32,6 @@ # include <sched.h> #endif -#include "libguile/_scm.h" -#include "libguile/dynwind.h" -#include "libguile/fports.h" -#include "libguile/scmsigs.h" -#include "libguile/feature.h" -#include "libguile/strings.h" -#include "libguile/srfi-13.h" -#include "libguile/srfi-14.h" -#include "libguile/vectors.h" -#include "libguile/values.h" - -#include "libguile/validate.h" -#include "libguile/posix.h" -#include "libguile/gettext.h" -#include "libguile/threads.h" - - #ifdef HAVE_STRING_H #include <string.h> #endif @@ -65,10 +48,6 @@ #ifdef HAVE_UNISTD_H #include <unistd.h> -#else -#ifndef ttyname -extern char *ttyname(); -#endif #endif #ifdef LIBC_H_WITH_UNISTD_H @@ -85,15 +64,23 @@ extern char *ttyname(); #ifdef HAVE_IO_H #include <io.h> #endif -#ifdef HAVE_WINSOCK2_H -#include <winsock2.h> -#endif -#ifdef __MINGW32__ -/* Some defines for Windows here. */ -# include <process.h> -# define pipe(fd) _pipe (fd, 256, O_BINARY) -#endif /* __MINGW32__ */ +#include "libguile/_scm.h" +#include "libguile/dynwind.h" +#include "libguile/fports.h" +#include "libguile/scmsigs.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" +#include "libguile/vectors.h" +#include "libguile/values.h" + +#include "libguile/validate.h" +#include "libguile/posix.h" +#include "libguile/gettext.h" +#include "libguile/threads.h" + #if HAVE_SYS_WAIT_H # include <sys/wait.h> @@ -1922,21 +1909,7 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, #endif /* HAVE_CHROOT */ -#ifdef __MINGW32__ -/* Wrapper function to supplying `getlogin()' under Windows. */ -static char * getlogin (void) -{ - static char user[256]; - static unsigned long len = 256; - - if (!GetUserName (user, &len)) - return NULL; - return user; -} -#endif /* __MINGW32__ */ - - -#if defined (HAVE_GETLOGIN) || defined (__MINGW32__) +#if defined (HAVE_GETLOGIN) SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, (void), "Return a string containing the name of the user logged in on\n" From 6ab4de612510b7c8668f0b50388258392f25b157 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 22:45:33 +0100 Subject: [PATCH 077/147] don't provide scm_std_select on mingw and similar platforms * libguile/iselect.h: If we do not have sys/select.h, don't provide scm_std_select, SELECT_TYPE, FD_SET, FD_ZERO, FD_ISSET, or FD_CLR. Guile should not be setting these macros in public API. This is an incompatible change on mingw, but oh well. * libguile/threads.c: Rely on gnulib's select, and use that to implement scm_std_select. * libguile/deprecated.h: * libguile/deprecated.c: Only provide scm_internal_select if we have sys/select.h. --- libguile/deprecated.c | 19 +++++++++++-------- libguile/deprecated.h | 8 +++++--- libguile/iselect.h | 35 +++++++++-------------------------- libguile/threads.c | 22 ++++++++++++++++------ 4 files changed, 41 insertions(+), 43 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index b5e7cf395..e1dbfaf37 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -24,6 +24,12 @@ # include <config.h> #endif +#include <math.h> +#include <stdio.h> +#include <string.h> + +#include <arpa/inet.h> + #define SCM_BUILDING_DEPRECATED_CODE #include "libguile/_scm.h" @@ -60,11 +66,6 @@ #include "libguile/feature.h" #include "libguile/uniform.h" -#include <math.h> -#include <stdio.h> -#include <string.h> - -#include <arpa/inet.h> #if (SCM_ENABLE_DEPRECATED == 1) @@ -2356,16 +2357,18 @@ scm_thread_usleep (unsigned long t) return scm_std_usleep (t); } +#ifdef HAVE_SYS_SELECT_H int scm_internal_select (int fds, - SELECT_TYPE *rfds, - SELECT_TYPE *wfds, - SELECT_TYPE *efds, + fd_set *rfds, + fd_set *wfds, + fd_set *efds, struct timeval *timeout) { scm_c_issue_deprecation_warning ("`scm_internal_select' is deprecated. Use scm_std_select instead."); return scm_std_select (fds, rfds, wfds, efds, timeout); } +#endif /* HAVE_SYS_SELECT_H */ diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 1812dd063..e17542b62 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -742,11 +742,13 @@ SCM_DEPRECATED SCM scm_c_make_keyword (const char *s); SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int); SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long); +#if SCM_HAVE_SYS_SELECT_H SCM_DEPRECATED int scm_internal_select (int fds, - SELECT_TYPE *rfds, - SELECT_TYPE *wfds, - SELECT_TYPE *efds, + fd_set *rfds, + fd_set *wfds, + fd_set *efds, struct timeval *timeout); +#endif /* Deprecated because the cuserid call is deprecated. */ diff --git a/libguile/iselect.h b/libguile/iselect.h index 760d959d8..092fb07bf 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -3,7 +3,7 @@ #ifndef SCM_ISELECT_H #define SCM_ISELECT_H -/* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1997,1998,2000,2001, 2002, 2006, 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 License @@ -29,36 +29,19 @@ #include <sys/types.h> #if SCM_HAVE_SYS_SELECT_H -# include <sys/select.h> -#endif -#if SCM_HAVE_WINSOCK2_H -# include <winsock2.h> -#endif - -#ifdef FD_SET - -#define SELECT_TYPE fd_set -#define SELECT_SET_SIZE FD_SETSIZE - -#else /* no FD_SET */ - -/* Define the macros to access a single-int bitmap of descriptors. */ -#define SELECT_SET_SIZE 32 -#define SELECT_TYPE int -#define FD_SET(n, p) (*(p) |= (1 << (n))) -#define FD_CLR(n, p) (*(p) &= ~(1 << (n))) -#define FD_ISSET(n, p) (*(p) & (1 << (n))) -#define FD_ZERO(p) (*(p) = 0) - -#endif /* no FD_SET */ +#include <sys/select.h> SCM_API int scm_std_select (int fds, - SELECT_TYPE *rfds, - SELECT_TYPE *wfds, - SELECT_TYPE *efds, + fd_set *rfds, + fd_set *wfds, + fd_set *efds, struct timeval *timeout); +#define SELECT_TYPE fd_set + +#endif /* SCM_HAVE_SYS_SELECT_H */ + #endif /* SCM_ISELECT_H */ /* diff --git a/libguile/threads.c b/libguile/threads.c index a3aee0f17..c1b9c3982 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -45,6 +45,8 @@ # include <pthread_np.h> #endif +#include <sys/select.h> + #include <assert.h> #include <fcntl.h> #include <nproc.h> @@ -1851,9 +1853,9 @@ SCM_DEFINE (scm_condition_variable_p, "condition-variable?", 1, 0, 0, struct select_args { int nfds; - SELECT_TYPE *read_fds; - SELECT_TYPE *write_fds; - SELECT_TYPE *except_fds; + fd_set *read_fds; + fd_set *write_fds; + fd_set *except_fds; struct timeval *timeout; int result; @@ -1876,11 +1878,19 @@ do_std_select (void *args) return NULL; } +#if !SCM_HAVE_SYS_SELECT_H +static int scm_std_select (int nfds, + fd_set *readfds, + fd_set *writefds, + fd_set *exceptfds, + struct timeval *timeout); +#endif + int scm_std_select (int nfds, - SELECT_TYPE *readfds, - SELECT_TYPE *writefds, - SELECT_TYPE *exceptfds, + fd_set *readfds, + fd_set *writefds, + fd_set *exceptfds, struct timeval *timeout) { fd_set my_readfds; From b7548cd2dc4ead3c0ad3d2fb5c9fc43d54e6ce8d Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 23:09:36 +0100 Subject: [PATCH 078/147] add getlogin from gnulib * lib/Makefile.am: * lib/getlogin.c: * m4/getlogin.m4: * m4/gnulib-cache.m4: Add getlogin module. --- lib/Makefile.am | 11 ++++++++++- lib/getlogin.c | 41 +++++++++++++++++++++++++++++++++++++++++ m4/getlogin.m4 | 14 ++++++++++++++ m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 8 ++++++++ 5 files changed, 75 insertions(+), 2 deletions(-) create mode 100644 lib/getlogin.c create mode 100644 m4/getlogin.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index a0d857aa0..701cd1296 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -577,6 +577,15 @@ EXTRA_libgnu_la_SOURCES += gai_strerror.c getaddrinfo.c ## end gnulib module getaddrinfo +## begin gnulib module getlogin + + +EXTRA_DIST += getlogin.c + +EXTRA_libgnu_la_SOURCES += getlogin.c + +## end gnulib module getlogin + ## begin gnulib module getpeername diff --git a/lib/getlogin.c b/lib/getlogin.c new file mode 100644 index 000000000..ebe7c3366 --- /dev/null +++ b/lib/getlogin.c @@ -0,0 +1,41 @@ +/* Provide a working getlogin for systems which lack it. + + Copyright (C) 2010-2013 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. */ + +/* Written by Bruno Haible, 2010. */ + +#include <config.h> + +/* Specification. */ +#include <unistd.h> + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +# define WIN32_LEAN_AND_MEAN +# include <windows.h> +#endif + +char * +getlogin (void) +{ +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + static char login_name[1024]; + DWORD sz = sizeof (login_name); + + if (GetUserName (login_name, &sz)) + return login_name; +#endif + return NULL; +} diff --git a/m4/getlogin.m4 b/m4/getlogin.m4 new file mode 100644 index 000000000..9b3f3cdae --- /dev/null +++ b/m4/getlogin.m4 @@ -0,0 +1,14 @@ +# getlogin.m4 serial 3 +dnl Copyright (C) 2010-2013 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_FUNC_GETLOGIN], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([getlogin]) + if test $ac_cv_func_getlogin = no; then + HAVE_GETLOGIN=0 + fi +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 1543626ee..99ace9aed 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -58,6 +58,7 @@ gl_MODULES([ func gendocs getaddrinfo + getlogin getpeername getsockname getsockopt diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 3a8172b87..0d0aa7b79 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -87,6 +87,7 @@ AC_DEFUN([gl_EARLY], # Code from module func: # Code from module gendocs: # Code from module getaddrinfo: + # Code from module getlogin: # Code from module getpeername: # Code from module getsockname: # Code from module getsockopt: @@ -353,6 +354,11 @@ AC_SUBST([LTALLOCA]) AC_LIBOBJ([gai_strerror]) fi gl_NETDB_MODULE_INDICATOR([getaddrinfo]) + gl_FUNC_GETLOGIN + if test $HAVE_GETLOGIN = 0; then + AC_LIBOBJ([getlogin]) + fi + gl_UNISTD_MODULE_INDICATOR([getlogin]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) if test "$ac_cv_header_winsock2_h" = yes; then AC_LIBOBJ([getpeername]) @@ -944,6 +950,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/full-write.h lib/gai_strerror.c lib/getaddrinfo.c + lib/getlogin.c lib/getpeername.c lib/getsockname.c lib/getsockopt.c @@ -1131,6 +1138,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/fstat.m4 m4/func.m4 m4/getaddrinfo.m4 + m4/getlogin.m4 m4/glibc21.m4 m4/gnulib-common.m4 m4/hostent.m4 From aa59904eaec70c95fa95960f98ba9cbc62010e8d Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 23:12:51 +0100 Subject: [PATCH 079/147] fix mingw issues with posix.c * libguile/posix.c (scm_execl, scm_execlp, scm_execle) (scm_open_process): Remove casts for ancient mingw. (scm_utime): If we fall back to utime, assert that flags is 0. (scm_getlogin): Rely on gnulib. --- libguile/posix.c | 42 ++++++++++-------------------------------- 1 file changed, 10 insertions(+), 32 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index e7a3da775..be4714b6a 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1135,12 +1135,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1, exec_argv = scm_i_allocate_string_pointers (args); - execv (exec_file, -#ifdef __MINGW32__ - /* extra "const" in mingw formals, provokes warning from gcc */ - (const char * const *) -#endif - exec_argv); + execv (exec_file, exec_argv); SCM_SYSERROR; /* not reached. */ @@ -1169,12 +1164,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, exec_argv = scm_i_allocate_string_pointers (args); - execvp (exec_file, -#ifdef __MINGW32__ - /* extra "const" in mingw formals, provokes warning from gcc */ - (const char * const *) -#endif - exec_argv); + execvp (exec_file, exec_argv); SCM_SYSERROR; /* not reached. */ @@ -1208,17 +1198,7 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, exec_argv = scm_i_allocate_string_pointers (args); exec_env = scm_i_allocate_string_pointers (env); - execve (exec_file, -#ifdef __MINGW32__ - /* extra "const" in mingw formals, provokes warning from gcc */ - (const char * const *) -#endif - exec_argv, -#ifdef __MINGW32__ - /* extra "const" in mingw formals, provokes warning from gcc */ - (const char * const *) -#endif - exec_env); + execve (exec_file, exec_argv, exec_env); SCM_SYSERROR; /* not reached. */ @@ -1418,12 +1398,7 @@ scm_open_process (SCM mode, SCM prog, SCM args) close (err); } - execvp (exec_file, -#ifdef __MINGW32__ - /* extra "const" in mingw formals, provokes warning from gcc */ - (const char * const *) -#endif - exec_argv); + execvp (exec_file, exec_argv); /* The exec failed! There is nothing sensible to do. */ if (err > 0) @@ -1624,6 +1599,12 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0, struct utimbuf utm; utm.actime = atim_sec; utm.modtime = mtim_sec; + /* Silence warnings. */ + (void) atim_nsec; + (void) mtim_nsec; + + if (f != 0) + scm_out_of_range(FUNC_NAME, flags); STRING_SYSCALL (pathname, c_pathname, rv = utime (c_pathname, &utm)); @@ -1908,8 +1889,6 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, #undef FUNC_NAME #endif /* HAVE_CHROOT */ - -#if defined (HAVE_GETLOGIN) SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, (void), "Return a string containing the name of the user logged in on\n" @@ -1925,7 +1904,6 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, return scm_from_locale_string (p); } #undef FUNC_NAME -#endif /* HAVE_GETLOGIN */ #if HAVE_GETPRIORITY SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, From 94c53e0601c3fb4a4dcd6d3bd602347a8253c167 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Sat, 9 Mar 2013 23:55:01 +0100 Subject: [PATCH 080/147] provide getlogin declaration if needed. * configure.ac: Check for getlogin decl. * libguile/posix.c: Declare getlogin if needed. --- configure.ac | 2 +- libguile/posix.c | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 31cb3a038..62ceb3ab2 100644 --- a/configure.ac +++ b/configure.ac @@ -919,7 +919,7 @@ AC_DEFUN([GUILE_FUNC_DECLARED], [ GUILE_FUNC_DECLARED(sleep, unistd.h) GUILE_FUNC_DECLARED(usleep, unistd.h) -AC_CHECK_DECLS([alarm]) +AC_CHECK_DECLS([getlogin alarm]) AC_CHECK_DECLS([strptime],,, [#define _GNU_SOURCE /* ask glibc to give strptime prototype */ diff --git a/libguile/posix.c b/libguile/posix.c index be4714b6a..99f758f3a 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -155,6 +155,13 @@ int sethostname (char *name, size_t namelen); #endif +#if defined HAVE_GETLOGIN && !HAVE_DECL_GETLOGIN +/* MinGW doesn't supply this decl; see + http://lists.gnu.org/archive/html/bug-gnulib/2013-03/msg00030.html for more + details. */ +char *getlogin (void); +#endif + /* On NextStep, <utime.h> doesn't define struct utime, unless we #define _POSIX_SOURCE before #including it. I think this is less of a kludge than defining struct utimbuf ourselves. */ From 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 19:23:31 +0100 Subject: [PATCH 081/147] fix response-body-port for responses without content-length * module/web/response.scm (response-body-port): Correctly handle cases in which EOF terminates the body. --- module/web/response.scm | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/module/web/response.scm b/module/web/response.scm index 7e14f4dc0..3f97dffa5 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -273,13 +273,26 @@ 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?))))) + (cond + ((member '(chunked) (response-transfer-encoding r)) + (make-chunked-input-port (response-port r) + #:keep-alive? keep-alive?)) + ((response-content-length r) + => (lambda (len) + (make-delimited-input-port (response-port r) + len keep-alive?))) + ((response-must-not-include-body? r) + #f) + ((or (memq 'close (response-connection r)) + (and (equal? (response-version r) '(1 . 0)) + (not (memq 'keep-alive (response-connection r))))) + (response-port r)) + (else + ;; Here we have a message with no transfer encoding, no + ;; content-length, and a response that won't necessarily be closed + ;; by the server. Not much we can do; assume that the client + ;; knows how to handle it. + (response-port r)))) (when (and decode? port) (match (response-content-type r) From cfe24bc4deef6f52ad3e07ffc513160890db4ff3 Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 20:12:05 +0100 Subject: [PATCH 082/147] use chmod portably in (system base compile) * module/system/base/compile.scm (call-with-output-file/atomic): Call chmod with the file name instead of the port. --- module/system/base/compile.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index db05d1790..c522b74b5 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -57,7 +57,9 @@ (with-throw-handler #t (lambda () (proc tmp) - (chmod tmp (logand #o0666 (lognot (umask)))) + ;; Chmodding by name instead of by port allows this chmod to + ;; work on systems without fchmod, like MinGW. + (chmod template (logand #o0666 (lognot (umask)))) (close-port tmp) (rename-file template filename)) (lambda args From e9381f58d1b0c9d8882328efecf938b45817e3dd Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 20:20:49 +0100 Subject: [PATCH 083/147] fix AC_CHECK_DECLS for `alarm' * configure.ac: Fix decl check for `alarm'. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 62ceb3ab2..b44159870 100644 --- a/configure.ac +++ b/configure.ac @@ -919,7 +919,7 @@ AC_DEFUN([GUILE_FUNC_DECLARED], [ GUILE_FUNC_DECLARED(sleep, unistd.h) GUILE_FUNC_DECLARED(usleep, unistd.h) -AC_CHECK_DECLS([getlogin alarm]) +AC_CHECK_DECLS([getlogin, alarm]) AC_CHECK_DECLS([strptime],,, [#define _GNU_SOURCE /* ask glibc to give strptime prototype */ From a4b4fbbdaa3542e35ea436179200d071b57ff1ca Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 22:29:18 +0100 Subject: [PATCH 084/147] excise use of "iff" in the manual * doc/ref/api-compound.texi: * doc/ref/api-control.texi: * doc/ref/api-data.texi: * doc/ref/api-macros.texi: * doc/ref/api-modules.texi: * doc/ref/api-procedures.texi: * doc/ref/api-scheduling.texi: * doc/ref/api-smobs.texi: * doc/ref/api-undocumented.texi: * doc/ref/api-utility.texi: * doc/ref/compiler.texi: * doc/ref/intro.texi: * doc/ref/scheme-using.texi: * doc/ref/sxml.texi: * doc/ref/web.texi: Change uses of "iff" to "if, otherwise". Fixes bug 10302. --- doc/ref/api-compound.texi | 4 ++-- doc/ref/api-control.texi | 2 +- doc/ref/api-data.texi | 38 +++++++++++++++++------------------ doc/ref/api-macros.texi | 18 +++++++++-------- doc/ref/api-modules.texi | 8 ++++---- doc/ref/api-procedures.texi | 3 ++- doc/ref/api-scheduling.texi | 12 +++++------ doc/ref/api-smobs.texi | 6 +++--- doc/ref/api-undocumented.texi | 6 +++--- doc/ref/api-utility.texi | 6 +++--- doc/ref/compiler.texi | 8 ++++---- doc/ref/intro.texi | 21 +------------------ doc/ref/scheme-using.texi | 2 +- doc/ref/sxml.texi | 9 ++------- doc/ref/web.texi | 8 ++++---- 15 files changed, 65 insertions(+), 86 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 6dfc5fdc0..83de8077c 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -300,7 +300,7 @@ depending on the datatype of their arguments. @rnindex list? @deffn {Scheme Procedure} list? x @deffnx {C Function} scm_list_p (x) -Return @code{#t} iff @var{x} is a proper list, else @code{#f}. +Return @code{#t} if @var{x} is a proper list, else @code{#f}. @end deffn The predicate @code{null?} is often used in list-processing code to @@ -311,7 +311,7 @@ somehow deals with the elements of a list until the list satisfies @rnindex null? @deffn {Scheme Procedure} null? x @deffnx {C Function} scm_null_p (x) -Return @code{#t} iff @var{x} is the empty list, else @code{#f}. +Return @code{#t} if @var{x} is the empty list, else @code{#f}. @end deffn @deftypefn {C Function} int scm_is_null (SCM x) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index ea943d360..320812dfb 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -200,7 +200,7 @@ For this clause type, @var{test} may return multiple values, and @code{cond} ignores its boolean state; instead, @code{cond} evaluates @var{guard} and applies the resulting procedure to the value(s) of @var{test}, as if @var{guard} were the @var{consumer} argument of -@code{call-with-values}. Iff the result of that procedure call is a +@code{call-with-values}. If the result of that procedure call is a true value, it evaluates @var{expression} and applies the resulting procedure to the value(s) of @var{test}, in the same manner as the @var{guard} was called. diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 9da17d8c3..fb12d2ccf 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -2049,7 +2049,7 @@ number of one to eight digits. @rnindex char? @deffn {Scheme Procedure} char? x @deffnx {C Function} scm_char_p (x) -Return @code{#t} iff @var{x} is a character, else @code{#f}. +Return @code{#t} if @var{x} is a character, else @code{#f}. @end deffn Fundamentally, the character comparison operations below are @@ -2057,31 +2057,31 @@ numeric comparisons of the character's code points. @rnindex char=? @deffn {Scheme Procedure} char=? x y -Return @code{#t} iff code point of @var{x} is equal to the code point +Return @code{#t} if code point of @var{x} is equal to the code point of @var{y}, else @code{#f}. @end deffn @rnindex char<? @deffn {Scheme Procedure} char<? x y -Return @code{#t} iff the code point of @var{x} is less than the code +Return @code{#t} if the code point of @var{x} is less than the code point of @var{y}, else @code{#f}. @end deffn @rnindex char<=? @deffn {Scheme Procedure} char<=? x y -Return @code{#t} iff the code point of @var{x} is less than or equal +Return @code{#t} if the code point of @var{x} is less than or equal to the code point of @var{y}, else @code{#f}. @end deffn @rnindex char>? @deffn {Scheme Procedure} char>? x y -Return @code{#t} iff the code point of @var{x} is greater than the +Return @code{#t} if the code point of @var{x} is greater than the code point of @var{y}, else @code{#f}. @end deffn @rnindex char>=? @deffn {Scheme Procedure} char>=? x y -Return @code{#t} iff the code point of @var{x} is greater than or +Return @code{#t} if the code point of @var{x} is greater than or equal to the code point of @var{y}, else @code{#f}. @end deffn @@ -2099,32 +2099,32 @@ it cannot cover all cases for all languages. @rnindex char-ci=? @deffn {Scheme Procedure} char-ci=? x y -Return @code{#t} iff the case-folded code point of @var{x} is the same +Return @code{#t} if the case-folded code point of @var{x} is the same as the case-folded code point of @var{y}, else @code{#f}. @end deffn @rnindex char-ci<? @deffn {Scheme Procedure} char-ci<? x y -Return @code{#t} iff the case-folded code point of @var{x} is less +Return @code{#t} if the case-folded code point of @var{x} is less than the case-folded code point of @var{y}, else @code{#f}. @end deffn @rnindex char-ci<=? @deffn {Scheme Procedure} char-ci<=? x y -Return @code{#t} iff the case-folded code point of @var{x} is less +Return @code{#t} if the case-folded code point of @var{x} is less than or equal to the case-folded code point of @var{y}, else @code{#f}. @end deffn @rnindex char-ci>? @deffn {Scheme Procedure} char-ci>? x y -Return @code{#t} iff the case-folded code point of @var{x} is greater +Return @code{#t} if the case-folded code point of @var{x} is greater than the case-folded code point of @var{y}, else @code{#f}. @end deffn @rnindex char-ci>=? @deffn {Scheme Procedure} char-ci>=? x y -Return @code{#t} iff the case-folded code point of @var{x} is greater +Return @code{#t} if the case-folded code point of @var{x} is greater than or equal to the case-folded code point of @var{y}, else @code{#f}. @end deffn @@ -2132,36 +2132,36 @@ than or equal to the case-folded code point of @var{y}, else @rnindex char-alphabetic? @deffn {Scheme Procedure} char-alphabetic? chr @deffnx {C Function} scm_char_alphabetic_p (chr) -Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. +Return @code{#t} if @var{chr} is alphabetic, else @code{#f}. @end deffn @rnindex char-numeric? @deffn {Scheme Procedure} char-numeric? chr @deffnx {C Function} scm_char_numeric_p (chr) -Return @code{#t} iff @var{chr} is numeric, else @code{#f}. +Return @code{#t} if @var{chr} is numeric, else @code{#f}. @end deffn @rnindex char-whitespace? @deffn {Scheme Procedure} char-whitespace? chr @deffnx {C Function} scm_char_whitespace_p (chr) -Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. +Return @code{#t} if @var{chr} is whitespace, else @code{#f}. @end deffn @rnindex char-upper-case? @deffn {Scheme Procedure} char-upper-case? chr @deffnx {C Function} scm_char_upper_case_p (chr) -Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. +Return @code{#t} if @var{chr} is uppercase, else @code{#f}. @end deffn @rnindex char-lower-case? @deffn {Scheme Procedure} char-lower-case? chr @deffnx {C Function} scm_char_lower_case_p (chr) -Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. +Return @code{#t} if @var{chr} is lowercase, else @code{#f}. @end deffn @deffn {Scheme Procedure} char-is-both? chr @deffnx {C Function} scm_char_is_both_p (chr) -Return @code{#t} iff @var{chr} is either uppercase or lowercase, else +Return @code{#t} if @var{chr} is either uppercase or lowercase, else @code{#f}. @end deffn @@ -2583,8 +2583,8 @@ string is not defined. @deffn {Scheme Procedure} char-set-contains? cs ch @deffnx {C Function} scm_char_set_contains_p (cs, ch) -Return @code{#t} iff the character @var{ch} is contained in the -character set @var{cs}. +Return @code{#t} if the character @var{ch} is contained in the +character set @var{cs}, or @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} char-set-every pred cs diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index 347d02589..dcbde9b30 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, 2012 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, 2012, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -520,7 +520,8 @@ is impossible with @code{syntax-rules}, given the datum matching forms. But with @code{syntax-case} it is easy: @deffn {Scheme Procedure} identifier? syntax-object -Returns @code{#t} iff @var{syntax-object} is an identifier. +Returns @code{#t} if @var{syntax-object} is an identifier, or @code{#f} +otherwise. @end deffn @example @@ -690,13 +691,13 @@ macros can use to compare, generate, and query objects of this data type. @deffn {Scheme Procedure} bound-identifier=? a b -Return @code{#t} iff the syntax objects @var{a} and @var{b} refer to the -same lexically-bound identifier. +Return @code{#t} if the syntax objects @var{a} and @var{b} refer to the +same lexically-bound identifier, or @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} free-identifier=? a b -Return @code{#t} iff the syntax objects @var{a} and @var{b} refer to the -same free identifier. +Return @code{#t} if the syntax objects @var{a} and @var{b} refer to the +same free identifier, or @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} generate-temporaries ls @@ -935,7 +936,7 @@ left-hand side of a @code{set!} expression, as in the following: (set! foo @var{val}) ;; expands via (foo-transformer #'(set! foo @var{val})) -;; iff foo-transformer is a "variable transformer" +;; if foo-transformer is a "variable transformer" @end example As the example notes, the transformer procedure must be explicitly @@ -1125,7 +1126,8 @@ for syntax-case. @deffn {Scheme Procedure} macro? obj @deffnx {C Function} scm_macro_p (obj) -Return @code{#t} iff @var{obj} is a syntax transformer. +Return @code{#t} if @var{obj} is a syntax transformer, or @code{#f} +otherwise. Note that it's a bit difficult to actually get a macro as a first-class object; simply naming it (like @code{case}) will produce a syntax error. But it is diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 47b81601b..4a4011d20 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -759,8 +759,8 @@ Return a variable initialized to value @var{init}. @deffn {Scheme Procedure} variable-bound? var @deffnx {C Function} scm_variable_bound_p (var) -Return @code{#t} iff @var{var} is bound to a value. -Throws an error if @var{var} is not a variable object. +Return @code{#t} if @var{var} is bound to a value, or @code{#f} +otherwise. Throws an error if @var{var} is not a variable object. @end deffn @deffn {Scheme Procedure} variable-ref var @@ -784,8 +784,8 @@ Unset the value of the variable @var{var}, leaving @var{var} unbound. @deffn {Scheme Procedure} variable? obj @deffnx {C Function} scm_variable_p (obj) -Return @code{#t} iff @var{obj} is a variable object, else -return @code{#f}. +Return @code{#t} if @var{obj} is a variable object, else return +@code{#f}. @end deffn diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index 38ae1bb69..e0158fd09 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -157,7 +157,8 @@ appropriate module first, though: @deffn {Scheme Procedure} program? obj @deffnx {C Function} scm_program_p (obj) -Returns @code{#t} iff @var{obj} is a compiled procedure. +Returns @code{#t} if @var{obj} is a compiled procedure, or @code{#f} +otherwise. @end deffn @deffn {Scheme Procedure} program-objcode program diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 749583a1b..e040904cf 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -247,7 +247,7 @@ Once @var{body} or @var{handler} returns, the return value is made the @deffn {Scheme Procedure} thread? obj @deffnx {C Function} scm_thread_p (obj) -Return @code{#t} iff @var{obj} is a thread; otherwise, return +Return @code{#t} ff @var{obj} is a thread; otherwise, return @code{#f}. @end deffn @@ -267,7 +267,7 @@ specified; @code{#f} is returned otherwise). @deffn {Scheme Procedure} thread-exited? thread @deffnx {C Function} scm_thread_exited_p (thread) -Return @code{#t} iff @var{thread} has exited. +Return @code{#t} if @var{thread} has exited, or @code{#f} otherwise. @end deffn @c begin (texi-doc-string "guile" "yield") @@ -376,7 +376,7 @@ The returned mutex will be recursive. @deffn {Scheme Procedure} mutex? obj @deffnx {C Function} scm_mutex_p (obj) -Return @code{#t} iff @var{obj} is a mutex; otherwise, return +Return @code{#t} if @var{obj} is a mutex; otherwise, return @code{#f}. @end deffn @@ -481,7 +481,7 @@ Return a new condition variable. @deffn {Scheme Procedure} condition-variable? obj @deffnx {C Function} scm_condition_variable_p (obj) -Return @code{#t} iff @var{obj} is a condition variable; otherwise, +Return @code{#t} if @var{obj} is a condition variable; otherwise, return @code{#f}. @end deffn @@ -702,7 +702,7 @@ implicitly bound to some definite value). @deffn {Scheme Procedure} fluid? obj @deffnx {C Function} scm_fluid_p (obj) -Return @code{#t} iff @var{obj} is a fluid; otherwise, return +Return @code{#t} if @var{obj} is a fluid; otherwise, return @code{#f}. @end deffn @@ -726,7 +726,7 @@ Disassociate the given fluid from any value, making it unbound. @deffn {Scheme Procedure} fluid-bound? fluid @deffnx {C Function} scm_fluid_bound_p (fluid) -Returns @code{#t} iff the given fluid is bound to a value, otherwise +Returns @code{#t} if the given fluid is bound to a value, otherwise @code{#f}. @end deffn diff --git a/doc/ref/api-smobs.texi b/doc/ref/api-smobs.texi index cb2034ce1..345bf7cbd 100644 --- a/doc/ref/api-smobs.texi +++ b/doc/ref/api-smobs.texi @@ -124,9 +124,9 @@ Else, signal an error. @end deftypefn @deftypefn {C Macro} int SCM_SMOB_PREDICATE (scm_t_bits tag, SCM exp) -Return true iff @var{exp} is a smob instance of the type indicated by -@var{tag}. The expression @var{exp} can be evaluated more than once, -so it shouldn't contain any side effects. +Return true if @var{exp} is a smob instance of the type indicated by +@var{tag}, or false otherwise. The expression @var{exp} can be +evaluated more than once, so it shouldn't contain any side effects. @end deftypefn @deftypefn {C Function} SCM scm_new_smob (scm_t_bits tag, void *data) diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi index 1ffb3a914..4e478f4c4 100644 --- a/doc/ref/api-undocumented.texi +++ b/doc/ref/api-undocumented.texi @@ -188,8 +188,8 @@ would modify regular hash tables. (@pxref{Hash Tables}) @end deffn @deffn {Scheme Procedure} include-deprecated-features -Return @code{#t} iff deprecated features should be included -in public interfaces. +Return @code{#t} if deprecated features should be included in public +interfaces, or @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} issue-deprecation-warning . msgs @@ -202,7 +202,7 @@ they are printed in turn, each one followed by a newline. @deffn {Scheme Procedure} valid-object-procedure? proc @deffnx {C Function} scm_valid_object_procedure_p (proc) -Return @code{#t} iff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}. +Return @code{#t} ff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}. @end deffn @deffn {Scheme Procedure} %get-pre-modules-obarray diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index 17694ecab..76c50b2ca 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011, 2012 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011, 2012, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -308,10 +308,10 @@ input. @deffn {Scheme Procedure} sorted? items less @deffnx {C Function} scm_sorted_p (items, less) -Return @code{#t} iff @var{items} is a list or vector such that, +Return @code{#t} if @var{items} is a list or vector such that, for each element @var{x} and the next element @var{y} of @var{items}, @code{(@var{less} @var{y} @var{x})} returns -@code{#f}. +@code{#f}. Otherwise return @code{#f}. @end deffn @deffn {Scheme Procedure} sort items less diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 400814080..bfc633e57 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -580,9 +580,9 @@ variables. @var{vars} is a list of @code{(@var{name} @var{type} program's metadata and do not form part of a program's code path. @end deftp @deftp {Scheme Variable} <glil-mv-bind> vars rest -A multiple-value binding of the values on the stack to @var{vars}. Iff -@var{rest} is true, the last element of @var{vars} will be treated as -a rest argument. +A multiple-value binding of the values on the stack to @var{vars}. If +@var{rest} is true, the last element of @var{vars} will be treated as a +rest argument. In addition to pushing a binding annotation on the stack, like @code{<glil-bind>}, an expression is emitted at compilation time to @@ -789,7 +789,7 @@ objcode)} module. @deffn {Scheme Procedure} objcode? obj @deffnx {C Function} scm_objcode_p (obj) -Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise. +Returns @code{#f} if @var{obj} is object code, @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} bytecode->objcode bytecode diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi index e94948f92..28da4ac3c 100644 --- a/doc/ref/intro.texi +++ b/doc/ref/intro.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -288,21 +288,6 @@ classes, multiple inheritance and generic functions. @node Typographical Conventions @section Typographical Conventions -We use some conventions in this manual. - -@itemize @bullet - -@item -For some procedures, notably type predicates, we use ``iff'' to mean -``if and only if''. The construct is usually something like: `Return -@var{val} iff @var{condition}', where @var{val} is usually -``@nicode{#t}'' or ``non-@nicode{#f}''. This typically means that -@var{val} is returned if @var{condition} holds, and that @samp{#f} is -returned otherwise. To clarify: @var{val} will @strong{only} be -returned when @var{condition} is true. -@cindex iff - -@item In examples and procedure descriptions and all other places where the evaluation of Scheme expression is shown, we use some notation for denoting the output and evaluation results of expressions. @@ -328,10 +313,6 @@ As you can see, this code prints @samp{1} (denoted by @samp{@print{}}), and returns @code{hooray} (denoted by @samp{@result{}}). -@c Add other conventions here. - -@end itemize - @c Local Variables: @c TeX-master: "guile.texi" diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 81576605b..b6516bd63 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -125,7 +125,7 @@ The programmatic interface to value history is in a module: @end lisp @deffn {Scheme Procedure} value-history-enabled? -Return true iff value history is enabled. +Return true if value history is enabled, or false otherwise. @end deffn @deffn {Scheme Procedure} enable-value-history! diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi index 6dc261f31..75867f3a6 100644 --- a/doc/ref/sxml.texi +++ b/doc/ref/sxml.texi @@ -381,13 +381,8 @@ Pearl. Proc ICFP'00, pp. 186-197. @deffn {Scheme Procedure} attlist-add attlist name-value @end deffn -@deffn {Scheme Procedure} attlist-null? _ -@verbatim - -- Scheme Procedure: null? x - Return `#t' iff X is the empty list, else `#f'. - - -@end verbatim +@deffn {Scheme Procedure} attlist-null? x +Return @code{#t} if @var{x} is the empty list, else @code{#f}. @end deffn @deffn {Scheme Procedure} attlist-remove-top attlist diff --git a/doc/ref/web.texi b/doc/ref/web.texi index ae387ce14..70e0f2e43 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -351,8 +351,8 @@ parsing and serialization procedures. If a header is unknown, its string name is simply its symbol name in title-case. @deffn {Scheme Procedure} known-header? sym -Return @code{#t} iff @var{sym} is a known header, with associated -parsers and serialization procedures. +Return @code{#t} if @var{sym} is a known header, with associated +parsers and serialization procedures, or @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} header-parser sym @@ -405,8 +405,8 @@ you want a header's value to be returned/written ``as-is''. @end deffn @deffn {Scheme Procedure} valid-header? sym val -Return a true value iff @var{val} is a valid Scheme value for the header -with name @var{sym}. +Return a true value if @var{val} is a valid Scheme value for the header +with name @var{sym}, or @code{#f} otherwise. @end deffn Now that we have a generic interface for reading and writing headers, we From 988ca6b212fce6d9419d1ffce8f115425ade3a9f Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 23:20:22 +0100 Subject: [PATCH 085/147] add %site-ccache-dir * libguile/load.h: * libguile/load.c (scm_sys_site_ccache_dir): New procedure. * doc/ref/scheme-using.texi (Installing Site Packages): * doc/ref/api-options.texi (Build Config): Add docs. Fixes bug 10326. --- doc/ref/api-options.texi | 7 +++++++ doc/ref/scheme-using.texi | 11 ++++++----- libguile/load.c | 13 +++++++++++++ libguile/load.h | 3 ++- 4 files changed, 28 insertions(+), 6 deletions(-) diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index 173431890..a1575c5af 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -96,6 +96,13 @@ your site should be installed. On Unix-like systems, this is usually @file{/usr/local/share/guile/site} or @file{/usr/share/guile/site}. @end deffn +@deffn {Scheme Procedure} %site-ccache-dir +@deffnx {C Function} scm_sys_site_ccache_dir () +Return the directory where users should install compiled @code{.go} +files for use with this version of Guile. Might look something like +@file{/usr/lib/guile/@value{EFFECTIVE-VERSION}/site-ccache}. +@end deffn + @defvar %guile-build-info Alist of information collected during the building of a particular Guile. Entries can be grouped into one of several categories: diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index b6516bd63..4422c1863 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -752,6 +752,7 @@ list}, or simply @code{guild}. @cindex site path @cindex load path @findex %site-dir +@findex %site-ccache-dir At some point, you will probably want to share your code with other people. To do so effectively, it is important to follow a set of common @@ -783,11 +784,11 @@ find them. As with Scheme files, Guile searches a path to find compiled @code{.go} files, the @code{%load-compiled-path}. By default, this path has two entries: a path for Guile's files, and a path for site packages. You -should install your @code{.go} files into the latter. Currently there -is no procedure to get at this path, which is probably a bug. As in the -previous example, if Guile @value{EFFECTIVE-VERSION} is installed on -your system in @code{/usr/}, then the place to put compiled files for -site packages will be +should install your @code{.go} files into the latter directory, whose +value is returned by invoking the @code{%site-ccache-dir} procedure. As +in the previous example, if Guile @value{EFFECTIVE-VERSION} is installed +on your system in @code{/usr/}, then @code{(%site-ccache-dir)} site +packages will be @code{/usr/lib/guile/@value{EFFECTIVE-VERSION}/site-ccache}. Note that a @code{.go} file will only be loaded in preference to a diff --git a/libguile/load.c b/libguile/load.c index da75a5a71..c46072512 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -198,6 +198,19 @@ SCM_DEFINE (scm_sys_global_site_dir, "%global-site-dir", 0,0,0, #undef FUNC_NAME #endif /* SCM_GLOBAL_SITE_DIR */ +#ifdef SCM_SITE_CCACHE_DIR +SCM_DEFINE (scm_sys_site_ccache_dir, "%site-ccache-dir", 0,0,0, + (), + "Return the directory where users should install compiled\n" + "@code{.go} files for use with this version of Guile.\n\n" + "E.g., may return \"/usr/lib/guile/" SCM_EFFECTIVE_VERSION "/site-ccache\".") +#define FUNC_NAME s_scm_sys_site_ccache_dir +{ + return scm_from_locale_string (SCM_SITE_CCACHE_DIR); +} +#undef FUNC_NAME +#endif /* SCM_SITE_CCACHE_DIR */ + /* Initializing the load path, and searching it. */ diff --git a/libguile/load.h b/libguile/load.h index 698bbaf6c..ab75ea3b3 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -3,7 +3,7 @@ #ifndef SCM_LOAD_H #define SCM_LOAD_H -/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011, 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 License @@ -34,6 +34,7 @@ SCM_API SCM scm_sys_package_data_dir (void); SCM_API SCM scm_sys_library_dir (void); SCM_API SCM scm_sys_site_dir (void); SCM_API SCM scm_sys_global_site_dir (void); +SCM_API SCM scm_sys_site_ccache_dir (void); SCM_API SCM scm_search_path (SCM path, SCM filename, SCM rest); SCM_API SCM scm_sys_search_load_path (SCM filename); SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found); From ccd0ae1fbb1c8c942a89bf84272377b341739e0f Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@pobox.com> Date: Fri, 30 Mar 2012 20:04:16 +0200 Subject: [PATCH 086/147] guile.m4 allows selection of guile 2.0, 1.8, etc. * meta/guile.m4 (GUILE_PKG): New macro, chooses a version of Guile against which to compile. (GUILE_FLAGS, GUILE_PROGS): Rewrite to call GUILE_PKG as necessary, to respect any previous call to GUILE_PKG, and to not require guile-tools. --- meta/guile.m4 | 165 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 121 insertions(+), 44 deletions(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index a7186fb84..a3e1ef1de 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -1,6 +1,6 @@ ## Autoconf macros for working with Guile. ## -## Copyright (C) 1998,2001, 2006, 2010 Free Software Foundation, Inc. +## Copyright (C) 1998,2001, 2006, 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 @@ -22,6 +22,7 @@ ## Index ## ----- ## +## GUILE_PKG -- find Guile development files ## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs ## GUILE_FLAGS -- set flags for compiling and linking with Guile ## GUILE_SITE_DIR -- find path to Guile "site" directory @@ -38,53 +39,85 @@ ## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged ## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory). -# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs +# GUILE_PKG -- find Guile development files # -# Usage: GUILE_PROGS +# Usage: GUILE_PKG([VERSIONS]) # -# This macro looks for programs @code{guile}, @code{guile-config} and -# @code{guile-tools}, and sets variables @var{GUILE}, @var{GUILE_CONFIG} and -# @var{GUILE_TOOLS}, to their paths, respectively. If either of the first two -# is not found, signal error. +# This macro runs the @code{pkg-config} tool to find development files +# for an available version of Guile. # -# The variables are marked for substitution, as by @code{AC_SUBST}. +# By default, this macro will search for the latest stable version of +# Guile (e.g. 2.0), falling back to the previous stable version +# (e.g. 1.8) if it is available. If no guile-@var{VERSION}.pc file is +# found, an error is signalled. The found version is stored in +# @var{GUILE_EFFECTIVE_VERSION}. # -AC_DEFUN([GUILE_PROGS], - [AC_PATH_PROG(GUILE,guile) - if test "$GUILE" = "" ; then - AC_MSG_ERROR([guile required but not found]) +# If @code{GUILE_PROGS} was already invoked, this macro ensures that the +# development files have the same effective version as the Guile +# program. +# +# @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by +# @code{AC_SUBST}. +# +AC_DEFUN([GUILE_PKG], + [PKG_PROG_PKG_CONFIG + _guile_versions_to_search="m4_default([$1], [2.0 1.8])" + if test -n "$GUILE_EFFECTIVE_VERSION"; then + _guile_tmp="" + for v in $_guile_versions_to_search; do + if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then + _guile_tmp=$v + fi + done + if test -z "$_guile_tmp"; then + AC_MSG_FAILURE([searching for guile development files for versions $_guile_versions_to_search, but previously found $GUILE version $GUILE_EFFECTIVE_VERSION]) + fi + _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION fi - AC_SUBST(GUILE) - AC_PATH_PROG(GUILE_CONFIG,guile-config) - if test "$GUILE_CONFIG" = "" ; then - AC_MSG_ERROR([guile-config required but not found]) + GUILE_EFFECTIVE_VERSION="" + _guile_errors="" + for v in $_guile_versions_to_search; do + AC_MSG_NOTICE([checking for guile $v]) + if test -z "$GUILE_EFFECTIVE_VERSION"; then + PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], []) + fi + done + + if test -z "$GUILE_EFFECTIVE_VERSION"; then + AC_MSG_ERROR([ +No Guile development packages were found. + +Please verify that you have Guile installed. If you installed Guile +from a binary distribution, please verify that you have also installed +the development packages. If you installed it yourself, you might need +to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. +]) fi - AC_SUBST(GUILE_CONFIG) - AC_PATH_PROG(GUILE_TOOLS,guile-tools) - AC_SUBST(GUILE_TOOLS) + AC_MSG_NOTICE([found guile $v]) + AC_SUBST([GUILE_EFFECTIVE_VERSION]) ]) # GUILE_FLAGS -- set flags for compiling and linking with Guile # # Usage: GUILE_FLAGS # -# This macro runs the @code{guile-config} script, installed with Guile, to -# find out where Guile's header files and libraries are installed. It sets -# four variables, @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, -# and @var{GUILE_LTLIBS}. +# This macro runs the @code{pkg-config} tool to find out how to compile +# and link programs against Guile. It sets four variables: +# @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and +# @var{GUILE_LTLIBS}. # # @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that # uses Guile header files. This is almost always just one or more @code{-I} # flags. # -# @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program against -# Guile. This includes @code{-lguile} for the Guile library itself, any -# libraries that Guile itself requires (like -lqthreads), and so on. It may -# also include one or more @code{-L} flag to tell the compiler where to find -# the libraries. But it does not include flags that influence the program's -# runtime search path for libraries, and will therefore lead to a program -# that fails to start, unless all necessary libraries are installed in a -# standard location such as @file{/usr/lib}. +# @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program +# against Guile. This includes @code{-lguile-@var{VERSION}} for the +# Guile library itself, and may also include one or more @code{-L} flag +# to tell the compiler where to find the libraries. But it does not +# include flags that influence the program's runtime search path for +# libraries, and will therefore lead to a program that fails to start, +# unless all necessary libraries are installed in a standard location +# such as @file{/usr/lib}. # # @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to # libtool, respectively, to link a program against Guile. It includes flags @@ -97,16 +130,14 @@ AC_DEFUN([GUILE_PROGS], # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_FLAGS], - [dnl Find guile-config. - AC_REQUIRE([GUILE_PROGS])dnl + [AC_REQUIRE([GUILE_PKG]) + PKG_CHECK_MODULES(GUILE, [guile-$GUILE_EFFECTIVE_VERSION]) - AC_MSG_CHECKING([libguile compile flags]) - GUILE_CFLAGS="`$GUILE_CONFIG compile`" - AC_MSG_RESULT([$GUILE_CFLAGS]) + dnl GUILE_CFLAGS and GUILE_LIBS are already defined and AC_SUBST'd by + dnl PKG_CHECK_MODULES. But GUILE_LIBS to pkg-config is GUILE_LDFLAGS + dnl to us. - AC_MSG_CHECKING([libguile link flags]) - GUILE_LDFLAGS="`$GUILE_CONFIG link`" - AC_MSG_RESULT([$GUILE_LDFLAGS]) + GUILE_LDFLAGS=$GUILE_LIBS dnl Determine the platform dependent parameters needed to use rpath. dnl AC_LIB_LINKFLAGS_FROM_LIBS is defined in gnulib/m4/lib-link.m4 and needs @@ -116,6 +147,7 @@ AC_DEFUN([GUILE_FLAGS], AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LTLIBS], [$GUILE_LDFLAGS], [yes]) GUILE_LTLIBS="$GUILE_LDFLAGS $GUILE_LTLIBS" + AC_SUBST([GUILE_EFFECTIVE_VERSION]) AC_SUBST([GUILE_CFLAGS]) AC_SUBST([GUILE_LDFLAGS]) AC_SUBST([GUILE_LIBS]) @@ -133,16 +165,61 @@ AC_DEFUN([GUILE_FLAGS], # The variable is marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_SITE_DIR], - [AC_REQUIRE([GUILE_PROGS])dnl + [AC_REQUIRE([GUILE_PKG]) AC_MSG_CHECKING(for Guile site directory) - GUILE_SITE=`[$GUILE_CONFIG] info sitedir` - if test "$GUILE_SITE" = ""; then - GUILE_SITE=`[$GUILE_CONFIG] info pkgdatadir`/site - fi + GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` AC_MSG_RESULT($GUILE_SITE) + if test "$GUILE_SITE" = ""; then + AC_MSG_FAILURE(sitedir not found) + fi AC_SUBST(GUILE_SITE) ]) +# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs +# +# Usage: GUILE_PROGS +# +# This macro looks for programs @code{guile} and @code{guild}, setting +# variables @var{GUILE} and @var{GUILD} to their paths, respectively. +# If @code{guile} is not found, signal an error. +# +# The effective version of the found @code{guile} is set to +# @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective +# version is compatible with the result of a previous invocation of +# @code{GUILE_FLAGS}, if any. +# +# As a legacy interface, it also looks for @code{guile-config} and +# @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}. +# +# The variables are marked for substitution, as by @code{AC_SUBST}. +# +AC_DEFUN([GUILE_PROGS], + [AC_PATH_PROG(GUILE,guile) + if test "$GUILE" = "" ; then + AC_MSG_ERROR([guile required but not found]) + fi + AC_SUBST(GUILE) + + _guile_prog_version=`$GUILE -c "(display (effective-version))"` + if test -z "$GUILE_EFFECTIVE_VERSION"; then + GUILE_EFFECTIVE_VERSION=$_guile_prog_version + elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_prog_version"; then + AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_prog_version]) + fi + + AC_PATH_PROG(GUILD,guild) + AC_SUBST(GUILD) + + AC_PATH_PROG(GUILE_CONFIG,guile-config) + AC_SUBST(GUILE_CONFIG) + if test -n "$GUILD"; then + GUILE_TOOLS=$GUILD + else + AC_PATH_PROG(GUILE_TOOLS,guile-tools) + fi + AC_SUBST(GUILE_TOOLS) + ]) + # GUILE_CHECK -- evaluate Guile Scheme code and capture the return value # # Usage: GUILE_CHECK_RETVAL(var,check) From 428f9e95fccb7105f00d22e80312e9f5a7a263a4 Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 23:40:13 +0100 Subject: [PATCH 087/147] import `poll' from gnulib * lib/Makefile.am: * lib/poll.c: * lib/poll.in.h: * m4/gnulib-cache.m4: * m4/gnulib-comp.m4: * m4/poll.m4: * m4/poll_h.m4: Add poll gnulib module. --- lib/Makefile.am | 41 ++- lib/poll.c | 611 +++++++++++++++++++++++++++++++++++++++++++++ lib/poll.in.h | 103 ++++++++ m4/gnulib-cache.m4 | 3 +- m4/gnulib-comp.m4 | 13 + m4/poll.m4 | 103 ++++++++ m4/poll_h.m4 | 47 ++++ 7 files changed, 919 insertions(+), 2 deletions(-) create mode 100644 lib/poll.c create mode 100644 lib/poll.in.h create mode 100644 m4/poll.m4 create mode 100644 m4/poll_h.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 701cd1296..c92a8acf4 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -62,6 +62,7 @@ libgnu_la_LDFLAGS += $(ISNANL_LIBM) libgnu_la_LDFLAGS += $(LDEXP_LIBM) libgnu_la_LDFLAGS += $(LIBSOCKET) libgnu_la_LDFLAGS += $(LIB_CLOCK_GETTIME) +libgnu_la_LDFLAGS += $(LIB_POLL) libgnu_la_LDFLAGS += $(LIB_SELECT) libgnu_la_LDFLAGS += $(LOG1P_LIBM) libgnu_la_LDFLAGS += $(LOG_LIBM) @@ -1484,6 +1485,44 @@ libgnu_la_SOURCES += pipe2.c ## end gnulib module pipe2 +## begin gnulib module poll + + +EXTRA_DIST += poll.c + +EXTRA_libgnu_la_SOURCES += poll.c + +## end gnulib module poll + +## begin gnulib module poll-h + +BUILT_SOURCES += poll.h + +# We need the following in order to create <poll.h> when the system +# doesn't have one. +poll.h: poll.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H) + $(AM_V_GEN)rm -f $@-t $@ && \ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + sed -e 's|@''GUARD_PREFIX''@|GL|g' \ + -e 's|@''HAVE_POLL_H''@|$(HAVE_POLL_H)|g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ + -e 's|@''NEXT_POLL_H''@|$(NEXT_POLL_H)|g' \ + -e 's/@''GNULIB_POLL''@/$(GNULIB_POLL)/g' \ + -e 's|@''HAVE_POLL''@|$(HAVE_POLL)|g' \ + -e 's|@''REPLACE_POLL''@|$(REPLACE_POLL)|g' \ + -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ + -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ + < $(srcdir)/poll.in.h; \ + } > $@-t && \ + mv -f $@-t $@ +MOSTLYCLEANFILES += poll.h poll.h-t + +EXTRA_DIST += poll.in.h + +## end gnulib module poll-h + ## begin gnulib module putenv diff --git a/lib/poll.c b/lib/poll.c new file mode 100644 index 000000000..2767f5a41 --- /dev/null +++ b/lib/poll.c @@ -0,0 +1,611 @@ +/* Emulation for poll(2) + Contributed by Paolo Bonzini. + + Copyright 2001-2003, 2006-2013 Free Software Foundation, Inc. + + This file is part of gnulib. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see <http://www.gnu.org/licenses/>. */ + +/* Tell gcc not to warn about the (nfd < 0) tests, below. */ +#if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ +# pragma GCC diagnostic ignored "-Wtype-limits" +#endif + +#include <config.h> +#include <alloca.h> + +#include <sys/types.h> + +/* Specification. */ +#include <poll.h> + +#include <errno.h> +#include <limits.h> +#include <assert.h> + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +# define WINDOWS_NATIVE +# include <winsock2.h> +# include <windows.h> +# include <io.h> +# include <stdio.h> +# include <conio.h> +# include "msvc-nothrow.h" +#else +# include <sys/time.h> +# include <sys/socket.h> +# include <sys/select.h> +# include <unistd.h> +#endif + +#ifdef HAVE_SYS_IOCTL_H +# include <sys/ioctl.h> +#endif +#ifdef HAVE_SYS_FILIO_H +# include <sys/filio.h> +#endif + +#include <time.h> + +#ifndef INFTIM +# define INFTIM (-1) +#endif + +/* BeOS does not have MSG_PEEK. */ +#ifndef MSG_PEEK +# define MSG_PEEK 0 +#endif + +#ifdef WINDOWS_NATIVE + +/* Optimized test whether a HANDLE refers to a console. + See <http://lists.gnu.org/archive/html/bug-gnulib/2009-08/msg00065.html>. */ +#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) + +static BOOL +IsSocketHandle (HANDLE h) +{ + WSANETWORKEVENTS ev; + + if (IsConsoleHandle (h)) + return FALSE; + + /* Under Wine, it seems that getsockopt returns 0 for pipes too. + WSAEnumNetworkEvents instead distinguishes the two correctly. */ + ev.lNetworkEvents = 0xDEADBEEF; + WSAEnumNetworkEvents ((SOCKET) h, NULL, &ev); + return ev.lNetworkEvents != 0xDEADBEEF; +} + +/* Declare data structures for ntdll functions. */ +typedef struct _FILE_PIPE_LOCAL_INFORMATION { + ULONG NamedPipeType; + ULONG NamedPipeConfiguration; + ULONG MaximumInstances; + ULONG CurrentInstances; + ULONG InboundQuota; + ULONG ReadDataAvailable; + ULONG OutboundQuota; + ULONG WriteQuotaAvailable; + ULONG NamedPipeState; + ULONG NamedPipeEnd; +} FILE_PIPE_LOCAL_INFORMATION, *PFILE_PIPE_LOCAL_INFORMATION; + +typedef struct _IO_STATUS_BLOCK +{ + union { + DWORD Status; + PVOID Pointer; + } u; + ULONG_PTR Information; +} IO_STATUS_BLOCK, *PIO_STATUS_BLOCK; + +typedef enum _FILE_INFORMATION_CLASS { + FilePipeLocalInformation = 24 +} FILE_INFORMATION_CLASS, *PFILE_INFORMATION_CLASS; + +typedef DWORD (WINAPI *PNtQueryInformationFile) + (HANDLE, IO_STATUS_BLOCK *, VOID *, ULONG, FILE_INFORMATION_CLASS); + +# ifndef PIPE_BUF +# define PIPE_BUF 512 +# endif + +/* Compute revents values for file handle H. If some events cannot happen + for the handle, eliminate them from *P_SOUGHT. */ + +static int +windows_compute_revents (HANDLE h, int *p_sought) +{ + int i, ret, happened; + INPUT_RECORD *irbuffer; + DWORD avail, nbuffer; + BOOL bRet; + IO_STATUS_BLOCK iosb; + FILE_PIPE_LOCAL_INFORMATION fpli; + static PNtQueryInformationFile NtQueryInformationFile; + static BOOL once_only; + + switch (GetFileType (h)) + { + case FILE_TYPE_PIPE: + if (!once_only) + { + NtQueryInformationFile = (PNtQueryInformationFile) + GetProcAddress (GetModuleHandle ("ntdll.dll"), + "NtQueryInformationFile"); + once_only = TRUE; + } + + happened = 0; + if (PeekNamedPipe (h, NULL, 0, NULL, &avail, NULL) != 0) + { + if (avail) + happened |= *p_sought & (POLLIN | POLLRDNORM); + } + else if (GetLastError () == ERROR_BROKEN_PIPE) + happened |= POLLHUP; + + else + { + /* It was the write-end of the pipe. Check if it is writable. + If NtQueryInformationFile fails, optimistically assume the pipe is + writable. This could happen on Windows 9x, where + NtQueryInformationFile is not available, or if we inherit a pipe + that doesn't permit FILE_READ_ATTRIBUTES access on the write end + (I think this should not happen since Windows XP SP2; WINE seems + fine too). Otherwise, ensure that enough space is available for + atomic writes. */ + memset (&iosb, 0, sizeof (iosb)); + memset (&fpli, 0, sizeof (fpli)); + + if (!NtQueryInformationFile + || NtQueryInformationFile (h, &iosb, &fpli, sizeof (fpli), + FilePipeLocalInformation) + || fpli.WriteQuotaAvailable >= PIPE_BUF + || (fpli.OutboundQuota < PIPE_BUF && + fpli.WriteQuotaAvailable == fpli.OutboundQuota)) + happened |= *p_sought & (POLLOUT | POLLWRNORM | POLLWRBAND); + } + return happened; + + case FILE_TYPE_CHAR: + ret = WaitForSingleObject (h, 0); + if (!IsConsoleHandle (h)) + return ret == WAIT_OBJECT_0 ? *p_sought & ~(POLLPRI | POLLRDBAND) : 0; + + nbuffer = avail = 0; + bRet = GetNumberOfConsoleInputEvents (h, &nbuffer); + if (bRet) + { + /* Input buffer. */ + *p_sought &= POLLIN | POLLRDNORM; + if (nbuffer == 0) + return POLLHUP; + if (!*p_sought) + return 0; + + irbuffer = (INPUT_RECORD *) alloca (nbuffer * sizeof (INPUT_RECORD)); + bRet = PeekConsoleInput (h, irbuffer, nbuffer, &avail); + if (!bRet || avail == 0) + return POLLHUP; + + for (i = 0; i < avail; i++) + if (irbuffer[i].EventType == KEY_EVENT) + return *p_sought; + return 0; + } + else + { + /* Screen buffer. */ + *p_sought &= POLLOUT | POLLWRNORM | POLLWRBAND; + return *p_sought; + } + + default: + ret = WaitForSingleObject (h, 0); + if (ret == WAIT_OBJECT_0) + return *p_sought & ~(POLLPRI | POLLRDBAND); + + return *p_sought & (POLLOUT | POLLWRNORM | POLLWRBAND); + } +} + +/* Convert fd_sets returned by select into revents values. */ + +static int +windows_compute_revents_socket (SOCKET h, int sought, long lNetworkEvents) +{ + int happened = 0; + + if ((lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) == FD_ACCEPT) + happened |= (POLLIN | POLLRDNORM) & sought; + + else if (lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) + { + int r, error; + + char data[64]; + WSASetLastError (0); + r = recv (h, data, sizeof (data), MSG_PEEK); + error = WSAGetLastError (); + WSASetLastError (0); + + if (r > 0 || error == WSAENOTCONN) + happened |= (POLLIN | POLLRDNORM) & sought; + + /* Distinguish hung-up sockets from other errors. */ + else if (r == 0 || error == WSAESHUTDOWN || error == WSAECONNRESET + || error == WSAECONNABORTED || error == WSAENETRESET) + happened |= POLLHUP; + + else + happened |= POLLERR; + } + + if (lNetworkEvents & (FD_WRITE | FD_CONNECT)) + happened |= (POLLOUT | POLLWRNORM | POLLWRBAND) & sought; + + if (lNetworkEvents & FD_OOB) + happened |= (POLLPRI | POLLRDBAND) & sought; + + return happened; +} + +#else /* !MinGW */ + +/* Convert select(2) returned fd_sets into poll(2) revents values. */ +static int +compute_revents (int fd, int sought, fd_set *rfds, fd_set *wfds, fd_set *efds) +{ + int happened = 0; + if (FD_ISSET (fd, rfds)) + { + int r; + int socket_errno; + +# if defined __MACH__ && defined __APPLE__ + /* There is a bug in Mac OS X that causes it to ignore MSG_PEEK + for some kinds of descriptors. Detect if this descriptor is a + connected socket, a server socket, or something else using a + 0-byte recv, and use ioctl(2) to detect POLLHUP. */ + r = recv (fd, NULL, 0, MSG_PEEK); + socket_errno = (r < 0) ? errno : 0; + if (r == 0 || socket_errno == ENOTSOCK) + ioctl (fd, FIONREAD, &r); +# else + char data[64]; + r = recv (fd, data, sizeof (data), MSG_PEEK); + socket_errno = (r < 0) ? errno : 0; +# endif + if (r == 0) + happened |= POLLHUP; + + /* If the event happened on an unconnected server socket, + that's fine. */ + else if (r > 0 || ( /* (r == -1) && */ socket_errno == ENOTCONN)) + happened |= (POLLIN | POLLRDNORM) & sought; + + /* Distinguish hung-up sockets from other errors. */ + else if (socket_errno == ESHUTDOWN || socket_errno == ECONNRESET + || socket_errno == ECONNABORTED || socket_errno == ENETRESET) + happened |= POLLHUP; + + /* some systems can't use recv() on non-socket, including HP NonStop */ + else if (socket_errno == ENOTSOCK) + happened |= (POLLIN | POLLRDNORM) & sought; + + else + happened |= POLLERR; + } + + if (FD_ISSET (fd, wfds)) + happened |= (POLLOUT | POLLWRNORM | POLLWRBAND) & sought; + + if (FD_ISSET (fd, efds)) + happened |= (POLLPRI | POLLRDBAND) & sought; + + return happened; +} +#endif /* !MinGW */ + +int +poll (struct pollfd *pfd, nfds_t nfd, int timeout) +{ +#ifndef WINDOWS_NATIVE + fd_set rfds, wfds, efds; + struct timeval tv; + struct timeval *ptv; + int maxfd, rc; + nfds_t i; + +# ifdef _SC_OPEN_MAX + static int sc_open_max = -1; + + if (nfd < 0 + || (nfd > sc_open_max + && (sc_open_max != -1 + || nfd > (sc_open_max = sysconf (_SC_OPEN_MAX))))) + { + errno = EINVAL; + return -1; + } +# else /* !_SC_OPEN_MAX */ +# ifdef OPEN_MAX + if (nfd < 0 || nfd > OPEN_MAX) + { + errno = EINVAL; + return -1; + } +# endif /* OPEN_MAX -- else, no check is needed */ +# endif /* !_SC_OPEN_MAX */ + + /* EFAULT is not necessary to implement, but let's do it in the + simplest case. */ + if (!pfd && nfd) + { + errno = EFAULT; + return -1; + } + + /* convert timeout number into a timeval structure */ + if (timeout == 0) + { + ptv = &tv; + ptv->tv_sec = 0; + ptv->tv_usec = 0; + } + else if (timeout > 0) + { + ptv = &tv; + ptv->tv_sec = timeout / 1000; + ptv->tv_usec = (timeout % 1000) * 1000; + } + else if (timeout == INFTIM) + /* wait forever */ + ptv = NULL; + else + { + errno = EINVAL; + return -1; + } + + /* create fd sets and determine max fd */ + maxfd = -1; + FD_ZERO (&rfds); + FD_ZERO (&wfds); + FD_ZERO (&efds); + for (i = 0; i < nfd; i++) + { + if (pfd[i].fd < 0) + continue; + + if (pfd[i].events & (POLLIN | POLLRDNORM)) + FD_SET (pfd[i].fd, &rfds); + + /* see select(2): "the only exceptional condition detectable + is out-of-band data received on a socket", hence we push + POLLWRBAND events onto wfds instead of efds. */ + if (pfd[i].events & (POLLOUT | POLLWRNORM | POLLWRBAND)) + FD_SET (pfd[i].fd, &wfds); + if (pfd[i].events & (POLLPRI | POLLRDBAND)) + FD_SET (pfd[i].fd, &efds); + if (pfd[i].fd >= maxfd + && (pfd[i].events & (POLLIN | POLLOUT | POLLPRI + | POLLRDNORM | POLLRDBAND + | POLLWRNORM | POLLWRBAND))) + { + maxfd = pfd[i].fd; + if (maxfd > FD_SETSIZE) + { + errno = EOVERFLOW; + return -1; + } + } + } + + /* examine fd sets */ + rc = select (maxfd + 1, &rfds, &wfds, &efds, ptv); + if (rc < 0) + return rc; + + /* establish results */ + rc = 0; + for (i = 0; i < nfd; i++) + if (pfd[i].fd < 0) + pfd[i].revents = 0; + else + { + int happened = compute_revents (pfd[i].fd, pfd[i].events, + &rfds, &wfds, &efds); + if (happened) + { + pfd[i].revents = happened; + rc++; + } + } + + return rc; +#else + static struct timeval tv0; + static HANDLE hEvent; + WSANETWORKEVENTS ev; + HANDLE h, handle_array[FD_SETSIZE + 2]; + DWORD ret, wait_timeout, nhandles; + fd_set rfds, wfds, xfds; + BOOL poll_again; + MSG msg; + int rc = 0; + nfds_t i; + + if (nfd < 0 || timeout < -1) + { + errno = EINVAL; + return -1; + } + + if (!hEvent) + hEvent = CreateEvent (NULL, FALSE, FALSE, NULL); + +restart: + handle_array[0] = hEvent; + nhandles = 1; + FD_ZERO (&rfds); + FD_ZERO (&wfds); + FD_ZERO (&xfds); + + /* Classify socket handles and create fd sets. */ + for (i = 0; i < nfd; i++) + { + int sought = pfd[i].events; + pfd[i].revents = 0; + if (pfd[i].fd < 0) + continue; + if (!(sought & (POLLIN | POLLRDNORM | POLLOUT | POLLWRNORM | POLLWRBAND + | POLLPRI | POLLRDBAND))) + continue; + + h = (HANDLE) _get_osfhandle (pfd[i].fd); + assert (h != NULL); + if (IsSocketHandle (h)) + { + int requested = FD_CLOSE; + + /* see above; socket handles are mapped onto select. */ + if (sought & (POLLIN | POLLRDNORM)) + { + requested |= FD_READ | FD_ACCEPT; + FD_SET ((SOCKET) h, &rfds); + } + if (sought & (POLLOUT | POLLWRNORM | POLLWRBAND)) + { + requested |= FD_WRITE | FD_CONNECT; + FD_SET ((SOCKET) h, &wfds); + } + if (sought & (POLLPRI | POLLRDBAND)) + { + requested |= FD_OOB; + FD_SET ((SOCKET) h, &xfds); + } + + if (requested) + WSAEventSelect ((SOCKET) h, hEvent, requested); + } + else + { + /* Poll now. If we get an event, do not poll again. Also, + screen buffer handles are waitable, and they'll block until + a character is available. windows_compute_revents eliminates + bits for the "wrong" direction. */ + pfd[i].revents = windows_compute_revents (h, &sought); + if (sought) + handle_array[nhandles++] = h; + if (pfd[i].revents) + timeout = 0; + } + } + + if (select (0, &rfds, &wfds, &xfds, &tv0) > 0) + { + /* Do MsgWaitForMultipleObjects anyway to dispatch messages, but + no need to call select again. */ + poll_again = FALSE; + wait_timeout = 0; + } + else + { + poll_again = TRUE; + if (timeout == INFTIM) + wait_timeout = INFINITE; + else + wait_timeout = timeout; + } + + for (;;) + { + ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE, + wait_timeout, QS_ALLINPUT); + + if (ret == WAIT_OBJECT_0 + nhandles) + { + /* new input of some other kind */ + BOOL bRet; + while ((bRet = PeekMessage (&msg, NULL, 0, 0, PM_REMOVE)) != 0) + { + TranslateMessage (&msg); + DispatchMessage (&msg); + } + } + else + break; + } + + if (poll_again) + select (0, &rfds, &wfds, &xfds, &tv0); + + /* Place a sentinel at the end of the array. */ + handle_array[nhandles] = NULL; + nhandles = 1; + for (i = 0; i < nfd; i++) + { + int happened; + + if (pfd[i].fd < 0) + continue; + if (!(pfd[i].events & (POLLIN | POLLRDNORM | + POLLOUT | POLLWRNORM | POLLWRBAND))) + continue; + + h = (HANDLE) _get_osfhandle (pfd[i].fd); + if (h != handle_array[nhandles]) + { + /* It's a socket. */ + WSAEnumNetworkEvents ((SOCKET) h, NULL, &ev); + WSAEventSelect ((SOCKET) h, 0, 0); + + /* If we're lucky, WSAEnumNetworkEvents already provided a way + to distinguish FD_READ and FD_ACCEPT; this saves a recv later. */ + if (FD_ISSET ((SOCKET) h, &rfds) + && !(ev.lNetworkEvents & (FD_READ | FD_ACCEPT))) + ev.lNetworkEvents |= FD_READ | FD_ACCEPT; + if (FD_ISSET ((SOCKET) h, &wfds)) + ev.lNetworkEvents |= FD_WRITE | FD_CONNECT; + if (FD_ISSET ((SOCKET) h, &xfds)) + ev.lNetworkEvents |= FD_OOB; + + happened = windows_compute_revents_socket ((SOCKET) h, pfd[i].events, + ev.lNetworkEvents); + } + else + { + /* Not a socket. */ + int sought = pfd[i].events; + happened = windows_compute_revents (h, &sought); + nhandles++; + } + + if ((pfd[i].revents |= happened) != 0) + rc++; + } + + if (!rc && timeout == INFTIM) + { + SleepEx (1, TRUE); + goto restart; + } + + return rc; +#endif +} diff --git a/lib/poll.in.h b/lib/poll.in.h new file mode 100644 index 000000000..3c0b48f0d --- /dev/null +++ b/lib/poll.in.h @@ -0,0 +1,103 @@ +/* Header for poll(2) emulation + Contributed by Paolo Bonzini. + + Copyright 2001-2003, 2007, 2009-2013 Free Software Foundation, Inc. + + This file is part of gnulib. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see <http://www.gnu.org/licenses/>. */ + +#ifndef _@GUARD_PREFIX@_POLL_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif +@PRAGMA_COLUMNS@ + +/* The include_next requires a split double-inclusion guard. */ +#if @HAVE_POLL_H@ +# @INCLUDE_NEXT@ @NEXT_POLL_H@ +#endif + +#ifndef _@GUARD_PREFIX@_POLL_H +#define _@GUARD_PREFIX@_POLL_H + + +/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ + +/* The definition of _GL_WARN_ON_USE is copied here. */ + + +#if !@HAVE_POLL_H@ + +/* fake a poll(2) environment */ +# define POLLIN 0x0001 /* any readable data available */ +# define POLLPRI 0x0002 /* OOB/Urgent readable data */ +# define POLLOUT 0x0004 /* file descriptor is writable */ +# define POLLERR 0x0008 /* some poll error occurred */ +# define POLLHUP 0x0010 /* file descriptor was "hung up" */ +# define POLLNVAL 0x0020 /* requested events "invalid" */ +# define POLLRDNORM 0x0040 +# define POLLRDBAND 0x0080 +# define POLLWRNORM 0x0100 +# define POLLWRBAND 0x0200 + +# if !GNULIB_defined_poll_types + +struct pollfd +{ + int fd; /* which file descriptor to poll */ + short events; /* events we are interested in */ + short revents; /* events found on return */ +}; + +typedef unsigned long nfds_t; + +# define GNULIB_defined_poll_types 1 +# endif + +/* Define INFTIM only if doing so conforms to POSIX. */ +# if !defined (_POSIX_C_SOURCE) && !defined (_XOPEN_SOURCE) +# define INFTIM (-1) +# endif + +#endif + + +#if @GNULIB_POLL@ +# if @REPLACE_POLL@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef poll +# define poll rpl_poll +# endif +_GL_FUNCDECL_RPL (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout)); +_GL_CXXALIAS_RPL (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout)); +# else +# if !@HAVE_POLL@ +_GL_FUNCDECL_SYS (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout)); +# endif +_GL_CXXALIAS_SYS (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout)); +# endif +_GL_CXXALIASWARN (poll); +#elif defined GNULIB_POSIXCHECK +# undef poll +# if HAVE_RAW_DECL_POLL +_GL_WARN_ON_USE (poll, "poll is unportable - " + "use gnulib module poll for portability"); +# endif +#endif + + +#endif /* _@GUARD_PREFIX@_POLL_H */ +#endif /* _@GUARD_PREFIX@_POLL_H */ diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 99ace9aed..02c8bcbea 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat times trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -88,6 +88,7 @@ gl_MODULES([ open pipe-posix pipe2 + poll putenv recv recvfrom diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 0d0aa7b79..55c003a58 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -149,6 +149,8 @@ AC_DEFUN([gl_EARLY], # Code from module pathmax: # Code from module pipe-posix: # Code from module pipe2: + # Code from module poll: + # Code from module poll-h: # Code from module putenv: # Code from module raise: # Code from module read: @@ -559,6 +561,13 @@ AC_SUBST([LTALLOCA]) gl_UNISTD_MODULE_INDICATOR([pipe]) gl_FUNC_PIPE2 gl_UNISTD_MODULE_INDICATOR([pipe2]) + gl_FUNC_POLL + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + AC_LIBOBJ([poll]) + gl_PREREQ_POLL + fi + gl_POLL_MODULE_INDICATOR([poll]) + gl_POLL_H gl_FUNC_PUTENV if test $REPLACE_PUTENV = 1; then AC_LIBOBJ([putenv]) @@ -1009,6 +1018,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/pathmax.h lib/pipe.c lib/pipe2.c + lib/poll.c + lib/poll.in.h lib/printf-args.c lib/printf-args.h lib/printf-parse.c @@ -1200,6 +1211,8 @@ AC_DEFUN([gl_FILE_LIST], [ m4/pathmax.m4 m4/pipe.m4 m4/pipe2.m4 + m4/poll.m4 + m4/poll_h.m4 m4/printf.m4 m4/putenv.m4 m4/raise.m4 diff --git a/m4/poll.m4 b/m4/poll.m4 new file mode 100644 index 000000000..f0f0b80e2 --- /dev/null +++ b/m4/poll.m4 @@ -0,0 +1,103 @@ +# poll.m4 serial 17 +dnl Copyright (c) 2003, 2005-2007, 2009-2013 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_FUNC_POLL], +[ + AC_REQUIRE([gl_POLL_H]) + AC_REQUIRE([gl_SOCKETS]) + if test $ac_cv_header_poll_h = no; then + ac_cv_func_poll=no + gl_cv_func_poll=no + else + AC_CHECK_FUNC([poll], + [# Check whether poll() works on special files (like /dev/null) and + # and ttys (like /dev/tty). On Mac OS X 10.4.0 and AIX 5.3, it doesn't. + AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include <fcntl.h> +#include <poll.h> + int main() + { + int result = 0; + struct pollfd ufd; + /* Try /dev/null for reading. */ + ufd.fd = open ("/dev/null", O_RDONLY); + /* If /dev/null does not exist, it's not Mac OS X nor AIX. */ + if (ufd.fd >= 0) + { + ufd.events = POLLIN; + ufd.revents = 0; + if (!(poll (&ufd, 1, 0) == 1 && ufd.revents == POLLIN)) + result |= 1; + } + /* Try /dev/null for writing. */ + ufd.fd = open ("/dev/null", O_WRONLY); + /* If /dev/null does not exist, it's not Mac OS X nor AIX. */ + if (ufd.fd >= 0) + { + ufd.events = POLLOUT; + ufd.revents = 0; + if (!(poll (&ufd, 1, 0) == 1 && ufd.revents == POLLOUT)) + result |= 2; + } + /* Trying /dev/tty may be too environment dependent. */ + return result; + }]])], + [gl_cv_func_poll=yes], + [gl_cv_func_poll=no], + [# When cross-compiling, assume that poll() works everywhere except on + # Mac OS X or AIX, regardless of its version. + AC_EGREP_CPP([MacOSX], [ +#if (defined(__APPLE__) && defined(__MACH__)) || defined(_AIX) +This is MacOSX or AIX +#endif +], [gl_cv_func_poll=no], [gl_cv_func_poll=yes])])]) + fi + if test $gl_cv_func_poll != yes; then + AC_CHECK_FUNC([poll], [ac_cv_func_poll=yes], [ac_cv_func_poll=no]) + if test $ac_cv_func_poll = no; then + HAVE_POLL=0 + else + REPLACE_POLL=1 + fi + fi + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + : + else + AC_DEFINE([HAVE_POLL], [1], + [Define to 1 if you have the 'poll' function and it works.]) + fi + + dnl Determine the needed libraries. + LIB_POLL="$LIBSOCKET" + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + case "$host_os" in + mingw*) + dnl On the MSVC platform, the function MsgWaitForMultipleObjects + dnl (used in lib/poll.c) requires linking with -luser32. On mingw, + dnl it is implicit. + AC_LINK_IFELSE( + [AC_LANG_SOURCE([[ +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +int +main () +{ + MsgWaitForMultipleObjects (0, NULL, 0, 0, 0); + return 0; +}]])], + [], + [LIB_POLL="$LIB_POLL -luser32"]) + ;; + esac + fi + AC_SUBST([LIB_POLL]) +]) + +# Prerequisites of lib/poll.c. +AC_DEFUN([gl_PREREQ_POLL], +[ + AC_CHECK_HEADERS_ONCE([sys/ioctl.h sys/filio.h]) +]) diff --git a/m4/poll_h.m4 b/m4/poll_h.m4 new file mode 100644 index 000000000..49306746c --- /dev/null +++ b/m4/poll_h.m4 @@ -0,0 +1,47 @@ +# poll_h.m4 serial 2 +dnl Copyright (C) 2010-2013 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 Written by Bruno Haible. + +AC_DEFUN([gl_POLL_H], +[ + dnl Use AC_REQUIRE here, so that the default behavior below is expanded + dnl once only, before all statements that occur in other macros. + AC_REQUIRE([gl_POLL_H_DEFAULTS]) + + AC_CHECK_HEADERS_ONCE([poll.h]) + if test $ac_cv_header_poll_h = yes; then + HAVE_POLL_H=1 + else + HAVE_POLL_H=0 + fi + AC_SUBST([HAVE_POLL_H]) + + dnl <poll.h> is always overridden, because of GNULIB_POSIXCHECK. + gl_CHECK_NEXT_HEADERS([poll.h]) + + dnl Check for declarations of anything we want to poison if the + dnl corresponding gnulib module is not in use. + gl_WARN_ON_USE_PREPARE([[#include <poll.h>]], + [poll]) +]) + +AC_DEFUN([gl_POLL_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_POLL_H_DEFAULTS]) + gl_MODULE_INDICATOR_SET_VARIABLE([$1]) + dnl Define it also as a C macro, for the benefit of the unit tests. + gl_MODULE_INDICATOR_FOR_TESTS([$1]) +]) + +AC_DEFUN([gl_POLL_H_DEFAULTS], +[ + GNULIB_POLL=0; AC_SUBST([GNULIB_POLL]) + dnl Assume proper GNU behavior unless another module says otherwise. + HAVE_POLL=1; AC_SUBST([HAVE_POLL]) + REPLACE_POLL=0; AC_SUBST([REPLACE_POLL]) +]) From b5870f25ad70dc70df99f69ff2652d73ec07343c Mon Sep 17 00:00:00 2001 From: Jason Earl <jearl@notengoamigos.org> Date: Sun, 10 Mar 2013 23:44:23 +0100 Subject: [PATCH 088/147] rely on gnulib for `poll' * configure.ac: * libguile/fports.c (fport_input_waiting): * libguile/poll.c (scm_primitive_poll): Rely on gnulib to provide poll for us. --- configure.ac | 7 ++----- libguile/fports.c | 32 -------------------------------- libguile/poll.c | 13 ++----------- 3 files changed, 4 insertions(+), 48 deletions(-) diff --git a/configure.ac b/configure.ac index b44159870..af6afcc77 100644 --- a/configure.ac +++ b/configure.ac @@ -652,7 +652,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h memory.h process.h strin sys/dir.h sys/ioctl.h sys/select.h \ sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \ sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \ -direct.h machine/fpu.h poll.h sched.h]) +direct.h machine/fpu.h sched.h]) # "complex double" is new in C99, and "complex" is only a keyword if # <complex.h> is included @@ -674,8 +674,6 @@ AC_CHECK_TYPE(socklen_t, , AC_CHECK_TYPES([struct ip_mreq], , , [#include <netinet/in.h>]) -AC_CHECK_TYPES([struct pollfd], , , [#include <poll.h>]) - GUILE_HEADER_LIBC_WITH_UNISTD AC_TYPE_GETGROUPS @@ -737,7 +735,6 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # gmtime_r - recent posix, not on old systems # pipe - not in mingw # _pipe - specific to mingw, taking 3 args -# poll - since posix 2001 # readdir_r - recent posix, not on old systems # readdir64_r - not available on HP-UX 11.11 # stat64 - SuS largefile stuff, not on old systems @@ -750,7 +747,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # 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]) +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 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"]) diff --git a/libguile/fports.c b/libguile/fports.c index e0b99b520..f6c3c92ca 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -41,9 +41,7 @@ #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE #include <sys/stat.h> #endif -#ifdef HAVE_POLL_H #include <poll.h> -#endif #include <errno.h> #include <sys/types.h> #include <sys/stat.h> @@ -546,42 +544,12 @@ fport_input_waiting (SCM port) { int fdes = SCM_FSTREAM (port)->fdes; - /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the - highest numerical value of file descriptors that can be monitored. - Thus, use poll(2) whenever that is possible. */ - -#if defined(HAVE_POLL) && defined(HAVE_STRUCT_POLLFD) struct pollfd pollfd = { fdes, POLLIN, 0 }; if (poll (&pollfd, 1, 0) < 0) scm_syserror ("fport_input_waiting"); return pollfd.revents & POLLIN ? 1 : 0; - -#else - struct timeval timeout; - fd_set read_set; - fd_set write_set; - fd_set except_set; - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - if (fdes < FD_SETSIZE) - FD_SET (fdes, &read_set); - else - scm_out_of_range ("fport_input_waiting", scm_from_int (fdes)); - - timeout.tv_sec = 0; - timeout.tv_usec = 0; - - if (select (fdes + 1, - &read_set, &write_set, &except_set, &timeout) - < 0) - scm_syserror ("fport_input_waiting"); - return FD_ISSET (fdes, &read_set) ? 1 : 0; -#endif } diff --git a/libguile/poll.c b/libguile/poll.c index 5bfd97b05..9ea846b6d 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -25,6 +25,8 @@ # include <config.h> #endif +#include <poll.h> + #include "libguile/_scm.h" #include "libguile/bytevectors.h" #include "libguile/numbers.h" @@ -33,11 +35,6 @@ #include "libguile/poll.h" - -#ifdef HAVE_POLL_H -#include <poll.h> -#endif - /* {Poll} @@ -73,7 +70,6 @@ If timeout is given and is non-negative, the poll will return after that number of milliseconds if no fd became active. */ -#if defined(HAVE_POLL) && defined(HAVE_STRUCT_POLLFD) static SCM scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) #define FUNC_NAME "primitive-poll" @@ -174,7 +170,6 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) return scm_from_int (rv); } #undef FUNC_NAME -#endif /* HAVE_POLL && HAVE_STRUCT_POLLFD */ @@ -182,12 +177,8 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) static void scm_init_poll (void) { -#if defined(HAVE_POLL) && defined(HAVE_STRUCT_POLLFD) scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_poll); scm_c_define ("%sizeof-struct-pollfd", scm_from_size_t (sizeof (struct pollfd))); -#else - scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL); -#endif #ifdef POLLIN scm_c_define ("POLLIN", scm_from_int (POLLIN)); From d2df3950a905f7acab70633717beddfd90455b68 Mon Sep 17 00:00:00 2001 From: Mike Gran <spk121@yahoo.com> Date: Sun, 10 Mar 2013 19:43:38 -0700 Subject: [PATCH 089/147] Add standalone test for smob marking * test-suite/standalone/Makefile.am (TESTS, check_PROGRAMS): add test-smob-mark (test_smob_mark_SOURCES, test_smob_mark_CFLAGS, test_smob_mark_LDADD): new variables * test-suite/standalone/test-smob-mark.c: new file --- test-suite/standalone/Makefile.am | 6 ++ test-suite/standalone/test-smob-mark.c | 133 +++++++++++++++++++++++++ 2 files changed, 139 insertions(+) create mode 100644 test-suite/standalone/test-smob-mark.c diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 4b1c8227c..ffeafa808 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -251,4 +251,10 @@ EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c endif +test_smob_mark_SOURCES = test-smob-mark.c +test_smob_mark_CFLAGS = ${test_cflags} +test_smob_mark_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-smob-mark +TESTS += test-smob-mark + EXTRA_DIST += ${check_SCRIPTS} diff --git a/test-suite/standalone/test-smob-mark.c b/test-suite/standalone/test-smob-mark.c new file mode 100644 index 000000000..d9db9a651 --- /dev/null +++ b/test-suite/standalone/test-smob-mark.c @@ -0,0 +1,133 @@ +/* Copyright (C) 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#if HAVE_CONFIG_H +#include <config.h> +#endif + +#include <assert.h> +#include <libguile.h> +#include <stdio.h> +#include <stdlib.h> + +#define SMOBS_COUNT (10000) + +struct x_tag +{ + SCM scm_value; + int c_value; +}; + +typedef struct x_tag x_t; + +unsigned int mark_call_count = 0; + +static scm_t_bits x_tag; +static SCM make_x (void); +static SCM mark_x (SCM x); +static int print_x (SCM x, SCM port, scm_print_state * pstate); +static size_t free_x (SCM x); +static void init_smob_type (void); +static void test_scm_smob_mark (void); + +static SCM +make_x () +{ + static int i = 0; + SCM s_x; + x_t *c_x; + + i++; + c_x = (x_t *) scm_gc_malloc (sizeof (x_t), "x"); + c_x->scm_value = scm_from_int (i); + c_x->c_value = i; + SCM_NEWSMOB (s_x, x_tag, c_x); + return s_x; +} + +static SCM +mark_x (SCM x) +{ + x_t *c_x; + c_x = (x_t *) SCM_SMOB_DATA (x); + scm_gc_mark (c_x->scm_value); + mark_call_count++; + return SCM_BOOL_F; +} + +static size_t +free_x (SCM x) +{ + x_t *c_x; + c_x = (x_t *) SCM_SMOB_DATA (x); + scm_gc_free (c_x, sizeof (x_t), "x"); + c_x = NULL; + return 0; +} + +static int +print_x (SCM x, SCM port, scm_print_state * pstate SCM_UNUSED) +{ + x_t *c_x = (x_t *) SCM_SMOB_DATA (x); + scm_puts ("#<x ", port); + if (c_x == (x_t *) NULL) + scm_puts ("(freed)", port); + else + scm_write (c_x->scm_value, port); + scm_puts (">", port); + + return 1; +} + +static void +test_scm_smob_mark () +{ + int i; + mark_call_count = 0; + for (i = 0; i < SMOBS_COUNT; i++) + make_x (); + scm_gc (); + if (mark_call_count < SMOBS_COUNT) + { + fprintf (stderr, "FAIL: SMOB mark function called for each SMOB\n"); + exit (EXIT_FAILURE); + } +} + +static void +init_smob_type () +{ + x_tag = scm_make_smob_type ("x", sizeof (x_t)); + scm_set_smob_free (x_tag, free_x); + scm_set_smob_print (x_tag, print_x); + scm_set_smob_mark (x_tag, mark_x); +} + +static void +tests (void *data, int argc, char **argv) +{ + init_smob_type (); + test_scm_smob_mark (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} From a285b18ca820e089e2e5d02f8ed07a1e341dffc3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sun, 3 Mar 2013 04:34:50 -0500 Subject: [PATCH 090/147] Optimize and simplify fractions code. * libguile/numbers.c (scm_exact_integer_quotient, scm_i_make_ratio_already_reduced): New static functions. (scm_i_make_ratio): Rewrite in terms of 'scm_i_make_ratio_already_reduced'. (scm_integer_expt): Optimize fraction case. (scm_abs, scm_magnitude, scm_difference, do_divide): Use 'scm_i_make_ratio_already_reduced'. * test-suite/tests/numbers.test (expt, integer-expt): Add tests. --- libguile/numbers.c | 248 +++++++++++++++++++++------------- test-suite/tests/numbers.test | 6 + 2 files changed, 161 insertions(+), 93 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index bb1ecf5ed..2b64a748c 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -442,96 +442,56 @@ scm_i_mpz2num (mpz_t b) /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */ static SCM scm_divide2real (SCM x, SCM y); +/* Make the ratio NUMERATOR/DENOMINATOR, where: + 1. NUMERATOR and DENOMINATOR are exact integers + 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */ +static SCM +scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator) +{ + /* Flip signs so that the denominator is positive. */ + if (scm_is_false (scm_positive_p (denominator))) + { + if (SCM_UNLIKELY (scm_is_eq (denominator, SCM_INUM0))) + scm_num_overflow ("make-ratio"); + else + { + numerator = scm_difference (numerator, SCM_UNDEFINED); + denominator = scm_difference (denominator, SCM_UNDEFINED); + } + } + + /* Check for the integer case */ + if (scm_is_eq (denominator, SCM_INUM1)) + return numerator; + + return scm_double_cell (scm_tc16_fraction, + SCM_UNPACK (numerator), + SCM_UNPACK (denominator), 0); +} + +static SCM scm_exact_integer_quotient (SCM x, SCM y); + +/* Make the ratio NUMERATOR/DENOMINATOR */ static SCM scm_i_make_ratio (SCM numerator, SCM denominator) #define FUNC_NAME "make-ratio" { - /* First make sure the arguments are proper. - */ - if (SCM_I_INUMP (denominator)) - { - if (scm_is_eq (denominator, SCM_INUM0)) - scm_num_overflow ("make-ratio"); - if (scm_is_eq (denominator, SCM_INUM1)) - return numerator; - } - else - { - if (!(SCM_BIGP(denominator))) - SCM_WRONG_TYPE_ARG (2, denominator); - } - if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator)) + /* Make sure the arguments are proper */ + if (!SCM_LIKELY (SCM_I_INUMP (numerator) || SCM_BIGP (numerator))) SCM_WRONG_TYPE_ARG (1, numerator); - - /* Then flip signs so that the denominator is positive. - */ - if (scm_is_true (scm_negative_p (denominator))) + else if (!SCM_LIKELY (SCM_I_INUMP (denominator) || SCM_BIGP (denominator))) + SCM_WRONG_TYPE_ARG (2, denominator); + else { - numerator = scm_difference (numerator, SCM_UNDEFINED); - denominator = scm_difference (denominator, SCM_UNDEFINED); - } - - /* Now consider for each of the four fixnum/bignum combinations - whether the rational number is really an integer. - */ - if (SCM_I_INUMP (numerator)) - { - scm_t_inum x = SCM_I_INUM (numerator); - if (scm_is_eq (numerator, SCM_INUM0)) - return SCM_INUM0; - if (SCM_I_INUMP (denominator)) + SCM the_gcd = scm_gcd (numerator, denominator); + if (!(scm_is_eq (the_gcd, SCM_INUM1))) { - scm_t_inum y; - y = SCM_I_INUM (denominator); - if (x == y) - return SCM_INUM1; - if ((x % y) == 0) - return SCM_I_MAKINUM (x / y); + /* Reduce to lowest terms */ + numerator = scm_exact_integer_quotient (numerator, the_gcd); + denominator = scm_exact_integer_quotient (denominator, the_gcd); } - else - { - /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative - of that value for the denominator, as a bignum. Apart from - that case, abs(bignum) > abs(inum) so inum/bignum is not an - integer. */ - if (x == SCM_MOST_NEGATIVE_FIXNUM - && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator), - - SCM_MOST_NEGATIVE_FIXNUM) == 0) - return SCM_I_MAKINUM(-1); - } + return scm_i_make_ratio_already_reduced (numerator, denominator); } - else if (SCM_BIGP (numerator)) - { - if (SCM_I_INUMP (denominator)) - { - scm_t_inum yy = SCM_I_INUM (denominator); - if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy)) - return scm_divide (numerator, denominator); - } - else - { - if (scm_is_eq (numerator, denominator)) - return SCM_INUM1; - if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), - SCM_I_BIG_MPZ (denominator))) - return scm_divide(numerator, denominator); - } - } - - /* No, it's a proper fraction. - */ - { - SCM divisor = scm_gcd (numerator, denominator); - if (!(scm_is_eq (divisor, SCM_INUM1))) - { - numerator = scm_divide (numerator, divisor); - denominator = scm_divide (denominator, divisor); - } - - return scm_double_cell (scm_tc16_fraction, - SCM_UNPACK (numerator), - SCM_UNPACK (denominator), 0); - } } #undef FUNC_NAME @@ -823,8 +783,9 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, { if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x)))) return x; - return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), - SCM_FRACTION_DENOMINATOR (x)); + return scm_i_make_ratio_already_reduced + (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); } else SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs); @@ -892,6 +853,84 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0, } #undef FUNC_NAME +/* Return the exact integer q such that n = q*d, for exact integers n + and d, where d is known in advance to divide n evenly (with zero + remainder). For large integers, this can be computed more + efficiently than when the remainder is unknown. */ +static SCM +scm_exact_integer_quotient (SCM n, SCM d) +#define FUNC_NAME "exact-integer-quotient" +{ + if (SCM_LIKELY (SCM_I_INUMP (n))) + { + scm_t_inum nn = SCM_I_INUM (n); + if (SCM_LIKELY (SCM_I_INUMP (d))) + { + scm_t_inum dd = SCM_I_INUM (d); + if (SCM_UNLIKELY (dd == 0)) + scm_num_overflow ("exact-integer-quotient"); + else + { + scm_t_inum qq = nn / dd; + if (SCM_LIKELY (SCM_FIXABLE (qq))) + return SCM_I_MAKINUM (qq); + else + return scm_i_inum2big (qq); + } + } + else if (SCM_LIKELY (SCM_BIGP (d))) + { + /* n is an inum and d is a bignum. Given that d is known to + divide n evenly, there are only two possibilities: n is 0, + or else n is fixnum-min and d is abs(fixnum-min). */ + if (nn == 0) + return SCM_INUM0; + else + return SCM_I_MAKINUM (-1); + } + else + SCM_WRONG_TYPE_ARG (2, d); + } + else if (SCM_LIKELY (SCM_BIGP (n))) + { + if (SCM_LIKELY (SCM_I_INUMP (d))) + { + scm_t_inum dd = SCM_I_INUM (d); + if (SCM_UNLIKELY (dd == 0)) + scm_num_overflow ("exact-integer-quotient"); + else if (SCM_UNLIKELY (dd == 1)) + return n; + else + { + SCM q = scm_i_mkbig (); + if (dd > 0) + mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), dd); + else + { + mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), -dd); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + } + scm_remember_upto_here_1 (n); + return scm_i_normbig (q); + } + } + else if (SCM_LIKELY (SCM_BIGP (d))) + { + SCM q = scm_i_mkbig (); + mpz_divexact (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (n), + SCM_I_BIG_MPZ (d)); + scm_remember_upto_here_2 (n, d); + return scm_i_normbig (q); + } + else + SCM_WRONG_TYPE_ARG (2, d); + } + else + SCM_WRONG_TYPE_ARG (1, n); +} +#undef FUNC_NAME + /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for two-valued functions. It is called from primitive generics that take two arguments and return two values, when the core procedure is @@ -4675,6 +4714,26 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, else /* return NaN for (0 ^ k) for negative k per R6RS */ return scm_nan (); } + else if (SCM_FRACTIONP (n)) + { + /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid + needless reduction of intermediate products to lowest terms. + If a and b have no common factors, then a^k and b^k have no + common factors. Use 'scm_i_make_ratio_already_reduced' to + construct the final result, so that no gcd computations are + needed to exponentiate a fraction. */ + if (scm_is_true (scm_positive_p (k))) + return scm_i_make_ratio_already_reduced + (scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k), + scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k)); + else + { + k = scm_difference (k, SCM_UNDEFINED); + return scm_i_make_ratio_already_reduced + (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k), + scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k)); + } + } if (SCM_I_INUMP (k)) i2 = SCM_I_INUM (k); @@ -7354,8 +7413,9 @@ scm_difference (SCM x, SCM y) return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x), -SCM_COMPLEX_IMAG (x)); else if (SCM_FRACTIONP (x)) - return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), - SCM_FRACTION_DENOMINATOR (x)); + return scm_i_make_ratio_already_reduced + (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); else SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); } @@ -7903,14 +7963,14 @@ do_divide (SCM x, SCM y, int inexact) { if (inexact) return scm_from_double (1.0 / (double) xx); - else return scm_i_make_ratio (SCM_INUM1, x); + else return scm_i_make_ratio_already_reduced (SCM_INUM1, x); } } else if (SCM_BIGP (x)) { if (inexact) return scm_from_double (1.0 / scm_i_big2dbl (x)); - else return scm_i_make_ratio (SCM_INUM1, x); + else return scm_i_make_ratio_already_reduced (SCM_INUM1, x); } else if (SCM_REALP (x)) { @@ -7940,8 +8000,8 @@ do_divide (SCM x, SCM y, int inexact) } } else if (SCM_FRACTIONP (x)) - return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x), - SCM_FRACTION_NUMERATOR (x)); + return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_NUMERATOR (x)); else SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); } @@ -8904,8 +8964,9 @@ SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0, { if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) return z; - return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED), - SCM_FRACTION_DENOMINATOR (z)); + return scm_i_make_ratio_already_reduced + (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (z)); } else SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude); @@ -9006,8 +9067,9 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, mpq_init (frac); mpq_set_d (frac, val); - q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)), - scm_i_mpz2num (mpq_denref (frac))); + q = scm_i_make_ratio_already_reduced + (scm_i_mpz2num (mpq_numref (frac)), + scm_i_mpz2num (mpq_denref (frac))); /* When scm_i_make_ratio throws, we leak the memory allocated for frac... diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index be378b724..c4e819db2 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4054,6 +4054,9 @@ (pass-if (eqv? -0.125 (expt -2 -3.0))) (pass-if (eqv? -0.125 (expt -2.0 -3.0))) (pass-if (eqv? 0.25 (expt 2.0 -2.0))) + (pass-if (eqv? 32/243 (expt 2/3 5))) + (pass-if (eqv? 243/32 (expt 2/3 -5))) + (pass-if (eqv? 32 (expt 1/2 -5))) (pass-if (test-eqv? (* -1.0+0.0i 12398 12398) (expt +12398i 2.0))) (pass-if (eqv-loosely? +i (expt -1 0.5))) (pass-if (eqv-loosely? +i (expt -1 1/2))) @@ -4327,6 +4330,9 @@ (pass-if (eqv? -1/8 (integer-expt -2 -3))) (pass-if (eqv? -0.125 (integer-expt -2.0 -3))) (pass-if (eqv? 0.25 (integer-expt 2.0 -2))) + (pass-if (eqv? 32/243 (integer-expt 2/3 5))) + (pass-if (eqv? 243/32 (integer-expt 2/3 -5))) + (pass-if (eqv? 32 (integer-expt 1/2 -5))) (pass-if (test-eqv? (* -1.0+0.0i 12398 12398) (integer-expt +12398.0i 2)))) From e08a12b5356c20ed0418bcaee136eb3632c5616f Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sun, 3 Mar 2013 04:35:09 -0500 Subject: [PATCH 091/147] Add 'round-ash', a rounding arithmetic shift operator * libguile/numbers.c (left_shift_exact_integer, floor_right_shift_exact_integer, round_right_shift_exact_integer): New static functions. (scm_round_ash): New procedure. (scm_ash): Reimplement in terms of 'left_shift_exact_integer' and 'floor_right_shift_exact_integer'. * libguile/numbers.h: Add prototype for scm_round_ash. Rename the second argument of 'scm_ash' from 'cnt' to 'count'. * test-suite/tests/numbers.test (round-ash, ash): Add new unified testing framework for 'ash' and 'round-ash'. Previously, the tests for 'ash' were not very comprehensive; for example, they did not include a single test where the number to be shifted was a bignum. * doc/ref/api-data.texi (Bitwise Operations): Add documentation for 'round-ash'. Improve documentation for `ash'. --- doc/ref/api-data.texi | 42 +++++-- libguile/numbers.c | 228 +++++++++++++++++++++++----------- libguile/numbers.h | 3 +- test-suite/tests/numbers.test | 114 ++++++++--------- 4 files changed, 234 insertions(+), 153 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index fb12d2ccf..81c6d5b70 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1686,19 +1686,15 @@ starts from 0 for the least significant bit. @end lisp @end deffn -@deffn {Scheme Procedure} ash n cnt -@deffnx {C Function} scm_ash (n, cnt) -Return @var{n} shifted left by @var{cnt} bits, or shifted right if -@var{cnt} is negative. This is an ``arithmetic'' shift. +@deffn {Scheme Procedure} ash n count +@deffnx {C Function} scm_ash (n, count) +Return @math{floor(@var{n} * 2^@var{count})}. +@var{n} and @var{count} must be exact integers. -This is effectively a multiplication by @m{2^{cnt}, 2^@var{cnt}}, and -when @var{cnt} is negative it's a division, rounded towards negative -infinity. (Note that this is not the same rounding as @code{quotient} -does.) - -With @var{n} viewed as an infinite precision twos complement, -@code{ash} means a left shift introducing zero bits, or a right shift -dropping bits. +With @var{n} viewed as an infinite-precision twos-complement +integer, @code{ash} means a left shift introducing zero bits +when @var{count} is positive, or a right shift dropping bits +when @var{count} is negative. This is an ``arithmetic'' shift. @lisp (number->string (ash #b1 3) 2) @result{} "1000" @@ -1709,6 +1705,28 @@ dropping bits. @end lisp @end deffn +@deffn {Scheme Procedure} round-ash n count +@deffnx {C Function} scm_round_ash (n, count) +Return @math{round(@var{n} * 2^@var{count})}. +@var{n} and @var{count} must be exact integers. + +With @var{n} viewed as an infinite-precision twos-complement +integer, @code{round-ash} means a left shift introducing zero +bits when @var{count} is positive, or a right shift rounding +to the nearest integer (with ties going to the nearest even +integer) when @var{count} is negative. This is a rounded +``arithmetic'' shift. + +@lisp +(number->string (round-ash #b1 3) 2) @result{} \"1000\" +(number->string (round-ash #b1010 -1) 2) @result{} \"101\" +(number->string (round-ash #b1010 -2) 2) @result{} \"10\" +(number->string (round-ash #b1011 -2) 2) @result{} \"11\" +(number->string (round-ash #b1101 -2) 2) @result{} \"11\" +(number->string (round-ash #b1110 -2) 2) @result{} \"100\" +@end lisp +@end deffn + @deffn {Scheme Procedure} logcount n @deffnx {C Function} scm_logcount (n) Return the number of bits in integer @var{n}. If @var{n} is diff --git a/libguile/numbers.c b/libguile/numbers.c index 2b64a748c..3f2afdebb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4791,19 +4791,119 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, } #undef FUNC_NAME +/* Efficiently compute (N * 2^COUNT), + where N is an exact integer, and COUNT > 0. */ +static SCM +left_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always + overflow a non-zero fixnum. For smaller shifts we check the + bits going into positions above SCM_I_FIXNUM_BIT-1. If they're + all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. + Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */ + + if (nn == 0) + return n; + else if (count < SCM_I_FIXNUM_BIT-1 && + ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1) + <= 1)) + return SCM_I_MAKINUM (nn << count); + else + { + SCM result = scm_i_inum2big (nn); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + count); + return result; + } + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), count); + scm_remember_upto_here_1 (n); + return result; + } + else + scm_syserror ("left_shift_exact_integer"); +} + +/* Efficiently compute floor (N / 2^COUNT), + where N is an exact integer and COUNT > 0. */ +static SCM +floor_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + if (count >= SCM_I_FIXNUM_BIT) + return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1)); + else + return SCM_I_MAKINUM (SCM_SRS (nn, count)); + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), + count); + scm_remember_upto_here_1 (n); + return scm_i_normbig (result); + } + else + scm_syserror ("floor_right_shift_exact_integer"); +} + +/* Efficiently compute round (N / 2^COUNT), + where N is an exact integer and COUNT > 0. */ +static SCM +round_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + if (count >= SCM_I_FIXNUM_BIT) + return SCM_INUM0; + else + { + scm_t_inum nn = SCM_I_INUM (n); + scm_t_inum qq = SCM_SRS (nn, count); + + if (0 == (nn & (1L << (count-1)))) + return SCM_I_MAKINUM (qq); /* round down */ + else if (nn & ((1L << (count-1)) - 1)) + return SCM_I_MAKINUM (qq + 1); /* round up */ + else + return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */ + } + } + else if (SCM_BIGP (n)) + { + SCM q = scm_i_mkbig (); + + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count); + if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1) + && (mpz_odd_p (SCM_I_BIG_MPZ (q)) + || (mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1))) + mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1); + scm_remember_upto_here_1 (n); + return scm_i_normbig (q); + } + else + scm_syserror ("round_right_shift_exact_integer"); +} + SCM_DEFINE (scm_ash, "ash", 2, 0, 0, - (SCM n, SCM cnt), - "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n" - "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n" + (SCM n, SCM count), + "Return @math{floor(@var{n} * 2^@var{count})}.\n" + "@var{n} and @var{count} must be exact integers.\n" "\n" - "This is effectively a multiplication by 2^@var{cnt}, and when\n" - "@var{cnt} is negative it's a division, rounded towards negative\n" - "infinity. (Note that this is not the same rounding as\n" - "@code{quotient} does.)\n" - "\n" - "With @var{n} viewed as an infinite precision twos complement,\n" - "@code{ash} means a left shift introducing zero bits, or a right\n" - "shift dropping bits.\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{ash} means a left shift introducing zero bits\n" + "when @var{count} is positive, or a right shift dropping bits\n" + "when @var{count} is negative. This is an ``arithmetic'' shift.\n" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" @@ -4814,79 +4914,57 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_ash { - long bits_to_shift; - bits_to_shift = scm_to_long (cnt); - - if (SCM_I_INUMP (n)) + if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - scm_t_inum nn = SCM_I_INUM (n); + long bits_to_shift = scm_to_long (count); if (bits_to_shift > 0) - { - /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always - overflow a non-zero fixnum. For smaller shifts we check the - bits going into positions above SCM_I_FIXNUM_BIT-1. If they're - all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. - Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - - bits_to_shift)". */ - - if (nn == 0) - return n; - - if (bits_to_shift < SCM_I_FIXNUM_BIT-1 - && ((scm_t_bits) - (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) - <= 1)) - { - return SCM_I_MAKINUM (nn << bits_to_shift); - } - else - { - SCM result = scm_i_inum2big (nn); - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), - bits_to_shift); - return result; - } - } + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return floor_right_shift_exact_integer (n, -bits_to_shift); else - { - bits_to_shift = -bits_to_shift; - if (bits_to_shift >= SCM_LONG_BIT) - return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1)); - else - return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift)); - } - - } - else if (SCM_BIGP (n)) - { - SCM result; - - if (bits_to_shift == 0) return n; - - result = scm_i_mkbig (); - if (bits_to_shift >= 0) - { - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - bits_to_shift); - return result; - } - else - { - /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so - we have to allocate a bignum even if the result is going to be a - fixnum. */ - mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - -bits_to_shift); - return scm_i_normbig (result); - } - } else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0, + (SCM n, SCM count), + "Return @math{round(@var{n} * 2^@var{count})}.\n" + "@var{n} and @var{count} must be exact integers.\n" + "\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{round-ash} means a left shift introducing zero\n" + "bits when @var{count} is positive, or a right shift rounding\n" + "to the nearest integer (with ties going to the nearest even\n" + "integer) when @var{count} is negative. This is a rounded\n" + "``arithmetic'' shift.\n" + "\n" + "@lisp\n" + "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n" + "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n" + "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n" + "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n" + "@end lisp") +#define FUNC_NAME s_scm_round_ash +{ + if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + long bits_to_shift = scm_to_long (count); + + if (bits_to_shift > 0) + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return round_right_shift_exact_integer (n, -bits_to_shift); + else + return n; } + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME diff --git a/libguile/numbers.h b/libguile/numbers.h index 2c8b2602e..912f287bb 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -206,7 +206,8 @@ SCM_API SCM scm_logbit_p (SCM n1, SCM n2); SCM_API SCM scm_lognot (SCM n); SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m); SCM_API SCM scm_integer_expt (SCM z1, SCM z2); -SCM_API SCM scm_ash (SCM n, SCM cnt); +SCM_API SCM scm_ash (SCM n, SCM count); +SCM_API SCM scm_round_ash (SCM n, SCM count); SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end); SCM_API SCM scm_logcount (SCM n); SCM_API SCM scm_integer_length (SCM n); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index c4e819db2..bb1424853 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -200,71 +200,6 @@ (pass-if "1- fixnum = bignum (64-bit)" (eqv? -2305843009213693953 (1- -2305843009213693952)))) -;;; -;;; ash -;;; - -(with-test-prefix "ash" - - (pass-if "documented?" - (documented? ash)) - - (pass-if (eqv? 0 (ash 0 0))) - (pass-if (eqv? 0 (ash 0 1))) - (pass-if (eqv? 0 (ash 0 1000))) - (pass-if (eqv? 0 (ash 0 -1))) - (pass-if (eqv? 0 (ash 0 -1000))) - - (pass-if (eqv? 1 (ash 1 0))) - (pass-if (eqv? 2 (ash 1 1))) - (pass-if (eqv? 340282366920938463463374607431768211456 (ash 1 128))) - (pass-if (eqv? 0 (ash 1 -1))) - (pass-if (eqv? 0 (ash 1 -1000))) - - (pass-if (eqv? -1 (ash -1 0))) - (pass-if (eqv? -2 (ash -1 1))) - (pass-if (eqv? -340282366920938463463374607431768211456 (ash -1 128))) - (pass-if (eqv? -1 (ash -1 -1))) - (pass-if (eqv? -1 (ash -1 -1000))) - - (pass-if (eqv? -3 (ash -3 0))) - (pass-if (eqv? -6 (ash -3 1))) - (pass-if (eqv? -1020847100762815390390123822295304634368 (ash -3 128))) - (pass-if (eqv? -2 (ash -3 -1))) - (pass-if (eqv? -1 (ash -3 -1000))) - - (pass-if (eqv? -6 (ash -23 -2))) - - (pass-if (eqv? most-positive-fixnum (ash most-positive-fixnum 0))) - (pass-if (eqv? (* 2 most-positive-fixnum) (ash most-positive-fixnum 1))) - (pass-if (eqv? (* 4 most-positive-fixnum) (ash most-positive-fixnum 2))) - (pass-if - (eqv? (* most-positive-fixnum 340282366920938463463374607431768211456) - (ash most-positive-fixnum 128))) - (pass-if (eqv? (quotient most-positive-fixnum 2) - (ash most-positive-fixnum -1))) - (pass-if (eqv? 0 (ash most-positive-fixnum -1000))) - - (let ((mpf4 (quotient most-positive-fixnum 4))) - (pass-if (eqv? (* 2 mpf4) (ash mpf4 1))) - (pass-if (eqv? (* 4 mpf4) (ash mpf4 2))) - (pass-if (eqv? (* 8 mpf4) (ash mpf4 3)))) - - (pass-if (eqv? most-negative-fixnum (ash most-negative-fixnum 0))) - (pass-if (eqv? (* 2 most-negative-fixnum) (ash most-negative-fixnum 1))) - (pass-if (eqv? (* 4 most-negative-fixnum) (ash most-negative-fixnum 2))) - (pass-if - (eqv? (* most-negative-fixnum 340282366920938463463374607431768211456) - (ash most-negative-fixnum 128))) - (pass-if (eqv? (quotient-floor most-negative-fixnum 2) - (ash most-negative-fixnum -1))) - (pass-if (eqv? -1 (ash most-negative-fixnum -1000))) - - (let ((mnf4 (quotient-floor most-negative-fixnum 4))) - (pass-if (eqv? (* 2 mnf4) (ash mnf4 1))) - (pass-if (eqv? (* 4 mnf4) (ash mnf4 2))) - (pass-if (eqv? (* 8 mnf4) (ash mnf4 3))))) - ;;; ;;; exact? ;;; @@ -4914,3 +4849,52 @@ round-quotient round-remainder valid-round-answer?))) + +;;; +;;; ash +;;; round-ash +;;; + +(let () + (define (test-ash-variant name ash-variant round-variant) + (with-test-prefix name + (define (test n count) + (pass-if (list n count) + (eqv? (ash-variant n count) + (round-variant (* n (expt 2 count)))))) + + (pass-if "documented?" + (documented? ash-variant)) + + (for-each (lambda (n) + (for-each (lambda (count) (test n count)) + '(-1000 -3 -2 -1 0 1 2 3 1000))) + (list 0 1 3 23 -1 -3 -23 + fixnum-max + (1+ fixnum-max) + (1- fixnum-max) + (* fixnum-max 4) + (quotient fixnum-max 4) + fixnum-min + (1+ fixnum-min) + (1- fixnum-min) + (* fixnum-min 4) + (quotient fixnum-min 4))) + + (do ((count -2 (1- count)) + (vals '(1 3 5 7 9 11) + (map (lambda (n) (* 2 n)) vals))) + ((> (car vals) (* 2 fixnum-max)) 'done) + (for-each (lambda (n) + (test n count) + (test (- n) count)) + vals)) + + ;; Test rounding + (for-each (lambda (base) + (for-each (lambda (offset) (test (+ base offset) -3)) + '(#b11001 #b11100 #b11101 #b10001 #b10100 #b10101))) + (list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min))))) + + (test-ash-variant 'ash ash floor) + (test-ash-variant 'round-ash round-ash round)) From 1eb6a33a30ea27f97fc401a25a3014e10e3c6f98 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sun, 3 Mar 2013 04:58:55 -0500 Subject: [PATCH 092/147] Simplify and improve scm_i_big2dbl, and add scm_i_big2dbl_2exp * libguile/numbers.c (scm_i_big2dbl_2exp): New static function. (scm_i_big2dbl): Reimplement in terms of 'scm_i_big2dbl_2exp', with proper rounding. * test-suite/tests/numbers.test ("exact->inexact"): Add tests. --- libguile/numbers.c | 101 ++++++++++++---------------------- test-suite/tests/numbers.test | 57 ++++++++++++++----- 2 files changed, 80 insertions(+), 78 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 3f2afdebb..81461792d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -330,81 +330,52 @@ scm_i_dbl2num (double u) return scm_i_dbl2big (u); } -/* scm_i_big2dbl() rounds to the closest representable double, in accordance - with R5RS exact->inexact. +static SCM round_right_shift_exact_integer (SCM n, long count); - The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits - (ie. truncate towards zero), then adjust to get the closest double by - examining the next lower bit and adding 1 (to the absolute value) if - necessary. +/* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the + bignum b into a normalized significand and exponent such that + b = significand * 2^exponent and 1/2 <= abs(significand) < 1. + The return value is the significand rounded to the closest + representable double, and the exponent is placed into *expon_p. + If b is zero, then the returned exponent and significand are both + zero. */ - Bignums exactly half way between representable doubles are rounded to the - next higher absolute value (ie. away from zero). This seems like an - adequate interpretation of R5RS "numerically closest", and it's easier - and faster than a full "nearest-even" style. - - The bit test must be done on the absolute value of the mpz_t, which means - we need to use mpz_getlimbn. mpz_tstbit is not right, it treats - negatives as twos complement. - - In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up - following the hardware rounding mode, but applied to the absolute - value of the mpz_t operand. This is not what we want so we put the - high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2 - (released in March 2006) mpz_get_d now always truncates towards zero. - - ENHANCE-ME: The temporary init+clear to force the rounding in GMP - before 4.2 is a slowdown. It'd be faster to pick out the relevant - high bits with mpz_getlimbn. */ - -double -scm_i_big2dbl (SCM b) +static double +scm_i_big2dbl_2exp (SCM b, long *expon_p) { - double result; - size_t bits; - - bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2); - -#if 1 - { - /* For GMP earlier than 4.2, force truncation towards zero */ - - /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits, - _not_ the number of bits, so this code will break badly on a - system with non-binary doubles. */ - - mpz_t tmp; - if (bits > DBL_MANT_DIG) - { - size_t shift = bits - DBL_MANT_DIG; - mpz_init2 (tmp, DBL_MANT_DIG); - mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift); - result = ldexp (mpz_get_d (tmp), shift); - mpz_clear (tmp); - } - else - { - result = mpz_get_d (SCM_I_BIG_MPZ (b)); - } - } -#else - /* GMP 4.2 or later */ - result = mpz_get_d (SCM_I_BIG_MPZ (b)); -#endif + size_t bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2); + size_t shift = 0; if (bits > DBL_MANT_DIG) { - unsigned long pos = bits - DBL_MANT_DIG - 1; - /* test bit number "pos" in absolute value */ - if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS) - & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS))) + shift = bits - DBL_MANT_DIG; + b = round_right_shift_exact_integer (b, shift); + if (SCM_I_INUMP (b)) { - result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1); + int expon; + double signif = frexp (SCM_I_INUM (b), &expon); + *expon_p = expon + shift; + return signif; } } - scm_remember_upto_here_1 (b); - return result; + { + long expon; + double signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b)); + scm_remember_upto_here_1 (b); + *expon_p = expon + shift; + return signif; + } +} + +/* scm_i_big2dbl() rounds to the closest representable double, + in accordance with R5RS exact->inexact. */ +double +scm_i_big2dbl (SCM b) +{ + long expon; + double signif = scm_i_big2dbl_2exp (b, &expon); + return ldexp (signif, expon); } SCM diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index bb1424853..6b4e08c3a 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3858,21 +3858,17 @@ ;;; (with-test-prefix "exact->inexact" - + + ;; Test "(exact->inexact n)", expect "want". + (define (test name n want) + (with-test-prefix name + (pass-if-equal "pos" want (exact->inexact n)) + (pass-if-equal "neg" (- want) (exact->inexact (- n))))) + ;; Test "(exact->inexact n)", expect "want". ;; "i" is a index, for diagnostic purposes. (define (try-i i n want) - (with-test-prefix (list i n want) - (with-test-prefix "pos" - (let ((got (exact->inexact n))) - (pass-if "inexact?" (inexact? got)) - (pass-if (list "=" got) (= want got)))) - (set! n (- n)) - (set! want (- want)) - (with-test-prefix "neg" - (let ((got (exact->inexact n))) - (pass-if "inexact?" (inexact? got)) - (pass-if (list "=" got) (= want got)))))) + (test (list i n want) n want)) (with-test-prefix "2^i, no round" (do ((i 0 (1+ i)) @@ -3945,7 +3941,42 @@ ;; convert the num and den to doubles, resulting in infs. (pass-if "frac big/big, exceeding double" (let ((big (ash 1 4096))) - (= 1.0 (exact->inexact (/ (1+ big) big)))))) + (= 1.0 (exact->inexact (/ (1+ big) big))))) + + (test "round up to odd" + ;; ===================================================== + ;; 11111111111111111111111111111111111111111111111111000101 -> + ;; 11111111111111111111111111111111111111111111111111001000 + (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b000101) + (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b001000)) + + (test "round down to odd" + ;; ===================================================== + ;; 11111111111111111111111111111111111111111111111111001011 -> + ;; 11111111111111111111111111111111111111111111111111001000 + (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b001011) + (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b001000)) + + (test "round tie up to even" + ;; ===================================================== + ;; 11111111111111111111111111111111111111111111111111011100 -> + ;; 11111111111111111111111111111111111111111111111111100000 + (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b011100) + (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b100000)) + + (test "round tie down to even" + ;; ===================================================== + ;; 11111111111111111111111111111111111111111111111111000100 -> + ;; 11111111111111111111111111111111111111111111111111000000 + (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b000100) + (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b000000)) + + (test "round tie up to next power of two" + ;; ===================================================== + ;; 11111111111111111111111111111111111111111111111111111100 -> + ;; 100000000000000000000000000000000000000000000000000000000 + (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b111100) + (expt 2.0 (+ dbl-mant-dig 3)))) ;;; ;;; expt From 7f34acd8a48198c7fec2daf8d2f4161eaa9963ec Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sun, 3 Mar 2013 05:02:53 -0500 Subject: [PATCH 093/147] Optimize logarithms using scm_i_big2dbl_2exp * libguile/numbers.c (log_of_exact_integer_with_size): Removed. (log_of_exact_integer): Handle bignums too large to fit in a double using 'scm_i_big2dbl_2exp' instead of 'scm_integer_length' and 'scm_ash'. (log_of_fraction): Use 'log_of_exact_integer' instead of 'log_of_exact_integer_with_size'. --- libguile/numbers.c | 30 ++++++++++++------------------ 1 file changed, 12 insertions(+), 18 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 81461792d..fa55b4f9e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9600,26 +9600,20 @@ log_of_shifted_double (double x, long shift) return scm_c_make_rectangular (ans, M_PI); } -/* Returns log(n), for exact integer n of integer-length size */ -static SCM -log_of_exact_integer_with_size (SCM n, long size) -{ - long shift = size - 2 * scm_dblprec[0]; - - if (shift > 0) - return log_of_shifted_double - (scm_to_double (scm_ash (n, scm_from_long(-shift))), - shift); - else - return log_of_shifted_double (scm_to_double (n), 0); -} - /* Returns log(n), for exact integer n */ static SCM log_of_exact_integer (SCM n) { - return log_of_exact_integer_with_size - (n, scm_to_long (scm_integer_length (n))); + if (SCM_I_INUMP (n)) + return log_of_shifted_double (SCM_I_INUM (n), 0); + else if (SCM_BIGP (n)) + { + long expon; + double signif = scm_i_big2dbl_2exp (n, &expon); + return log_of_shifted_double (signif, expon); + } + else + scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1, n); } /* Returns log(n/d), for exact non-zero integers n and d */ @@ -9630,8 +9624,8 @@ log_of_fraction (SCM n, SCM d) long d_size = scm_to_long (scm_integer_length (d)); if (abs (n_size - d_size) > 1) - return (scm_difference (log_of_exact_integer_with_size (n, n_size), - log_of_exact_integer_with_size (d, d_size))); + return (scm_difference (log_of_exact_integer (n), + log_of_exact_integer (d))); else if (scm_is_false (scm_negative_p (n))) return scm_from_double (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d)))); From 24475b860b02880b1cfdf4e03f9659a8af09eb72 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 4 Mar 2013 18:42:27 -0500 Subject: [PATCH 094/147] Reimplement 'inexact->exact' to avoid mpq functions. * libguile/numbers.c (scm_inexact_to_exact): Implement conversion of a double to an exact rational without using the mpq functions. * test-suite/tests/numbers.test (dbl-mant-dig): Simplify initializer. (dbl-epsilon, dbl-min-exp): New variables. ("inexact->exact"): Add tests. Fix broken "2.0**i to exact and back" test, and change it to "2.0**i to exact", to avoid use of 'exact->inexact'. --- libguile/numbers.c | 39 +++++++++++------ test-suite/tests/numbers.test | 80 +++++++++++++++++++++++++++++------ 2 files changed, 92 insertions(+), 27 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index fa55b4f9e..f0f7236dd 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9109,22 +9109,35 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, if (!SCM_LIKELY (DOUBLE_IS_FINITE (val))) SCM_OUT_OF_RANGE (1, z); + else if (val == 0.0) + return SCM_INUM0; else { - mpq_t frac; - SCM q; - - mpq_init (frac); - mpq_set_d (frac, val); - q = scm_i_make_ratio_already_reduced - (scm_i_mpz2num (mpq_numref (frac)), - scm_i_mpz2num (mpq_denref (frac))); + int expon; + SCM numerator; - /* When scm_i_make_ratio throws, we leak the memory allocated - for frac... - */ - mpq_clear (frac); - return q; + numerator = scm_i_dbl2big (ldexp (frexp (val, &expon), + DBL_MANT_DIG)); + expon -= DBL_MANT_DIG; + if (expon < 0) + { + int shift = mpz_scan1 (SCM_I_BIG_MPZ (numerator), 0); + + if (shift > -expon) + shift = -expon; + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator), + SCM_I_BIG_MPZ (numerator), + shift); + expon += shift; + } + numerator = scm_i_normbig (numerator); + if (expon < 0) + return scm_i_make_ratio_already_reduced + (numerator, left_shift_exact_integer (SCM_INUM1, -expon)); + else if (expon > 0) + return left_shift_exact_integer (numerator, expon); + else + return numerator; } } } diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 6b4e08c3a..550dc502f 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -46,15 +46,24 @@ ;; the usual 53. ;; (define dbl-mant-dig - (let more ((i 1) - (d 2.0)) - (if (> i 1024) - (error "Oops, cannot determine number of bits in mantissa of inexact")) - (let* ((sum (+ 1.0 d)) - (diff (- sum d))) - (if (= diff 1.0) - (more (1+ i) (* 2.0 d)) - i)))) + (do ((prec 0 (+ prec 1)) + (eps 1.0 (/ eps 2.0))) + ((begin (when (> prec 1000000) + (error "Unable to determine dbl-mant-dig")) + (= 1.0 (+ 1.0 eps))) + prec))) + +(define dbl-epsilon + (expt 0.5 (- dbl-mant-dig 1))) + +(define dbl-min-exp + (do ((x 1.0 (/ x 2.0)) + (y (+ 1.0 dbl-epsilon) (/ y 2.0)) + (e 2 (- e 1))) + ((begin (when (< e -100000000) + (error "Unable to determine dbl-min-exp")) + (= x y)) + e))) ;; like ash, but working on a flonum (define (ash-flo x n) @@ -4251,6 +4260,13 @@ ;;; (with-test-prefix "inexact->exact" + + ;; Test "(inexact->exact f)", expect "want". + (define (test name f want) + (with-test-prefix name + (pass-if-equal "pos" want (inexact->exact f)) + (pass-if-equal "neg" (- want) (inexact->exact (- f))))) + (pass-if (documented? inexact->exact)) (pass-if-exception "+inf" exception:out-of-range @@ -4261,13 +4277,49 @@ (pass-if-exception "nan" exception:out-of-range (inexact->exact +nan.0)) - - (with-test-prefix "2.0**i to exact and back" + + (test "0.0" 0.0 0) + (test "small even integer" 72.0 72) + (test "small odd integer" 73.0 73) + + (test "largest inexact odd integer" + (- (expt 2.0 dbl-mant-dig) 1) + (- (expt 2 dbl-mant-dig) 1)) + + (test "largest inexact odd integer - 1" + (- (expt 2.0 dbl-mant-dig) 2) + (- (expt 2 dbl-mant-dig) 2)) + + (test "largest inexact odd integer + 3" + (+ (expt 2.0 dbl-mant-dig) 2) + (+ (expt 2 dbl-mant-dig) 2)) + + (test "largest inexact odd integer * 2^48" + (* (expt 2.0 48) (- (expt 2.0 dbl-mant-dig) 1)) + (* (expt 2 48) (- (expt 2 dbl-mant-dig) 1))) + + (test "largest inexact odd integer / 2^48" + (* (expt 0.5 48) (- (expt 2.0 dbl-mant-dig) 1)) + (* (expt 1/2 48) (- (expt 2 dbl-mant-dig) 1))) + + (test "smallest inexact" + (expt 2.0 (- dbl-min-exp dbl-mant-dig)) + (expt 2 (- dbl-min-exp dbl-mant-dig))) + + (test "smallest inexact * 2" + (* 2.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig))) + (* 2 (expt 2 (- dbl-min-exp dbl-mant-dig)))) + + (test "smallest inexact * 3" + (* 3.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig))) + (* 3 (expt 2 (- dbl-min-exp dbl-mant-dig)))) + + (with-test-prefix "2.0**i to exact" (do ((i 0 (1+ i)) - (n 1.0 (* 2.0 n))) + (n 1 (* 2 n)) + (f 1.0 (* 2.0 f))) ((> i 100)) - (pass-if (list i n) - (= n (inexact->exact (exact->inexact n))))))) + (test (list i n) f n)))) ;;; ;;; integer-expt From dfd1d3b144d97522b2a4e82dc583a43e0b4f8b93 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@igalia.com> Date: Tue, 12 Mar 2013 22:07:50 +0100 Subject: [PATCH 095/147] failing to load module in psyntax indicates an identifier is not macro * module/ice-9/boot-9.scm (false-if-exception): Add optional #:warning TEMPLATE ARG... tail, which indicates that we should print a warning on failure. (load-in-vicinity): Use the new #:warning. (make-autoload-interface): Surround the bits that load modules with a false-if-exception with #:warning. Fixes http://debbugs.gnu.org/cgi/bugreport.cgi?bug=12202. * test-suite/tests/syncase.test ("missing autoloads do not foil psyntax"): Add a test. --- module/ice-9/boot-9.scm | 107 +++++++++++++++++----------------- test-suite/tests/syncase.test | 12 +++- 2 files changed, 65 insertions(+), 54 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 067d672cf..ed7ebeac4 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -947,10 +947,26 @@ VALUE." (define (and=> value procedure) (and value (procedure value))) (define call/cc call-with-current-continuation) -(define-syntax-rule (false-if-exception expr) - (catch #t - (lambda () expr) - (lambda (k . args) #f))) +(define-syntax false-if-exception + (syntax-rules () + ((false-if-exception expr) + (catch #t + (lambda () expr) + (lambda args #f))) + ((false-if-exception expr #:warning template arg ...) + (catch #t + (lambda () expr) + (lambda (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) + (format port template arg ...) + (print-exception port #f key args))) + #\newline)) + #f))))) @@ -2786,16 +2802,18 @@ VALUE." (define (make-autoload-interface module name bindings) (let ((b (lambda (a sym definep) - (and (memq sym bindings) - (let ((i (module-public-interface (resolve-module name)))) - (if (not i) - (error "missing interface for module" name)) - (let ((autoload (memq a (module-uses module)))) - ;; Replace autoload-interface with actual interface if - ;; that has not happened yet. - (if (pair? autoload) - (set-car! autoload i))) - (module-local-variable i sym)))))) + (false-if-exception + (and (memq sym bindings) + (let ((i (module-public-interface (resolve-module name)))) + (if (not i) + (error "missing interface for module" name)) + (let ((autoload (memq a (module-uses module)))) + ;; Replace autoload-interface with actual interface if + ;; that has not happened yet. + (if (pair? autoload) + (set-car! autoload i))) + (module-local-variable i sym))) + #:warning "Failed to autoload ~a in ~a:\n" sym name)))) (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f (make-hash-table 0) '() (make-weak-value-hash-table 31) #f (make-hash-table 0) #f #f #f))) @@ -3750,15 +3768,6 @@ when none is available, reading FILE-NAME with READER." #: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 @@ -3775,30 +3784,25 @@ when none is available, reading FILE-NAME with READER." ;; Return GO-FILE-NAME 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 ((gostat (and (not %fresh-auto-compile) - (stat go-file-name #f)))) - (if (and gostat (more-recent? gostat scmstat)) - go-file-name - (begin - (if gostat - (format (current-warning-port) - ";;; note: source file ~a\n;;; newer than compiled ~a\n" - name go-file-name)) - (cond - (%load-should-auto-compile - (%warn-auto-compilation-enabled) - (format (current-warning-port) ";;; compiling ~a\n" name) - (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) - (warn-about-exception k args) - #f))) + (false-if-exception + (let ((gostat (and (not %fresh-auto-compile) + (stat go-file-name #f)))) + (if (and gostat (more-recent? gostat scmstat)) + go-file-name + (begin + (if gostat + (format (current-warning-port) + ";;; note: source file ~a\n;;; newer than compiled ~a\n" + name go-file-name)) + (cond + (%load-should-auto-compile + (%warn-auto-compilation-enabled) + (format (current-warning-port) ";;; compiling ~a\n" name) + (let ((cfn (compile name))) + (format (current-warning-port) ";;; compiled ~a\n" cfn) + cfn)) + (else #f))))) + #:warning "WARNING: compilation of ~a failed:\n" name)) (define (sans-extension file) (let ((dot (string-rindex file #\.))) @@ -3810,12 +3814,9 @@ when none is available, reading FILE-NAME with READER." ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling ;; if needed. (define scmstat - (catch #t - (lambda () - (stat abs-file-name)) - (lambda (key . args) - (warn-about-exception key args) - #f))) + (false-if-exception + (stat abs-file-name) + #:warning "Stat of ~a failed:\n" abs-file-name)) (define (pre-compiled) (and=> (search-path %load-compiled-path (sans-extension file-name) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 0e81f6506..b1b29227f 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -1,6 +1,6 @@ ;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*- ;;;; -;;;; Copyright (C) 2001, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2009, 2010, 2011, 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 @@ -239,3 +239,13 @@ ((odd? x) (not (even? x))))) (even? 10)) (current-module)))) + +(define-module (test-suite test-syncase-3) + #:autoload (test-syncase-3-does-not-exist) (baz)) + +(define-module (test-suite test-syncase)) ;; back to main module + +(pass-if "missing autoloads do not foil psyntax" + (parameterize ((current-warning-port (%make-void-port "w"))) + (eval '(if #f (baz) #t) + (resolve-module '(test-suite test-syncase-3))))) From dbab8aaacaa7ce4d1d3db09d422615b6fcd6724f Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@igalia.com> Date: Wed, 13 Mar 2013 11:01:38 +0100 Subject: [PATCH 096/147] allow for spurious wakeups from pthread_cond_wait * libguile/threads.c (scm_call_with_new_thread, scm_spawn_thread): Allow for spurious wakeups while waiting on cond variables. Should fix bug 10641. --- libguile/threads.c | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index c1b9c3982..04897e383 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, - * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 + * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -1058,7 +1058,10 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0, errno = err; scm_syserror (NULL); } - scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex); + + while (scm_is_false (data.thread)) + scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex); + scm_i_pthread_mutex_unlock (&data.mutex); return data.thread; @@ -1135,7 +1138,10 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data, errno = err; scm_syserror (NULL); } - scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex); + + while (scm_is_false (data.thread)) + scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex); + scm_i_pthread_mutex_unlock (&data.mutex); assert (SCM_I_IS_THREAD (data.thread)); From de2811cc41e86f8f558cfe99172a1987cbcad47a Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@igalia.com> Date: Wed, 13 Mar 2013 23:22:34 +0100 Subject: [PATCH 097/147] very beginnings of NEWS * NEWS: A very very very rough start at 2.0.8 news --- NEWS | 267 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 266 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index ebf5d6169..64a56d2de 100644 --- a/NEWS +++ b/NEWS @@ -1,10 +1,275 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2012 Free Software Foundation, Inc. +Copyright (C) 1996-2013 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes in 2.0.8 (since 2.0.7): + +* TODO + +Reorder points in order of importance and make comprehensible + +Assemble thanks + +* Notable changes + +** guile.m4 allows selection of guile 2.0, 1.8, etc. + +Also GUILE_PKG; see "Autoconf Macros" in manual + +** more efficient scm_gcd of inums + + Optimize and simplify fractions code. + + Simplify and improve scm_i_big2dbl + + Optimize logarithms + + Reimplement 'inexact->exact' to avoid mpq functions. + +** mingw + +many, many bugs. + +remove special ifdefs, given gnulib + +windows file names handled correctly + +don't provide scm_std_select on mingw and similar platforms + +If we do not have sys/select.h, don't provide scm_std_select, +SELECT_TYPE, FD_SET, FD_ZERO, FD_ISSET, or FD_CLR. Guile should not be +setting these macros in public API. This is an incompatible change on +mingw, but oh well. + +** gnulib imports + +select, times, pipe-posix, fstat, getlogin, poll + +** optimize access to arrays of rank 1 or 2 + +** peval improvements + +inlining of ((let ((_ 10)) (lambda () _))) + +inlining of ((lambda _ _)) + +inlining of (apply (lambda _) 1 2 3 4) + +inlining of (call-with-values (lambda () (values 1 2)) (lambda _ _)) + +** `include' relative paths relative to including file + +Local Inclusion + +** slib compatibility + +** warn on multithreaded fork + +** trace: limit length of "| | | "... prefix + +see docs for ",trace" + +** Update predefined character sets to Unicode 6.2 + +* Manual updates + +** excise use of "iff" in the manual + +** Improve keyword notation of Texinfo function definitions. + +** arrays + +Document scm_array_type(), scm_array_ref(), array-length, +scm_array_length(), scm_c_array_length(). + +Fix wording of documentation for array-in-bounds? + +** better sxml docs + +"SXML" in manual + +** updates + +scm_new_smob instead of SCM_NEWSMOB / SCM_RETURN_NEWSMOB. +procedural interface to vectors (scm_c_vector_ref et al). + +replace old foreign->bytevector and bytevector->foreign with the new +procedure names using pointer. + +** an end to the generated-documentation experiment + +** document program-arguments-alist and program-lambda-list + +** update GOOPS class hierarchy diagram in web and pdf + +* New deprecations + +** (ice-9 mapping) + +** Deprecate generalized vector interface + +scm_generalized_vector_p, scm_generalized_vector_length, +scm_generalized_vector_ref, scm_generalized_vector_set_x, +scm_generalized_vector_to_list + +** deprecate SCM_CHAR_CODE_LIMIT and char-code-limit + +** deprecate http-get* + +The #:streaming? argument subsumes the functionality of http-get*. Also +deprecate #:extra-headers argument in favor of #:headers. + +* New interfaces + +** round-ash + +"Bitwise Operations" + +** GUILE_STACK_SIZE + +"Environment Variables" + +** GUILE_INSTALL_LOCALE + +"Environment Variables" + +** file names + +system-file-name-convention, file-name-separator?, +absolute-file-name? file-name-separator-string + +missing docs + +** array-length + +Array Procedures + +** add hash-count for native tables + +Hash Tables + +** Add foreign types: ssize_t and ptrdiff_t. + +Foreign Types + +** Add scm_from_ptrdiff_t and scm_to_ptrdiff_t. + +Integers + +** much more capable xml->sxml + +namespaces, processed entities, doctypes, literal strings... see +"Reading and Writing XML" + +** add --language argument to guile + +needs docs + +** current-language is a parameter in boot-9 + +Compiler Tower; repl, compile-and-load default to current language + +** add fluid->parameter + +Parameters in manual + +** add read-string and read-string! to (ice-9 rdelim) + +Line/Delimited in manual + +** http-head, http-post, http-put, http-delete, http-trace http-options + +"Web Client" + +** add bytevector->string and string->bytevector in new (ice-9 iconv) module + +"Representing Strings as Bytes" + +** add repl-option for customized print + +"REPL Commands" in the manual (,option print ...) + +** current-ssax-error-port is a parameter + +** %site-ccache-dir + +"Installing Site Packages", "Build Config" + +* Build fixes + +** Use accessors instead of symbols deprecated in libgc 7.3. +** Fix cross-compilation of `c-tokenize.o'. +** tests: Avoid missing missing-prototype warning with <fenv.h> on glibc 2.17. +** doc: Fix build with Texinfo 5.0. +** GUILE_INSTALL_LOCALE=1 during build + (http://bugs.gnu.org/12887) +** if we have threads on windows, we have pthreads; inform bdw-gc of that + +* Bug fixes + +** allow for spurious wakeups from pthread_cond_wait + (http://bugs.gnu.org/10641) +** fix psyntax vs autoload + (http://bugs.gnu.org/12202) +** use chmod portably in (system base compile) +** fix response-body-port for responses without content-length +** allow case-lambda expressions with no clauses +** Improve standards conformance of string->number. + (http://bugs.gnu.org/11887) +** support calls and tail-calls with more than 255 formals +** ,option evaluates its right-hand-side + (http://bugs.gnu.org/13076) +** structs with tail arrays are not simple + (http://bugs.gnu.org/12808) +** Make `SCM_LONG_BIT' usable in preprocessor conditionals. + (http://bugs.gnu.org/13848) +** Fix thread-unsafe lazy initializations. +** Allow the SMOB mark procedures to be called when libgc uses parallel markers. + (http://bugs.gnu.org/13611) +** Fix later-bindings-win logic in with-fluids. + (http://bugs.gnu.org/13843) +** Fix duplicate removal of with-fluids. + (http://bugs.gnu.org/13838) +** Support calling foreign functions of 10 arguments or more. +** Let reverse! accept arbitrary types as second argument (new_tail) +** Recognize the `x86_64.*-gnux32' triplet. +** Check whether a triplet's OS part specifies an ABI. +** Recognize mips64* as having 32-bit pointers by default. +** remove language/glil/decompile-assembly.scm +** random_state_of_last_resort doesn't rely on HAVE_POSIX +** copy-file, load-objcode, mkstemp use O_BINARY +** fix compilation of functions with more than 255 local variables. +** Fix `getgroups' for when zero supplementary group IDs exist. +** allow (define-macro name (lambda ...)) +** (texinfo): add a command-spec for @math{}. +** (texinfo docbook): informaltable is a block element. +** (texinfo plain-text): Pass @math{} through as-is. +** (texinfo serialize): don't break words when wrapping +** guild: Gracefully handle failures to install the locale. +** Fix argument count for various format string escape sequences (in warning pass) +** Fix source annotation bug in psyntax 'expand-body'. +** ecmascript: Fix conversion to boolean for non-numbers. +** fix try-module-autoload, which did not detect failure to find the file + +file not found vs failure to load module. + +** Many (oop goops save) fixes +** http-get: don't shutdown write end of socket +** Avoid signed integer overflow in scm_product +** http: read-response-body always returns bytevector or #f (not EOF in one case) +** web: Correctly detect "No route to host" conditions. +** `system*': failure to execvp no longer leaks dangling processes + (http://bugs.gnu.org/13166) +** More sensible case-lambda* dispatch + (http://bugs.gnu.org/12929; see "Case-Lambda" in the manual) +** Do not defer expansion of internal define-syntax forms. + (http://bugs.gnu.org/13509) + + + Changes in 2.0.7 (since 2.0.6): * Notable changes From 912f5f34458fd6998b129e65685adbaf44356860 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@igalia.com> Date: Fri, 15 Mar 2013 19:22:18 +0100 Subject: [PATCH 098/147] fix doc build * doc/ref/api-data.texi (Bitwise Operations): Don't use @-commands in @math. Fixes doc build. * doc/ref/api-macros.texi (Syntax Rules): Fix example result. --- doc/ref/api-data.texi | 4 ++-- doc/ref/api-macros.texi | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 81c6d5b70..17baed27d 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1688,7 +1688,7 @@ starts from 0 for the least significant bit. @deffn {Scheme Procedure} ash n count @deffnx {C Function} scm_ash (n, count) -Return @math{floor(@var{n} * 2^@var{count})}. +Return @math{floor(n * 2^count)}. @var{n} and @var{count} must be exact integers. With @var{n} viewed as an infinite-precision twos-complement @@ -1707,7 +1707,7 @@ when @var{count} is negative. This is an ``arithmetic'' shift. @deffn {Scheme Procedure} round-ash n count @deffnx {C Function} scm_round_ash (n, count) -Return @math{round(@var{n} * 2^@var{count})}. +Return @math{round(n * 2^count)}. @var{n} and @var{count} must be exact integers. With @var{n} viewed as an infinite-precision twos-complement diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index dcbde9b30..ea4e8d68a 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -215,7 +215,7 @@ including ellipsizing and tail patterns. ((_ #((var val) ...) exp exp* ...) (let ((var val) ...) exp exp* ...)))) (letv #((foo 'bar)) foo) -@result{} foo +@result{} bar @end example Literals are used to match specific datums in an expression, like the use of From f361bb937aed7b26a18580c78e66657ed44be294 Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@igalia.com> Date: Fri, 15 Mar 2013 21:13:27 +0100 Subject: [PATCH 099/147] incremental NEWS work * NEWS: Checkpoint. --- NEWS | 171 +++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 101 insertions(+), 70 deletions(-) diff --git a/NEWS b/NEWS index 64a56d2de..d68e3e47f 100644 --- a/NEWS +++ b/NEWS @@ -13,114 +13,143 @@ Reorder points in order of importance and make comprehensible Assemble thanks +file name docs + +gnulib version + * Notable changes -** guile.m4 allows selection of guile 2.0, 1.8, etc. +** New guile.m4 -Also GUILE_PKG; see "Autoconf Macros" in manual +The `guile.m4' autoconf macros have been rewritten to use `guild' and +`pkg-config' instead of the deprecated `guile-config' (which itself +calls pkg-config). -** more efficient scm_gcd of inums +There is also a new macro, `GUILE_PKG', which allows packages to select +the version of Guile that they want to compile against. See "Autoconf +Macros" in the manual, for more information. - Optimize and simplify fractions code. - - Simplify and improve scm_i_big2dbl - - Optimize logarithms +** Better Windows support - Reimplement 'inexact->exact' to avoid mpq functions. +Guile now correctly identifies absolute paths on Windows (MinGW), and +creates files on that platform according to its path conventions. See +XXX in the manual, for all details. -** mingw +In addition, the new Gnulib imports provide `select' and `poll' on +Windows builds. -many, many bugs. +As an incompatible change, systems that are missing <sys/select.h> were +previously provided a public `scm_std_select' C function that defined a +version of `select', but unhappily it also provided its own incompatible +definitions for FD_SET, FD_ZERO, and other system interface. Guile +should not be setting these macros in public API, so this interface was +removed on those plaforms (basically only MinGW). -remove special ifdefs, given gnulib +** Gnulib update -windows file names handled correctly +Guile's copy of Gnulib was updated to XXX. The following modules were +imported from Gnulib: select, times, pipe-posix, fstat, getlogin, and +poll. -don't provide scm_std_select on mingw and similar platforms - -If we do not have sys/select.h, don't provide scm_std_select, -SELECT_TYPE, FD_SET, FD_ZERO, FD_ISSET, or FD_CLR. Guile should not be -setting these macros in public API. This is an incompatible change on -mingw, but oh well. +** Optimizations -** gnulib imports +There were a number of improvements to the partial evaluator, allowing +complete reduction of forms like: -select, times, pipe-posix, fstat, getlogin, poll + ((let ((_ 10)) (lambda () _))) -** optimize access to arrays of rank 1 or 2 + ((lambda _ _)) -** peval improvements + (apply (lambda _) 1 2 3 4) -inlining of ((let ((_ 10)) (lambda () _))) + (call-with-values (lambda () (values 1 2)) (lambda _ _)) -inlining of ((lambda _ _)) +A number (ahem) of numeric operations on have been made faster, among +them GCD and logarithms. -inlining of (apply (lambda _) 1 2 3 4) +Finally, `array-ref' and `array-set!' on arrays of rank 1 or 2 is now +faster, because it avoids building a rest list. -inlining of (call-with-values (lambda () (values 1 2)) (lambda _ _)) +** `include' relative file names relative to including file -** `include' relative paths relative to including file +Given a relative file name, `include' will look for it relative to the +directory of the including file. This harmonizes the behavior of +`include' with that of `load'. -Local Inclusion +** SLIB compatibility restored -** slib compatibility +Guile 2.0.8 is now compatible with SLIB. You will have to use a +development version of SLIB, however, until a new version of SLIB is +released. -** warn on multithreaded fork +** Better ,trace REPL command -** trace: limit length of "| | | "... prefix - -see docs for ",trace" +Sometimes the ,trace output for nested function calls could overflow the +terminal width, which wasn't useful. Now there is a limit to the amount +of space the prefix will take. See the documentation for ",trace" for +more information. ** Update predefined character sets to Unicode 6.2 * Manual updates -** excise use of "iff" in the manual +** Better SXML documentation -** Improve keyword notation of Texinfo function definitions. +The documentation for SXML modules was much improved, though there is +still far to go. See "SXML" in manual. -** arrays +** Style updates -Document scm_array_type(), scm_array_ref(), array-length, -scm_array_length(), scm_c_array_length(). +Use of "iff" was replaced with standard English. Keyword arguments are +now documented consistently, along with their default values. -Fix wording of documentation for array-in-bounds? +** An end to the generated-documentation experiment -** better sxml docs +When Guile 2.0 imported some modules from Guile-Lib, they came with a +system that generated documentation from docstrings and module +commentaries. This produced terrible documentation. We finally bit the +bullet and incorporated these modules into the main text, and will be +improving them manually over time, as is the case with SXML. Help is +appreciated. -"SXML" in manual +** New documentation -** updates - -scm_new_smob instead of SCM_NEWSMOB / SCM_RETURN_NEWSMOB. -procedural interface to vectors (scm_c_vector_ref et al). - -replace old foreign->bytevector and bytevector->foreign with the new -procedure names using pointer. - -** an end to the generated-documentation experiment - -** document program-arguments-alist and program-lambda-list - -** update GOOPS class hierarchy diagram in web and pdf +There is now documentation for `scm_array_type', and `scm_array_ref', as +well as for the new `array-length' / 'scm_c_array_length' / +`scm_array_length' functions. `array-in-bounds?' has better +documentation as well. The `program-arguments-alist' and +`program-lambda-list' functions are now documented. Finally, the GOOPS +class hierarchy diagram has been regenerated for the web and print +output formats. * New deprecations -** (ice-9 mapping) - ** Deprecate generalized vector interface -scm_generalized_vector_p, scm_generalized_vector_length, -scm_generalized_vector_ref, scm_generalized_vector_set_x, -scm_generalized_vector_to_list +The generalized vector interface, introduced in 1.8.0, is simply a +redundant, verbose interface to arrays of rank 1. `array-ref' and +similar functions are entirely sufficient. Thus, +`scm_generalized_vector_p', `scm_generalized_vector_length', +`scm_generalized_vector_ref', `scm_generalized_vector_set_x', and +`scm_generalized_vector_to_list' are now deprecated. -** deprecate SCM_CHAR_CODE_LIMIT and char-code-limit +** Deprecate SCM_CHAR_CODE_LIMIT and char-code-limit -** deprecate http-get* +These constants were defined to 256, which is not the highest codepoint +supported by Guile. Given that they were useless and incorrect, they +have been deprecated. -The #:streaming? argument subsumes the functionality of http-get*. Also -deprecate #:extra-headers argument in favor of #:headers. +** Deprecate `http-get*' + +The new `#:streaming?' argument to `http-get' subsumes the functionality +of `http-get*'. Also, the `#:extra-headers' argument is deprecated in +favor of `#:headers'. + +** Deprecate (ice-9 mapping) + +This module, present in Guile since 1996 but never used or documented, +has never worked in Guile 2.0. It has now been deprecated and will be +removed in Guile 2.2. * New interfaces @@ -200,16 +229,18 @@ Line/Delimited in manual * Build fixes -** Use accessors instead of symbols deprecated in libgc 7.3. +** Fix compilation against libgc 7.3. ** Fix cross-compilation of `c-tokenize.o'. -** tests: Avoid missing missing-prototype warning with <fenv.h> on glibc 2.17. -** doc: Fix build with Texinfo 5.0. -** GUILE_INSTALL_LOCALE=1 during build - (http://bugs.gnu.org/12887) -** if we have threads on windows, we have pthreads; inform bdw-gc of that +** Fix warning when compiling against glibc 2.17. +** Fix documentation build against Texinfo 5.0. +** Fix building Guile from a directory with non-ASCII characters +** Fix native MinGW build +** Fix MinGW builds with networking, POSIX, and thread support * Bug fixes +** warn on multithreaded fork + ** allow for spurious wakeups from pthread_cond_wait (http://bugs.gnu.org/10641) ** fix psyntax vs autoload From 01b83dbd1a11735519b7d6ca7b02006b45861c9c Mon Sep 17 00:00:00 2001 From: Andy Wingo <wingo@igalia.com> Date: Fri, 15 Mar 2013 22:21:34 +0100 Subject: [PATCH 100/147] more NEWS * NEWS: Update. --- NEWS | 197 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 103 insertions(+), 94 deletions(-) diff --git a/NEWS b/NEWS index d68e3e47f..fe6bad134 100644 --- a/NEWS +++ b/NEWS @@ -17,9 +17,11 @@ file name docs gnulib version +--language docs + * Notable changes -** New guile.m4 +** New guile.m4. The `guile.m4' autoconf macros have been rewritten to use `guild' and `pkg-config' instead of the deprecated `guile-config' (which itself @@ -29,7 +31,7 @@ There is also a new macro, `GUILE_PKG', which allows packages to select the version of Guile that they want to compile against. See "Autoconf Macros" in the manual, for more information. -** Better Windows support +** Better Windows support. Guile now correctly identifies absolute paths on Windows (MinGW), and creates files on that platform according to its path conventions. See @@ -45,16 +47,16 @@ definitions for FD_SET, FD_ZERO, and other system interface. Guile should not be setting these macros in public API, so this interface was removed on those plaforms (basically only MinGW). -** Gnulib update +** Gnulib update. Guile's copy of Gnulib was updated to XXX. The following modules were imported from Gnulib: select, times, pipe-posix, fstat, getlogin, and poll. -** Optimizations +** New optimizations. There were a number of improvements to the partial evaluator, allowing -complete reduction of forms like: +complete reduction of forms such as: ((let ((_ 10)) (lambda () _))) @@ -70,40 +72,40 @@ them GCD and logarithms. Finally, `array-ref' and `array-set!' on arrays of rank 1 or 2 is now faster, because it avoids building a rest list. -** `include' relative file names relative to including file +** `include' resolves relative file names relative to including file. Given a relative file name, `include' will look for it relative to the directory of the including file. This harmonizes the behavior of `include' with that of `load'. -** SLIB compatibility restored +** SLIB compatibility restored. Guile 2.0.8 is now compatible with SLIB. You will have to use a development version of SLIB, however, until a new version of SLIB is released. -** Better ,trace REPL command +** Better ,trace REPL command. Sometimes the ,trace output for nested function calls could overflow the terminal width, which wasn't useful. Now there is a limit to the amount of space the prefix will take. See the documentation for ",trace" for more information. -** Update predefined character sets to Unicode 6.2 +** Update predefined character sets to Unicode 6.2. * Manual updates -** Better SXML documentation +** Better SXML documentation. The documentation for SXML modules was much improved, though there is still far to go. See "SXML" in manual. -** Style updates +** Style updates. Use of "iff" was replaced with standard English. Keyword arguments are now documented consistently, along with their default values. -** An end to the generated-documentation experiment +** An end to the generated-documentation experiment. When Guile 2.0 imported some modules from Guile-Lib, they came with a system that generated documentation from docstrings and module @@ -112,7 +114,7 @@ bullet and incorporated these modules into the main text, and will be improving them manually over time, as is the case with SXML. Help is appreciated. -** New documentation +** New documentation. There is now documentation for `scm_array_type', and `scm_array_ref', as well as for the new `array-length' / 'scm_c_array_length' / @@ -124,7 +126,7 @@ output formats. * New deprecations -** Deprecate generalized vector interface +** Deprecate generalized vector interface. The generalized vector interface, introduced in 1.8.0, is simply a redundant, verbose interface to arrays of rank 1. `array-ref' and @@ -133,19 +135,19 @@ similar functions are entirely sufficient. Thus, `scm_generalized_vector_ref', `scm_generalized_vector_set_x', and `scm_generalized_vector_to_list' are now deprecated. -** Deprecate SCM_CHAR_CODE_LIMIT and char-code-limit +** Deprecate SCM_CHAR_CODE_LIMIT and char-code-limit. These constants were defined to 256, which is not the highest codepoint supported by Guile. Given that they were useless and incorrect, they have been deprecated. -** Deprecate `http-get*' +** Deprecate `http-get*'. The new `#:streaming?' argument to `http-get' subsumes the functionality of `http-get*'. Also, the `#:extra-headers' argument is deprecated in favor of `#:headers'. -** Deprecate (ice-9 mapping) +** Deprecate (ice-9 mapping). This module, present in Guile since 1996 but never used or documented, has never worked in Guile 2.0. It has now been deprecated and will be @@ -153,79 +155,85 @@ removed in Guile 2.2. * New interfaces -** round-ash +** `round-ash', a bit-shifting operator that rounds on right-shift. -"Bitwise Operations" +See "Bitwise Operations". -** GUILE_STACK_SIZE +** New environment variables: `GUILE_STACK_SIZE', `GUILE_INSTALL_LOCALE'. -"Environment Variables" +See "Environment Variables". -** GUILE_INSTALL_LOCALE +** New procedures for dealing with file names. -"Environment Variables" +See XXX for documentation on `system-file-name-convention', +`file-name-separator?', `absolute-file-name?', and +`file-name-separator-string'. -** file names +** `array-length', an array's first dimension. -system-file-name-convention, file-name-separator?, -absolute-file-name? file-name-separator-string +See "Array Procedures". -missing docs +** `hash-count', for hash tables. -** array-length +See "Hash Tables". -Array Procedures - -** add hash-count for native tables - -Hash Tables - -** Add foreign types: ssize_t and ptrdiff_t. +** New foreign types: `ssize_t', `ptrdiff_t'. -Foreign Types +See "Foreign Types". -** Add scm_from_ptrdiff_t and scm_to_ptrdiff_t. +** New C helpers: `scm_from_ptrdiff_t', `scm_to_ptrdiff_t'. -Integers +See "Integers". -** much more capable xml->sxml +** Much more capable `xml->sxml' -namespaces, processed entities, doctypes, literal strings... see -"Reading and Writing XML" +See "Reading and Writing XML" for information on how the `xml->sxml' +parser deals with namespaces, processed entities, doctypes, and literal +strings. Incidentally, `current-ssax-error-port' is now a parameter +object. -** add --language argument to guile +** New command-line argument: `--language' -needs docs +See XXX in the manual. -** current-language is a parameter in boot-9 +** `current-language' in default environment. -Compiler Tower; repl, compile-and-load default to current language +Previously defined only in `(system base language)', `current-language' +is now defined in the default environment, and is used to determine the +language for the REPL, and for `compile-and-load'. -** add fluid->parameter +** New procedure: `fluid->parameter' -Parameters in manual +See "Parameters", for information on how to convert a fluid to a +parameter. -** add read-string and read-string! to (ice-9 rdelim) +** New procedures to read all characters from a port -Line/Delimited in manual +See "Line/Delimited" in the manual for documentation on `read-string' + and `read-string!'. -** http-head, http-post, http-put, http-delete, http-trace http-options +** New HTTP client procedures. -"Web Client" +See "Web Client" for documentation on the new `http-head', `http-post', +`http-put', `http-delete', `http-trace', and `http-options' procedures, +and also for more options to `http-get'. -** add bytevector->string and string->bytevector in new (ice-9 iconv) module +** New procedures for converting strings to and from bytevectors. -"Representing Strings as Bytes" +See "Representing Strings as Bytes" for documention on the new `(ice-9 +iconv)' module and its `bytevector->string' and `string->bytevector' +procedures. -** add repl-option for customized print +** New `print' REPL option. -"REPL Commands" in the manual (,option print ...) +See "REPL Commands" in the manual for information on the new +user-customizable REPL printer. -** current-ssax-error-port is a parameter - -** %site-ccache-dir +** New variable: %site-ccache-dir. -"Installing Site Packages", "Build Config" +The "Installing Site Packages" and "Build Config" manual sections now +refer to this variable to describe where users should install their +`.go' files. * Build fixes @@ -233,69 +241,70 @@ Line/Delimited in manual ** Fix cross-compilation of `c-tokenize.o'. ** Fix warning when compiling against glibc 2.17. ** Fix documentation build against Texinfo 5.0. -** Fix building Guile from a directory with non-ASCII characters -** Fix native MinGW build -** Fix MinGW builds with networking, POSIX, and thread support +** Fix building Guile from a directory with non-ASCII characters. +** Fix native MinGW build. +** Fix --disable-posix build. +** Fix MinGW builds with networking, POSIX, and thread support. * Bug fixes -** warn on multithreaded fork - -** allow for spurious wakeups from pthread_cond_wait +** A fork when multiple threads are running will now print a warning. +** Allow for spurious wakeups from pthread_cond_wait. (http://bugs.gnu.org/10641) -** fix psyntax vs autoload +** Warn and ignore module autoload failures. (http://bugs.gnu.org/12202) -** use chmod portably in (system base compile) -** fix response-body-port for responses without content-length -** allow case-lambda expressions with no clauses +** Use chmod portably in (system base compile). + (http://bugs.gnu.org/10474) +** Fix response-body-port for responses without content-length. + (http://bugs.gnu.org/13857) +** Allow case-lambda expressions with no clauses. + (http://bugs.gnu.org/9776) ** Improve standards conformance of string->number. (http://bugs.gnu.org/11887) -** support calls and tail-calls with more than 255 formals -** ,option evaluates its right-hand-side +** Support calls and tail-calls with more than 255 formals. +** ,option evaluates its right-hand-side. (http://bugs.gnu.org/13076) -** structs with tail arrays are not simple +** Structs with tail arrays are not simple. (http://bugs.gnu.org/12808) ** Make `SCM_LONG_BIT' usable in preprocessor conditionals. (http://bugs.gnu.org/13848) ** Fix thread-unsafe lazy initializations. -** Allow the SMOB mark procedures to be called when libgc uses parallel markers. +** Allow SMOB mark procedures to be called from parallel markers. (http://bugs.gnu.org/13611) ** Fix later-bindings-win logic in with-fluids. (http://bugs.gnu.org/13843) ** Fix duplicate removal of with-fluids. (http://bugs.gnu.org/13838) ** Support calling foreign functions of 10 arguments or more. -** Let reverse! accept arbitrary types as second argument (new_tail) + (http://bugs.gnu.org/13809) +** Let reverse! accept arbitrary types as second argument. + (http://bugs.gnu.org/13835) ** Recognize the `x86_64.*-gnux32' triplet. ** Check whether a triplet's OS part specifies an ABI. ** Recognize mips64* as having 32-bit pointers by default. -** remove language/glil/decompile-assembly.scm -** random_state_of_last_resort doesn't rely on HAVE_POSIX -** copy-file, load-objcode, mkstemp use O_BINARY -** fix compilation of functions with more than 255 local variables. +** Remove language/glil/decompile-assembly.scm. + (http://bugs.gnu.org/10622) +** Use O_BINARY in `copy-file', `load-objcode', `mkstemp'. +** Fix compilation of functions with more than 255 local variables. ** Fix `getgroups' for when zero supplementary group IDs exist. -** allow (define-macro name (lambda ...)) -** (texinfo): add a command-spec for @math{}. -** (texinfo docbook): informaltable is a block element. -** (texinfo plain-text): Pass @math{} through as-is. -** (texinfo serialize): don't break words when wrapping +** Allow (define-macro name (lambda ...)). +** Various fixes to the (texinfo) modules. ** guild: Gracefully handle failures to install the locale. -** Fix argument count for various format string escape sequences (in warning pass) +** Fix format string warnings for ~!, ~|, ~/, ~q, ~Q, and ~^. + (http://bugs.gnu.org/13485) ** Fix source annotation bug in psyntax 'expand-body'. -** ecmascript: Fix conversion to boolean for non-numbers. -** fix try-module-autoload, which did not detect failure to find the file - -file not found vs failure to load module. - -** Many (oop goops save) fixes -** http-get: don't shutdown write end of socket -** Avoid signed integer overflow in scm_product -** http: read-response-body always returns bytevector or #f (not EOF in one case) +** Ecmascript: Fix conversion to boolean for non-numbers. +** A failure to find a module's file does not prevent future loading. +** Many (oop goops save) fixes. +** `http-get': don't shutdown write end of socket. + (http://bugs.gnu.org/13095) +** Avoid signed integer overflow in scm_product. +** http: read-response-body always returns bytevector or #f (not EOF in one case). ** web: Correctly detect "No route to host" conditions. ** `system*': failure to execvp no longer leaks dangling processes (http://bugs.gnu.org/13166) ** More sensible case-lambda* dispatch - (http://bugs.gnu.org/12929; see "Case-Lambda" in the manual) + (http://bugs.gnu.org/12929) ** Do not defer expansion of internal define-syntax forms. (http://bugs.gnu.org/13509) From dc8712611597c6d5be918a69b0ce719e0675f6fe Mon Sep 17 00:00:00 2001 From: Daniel Hartwig <mandyke@gmail.com> Date: Sat, 16 Mar 2013 17:53:53 +0800 Subject: [PATCH 101/147] minor tweaks to web documentation * doc/ref/web.texi: Say `World Wide Web'; the hyphenated form is almost never used (c.f. w3.org). General predicate arguments are named `obj'. Fill in arguments omitted from some procedure definitions (e.g. `request-method'). Minor tweaks, such as using en-dash and missing markup as appropriate. Wrap very long deffn lines. * module/web/*.scm: Expand texinfo markup in doc strings. Synchronize with changes in web.texi. --- doc/ref/web.texi | 70 +++++++++++++++++++++++------------------ module/web/client.scm | 6 ++-- module/web/http.scm | 6 ++-- module/web/response.scm | 6 ++-- module/web/uri.scm | 28 ++++++++--------- 5 files changed, 61 insertions(+), 55 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 70e0f2e43..0d41f9f7a 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -10,7 +10,7 @@ @cindex HTTP It has always been possible to connect computers together and share -information between them, but the rise of the World-Wide Web over the +information between them, but the rise of the World Wide Web over the last couple of decades has made it much easier to do so. The result is a richly connected network of computation, in which Guile forms a part. @@ -206,9 +206,10 @@ The following procedures can be found in the @code{(web uri)} module. Load it into your Guile, using a form like the above, to have 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}] +@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, @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, @@ -216,7 +217,7 @@ also run some consistency checks to make sure that the constructed URI is valid. @end deffn -@deffn {Scheme Procedure} uri? x +@deffn {Scheme Procedure} uri? obj @deffnx {Scheme Procedure} uri-scheme uri @deffnx {Scheme Procedure} uri-userinfo uri @deffnx {Scheme Procedure} uri-host uri @@ -249,9 +250,9 @@ Percent-decode the given @var{str}, according to @var{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 -the components separately. +string. For paths, use @code{split-and-decode-uri-path} instead. For +query strings, split the query on @code{&} and @code{=} boundaries, and +decode the components separately. Note also that percent-encoded strings encode @emph{bytes}, not characters. There is no guarantee that a given byte sequence is a valid @@ -378,7 +379,8 @@ For more on the set of headers that Guile knows about out of the box, @pxref{HTTP Headers}. To add your own, use the @code{declare-header!} procedure: -@deffn {Scheme Procedure} declare-header! name parser validator writer [#:multiple?=@code{#f}] +@deffn {Scheme Procedure} declare-header! name parser validator writer @ + [#:multiple?=@code{#f}] Declare a parser, validator, and writer for a given header. @end deffn @@ -450,7 +452,7 @@ like @code{GET}. @end deffn @deffn {Scheme Procedure} parse-http-version str [start] [end] -Parse an HTTP version from @var{str}, returning it as a major-minor +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)}. @end deffn @@ -471,7 +473,7 @@ Write the first line of an HTTP request to @var{port}. @deffn {Scheme Procedure} read-response-line port Read the first line of an HTTP response from @var{port}, returning three -values: the HTTP version, the response code, and the "reason phrase". +values: the HTTP version, the response code, and the ``reason phrase''. @end deffn @deffn {Scheme Procedure} write-response-line version code reason-phrase port @@ -1130,13 +1132,13 @@ any loss of generality. @subsubsection Request API -@deffn {Scheme Procedure} request? -@deffnx {Scheme Procedure} request-method -@deffnx {Scheme Procedure} request-uri -@deffnx {Scheme Procedure} request-version -@deffnx {Scheme Procedure} request-headers -@deffnx {Scheme Procedure} request-meta -@deffnx {Scheme Procedure} request-port +@deffn {Scheme Procedure} request? obj +@deffnx {Scheme Procedure} request-method request +@deffnx {Scheme Procedure} request-uri request +@deffnx {Scheme Procedure} request-version request +@deffnx {Scheme Procedure} request-headers request +@deffnx {Scheme Procedure} request-meta request +@deffnx {Scheme Procedure} request-port request A predicate and field accessors for the request type. The fields are as follows: @table @code @@ -1170,7 +1172,9 @@ request, you may read the body separately, and likewise for writing requests. @end deffn -@deffn {Scheme Procedure} build-request uri [#:method='GET] [#:version='(1 . 1)] [#:headers='()] [#:port=#f] [#:meta='()] [#:validate-headers?=#t] +@deffn {Scheme Procedure} build-request uri [#:method='GET] @ + [#:version='(1 . 1)] [#:headers='()] [#:port=#f] [#:meta='()] @ + [#:validate-headers?=#t] Construct an HTTP request object. If @var{validate-headers?} is true, the headers are each run through their respective validators. @end deffn @@ -1253,12 +1257,12 @@ A helper routine to determine the absolute URI of a request, using the As with requests (@pxref{Requests}), Guile offers a data type for HTTP responses. Again, the body is represented separately from the request. -@deffn {Scheme Procedure} response? -@deffnx {Scheme Procedure} response-version -@deffnx {Scheme Procedure} response-code +@deffn {Scheme Procedure} response? obj +@deffnx {Scheme Procedure} response-version response +@deffnx {Scheme Procedure} response-code response @deffnx {Scheme Procedure} response-reason-phrase response -@deffnx {Scheme Procedure} response-headers -@deffnx {Scheme Procedure} response-port +@deffnx {Scheme Procedure} response-headers response +@deffnx {Scheme Procedure} response-port response A predicate and field accessors for the response type. The fields are as follows: @table @code @@ -1384,6 +1388,10 @@ Return @code{#t} if @var{type}, a symbol as returned by @code{(web client)} provides a simple, synchronous HTTP client, built on the lower-level HTTP, request, and response modules. +@example +(use-modules (web client)) +@end example + @deffn {Scheme Procedure} open-socket-for-uri uri Return an open input/output port for a connection to URI. @end deffn @@ -1419,9 +1427,9 @@ If you already have a port open, pass it as @var{port}. Otherwise, a connection will be opened to the server corresponding to @var{uri}. Any extra headers in the alist @var{headers} will be added to the request. -If @var{body} is not #f, a message body will also be sent with the HTTP -request. If @var{body} is a string, it is encoded according to the -content-type in @var{headers}, defaulting to UTF-8. Otherwise +If @var{body} is not @code{#f}, a message body will also be sent with +the HTTP request. If @var{body} is a string, it is encoded according to +the content-type in @var{headers}, defaulting to UTF-8. Otherwise @var{body} should be a bytevector, or @code{#f} for no body. Although a message body may be sent with any request, usually only @code{POST} and @code{PUT} requests have bodies. @@ -1480,8 +1488,8 @@ The life cycle of a server goes as follows: @enumerate @item -The @code{open} hook is called, to open the server. @code{open} takes 0 or -more arguments, depending on the backend, and returns an opaque +The @code{open} hook is called, to open the server. @code{open} takes +zero or more arguments, depending on the backend, and returns an opaque server socket object, or signals an error. @item @@ -1578,8 +1586,8 @@ in, allowing the user's handler to explicitly manage its state. @end deffn @deffn {Scheme Procedure} sanitize-response request response body -"Sanitize" the given response and body, making them appropriate for the -given request. +``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 an alist of headers, in which case it is used to construct a default diff --git a/module/web/client.scm b/module/web/client.scm index 9fbb25bba..7d5ea4989 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -248,10 +248,10 @@ 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 HEADERS will be added to the request. -If BODY is not #f, a message body will also be sent with the HTTP +If BODY is not ‘#f’, a message body will also be sent with the HTTP request. If BODY is a string, it is encoded according to the content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be -a bytevector, or #f for no body. Although it's allowed to send a +a bytevector, or ‘#f’ for no body. Although it's allowed to send a message body along with any request, usually only POST and PUT requests have bodies. See ‘http-put’ and ‘http-post’ documentation, for more. @@ -317,7 +317,7 @@ This function is similar to ‘http-get’, except it uses the \"HEAD\" method. See ‘http-get’ for full documentation on the various keyword arguments that are accepted by this function. -Returns two values: the resulting response, and #f. Responses to HEAD +Returns two values: the resulting response, and ‘#f’. Responses to HEAD requests do not have a body. The second value is only returned so that other procedures can treat all of the http-foo verbs identically.") diff --git a/module/web/http.scm b/module/web/http.scm index c79d57d78..712208b69 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -167,7 +167,7 @@ The default writer is ‘display’." (define *eof* (call-with-input-string "" read)) (define (read-header port) - "Reads one HTTP header from PORT. Returns two values: the header + "Read one HTTP header from PORT. Return two values: the header name and the parsed Scheme value. May raise an exception if the header was known but the value was invalid. @@ -220,7 +220,7 @@ as an ordered alist." (define (write-headers headers port) "Write the given header alist to PORT. Doesn't write the final -@samp{\\r\\n}, as the user might want to add another header." +‘\\r\\n’, as the user might want to add another header." (let lp ((headers headers)) (if (pair? headers) (begin @@ -971,7 +971,7 @@ as an ordered alist." (define *known-versions* '()) (define* (parse-http-version str #:optional (start 0) (end (string-length str))) - "Parse an HTTP version from STR, returning it as a major-minor + "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*)) diff --git a/module/web/response.scm b/module/web/response.scm index 3f97dffa5..570a2d7d2 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -267,10 +267,10 @@ closes PORT, unless KEEP-ALIVE? is true." (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. +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 +When KEEP-ALIVE? is ‘#f’, closing the returned port also closes R's response port." (define port (cond diff --git a/module/web/uri.scm b/module/web/uri.scm index 25406b368..7fe010096 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -53,8 +53,8 @@ (query uri-query) (fragment uri-fragment)) -(define (absolute-uri? x) - (and (uri? x) (uri-scheme x) #t)) +(define (absolute-uri? obj) + (and (uri? obj) (uri-scheme obj) #t)) (define (uri-error message . args) (throw 'uri-error message args)) @@ -309,17 +309,16 @@ serialization." 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 +string. For paths, use ‘split-and-decode-uri-path’ instead. For query strings, split the query on ‘&’ and ‘=’ boundaries, and decode the components separately. -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. +Note also that percent-encoded strings encode _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. ‘set-port-encoding!’, +for more information on character encodings. Returns a string of the decoded characters, or a bytevector if ENCODING was ‘#f’." @@ -380,11 +379,10 @@ ENCODING was ‘#f’." 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." +the special characters ‘-’, ‘.’, ‘_’, and ‘~’. 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))) (if (string-index str needs-escaped?) From 2e08ff38b735020e8ed5403acb637e6041d3d743 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig <mandyke@gmail.com> Date: Sat, 23 Feb 2013 15:15:33 +0800 Subject: [PATCH 102/147] add tests for read-request-line, etc. * test-suite/web/web-http.test ("read-request-line"): ("write-request-line", "read-response-line", "write-response-line"): Add. --- test-suite/tests/web-http.test | 107 +++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 97f55594a..6fa16bd4c 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -85,6 +85,113 @@ #t (error "unexpected exception" component arg)))))))) +(define-syntax pass-if-read-request-line + (syntax-rules () + ((_ str expected-method expected-uri expected-version) + (pass-if str + (equal? (call-with-values + (lambda () + (read-request-line (open-input-string + (string-append str "\r\n")))) + list) + (list 'expected-method + expected-uri + 'expected-version)))))) + +(define-syntax pass-if-write-request-line + (syntax-rules () + ((_ expected-str method uri version) + (pass-if expected-str + (equal? (string-append expected-str "\r\n") + (call-with-output-string + (lambda (port) + (write-request-line 'method uri 'version port)))))))) + +(define-syntax pass-if-read-response-line + (syntax-rules () + ((_ str expected-version expected-code expected-phrase) + (pass-if str + (equal? (call-with-values + (lambda () + (read-response-line (open-input-string + (string-append str "\r\n")))) + list) + (list 'expected-version + expected-code + expected-phrase)))))) + +(define-syntax pass-if-write-response-line + (syntax-rules () + ((_ expected-str version code phrase) + (pass-if expected-str + (equal? (string-append expected-str "\r\n") + (call-with-output-string + (lambda (port) + (write-response-line 'version code phrase port)))))))) + +(with-test-prefix "read-request-line" + (pass-if-read-request-line "GET / HTTP/1.1" + GET + (build-uri 'http + #:path "/") + (1 . 1)) + (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1" + GET + (build-uri 'http + #:host "www.w3.org" + #:path "/pub/WWW/TheProject.html") + (1 . 1)) + (pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1" + GET + (build-uri 'http + #:path "/pub/WWW/TheProject.html") + (1 . 1)) + (pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1" + HEAD + (build-uri 'http + #:path "/etc/hosts" + #:query "foo=bar") + (1 . 1))) + +(with-test-prefix "write-request-line" + (pass-if-write-request-line "GET / HTTP/1.1" + GET + (build-uri 'http + #:path "/") + (1 . 1)) + ;;; FIXME: Test fails due to scheme, host always being removed. + ;;; However, it should be supported to request these be present, and + ;;; that is possible with absolute/relative URI support. + ;; (pass-if-write-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1" + ;; GET + ;; (build-uri 'http + ;; #:host "www.w3.org" + ;; #:path "/pub/WWW/TheProject.html") + ;; (1 . 1)) + (pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1" + GET + (build-uri 'http + #:path "/pub/WWW/TheProject.html") + (1 . 1)) + (pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1" + HEAD + (build-uri 'http + #:path "/etc/hosts" + #:query "foo=bar") + (1 . 1))) + +(with-test-prefix "read-response-line" + (pass-if-read-response-line "HTTP/1.0 404 Not Found" + (1 . 0) 404 "Not Found") + (pass-if-read-response-line "HTTP/1.1 200 OK" + (1 . 1) 200 "OK")) + +(with-test-prefix "write-response-line" + (pass-if-write-response-line "HTTP/1.0 404 Not Found" + (1 . 0) 404 "Not Found") + (pass-if-write-response-line "HTTP/1.1 200 OK" + (1 . 1) 200 "OK")) + (with-test-prefix "general headers" (pass-if-parse cache-control "no-transform" '(no-transform)) From b1c46fd30a4615b4ab534d6bd824a81e3f536660 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig <mandyke@gmail.com> Date: Sat, 16 Mar 2013 19:53:07 +0800 Subject: [PATCH 103/147] http: support IP-literal (IPv6 address) in Host header * module/web/http.scm ("Host"): Parse and write IP-literals treating escapes as uri module does: remove brackets on parse, replace them on write. * test-suite/tests/web-http.test ("request headers"): Add tests. --- module/web/http.scm | 26 ++++++++++++++++++++------ test-suite/tests/web-http.test | 4 ++++ 2 files changed, 24 insertions(+), 6 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 712208b69..b5202b69c 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1628,18 +1628,32 @@ treated specially, and is just returned as a plain string." ;; (declare-header! "Host" (lambda (str) - (let ((colon (string-index str #\:))) - (if colon - (cons (substring str 0 colon) - (parse-non-negative-integer str (1+ colon))) - (cons str #f)))) + (let* ((rbracket (string-index str #\])) + (colon (string-index str #\: (or rbracket 0))) + (host (cond + (rbracket + (unless (eqv? (string-ref str 0) #\[) + (bad-header 'host str)) + (substring str 1 rbracket)) + (colon + (substring str 0 colon)) + (else + str))) + (port (and colon + (parse-non-negative-integer str (1+ colon))))) + (cons host port))) (lambda (val) (and (pair? val) (string? (car val)) (or (not (cdr val)) (non-negative-integer? (cdr val))))) (lambda (val port) - (display (car val) port) + (if (string-index (car val) #\:) + (begin + (display #\[ port) + (display (car val) port) + (display #\] port)) + (display (car val) port)) (if (cdr val) (begin (display #\: port) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 6fa16bd4c..291372445 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -287,6 +287,10 @@ (pass-if-parse from "foo@bar" "foo@bar") (pass-if-parse host "qux" '("qux" . #f)) (pass-if-parse host "qux:80" '("qux" . 80)) + (pass-if-parse host "[2001:db8::1]" '("2001:db8::1" . #f)) + (pass-if-parse host "[2001:db8::1]:80" '("2001:db8::1" . 80)) + (pass-if-parse host "[::ffff:192.0.2.1]" '("::ffff:192.0.2.1" . #f)) + (pass-if-round-trip "Host: [2001:db8::1]\r\n") (pass-if-parse if-match "\"xyzzy\", W/\"qux\"" '(("xyzzy" . #t) ("qux" . #f))) (pass-if-parse if-match "*" '*) From 982377849029f2840ebb105cda49390fecca4fe4 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 4 Mar 2013 18:46:33 -0500 Subject: [PATCH 104/147] Improve inexact division of exact integers. * libguile/numbers.c (scm_i_divide2double): New function. (scm_i_divide2double_lo2b): New variable. (scm_i_fraction2double, log_of_fraction): Use 'scm_i_divide2double'. (do_divide): Removed. Its code is now in 'scm_divide'. (scm_divide2real): Removed. Superceded by 'scm_i_divide2double'. (scm_divide): Inherit code from 'do_divide', but without support for forcing a 'double' result (that functionality is now implemented by 'scm_i_divide2double'). Add FIXME comments in cases where divisions might not be as precise as they should be. (scm_init_numbers): Initialize 'scm_i_divide2double_lo2b'. * test-suite/tests/numbers.test (dbl-epsilon-exact, dbl-max-exp): New variables. ("exact->inexact"): Add tests. ("inexact->exact"): Add test for largest finite inexact. --- libguile/numbers.c | 284 ++++++++++++++++++++++++---------- test-suite/tests/numbers.test | 132 +++++++++++++++- 2 files changed, 335 insertions(+), 81 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index f0f7236dd..f6327339e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -410,9 +410,6 @@ scm_i_mpz2num (mpz_t b) } } -/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */ -static SCM scm_divide2real (SCM x, SCM y); - /* Make the ratio NUMERATOR/DENOMINATOR, where: 1. NUMERATOR and DENOMINATOR are exact integers 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */ @@ -466,11 +463,149 @@ scm_i_make_ratio (SCM numerator, SCM denominator) } #undef FUNC_NAME +static mpz_t scm_i_divide2double_lo2b; + +/* Return the double that is closest to the exact rational N/D, with + ties rounded toward even mantissas. N and D must be exact + integers. */ +static double +scm_i_divide2double (SCM n, SCM d) +{ + int neg; + mpz_t nn, dd, lo, hi, x; + ssize_t e; + + if (SCM_I_INUMP (d)) + { + if (SCM_UNLIKELY (scm_is_eq (d, SCM_INUM0))) + { + if (scm_is_true (scm_positive_p (n))) + return 1.0 / 0.0; + else if (scm_is_true (scm_negative_p (n))) + return -1.0 / 0.0; + else + return 0.0 / 0.0; + } + mpz_init_set_si (dd, SCM_I_INUM (d)); + } + else + mpz_init_set (dd, SCM_I_BIG_MPZ (d)); + + if (SCM_I_INUMP (n)) + mpz_init_set_si (nn, SCM_I_INUM (n)); + else + mpz_init_set (nn, SCM_I_BIG_MPZ (n)); + + neg = (mpz_sgn (nn) < 0) ^ (mpz_sgn (dd) < 0); + mpz_abs (nn, nn); + mpz_abs (dd, dd); + + /* Now we need to find the value of e such that: + + For e <= 0: + b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A] + (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A] + (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A] + + For e >= 0: + b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B] + (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B] + (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B] + + where: p = DBL_MANT_DIG + b = FLT_RADIX (here assumed to be 2) + + After rounding, the mantissa must be an integer between b^{p-1} and + (b^p - 1), except for subnormal numbers. In the inequations [1A] + and [1B], the middle expression represents the mantissa *before* + rounding, and therefore is bounded by the range of values that will + round to a floating-point number with the exponent e. The upper + bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because + ties will round up to the next power of b. The lower bound is + (b^{p-1} - 1/2b), and is inclusive because ties will round toward + this power of b. Here we subtract 1/2b instead of 1/2 because it + is in the range of the next smaller exponent, where the + representable numbers are closer together by a factor of b. + + Inequations [2A] and [2B] are derived from [1A] and [1B] by + multiplying by 2b, and in [3A] and [3B] we multiply by the + denominator of the middle value to obtain integer expressions. + + In the code below, we refer to the three expressions in [3A] or + [3B] as lo, x, and hi. If the number is normalizable, we will + achieve the goal: lo <= x < hi */ + + /* Make an initial guess for e */ + e = mpz_sizeinbase (nn, 2) - mpz_sizeinbase (dd, 2) - (DBL_MANT_DIG-1); + if (e < DBL_MIN_EXP - DBL_MANT_DIG) + e = DBL_MIN_EXP - DBL_MANT_DIG; + + /* Compute the initial values of lo, x, and hi + based on the initial guess of e */ + mpz_inits (lo, hi, x, NULL); + mpz_mul_2exp (x, nn, 2 + ((e < 0) ? -e : 0)); + mpz_mul (lo, dd, scm_i_divide2double_lo2b); + if (e > 0) + mpz_mul_2exp (lo, lo, e); + mpz_mul_2exp (hi, lo, 1); + + /* Adjust e as needed to satisfy the inequality lo <= x < hi, + (but without making e less then the minimum exponent) */ + while (mpz_cmp (x, lo) < 0 && e > DBL_MIN_EXP - DBL_MANT_DIG) + { + mpz_mul_2exp (x, x, 1); + e--; + } + while (mpz_cmp (x, hi) >= 0) + { + /* If we ever used lo's value again, + we would need to double lo here. */ + mpz_mul_2exp (hi, hi, 1); + e++; + } + + /* Now compute the rounded mantissa: + n / b^e d (if e >= 0) + n b^-e / d (if e <= 0) */ + { + int cmp; + double result; + + if (e < 0) + mpz_mul_2exp (nn, nn, -e); + else + mpz_mul_2exp (dd, dd, e); + + /* mpz does not directly support rounded right + shifts, so we have to do it the hard way. + For efficiency, we reuse lo and hi. + hi == quotient, lo == remainder */ + mpz_fdiv_qr (hi, lo, nn, dd); + + /* The fractional part of the unrounded mantissa would be + remainder/dividend, i.e. lo/dd. So we have a tie if + lo/dd = 1/2. Multiplying both sides by 2*dd yields the + integer expression 2*lo = dd. Here we do that comparison + to decide whether to round up or down. */ + mpz_mul_2exp (lo, lo, 1); + cmp = mpz_cmp (lo, dd); + if (cmp > 0 || (cmp == 0 && mpz_odd_p (hi))) + mpz_add_ui (hi, hi, 1); + + result = ldexp (mpz_get_d (hi), e); + if (neg) + result = -result; + + mpz_clears (nn, dd, lo, hi, x, NULL); + return result; + } +} + double scm_i_fraction2double (SCM z) { - return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z), - SCM_FRACTION_DENOMINATOR (z))); + return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z), + SCM_FRACTION_DENOMINATOR (z)); } static int @@ -7989,8 +8124,8 @@ SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1, #define s_divide s_scm_i_divide #define g_divide g_scm_i_divide -static SCM -do_divide (SCM x, SCM y, int inexact) +SCM +scm_divide (SCM x, SCM y) #define FUNC_NAME s_divide { double a; @@ -8009,18 +8144,10 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); #endif else - { - if (inexact) - return scm_from_double (1.0 / (double) xx); - else return scm_i_make_ratio_already_reduced (SCM_INUM1, x); - } + return scm_i_make_ratio_already_reduced (SCM_INUM1, x); } else if (SCM_BIGP (x)) - { - if (inexact) - return scm_from_double (1.0 / scm_i_big2dbl (x)); - else return scm_i_make_ratio_already_reduced (SCM_INUM1, x); - } + return scm_i_make_ratio_already_reduced (SCM_INUM1, x); else if (SCM_REALP (x)) { double xx = SCM_REAL_VALUE (x); @@ -8070,11 +8197,7 @@ do_divide (SCM x, SCM y, int inexact) #endif } else if (xx % yy != 0) - { - if (inexact) - return scm_from_double ((double) xx / (double) yy); - else return scm_i_make_ratio (x, y); - } + return scm_i_make_ratio (x, y); else { scm_t_inum z = xx / yy; @@ -8085,11 +8208,7 @@ do_divide (SCM x, SCM y, int inexact) } } else if (SCM_BIGP (y)) - { - if (inexact) - return scm_from_double ((double) xx / scm_i_big2dbl (y)); - else return scm_i_make_ratio (x, y); - } + return scm_i_make_ratio (x, y); else if (SCM_REALP (y)) { double yy = SCM_REAL_VALUE (y); @@ -8098,6 +8217,9 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) The cast from 'scm_t_inum' to 'double' + (2) Double rounding */ return scm_from_double ((double) xx / yy); } else if (SCM_COMPLEXP (y)) @@ -8124,7 +8246,7 @@ do_divide (SCM x, SCM y, int inexact) else if (SCM_FRACTIONP (y)) /* a / b/c = ac / b */ return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), - SCM_FRACTION_NUMERATOR (y)); + SCM_FRACTION_NUMERATOR (y)); else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -8168,43 +8290,24 @@ do_divide (SCM x, SCM y, int inexact) return scm_i_normbig (result); } else - { - if (inexact) - return scm_from_double (scm_i_big2dbl (x) / (double) yy); - else return scm_i_make_ratio (x, y); - } + return scm_i_make_ratio (x, y); } } else if (SCM_BIGP (y)) { - /* big_x / big_y */ - if (inexact) - { - /* It's easily possible for the ratio x/y to fit a double - but one or both x and y be too big to fit a double, - hence the use of mpq_get_d rather than converting and - dividing. */ - mpq_t q; - *mpq_numref(q) = *SCM_I_BIG_MPZ (x); - *mpq_denref(q) = *SCM_I_BIG_MPZ (y); - return scm_from_double (mpq_get_d (q)); - } - else - { - int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - if (divisible_p) - { - SCM result = scm_i_mkbig (); - mpz_divexact (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_i_normbig (result); - } - else - return scm_i_make_ratio (x, y); - } + int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + if (divisible_p) + { + SCM result = scm_i_mkbig (); + mpz_divexact (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (result); + } + else + return scm_i_make_ratio (x, y); } else if (SCM_REALP (y)) { @@ -8214,6 +8317,8 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) scm_i_big2dbl (2) Double rounding */ return scm_from_double (scm_i_big2dbl (x) / yy); } else if (SCM_COMPLEXP (y)) @@ -8223,7 +8328,7 @@ do_divide (SCM x, SCM y, int inexact) } else if (SCM_FRACTIONP (y)) return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), - SCM_FRACTION_NUMERATOR (y)); + SCM_FRACTION_NUMERATOR (y)); else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -8238,10 +8343,16 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) The cast from 'scm_t_inum' to 'double' + (2) Double rounding */ return scm_from_double (rx / (double) yy); } else if (SCM_BIGP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from bignum to double + (2) Double rounding */ double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); scm_remember_upto_here_1 (y); return scm_from_double (rx / dby); @@ -8279,12 +8390,18 @@ do_divide (SCM x, SCM y, int inexact) else #endif { + /* FIXME: Precision may be lost here due to: + (1) The conversion from 'scm_t_inum' to double + (2) Double rounding */ double d = yy; return scm_c_make_rectangular (rx / d, ix / d); } } else if (SCM_BIGP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from bignum to double + (2) Double rounding */ double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); scm_remember_upto_here_1 (y); return scm_c_make_rectangular (rx / dby, ix / dby); @@ -8318,6 +8435,9 @@ do_divide (SCM x, SCM y, int inexact) } else if (SCM_FRACTIONP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from fraction to double + (2) Double rounding */ double yy = scm_i_fraction2double (y); return scm_c_make_rectangular (rx / yy, ix / yy); } @@ -8335,12 +8455,12 @@ do_divide (SCM x, SCM y, int inexact) else #endif return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x), - scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); } else if (SCM_BIGP (y)) { return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x), - scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); } else if (SCM_REALP (y)) { @@ -8350,33 +8470,28 @@ do_divide (SCM x, SCM y, int inexact) scm_num_overflow (s_divide); else #endif + /* FIXME: Precision may be lost here due to: + (1) The conversion from fraction to double + (2) Double rounding */ return scm_from_double (scm_i_fraction2double (x) / yy); } else if (SCM_COMPLEXP (y)) { + /* FIXME: Precision may be lost here due to: + (1) The conversion from fraction to double + (2) Double rounding */ a = scm_i_fraction2double (x); goto complex_div; } else if (SCM_FRACTIONP (y)) return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)), - scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))); + scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))); else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); } - -SCM -scm_divide (SCM x, SCM y) -{ - return do_divide (x, y, 0); -} - -static SCM scm_divide2real (SCM x, SCM y) -{ - return do_divide (x, y, 1); -} #undef FUNC_NAME @@ -9641,12 +9756,11 @@ log_of_fraction (SCM n, SCM d) log_of_exact_integer (d))); else if (scm_is_false (scm_negative_p (n))) return scm_from_double - (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d)))); + (log1p (scm_i_divide2double (scm_difference (n, d), d))); else return scm_c_make_rectangular - (log1p (scm_to_double (scm_divide2real - (scm_difference (scm_abs (n), d), - d))), + (log1p (scm_i_divide2double (scm_difference (scm_abs (n), d), + d)), M_PI); } @@ -9914,6 +10028,16 @@ scm_init_numbers () #endif exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2)); + + { + /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */ + mpz_init_set_ui (scm_i_divide2double_lo2b, 1); + mpz_mul_2exp (scm_i_divide2double_lo2b, + scm_i_divide2double_lo2b, + DBL_MANT_DIG + 1); /* 2 b^p */ + mpz_sub_ui (scm_i_divide2double_lo2b, scm_i_divide2double_lo2b, 1); + } + #include "libguile/numbers.x" } diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 550dc502f..5a77e93ab 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -56,6 +56,9 @@ (define dbl-epsilon (expt 0.5 (- dbl-mant-dig 1))) +(define dbl-epsilon-exact + (expt 1/2 (- dbl-mant-dig 1))) + (define dbl-min-exp (do ((x 1.0 (/ x 2.0)) (y (+ 1.0 dbl-epsilon) (/ y 2.0)) @@ -65,6 +68,14 @@ (= x y)) e))) +(define dbl-max-exp + (do ((x 1.0 (* x 2.0)) + (e 0 (+ e 1))) + ((begin (when (> e 100000000) + (error "Unable to determine dbl-max-exp")) + (inf? x)) + e))) + ;; like ash, but working on a flonum (define (ash-flo x n) (while (> n 0) @@ -3985,7 +3996,120 @@ ;; 11111111111111111111111111111111111111111111111111111100 -> ;; 100000000000000000000000000000000000000000000000000000000 (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b111100) - (expt 2.0 (+ dbl-mant-dig 3)))) + (expt 2.0 (+ dbl-mant-dig 3))) + + (test "miniscule value rounds to zero of appropriate sign" + (expt 17 (- dbl-min-exp dbl-mant-dig)) + 0.0) + + (test "smallest inexact" + (expt 2 (- dbl-min-exp dbl-mant-dig)) + (expt 2.0 (- dbl-min-exp dbl-mant-dig))) + + (test "1/2 smallest inexact rounds down to zero" + (* 1/2 (expt 2 (- dbl-min-exp dbl-mant-dig))) + 0.0) + + (test "just over 1/2 smallest inexact rounds up" + (+ (* 1/2 (expt 2 (- dbl-min-exp dbl-mant-dig))) + (expt 7 (- dbl-min-exp dbl-mant-dig))) + (expt 2.0 (- dbl-min-exp dbl-mant-dig))) + + (test "3/2 smallest inexact rounds up to twice smallest inexact" + (* 3/2 (expt 2 (- dbl-min-exp dbl-mant-dig))) + (* 2.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig)))) + + (test "just under 3/2 smallest inexact rounds down" + (- (* 3/2 (expt 2 (- dbl-min-exp dbl-mant-dig))) + (expt 11 (- dbl-min-exp dbl-mant-dig))) + (expt 2.0 (- dbl-min-exp dbl-mant-dig))) + + (test "5/2 smallest inexact rounds down to twice smallest inexact" + (* 5/2 (expt 2 (- dbl-min-exp dbl-mant-dig))) + (* 2.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig)))) + + (test "just over 5/2 smallest inexact rounds up" + (+ (* 5/2 (expt 2 (- dbl-min-exp dbl-mant-dig))) + (expt 13 (- dbl-min-exp dbl-mant-dig))) + (* 3.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig)))) + + (test "one plus dbl-epsilon" + (+ 1 dbl-epsilon-exact) + (+ 1.0 dbl-epsilon)) + + (test "one plus 1/2 dbl-epsilon rounds down to 1.0" + (+ 1 (* 1/2 dbl-epsilon-exact)) + 1.0) + + (test "just over one plus 1/2 dbl-epsilon rounds up" + (+ 1 + (* 1/2 dbl-epsilon-exact) + (expt 13 (- dbl-min-exp dbl-mant-dig))) + (+ 1.0 dbl-epsilon)) + + (test "one plus 3/2 dbl-epsilon rounds up" + (+ 1 (* 3/2 dbl-epsilon-exact)) + (+ 1.0 (* 2.0 dbl-epsilon))) + + (test "just under one plus 3/2 dbl-epsilon rounds down" + (+ 1 + (* 3/2 dbl-epsilon-exact) + (- (expt 17 (- dbl-min-exp dbl-mant-dig)))) + (+ 1.0 dbl-epsilon)) + + (test "one plus 5/2 dbl-epsilon rounds down" + (+ 1 (* 5/2 dbl-epsilon-exact)) + (+ 1.0 (* 2.0 dbl-epsilon))) + + (test "just over one plus 5/2 dbl-epsilon rounds up" + (+ 1 + (* 5/2 dbl-epsilon-exact) + (expt 13 (- dbl-min-exp dbl-mant-dig))) + (+ 1.0 (* 3.0 dbl-epsilon))) + + (test "largest finite inexact" + (* (- (expt 2 dbl-mant-dig) 1) + (expt 2 (- dbl-max-exp dbl-mant-dig))) + (* (- (expt 2.0 dbl-mant-dig) 1) + (expt 2.0 (- dbl-max-exp dbl-mant-dig)))) + + (test "largest finite inexact plus 1/2 epsilon rounds up to infinity" + (* (+ (expt 2 dbl-mant-dig) -1 1/2) + (expt 2 (- dbl-max-exp dbl-mant-dig))) + (inf)) + + (test "largest finite inexact plus just under 1/2 epsilon rounds down" + (* (+ (expt 2 dbl-mant-dig) -1 1/2 + (- (expt 13 (- dbl-min-exp dbl-mant-dig)))) + (expt 2 (- dbl-max-exp dbl-mant-dig))) + (* (- (expt 2.0 dbl-mant-dig) 1) + (expt 2.0 (- dbl-max-exp dbl-mant-dig)))) + + (test "1/2 largest finite inexact" + (* (- (expt 2 dbl-mant-dig) 1) + (expt 2 (- dbl-max-exp dbl-mant-dig 1))) + (* (- (expt 2.0 dbl-mant-dig) 1) + (expt 2.0 (- dbl-max-exp dbl-mant-dig 1)))) + + (test "1/2 largest finite inexact plus 1/2 epsilon rounds up to next power of two" + (* (+ (expt 2 dbl-mant-dig) -1 1/2) + (expt 2 (- dbl-max-exp dbl-mant-dig 1))) + (expt 2.0 (- dbl-max-exp 1))) + + (test "1/2 largest finite inexact plus just over 1/2 epsilon rounds up to next power of two" + (* (+ (expt 2 dbl-mant-dig) -1 1/2 + (expt 13 (- dbl-min-exp dbl-mant-dig))) + (expt 2 (- dbl-max-exp dbl-mant-dig 1))) + (expt 2.0 (- dbl-max-exp 1))) + + (test "1/2 largest finite inexact plus just under 1/2 epsilon rounds down" + (* (+ (expt 2 dbl-mant-dig) -1 1/2 + (- (expt 13 (- dbl-min-exp dbl-mant-dig)))) + (expt 2 (- dbl-max-exp dbl-mant-dig 1))) + (* (- (expt 2.0 dbl-mant-dig) 1) + (expt 2.0 (- dbl-max-exp dbl-mant-dig 1)))) + + ) ;;; ;;; expt @@ -4302,6 +4426,12 @@ (* (expt 0.5 48) (- (expt 2.0 dbl-mant-dig) 1)) (* (expt 1/2 48) (- (expt 2 dbl-mant-dig) 1))) + (test "largest finite inexact" + (* (- (expt 2.0 dbl-mant-dig) 1) + (expt 2.0 (- dbl-max-exp dbl-mant-dig))) + (* (- (expt 2 dbl-mant-dig) 1) + (expt 2 (- dbl-max-exp dbl-mant-dig)))) + (test "smallest inexact" (expt 2.0 (- dbl-min-exp dbl-mant-dig)) (expt 2 (- dbl-min-exp dbl-mant-dig))) From 1ea37620c2c1794f7685b312d2530676a078ada7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 5 Mar 2013 05:47:56 -0500 Subject: [PATCH 105/147] Reimplement idbl2str number printer. Fixes <http://bugs.gnu.org/13757>. * libguile/numbers.c (idbl2str): Reimplement. (mem2decimal_from_point): Accept negative exponents larger than SCM_MAXEXP that produce subnormals. (SCM_MAX_DBL_PREC): Removed preprocessor macro. (scm_dblprec, fx_per_radix): Removed static variables. (init_dblprec, init_fx_radix): Removed static functions. (scm_init_numbers): Remove initialization code for 'scm_dblprec' and 'fx_per_radix'. * test-suite/tests/numbers.test ("number->string"): Restore tests that previously failed. Remove comments about problems in the number printer that are now fixed. --- libguile/numbers.c | 395 ++++++++++++++++------------------ test-suite/tests/numbers.test | 97 +++++++-- 2 files changed, 256 insertions(+), 236 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index f6327339e..c641e3fbd 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5250,229 +5250,201 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, #undef FUNC_NAME /*** NUMBERS -> STRINGS ***/ -#define SCM_MAX_DBL_PREC 60 #define SCM_MAX_DBL_RADIX 36 -/* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */ -static int scm_dblprec[SCM_MAX_DBL_RADIX - 1]; -static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC]; - -static -void init_dblprec(int *prec, int radix) { - /* determine floating point precision by adding successively - smaller increments to 1.0 until it is considered == 1.0 */ - double f = ((double)1.0)/radix; - double fsum = 1.0 + f; - - *prec = 0; - while (fsum != 1.0) - { - if (++(*prec) > SCM_MAX_DBL_PREC) - fsum = 1.0; - else - { - f /= radix; - fsum = f + 1.0; - } - } - (*prec) -= 1; -} - -static -void init_fx_radix(double *fx_list, int radix) -{ - /* initialize a per-radix list of tolerances. When added - to a number < 1.0, we can determine if we should raund - up and quit converting a number to a string. */ - int i; - fx_list[0] = 0.0; - fx_list[1] = 0.5; - for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i ) - fx_list[i] = (fx_list[i-1] / radix); -} - /* use this array as a way to generate a single digit */ static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz"; +static mpz_t dbl_minimum_normal_mantissa; + static size_t -idbl2str (double f, char *a, int radix) +idbl2str (double dbl, char *a, int radix) { - int efmt, dpt, d, i, wp; - double *fx; -#ifdef DBL_MIN_10_EXP - double f_cpy; - int exp_cpy; -#endif /* DBL_MIN_10_EXP */ - size_t ch = 0; - int exp = 0; + int ch = 0; - if(radix < 2 || - radix > SCM_MAX_DBL_RADIX) - { - /* revert to existing behavior */ - radix = 10; - } + if (radix < 2 || radix > SCM_MAX_DBL_RADIX) + /* revert to existing behavior */ + radix = 10; - wp = scm_dblprec[radix-2]; - fx = fx_per_radix[radix-2]; - - if (f == 0.0) + if (isinf (dbl)) { -#ifdef HAVE_COPYSIGN - double sgn = copysign (1.0, f); - - if (sgn < 0.0) - a[ch++] = '-'; -#endif - goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ + strcpy (a, (dbl > 0.0) ? "+inf.0" : "-inf.0"); + return 6; } - - if (isinf (f)) + else if (dbl > 0.0) + ; + else if (dbl < 0.0) { - if (f < 0) - strcpy (a, "-inf.0"); - else - strcpy (a, "+inf.0"); - return ch+6; - } - else if (isnan (f)) - { - strcpy (a, "+nan.0"); - return ch+6; - } - - if (f < 0.0) - { - f = -f; + dbl = -dbl; a[ch++] = '-'; } - -#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from - make-uniform-vector, from causing infinite loops. */ - /* just do the checking...if it passes, we do the conversion for our - radix again below */ - f_cpy = f; - exp_cpy = exp; - - while (f_cpy < 1.0) + else if (dbl == 0.0) { - f_cpy *= 10.0; - if (exp_cpy-- < DBL_MIN_10_EXP) - { - a[ch++] = '#'; - a[ch++] = '.'; - a[ch++] = '#'; - return ch; - } + if (!double_is_non_negative_zero (dbl)) + a[ch++] = '-'; + strcpy (a + ch, "0.0"); + return ch + 3; } - while (f_cpy > 10.0) + else if (isnan (dbl)) { - f_cpy *= 0.10; - if (exp_cpy++ > DBL_MAX_10_EXP) - { - a[ch++] = '#'; - a[ch++] = '.'; - a[ch++] = '#'; - return ch; - } - } -#endif - - while (f < 1.0) - { - f *= radix; - exp--; - } - while (f > radix) - { - f /= radix; - exp++; + strcpy (a, "+nan.0"); + return 6; } - if (f + fx[wp] >= radix) - { - f = 1.0; - exp++; - } - zero: -#ifdef ENGNOT - /* adding 9999 makes this equivalent to abs(x) % 3 */ - dpt = (exp + 9999) % 3; - exp -= dpt++; - efmt = 1; -#else - efmt = (exp < -3) || (exp > wp + 2); - if (!efmt) - { - if (exp < 0) - { - a[ch++] = '0'; - a[ch++] = '.'; - dpt = exp; - while (++dpt) - a[ch++] = '0'; - } - else - dpt = exp + 1; - } - else - dpt = 1; -#endif + /* Algorithm taken from "Printing Floating-Point Numbers Quickly and + Accurately" by Robert G. Burger and R. Kent Dybvig */ + { + int e, k; + mpz_t f, r, s, mplus, mminus, hi, digit; + int f_is_even, f_is_odd; + int show_exp = 0; - do - { - d = f; - f -= d; - a[ch++] = number_chars[d]; - if (f < fx[wp]) - break; - if (f + fx[wp] >= 1.0) - { - a[ch - 1] = number_chars[d+1]; - break; - } - f *= radix; - if (!(--dpt)) - a[ch++] = '.'; - } - while (wp--); + mpz_inits (f, r, s, mplus, mminus, hi, digit, NULL); + mpz_set_d (f, ldexp (frexp (dbl, &e), DBL_MANT_DIG)); + if (e < DBL_MIN_EXP) + { + mpz_tdiv_q_2exp (f, f, DBL_MIN_EXP - e); + e = DBL_MIN_EXP; + } + e -= DBL_MANT_DIG; - if (dpt > 0) + f_is_even = !mpz_odd_p (f); + f_is_odd = !f_is_even; + + /* Initialize r, s, mplus, and mminus according + to Table 1 from the paper. */ + if (e < 0) + { + mpz_set_ui (mminus, 1); + if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0 + || e == DBL_MIN_EXP - DBL_MANT_DIG) + { + mpz_set_ui (mplus, 1); + mpz_mul_2exp (r, f, 1); + mpz_mul_2exp (s, mminus, 1 - e); + } + else + { + mpz_set_ui (mplus, 2); + mpz_mul_2exp (r, f, 2); + mpz_mul_2exp (s, mminus, 2 - e); + } + } + else + { + mpz_set_ui (mminus, 1); + mpz_mul_2exp (mminus, mminus, e); + if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0) + { + mpz_set (mplus, mminus); + mpz_mul_2exp (r, f, 1 + e); + mpz_set_ui (s, 2); + } + else + { + mpz_mul_2exp (mplus, mminus, 1); + mpz_mul_2exp (r, f, 2 + e); + mpz_set_ui (s, 4); + } + } + + /* Find the smallest k such that: + (r + mplus) / s < radix^k (if f is even) + (r + mplus) / s <= radix^k (if f is odd) */ { -#ifndef ENGNOT - if ((dpt > 4) && (exp > 6)) - { - d = (a[0] == '-' ? 2 : 1); - for (i = ch++; i > d; i--) - a[i] = a[i - 1]; - a[d] = '.'; - efmt = 1; - } - else -#endif - { - while (--dpt) - a[ch++] = '0'; - a[ch++] = '.'; - } - } - if (a[ch - 1] == '.') - a[ch++] = '0'; /* trailing zero */ - if (efmt && exp) - { - a[ch++] = 'e'; - if (exp < 0) - { - exp = -exp; - a[ch++] = '-'; - } - for (i = radix; i <= exp; i *= radix); - for (i /= radix; i; i /= radix) - { - a[ch++] = number_chars[exp / i]; - exp %= i; - } + /* IMPROVE-ME: Make an initial guess to speed this up */ + mpz_add (hi, r, mplus); + k = 0; + while (mpz_cmp (hi, s) >= f_is_odd) + { + mpz_mul_ui (s, s, radix); + k++; + } + if (k == 0) + { + mpz_mul_ui (hi, hi, radix); + while (mpz_cmp (hi, s) < f_is_odd) + { + mpz_mul_ui (r, r, radix); + mpz_mul_ui (mplus, mplus, radix); + mpz_mul_ui (mminus, mminus, radix); + mpz_mul_ui (hi, hi, radix); + k--; + } + } } + + if (k >= 8 || k <= -3) + { + /* Use scientific notation */ + show_exp = k - 1; + k = 1; + } + else if (k <= 0) + { + int i; + + /* Print leading zeroes */ + a[ch++] = '0'; + a[ch++] = '.'; + for (i = 0; i > k; i--) + a[ch++] = '0'; + } + + for (;;) + { + int end_1_p, end_2_p; + int d; + + mpz_mul_ui (mplus, mplus, radix); + mpz_mul_ui (mminus, mminus, radix); + mpz_mul_ui (r, r, radix); + mpz_fdiv_qr (digit, r, r, s); + d = mpz_get_ui (digit); + + mpz_add (hi, r, mplus); + end_1_p = (mpz_cmp (r, mminus) < f_is_even); + end_2_p = (mpz_cmp (s, hi) < f_is_even); + if (end_1_p || end_2_p) + { + mpz_mul_2exp (r, r, 1); + if (!end_2_p) + ; + else if (!end_1_p) + d++; + else if (mpz_cmp (r, s) >= !(d & 1)) + d++; + a[ch++] = number_chars[d]; + if (--k == 0) + a[ch++] = '.'; + break; + } + else + { + a[ch++] = number_chars[d]; + if (--k == 0) + a[ch++] = '.'; + } + } + + if (k > 0) + { + for (; k > 0; k--) + a[ch++] = '0'; + a[ch++] = '.'; + } + + if (k == 0) + a[ch++] = '0'; + + if (show_exp) + { + a[ch++] = 'e'; + ch += scm_iint2str (show_exp, radix, a + ch); + } + + mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL); + } return ch; } @@ -5956,7 +5928,7 @@ mem2decimal_from_point (SCM result, SCM mem, break; } - if (exponent > SCM_MAXEXP) + if (exponent > ((sign == 1) ? SCM_MAXEXP : SCM_MAXEXP + DBL_DIG + 1)) { size_t exp_len = idx - start; SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len); @@ -9993,8 +9965,6 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, void scm_init_numbers () { - int i; - if (scm_install_gmp_memory_functions) mp_set_memory_functions (custom_gmp_malloc, custom_gmp_realloc, @@ -10016,17 +9986,6 @@ scm_init_numbers () flo0 = scm_from_double (0.0); flo_log10e = scm_from_double (M_LOG10E); - /* determine floating point precision */ - for (i=2; i <= SCM_MAX_DBL_RADIX; ++i) - { - init_dblprec(&scm_dblprec[i-2],i); - init_fx_radix(fx_per_radix[i-2],i); - } -#ifdef DBL_DIG - /* hard code precision for base 10 if the preprocessor tells us to... */ - scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG; -#endif - exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2)); { @@ -10038,6 +9997,14 @@ scm_init_numbers () mpz_sub_ui (scm_i_divide2double_lo2b, scm_i_divide2double_lo2b, 1); } + { + /* Set dbl_minimum_normal_mantissa to b^{p-1} */ + mpz_init_set_ui (dbl_minimum_normal_mantissa, 1); + mpz_mul_2exp (dbl_minimum_normal_mantissa, + dbl_minimum_normal_mantissa, + DBL_MANT_DIG - 1); + } + #include "libguile/numbers.x" } diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 5a77e93ab..8f01633db 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1383,21 +1383,39 @@ (lambda (n radix) (string->number (number->string n radix) radix)))) + (define (test num) + (pass-if-equal (list num 'pos) + num + (num->str->num num 10)) + (pass-if-equal (list num 'neg) + (- num) + (num->str->num (- num) 10))) + (pass-if (documented? number->string)) (pass-if (string=? (number->string 0) "0")) (pass-if (string=? (number->string 171) "171")) (pass-if (= (+ fixnum-max 1) (num->str->num (+ fixnum-max 1) 10))) (pass-if (= (- fixnum-min 1) (num->str->num (- fixnum-min 1) 10))) - (pass-if (= (inf) (num->str->num (inf) 10))) - (pass-if (= 1.3 (num->str->num 1.3 10))) - ;; XXX - some results depend on whether Guile is compiled optimzed - ;; or not. It is clearly undesirable to have number->string to be - ;; influenced by this. + (test (inf)) + (test 1.3) + (test (acos -1)) ; pi + (test (exp 1)) ; e + (test (/ 3.0)) + (test (/ 7.0)) + (test 2.2250738585072011e-308) + (test 2.2250738585072012e-308) + + ;; Largest finite inexact + (test (* (- (expt 2.0 dbl-mant-dig) 1) + (expt 2.0 (- dbl-max-exp dbl-mant-dig)))) + + (pass-if (string=? "0.0" (number->string 0.0))) + (pass-if (or (eqv? 0.0 -0.0) + (string=? "-0.0" (number->string -0.0)))) (pass-if (string=? (number->string 35.25 36) "z.9")) - (pass-if (or (string=? (number->string 0.25 2) "0.01") - (string=? (number->string 0.25 2) "0.010"))) + (pass-if (string=? (number->string 0.25 2) "0.01")) (pass-if (string=? (number->string 255.0625 16) "ff.1")) (pass-if (string=? (number->string (/ 1 3) 3) "1/10")) @@ -1411,26 +1429,61 @@ (pass-if (string=? (number->string 35 36) "z")) (pass-if (= (num->str->num 35 36) 35)) + (with-test-prefix "powers of radix" + (for-each + (lambda (radix) + (for-each (lambda (k) + (let ((val (exact->inexact (expt radix k))) + (str (if (<= -3 k 6) + (assoc-ref '((-3 . "0.001") + (-2 . "0.01") + (-1 . "0.1") + ( 0 . "1.0") + ( 1 . "10.0") + ( 2 . "100.0") + ( 3 . "1000.0") + ( 4 . "10000.0") + ( 5 . "100000.0") + ( 6 . "1000000.0")) + k) + (string-append "1.0e" + (number->string k radix))))) + (pass-if-equal (list radix k 'pos) + str + (number->string val radix)) + (pass-if-equal (list radix k 'neg) + (string-append "-" str) + (number->string (- val) radix)))) + (iota 41 -20))) + (iota 35 2))) + + (with-test-prefix "multiples of smallest inexact" + (for-each (lambda (k) + (let ((val (* k (expt 2.0 (- dbl-min-exp dbl-mant-dig))))) + (test val))) + (iota 40 1))) + + (with-test-prefix "one plus multiples of epsilon" + (for-each (lambda (k) + (let ((val (+ 1.0 (* k dbl-epsilon)))) + (test val))) + (iota 40 1))) + + (with-test-prefix "one minus multiples of 1/2 epsilon" + (for-each (lambda (k) + (let ((val (- 1.0 (* k 1/2 dbl-epsilon)))) + (test val))) + (iota 40 1))) + ;; Before Guile 2.0.1, even in the presence of a #e forced exactness ;; specifier, negative exponents were applied inexactly and then ;; later coerced to exact, yielding an incorrect fraction. (pass-if (eqv? (string->number "#e1e-10") 1/10000000000)) - ;; Numeric conversion from decimal is not precise, in its current - ;; implementation, so 11.333... and 1.324... can't be expected to - ;; reliably come out to precise values. These tests did actually work - ;; for a while, but something in gcc changed, affecting the conversion - ;; code. - ;; - ;; (pass-if (or (string=? (number->string 11.33333333333333333 12) - ;; "B.4") - ;; (string=? (number->string 11.33333333333333333 12) - ;; "B.400000000000009"))) - ;; (pass-if (or (string=? (number->string 1.324e44 16) - ;; "5.EFE0A14FAFEe24") - ;; (string=? (number->string 1.324e44 16) - ;; "5.EFE0A14FAFDF8e24"))) - )) + (pass-if (string=? (number->string 11.33333333333333333 12) + "b.4")) + (pass-if (string=? (number->string 1.324e44 16) + "5.efe0a14fafdf8e24")))) ;;; ;;; string->number From 5f24f1b53ed2c1746670ae8828a05cc7b63354e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 18 Mar 2013 21:28:05 +0100 Subject: [PATCH 106/147] Define the new Linux-specific `SO_REUSEPORT'. * libguile/socket.c (scm_init_socket)[SO_REUSEPORT]: Define `SO_REUSEPORT'. (scm_setsockopt, scm_getsockopt): Update docstring. * doc/ref/posix.texi (Network Sockets and Communication): List `SO_REUSEPORT'. --- doc/ref/posix.texi | 1 + libguile/socket.c | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 18aadca85..d659cf391 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -3051,6 +3051,7 @@ Manual}, or @command{man 7 socket}. @defvarx SO_OOBINLINE @defvarx SO_NO_CHECK @defvarx SO_PRIORITY +@defvarx SO_REUSEPORT The @var{value} taken or returned is an integer. @end defvar diff --git a/libguile/socket.c b/libguile/socket.c index bed069b83..fd5bea87c 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -510,6 +510,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, "@defvarx SO_OOBINLINE\n" "@defvarx SO_NO_CHECK\n" "@defvarx SO_PRIORITY\n" + "@defvarx SO_REUSEPORT\n" "The value returned is an integer.\n" "@end defvar\n" "\n" @@ -608,6 +609,7 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, "@defvarx SO_OOBINLINE\n" "@defvarx SO_NO_CHECK\n" "@defvarx SO_PRIORITY\n" + "@defvarx SO_REUSEPORT\n" "@var{value} is an integer.\n" "@end defvar\n" "\n" @@ -1856,6 +1858,9 @@ scm_init_socket () #ifdef SO_LINGER scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER)); #endif +#ifdef SO_REUSEPORT /* new in Linux 3.9 */ + scm_c_define ("SO_REUSEPORT", scm_from_int (SO_REUSEPORT)); +#endif /* recv/send options. */ #ifdef MSG_DONTWAIT From e5029c585382471f81717f8e1539854d90579512 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 18 Mar 2013 21:31:50 +0100 Subject: [PATCH 107/147] Use byte-oriented functions in `get-bytevector*'. * libguile/r6rs-ports.c (scm_get_bytevector_some, scm_get_bytevector_n, scm_get_bytevector_n_x, scm_get_bytevector_all): Use `scm_get_byte_or_eof' and `scm_peek_byte_or_eof' instead of their `char' counterparts. Reported by Chris K. Jester-Young. --- libguile/r6rs-ports.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index e8674299d..d5fcd2076 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011, 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 License @@ -498,7 +498,7 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, if ((c_read == 0) && (c_count > 0)) { - if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + if (scm_peek_byte_or_eof (port) == EOF) result = SCM_EOF_VAL; else result = scm_null_bytevector; @@ -545,7 +545,7 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, if ((c_read == 0) && (c_count > 0)) { - if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + if (scm_peek_byte_or_eof (port) == EOF) result = SCM_EOF_VAL; else result = SCM_I_MAKINUM (0); @@ -593,15 +593,17 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, } /* We can't use `scm_c_read ()' since it blocks. */ - c_chr = scm_getc (port); + c_chr = scm_get_byte_or_eof (port); if (c_chr != EOF) { c_bv[c_total] = (char) c_chr; c_total++; } } - while ((scm_is_true (scm_char_ready_p (port))) - && (!SCM_EOF_OBJECT_P (scm_peek_char (port)))); + /* XXX: We want to check for the availability of a byte, but that's + what `scm_char_ready_p' actually does. */ + while (scm_is_true (scm_char_ready_p (port)) + && (scm_peek_byte_or_eof (port) != EOF)); if (c_total == 0) { @@ -660,7 +662,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, c_read = scm_c_read (port, c_bv + c_total, c_count); c_total += c_read, c_count -= c_read; } - while (!SCM_EOF_OBJECT_P (scm_peek_char (port))); + while (scm_peek_byte_or_eof (port) != EOF); if (c_total == 0) { From a9ea4f909b9970c755b0a7c4cd9da907e66496fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 18 Mar 2013 22:28:23 +0100 Subject: [PATCH 108/147] Avoid rebuild of `guile.info' at the user's site. * configure.ac: Remove `doc/ref/effective-version.texi' from the `AC_CONFIG_FILES'. * doc/ref/Makefile.am ($(srcdir)/effective-version.texi): New target. --- configure.ac | 1 - doc/ref/Makefile.am | 7 +++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index af6afcc77..42de73307 100644 --- a/configure.ac +++ b/configure.ac @@ -1635,7 +1635,6 @@ AC_CONFIG_FILES([ AC_CONFIG_FILES([meta/guile-2.0.pc]) AC_CONFIG_FILES([meta/guile-2.0-uninstalled.pc]) -AC_CONFIG_FILES([doc/ref/effective-version.texi]) GUILE_CONFIG_SCRIPT([check-guile]) GUILE_CONFIG_SCRIPT([benchmark-guile]) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 4b1706e2b..d0ea94d51 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -123,6 +123,13 @@ autoconf-macros.texi: $(top_srcdir)/meta/guile.m4 snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ > $(srcdir)/$@ +# Build that file from here rather than at the user's site to avoid +# triggering a rebuild of `guile.info'. Note that `GUILE-VERSION' is +# among $(CONFIG_STATUS_DEPENDENCIES); thus, when it's updated, this +# Makefile is rebuilt, and $(GUILE_EFFECTIVE_VERSION) is up-to-date. +$(srcdir)/effective-version.texi: $(top_srcdir)/GUILE-VERSION + echo "@set EFFECTIVE-VERSION $(GUILE_EFFECTIVE_VERSION)" > $@ + MAINTAINERCLEANFILES = autoconf-macros.texi www-commit: html From 8150dfa1f2f84d151ced5f723dc69ce0cae1cd32 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 19 Mar 2013 03:25:59 -0400 Subject: [PATCH 109/147] Use scientific notation only if there are enough trailing zeroes. * libguile/numbers.c (idbl2str): Print large numbers in scientific notation only if the exponent is >= 7 and the least significant non-zero digit has value >= radix^4. * test-suite/tests/numbers.test ("number->string"): Add tests. --- libguile/numbers.c | 63 +++++++++++++++++++++++++---------- test-suite/tests/numbers.test | 4 +++ 2 files changed, 50 insertions(+), 17 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index c641e3fbd..1f845a365 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5297,6 +5297,7 @@ idbl2str (double dbl, char *a, int radix) int e, k; mpz_t f, r, s, mplus, mminus, hi, digit; int f_is_even, f_is_odd; + int expon; int show_exp = 0; mpz_inits (f, r, s, mplus, mminus, hi, digit, NULL); @@ -5374,21 +5375,25 @@ idbl2str (double dbl, char *a, int radix) } } - if (k >= 8 || k <= -3) + expon = k - 1; + if (k <= 0) { - /* Use scientific notation */ - show_exp = k - 1; - k = 1; - } - else if (k <= 0) - { - int i; + if (k <= -3) + { + /* Use scientific notation */ + show_exp = 1; + k = 1; + } + else + { + int i; - /* Print leading zeroes */ - a[ch++] = '0'; - a[ch++] = '.'; - for (i = 0; i > k; i--) - a[ch++] = '0'; + /* Print leading zeroes */ + a[ch++] = '0'; + a[ch++] = '.'; + for (i = 0; i > k; i--) + a[ch++] = '0'; + } } for (;;) @@ -5429,9 +5434,33 @@ idbl2str (double dbl, char *a, int radix) if (k > 0) { - for (; k > 0; k--) - a[ch++] = '0'; - a[ch++] = '.'; + if (expon >= 7 && k >= 4 && expon >= k) + { + /* Here we would have to print more than three zeroes + followed by a decimal point and another zero. It + makes more sense to use scientific notation. */ + + /* Adjust k to what it would have been if we had chosen + scientific notation from the beginning. */ + k -= expon; + + /* k will now be <= 0, with magnitude equal to the number of + digits that we printed which should now be put after the + decimal point. */ + + /* Insert a decimal point */ + memmove (a + ch + k + 1, a + ch + k, -k); + a[ch + k] = '.'; + ch++; + + show_exp = 1; + } + else + { + for (; k > 0; k--) + a[ch++] = '0'; + a[ch++] = '.'; + } } if (k == 0) @@ -5440,7 +5469,7 @@ idbl2str (double dbl, char *a, int radix) if (show_exp) { a[ch++] = 'e'; - ch += scm_iint2str (show_exp, radix, a + ch); + ch += scm_iint2str (expon, radix, a + ch); } mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 8f01633db..be2e31732 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1429,6 +1429,10 @@ (pass-if (string=? (number->string 35 36) "z")) (pass-if (= (num->str->num 35 36) 35)) + (pass-if (string=? (number->string 12342342340000.0) "1.234234234e13")) + (pass-if (string=? (number->string 1234234234000.0) "1234234234000.0")) + (pass-if (string=? (number->string 1240000.0) "1240000.0")) + (with-test-prefix "powers of radix" (for-each (lambda (radix) From 1d64b4edb9da4011ad06c0fab1c6225ec20b0876 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Mon, 18 Mar 2013 20:01:12 -0400 Subject: [PATCH 110/147] SRFI-45: Support multiple values; add promise? predicate. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/srfi/srfi-45.scm (eager): Accept any number of arguments. Store the list of arguments in the value record. Previously, only one argument was accepted, and that value was stored in the value record. (delay): Support expressions that return any number of arguments. (force): Return the list of values stored in the value record. (promise?): Export. * doc/ref/srfi-modules.texi (SRFI-45): Update docs. Remove typing for simplicity in discussing multiple values. * test-suite/tests/srfi-45.test: Add tests. Add FSF copyright for 2010 and 2013. Add missing year to André van Tonder's copyright notice. --- doc/ref/srfi-modules.texi | 57 +++++++++++++++++++++-------------- module/srfi/srfi-45.scm | 21 +++++++------ test-suite/tests/srfi-45.test | 43 +++++++++++++++++++++++++- 3 files changed, 89 insertions(+), 32 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index af1afc013..e60dbb4e1 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3833,45 +3833,58 @@ words, no program that uses the R5RS definitions of delay and force will break if those definition are replaced by the SRFI-45 definitions of delay and force. +Guile compatibly extends SRFI-45 to support multiple values. It also +adds @code{promise?} to the list of exports. + +@deffn {Scheme Procedure} promise? obj +Return true if @var{obj} is an SRFI-45 promise, otherwise return false. +@end deffn + @deffn {Scheme Syntax} delay expression -Takes an expression of arbitrary type @var{a} and returns a promise of -type @code{(Promise @var{a})} which at some point in the future may be -asked (by the @code{force} procedure) to evaluate the expression and -deliver the resulting value. +Takes an expression and returns a promise which at some point in the +future may be asked (by the @code{force} procedure) to evaluate the +expression and deliver the resulting value(s). @end deffn @deffn {Scheme Syntax} lazy expression -Takes an expression of type @code{(Promise @var{a})} and returns a -promise of type @code{(Promise @var{a})} which at some point in the -future may be asked (by the @code{force} procedure) to evaluate the -expression and deliver the resulting promise. +Takes an expression (which must evaluate to a promise) and returns a +promise which at some point in the future may be asked (by the +@code{force} procedure) to evaluate the expression and deliver the +resulting promise. @end deffn -@deffn {Scheme Procedure} force expression -Takes an argument of type @code{(Promise @var{a})} and returns a value -of type @var{a} as follows: If a value of type @var{a} has been computed -for the promise, this value is returned. Otherwise, the promise is -first evaluated, then overwritten by the obtained promise or value, and -then force is again applied (iteratively) to the promise. +@deffn {Scheme Procedure} force promise +Takes a promise and returns the associated value(s) as follows: If +value(s) have been computed for the promise, these value(s) are +returned. Otherwise, the promise is first evaluated, then overwritten +by the obtained promise or value(s), and then force is again applied +(iteratively) to the promise. @end deffn -@deffn {Scheme Procedure} eager expression -Takes an argument of type @var{a} and returns a value of type -@code{(Promise @var{a})}. As opposed to @code{delay}, the argument is -evaluated eagerly. Semantically, writing @code{(eager expression)} is -equivalent to writing +@deffn {Scheme Procedure} eager obj ... +Takes any number of argument(s) and returns a promise. As opposed to +@code{delay}, the argument(s) are evaluated eagerly. Semantically, +writing @code{(eager expression)} is equivalent to writing @lisp (let ((value expression)) (delay value)). @end lisp However, the former is more efficient since it does not require -unnecessary creation and evaluation of thunks. We also have the -equivalence +unnecessary creation and evaluation of thunks. For expressions that +return a single value, we also have the equivalence @lisp (delay expression) = (lazy (eager expression)) @end lisp + +More generally, the following equivalence holds: + +@lisp +(delay expression) = (lazy (call-with-values + (lambda () expression) + eager)) +@end lisp @end deffn The following reduction rules may be helpful for reasoning about these @@ -3881,7 +3894,7 @@ usage semantics specified above: @lisp (force (delay expression)) -> expression (force (lazy expression)) -> (force expression) -(force (eager value)) -> value +(force (eager obj ...)) -> (values obj ...) @end lisp @subsubheading Correct usage diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm index 29b0393ff..47e3ba605 100644 --- a/module/srfi/srfi-45.scm +++ b/module/srfi/srfi-45.scm @@ -1,6 +1,6 @@ ;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. ;; Copyright (C) 2003 André van Tonder. All Rights Reserved. ;; Permission is hereby granted, free of charge, to any person @@ -25,8 +25,8 @@ ;;; Commentary: -;; This is the code of the reference implementation of SRFI-45, slightly -;; modified to use SRFI-9. +;; This is the code of the reference implementation of SRFI-45, +;; modified to use SRFI-9 and to support multiple values. ;; This module is documented in the Guile Reference Manual. @@ -36,8 +36,9 @@ #:export (delay lazy force - eager) - #:replace (delay force) + eager + promise?) + #:replace (delay force promise?) #:use-module (srfi srfi-9)) (define-record-type promise (make-promise val) promise? @@ -50,16 +51,18 @@ (define-syntax-rule (lazy exp) (make-promise (make-value 'lazy (lambda () exp)))) -(define (eager x) - (make-promise (make-value 'eager x))) +(define (eager . xs) + (make-promise (make-value 'eager xs))) (define-syntax-rule (delay exp) - (lazy (eager exp))) + (lazy (call-with-values + (lambda () exp) + eager))) (define (force promise) (let ((content (promise-val promise))) (case (value-tag content) - ((eager) (value-proc content)) + ((eager) (apply values (value-proc content))) ((lazy) (let* ((promise* ((value-proc content))) (content (promise-val promise))) ; * (if (not (eqv? (value-tag content) 'eager)) ; * diff --git a/test-suite/tests/srfi-45.test b/test-suite/tests/srfi-45.test index 573eea04a..cb3f7908f 100644 --- a/test-suite/tests/srfi-45.test +++ b/test-suite/tests/srfi-45.test @@ -1,6 +1,7 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;; Copyright André van Tonder. All Rights Reserved. +;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2003 André van Tonder. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation @@ -258,3 +259,43 @@ ;; Commented out since it takes too long #; (test-equal 300000000 (force (times3 100000000))) ;==> bounded space + + +;====================================================================== +; Test promise? predicate (non-standard Guile extension) + +(pass-if "promise? predicate" + (promise? (delay 1))) + +;====================================================================== +; Test memoization of multiple values (non-standard Guile extension) + +(with-test-prefix "Multiple values (non-standard)" + + (let ((promise (delay (values 1 2 3)))) + (pass-if-equal "Multiple values delay" + '(1 2 3) + (call-with-values + (lambda () (force promise)) + list))) + + (let ((promise (eager 1 2 3))) + (pass-if-equal "Multiple values eager" + '(1 2 3) + (call-with-values + (lambda () (force promise)) + list))) + + (let ((promise (delay (values)))) + (pass-if-equal "Zero values delay" + '() + (call-with-values + (lambda () (force promise)) + list))) + + (let ((promise (eager))) + (pass-if-equal "Zero values eager" + '() + (call-with-values + (lambda () (force promise)) + list)))) From c8248c8ed5459991e7d2d6d8f20f652295c19514 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 19 Mar 2013 22:38:45 -0400 Subject: [PATCH 111/147] Optimize scm_i_divide2double for integers less than 2^DBL_MANT_DIG. * libguile/numbers.c (scm_i_divide2double): Optimize for common case when both operands are less than 2^DBL_MANT_DIG (normally 2^53). --- libguile/numbers.c | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 1f845a365..a490f5d74 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -475,8 +475,17 @@ scm_i_divide2double (SCM n, SCM d) mpz_t nn, dd, lo, hi, x; ssize_t e; - if (SCM_I_INUMP (d)) + if (SCM_LIKELY (SCM_I_INUMP (d))) { + if (SCM_LIKELY (SCM_I_INUMP (n) + && (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG + || (SCM_I_INUM (n) < (1L << DBL_MANT_DIG) + && SCM_I_INUM (d) < (1L << DBL_MANT_DIG))))) + /* If both N and D can be losslessly converted to doubles, then + we can rely on IEEE floating point to do proper rounding much + faster than we can. */ + return ((double) SCM_I_INUM (n)) / ((double) SCM_I_INUM (d)); + if (SCM_UNLIKELY (scm_is_eq (d, SCM_INUM0))) { if (scm_is_true (scm_positive_p (n))) @@ -486,6 +495,7 @@ scm_i_divide2double (SCM n, SCM d) else return 0.0 / 0.0; } + mpz_init_set_si (dd, SCM_I_INUM (d)); } else From 4400266478b4a477c6747f9eed38f7c6021491d8 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 19 Mar 2013 18:48:56 -0400 Subject: [PATCH 112/147] Sqrt returns exact results when possible. * libguile/numbers.c (scm_sqrt): Handle exact integers and rationals in such a way that exact results are returned whenever possible. * test-suite/tests/numbers.test ("sqrt"): Add tests. --- libguile/numbers.c | 69 ++++++++++++++++++++++++++++++++--- test-suite/tests/numbers.test | 40 +++++++++++++++++++- 2 files changed, 103 insertions(+), 6 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index a490f5d74..9725fe443 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9988,11 +9988,70 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, } else if (SCM_NUMBERP (z)) { - double xx = scm_to_double (z); - if (xx < 0) - return scm_c_make_rectangular (0.0, sqrt (-xx)); - else - return scm_from_double (sqrt (xx)); + if (SCM_I_INUMP (z)) + { + if (SCM_I_INUM (z) >= 0) + { + if (SCM_I_FIXNUM_BIT < DBL_MANT_DIG + || SCM_I_INUM (z) < (1L << (DBL_MANT_DIG - 1))) + { + double root = sqrt (SCM_I_INUM (z)); + + /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an + integer, then the result is exact. */ + if (root == floor (root)) + return SCM_I_MAKINUM ((scm_t_inum) root); + else + return scm_from_double (root); + } + else + { + mpz_t x; + scm_t_inum root; + + mpz_init_set_ui (x, SCM_I_INUM (z)); + if (mpz_perfect_square_p (x)) + { + mpz_sqrt (x, x); + root = mpz_get_ui (x); + mpz_clear (x); + return SCM_I_MAKINUM (root); + } + else + mpz_clear (x); + } + } + } + else if (SCM_BIGP (z)) + { + /* IMPROVE-ME: Handle square roots of very large integers + better: (1) integers too large to fit in a double, and + (2) integers so large that the roundoff of the original + number would significantly reduce precision. */ + + if (mpz_sgn (SCM_I_BIG_MPZ (z)) >= 0 + && mpz_perfect_square_p (SCM_I_BIG_MPZ (z))) + { + SCM root = scm_i_mkbig (); + + mpz_sqrt (SCM_I_BIG_MPZ (root), SCM_I_BIG_MPZ (z)); + scm_remember_upto_here_1 (z); + return scm_i_normbig (root); + } + } + else if (SCM_FRACTIONP (z)) + /* FIXME: This loses precision due to double rounding. */ + return scm_divide (scm_sqrt (SCM_FRACTION_NUMERATOR (z)), + scm_sqrt (SCM_FRACTION_DENOMINATOR (z))); + + /* Fallback method, when the cases above do not apply. */ + { + double xx = scm_to_double (z); + if (xx < 0) + return scm_c_make_rectangular (0.0, sqrt (-xx)); + else + return scm_from_double (sqrt (xx)); + } } else SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index be2e31732..a52e79a01 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4840,7 +4840,45 @@ (pass-if-exception "two args" exception:wrong-num-args (sqrt 123 456)) - (pass-if (eqv? 0.0 (sqrt 0))) + (pass-if (eqv? 0 (sqrt 0))) + (pass-if (eqv? 1 (sqrt 1))) + (pass-if (eqv? 2 (sqrt 4))) + (pass-if (eqv? 3 (sqrt 9))) + (pass-if (eqv? 4 (sqrt 16))) + (pass-if (eqv? fixnum-max (sqrt (expt fixnum-max 2)))) + (pass-if (eqv? (+ 1 fixnum-max) (sqrt (expt (+ 1 fixnum-max) 2)))) + (pass-if (eqv? (expt 10 400) (sqrt (expt 10 800)))) + (pass-if (eqv? (/ (expt 10 1000) + (expt 13 1000)) + (sqrt (/ (expt 10 2000) + (expt 13 2000))))) + + (with-test-prefix "exact sqrt" + + (define (test root) + (pass-if (list root 'exact) + (eqv? root (sqrt (expt root 2)))) + (pass-if (list root '-1) + (let ((r (sqrt (- (expt root 2) 1)))) + (and (inexact? r) + (eqv-loosely? root r)))) + (pass-if (list root '+1) + (let ((r (sqrt (+ (expt root 2) 1)))) + (and (inexact? r) + (eqv-loosely? root r)))) + (pass-if (list root 'negative) + (eqv-loosely? (* +i root) (sqrt (- (expt root 2)))))) + + (test (exact-integer-sqrt (+ -1 (expt 2 (+ 2 dbl-mant-dig))))) + (test (exact-integer-sqrt (+ -1 (expt 2 (+ 1 dbl-mant-dig))))) + (test (exact-integer-sqrt (+ -1 (expt 2 (+ 0 dbl-mant-dig))))) + (test (exact-integer-sqrt (+ -1 (expt 2 (+ -1 dbl-mant-dig))))) + (test (exact-integer-sqrt (+ -1 (expt 2 (+ -2 dbl-mant-dig)))))) + + (pass-if (eqv? +4i (sqrt -16))) + (pass-if (eqv-loosely? +1.0e150i (sqrt #e-1e300))) + (pass-if (eqv-loosely? +0.7071i (sqrt -1/2))) + (pass-if (eqv? 0.0 (sqrt 0.0))) (pass-if (eqv? 1.0 (sqrt 1.0))) (pass-if (eqv-loosely? 2.0 (sqrt 4.0))) From 687a87bf012f0c0afa79dd9bebf7d173d1243880 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 20 Mar 2013 02:27:10 -0400 Subject: [PATCH 113/147] Optimize inum case of exact-integer-sqrt. * libguile/numbers.c (scm_exact_integer_sqrt): Use GMP for inum case. It is faster than what we had before. --- libguile/numbers.c | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9725fe443..ed09ad17d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9919,25 +9919,17 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp) { if (SCM_LIKELY (SCM_I_INUMP (k))) { - scm_t_inum kk = SCM_I_INUM (k); - scm_t_inum uu = kk; - scm_t_inum ss; + mpz_t kk, ss, rr; - if (SCM_LIKELY (kk > 0)) - { - do - { - ss = uu; - uu = (ss + kk/ss) / 2; - } while (uu < ss); - *sp = SCM_I_MAKINUM (ss); - *rp = SCM_I_MAKINUM (kk - ss*ss); - } - else if (SCM_LIKELY (kk == 0)) - *sp = *rp = SCM_INUM0; - else + if (SCM_I_INUM (k) < 0) scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, "exact non-negative integer"); + mpz_init_set_ui (kk, SCM_I_INUM (k)); + mpz_inits (ss, rr, NULL); + mpz_sqrtrem (ss, rr, kk); + *sp = SCM_I_MAKINUM (mpz_get_ui (ss)); + *rp = SCM_I_MAKINUM (mpz_get_ui (rr)); + mpz_clears (kk, ss, rr, NULL); } else if (SCM_LIKELY (SCM_BIGP (k))) { From ddb717423619cb2c36fb798dc12552b70cd9b0ad Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 20 Mar 2013 06:15:32 -0400 Subject: [PATCH 114/147] Improve sqrt handling of large integers and large and small rationals. * libguile/numbers.c (exact_integer_is_perfect_square, exact_integer_floor_square_root): New static functions. (scm_sqrt): Use SCM_LIKELY. Add 'scm_t_inum' variable in inum case to reduce the number of uses of SCM_I_INUM. Rename 'mpz_t' variable. Remove unneeded sign check. Handle bignums too large to fit in a double. Handle fractions too large or too small to fit in a normalized double. * test-suite/tests/numbers.test ("sqrt"): Add tests. --- libguile/numbers.c | 133 ++++++++++++++++++++++++++++------ test-suite/tests/numbers.test | 37 +++++++++- 2 files changed, 148 insertions(+), 22 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index ed09ad17d..a7c092803 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9950,6 +9950,56 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp) "exact non-negative integer"); } +/* Return true iff K is a perfect square. + K must be an exact integer. */ +static int +exact_integer_is_perfect_square (SCM k) +{ + int result; + + if (SCM_LIKELY (SCM_I_INUMP (k))) + { + mpz_t kk; + + mpz_init_set_si (kk, SCM_I_INUM (k)); + result = mpz_perfect_square_p (kk); + mpz_clear (kk); + } + else + { + result = mpz_perfect_square_p (SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_1 (k); + } + return result; +} + +/* Return the floor of the square root of K. + K must be an exact integer. */ +static SCM +exact_integer_floor_square_root (SCM k) +{ + if (SCM_LIKELY (SCM_I_INUMP (k))) + { + mpz_t kk; + scm_t_inum ss; + + mpz_init_set_ui (kk, SCM_I_INUM (k)); + mpz_sqrt (kk, kk); + ss = mpz_get_ui (kk); + mpz_clear (kk); + return SCM_I_MAKINUM (ss); + } + else + { + SCM s; + + s = scm_i_mkbig (); + mpz_sqrt (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_1 (k); + return scm_i_normbig (s); + } +} + SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, (SCM z), @@ -9982,12 +10032,14 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, { if (SCM_I_INUMP (z)) { - if (SCM_I_INUM (z) >= 0) + scm_t_inum x = SCM_I_INUM (z); + + if (SCM_LIKELY (x >= 0)) { - if (SCM_I_FIXNUM_BIT < DBL_MANT_DIG - || SCM_I_INUM (z) < (1L << (DBL_MANT_DIG - 1))) + if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG + || x < (1L << (DBL_MANT_DIG - 1)))) { - double root = sqrt (SCM_I_INUM (z)); + double root = sqrt (x); /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an integer, then the result is exact. */ @@ -9998,31 +10050,25 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, } else { - mpz_t x; + mpz_t xx; scm_t_inum root; - mpz_init_set_ui (x, SCM_I_INUM (z)); - if (mpz_perfect_square_p (x)) + mpz_init_set_ui (xx, x); + if (mpz_perfect_square_p (xx)) { - mpz_sqrt (x, x); - root = mpz_get_ui (x); - mpz_clear (x); + mpz_sqrt (xx, xx); + root = mpz_get_ui (xx); + mpz_clear (xx); return SCM_I_MAKINUM (root); } else - mpz_clear (x); + mpz_clear (xx); } } } else if (SCM_BIGP (z)) { - /* IMPROVE-ME: Handle square roots of very large integers - better: (1) integers too large to fit in a double, and - (2) integers so large that the roundoff of the original - number would significantly reduce precision. */ - - if (mpz_sgn (SCM_I_BIG_MPZ (z)) >= 0 - && mpz_perfect_square_p (SCM_I_BIG_MPZ (z))) + if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z))) { SCM root = scm_i_mkbig (); @@ -10030,11 +10076,56 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, scm_remember_upto_here_1 (z); return scm_i_normbig (root); } + else + { + long expon; + double signif = scm_i_big2dbl_2exp (z, &expon); + + if (expon & 1) + { + signif *= 2; + expon--; + } + if (signif < 0) + return scm_c_make_rectangular + (0.0, ldexp (sqrt (-signif), expon / 2)); + else + return scm_from_double (ldexp (sqrt (signif), expon / 2)); + } } else if (SCM_FRACTIONP (z)) - /* FIXME: This loses precision due to double rounding. */ - return scm_divide (scm_sqrt (SCM_FRACTION_NUMERATOR (z)), - scm_sqrt (SCM_FRACTION_DENOMINATOR (z))); + { + SCM n = SCM_FRACTION_NUMERATOR (z); + SCM d = SCM_FRACTION_DENOMINATOR (z); + + if (exact_integer_is_perfect_square (n) + && exact_integer_is_perfect_square (d)) + return scm_i_make_ratio_already_reduced + (exact_integer_floor_square_root (n), + exact_integer_floor_square_root (d)); + else + { + double xx = scm_i_divide2double (n, d); + double abs_xx = fabs (xx); + long shift = 0; + + if (SCM_UNLIKELY (abs_xx > DBL_MAX || abs_xx < DBL_MIN)) + { + shift = (scm_to_long (scm_integer_length (n)) + - scm_to_long (scm_integer_length (d))) / 2; + if (shift > 0) + d = left_shift_exact_integer (d, 2 * shift); + else + n = left_shift_exact_integer (n, -2 * shift); + xx = scm_i_divide2double (n, d); + } + + if (xx < 0) + return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx), shift)); + else + return scm_from_double (ldexp (sqrt (xx), shift)); + } + } /* Fallback method, when the cases above do not apply. */ { diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index a52e79a01..7d30392c8 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4858,6 +4858,10 @@ (define (test root) (pass-if (list root 'exact) (eqv? root (sqrt (expt root 2)))) + (pass-if (list root '*2) + (let ((r (sqrt (* 2 (expt root 2))))) + (and (inexact? r) + (eqv-loosely? (* (sqrt 2) root) r)))) (pass-if (list root '-1) (let ((r (sqrt (- (expt root 2) 1)))) (and (inexact? r) @@ -4873,7 +4877,38 @@ (test (exact-integer-sqrt (+ -1 (expt 2 (+ 1 dbl-mant-dig))))) (test (exact-integer-sqrt (+ -1 (expt 2 (+ 0 dbl-mant-dig))))) (test (exact-integer-sqrt (+ -1 (expt 2 (+ -1 dbl-mant-dig))))) - (test (exact-integer-sqrt (+ -1 (expt 2 (+ -2 dbl-mant-dig)))))) + (test (exact-integer-sqrt (+ -1 (expt 2 (+ -2 dbl-mant-dig))))) + + ;; largest finite inexact + (test (* (- (expt 2 dbl-mant-dig) 1) + (expt 2 (- dbl-max-exp dbl-mant-dig))))) + + (pass-if-equal "smallest inexact" + (expt 2.0 (- dbl-min-exp dbl-mant-dig)) + (sqrt (/ (+ -1 (expt 2 (* 2 (- dbl-mant-dig dbl-min-exp))))))) + + (with-test-prefix "extreme ratios" + (define-syntax-rule (test want x) + (pass-if 'x + (let ((got (sqrt x))) + (and (inexact? got) + (test-eqv? 1.0 (/ want got)))))) + (test 1.511139943175573e176 (/ (expt 3 2001) (expt 2 2001))) + (test 2.1370746022826034e176 (/ (expt 3 2001) (expt 2 2000))) + (test 8.724570529756128e175 (/ (expt 3 2000) (expt 2 2001))) + (test 6.6175207962444435e-177 (/ (expt 2 2001) (expt 3 2001))) + (test 1.1461882239239027e-176 (/ (expt 2 2001) (expt 3 2000))) + (test 4.679293829667447e-177 (/ (expt 2 2000) (expt 3 2001)))) + + (pass-if (eqv? (/ (expt 2 1000) + (expt 3 1000)) + (sqrt (/ (expt 2 2000) + (expt 3 2000))))) + + (pass-if (eqv? (/ (expt 3 1000) + (expt 2 1000)) + (sqrt (/ (expt 3 2000) + (expt 2 2000))))) (pass-if (eqv? +4i (sqrt -16))) (pass-if (eqv-loosely? +1.0e150i (sqrt #e-1e300))) From 8edab37f17cd60cf6986da822dfbdad6067aef66 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Thu, 21 Mar 2013 12:41:05 -0400 Subject: [PATCH 115/147] Mention the non-conformance of the core SRFI-6 procedures in the manual. * doc/ref/srfi-modules.texi (About SRFI Usage): Use SRFI-13 as an example of a module which is included in core Guile, instead of SRFI-6. (SRFI-6): Mention the non-conformance of the core 'open-input-string' and 'open-output-string' procedures. Remove the claim that importing this module does nothing. Recommend that users import the module. --- doc/ref/srfi-modules.texi | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index e60dbb4e1..059e14b6f 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -76,13 +76,13 @@ check for the Scheme implementation, that is, before she can know that it is safe to use @code{use-modules} to load SRFI support modules. The second reason is that some features defined in SRFIs had been implemented in Guile before the developers started to add SRFI -implementations as modules (for example SRFI-6 (@pxref{SRFI-6})). In +implementations as modules (for example SRFI-13 (@pxref{SRFI-13})). In the future, it is possible that SRFIs in the core library might be factored out into separate modules, requiring explicit module loading when they are needed. So you should be prepared to have to use -@code{use-modules} someday in the future to access SRFI-6 bindings. If +@code{use-modules} someday in the future to access SRFI-13 bindings. If you want, you can do that already. We have included the module -@code{(srfi srfi-6)} in the distribution, which currently does nothing, +@code{(srfi srfi-13)} in the distribution, which currently does nothing, but ensures that you can write future-safe code. Generally, support for a specific SRFI is made available by using @@ -1846,11 +1846,19 @@ uniform numeric vector, it is returned unchanged. @cindex SRFI-6 SRFI-6 defines the procedures @code{open-input-string}, -@code{open-output-string} and @code{get-output-string}. These -procedures are included in the Guile core, so using this module does not -make any difference at the moment. But it is possible that support for -SRFI-6 will be factored out of the core library in the future, so using -this module does not hurt, after all. +@code{open-output-string} and @code{get-output-string}. + +Note that although versions of these procedures are included in the +Guile core, the core versions are not fully conformant with SRFI-6: +attempts to read or write characters that are not supported by the +current @code{%default-port-encoding} will fail. + +We therefore recommend that you import this module, which supports all +characters: + +@example +(use-modules (srfi srfi-6)) +@end example @node SRFI-8 @subsection SRFI-8 - receive From edb6de0becea3a52a4e5e3fa73a090928f0cbd61 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Thu, 21 Mar 2013 11:51:18 -0400 Subject: [PATCH 116/147] Add missing 'cond-expand' feature identifiers; remove srfi-6 from core list. * module/ice-9/boot-9.scm (%cond-expand-features): Remove redundant list of feature identifiers in the comment. Explain more clearly what belongs in this list. Remove srfi-6. * module/srfi/srfi-4.scm, module/srfi/srfi-27.scm, module/srfi/srfi-31.scm, module/srfi/srfi-38.scm, module/srfi/srfi-39.scm, module/srfi/srfi-42.scm, module/srfi/srfi-45.scm, module/srfi/srfi-67.scm: Add missing 'cond-expand-provide'. * module/srfi/srfi-69.scm: Fix erroneous 'cond-expand-provide'. * doc/ref/srfi-modules.texi (SRFI-0): Update the list of features in Guile core. --- doc/ref/srfi-modules.texi | 6 +++++- module/ice-9/boot-9.scm | 14 +++++++------- module/srfi/srfi-27.scm | 2 ++ module/srfi/srfi-31.scm | 2 ++ module/srfi/srfi-38.scm | 1 + module/srfi/srfi-39.scm | 2 ++ module/srfi/srfi-4.scm | 1 + module/srfi/srfi-42.scm | 2 ++ module/srfi/srfi-45.scm | 2 ++ module/srfi/srfi-67.scm | 2 ++ module/srfi/srfi-69.scm | 2 +- 11 files changed, 27 insertions(+), 9 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 059e14b6f..347b3de1f 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -145,9 +145,13 @@ guile-2 ;; starting from Guile 2.x r5rs srfi-0 srfi-4 -srfi-6 srfi-13 srfi-14 +srfi-23 +srfi-39 +srfi-55 +srfi-61 +srfi-105 @end example Other SRFI feature symbols are defined once their code has been loaded diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ed7ebeac4..ced3a2841 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3897,21 +3897,21 @@ when none is available, reading FILE-NAME with READER." ;;; <feature-identifier>s `guile' and `r5rs', so that programs can ;;; determine the implementation type and the supported standard. ;;; -;;; Currently, the following feature identifiers are supported: -;;; -;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105 -;;; ;;; Remember to update the features list when adding more SRFIs. ;;; (define %cond-expand-features - ;; Adjust the above comment when changing this. + ;; This should contain only features that are present in core Guile, + ;; before loading any modules. Modular features are handled by + ;; placing 'cond-expand-provide' in the relevant module. '(guile guile-2 r5rs srfi-0 ;; cond-expand itself - srfi-4 ;; homogenous numeric vectors - srfi-6 ;; open-input-string etc, in the guile core + srfi-4 ;; homogeneous numeric vectors + ;; We omit srfi-6 because the 'open-input-string' etc in Guile + ;; core are not conformant with SRFI-6; they expose details + ;; of the binary I/O model and may fail to support some characters. srfi-13 ;; string library srfi-14 ;; character sets srfi-23 ;; `error` procedure diff --git a/module/srfi/srfi-27.scm b/module/srfi/srfi-27.scm index 9777acea6..0794a437d 100644 --- a/module/srfi/srfi-27.scm +++ b/module/srfi/srfi-27.scm @@ -36,6 +36,8 @@ random-source-make-reals) #:use-module (srfi srfi-9)) +(cond-expand-provide (current-module) '(srfi-27)) + (define-record-type :random-source (%make-random-source state) random-source? diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm index cf67e8af5..f11aa8419 100644 --- a/module/srfi/srfi-31.scm +++ b/module/srfi/srfi-31.scm @@ -21,6 +21,8 @@ (define-module (srfi srfi-31) #:export (rec)) +(cond-expand-provide (current-module) '(srfi-31)) + (define-syntax rec (syntax-rules () "Return the given object, defined in a lexical environment where diff --git a/module/srfi/srfi-38.scm b/module/srfi/srfi-38.scm index 874dd9080..34cf22ef7 100644 --- a/module/srfi/srfi-38.scm +++ b/module/srfi/srfi-38.scm @@ -32,6 +32,7 @@ #:use-module (srfi srfi-69) #:use-module (system vm trap-state)) +(cond-expand-provide (current-module) '(srfi-38)) ;; A printer that shows all sharing of substructures. Uses the Common ;; Lisp print-circle notation: #n# refers to a previous substructure diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index 0d540633d..661ab0fbe 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -41,6 +41,8 @@ parameterize current-input-port current-output-port current-error-port)) +(cond-expand-provide (current-module) '(srfi-39)) + (define (with-parameters* params values thunk) (let more ((params params) (values values) diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm index 43f5ef68f..c6eb00bf0 100644 --- a/module/srfi/srfi-4.scm +++ b/module/srfi/srfi-4.scm @@ -69,6 +69,7 @@ f64vector? make-f64vector f64vector f64vector-length f64vector-ref f64vector-set! f64vector->list list->f64vector)) +(cond-expand-provide (current-module) '(srfi-4)) ;; Need quasisyntax to do this effectively using syntax-case (define-macro (define-bytevector-type tag infix size) diff --git a/module/srfi/srfi-42.scm b/module/srfi/srfi-42.scm index 0aaaf8f3f..c826f6f9e 100644 --- a/module/srfi/srfi-42.scm +++ b/module/srfi/srfi-42.scm @@ -61,4 +61,6 @@ vector-ec vector-of-length-ec)) +(cond-expand-provide (current-module) '(srfi-42)) + (include-from-path "srfi/srfi-42/ec.scm") diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm index 47e3ba605..f865f912c 100644 --- a/module/srfi/srfi-45.scm +++ b/module/srfi/srfi-45.scm @@ -41,6 +41,8 @@ #:replace (delay force promise?) #:use-module (srfi srfi-9)) +(cond-expand-provide (current-module) '(srfi-45)) + (define-record-type promise (make-promise val) promise? (val promise-val promise-val-set!)) diff --git a/module/srfi/srfi-67.scm b/module/srfi/srfi-67.scm index 7a43ee50b..6d9d4c5ad 100644 --- a/module/srfi/srfi-67.scm +++ b/module/srfi/srfi-67.scm @@ -83,4 +83,6 @@ #:replace (string-compare string-compare-ci) #:use-module (srfi srfi-27)) +(cond-expand-provide (current-module) '(srfi-67)) + (include-from-path "srfi/srfi-67/compare.scm") diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm index df07f7510..b9486c465 100644 --- a/module/srfi/srfi-69.scm +++ b/module/srfi/srfi-69.scm @@ -88,7 +88,7 @@ #:re-export (string-hash) #:replace (hash make-hash-table hash-table?)) -(cond-expand-provide (current-module) '(srfi-37)) +(cond-expand-provide (current-module) '(srfi-69)) ;;;; Internal helper macros From 14ae4725ab5cdfc334786012c0b4fdacc2851be2 Mon Sep 17 00:00:00 2001 From: Mike Gran <spk121@yahoo.com> Date: Thu, 21 Mar 2013 09:20:31 -0700 Subject: [PATCH 117/147] Document quit and exit * doc/ref/posix.texi (Processes): document `quit' and `exit' * doc/ref/r6rs.texi (rnrs programs): xref exit --- doc/ref/posix.texi | 12 ++++++++++++ doc/ref/r6rs.texi | 6 +++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index d659cf391..ded3787df 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1718,6 +1718,18 @@ interpretation is not required. Example: (system* "echo" "foo" "bar") @end deffn +@deffn {Scheme Procedure} quit [status] +@deffnx {Scheme Procedure} exit [status] +Terminate the current process with proper unwinding of the Scheme stack. +The exit status zero if @var{status} is not supplied. If @var{status} +is supplied, and it is an integer, that integer is used as the exit +status. If @var{status} is @code{#t} or @code{#f}, the exit status is 0 +or 1, respectively. + +The procedure @code{exit} is an alias of @code{quit}. They have the +same functionality. +@end deffn + @deffn {Scheme Procedure} primitive-exit [status] @deffnx {Scheme Procedure} primitive-_exit [status] @deffnx {C Function} scm_primitive_exit (status) diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index 13f9e2078..b18377135 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -1521,9 +1521,9 @@ This procedure is identical to the one provided by Guile's core library. @xref{Runtime Environment}, for documentation. @end deffn -@deffn {Scheme Procedure} exit -@deffnx {Scheme Procedure} exit obj -This procedure is identical to the one provided by Guile's core library. +@deffn {Scheme Procedure} exit [status] +This procedure is identical to the one provided by Guile's core +library. @xref{Processes}, for documentation. @end deffn @node rnrs arithmetic fixnums From c52ce75a1f87e72d675fc5a6ad95ef26dd517e10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 21 Mar 2013 16:36:24 +0100 Subject: [PATCH 118/147] test suite: Use `pass-if-equal' in texinfo.test. * test-suite/tests/texinfo.test: Replace occurrences of `(pass-if (equal? ...))' by `pass-if-equal'. --- test-suite/tests/texinfo.test | 61 +++++++++++++++++------------------ 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 8a4b593fd..9776f8902 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -1,6 +1,6 @@ ;;;; texinfo.test -*- scheme -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -56,24 +56,24 @@ str (lambda (port) (texinfo:read-verbatim-body port consumer '()))))) - (pass-if (equal? '() - (read-verbatim-body-from-string "@end verbatim\n"))) + (pass-if-equal '() + (read-verbatim-body-from-string "@end verbatim\n")) ;; after @verbatim, the current position will always directly after ;; the newline. (pass-if-exception "@end verbatim needs a newline" exception:eof-while-reading-token (read-verbatim-body-from-string "@end verbatim")) - - (pass-if (equal? '("@@end verbatim" " NL\n") - (read-verbatim-body-from-string "@@end verbatim\n@end verbatim\n"))) - (pass-if (equal? '("@@@@faosfasf adsfas " " NL\n" " asf @foo{asdf}" " NL\n") - (read-verbatim-body-from-string - "@@@@faosfasf adsfas \n asf @foo{asdf}\n@end verbatim\n"))) + (pass-if-equal '("@@end verbatim" " NL\n") + (read-verbatim-body-from-string "@@end verbatim\n@end verbatim\n")) - (pass-if (equal? '("@end verbatim " " NL\n") - (read-verbatim-body-from-string "@end verbatim \n@end verbatim\n")))) + (pass-if-equal '("@@@@faosfasf adsfas " " NL\n" " asf @foo{asdf}" " NL\n") + (read-verbatim-body-from-string + "@@@@faosfasf adsfas \n asf @foo{asdf}\n@end verbatim\n")) + + (pass-if-equal '("@end verbatim " " NL\n") + (read-verbatim-body-from-string "@end verbatim \n@end verbatim\n"))) (define texinfo:read-arguments (@@ (texinfo) read-arguments)) @@ -84,8 +84,8 @@ (lambda (port) (texinfo:read-arguments port #\})))) (define (test str expected-res) - (pass-if (equal? expected-res - (read-arguments-from-string str)))) + (pass-if-equal expected-res + (read-arguments-from-string str))) (test "}" '()) (test "foo}" '("foo")) @@ -111,20 +111,20 @@ (texinfo:complete-start-command command port)) list)))) - (pass-if (equal? '(section () EOL-TEXT) - (test 'section "foo bar baz bonzerts"))) - (pass-if (equal? '(deffnx ((category "Function") (name "foo") (arguments)) EOL-TEXT-ARGS) - (test 'deffnx "Function foo"))) + (pass-if-equal '(section () EOL-TEXT) + (test 'section "foo bar baz bonzerts")) + (pass-if-equal '(deffnx ((category "Function") (name "foo") (arguments)) EOL-TEXT-ARGS) + (test 'deffnx "Function foo")) (pass-if-exception "@emph missing a start brace" exception:wrong-character (test 'emph "no brace here")) - (pass-if (equal? '(emph () INLINE-TEXT) - (test 'emph "{foo bar baz bonzerts"))) - (pass-if (equal? '(ref ((node "foo bar") (section "baz") (info-file "bonzerts")) - INLINE-ARGS) - (test 'ref "{ foo bar ,, baz, bonzerts}"))) - (pass-if (equal? '(node ((name "referenced node")) EOL-ARGS) - (test 'node " referenced node\n")))) + (pass-if-equal '(emph () INLINE-TEXT) + (test 'emph "{foo bar baz bonzerts")) + (pass-if-equal '(ref ((node "foo bar") (section "baz") (info-file "bonzerts")) + INLINE-ARGS) + (test 'ref "{ foo bar ,, baz, bonzerts}")) + (pass-if-equal '(node ((name "referenced node")) EOL-ARGS) + (test 'node " referenced node\n"))) (define texinfo:read-char-data (@@ (texinfo) read-char-data)) @@ -149,8 +149,8 @@ port expect-eof? preserve-ws? str-handler '())))) (lambda (seed token) (let ((result (reverse seed))) - (pass-if (equal? expected-data result)) - (pass-if (equal? expected-token token)))))) + (pass-if-equal expected-data result) + (pass-if-equal expected-token token))))) ;; add some newline-related tests here (test "" #t #f '() eof-object) @@ -167,8 +167,8 @@ (with-test-prefix "test-texinfo->stexinfo" (define (test str expected-res) - (pass-if (equal? expected-res - (call-with-input-string str texi->stexi)))) + (pass-if-equal expected-res + (call-with-input-string str texi->stexi))) (define (try-with-title title str) (call-with-input-string (string-append "foo bar baz\n@settitle " title "\n" str) @@ -177,9 +177,8 @@ (test (string-append "foo bar baz\n@settitle " title "\n" str) expected-res)) (define (test-body str expected-res) - (pass-if str - (equal? expected-res - (cddr (try-with-title "zog" str))))) + (pass-if-equal str expected-res + (cddr (try-with-title "zog" str)))) (define (list-intersperse src-l elem) (if (null? src-l) src-l From 797b2aa69aeb7db607250bad83d31a31f8f4d1c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 21 Mar 2013 16:37:48 +0100 Subject: [PATCH 119/147] texinfo: Allow markup in the arguments of `@pxref'. * module/texinfo.scm (texi-command-specs)[pxref]: Change to `INLINE-TEXT-ARGS'. * test-suite/tests/texinfo.test ("test-texinfo->stexinfo")["@pxref{Locales, @code{setlocale}}"]: New test. --- module/texinfo.scm | 3 ++- test-suite/tests/texinfo.test | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/module/texinfo.scm b/module/texinfo.scm index edee5b397..cb7a775d4 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -216,7 +216,8 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, (value INLINE-ARGS . (key)) (ref INLINE-ARGS . (node #:opt name section info-file manual)) (xref INLINE-ARGS . (node #:opt name section info-file manual)) - (pxref INLINE-ARGS . (node #:opt name section info-file manual)) + (pxref INLINE-TEXT-ARGS + . (node #:opt name section info-file manual)) (url ALIAS . uref) (uref INLINE-ARGS . (url #:opt title replacement)) (anchor INLINE-ARGS . (name)) diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 9776f8902..ebe46717f 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -416,4 +416,7 @@ (name "foo") (arguments "bar " (code "baz")))) (para "text that should be in a para"))) + (test-body "@pxref{Locales, @code{setlocale}}" + '((para (pxref (% (node "Locales") + (name (code "setlocale"))))))) ) From 4215ea75a525a848ce9d73fad9c03983e8b3cd0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 21 Mar 2013 16:42:54 +0100 Subject: [PATCH 120/147] texinfo: Recognize `@:'. * module/texinfo.scm (read-command-token): Recognize @:. * test-suite/tests/texinfo.test ("test-texinfo->stexinfo"): Add test. --- module/texinfo.scm | 2 +- test-suite/tests/texinfo.test | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/module/texinfo.scm b/module/texinfo.scm index cb7a775d4..91bb46d8d 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -485,7 +485,7 @@ Examples: (assert-curr-char '(#\@) "start of the command" port) (let ((peeked (peek-char port))) (cond - ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\})) + ((memq peeked '(#\! #\: #\. #\? #\@ #\\ #\{ #\})) ;; @-commands that escape characters (make-token 'STRING (string (read-char port)))) (else diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index ebe46717f..c4ee58257 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -419,4 +419,6 @@ (test-body "@pxref{Locales, @code{setlocale}}" '((para (pxref (% (node "Locales") (name (code "setlocale"))))))) + (test-body "Like this---e.g.@:, at colon." + ((para "Like this---e.g.:, at colon."))) ) From 8fe4c4eccbd6fcd5e26d955cc3b59aef60f561ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 21 Mar 2013 19:17:56 +0100 Subject: [PATCH 121/147] test suite: Fix typo in `texinfo.test'. * test-suite/tests/texinfo.test ("test-texinfo->stexinfo"): Add missing quote. --- test-suite/tests/texinfo.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index c4ee58257..2cb4a7187 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -420,5 +420,5 @@ '((para (pxref (% (node "Locales") (name (code "setlocale"))))))) (test-body "Like this---e.g.@:, at colon." - ((para "Like this---e.g.:, at colon."))) + '((para "Like this---e.g.:, at colon."))) ) From 2bb7a730137013d2cc931e3b5932f6235d76e1e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 21 Mar 2013 23:22:08 +0100 Subject: [PATCH 122/147] texinfo plain-text: Properly render @dots{}. * module/texinfo/plain-text.scm (tag-handlers): Add `dot' handler. --- module/texinfo/plain-text.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm index 83e5e38f9..3adaf0413 100644 --- a/module/texinfo/plain-text.scm +++ b/module/texinfo/plain-text.scm @@ -255,6 +255,7 @@ (sc ,var) (copyright ,(lambda args "(C)")) (result ,(lambda args "==>")) + (dots ,(lambda args "...")) (xref ,ref) (ref ,ref) (pxref ,ref) From 6cfdc6b87881a592b7ad99db8d9ea0ee13a4101b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Thu, 21 Mar 2013 19:17:13 +0100 Subject: [PATCH 123/147] Build `guile-procedures.txt' using (texinfo) instead of `makeinfo'. * Makefile.am (schemelibdir, schemelib_DATA): New variables. (libguile/guile-procedures.txt): New target. (EXTRA_DIST): Add libguile/texi-fragments-to-docstrings. * libguile/Makefile.am (guile-procedures.txt): Remove target. (schemelibdir, schemelib_DATA): Remove. * libguile/texi-fragments-to-docstrings: New file. --- Makefile.am | 17 ++++++++- libguile/Makefile.am | 16 -------- libguile/texi-fragments-to-docstrings | 55 +++++++++++++++++++++++++++ 3 files changed, 70 insertions(+), 18 deletions(-) create mode 100644 libguile/texi-fragments-to-docstrings diff --git a/Makefile.am b/Makefile.am index 3aa5ddd76..737897bcf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -42,6 +42,18 @@ SUBDIRS = \ libguileincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION) libguileinclude_HEADERS = libguile.h +schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION) +schemelib_DATA = libguile/guile-procedures.txt + +# Build it from here so that all the modules are compiled by the time we +# build it. +libguile/guile-procedures.txt: libguile/guile-procedures.texi + $(AM_V_GEN) \ + $(top_builddir)/meta/guile --no-auto-compile \ + "$(srcdir)/libguile/texi-fragments-to-docstrings" \ + "$(builddir)/libguile/guile-procedures.texi" \ + > libguile/guile-procedures.txt + EXTRA_DIST = LICENSE HACKING GUILE-VERSION \ m4/ChangeLog-2008 \ m4/gnulib-cache.m4 \ @@ -50,7 +62,8 @@ 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/build-aux/git-version-gen.diff + gnulib-local/build-aux/git-version-gen.diff \ + libguile/texi-fragments-to-docstrings TESTS = check-guile TESTS_ENVIRONMENT = @LOCALCHARSET_TESTS_ENVIRONMENT@ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index d77bdfe2d..450d955ce 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -713,25 +713,9 @@ guile.texi: $(alldotdocfiles) guile$(EXEEXT) guile-procedures.texi: $(alldotdocfiles) guile$(EXEEXT) $(AM_V_GEN)$(dotdoc2texi) > $@ || { rm $@; false; } -if HAVE_MAKEINFO - -guile-procedures.txt: guile-procedures.texi - rm -f $@ - makeinfo --force -o $@ guile-procedures.texi || test -f $@ - -else - -guile-procedures.txt: guile-procedures.texi - cp guile-procedures.texi $@ - -endif - c-tokenize.c: c-tokenize.lex flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; } -schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION) -schemelib_DATA = guile-procedures.txt - ## Add -MG to make the .x magic work with auto-dep code. MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS) diff --git a/libguile/texi-fragments-to-docstrings b/libguile/texi-fragments-to-docstrings new file mode 100644 index 000000000..b72390b89 --- /dev/null +++ b/libguile/texi-fragments-to-docstrings @@ -0,0 +1,55 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; +;;; Copyright (C) 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 +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +;;; +;;; Read Texinfo fragments from stdin (docstrings of Guile's primitives +;;; in the format of `guile-procedures.texi'), and write to stdout a +;;; textual rendering thereof. The output preserves page breaks (^L) +;;; found in the input, as per the Guile Documentation Format +;;; version 2---see (ice-9 documentation). +;;; + +(use-modules (texinfo) + (texinfo plain-text) + (srfi srfi-1) + (ice-9 match) + (rnrs io ports)) + +(define (docstring-fragments->strings str) + "Return the list resulting from the split of STR at each page +break (^L)" + (string-tokenize str (char-set-complement (char-set #\page)))) + +(match (command-line) + ((_ texi-file) + (let* ((fragments (remove (compose string-null? string-trim-both) + (call-with-input-file texi-file + (compose docstring-fragments->strings + get-string-all)))) + (stexi (map texi-fragment->stexi fragments))) + (format #t "Produced by GNU Guile ~a from `~a'.~%~%" + (version) texi-file) + (for-each (lambda (stexi) + (display #\page) + (display (stexi->plain-text stexi))) + stexi))) + ((command args ...) + (format (current-error-port) "invalid arguments: ~s~%" args) + (format (current-error-port) "Usage: ~a TEXINFO-FILE~%" command) + (exit 1))) From c5c7c1146f2488f92b11b1edbe36fa99ffdf2771 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 22 Mar 2013 00:52:16 +0100 Subject: [PATCH 124/147] build: Adjust makefiles for `guile-procedures.txt'. * libguile/Makefile.am (all-local): New target. * Makefile.am (libguile/guile-procedures.txt): Output to $@.tmp first. (CLEANFILES): New variable. --- Makefile.am | 4 +++- libguile/Makefile.am | 4 ++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 737897bcf..8cdcc7e4e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -52,7 +52,8 @@ libguile/guile-procedures.txt: libguile/guile-procedures.texi $(top_builddir)/meta/guile --no-auto-compile \ "$(srcdir)/libguile/texi-fragments-to-docstrings" \ "$(builddir)/libguile/guile-procedures.texi" \ - > libguile/guile-procedures.txt + > $@.tmp + @mv $@.tmp $@ EXTRA_DIST = LICENSE HACKING GUILE-VERSION \ m4/ChangeLog-2008 \ @@ -70,6 +71,7 @@ TESTS_ENVIRONMENT = @LOCALCHARSET_TESTS_ENVIRONMENT@ ACLOCAL_AMFLAGS = -I m4 +CLEANFILES = libguile/guile-procedures.txt DISTCLEANFILES = check-guile.log DISTCHECK_CONFIGURE_FLAGS = --enable-error-on-warning diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 450d955ce..4b1f96bee 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -429,6 +429,10 @@ BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \ scmconfig.h \ $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) +# Force the generation of `guile-procedures.texi' because the top-level +# Makefile expects it to be built. +all-local: guile-procedures.texi + EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ memmove.c strerror.c \ dynl.c regex-posix.c \ From 43c2a48323803e9aae41ba896ce6b6a0067343ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 22 Mar 2013 22:05:23 +0100 Subject: [PATCH 125/147] texinfo: Add whitespace after periods. * module/texinfo/string-utils.scm (end-of-sentence?): New procedure. (make-text-wrapper): Append an extra space after LINE when it matches `end-of-sentence?' and COLLAPSE-WHITESPACE? is false. * test-suite/tests/texinfo.serialize.test ("test-serialize"): Adjust accordingly. * test-suite/tests/texinfo.string-utils.test ("text wrapping")["two spaces after end of sentence"]: New test prefix. --- module/texinfo/string-utils.scm | 15 +++++++++++++-- test-suite/tests/texinfo.serialize.test | 4 ++-- test-suite/tests/texinfo.string-utils.test | 9 ++++++++- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/module/texinfo/string-utils.scm b/module/texinfo/string-utils.scm index 767514952..22f969c04 100644 --- a/module/texinfo/string-utils.scm +++ b/module/texinfo/string-utils.scm @@ -1,6 +1,6 @@ ;;;; (texinfo string-utils) -- text filling and wrapping ;;;; -;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2003 Richard Todd ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -262,6 +262,13 @@ the default value for @var{num} is 1. ;; did not find non-ws... only ws at end of the string... (reverse ans)))))) +(define (end-of-sentence? str) + "Return #t when STR likely denotes the end of sentence." + (let ((len (string-length str))) + (and (> len 1) + (eqv? #\. (string-ref str (- len 1))) + (not (eqv? #\. (string-ref str (- len 2))))))) + (define* (make-text-wrapper #:key (line-width 80) (expand-tabs? #t) @@ -352,7 +359,11 @@ returns a list of strings, where each element of the list is one line." length-left) (loop ans (cdr words) - (string-append line next-word) + (if (and collapse-whitespace? + (end-of-sentence? line)) + ;; Add an extra space after the period. + (string-append line " " next-word) + (string-append line next-word)) (+ count 1))) ;; ok, it didn't fit...is there already at least one word on the line? diff --git a/test-suite/tests/texinfo.serialize.test b/test-suite/tests/texinfo.serialize.test index 95e26b845..554390c0f 100644 --- a/test-suite/tests/texinfo.serialize.test +++ b/test-suite/tests/texinfo.serialize.test @@ -1,6 +1,6 @@ ;;;; texinfo.serialize.test -*- scheme -*- ;;;; -;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -103,7 +103,7 @@ "@iftex This is only for tex. -Note. Foo. +Note. Foo. @end iftex diff --git a/test-suite/tests/texinfo.string-utils.test b/test-suite/tests/texinfo.string-utils.test index ad19df871..4f2e4c5e3 100644 --- a/test-suite/tests/texinfo.string-utils.test +++ b/test-suite/tests/texinfo.string-utils.test @@ -1,6 +1,6 @@ ;;;; texinfo.string-utils.test -*- scheme -*- ;;;; -;;;; Copyright (C) 2003, 2009, 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2009, 2010, 2013 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 @@ -109,6 +109,13 @@ to using the function `set-language-environment'. variable should be set only with M-x customize, which is equivalent to using the function `set-language-environment'."))) + (with-test-prefix "two spaces after end of sentence" + (pass-if-equal "This is a sentence. There should be two spaces before." + (fill-string "This is a sentence. There should be two spaces before.")) + + (pass-if-equal "This is version 2.0..." + (fill-string "This is version 2.0..."))) + (with-test-prefix "test-no-word-break" (pass-if (equal? "thisisalongword blah From e8a57fb052c4d9c27681183bd0cf2be31142d58a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 22 Mar 2013 22:09:05 +0100 Subject: [PATCH 126/147] texinfo plain-text: Use `match' for `stexi->plain-text'. * module/texinfo/plain-text.scm (def)[list/spaces]: Remove. (stexi->plain-text): Use `match' instead of `cond'. --- module/texinfo/plain-text.scm | 34 ++++++++++++++-------------------- 1 file changed, 14 insertions(+), 20 deletions(-) diff --git a/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm index 3adaf0413..809cdb7b3 100644 --- a/module/texinfo/plain-text.scm +++ b/module/texinfo/plain-text.scm @@ -31,6 +31,7 @@ #:use-module (sxml transform) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) + #:use-module (ice-9 match) #:export (stexi->plain-text)) ;; The return value is a string. @@ -95,13 +96,6 @@ (string-append "`" url "'")))) (define (def tag args . body) - (define (list/spaces . elts) - (let lp ((in elts) (out '())) - (cond ((null? in) (reverse! out)) - ((null? (car in)) (lp (cdr in) out)) - (else (lp (cdr in) - (cons (car in) - (if (null? out) out (cons " " out)))))))) (define (first-line) (string-join (filter identity @@ -297,18 +291,18 @@ (define (stexi->plain-text tree) "Transform @var{tree} into plain text. Returns a string." - (cond - ((null? tree) "") - ((string? tree) tree) - ((pair? tree) - (cond - ((symbol? (car tree)) - (let ((handler (and (not (ignored? (car tree))) - (or (and=> (assq (car tree) tag-handlers) cadr) - para)))) - (if handler (apply handler tree) ""))) - (else - (string-concatenate (map-in-order stexi->plain-text tree))))) - (else ""))) + (match tree + (() "") + ((? string?) tree) + (((? symbol? tag) body ...) + (let ((handler (and (not (ignored? tag)) + (or (and=> (assq tag tag-handlers) cadr) + para)))) + (if handler + (apply handler tree) + ""))) + ((tree ...) + (string-concatenate (map-in-order stexi->plain-text tree))) + (_ ""))) ;;; arch-tag: f966c3f6-3b46-4790-bbf9-3ad27e4917c2 From fbac7c6113056bc6ee85996b10bdc08325c742a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 20 Mar 2013 23:04:11 +0100 Subject: [PATCH 127/147] Add bindings for `sendfile'. * configure.ac: Check for <sys/sendfile.h> and `sendfile'. * libguile/filesys.c (scm_sendfile): New function. * libguile/filesys.h (scm_sendfile): New declaration. * test-suite/tests/filesys.test ("sendfile"): New test prefix. * doc/ref/posix.texi (File System): Document `sendfile'. --- configure.ac | 20 ++++++-- doc/ref/posix.texi | 23 +++++++++ libguile/filesys.c | 91 +++++++++++++++++++++++++++++++++++ libguile/filesys.h | 4 +- test-suite/tests/filesys.test | 70 ++++++++++++++++++++++++++- 5 files changed, 201 insertions(+), 7 deletions(-) diff --git a/configure.ac b/configure.ac index 42de73307..bcfc1a65e 100644 --- a/configure.ac +++ b/configure.ac @@ -647,12 +647,13 @@ AC_SUBST([SCM_I_GSC_HAVE_STRUCT_DIRENT64]) # this file instead of <fenv.h> # process.h - mingw specific # sched.h - missing on MinGW +# sys/sendfile.h - non-POSIX, found in glibc # AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h memory.h process.h string.h \ sys/dir.h sys/ioctl.h sys/select.h \ sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \ sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \ -direct.h machine/fpu.h sched.h]) +direct.h machine/fpu.h sched.h sys/sendfile.h]) # "complex double" is new in C99, and "complex" is only a keyword if # <complex.h> is included @@ -744,10 +745,21 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # _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) +# utimensat - posix.1-2008 +# sched_getaffinity, sched_setaffinity - GNU extensions (glibc) +# sendfile - non-POSIX, found in 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 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]) +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 \ + 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 sendfile]) AM_CONDITIONAL([HAVE_FORK], [test "x$ac_cv_func_fork" = "xyes"]) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index ded3787df..bc8732932 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -803,6 +803,29 @@ Copy the file specified by @var{oldfile} to @var{newfile}. The return value is unspecified. @end deffn +@deffn {Scheme Procedure} sendfile out in count [offset] +@deffnx {C Function} scm_sendfile (out, in, count, offset) +Send @var{count} bytes from @var{in} to @var{out}, both of which +are either open file ports or file descriptors. When +@var{offset} is omitted, start reading from @var{in}'s current +position; otherwise, start reading at @var{offset}. + +When @var{in} is a port, it is often preferable to specify @var{offset}, +because @var{in}'s offset as a port may be different from the offset of +its underlying file descriptor. + +On systems that support it, such as GNU/Linux, this procedure uses the +@code{sendfile} libc function, which usually corresponds to a system +call. This is faster than doing a series of @code{read} and +@code{write} system calls. A typical application is to send a file over +a socket. + +In some cases, the @code{sendfile} libc function may return +@code{EINVAL} or @code{ENOSYS}. In that case, Guile's @code{sendfile} +procedure automatically falls back to doing a series of @code{read} and +@code{write} calls. +@end deffn + @findex rename @deffn {Scheme Procedure} rename-file oldname newname @deffnx {C Function} scm_rename (oldname, newname) diff --git a/libguile/filesys.c b/libguile/filesys.c index 282ff31b2..6804db9fb 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -98,6 +98,18 @@ #define NAMLEN(dirent) strlen ((dirent)->d_name) +#ifdef HAVE_SYS_SENDFILE_H +# include <sys/sendfile.h> +#endif + +/* Glibc's `sendfile' function. */ +#define sendfile_or_sendfile64 \ + CHOOSE_LARGEFILE (sendfile, sendfile64) + +#include <full-read.h> +#include <full-write.h> + + /* Some more definitions for the native Windows port. */ #ifdef __MINGW32__ # define fsync(fd) _commit (fd) @@ -1096,6 +1108,85 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0, + (SCM out, SCM in, SCM count, SCM offset), + "Send @var{count} bytes from @var{in} to @var{out}, both of which " + "are either open file ports or file descriptors. When " + "@var{offset} is omitted, start reading from @var{in}'s current " + "position; otherwise, start reading at @var{offset}.") +#define FUNC_NAME s_scm_sendfile +{ +#define VALIDATE_FD_OR_PORT(cvar, svar, pos) \ + if (scm_is_integer (svar)) \ + cvar = scm_to_int (svar); \ + else \ + { \ + SCM_VALIDATE_OPFPORT (pos, svar); \ + scm_flush (svar); \ + cvar = SCM_FPORT_FDES (svar); \ + } + + size_t c_count; + scm_t_off c_offset; + ssize_t result; + int in_fd, out_fd; + + VALIDATE_FD_OR_PORT (out_fd, out, 1); + VALIDATE_FD_OR_PORT (in_fd, in, 2); + c_count = scm_to_size_t (count); + c_offset = SCM_UNBNDP (offset) ? 0 : scm_to_off_t (offset); + +#ifdef HAVE_SENDFILE + result = sendfile_or_sendfile64 (out_fd, in_fd, + SCM_UNBNDP (offset) ? NULL : &c_offset, + c_count); + + /* Quoting the Linux man page: "In Linux kernels before 2.6.33, out_fd + must refer to a socket. Since Linux 2.6.33 it can be any file." + Fall back to read(2) and write(2) when such an error occurs. */ + if (result < 0 && errno != EINVAL && errno != ENOSYS) + SCM_SYSERROR; + else if (result < 0) +#endif + { + char buf[8192]; + size_t result, left; + + if (!SCM_UNBNDP (offset)) + { + if (SCM_PORTP (in)) + scm_seek (in, offset, scm_from_int (SEEK_SET)); + else + lseek_or_lseek64 (in_fd, c_offset, SEEK_SET); + } + + for (result = 0, left = c_count; result < c_count; ) + { + size_t asked, obtained; + + asked = SCM_MIN (sizeof buf, left); + obtained = full_read (in_fd, buf, asked); + if (obtained < asked) + SCM_SYSERROR; + + left -= obtained; + + obtained = full_write (out_fd, buf, asked); + if (obtained < asked) + SCM_SYSERROR; + + result += obtained; + } + + return scm_from_size_t (result); + } + + return scm_from_ssize_t (result); + +#undef VALIDATE_FD_OR_PORT +} +#undef FUNC_NAME + #endif /* HAVE_POSIX */ diff --git a/libguile/filesys.h b/libguile/filesys.h index 967ce7450..776b263cc 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -3,7 +3,8 @@ #ifndef SCM_FILESYS_H #define SCM_FILESYS_H -/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2006, 2008, 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 License @@ -66,6 +67,7 @@ SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile); SCM_API SCM scm_dirname (SCM filename); SCM_API SCM scm_basename (SCM filename, SCM suffix); SCM_API SCM scm_canonicalize_path (SCM path); +SCM_API SCM scm_sendfile (SCM out, SCM in, SCM count, SCM offset); SCM_INTERNAL SCM scm_i_relativize_path (SCM path, SCM in_path); SCM_INTERNAL void scm_init_filesys (void); diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index a6bfb6eb5..c80c2956c 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -1,6 +1,6 @@ ;;;; filesys.test --- test file system functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006, 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 @@ -18,7 +18,10 @@ (define-module (test-suite test-filesys) #:use-module (test-suite lib) - #:use-module (test-suite guile-test)) + #:use-module (test-suite guile-test) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors)) (define (test-file) (data-file-name "filesys-test.tmp")) @@ -125,5 +128,68 @@ (close-port port) (eqv? 5 (stat:size st)))))) +(with-test-prefix "sendfile" + + (pass-if "file" + (let ((file (search-path %load-path "ice-9/boot-9.scm"))) + (call-with-input-file file + (lambda (input) + (let ((len (stat:size (stat input)))) + (call-with-output-file (test-file) + (lambda (output) + (sendfile output input len 0)))))) + (let ((ref (call-with-input-file file get-bytevector-all)) + (out (call-with-input-file (test-file) get-bytevector-all))) + (bytevector=? ref out)))) + + (pass-if "file with offset" + (let ((file (search-path %load-path "ice-9/boot-9.scm"))) + (call-with-input-file file + (lambda (input) + (let ((len (stat:size (stat input)))) + (call-with-output-file (test-file) + (lambda (output) + (sendfile output input (- len 777) 777)))))) + (let ((ref (call-with-input-file file + (lambda (input) + (seek input 777 SEEK_SET) + (get-bytevector-all input)))) + (out (call-with-input-file (test-file) get-bytevector-all))) + (bytevector=? ref out)))) + + (pass-if "pipe" + (let* ((file (search-path %load-path "ice-9/boot-9.scm")) + (in+out (pipe)) + (child (call-with-new-thread + (lambda () + (call-with-input-file file + (lambda (input) + (let ((len (stat:size (stat input)))) + (sendfile (cdr in+out) (fileno input) len 0) + (close-port (cdr in+out))))))))) + (let ((ref (call-with-input-file file get-bytevector-all)) + (out (get-bytevector-all (car in+out)))) + (close-port (car in+out)) + (bytevector=? ref out)))) + + (pass-if "pipe with offset" + (let* ((file (search-path %load-path "ice-9/boot-9.scm")) + (in+out (pipe)) + (child (call-with-new-thread + (lambda () + (call-with-input-file file + (lambda (input) + (let ((len (stat:size (stat input)))) + (sendfile (cdr in+out) (fileno input) + (- len 777) 777) + (close-port (cdr in+out))))))))) + (let ((ref (call-with-input-file file + (lambda (input) + (seek input 777 SEEK_SET) + (get-bytevector-all input)))) + (out (get-bytevector-all (car in+out)))) + (close-port (car in+out)) + (bytevector=? ref out))))) + (delete-file (test-file)) (delete-file (test-symlink)) From 86fafc440220b0ab1d76439e89ac8114a9c7660d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Fri, 22 Mar 2013 22:24:27 +0100 Subject: [PATCH 128/147] tests: Add more `maybe-gc-flakiness'. Fixes <http://bugs.gnu.org/14001>. Reported by Dennis Clarke <dclarke@blastwave.org>. * test-suite/tests/gc.test ("gc")["Lexical vars are collectable"]: Wrap in `maybe-gc-flakiness'. --- test-suite/tests/gc.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index a969752f8..04f353984 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -1,6 +1,6 @@ ;;;; gc.test --- test guile's garbage collection -*- scheme -*- ;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009, -;;;; 2011, 2012 Free Software Foundation, Inc. +;;;; 2011, 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 @@ -101,4 +101,4 @@ (guardian)) ;; Prevent the optimizer from propagating f. #:opts '(#:partial-eval? #f)))) - (equal? l '(foo))))) + (maybe-gc-flakiness (equal? l '(foo)))))) From 45417ab1066b3f7f65ff4ff4f6ca2733c75bd521 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 25 Mar 2013 13:26:52 +0100 Subject: [PATCH 129/147] Skip relevant `sendfile' tests when thread support is lacking. * test-suite/tests/filesys.test ("sendfile")["pipe", "pipe with offset"]: Throw to `unresolved' when not (provided? 'threads). --- test-suite/tests/filesys.test | 64 +++++++++++++++++++---------------- 1 file changed, 34 insertions(+), 30 deletions(-) diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index c80c2956c..21b893796 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -158,38 +158,42 @@ (bytevector=? ref out)))) (pass-if "pipe" - (let* ((file (search-path %load-path "ice-9/boot-9.scm")) - (in+out (pipe)) - (child (call-with-new-thread - (lambda () - (call-with-input-file file - (lambda (input) - (let ((len (stat:size (stat input)))) - (sendfile (cdr in+out) (fileno input) len 0) - (close-port (cdr in+out))))))))) - (let ((ref (call-with-input-file file get-bytevector-all)) - (out (get-bytevector-all (car in+out)))) - (close-port (car in+out)) - (bytevector=? ref out)))) + (if (provided? 'threads) + (let* ((file (search-path %load-path "ice-9/boot-9.scm")) + (in+out (pipe)) + (child (call-with-new-thread + (lambda () + (call-with-input-file file + (lambda (input) + (let ((len (stat:size (stat input)))) + (sendfile (cdr in+out) (fileno input) len 0) + (close-port (cdr in+out))))))))) + (let ((ref (call-with-input-file file get-bytevector-all)) + (out (get-bytevector-all (car in+out)))) + (close-port (car in+out)) + (bytevector=? ref out))) + (throw 'unresolved))) (pass-if "pipe with offset" - (let* ((file (search-path %load-path "ice-9/boot-9.scm")) - (in+out (pipe)) - (child (call-with-new-thread - (lambda () - (call-with-input-file file - (lambda (input) - (let ((len (stat:size (stat input)))) - (sendfile (cdr in+out) (fileno input) - (- len 777) 777) - (close-port (cdr in+out))))))))) - (let ((ref (call-with-input-file file - (lambda (input) - (seek input 777 SEEK_SET) - (get-bytevector-all input)))) - (out (get-bytevector-all (car in+out)))) - (close-port (car in+out)) - (bytevector=? ref out))))) + (if (provided? 'threads) + (let* ((file (search-path %load-path "ice-9/boot-9.scm")) + (in+out (pipe)) + (child (call-with-new-thread + (lambda () + (call-with-input-file file + (lambda (input) + (let ((len (stat:size (stat input)))) + (sendfile (cdr in+out) (fileno input) + (- len 777) 777) + (close-port (cdr in+out))))))))) + (let ((ref (call-with-input-file file + (lambda (input) + (seek input 777 SEEK_SET) + (get-bytevector-all input)))) + (out (get-bytevector-all (car in+out)))) + (close-port (car in+out)) + (bytevector=? ref out))) + (throw 'unresolved)))) (delete-file (test-file)) (delete-file (test-symlink)) From f28885f4957882c4d96bdfee11d26cd265539aac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 25 Mar 2013 13:28:42 +0100 Subject: [PATCH 130/147] sendfile: Check return value of `lseek'. * libguile/filesys.c (scm_sendfile): Check return value of `lseek_or_lseek64', and use `SCM_SYSERROR' upon error. --- libguile/filesys.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 6804db9fb..334e2cd07 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1157,7 +1157,10 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0, if (SCM_PORTP (in)) scm_seek (in, offset, scm_from_int (SEEK_SET)); else - lseek_or_lseek64 (in_fd, c_offset, SEEK_SET); + { + if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0) + SCM_SYSERROR; + } } for (result = 0, left = c_count; result < c_count; ) From 11ed42771dec06626457eae58f2f334df1397f72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 25 Mar 2013 13:51:57 +0100 Subject: [PATCH 131/147] sendfile: Make sure we have a Linux-style `sendfile'. * libguile/filesys.c (scm_sendfile): Change conditional to HAVE_SYS_SENDFILE_H && HAVE_SENDFILE. --- libguile/filesys.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 334e2cd07..d318ae793 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1136,7 +1136,9 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0, c_count = scm_to_size_t (count); c_offset = SCM_UNBNDP (offset) ? 0 : scm_to_off_t (offset); -#ifdef HAVE_SENDFILE +#if defined HAVE_SYS_SENDFILE_H && defined HAVE_SENDFILE + /* The Linux-style sendfile(2), which is different from the BSD-style. */ + result = sendfile_or_sendfile64 (out_fd, in_fd, SCM_UNBNDP (offset) ? NULL : &c_offset, c_count); From 570fdeceacaad7f6e928123f40e8bb5f72677dcb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 25 Mar 2013 22:27:37 +0100 Subject: [PATCH 132/147] build: Use portable sed constructs. Partly fixes <http://bugs.gnu.org/14042>. Reported by Marc Girod <marc.girod@gmail.com>. * meta/Makefile.am (guile-config): Use separate "s" expressions to accommodate Solaris sed. --- meta/Makefile.am | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/meta/Makefile.am b/meta/Makefile.am index bd2078409..5a96e0e8b 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -2,7 +2,7 @@ ## Jim Blandy <jimb@red-bean.com> --- September 1997 ## ## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011, -## 2012 Free Software Foundation, Inc. +## 2012, 2013 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -46,10 +46,10 @@ aclocal_DATA = guile.m4 guile-config: $(srcdir)/guile-config.in $(top_builddir)/config.status guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ; \ - cat $(srcdir)/guile-config.in \ - | $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g ; \ - s,@""PKG_CONFIG@,$(PKG_CONFIG),g ; \ - s,@installed_guile@,$$guile,g" \ + cat $(srcdir)/guile-config.in \ + | $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g" \ + -e "s,@""PKG_CONFIG@,$(PKG_CONFIG),g" \ + -e "s,@installed_guile@,$$guile,g" \ > guile-config.out mv guile-config.out guile-config chmod +x guile-config From 5bb40f9df02c3395b198f254fdd43e7468b5ceee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 25 Mar 2013 22:46:53 +0100 Subject: [PATCH 133/147] getaddrinfo: Document the missing errno value for EAI_SYSTEM. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In response to <http://bugs.gnu.org/13958>. Reported by Lluís Batlle i Rossell <viric@viric.name>. * doc/ref/posix.texi (Network Databases): Document the missing errno value for EAI_SYSTEM. * libguile/net_db.c (scm_getaddrinfo): Likewise. --- doc/ref/posix.texi | 7 +++++-- libguile/net_db.c | 6 ++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index bc8732932..341191ac2 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2562,8 +2562,11 @@ code should be prepared to handle it when it is defined. @var{hint_socktype} was not recognized. @item EAI_SYSTEM -A system error occurred; the error code can be found in -@code{errno}. +A system error occurred. In C, the error code can be found in +@code{errno}; this value is not accessible from Scheme, but in +practice it provides little information about the actual error +cause. +@c See <http://bugs.gnu.org/13958>. @end table Users are encouraged to read the diff --git a/libguile/net_db.c b/libguile/net_db.c index 95f0040da..d7a12c50f 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -595,8 +595,10 @@ SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0, "@item EAI_SOCKTYPE\n" "@var{hint_socktype} was not recognized.\n\n" "@item EAI_SYSTEM\n" - "A system error occurred; the error code can be found in " - "@code{errno}.\n" + "A system error occurred. In C, the error code can be found in " + "@code{errno}; this value is not accessible from Scheme, but in\n" + "practice it provides little information about the actual error " + "cause.\n\n" /* see <http://bugs.gnu.org/13958>. */ "@end table\n" "\n" "Users are encouraged to read the " From 59b0f9d7635ea7e272e2976ab69764a570d7f6ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Mon, 25 Mar 2013 23:25:57 +0100 Subject: [PATCH 134/147] SRFI-37: Fix infinite loop when processing short option with no required arg. Fixes <http://bugs.gnu.org/13176>. * module/srfi/srfi-37.scm (args-fold)[short-option-argument]: When ARGS is a pair, always set it to its cdr. * test-suite/tests/srfi-37.test ("SRFI-37")["short option with optional argument omitted", "short option with optional argument provided"]: New tests. --- module/srfi/srfi-37.scm | 5 ++++- test-suite/tests/srfi-37.test | 24 +++++++++++++++++++++++- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm index 565b44cb9..3f654af2c 100644 --- a/module/srfi/srfi-37.scm +++ b/module/srfi/srfi-37.scm @@ -1,6 +1,6 @@ ;;; srfi-37.scm --- args-fold -;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2007, 2008, 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 @@ -145,6 +145,9 @@ program-arguments in ARGS, as decided by the OPTIONS' (let ((result (cadr args))) (set! args (cddr args)) result)) + ((pair? args) + (set! args (cdr args)) + #f) (else #f))) ;; Interpret the short-option at index POSITION in (car ARGS), diff --git a/test-suite/tests/srfi-37.test b/test-suite/tests/srfi-37.test index 1f739c5c5..5a3975070 100644 --- a/test-suite/tests/srfi-37.test +++ b/test-suite/tests/srfi-37.test @@ -1,6 +1,6 @@ ;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*- ;;;; -;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 2007, 2008, 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 @@ -105,4 +105,26 @@ (lambda (opt name arg k) #f) '())))) + (pass-if-equal "short option with optional argument omitted" 'good + ;; This would trigger an infinite loop in Guile up to 2.0.7. + ;; See <http://bugs.gnu.org/13176>. + (args-fold '("-I") + (list (option '(#\I) #f #t + (lambda (opt name arg value) + (and (eqv? name #\I) (not arg) + 'good)))) + (lambda _ (error "unrecognized")) + (const #f) + #f)) + + (pass-if-equal "short option with optional argument provided" + "the-argument" + (args-fold '("-I" "the-argument") + (list (option '(#\I) #f #t + (lambda (opt name arg result) + (and (eqv? name #\I) arg)))) + (lambda _ (error "unrecognized")) + (const #f) + #f)) + ) From 65ad02b96d4118970406b1474aa00bbe801aa61a Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 26 Mar 2013 21:16:26 -0400 Subject: [PATCH 135/147] Revert "SRFI-45: Support multiple values; add promise? predicate." This reverts commit 1d64b4edb9da4011ad06c0fab1c6225ec20b0876. --- doc/ref/srfi-modules.texi | 57 ++++++++++++++--------------------- module/srfi/srfi-45.scm | 21 ++++++------- test-suite/tests/srfi-45.test | 43 +------------------------- 3 files changed, 32 insertions(+), 89 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 347b3de1f..c99905c7d 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3845,58 +3845,45 @@ words, no program that uses the R5RS definitions of delay and force will break if those definition are replaced by the SRFI-45 definitions of delay and force. -Guile compatibly extends SRFI-45 to support multiple values. It also -adds @code{promise?} to the list of exports. - -@deffn {Scheme Procedure} promise? obj -Return true if @var{obj} is an SRFI-45 promise, otherwise return false. -@end deffn - @deffn {Scheme Syntax} delay expression -Takes an expression and returns a promise which at some point in the -future may be asked (by the @code{force} procedure) to evaluate the -expression and deliver the resulting value(s). +Takes an expression of arbitrary type @var{a} and returns a promise of +type @code{(Promise @var{a})} which at some point in the future may be +asked (by the @code{force} procedure) to evaluate the expression and +deliver the resulting value. @end deffn @deffn {Scheme Syntax} lazy expression -Takes an expression (which must evaluate to a promise) and returns a -promise which at some point in the future may be asked (by the -@code{force} procedure) to evaluate the expression and deliver the -resulting promise. +Takes an expression of type @code{(Promise @var{a})} and returns a +promise of type @code{(Promise @var{a})} which at some point in the +future may be asked (by the @code{force} procedure) to evaluate the +expression and deliver the resulting promise. @end deffn -@deffn {Scheme Procedure} force promise -Takes a promise and returns the associated value(s) as follows: If -value(s) have been computed for the promise, these value(s) are -returned. Otherwise, the promise is first evaluated, then overwritten -by the obtained promise or value(s), and then force is again applied -(iteratively) to the promise. +@deffn {Scheme Procedure} force expression +Takes an argument of type @code{(Promise @var{a})} and returns a value +of type @var{a} as follows: If a value of type @var{a} has been computed +for the promise, this value is returned. Otherwise, the promise is +first evaluated, then overwritten by the obtained promise or value, and +then force is again applied (iteratively) to the promise. @end deffn -@deffn {Scheme Procedure} eager obj ... -Takes any number of argument(s) and returns a promise. As opposed to -@code{delay}, the argument(s) are evaluated eagerly. Semantically, -writing @code{(eager expression)} is equivalent to writing +@deffn {Scheme Procedure} eager expression +Takes an argument of type @var{a} and returns a value of type +@code{(Promise @var{a})}. As opposed to @code{delay}, the argument is +evaluated eagerly. Semantically, writing @code{(eager expression)} is +equivalent to writing @lisp (let ((value expression)) (delay value)). @end lisp However, the former is more efficient since it does not require -unnecessary creation and evaluation of thunks. For expressions that -return a single value, we also have the equivalence +unnecessary creation and evaluation of thunks. We also have the +equivalence @lisp (delay expression) = (lazy (eager expression)) @end lisp - -More generally, the following equivalence holds: - -@lisp -(delay expression) = (lazy (call-with-values - (lambda () expression) - eager)) -@end lisp @end deffn The following reduction rules may be helpful for reasoning about these @@ -3906,7 +3893,7 @@ usage semantics specified above: @lisp (force (delay expression)) -> expression (force (lazy expression)) -> (force expression) -(force (eager obj ...)) -> (values obj ...) +(force (eager value)) -> value @end lisp @subsubheading Correct usage diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm index f865f912c..7b7fedd88 100644 --- a/module/srfi/srfi-45.scm +++ b/module/srfi/srfi-45.scm @@ -1,6 +1,6 @@ ;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms -;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; Copyright (C) 2003 André van Tonder. All Rights Reserved. ;; Permission is hereby granted, free of charge, to any person @@ -25,8 +25,8 @@ ;;; Commentary: -;; This is the code of the reference implementation of SRFI-45, -;; modified to use SRFI-9 and to support multiple values. +;; This is the code of the reference implementation of SRFI-45, slightly +;; modified to use SRFI-9. ;; This module is documented in the Guile Reference Manual. @@ -36,9 +36,8 @@ #:export (delay lazy force - eager - promise?) - #:replace (delay force promise?) + eager) + #:replace (delay force) #:use-module (srfi srfi-9)) (cond-expand-provide (current-module) '(srfi-45)) @@ -53,18 +52,16 @@ (define-syntax-rule (lazy exp) (make-promise (make-value 'lazy (lambda () exp)))) -(define (eager . xs) - (make-promise (make-value 'eager xs))) +(define (eager x) + (make-promise (make-value 'eager x))) (define-syntax-rule (delay exp) - (lazy (call-with-values - (lambda () exp) - eager))) + (lazy (eager exp))) (define (force promise) (let ((content (promise-val promise))) (case (value-tag content) - ((eager) (apply values (value-proc content))) + ((eager) (value-proc content)) ((lazy) (let* ((promise* ((value-proc content))) (content (promise-val promise))) ; * (if (not (eqv? (value-tag content) 'eager)) ; * diff --git a/test-suite/tests/srfi-45.test b/test-suite/tests/srfi-45.test index cb3f7908f..573eea04a 100644 --- a/test-suite/tests/srfi-45.test +++ b/test-suite/tests/srfi-45.test @@ -1,7 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. -;; Copyright (C) 2003 André van Tonder. All Rights Reserved. +;; Copyright André van Tonder. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation @@ -259,43 +258,3 @@ ;; Commented out since it takes too long #; (test-equal 300000000 (force (times3 100000000))) ;==> bounded space - - -;====================================================================== -; Test promise? predicate (non-standard Guile extension) - -(pass-if "promise? predicate" - (promise? (delay 1))) - -;====================================================================== -; Test memoization of multiple values (non-standard Guile extension) - -(with-test-prefix "Multiple values (non-standard)" - - (let ((promise (delay (values 1 2 3)))) - (pass-if-equal "Multiple values delay" - '(1 2 3) - (call-with-values - (lambda () (force promise)) - list))) - - (let ((promise (eager 1 2 3))) - (pass-if-equal "Multiple values eager" - '(1 2 3) - (call-with-values - (lambda () (force promise)) - list))) - - (let ((promise (delay (values)))) - (pass-if-equal "Zero values delay" - '() - (call-with-values - (lambda () (force promise)) - list))) - - (let ((promise (eager))) - (pass-if-equal "Zero values eager" - '() - (call-with-values - (lambda () (force promise)) - list)))) From d291d7990d72b5cb8a18b20e524e1c8324297e92 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 26 Mar 2013 21:22:11 -0400 Subject: [PATCH 136/147] SRFI-45: add promise? predicate. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/srfi/srfi-45.scm (promise?): Export. * doc/ref/srfi-modules.texi (SRFI-45): Update docs. * test-suite/tests/srfi-45.test: Add test. Add FSF copyright for 2010 and 2013. Add missing year to André van Tonder's copyright notice. --- doc/ref/srfi-modules.texi | 7 +++++++ module/srfi/srfi-45.scm | 11 ++++++----- test-suite/tests/srfi-45.test | 10 +++++++++- 3 files changed, 22 insertions(+), 6 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index c99905c7d..513bb5966 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3845,6 +3845,13 @@ words, no program that uses the R5RS definitions of delay and force will break if those definition are replaced by the SRFI-45 definitions of delay and force. +Guile also adds @code{promise?} to the list of exports, which is not +part of the official SRFI-45. + +@deffn {Scheme Procedure} promise? obj +Return true if @var{obj} is an SRFI-45 promise, otherwise return false. +@end deffn + @deffn {Scheme Syntax} delay expression Takes an expression of arbitrary type @var{a} and returns a promise of type @code{(Promise @var{a})} which at some point in the future may be diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm index 7b7fedd88..51947700c 100644 --- a/module/srfi/srfi-45.scm +++ b/module/srfi/srfi-45.scm @@ -1,6 +1,6 @@ ;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. ;; Copyright (C) 2003 André van Tonder. All Rights Reserved. ;; Permission is hereby granted, free of charge, to any person @@ -25,8 +25,8 @@ ;;; Commentary: -;; This is the code of the reference implementation of SRFI-45, slightly -;; modified to use SRFI-9. +;; This is the code of the reference implementation of SRFI-45, modified +;; to use SRFI-9 and to add 'promise?' to the list of exports. ;; This module is documented in the Guile Reference Manual. @@ -36,8 +36,9 @@ #:export (delay lazy force - eager) - #:replace (delay force) + eager + promise?) + #:replace (delay force promise?) #:use-module (srfi srfi-9)) (cond-expand-provide (current-module) '(srfi-45)) diff --git a/test-suite/tests/srfi-45.test b/test-suite/tests/srfi-45.test index 573eea04a..e9fd029c9 100644 --- a/test-suite/tests/srfi-45.test +++ b/test-suite/tests/srfi-45.test @@ -1,6 +1,7 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;; Copyright André van Tonder. All Rights Reserved. +;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2003 André van Tonder. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation @@ -258,3 +259,10 @@ ;; Commented out since it takes too long #; (test-equal 300000000 (force (times3 100000000))) ;==> bounded space + + +;====================================================================== +; Test promise? predicate (non-standard Guile extension) + +(pass-if "promise? predicate" + (promise? (delay 1))) From 41502bd00f12a6bce97484d33f5519e97a04cf2a Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 26 Mar 2013 21:25:12 -0400 Subject: [PATCH 137/147] Manual: xref SRFI-45 from core Delayed Evaluation section. * doc/ref/api-evaluation.texi (Delayed Evaluation): Add cross-reference to SRFI-45. --- doc/ref/api-evaluation.texi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 5c932a720..c4e77a9b4 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -1067,7 +1067,8 @@ was found, or @code{#f} otherwise. The port is rewound. @cindex promises Promises are a convenient way to defer a calculation until its result -is actually needed, and to run such a calculation only once. +is actually needed, and to run such a calculation only once. Also +@pxref{SRFI-45}. @deffn syntax delay expr @rnindex delay From c548da6949fef565dd1267afa5bbf2c21edda366 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Tue, 26 Mar 2013 22:11:30 +0100 Subject: [PATCH 138/147] doc: Use a preferred naming convention in SRFI-9 examples. * doc/ref/api-compound.texi (SRFI-9 Records): Use "Scheme Syntax" instead of "library syntax". Remove `get-' from getter names, and add an exclamation mark in setter names. Change `employee-type' to `<employee>'. --- doc/ref/api-compound.texi | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 83de8077c..641245a21 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2248,7 +2248,7 @@ Overview}). It can be used with: (use-modules (srfi srfi-9)) @end example -@deffn {library syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} +@deffn {Scheme Syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} @sp 1 Create a new record type, and make various @code{define}s for using it. This syntax can only occur at the top-level, not nested within @@ -2283,12 +2283,12 @@ field in a @var{record}. An example will illustrate typical usage, @example -(define-record-type employee-type +(define-record-type <employee> (make-employee name age salary) employee? - (name get-employee-name) - (age get-employee-age set-employee-age) - (salary get-employee-salary set-employee-salary)) + (name employee-name) + (age employee-age set-employee-age!) + (salary employee-salary set-employee-salary!)) @end example This creates a new employee data type, with name, age and salary @@ -2298,13 +2298,13 @@ that it's established only when an employee object is created). These can all then be used as for example, @example -employee-type @result{} #<record-type employee-type> +<employee> @result{} #<record-type <employee>> (define fred (make-employee "Fred" 45 20000.00)) (employee? fred) @result{} #t -(get-employee-age fred) @result{} 45 -(set-employee-salary fred 25000.00) ;; pay rise +(employee-age fred) @result{} 45 +(set-employee-salary! fred 25000.00) ;; pay rise @end example The functions created by @code{define-record-type} are ordinary @@ -2334,10 +2334,10 @@ an output port. This example prints the employee's name in brackets, for instance @code{[Fred]}. @example -(set-record-type-printer! employee-type +(set-record-type-printer! <employee> (lambda (record port) (write-char #\[ port) - (display (get-employee-name record) port) + (display (employee-name record) port) (write-char #\] port))) @end example From ffc8eca636a8e9311d35c9adba2fc80476ab11ca Mon Sep 17 00:00:00 2001 From: Daniel Hartwig <mandyke@gmail.com> Date: Fri, 15 Mar 2013 22:25:10 +0800 Subject: [PATCH 139/147] web http: parse numeric time zones in headers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/web/http.scm (parse-zone-offset, normalize-date): New procedures. (parse-rfc-822-date, parse-rfc-850-date, parse-date): Update. * test-suite/tests/web-http.test ("general headers"): Add test. Signed-off-by: Ludovic Courtès <ludo@gnu.org> --- module/web/http.scm | 61 +++++++++++++++++++++++++--------- test-suite/tests/web-http.test | 3 ++ 2 files changed, 49 insertions(+), 15 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index b5202b69c..35169ef5c 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -702,29 +702,50 @@ as an ordered alist." (else (bad)))) (else (bad)))))) +;; "GMT" | "+" 4DIGIT | "-" 4DIGIT +;; +;; RFC 2616 requires date values to use "GMT", but recommends accepting +;; the others as they are commonly generated by e.g. RFC 822 sources. +(define (parse-zone-offset str start) + (let ((s (substring str start))) + (define (bad) + (bad-header-component 'zone-offset s)) + (cond + ((string=? s "GMT") + 0) + ((string-match? s ".dddd") + (let ((sign (case (string-ref s 0) + ((#\+) +1) + ((#\-) -1) + (else (bad)))) + (hours (parse-non-negative-integer s 1 3)) + (minutes (parse-non-negative-integer s 3 5))) + (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich + (else (bad))))) + ;; RFC 822, updated by RFC 1123 ;; ;; Sun, 06 Nov 1994 08:49:37 GMT ;; 01234567890123456789012345678 ;; 0 1 2 -(define (parse-rfc-822-date str) +(define (parse-rfc-822-date str space zone-offset) ;; We could verify the day of the week but we don't. - (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT") + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") (let ((date (parse-non-negative-integer str 5 7)) (month (parse-month str 8 11)) (year (parse-non-negative-integer str 12 16)) (hour (parse-non-negative-integer str 17 19)) (minute (parse-non-negative-integer str 20 22)) (second (parse-non-negative-integer str 23 25))) - (make-date 0 second minute hour date month year 0))) - ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT") + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") (let ((date (parse-non-negative-integer str 5 6)) (month (parse-month str 7 10)) (year (parse-non-negative-integer str 11 15)) (hour (parse-non-negative-integer str 16 18)) (minute (parse-non-negative-integer str 19 21)) (second (parse-non-negative-integer str 22 24))) - (make-date 0 second minute hour date month year 0))) + (make-date 0 second minute hour date month year zone-offset))) (else (bad-header 'date str) ; prevent tail call #f))) @@ -733,10 +754,10 @@ as an ordered alist." ;; Sunday, 06-Nov-94 08:49:37 GMT ;; 0123456789012345678901 ;; 0 1 2 -(define (parse-rfc-850-date str comma) +(define (parse-rfc-850-date str comma space zone-offset) ;; We could verify the day of the week but we don't. - (let ((tail (substring str (1+ comma)))) - (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT")) + (let ((tail (substring str (1+ comma) space))) + (if (not (string-match? tail " dd-aaa-dd dd:dd:dd")) (bad-header 'date str)) (let ((date (parse-non-negative-integer tail 1 3)) (month (parse-month tail 4 7)) @@ -750,7 +771,7 @@ as an ordered alist." (cond ((< (+ then 50) now) (+ then 100)) ((< (+ now 50) then) (- then 100)) (else then))) - 0)))) + zone-offset)))) ;; ANSI C's asctime() format ;; Sun Nov 6 08:49:37 1994 @@ -770,13 +791,23 @@ as an ordered alist." (second (parse-non-negative-integer str 17 19))) (make-date 0 second minute hour date month year 0))) +;; Convert all date values to GMT time zone, as per RFC 2616 appendix C. +(define (normalize-date date) + (if (zero? (date-zone-offset date)) + date + (time-utc->date (date->time-utc date) 0))) + (define (parse-date str) - (if (string-suffix? " GMT" str) - (let ((comma (string-index str #\,))) - (cond ((not comma) (bad-header 'date str)) - ((= comma 3) (parse-rfc-822-date str)) - (else (parse-rfc-850-date str comma)))) - (parse-asctime-date str))) + (let* ((space (string-rindex str #\space)) + (zone-offset (and space (false-if-exception + (parse-zone-offset str (1+ space)))))) + (normalize-date + (if zone-offset + (let ((comma (string-index str #\,))) + (cond ((not comma) (bad-header 'date str)) + ((= comma 3) (parse-rfc-822-date str space zone-offset)) + (else (parse-rfc-850-date str comma space zone-offset)))) + (parse-asctime-date str))))) (define (write-date date port) (define (display-digits n digits port) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 291372445..b2c5c2c2b 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -216,6 +216,9 @@ (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT" (string->date "Tue, 15 Nov 1994 08:12:31 +0000" "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse date "Tue, 15 Nov 1994 16:12:31 +0800" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) (pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT" (string->date "Wed, 7 Sep 2011 11:25:00 +0000" "~a,~e ~b ~Y ~H:~M:~S ~z")) From 8cd109bf0a10e37c26bf476fed81a0d4282d13c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Mar 2013 16:45:54 +0100 Subject: [PATCH 140/147] Document `and=>'. * module/ice-9/boot-9.scm (and=>): Add docstring. * doc/ref/api-procedures.texi (Higher-Order Functions): Add `and=>'. --- doc/ref/api-procedures.texi | 5 +++++ module/ice-9/boot-9.scm | 5 ++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e0158fd09..8ff240a14 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -717,6 +717,11 @@ compatible arity. Return X. @end deffn +@deffn {Scheme Procedure} and=> value proc +When @var{value} is @code{#f}, return @code{#f}. Otherwise, return +@code{(@var{proc} @var{value})}. +@end deffn + @node Procedure Properties @subsection Procedure Properties and Meta-information diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ced3a2841..8461ee80d 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -944,7 +944,10 @@ VALUE." (lambda _ value)) -(define (and=> value procedure) (and value (procedure value))) +(define (and=> value procedure) + "When VALUE is #f, return #f. Otherwise, return (PROC VALUE)." + (and value (procedure value))) + (define call/cc call-with-current-continuation) (define-syntax false-if-exception From 8a177d316c0062afe74f9a761ef460e297435e59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Mar 2013 18:03:47 +0100 Subject: [PATCH 141/147] futures: Limit the number of nested futures on the same stack. Fixes <http://bugs.gnu.org/13188>. Reported by Nala Ginrut <nalaginrut@gmail.com>. * module/ice-9/futures.scm (%nesting-level): Rename to... (%nesting-level): ... this. Default to 0 instead of #f. Update users. (%max-nesting-level): New variable. (touch): When FUTURE is queued and (%nesting-level) is above %MAX-NESTING-LEVEL, abort to %FUTURE-PROMPT. * test-suite/tests/future.test ("nested futures")["loop"]: Remove `compile' call. * test-suite/tests/threads.test ("par-map")["long list"]: New test. * doc/ref/api-scheduling.texi (Futures): Add a paragraph about stack consumption. --- doc/ref/api-scheduling.texi | 7 +++++++ module/ice-9/futures.scm | 23 ++++++++++++++++------- test-suite/tests/future.test | 18 +++++++----------- test-suite/tests/threads.test | 9 +++++++-- 4 files changed, 37 insertions(+), 20 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index e040904cf..b23082192 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -1037,6 +1037,13 @@ future has completed. This suspend/resume is achieved by capturing the calling future's continuation, and later reinstating it (@pxref{Prompts, delimited continuations}). +Note that @code{par-map} above is not tail-recursive. This could lead +to stack overflows when @var{lst} is large compared to +@code{(current-processor-count)}. To address that, @code{touch} uses +the suspend mechanism described above to limit the number of nested +futures executing on the same stack. Thus, the above code should never +run into stack overflows. + @deffn {Scheme Syntax} future exp Return a future for expression @var{exp}. This is equivalent to: diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm index 6ff104d73..35a36ca59 100644 --- a/module/ice-9/futures.scm +++ b/module/ice-9/futures.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;; Copyright (C) 2010, 2011, 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,8 +88,14 @@ touched." ;; 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)) +;; Nesting level of futures. Incremented each time a future is touched +;; from within a future. +(define %nesting-level (make-parameter 0)) + +;; Maximum nesting level. The point is to avoid stack overflows when +;; nested futures are executed on the same stack. See +;; <http://bugs.gnu.org/13188>. +(define %max-nesting-level 200) (define-syntax-rule (with-mutex m e0 e1 ...) ;; Copied from (ice-9 threads) to avoid circular dependency. @@ -155,7 +161,8 @@ adding it to the waiter queue." (thunk (lambda () (call-with-prompt %future-prompt (lambda () - (parameterize ((%within-future? #t)) + (parameterize ((%nesting-level + (1+ (%nesting-level)))) ((future-thunk future)))) suspend)))) (set-future-result! future @@ -254,14 +261,16 @@ adding it to the waiter queue." (unlock-mutex (future-mutex future))) ((started) (unlock-mutex (future-mutex future)) - (if (%within-future?) + (if (> (%nesting-level) 0) (abort-to-prompt %future-prompt future) (begin (work) (loop)))) - (else + (else ; queued (unlock-mutex (future-mutex future)) - (work) + (if (> (%nesting-level) %max-nesting-level) + (abort-to-prompt %future-prompt future) + (work)) (loop)))) ((future-result future))) diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test index b8bacb2f0..a398aff37 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, 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 @@ -22,8 +22,7 @@ #:use-module (test-suite lib) #:use-module (ice-9 futures) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (system base compile)) + #:use-module (srfi srfi-26)) (define specific-exception-key (gensym)) @@ -98,11 +97,8 @@ (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)))) + (let loop ((list (iota 1000))) + (if (null? list) + '() + (cons (- (car list)) + (touch (future (loop (cdr list))))))))) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index be722fc75..817812051 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -1,6 +1,6 @@ ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 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 @@ -86,7 +86,12 @@ (equal? (par-map fibo (iota 13)) (map fibo (iota 13)))) #:to 'value - #:env (current-module)))) + #:env (current-module))) + + (pass-if-equal "long list" (map 1+ (iota 10000)) + ;; In Guile 2.0.7, this would trigger a stack overflow. + ;; See <http://bugs.gnu.org/13188>. + (par-map 1+ (iota 10000)))) ;; ;; par-for-each From ed4aa26489d33c22bcdbce2bb037a87df41bef16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org> Date: Wed, 27 Mar 2013 18:05:45 +0100 Subject: [PATCH 142/147] Update `NEWS'. --- NEWS | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index fe6bad134..80b06fd74 100644 --- a/NEWS +++ b/NEWS @@ -144,8 +144,8 @@ have been deprecated. ** Deprecate `http-get*'. The new `#:streaming?' argument to `http-get' subsumes the functionality -of `http-get*'. Also, the `#:extra-headers' argument is deprecated in -favor of `#:headers'. +of `http-get*' (introduced in 2.0.7). Also, the `#:extra-headers' +argument is deprecated in favor of `#:headers'. ** Deprecate (ice-9 mapping). @@ -163,6 +163,10 @@ See "Bitwise Operations". See "Environment Variables". +** New procedure `sendfile'. + +See "File System". + ** New procedures for dealing with file names. See XXX for documentation on `system-file-name-convention', @@ -248,6 +252,12 @@ refer to this variable to describe where users should install their * Bug fixes +** SRFI-37: Fix infinite loop when parsing optional-argument short options + (http://bugs.gnu.org/13176) +** web: Support non-GMT date headers in the HTTP client + (http://bugs.gnu.org/13544) +** Avoid stack overflows with `par-map' and nested futures in general + (http://bugs.gnu.org/13188) ** A fork when multiple threads are running will now print a warning. ** Allow for spurious wakeups from pthread_cond_wait. (http://bugs.gnu.org/10641) From 50d08cd8943dd54762d76746d5eec53af178eeae Mon Sep 17 00:00:00 2001 From: "Chris K. Jester-Young" <cky944@gmail.com> Date: Tue, 26 Mar 2013 22:15:31 -0400 Subject: [PATCH 143/147] Add SRFI-41. Incorporates suggestions from Mark H Weaver <mhw@netris.org> and Ian Price <ianprice90@googlemail.com>. * module/srfi/srfi-41.scm: New file. * module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-41.scm. * test-suite/tests/srfi-41.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-41.test. * doc/ref/srfi-modules.texi (SRFI Support): Add SRFI-41. (SRFI-41): New node which refers the reader to <http://srfi.schemers.org/srfi-41/srfi-41.html>. --- doc/ref/srfi-modules.texi | 8 + module/Makefile.am | 1 + module/srfi/srfi-41.scm | 482 ++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/srfi-41.test | 680 ++++++++++++++++++++++++++++++++++ 5 files changed, 1172 insertions(+) create mode 100644 module/srfi/srfi-41.scm create mode 100644 test-suite/tests/srfi-41.test diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 513bb5966..5a892097a 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -45,6 +45,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-37:: args-fold program argument processor * SRFI-38:: External Representation for Data With Shared Structure * SRFI-39:: Parameter objects +* SRFI-41:: Streams. * SRFI-42:: Eager comprehensions * SRFI-45:: Primitives for expressing iterative lazy algorithms * SRFI-55:: Requiring Features. @@ -3788,6 +3789,13 @@ scope and the result from that @var{thunk} is the return from @code{with-parameters*}. @end defun +@node SRFI-41 +@subsection SRFI-41 - Streams +@cindex SRFI-41 + +See @uref{http://srfi.schemers.org/srfi-41/srfi-41.html, the +specification of SRFI-41}. + @node SRFI-42 @subsection SRFI-42 - Eager Comprehensions @cindex SRFI-42 diff --git a/module/Makefile.am b/module/Makefile.am index c47d0b476..416ad2238 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -282,6 +282,7 @@ SRFI_SOURCES = \ srfi/srfi-35.scm \ srfi/srfi-37.scm \ srfi/srfi-38.scm \ + srfi/srfi-41.scm \ srfi/srfi-42.scm \ srfi/srfi-39.scm \ srfi/srfi-45.scm \ diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm new file mode 100644 index 000000000..edf95d7d9 --- /dev/null +++ b/module/srfi/srfi-41.scm @@ -0,0 +1,482 @@ +;;; srfi-41.scm -- SRFI 41 streams + +;; Copyright (c) 2007 Philip L. Bewig +;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-module (srfi srfi-41) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (stream-null stream-cons stream? stream-null? stream-pair? + stream-car stream-cdr stream-lambda define-stream + list->stream port->stream stream stream->list stream-append + stream-concat stream-constant stream-drop stream-drop-while + stream-filter stream-fold stream-for-each stream-from + stream-iterate stream-length stream-let stream-map + stream-match stream-of stream-range stream-ref stream-reverse + stream-scan stream-take stream-take-while stream-unfold + stream-unfolds stream-zip)) + +(cond-expand-provide (current-module) '(srfi-41)) + +;;; Private supporting functions and macros. + +(define-syntax-rule (must pred obj func msg args ...) + (let ((item obj)) + (unless (pred item) + (throw 'wrong-type-arg func msg (list args ...) (list item))))) + +(define-syntax-rule (must-not pred obj func msg args ...) + (let ((item obj)) + (when (pred item) + (throw 'wrong-type-arg func msg (list args ...) (list item))))) + +(define-syntax-rule (must-every pred objs func msg args ...) + (let ((flunk (remove pred objs))) + (unless (null? flunk) + (throw 'wrong-type-arg func msg (list args ...) flunk)))) + +(define-syntax-rule (first-value expr) + (receive (first . _) expr + first)) + +(define-syntax-rule (second-value expr) + (receive (first second . _) expr + second)) + +(define-syntax-rule (third-value expr) + (receive (first second third . _) expr + third)) + +(define-syntax define-syntax* + (syntax-rules () + ((_ (name . args) body ...) + (define-syntax name (lambda* args body ...))) + ((_ name syntax) + (define-syntax name syntax)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Here we include a copy of the code of srfi-45.scm (but with renamed +;; identifiers), in order to create a new promise type that's disjoint +;; from the promises created by srfi-45. Ideally this should be done +;; using a 'make-promise-type' macro that instantiates a copy of this +;; code, but a psyntax bug in Guile 2.0 prevents this from working +;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the +;; code. + +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2003 André van Tonder. All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-record-type stream-promise (make-stream-promise val) stream-promise? + (val stream-promise-val stream-promise-val-set!)) + +(define-record-type stream-value (make-stream-value tag proc) stream-value? + (tag stream-value-tag stream-value-tag-set!) + (proc stream-value-proc stream-value-proc-set!)) + +(define-syntax-rule (stream-lazy exp) + (make-stream-promise (make-stream-value 'lazy (lambda () exp)))) + +(define (stream-eager x) + (make-stream-promise (make-stream-value 'eager x))) + +(define-syntax-rule (stream-delay exp) + (stream-lazy (stream-eager exp))) + +(define (stream-force promise) + (let ((content (stream-promise-val promise))) + (case (stream-value-tag content) + ((eager) (stream-value-proc content)) + ((lazy) (let* ((promise* ((stream-value-proc content))) + (content (stream-promise-val promise))) + (if (not (eqv? (stream-value-tag content) 'eager)) + (begin (stream-value-tag-set! content + (stream-value-tag (stream-promise-val promise*))) + (stream-value-proc-set! content + (stream-value-proc (stream-promise-val promise*))) + (stream-promise-val-set! promise* content))) + (stream-force promise)))))) + +;; +;; End of the copy of the code from srfi-45.scm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Primitive stream functions and macros: (streams primitive) + +(define stream? stream-promise?) + +(define %stream-null '(stream . null)) +(define stream-null (stream-eager %stream-null)) + +(define (stream-null? obj) + (and (stream-promise? obj) + (eqv? (stream-force obj) %stream-null))) + +(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare? + (kar stream-kar) + (kdr stream-kdr)) + +(define (stream-pair? obj) + (and (stream-promise? obj) (stream-pare? (stream-force obj)))) + +(define-syntax-rule (stream-cons obj strm) + (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm)))) + +(define (stream-car strm) + (must stream? strm 'stream-car "non-stream") + (let ((pare (stream-force strm))) + (must stream-pare? pare 'stream-car "null stream") + (stream-force (stream-kar pare)))) + +(define (stream-cdr strm) + (must stream? strm 'stream-cdr "non-stream") + (let ((pare (stream-force strm))) + (must stream-pare? pare 'stream-cdr "null stream") + (stream-kdr pare))) + +(define-syntax-rule (stream-lambda formals body0 body1 ...) + (lambda formals (stream-lazy (begin body0 body1 ...)))) + +;;; Derived stream functions and macros: (streams derived) + +(define-syntax-rule (define-stream (name . formal) body0 body1 ...) + (define name (stream-lambda formal body0 body1 ...))) + +(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...) + ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)) + +(define (list->stream objs) + (define (list? x) + (or (proper-list? x) (circular-list? x))) + (must list? objs 'list->stream "non-list argument") + (stream-let recur ((objs objs)) + (if (null? objs) stream-null + (stream-cons (car objs) (recur (cdr objs)))))) + +(define* (port->stream #:optional (port (current-input-port))) + (must input-port? port 'port->stream "non-input-port argument") + (stream-let recur () + (let ((c (read-char port))) + (if (eof-object? c) stream-null + (stream-cons c (recur)))))) + +(define-syntax stream + (syntax-rules () + ((_) stream-null) + ((_ x y ...) (stream-cons x (stream y ...))))) + +;; Common helper for the various eager-folding functions, such as +;; stream-fold, stream-drop, stream->list, stream-length, etc. +(define-inlinable (stream-fold-aux proc base strm limit) + (do ((val base (and proc (proc val (stream-car strm)))) + (strm strm (stream-cdr strm)) + (limit limit (and limit (1- limit)))) + ((or (and limit (zero? limit)) (stream-null? strm)) + (values val strm limit)))) + +(define stream->list + (case-lambda + ((strm) (stream->list #f strm)) + ((n strm) + (must stream? strm 'stream->list "non-stream argument") + (when n + (must integer? n 'stream->list "non-integer count") + (must exact? n 'stream->list "inexact count") + (must-not negative? n 'stream->list "negative count")) + (reverse! (first-value (stream-fold-aux xcons '() strm n)))))) + +(define (stream-append . strms) + (must-every stream? strms 'stream-append "non-stream argument") + (stream-let recur ((strms strms)) + (if (null? strms) stream-null + (let ((strm (car strms))) + (if (stream-null? strm) (recur (cdr strms)) + (stream-cons (stream-car strm) + (recur (cons (stream-cdr strm) (cdr strms))))))))) + +(define (stream-concat strms) + (must stream? strms 'stream-concat "non-stream argument") + (stream-let recur ((strms strms)) + (if (stream-null? strms) stream-null + (let ((strm (stream-car strms))) + (must stream? strm 'stream-concat "non-stream object in input stream") + (if (stream-null? strm) (recur (stream-cdr strms)) + (stream-cons (stream-car strm) + (recur (stream-cons (stream-cdr strm) + (stream-cdr strms))))))))) + +(define stream-constant + (case-lambda + (() stream-null) + (objs (list->stream (apply circular-list objs))))) + +(define-syntax* (stream-do x) + (define (end x) + (syntax-case x () + (() #'(if #f #f)) + ((result) #'result) + ((result ...) #'(begin result ...)))) + (define (var-step v s) + (syntax-case s () + (() v) + ((e) #'e) + (_ (syntax-violation 'stream-do "bad step expression" x s)))) + + (syntax-case x () + ((_ ((var init . step) ...) + (test result ...) + expr ...) + (with-syntax ((result (end #'(result ...))) + ((step ...) (map var-step #'(var ...) #'(step ...)))) + #'(stream-let loop ((var init) ...) + (if test result + (begin + expr ... + (loop step ...)))))))) + +(define (stream-drop n strm) + (must integer? n 'stream-drop "non-integer argument") + (must exact? n 'stream-drop "inexact argument") + (must-not negative? n 'stream-drop "negative argument") + (must stream? strm 'stream-drop "non-stream argument") + (second-value (stream-fold-aux #f #f strm n))) + +(define (stream-drop-while pred? strm) + (must procedure? pred? 'stream-drop-while "non-procedural argument") + (must stream? strm 'stream-drop-while "non-stream argument") + (stream-do ((strm strm (stream-cdr strm))) + ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm))) + +(define (stream-filter pred? strm) + (must procedure? pred? 'stream-filter "non-procedural argument") + (must stream? strm 'stream-filter "non-stream argument") + (stream-let recur ((strm strm)) + (cond ((stream-null? strm) stream-null) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (recur (stream-cdr strm)))) + (else (recur (stream-cdr strm)))))) + +(define (stream-fold proc base strm) + (must procedure? proc 'stream-fold "non-procedural argument") + (must stream? strm 'stream-fold "non-stream argument") + (first-value (stream-fold-aux proc base strm #f))) + +(define stream-for-each + (case-lambda + ((proc strm) + (must procedure? proc 'stream-for-each "non-procedural argument") + (must stream? strm 'stream-for-each "non-stream argument") + (do ((strm strm (stream-cdr strm))) + ((stream-null? strm)) + (proc (stream-car strm)))) + ((proc strm . rest) + (let ((strms (cons strm rest))) + (must procedure? proc 'stream-for-each "non-procedural argument") + (must-every stream? strms 'stream-for-each "non-stream argument") + (do ((strms strms (map stream-cdr strms))) + ((any stream-null? strms)) + (apply proc (map stream-car strms))))))) + +(define* (stream-from first #:optional (step 1)) + (must number? first 'stream-from "non-numeric starting number") + (must number? step 'stream-from "non-numeric step size") + (stream-let recur ((first first)) + (stream-cons first (recur (+ first step))))) + +(define (stream-iterate proc base) + (must procedure? proc 'stream-iterate "non-procedural argument") + (stream-let recur ((base base)) + (stream-cons base (recur (proc base))))) + +(define (stream-length strm) + (must stream? strm 'stream-length "non-stream argument") + (- -1 (third-value (stream-fold-aux #f #f strm -1)))) + +(define stream-map + (case-lambda + ((proc strm) + (must procedure? proc 'stream-map "non-procedural argument") + (must stream? strm 'stream-map "non-stream argument") + (stream-let recur ((strm strm)) + (if (stream-null? strm) stream-null + (stream-cons (proc (stream-car strm)) + (recur (stream-cdr strm)))))) + ((proc strm . rest) + (let ((strms (cons strm rest))) + (must procedure? proc 'stream-map "non-procedural argument") + (must-every stream? strms 'stream-map "non-stream argument") + (stream-let recur ((strms strms)) + (if (any stream-null? strms) stream-null + (stream-cons (apply proc (map stream-car strms)) + (recur (map stream-cdr strms))))))))) + +(define-syntax* (stream-match x) + (define (make-matcher x) + (syntax-case x () + (() #'(? stream-null?)) + (rest (identifier? #'rest) #'rest) + ((var . rest) (identifier? #'var) + (with-syntax ((next (make-matcher #'rest))) + #'(? (negate stream-null?) + (= stream-car var) + (= stream-cdr next)))))) + (define (make-guarded x fail) + (syntax-case (list x fail) () + (((expr) _) #'expr) + (((guard expr) fail) #'(if guard expr (fail))))) + + (syntax-case x () + ((_ strm-expr (pat . expr) ...) + (with-syntax (((fail ...) (generate-temporaries #'(pat ...)))) + (with-syntax (((matcher ...) (map make-matcher #'(pat ...))) + ((expr ...) (map make-guarded #'(expr ...) #'(fail ...)))) + #'(let ((strm strm-expr)) + (must stream? strm 'stream-match "non-stream argument") + (match strm (matcher (=> fail) expr) ...))))))) + +(define-syntax-rule (stream-of expr rest ...) + (stream-of-aux expr stream-null rest ...)) + +(define-syntax stream-of-aux + (syntax-rules (in is) + ((_ expr base) + (stream-cons expr base)) + ((_ expr base (var in stream) rest ...) + (stream-let recur ((strm stream)) + (if (stream-null? strm) base + (let ((var (stream-car strm))) + (stream-of-aux expr (recur (stream-cdr strm)) rest ...))))) + ((_ expr base (var is exp) rest ...) + (let ((var exp)) (stream-of-aux expr base rest ...))) + ((_ expr base pred? rest ...) + (if pred? (stream-of-aux expr base rest ...) base)))) + +(define* (stream-range first past #:optional step) + (must number? first 'stream-range "non-numeric starting number") + (must number? past 'stream-range "non-numeric ending number") + (when step + (must number? step 'stream-range "non-numeric step size")) + (let* ((step (or step (if (< first past) 1 -1))) + (lt? (if (< 0 step) < >))) + (stream-let recur ((first first)) + (if (lt? first past) + (stream-cons first (recur (+ first step))) + stream-null)))) + +(define (stream-ref strm n) + (must stream? strm 'stream-ref "non-stream argument") + (must integer? n 'stream-ref "non-integer argument") + (must exact? n 'stream-ref "inexact argument") + (must-not negative? n 'stream-ref "negative argument") + (let ((res (stream-drop n strm))) + (must-not stream-null? res 'stream-ref "beyond end of stream") + (stream-car res))) + +(define (stream-reverse strm) + (must stream? strm 'stream-reverse "non-stream argument") + (stream-do ((strm strm (stream-cdr strm)) + (rev stream-null (stream-cons (stream-car strm) rev))) + ((stream-null? strm) rev))) + +(define (stream-scan proc base strm) + (must procedure? proc 'stream-scan "non-procedural argument") + (must stream? strm 'stream-scan "non-stream argument") + (stream-let recur ((base base) (strm strm)) + (if (stream-null? strm) (stream base) + (stream-cons base (recur (proc base (stream-car strm)) + (stream-cdr strm)))))) + +(define (stream-take n strm) + (must stream? strm 'stream-take "non-stream argument") + (must integer? n 'stream-take "non-integer argument") + (must exact? n 'stream-take "inexact argument") + (must-not negative? n 'stream-take "negative argument") + (stream-let recur ((n n) (strm strm)) + (if (or (zero? n) (stream-null? strm)) stream-null + (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm)))))) + +(define (stream-take-while pred? strm) + (must procedure? pred? 'stream-take-while "non-procedural argument") + (must stream? strm 'stream-take-while "non-stream argument") + (stream-let recur ((strm strm)) + (cond ((stream-null? strm) stream-null) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (recur (stream-cdr strm)))) + (else stream-null)))) + +(define (stream-unfold mapper pred? generator base) + (must procedure? mapper 'stream-unfold "non-procedural mapper") + (must procedure? pred? 'stream-unfold "non-procedural pred?") + (must procedure? generator 'stream-unfold "non-procedural generator") + (stream-let recur ((base base)) + (if (pred? base) + (stream-cons (mapper base) (recur (generator base))) + stream-null))) + +(define (stream-unfolds gen seed) + (define-stream (generator-stream seed) + (receive (next . items) (gen seed) + (stream-cons (list->vector items) (generator-stream next)))) + (define-stream (make-result-stream genstrm index) + (define head (vector-ref (stream-car genstrm) index)) + (define-stream (tail) (make-result-stream (stream-cdr genstrm) index)) + (match head + (() stream-null) + (#f (tail)) + ((item) (stream-cons item (tail))) + ((? list? items) (stream-append (list->stream items) (tail))))) + + (must procedure? gen 'stream-unfolds "non-procedural argument") + (let ((genstrm (generator-stream seed))) + (apply values (list-tabulate (vector-length (stream-car genstrm)) + (cut make-result-stream genstrm <>))))) + +(define (stream-zip strm . rest) + (let ((strms (cons strm rest))) + (must-every stream? strms 'stream-zip "non-stream argument") + (stream-let recur ((strms strms)) + (if (any stream-null? strms) stream-null + (stream-cons (map stream-car strms) (recur (map stream-cdr strms))))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index e7c8c4177..01ffd1c77 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -131,6 +131,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-37.test \ tests/srfi-38.test \ tests/srfi-39.test \ + tests/srfi-41.test \ tests/srfi-42.test \ tests/srfi-45.test \ tests/srfi-60.test \ diff --git a/test-suite/tests/srfi-41.test b/test-suite/tests/srfi-41.test new file mode 100644 index 000000000..f2e0864e8 --- /dev/null +++ b/test-suite/tests/srfi-41.test @@ -0,0 +1,680 @@ +;;; srfi-41.test -- test suite for SRFI 41 + +;; Copyright (c) 2007 Philip L. Bewig +;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-module (test-srfi-41) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-31) + #:use-module (srfi srfi-41) + #:use-module (test-suite lib)) + +(define-stream (qsort lt? strm) + (if (stream-null? strm) stream-null + (let ((x (stream-car strm)) + (xs (stream-cdr strm))) + (stream-append + (qsort lt? (stream-filter (cut lt? <> x) xs)) + (stream x) + (qsort lt? (stream-filter (cut (negate lt?) <> x) xs)))))) + +(define-stream (isort lt? strm) + (define-stream (insert strm x) + (stream-match strm + (() (stream x)) + ((y . ys) (if (lt? y x) + (stream-cons y (insert ys x)) + (stream-cons x strm))))) + (stream-fold insert stream-null strm)) + +(define-stream (stream-merge lt? . strms) + (stream-let loop ((strms strms)) + (cond ((null? strms) stream-null) + ((null? (cdr strms)) (car strms)) + (else (stream-let merge ((xx (car strms)) + (yy (loop (cdr strms)))) + (stream-match xx + (() yy) + ((x . xs) + (stream-match yy + (() xx) + ((y . ys) + (if (lt? y x) + (stream-cons y (merge xx ys)) + (stream-cons x (merge xs yy)))))))))))) + +(define-stream (msort lt? strm) + (let* ((n (quotient (stream-length strm) 2)) + (ts (stream-take n strm)) + (ds (stream-drop n strm))) + (if (zero? n) strm + (stream-merge lt? (msort < ts) (msort < ds))))) + +(define-stream (stream-unique eql? strm) + (if (stream-null? strm) stream-null + (stream-cons (stream-car strm) + (stream-unique eql? + (stream-drop-while (cut eql? (stream-car strm) <>) strm))))) + +(define nats + (stream-cons 1 + (stream-map 1+ nats))) + +(define hamming + (stream-unique = + (stream-cons 1 + (stream-merge < + (stream-map (cut * 2 <>) hamming) + (stream-merge < + (stream-map (cut * 3 <>) hamming) + (stream-map (cut * 5 <>) hamming)))))) + +(define primes (let () + (define-stream (next base mult strm) + (let ((first (stream-car strm)) + (rest (stream-cdr strm))) + (cond ((< first mult) + (stream-cons first + (next base mult rest))) + ((< mult first) + (next base (+ base mult) strm)) + (else (next base + (+ base mult) rest))))) + (define-stream (sift base strm) + (next base (+ base base) strm)) + (stream-let sieve ((strm (stream-from 2))) + (let ((first (stream-car strm)) + (rest (stream-cdr strm))) + (stream-cons first (sieve (sift first rest))))))) + +(define strm123 (stream 1 2 3)) + +(define (stream-equal? s1 s2) + (cond ((and (stream-null? s1) (stream-null? s2)) #t) + ((or (stream-null? s1) (stream-null? s2)) #f) + ((equal? (stream-car s1) (stream-car s2)) + (stream-equal? (stream-cdr s1) (stream-cdr s2))) + (else #f))) + +(with-test-prefix "stream-null" + (pass-if "is a stream" (stream? stream-null)) + (pass-if "is a null stream" (stream-null? stream-null)) + (pass-if "is not a stream pair" (not (stream-pair? stream-null)))) + +(with-test-prefix "stream-cons" + (pass-if "is a stream" (stream? (stream-cons 1 stream-null))) + (pass-if "is not a null stream" (not (stream-null? (stream-cons 1 stream-null)))) + (pass-if "is a stream pair" (stream-pair? (stream-cons 1 stream-null)))) + +(with-test-prefix "stream?" + (pass-if "is true for null stream" (stream? stream-null)) + (pass-if "is true for stream pair" (stream? (stream-cons 1 stream-null))) + (pass-if "is false for non-stream" (not (stream? "four")))) + +(with-test-prefix "stream-null?" + (pass-if "is true for null stream" (stream-null? stream-null)) + (pass-if "is false for stream pair" (not (stream-null? (stream-cons 1 stream-null)))) + (pass-if "is false for non-stream" (not (stream-null? "four")))) + +(with-test-prefix "stream-pair?" + (pass-if "is false for null stream" (not (stream-pair? stream-null))) + (pass-if "is true for stream pair" (stream-pair? (stream-cons 1 stream-null))) + (pass-if "is false for non-stream" (not (stream-pair? "four")))) + +(with-test-prefix "stream-car" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream") + (stream-car "four")) + (pass-if-exception "throws for null stream" + '(wrong-type-arg . "null stream") + (stream-car stream-null)) + (pass-if "returns first of stream" (eqv? (stream-car strm123) 1))) + +(with-test-prefix "stream-cdr" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream") + (stream-cdr "four")) + (pass-if-exception "throws for null stream" + '(wrong-type-arg . "null stream") + (stream-cdr stream-null)) + (pass-if "returns rest of stream" (eqv? (stream-car (stream-cdr strm123)) 2))) + +(with-test-prefix "stream-lambda" + (pass-if "returns correct result" + (stream-equal? + ((rec double (stream-lambda (strm) + (if (stream-null? strm) stream-null + (stream-cons (* 2 (stream-car strm)) + (double (stream-cdr strm)))))) + strm123) + (stream 2 4 6)))) + +(with-test-prefix "define-stream" + (pass-if "returns correct result" + (stream-equal? + (let () + (define-stream (double strm) + (if (stream-null? strm) stream-null + (stream-cons (* 2 (stream-car strm)) + (double (stream-cdr strm))))) + (double strm123)) + (stream 2 4 6)))) + +(with-test-prefix "list->stream" + (pass-if-exception "throws for non-list" + '(wrong-type-arg . "non-list argument") + (list->stream "four")) + (pass-if "returns empty stream for empty list" + (stream-null? (list->stream '()))) + (pass-if "returns stream with same content as given list" + (stream-equal? (list->stream '(1 2 3)) strm123))) + +(with-test-prefix "port->stream" + (pass-if-exception "throws for non-input-port" + '(wrong-type-arg . "non-input-port argument") + (port->stream "four")) + (call-with-input-string "Hello, world!" + (lambda (p) + (pass-if-equal "reads input string correctly" + "Hello, world!" + (list->string (stream->list (port->stream p))))))) + +(with-test-prefix "stream" + (pass-if-equal "with empty stream" + '() + (stream->list (stream))) + (pass-if-equal "with one-element stream" + '(1) + (stream->list (stream 1))) + (pass-if-equal "with three-element stream" + '(1 2 3) + (stream->list strm123))) + +(with-test-prefix "stream->list" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream->list '())) + (pass-if-exception "throws for non-integer count" + '(wrong-type-arg . "non-integer count") + (stream->list "four" strm123)) + (pass-if-exception "throws for negative count" + '(wrong-type-arg . "negative count") + (stream->list -1 strm123)) + (pass-if-equal "returns empty list for empty stream" + '() + (stream->list (stream))) + (pass-if-equal "without count" + '(1 2 3) + (stream->list strm123)) + (pass-if-equal "with count longer than stream" + '(1 2 3) + (stream->list 5 strm123)) + (pass-if-equal "with count shorter than stream" + '(1 2 3) + (stream->list 3 (stream-from 1)))) + +(with-test-prefix "stream-append" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-append "four")) + (pass-if "with one stream" + (stream-equal? (stream-append strm123) strm123)) + (pass-if "with two streams" + (stream-equal? (stream-append strm123 strm123) (stream 1 2 3 1 2 3))) + (pass-if "with three streams" + (stream-equal? (stream-append strm123 strm123 strm123) + (stream 1 2 3 1 2 3 1 2 3))) + (pass-if "append with null is noop" + (stream-equal? (stream-append strm123 stream-null) strm123)) + (pass-if "prepend with null is noop" + (stream-equal? (stream-append stream-null strm123) strm123))) + +(with-test-prefix "stream-concat" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-concat "four")) + (pass-if "with one stream" + (stream-equal? (stream-concat (stream strm123)) strm123)) + (pass-if "with two streams" + (stream-equal? (stream-concat (stream strm123 strm123)) + (stream 1 2 3 1 2 3)))) + +(with-test-prefix "stream-constant" + (pass-if "circular stream of 1 has >100 elements" + (eqv? (stream-ref (stream-constant 1) 100) 1)) + (pass-if "circular stream of 2 has >100 elements" + (eqv? (stream-ref (stream-constant 1 2) 100) 1)) + (pass-if "circular stream of 3 repeats after 3" + (eqv? (stream-ref (stream-constant 1 2 3) 3) 1)) + (pass-if "circular stream of 1 repeats at 1" + (stream-equal? (stream-take 8 (stream-constant 1)) + (stream 1 1 1 1 1 1 1 1))) + (pass-if "circular stream of 2 repeats at 2" + (stream-equal? (stream-take 8 (stream-constant 1 2)) + (stream 1 2 1 2 1 2 1 2))) + (pass-if "circular stream of 3 repeats at 3" + (stream-equal? (stream-take 8 (stream-constant 1 2 3)) + (stream 1 2 3 1 2 3 1 2)))) + +(with-test-prefix "stream-drop" + (pass-if-exception "throws for non-integer count" + '(wrong-type-arg . "non-integer argument") + (stream-drop "four" strm123)) + (pass-if-exception "throws for negative count" + '(wrong-type-arg . "negative argument") + (stream-drop -1 strm123)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-drop 2 "four")) + (pass-if "returns null when given null" + (stream-null? (stream-drop 0 stream-null))) + (pass-if "returns same stream when count is zero" + (eq? (stream-drop 0 strm123) strm123)) + (pass-if "returns dropped-by-one stream when count is one" + (stream-equal? (stream-drop 1 strm123) (stream 2 3))) + (pass-if "returns null if count is longer than stream" + (stream-null? (stream-drop 5 strm123)))) + +(with-test-prefix "stream-drop-while" + (pass-if-exception "throws for invalid predicate" + '(wrong-type-arg . "non-procedural argument") + (stream-drop-while "four" strm123)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-drop-while odd? "four")) + (pass-if "returns null when given null" + (stream-null? (stream-drop-while odd? stream-null))) + (pass-if "returns dropped stream when first element matches" + (stream-equal? (stream-drop-while odd? strm123) (stream 2 3))) + (pass-if "returns whole stream when first element doesn't match" + (stream-equal? (stream-drop-while even? strm123) strm123)) + (pass-if "returns empty stream if all elements match" + (stream-null? (stream-drop-while positive? strm123))) + (pass-if "return whole stream if no elements match" + (stream-equal? (stream-drop-while negative? strm123) strm123))) + +(with-test-prefix "stream-filter" + (pass-if-exception "throws for invalid predicate" + '(wrong-type-arg . "non-procedural argument") + (stream-filter "four" strm123)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-filter odd? '())) + (pass-if "returns null when given null" + (stream-null? (stream-filter odd? (stream)))) + (pass-if "filters out even numbers" + (stream-equal? (stream-filter odd? strm123) (stream 1 3))) + (pass-if "filters out odd numbers" + (stream-equal? (stream-filter even? strm123) (stream 2))) + (pass-if "returns all elements if predicate matches all" + (stream-equal? (stream-filter positive? strm123) strm123)) + (pass-if "returns null if predicate matches none" + (stream-null? (stream-filter negative? strm123))) + (pass-if "all elements of an odd-filtered stream are odd" + (every odd? (stream->list 10 (stream-filter odd? (stream-from 0))))) + (pass-if "no elements of an odd-filtered stream are even" + (not (any even? (stream->list 10 (stream-filter odd? (stream-from 0))))))) + +(with-test-prefix "stream-fold" + (pass-if-exception "throws for invalid function" + '(wrong-type-arg . "non-procedural argument") + (stream-fold "four" 0 strm123)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-fold + 0 '())) + (pass-if "returns the correct result" (eqv? (stream-fold + 0 strm123) 6))) + +(with-test-prefix "stream-for-each" + (pass-if-exception "throws for invalid function" + '(wrong-type-arg . "non-procedural argument") + (stream-for-each "four" strm123)) + (pass-if-exception "throws if given no streams" exception:wrong-num-args + (stream-for-each display)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-for-each display "four")) + (pass-if "function is called for stream elements" + (eqv? (let ((sum 0)) + (stream-for-each (lambda (x) + (set! sum (+ sum x))) + strm123) + sum) + 6))) + +(with-test-prefix "stream-from" + (pass-if-exception "throws for non-numeric start" + '(wrong-type-arg . "non-numeric starting number") + (stream-from "four")) + (pass-if-exception "throws for non-numeric step" + '(wrong-type-arg . "non-numeric step size") + (stream-from 1 "four")) + (pass-if "works for default values" + (eqv? (stream-ref (stream-from 0) 100) 100)) + (pass-if "works for non-default start and step" + (eqv? (stream-ref (stream-from 1 2) 100) 201)) + (pass-if "works for negative step" + (eqv? (stream-ref (stream-from 0 -1) 100) -100))) + +(with-test-prefix "stream-iterate" + (pass-if-exception "throws for invalid function" + '(wrong-type-arg . "non-procedural argument") + (stream-iterate "four" 0)) + (pass-if "returns correct iterated stream with 1+" + (stream-equal? (stream-take 3 (stream-iterate 1+ 1)) strm123)) + (pass-if "returns correct iterated stream with exact-integer-sqrt" + (stream-equal? (stream-take 5 (stream-iterate exact-integer-sqrt 65536)) + (stream 65536 256 16 4 2)))) + +(with-test-prefix "stream-length" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-length "four")) + (pass-if "returns 0 for empty stream" (zero? (stream-length (stream)))) + (pass-if "returns correct stream length" (eqv? (stream-length strm123) 3))) + +(with-test-prefix "stream-let" + (pass-if "returns correct result" + (stream-equal? + (stream-let loop ((strm strm123)) + (if (stream-null? strm) + stream-null + (stream-cons (* 2 (stream-car strm)) + (loop (stream-cdr strm))))) + (stream 2 4 6)))) + +(with-test-prefix "stream-map" + (pass-if-exception "throws for invalid function" + '(wrong-type-arg . "non-procedural argument") + (stream-map "four" strm123)) + (pass-if-exception "throws if given no streams" exception:wrong-num-args + (stream-map odd?)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-map odd? "four")) + (pass-if "works for one stream" + (stream-equal? (stream-map - strm123) (stream -1 -2 -3))) + (pass-if "works for two streams" + (stream-equal? (stream-map + strm123 strm123) (stream 2 4 6))) + (pass-if "returns finite stream for finite first stream" + (stream-equal? (stream-map + strm123 (stream-from 1)) (stream 2 4 6))) + (pass-if "returns finite stream for finite last stream" + (stream-equal? (stream-map + (stream-from 1) strm123) (stream 2 4 6))) + (pass-if "works for three streams" + (stream-equal? (stream-map + strm123 strm123 strm123) (stream 3 6 9)))) + +(with-test-prefix "stream-match" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-match '(1 2 3) (_ 'ok))) + (pass-if-exception "throws when no pattern matches" + '(match-error . "no matching pattern") + (stream-match strm123 (() 42))) + (pass-if-equal "matches empty stream correctly" + 'ok + (stream-match stream-null (() 'ok))) + (pass-if-equal "matches non-empty stream correctly" + 'ok + (stream-match strm123 (() 'no) (else 'ok))) + (pass-if-equal "matches stream of one element" + 1 + (stream-match (stream 1) (() 'no) ((a) a))) + (pass-if-equal "matches wildcard" + 'ok + (stream-match (stream 1) (() 'no) ((_) 'ok))) + (pass-if-equal "matches stream of three elements" + '(1 2 3) + (stream-match strm123 ((a b c) (list a b c)))) + (pass-if-equal "matches first element with wildcard rest" + 1 + (stream-match strm123 ((a . _) a))) + (pass-if-equal "matches first two elements with wildcard rest" + '(1 2) + (stream-match strm123 ((a b . _) (list a b)))) + (pass-if-equal "rest variable matches as stream" + '(1 2 3) + (stream-match strm123 ((a b . c) (list a b (stream-car c))))) + (pass-if-equal "rest variable can match whole stream" + '(1 2 3) + (stream-match strm123 (s (stream->list s)))) + (pass-if-equal "successful guard match" + 'ok + (stream-match strm123 ((a . _) (= a 1) 'ok))) + (pass-if-equal "unsuccessful guard match" + 'no + (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no))) + (pass-if-equal "unsuccessful guard match with two variables" + 'no + (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no))) + (pass-if-equal "successful guard match with two variables" + 'yes + (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no)))) + +(with-test-prefix "stream-of" + (pass-if "all 3 clause types work" + (stream-equal? (stream-of (+ y 6) + (x in (stream-range 1 6)) + (odd? x) + (y is (* x x))) + (stream 7 15 31))) + (pass-if "using two streams creates cartesian product" + (stream-equal? (stream-of (* x y) + (x in (stream-range 1 4)) + (y in (stream-range 1 5))) + (stream 1 2 3 4 2 4 6 8 3 6 9 12))) + (pass-if "using no clauses returns just the expression" + (stream-equal? (stream-of 1) (stream 1)))) + +(with-test-prefix "stream-range" + (pass-if-exception "throws for non-numeric start" + '(wrong-type-arg . "non-numeric starting number") + (stream-range "four" 0)) + (pass-if-exception "throws for non-numeric end" + '(wrong-type-arg . "non-numeric ending number") + (stream-range 0 "four")) + (pass-if-exception "throws for non-numeric step" + '(wrong-type-arg . "non-numeric step size") + (stream-range 1 2 "three")) + (pass-if "returns increasing range if start < end" + (stream-equal? (stream-range 0 5) (stream 0 1 2 3 4))) + (pass-if "returns decreasing range if start > end" + (stream-equal? (stream-range 5 0) (stream 5 4 3 2 1))) + (pass-if "returns increasing range of step 2" + (stream-equal? (stream-range 0 5 2) (stream 0 2 4))) + (pass-if "returns decreasing range of step 2" + (stream-equal? (stream-range 5 0 -2) (stream 5 3 1))) + (pass-if "returns empty range if start is past end value" + (stream-null? (stream-range 0 1 -1)))) + +(with-test-prefix "stream-ref" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-ref '() 4)) + (pass-if-exception "throws for non-integer index" + '(wrong-type-arg . "non-integer argument") + (stream-ref nats 3.5)) + (pass-if-exception "throws for negative index" + '(wrong-type-arg . "negative argument") + (stream-ref nats -3)) + (pass-if-exception "throws if index goes past end of stream" + '(wrong-type-arg . "beyond end of stream") + (stream-ref strm123 5)) + (pass-if-equal "returns first element when index = 0" + 1 + (stream-ref nats 0)) + (pass-if-equal "returns second element when index = 1" + 2 + (stream-ref nats 1)) + (pass-if-equal "returns third element when index = 2" + 3 + (stream-ref nats 2))) + +(with-test-prefix "stream-reverse" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-reverse '())) + (pass-if "returns null when given null" + (stream-null? (stream-reverse (stream)))) + (pass-if "returns (3 2 1) for (1 2 3)" + (stream-equal? (stream-reverse strm123) (stream 3 2 1)))) + +(with-test-prefix "stream-scan" + (pass-if-exception "throws for invalid function" + '(wrong-type-arg . "non-procedural argument") + (stream-scan "four" 0 strm123)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-scan + 0 '())) + (pass-if "returns the correct result" + (stream-equal? (stream-scan + 0 strm123) (stream 0 1 3 6)))) + +(with-test-prefix "stream-take" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-take 5 "four")) + (pass-if-exception "throws for non-integer index" + '(wrong-type-arg . "non-integer argument") + (stream-take "four" strm123)) + (pass-if-exception "throws for negative index" + '(wrong-type-arg . "negative argument") + (stream-take -4 strm123)) + (pass-if "returns null for empty stream" + (stream-null? (stream-take 5 stream-null))) + (pass-if "using 0 index returns null for empty stream" + (stream-null? (stream-take 0 stream-null))) + (pass-if "using 0 index returns null for non-empty stream" + (stream-null? (stream-take 0 strm123))) + (pass-if "returns first 2 elements of stream" + (stream-equal? (stream-take 2 strm123) (stream 1 2))) + (pass-if "returns whole stream when index is same as length" + (stream-equal? (stream-take 3 strm123) strm123)) + (pass-if "returns whole stream when index exceeds length" + (stream-equal? (stream-take 5 strm123) strm123))) + +(with-test-prefix "stream-take-while" + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-take-while odd? "four")) + (pass-if-exception "throws for invalid predicate" + '(wrong-type-arg . "non-procedural argument") + (stream-take-while "four" strm123)) + (pass-if "returns stream up to first non-matching item" + (stream-equal? (stream-take-while odd? strm123) (stream 1))) + (pass-if "returns empty stream if first item doesn't match" + (stream-null? (stream-take-while even? strm123))) + (pass-if "returns whole stream if every item matches" + (stream-equal? (stream-take-while positive? strm123) strm123)) + (pass-if "return empty stream if no item matches" + (stream-null? (stream-take-while negative? strm123)))) + +(with-test-prefix "stream-unfold" + (pass-if-exception "throws for invalid mapper" + '(wrong-type-arg . "non-procedural mapper") + (stream-unfold "four" odd? + 0)) + (pass-if-exception "throws for invalid predicate" + '(wrong-type-arg . "non-procedural pred?") + (stream-unfold + "four" + 0)) + (pass-if-exception "throws for invalid generator" + '(wrong-type-arg . "non-procedural generator") + (stream-unfold + odd? "four" 0)) + + (pass-if "returns the correct result" + (stream-equal? (stream-unfold (cut expt <> 2) (cut < <> 10) 1+ 0) + (stream 0 1 4 9 16 25 36 49 64 81)))) + +(with-test-prefix "stream-unfolds" + (pass-if "returns the correct result" + (stream-equal? (stream-unfolds + (lambda (x) + (receive (n s) (car+cdr x) + (if (zero? n) + (values 'dummy '()) + (values + (cons (- n 1) (stream-cdr s)) + (list (stream-car s)))))) + (cons 5 (stream-from 0))) + (stream 0 1 2 3 4))) + (pass-if "handles returns of multiple elements correctly" + (stream-equal? (stream-take 16 (stream-unfolds + (lambda (n) + (values (1+ n) (iota n))) + 1)) + (stream 0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0))) + (receive (p np) + (stream-unfolds (lambda (x) + (receive (n p) (car+cdr x) + (if (= n (stream-car p)) + (values (cons (1+ n) (stream-cdr p)) + (list n) #f) + (values (cons (1+ n) p) + #f (list n))))) + (cons 1 primes)) + (pass-if "returns first stream correctly" + (stream-equal? (stream-take 15 p) + (stream 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))) + (pass-if "returns second stream correctly" + (stream-equal? (stream-take 15 np) + (stream 1 4 6 8 9 10 12 14 15 16 18 20 21 22 24))))) + +(with-test-prefix "stream-zip" + (pass-if-exception "throws if given no streams" exception:wrong-num-args + (stream-zip)) + (pass-if-exception "throws for non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-zip "four")) + (pass-if-exception "throws if any argument is non-stream" + '(wrong-type-arg . "non-stream argument") + (stream-zip strm123 "four")) + (pass-if "returns null when given null as any argument" + (stream-null? (stream-zip strm123 stream-null))) + (pass-if "returns single-element lists when given one stream" + (stream-equal? (stream-zip strm123) (stream '(1) '(2) '(3)))) + (pass-if "returns double-element lists when given two streams" + (stream-equal? (stream-zip strm123 strm123) + (stream '(1 1) '(2 2) '(3 3)))) + (pass-if "returns finite stream if at least one given stream is" + (stream-equal? (stream-zip strm123 (stream-from 1)) + (stream '(1 1) '(2 2) '(3 3)))) + (pass-if "returns triple-element lists when given three streams" + (stream-equal? (stream-zip strm123 strm123 strm123) + (stream '(1 1 1) '(2 2 2) '(3 3 3))))) + +(with-test-prefix "other tests" + (pass-if-equal "returns biggest prime under 1000" + 997 + (stream-car + (stream-reverse (stream-take-while (cut < <> 1000) primes)))) + + (pass-if "quicksort returns same result as insertion sort" + (stream-equal? (qsort < (stream 3 1 5 2 4)) + (isort < (stream 2 5 1 4 3)))) + + (pass-if "merge sort returns same result as insertion sort" + (stream-equal? (msort < (stream 3 1 5 2 4)) + (isort < (stream 2 5 1 4 3)))) + + ;; http://www.research.att.com/~njas/sequences/A051037 + (pass-if-equal "returns 1000th Hamming number" + 51200000 + (stream-ref hamming 999))) From 80b809f114e9f3978aa6571affd343f34732fb94 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 26 Mar 2013 21:03:42 -0400 Subject: [PATCH 144/147] Add full documentation for SRFI-41. * doc/ref/misc-modules.texi (Streams): Add cross-reference to SRFI-41. * doc/ref/srfi-modules.texi (SRFI-41): Replace stub with full documentation. (SRFI-41 Stream Fundamentals, SRFI-41 Stream Primitives, SRFI-41 Stream Library): New subsubsections. --- doc/ref/misc-modules.texi | 3 + doc/ref/srfi-modules.texi | 703 +++++++++++++++++++++++++++++++++++++- 2 files changed, 704 insertions(+), 2 deletions(-) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index cf1e0e49f..c1e65d7e3 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -1573,6 +1573,9 @@ modifies the queue @var{list} then it must either maintain @section Streams @cindex streams +This section documents Guile's legacy stream module. For a more +complete and portable stream library, @pxref{SRFI-41}. + A stream represents a sequence of values, each of which is calculated only when required. This allows large or even infinite sequences to be represented and manipulated with familiar operations like ``car'', diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 5a892097a..5b02aec19 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3793,8 +3793,707 @@ scope and the result from that @var{thunk} is the return from @subsection SRFI-41 - Streams @cindex SRFI-41 -See @uref{http://srfi.schemers.org/srfi-41/srfi-41.html, the -specification of SRFI-41}. +This subsection is based on the +@uref{http://srfi.schemers.org/srfi-41/srfi-41.html, specification of +SRFI-41} by Philip L.@: Bewig. + +@c The copyright notice and license text of the SRFI-41 specification is +@c reproduced below: + +@c Copyright (C) Philip L. Bewig (2007). All Rights Reserved. + +@c Permission is hereby granted, free of charge, to any person obtaining a +@c copy of this software and associated documentation files (the +@c "Software"), to deal in the Software without restriction, including +@c without limitation the rights to use, copy, modify, merge, publish, +@c distribute, sublicense, and/or sell copies of the Software, and to +@c permit persons to whom the Software is furnished to do so, subject to +@c the following conditions: + +@c The above copyright notice and this permission notice shall be included +@c in all copies or substantial portions of the Software. + +@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +@noindent +This SRFI implements streams, sometimes called lazy lists, a sequential +data structure containing elements computed only on demand. A stream is +either null or is a pair with a stream in its cdr. Since elements of a +stream are computed only when accessed, streams can be infinite. Once +computed, the value of a stream element is cached in case it is needed +again. SRFI-41 can be made available with: + +@example +(use-modules (srfi srfi-41)) +@end example + +@menu +* SRFI-41 Stream Fundamentals:: +* SRFI-41 Stream Primitives:: +* SRFI-41 Stream Library:: +@end menu + +@node SRFI-41 Stream Fundamentals +@subsubsection SRFI-41 Stream Fundamentals + +SRFI-41 Streams are based on two mutually-recursive abstract data types: +An object of the @code{stream} abstract data type is a promise that, +when forced, is either @code{stream-null} or is an object of type +@code{stream-pair}. An object of the @code{stream-pair} abstract data +type contains a @code{stream-car} and a @code{stream-cdr}, which must be +a @code{stream}. The essential feature of streams is the systematic +suspensions of the recursive promises between the two data types. + +The object stored in the @code{stream-car} of a @code{stream-pair} is a +promise that is forced the first time the @code{stream-car} is accessed; +its value is cached in case it is needed again. The object may have any +type, and different stream elements may have different types. If the +@code{stream-car} is never accessed, the object stored there is never +evaluated. Likewise, the @code{stream-cdr} is a promise to return a +stream, and is only forced on demand. + +@node SRFI-41 Stream Primitives +@subsubsection SRFI-41 Stream Primitives + +This library provides eight operators: constructors for +@code{stream-null} and @code{stream-pair}s, type predicates for streams +and the two kinds of streams, accessors for both fields of a +@code{stream-pair}, and a lambda that creates procedures that return +streams. + +@deffn {Constant} stream-null +A promise that, when forced, is a single object, distinguishable from +all other objects, that represents the null stream. @code{stream-null} +is immutable and unique. +@end deffn + +@deffn {Scheme Syntax} stream-cons object-expr stream-expr +Creates a newly-allocated stream containing a promise that, when forced, +is a @code{stream-pair} with @var{object-expr} in its @code{stream-car} +and @var{stream-expr} in its @code{stream-cdr}. Neither +@var{object-expr} nor @var{stream-expr} is evaluated when +@code{stream-cons} is called. + +Once created, a @code{stream-pair} is immutable; there is no +@code{stream-set-car!} or @code{stream-set-cdr!} that modifies an +existing stream-pair. There is no dotted-pair or improper stream as +with lists. +@end deffn + +@deffn {Scheme Procedure} stream? object +Returns true if @var{object} is a stream, otherwise returns false. If +@var{object} is a stream, its promise will not be forced. If +@code{(stream? obj)} returns true, then one of @code{(stream-null? obj)} +or @code{(stream-pair? obj)} will return true and the other will return +false. +@end deffn + +@deffn {Scheme Procedure} stream-null? object +Returns true if @var{object} is the distinguished null stream, otherwise +returns false. If @var{object} is a stream, its promise will be forced. +@end deffn + +@deffn {Scheme Procedure} stream-pair? object +Returns true if @var{object} is a @code{stream-pair} constructed by +@code{stream-cons}, otherwise returns false. If @var{object} is a +stream, its promise will be forced. +@end deffn + +@deffn {Scheme Procedure} stream-car stream +Returns the object stored in the @code{stream-car} of @var{stream}. An +error is signalled if the argument is not a @code{stream-pair}. This +causes the @var{object-expr} passed to @code{stream-cons} to be +evaluated if it had not yet been; the value is cached in case it is +needed again. +@end deffn + +@deffn {Scheme Procedure} stream-cdr stream +Returns the stream stored in the @code{stream-cdr} of @var{stream}. An +error is signalled if the argument is not a @code{stream-pair}. +@end deffn + +@deffn {Scheme Syntax} stream-lambda formals body @dots{} +Creates a procedure that returns a promise to evaluate the @var{body} of +the procedure. The last @var{body} expression to be evaluated must +yield a stream. As with normal @code{lambda}, @var{formals} may be a +single variable name, in which case all the formal arguments are +collected into a single list, or a list of variable names, which may be +null if there are no arguments, proper if there are an exact number of +arguments, or dotted if a fixed number of arguments is to be followed by +zero or more arguments collected into a list. @var{Body} must contain +at least one expression, and may contain internal definitions preceding +any expressions to be evaluated. +@end deffn + +@example +(define strm123 + (stream-cons 1 + (stream-cons 2 + (stream-cons 3 + stream-null)))) + +(stream-car strm123) @result{} 1 +(stream-car (stream-cdr strm123) @result{} 2 + +(stream-pair? + (stream-cdr + (stream-cons (/ 1 0) stream-null))) @result{} #f + +(stream? (list 1 2 3)) @result{} #f + +(define iter + (stream-lambda (f x) + (stream-cons x (iter f (f x))))) + +(define nats (iter (lambda (x) (+ x 1)) 0)) + +(stream-car (stream-cdr nats)) @result{} 1 + +(define stream-add + (stream-lambda (s1 s2) + (stream-cons + (+ (stream-car s1) (stream-car s2)) + (stream-add (stream-cdr s1) + (stream-cdr s2))))) + +(define evens (stream-add nats nats)) + +(stream-car evens) @result{} 0 +(stream-car (stream-cdr evens)) @result{} 2 +(stream-car (stream-cdr (stream-cdr evens))) @result{} 4 +@end example + +@node SRFI-41 Stream Library +@subsubsection SRFI-41 Stream Library + +@deffn {Scheme Syntax} define-stream (name args @dots{}) body @dots{} +Creates a procedure that returns a stream, and may appear anywhere a +normal @code{define} may appear, including as an internal definition. +It may contain internal definitions of its own. The defined procedure +takes arguments in the same way as @code{stream-lambda}. +@code{define-stream} is syntactic sugar on @code{stream-lambda}; see +also @code{stream-let}, which is also a sugaring of +@code{stream-lambda}. + +A simple version of @code{stream-map} that takes only a single input +stream calls itself recursively: + +@example +(define-stream (stream-map proc strm) + (if (stream-null? strm) + stream-null + (stream-cons + (proc (stream-car strm)) + (stream-map proc (stream-cdr strm)))))) +@end example +@end deffn + +@deffn {Scheme Procedure} list->stream list +Returns a newly-allocated stream containing the elements from +@var{list}. +@end deffn + +@deffn {Scheme Procedure} port->stream [port] +Returns a newly-allocated stream containing in its elements the +characters on the port. If @var{port} is not given it defaults to the +current input port. The returned stream has finite length and is +terminated by @code{stream-null}. + +It looks like one use of @code{port->stream} would be this: + +@example +(define s ;wrong! + (with-input-from-file filename + (lambda () (port->stream)))) +@end example + +But that fails, because @code{with-input-from-file} is eager, and closes +the input port prematurely, before the first character is read. To read +a file into a stream, say: + +@example +(define-stream (file->stream filename) + (let ((p (open-input-file filename))) + (stream-let loop ((c (read-char p))) + (if (eof-object? c) + (begin (close-input-port p) + stream-null) + (stream-cons c + (loop (read-char p))))))) +@end example +@end deffn + +@deffn {Scheme Syntax} stream object-expr @dots{} +Creates a newly-allocated stream containing in its elements the objects, +in order. The @var{object-expr}s are evaluated when they are accessed, +not when the stream is created. If no objects are given, as in +(stream), the null stream is returned. See also @code{list->stream}. + +@example +(define strm123 (stream 1 2 3)) + +; (/ 1 0) not evaluated when stream is created +(define s (stream 1 (/ 1 0) -1)) +@end example +@end deffn + +@deffn {Scheme Procedure} stream->list [n] stream +Returns a newly-allocated list containing in its elements the first +@var{n} items in @var{stream}. If @var{stream} has less than @var{n} +items, all the items in the stream will be included in the returned +list. If @var{n} is not given it defaults to infinity, which means that +unless @var{stream} is finite @code{stream->list} will never return. + +@example +(stream->list 10 + (stream-map (lambda (x) (* x x)) + (stream-from 0))) + @result{} (0 1 4 9 16 25 36 49 64 81) +@end example +@end deffn + +@deffn {Scheme Procedure} stream-append stream @dots{} +Returns a newly-allocated stream containing in its elements those +elements contained in its input @var{stream}s, in order of input. If +any of the input streams is infinite, no elements of any of the +succeeding input streams will appear in the output stream. See also +@code{stream-concat}. +@end deffn + +@deffn {Scheme Procedure} stream-concat stream +Takes a @var{stream} consisting of one or more streams and returns a +newly-allocated stream containing all the elements of the input streams. +If any of the streams in the input @var{stream} is infinite, any +remaining streams in the input stream will never appear in the output +stream. See also @code{stream-append}. +@end deffn + +@deffn {Scheme Procedure} stream-constant object @dots{} +Returns a newly-allocated stream containing in its elements the +@var{object}s, repeating in succession forever. + +@example +(stream-constant 1) @result{} 1 1 1 @dots{} +(stream-constant #t #f) @result{} #t #f #t #f #t #f @dots{} +@end example +@end deffn + +@deffn {Scheme Procedure} stream-drop n stream +Returns the suffix of the input @var{stream} that starts at the next +element after the first @var{n} elements. The output stream shares +structure with the input @var{stream}; thus, promises forced in one +instance of the stream are also forced in the other instance of the +stream. If the input @var{stream} has less than @var{n} elements, +@code{stream-drop} returns the null stream. See also +@code{stream-take}. +@end deffn + +@deffn {Scheme Procedure} stream-drop-while pred stream +Returns the suffix of the input @var{stream} that starts at the first +element @var{x} for which @code{(pred x)} returns false. The output +stream shares structure with the input @var{stream}. See also +@code{stream-take-while}. +@end deffn + +@deffn {Scheme Procedure} stream-filter pred stream +Returns a newly-allocated stream that contains only those elements +@var{x} of the input @var{stream} which satisfy the predicate +@code{pred}. + +@example +(stream-filter odd? (stream-from 0)) + @result{} 1 3 5 7 9 @dots{} +@end example +@end deffn + +@deffn {Scheme Procedure} stream-fold proc base stream +Applies a binary procedure @var{proc} to @var{base} and the first +element of @var{stream} to compute a new @var{base}, then applies the +procedure to the new @var{base} and the next element of @var{stream} to +compute a succeeding @var{base}, and so on, accumulating a value that is +finally returned as the value of @code{stream-fold} when the end of the +stream is reached. @var{stream} must be finite, or @code{stream-fold} +will enter an infinite loop. See also @code{stream-scan}, which is +similar to @code{stream-fold}, but useful for infinite streams. For +readers familiar with other functional languages, this is a left-fold; +there is no corresponding right-fold, since right-fold relies on finite +streams that are fully-evaluated, in which case they may as well be +converted to a list. +@end deffn + +@deffn {Scheme Procedure} stream-for-each proc stream @dots{} +Applies @var{proc} element-wise to corresponding elements of the input +@var{stream}s for side-effects; it returns nothing. +@code{stream-for-each} stops as soon as any of its input streams is +exhausted. +@end deffn + +@deffn {Scheme Procedure} stream-from first [step] +Creates a newly-allocated stream that contains @var{first} as its first +element and increments each succeeding element by @var{step}. If +@var{step} is not given it defaults to 1. @var{first} and @var{step} +may be of any numeric type. @code{stream-from} is frequently useful as +a generator in @code{stream-of} expressions. See also +@code{stream-range} for a similar procedure that creates finite streams. +@end deffn + +@deffn {Scheme Procedure} stream-iterate proc base +Creates a newly-allocated stream containing @var{base} in its first +element and applies @var{proc} to each element in turn to determine the +succeeding element. See also @code{stream-unfold} and +@code{stream-unfolds}. +@end deffn + +@deffn {Scheme Procedure} stream-length stream +Returns the number of elements in the @var{stream}; it does not evaluate +its elements. @code{stream-length} may only be used on finite streams; +it enters an infinite loop with infinite streams. +@end deffn + +@deffn {Scheme Syntax} stream-let tag ((var expr) @dots{}) body @dots{} +Creates a local scope that binds each variable to the value of its +corresponding expression. It additionally binds @var{tag} to a +procedure which takes the bound variables as arguments and @var{body} as +its defining expressions, binding the @var{tag} with +@code{stream-lambda}. @var{tag} is in scope within body, and may be +called recursively. When the expanded expression defined by the +@code{stream-let} is evaluated, @code{stream-let} evaluates the +expressions in its @var{body} in an environment containing the +newly-bound variables, returning the value of the last expression +evaluated, which must yield a stream. + +@code{stream-let} provides syntactic sugar on @code{stream-lambda}, in +the same manner as normal @code{let} provides syntactic sugar on normal +@code{lambda}. However, unlike normal @code{let}, the @var{tag} is +required, not optional, because unnamed @code{stream-let} is +meaningless. + +For example, @code{stream-member} returns the first @code{stream-pair} +of the input @var{strm} with a @code{stream-car} @var{x} that satisfies +@code{(eql? obj x)}, or the null stream if @var{x} is not present in +@var{strm}. + +@example +(define-stream (stream-member eql? obj strm) + (stream-let loop ((strm strm)) + (cond ((stream-null? strm) strm) + ((eql? obj (stream-car strm)) strm) + (else (loop (stream-cdr strm)))))) +@end example +@end deffn + +@deffn {Scheme Procedure} stream-map proc stream @dots{} +Applies @var{proc} element-wise to corresponding elements of the input +@var{stream}s, returning a newly-allocated stream containing elements +that are the results of those procedure applications. The output stream +has as many elements as the minimum-length input stream, and may be +infinite. +@end deffn + +@deffn {Scheme Syntax} stream-match stream clause @dots{} +Provides pattern-matching for streams. The input @var{stream} is an +expression that evaluates to a stream. Clauses are of the form +@code{(pattern [fender] expression)}, consisting of a @var{pattern} that +matches a stream of a particular shape, an optional @var{fender} that +must succeed if the pattern is to match, and an @var{expression} that is +evaluated if the pattern matches. There are four types of patterns: + +@itemize @bullet +@item +() matches the null stream. + +@item +(@var{pat0} @var{pat1} @dots{}) matches a finite stream with length +exactly equal to the number of pattern elements. + +@item +(@var{pat0} @var{pat1} @dots{} @code{.} @var{pat-rest}) matches an +infinite stream, or a finite stream with length at least as great as the +number of pattern elements before the literal dot. + +@item +@var{pat} matches an entire stream. Should always appear last in the +list of clauses; it's not an error to appear elsewhere, but subsequent +clauses could never match. +@end itemize + +Each pattern element may be either: + +@itemize @bullet +@item +An identifier, which matches any stream element. Additionally, the +value of the stream element is bound to the variable named by the +identifier, which is in scope in the @var{fender} and @var{expression} +of the corresponding @var{clause}. Each identifier in a single pattern +must be unique. + +@item +A literal underscore (@code{_}), which matches any stream element but +creates no bindings. +@end itemize + +The @var{pattern}s are tested in order, left-to-right, until a matching +pattern is found; if @var{fender} is present, it must evaluate to a true +value for the match to be successful. Pattern variables are bound in +the corresponding @var{fender} and @var{expression}. Once the matching +@var{pattern} is found, the corresponding @var{expression} is evaluated +and returned as the result of the match. An error is signaled if no +pattern matches the input @var{stream}. + +@code{stream-match} is often used to distinguish null streams from +non-null streams, binding @var{head} and @var{tail}: + +@example +(define (len strm) + (stream-match strm + (() 0) + ((head . tail) (+ 1 (len tail))))) +@end example + +Fenders can test the common case where two stream elements must be +identical; the @code{else} pattern is an identifier bound to the entire +stream, not a keyword as in @code{cond}. + +@example +(stream-match strm + ((x y . _) (equal? x y) 'ok) + (else 'error)) +@end example + +A more complex example uses two nested matchers to match two different +stream arguments; @code{(stream-merge lt? . strms)} stably merges two or +more streams ordered by the @code{lt?} predicate: + +@example +(define-stream (stream-merge lt? . strms) + (define-stream (merge xx yy) + (stream-match xx (() yy) ((x . xs) + (stream-match yy (() xx) ((y . ys) + (if (lt? y x) + (stream-cons y (merge xx ys)) + (stream-cons x (merge xs yy)))))))) + (stream-let loop ((strms strms)) + (cond ((null? strms) stream-null) + ((null? (cdr strms)) (car strms)) + (else (merge (car strms) + (apply stream-merge lt? + (cdr strms))))))) +@end example +@end deffn + +@deffn {Scheme Syntax} stream-of expr clause @dots{} +Provides the syntax of stream comprehensions, which generate streams by +means of looping expressions. The result is a stream of objects of the +type returned by @var{expr}. There are four types of clauses: + +@itemize @bullet +@item +(@var{var} @code{in} @var{stream-expr}) loops over the elements of +@var{stream-expr}, in order from the start of the stream, binding each +element of the stream in turn to @var{var}. @code{stream-from} and +@code{stream-range} are frequently useful as generators for +@var{stream-expr}. + +@item +(@var{var} @code{is} @var{expr}) binds @var{var} to the value obtained +by evaluating @var{expr}. + +@item +(@var{pred} @var{expr}) includes in the output stream only those +elements @var{x} which satisfy the predicate @var{pred}. +@end itemize + +The scope of variables bound in the stream comprehension is the clauses +to the right of the binding clause (but not the binding clause itself) +plus the result expression. + +When two or more generators are present, the loops are processed as if +they are nested from left to right; that is, the rightmost generator +varies fastest. A consequence of this is that only the first generator +may be infinite and all subsequent generators must be finite. If no +generators are present, the result of a stream comprehension is a stream +containing the result expression; thus, @samp{(stream-of 1)} produces a +finite stream containing only the element 1. + +@example +(stream-of (* x x) + (x in (stream-range 0 10)) + (even? x)) + @result{} 0 4 16 36 64 + +(stream-of (list a b) + (a in (stream-range 1 4)) + (b in (stream-range 1 3))) + @result{} (1 1) (1 2) (2 1) (2 2) (3 1) (3 2) + +(stream-of (list i j) + (i in (stream-range 1 5)) + (j in (stream-range (+ i 1) 5))) + @result{} (1 2) (1 3) (1 4) (2 3) (2 4) (3 4) +@end example +@end deffn + +@deffn {Scheme Procedure} stream-range first past [step] +Creates a newly-allocated stream that contains @var{first} as its first +element and increments each succeeding element by @var{step}. The +stream is finite and ends before @var{past}, which is not an element of +the stream. If @var{step} is not given it defaults to 1 if @var{first} +is less than past and -1 otherwise. @var{first}, @var{past} and +@var{step} may be of any real numeric type. @code{stream-range} is +frequently useful as a generator in @code{stream-of} expressions. See +also @code{stream-from} for a similar procedure that creates infinite +streams. + +@example +(stream-range 0 10) @result{} 0 1 2 3 4 5 6 7 8 9 +(stream-range 0 10 2) @result{} 0 2 4 6 8 +@end example + +Successive elements of the stream are calculated by adding @var{step} to +@var{first}, so if any of @var{first}, @var{past} or @var{step} are +inexact, the length of the output stream may differ from +@code{(ceiling (- (/ (- past first) step) 1)}. +@end deffn + +@deffn {Scheme Procedure} stream-ref stream n +Returns the @var{n}th element of stream, counting from zero. An error +is signaled if @var{n} is greater than or equal to the length of stream. + +@example +(define (fact n) + (stream-ref + (stream-scan * 1 (stream-from 1)) + n)) +@end example +@end deffn + +@deffn {Scheme Procedure} stream-reverse stream +Returns a newly-allocated stream containing the elements of the input +@var{stream} but in reverse order. @code{stream-reverse} may only be +used with finite streams; it enters an infinite loop with infinite +streams. @code{stream-reverse} does not force evaluation of the +elements of the stream. +@end deffn + +@deffn {Scheme Procedure} stream-scan proc base stream +Accumulates the partial folds of an input @var{stream} into a +newly-allocated output stream. The output stream is the @var{base} +followed by @code{(stream-fold proc base (stream-take i stream))} for +each of the first @var{i} elements of @var{stream}. + +@example +(stream-scan + 0 (stream-from 1)) + @result{} (stream 0 1 3 6 10 15 @dots{}) + +(stream-scan * 1 (stream-from 1)) + @result{} (stream 1 1 2 6 24 120 @dots{}) +@end example +@end deffn + +@deffn {Scheme Procedure} stream-take n stream +Returns a newly-allocated stream containing the first @var{n} elements +of the input @var{stream}. If the input @var{stream} has less than +@var{n} elements, so does the output stream. See also +@code{stream-drop}. +@end deffn + +@deffn {Scheme Procedure} stream-take-while pred stream +Takes a predicate and a @code{stream} and returns a newly-allocated +stream containing those elements @code{x} that form the maximal prefix +of the input stream which satisfy @var{pred}. See also +@code{stream-drop-while}. +@end deffn + +@deffn {Scheme Procedure} stream-unfold map pred gen base +The fundamental recursive stream constructor. It constructs a stream by +repeatedly applying @var{gen} to successive values of @var{base}, in the +manner of @code{stream-iterate}, then applying @var{map} to each of the +values so generated, appending each of the mapped values to the output +stream as long as @code{(pred? base)} returns a true value. See also +@code{stream-iterate} and @code{stream-unfolds}. + +The expression below creates the finite stream @samp{0 1 4 9 16 25 36 49 +64 81}. Initially the @var{base} is 0, which is less than 10, so +@var{map} squares the @var{base} and the mapped value becomes the first +element of the output stream. Then @var{gen} increments the @var{base} +by 1, so it becomes 1; this is less than 10, so @var{map} squares the +new @var{base} and 1 becomes the second element of the output stream. +And so on, until the base becomes 10, when @var{pred} stops the +recursion and stream-null ends the output stream. + +@example +(stream-unfold + (lambda (x) (expt x 2)) ; map + (lambda (x) (< x 10)) ; pred? + (lambda (x) (+ x 1)) ; gen + 0) ; base +@end example +@end deffn + +@deffn {Scheme Procedure} stream-unfolds proc seed +Returns @var{n} newly-allocated streams containing those elements +produced by successive calls to the generator @var{proc}, which takes +the current @var{seed} as its argument and returns @var{n}+1 values + +(@var{proc} @var{seed}) @result{} @var{seed} @var{result_0} @dots{} @var{result_n-1} + +where the returned @var{seed} is the input @var{seed} to the next call +to the generator and @var{result_i} indicates how to produce the next +element of the @var{i}th result stream: + +@itemize @bullet +@item +(@var{value}): @var{value} is the next car of the result stream. + +@item +@code{#f}: no value produced by this iteration of the generator +@var{proc} for the result stream. + +@item +(): the end of the result stream. +@end itemize + +It may require multiple calls of @var{proc} to produce the next element +of any particular result stream. See also @code{stream-iterate} and +@code{stream-unfold}. + +@example +(define (stream-partition pred? strm) + (stream-unfolds + (lambda (s) + (if (stream-null? s) + (values s '() '()) + (let ((a (stream-car s)) + (d (stream-cdr s))) + (if (pred? a) + (values d (list a) #f) + (values d #f (list a)))))) + strm)) + +(call-with-values + (lambda () + (stream-partition odd? + (stream-range 1 6))) + (lambda (odds evens) + (list (stream->list odds) + (stream->list evens)))) + @result{} ((1 3 5) (2 4)) +@end example +@end deffn + +@deffn {Scheme Procedure} stream-zip stream @dots{} +Returns a newly-allocated stream in which each element is a list (not a +stream) of the corresponding elements of the input @var{stream}s. The +output stream is as long as the shortest input @var{stream}, if any of +the input @var{stream}s is finite, or is infinite if all the input +@var{stream}s are infinite. +@end deffn @node SRFI-42 @subsection SRFI-42 - Eager Comprehensions From 82ab673ceafa3174d9e5f8dfec08221ba69addba Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 27 Mar 2013 13:39:47 -0400 Subject: [PATCH 145/147] Thanks Chris K. Jester-Young. * THANKS: Add Chris K Jester-Young to the list of contributors. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index a39473f31..005f7803b 100644 --- a/THANKS +++ b/THANKS @@ -9,6 +9,7 @@ Contributors since the last release: Daniel Hartwig No Itisnt Neil Jerram + Chris K Jester-Young Daniel Kraft Noah Lavine Gregory Marton From 10b8cf1ebdba6989e8c9b23838d2f20d6cb7d60b Mon Sep 17 00:00:00 2001 From: "Chris K. Jester-Young" <cky944@gmail.com> Date: Wed, 27 Mar 2013 15:30:26 -0400 Subject: [PATCH 146/147] Use BT Templeton's preferred name. * THANKS: Use BT Templeton's preferred name. --- THANKS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/THANKS b/THANKS index 005f7803b..82099964c 100644 --- a/THANKS +++ b/THANKS @@ -22,7 +22,7 @@ Contributors since the last release: Ken Raeburn Andreas Rottmann Kevin Ryde - Brian Templeton + BT Templeton Mark H Weaver Göran Weinholt Ralf Wildenhues From 579127cce488ce208d62e68e679e34fbbdc17367 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 27 Mar 2013 21:11:06 -0400 Subject: [PATCH 147/147] SRFI-41 stream-null is a Scheme Variable, not a Constant. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Suggested by Ludovic Courtès <ludo@gnu.org>. * doc/ref/srfi-modules.texi (SRFI-41 Stream Primitives): Label 'stream-null' as a Scheme Variable, not a Constant. --- doc/ref/srfi-modules.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 5b02aec19..1fc60984a 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3867,7 +3867,7 @@ and the two kinds of streams, accessors for both fields of a @code{stream-pair}, and a lambda that creates procedures that return streams. -@deffn {Constant} stream-null +@deffn {Scheme Variable} stream-null A promise that, when forced, is a single object, distinguishable from all other objects, that represents the null stream. @code{stream-null} is immutable and unique.