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/Makefile.am b/Makefile.am index 3aa5ddd76..8cdcc7e4e 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,19 @@ 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" \ + > $@.tmp + @mv $@.tmp $@ + EXTRA_DIST = LICENSE HACKING GUILE-VERSION \ m4/ChangeLog-2008 \ m4/gnulib-cache.m4 \ @@ -50,13 +63,15 @@ 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@ ACLOCAL_AMFLAGS = -I m4 +CLEANFILES = libguile/guile-procedures.txt DISTCLEANFILES = check-guile.log DISTCHECK_CONFIGURE_FLAGS = --enable-error-on-warning diff --git a/NEWS b/NEWS index ebf5d6169..80b06fd74 100644 --- a/NEWS +++ b/NEWS @@ -1,10 +1,325 @@ 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 + +file name docs + +gnulib version + +--language docs + +* Notable changes + +** 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 +calls pkg-config). + +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. + +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. + +In addition, the new Gnulib imports provide `select' and `poll' on +Windows builds. + +As an incompatible change, systems that are missing 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). + +** 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. + +** New optimizations. + +There were a number of improvements to the partial evaluator, allowing +complete reduction of forms such as: + + ((let ((_ 10)) (lambda () _))) + + ((lambda _ _)) + + (apply (lambda _) 1 2 3 4) + + (call-with-values (lambda () (values 1 2)) (lambda _ _)) + +A number (ahem) of numeric operations on have been made faster, among +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' 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. + +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. + +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 + +** Better SXML documentation. + +The documentation for SXML modules was much improved, though there is +still far to go. See "SXML" in manual. + +** 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. + +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. + +** 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' / +`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 + +** 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 +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. + +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*'. + +The new `#:streaming?' argument to `http-get' subsumes the functionality +of `http-get*' (introduced in 2.0.7). 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 + +** `round-ash', a bit-shifting operator that rounds on right-shift. + +See "Bitwise Operations". + +** New environment variables: `GUILE_STACK_SIZE', `GUILE_INSTALL_LOCALE'. + +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', +`file-name-separator?', `absolute-file-name?', and +`file-name-separator-string'. + +** `array-length', an array's first dimension. + +See "Array Procedures". + +** `hash-count', for hash tables. + +See "Hash Tables". + +** New foreign types: `ssize_t', `ptrdiff_t'. + +See "Foreign Types". + +** New C helpers: `scm_from_ptrdiff_t', `scm_to_ptrdiff_t'. + +See "Integers". + +** Much more capable `xml->sxml' + +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. + +** New command-line argument: `--language' + +See XXX in the manual. + +** `current-language' in default environment. + +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'. + +** New procedure: `fluid->parameter' + +See "Parameters", for information on how to convert a fluid to a +parameter. + +** New procedures to read all characters from a port + +See "Line/Delimited" in the manual for documentation on `read-string' + and `read-string!'. + +** New HTTP client procedures. + +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'. + +** New procedures for converting strings to and from bytevectors. + +See "Representing Strings as Bytes" for documention on the new `(ice-9 +iconv)' module and its `bytevector->string' and `string->bytevector' +procedures. + +** New `print' REPL option. + +See "REPL Commands" in the manual for information on the new +user-customizable REPL printer. + +** New variable: %site-ccache-dir. + +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 + +** Fix compilation against libgc 7.3. +** 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 --disable-posix build. +** Fix MinGW builds with networking, POSIX, and thread support. + +* 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) +** Warn and ignore module autoload failures. + (http://bugs.gnu.org/12202) +** 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. + (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 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. + (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. + (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 ...)). +** Various fixes to the (texinfo) modules. +** guild: Gracefully handle failures to install the locale. +** 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. +** 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) +** 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 diff --git a/THANKS b/THANKS index fc2bf4924..82099964c 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 @@ -21,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 @@ -94,6 +95,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/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/configure.ac b/configure.ac index 3b532a07b..85e31704e 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 poll.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 @@ -705,9 +706,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, @@ -738,7 +736,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 @@ -748,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 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 sendfile]) AM_CONDITIONAL([HAVE_FORK], [test "x$ac_cv_func_fork" = "xyes"]) @@ -920,6 +928,8 @@ 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([strptime],,, [#define _GNU_SOURCE /* ask glibc to give strptime prototype */ #include <time.h>]) @@ -1229,7 +1239,13 @@ 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_suspend_signal GC_move_disappearing_link 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_suspend_signal GC_move_disappearing_link \ + 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 @@ -1632,7 +1648,6 @@ AC_CONFIG_FILES([ AC_CONFIG_FILES([meta/guile-2.2.pc]) AC_CONFIG_FILES([meta/guile-2.2-uninstalled.pc]) -AC_CONFIG_FILES([doc/ref/effective-version.texi]) GUILE_CONFIG_SCRIPT([check-guile]) GUILE_CONFIG_SCRIPT([benchmark-guile]) 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/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 diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 53cc7ce9a..75b1745fa 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 diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 6dfc5fdc0..641245a21 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) @@ -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 diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index d8b6a45ad..4dede7260 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 @@ -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. @@ -1735,8 +1735,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/api-data.texi b/doc/ref/api-data.texi index 9bb674a96..ac778b9de 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(n * 2^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(n * 2^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 @@ -2049,7 +2067,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 +2075,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 +2117,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 +2150,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 +2601,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-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..c4e77a9b4 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 @@ -1061,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 diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index b08c1035a..09ffee6a7 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 @@ -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 @@ -941,7 +942,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 @@ -1131,7 +1132,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 17ab46277..4a4011d20 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. @@ -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 @@ -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. @@ -942,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/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/api-procedures.texi b/doc/ref/api-procedures.texi index bef3386e8..8ff240a14 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 @@ -333,7 +334,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, @@ -712,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/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 749583a1b..b23082192 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 @@ -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/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 1d730b79c..0615ef78a 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} @@ -590,9 +591,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 @@ -799,7 +800,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 [endianness] diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 5a9a3f7ef..15ca625ec 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,32 @@ 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. Therefore, this option is on 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/doc/ref/guile.texi b/doc/ref/guile.texi index 262cd645f..c3170ce46 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -374,7 +374,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/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/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/posix.texi b/doc/ref/posix.texi index a019f4edd..950c3519d 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) @@ -1718,6 +1741,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) @@ -2528,8 +2563,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 @@ -3052,6 +3090,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/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index 2028ada2a..b18377135 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 @@ -1523,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 diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index e0f91af02..4422c1863 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! @@ -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 @@ -749,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 @@ -780,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/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 17b1918bf..8bf7c4126 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. @@ -76,13 +77,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 @@ -145,9 +146,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 @@ -1846,11 +1851,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 @@ -3429,9 +3442,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 @@ -3775,6 +3789,712 @@ 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 + +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 {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. +@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 @cindex SRFI-42 @@ -3832,6 +4552,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/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/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 diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 6c33f3225..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 @@ -351,8 +352,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 @@ -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 @@ -405,8 +407,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 @@ -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 @@ -1615,7 +1623,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 +1637,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 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/guile-readline/readline.c b/guile-readline/readline.c index 1e697eb5d..aac6e18c2 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -1,6 +1,7 @@ /* readline.c --- line editing support for Guile */ -/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2013 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 +28,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 +202,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 +233,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; } @@ -314,10 +305,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 } @@ -489,11 +478,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) @@ -504,14 +491,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) { @@ -520,12 +505,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; } @@ -542,9 +522,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 diff --git a/lib/Makefile.am b/lib/Makefile.am index 49c5140f2..c92a8acf4 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 @@ -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 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,8 @@ 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) libgnu_la_LDFLAGS += $(LTLIBICONV) @@ -87,6 +89,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 +384,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 @@ -556,6 +578,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 @@ -1006,6 +1037,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. @@ -1438,12 +1470,59 @@ 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 ## 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 @@ -1559,6 +1638,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 @@ -2093,6 +2181,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 +2210,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' \ @@ -2311,9 +2401,44 @@ 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 +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. @@ -2458,6 +2583,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 @@ -2560,6 +2716,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 @@ -2572,6 +2737,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 +3129,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.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/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/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/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/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/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/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/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/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/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/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/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_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/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_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/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/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/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/libguile/Makefile.am b/libguile/Makefile.am index d42c650ae..6f914e060 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 @@ -436,12 +436,16 @@ 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 \ 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 @@ -458,7 +462,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ elf.h \ srfi-14.i.c \ quicksort.i.c \ - win32-uname.h win32-socket.h \ + win32-uname.h \ private-gc.h private-options.h # vm instructions @@ -723,25 +727,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/__scm.h b/libguile/__scm.h index b42b82397..0a749bec5 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -371,7 +371,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) 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> 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> diff --git a/libguile/debug.c b/libguile/debug.c index 87513bf48..b01864fb8 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -202,10 +202,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/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/filesys.c b/libguile/filesys.c index 3d5b1fb3e..09a0de0e9 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 @@ -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> @@ -101,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) @@ -435,30 +444,17 @@ 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) +static int +is_file_name_separator (SCM c) { - 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); + if (scm_is_eq (c, SCM_MAKE_CHAR ('/'))) + return 1; +#ifdef __MINGW32__ + if (scm_is_eq (c, SCM_MAKE_CHAR ('\\'))) + return 1; +#endif + return 0; } -#endif /* __MINGW32__ */ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, (SCM object, SCM exception_on_error), @@ -532,21 +528,11 @@ 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)) { 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); } @@ -555,11 +541,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) @@ -653,15 +635,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; @@ -707,7 +687,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; @@ -742,7 +722,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; @@ -768,7 +748,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; @@ -829,9 +809,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; @@ -922,9 +902,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; } @@ -933,7 +913,6 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, retrieve_select_type (&except_set, SCM_EOL, excepts)); } #undef FUNC_NAME -#endif /* HAVE_SELECT */ @@ -1095,15 +1074,11 @@ 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; -#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; @@ -1133,6 +1108,90 @@ 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); + +#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); + + /* 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 + { + if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0) + SCM_SYSERROR; + } + } + + 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 */ @@ -1434,6 +1493,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" @@ -1449,32 +1526,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; @@ -1505,14 +1567,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) @@ -1523,22 +1579,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; @@ -1605,14 +1650,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) diff --git a/libguile/filesys.h b/libguile/filesys.h index c420992bd..fc66e40b2 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, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1997, 1998, 1999, 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 @@ -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/libguile/fluids.c b/libguile/fluids.c index 8e36acde6..146854b96 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 @@ -304,22 +305,24 @@ apply_thunk (void *thunk) size_t scm_prepare_fluids (size_t n, SCM *fluids, SCM *values) { - size_t j = n; + size_t j; /* 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. */ - while (j--) + for (j = n; j--;) { size_t i; if (SCM_UNLIKELY (!IS_FLUID (fluids[j]))) scm_wrong_type_arg ("with-fluids", 0, fluids[j]); - for (i = 0; i < j; i++) + for (i = j; i--;) if (scm_is_eq (fluids[i], fluids[j])) { values[i] = values[j]; /* later bindings win */ n--; + fluids[j] = fluids[n]; + values[j] = values[n]; break; } } diff --git a/libguile/foreign.c b/libguile/foreign.c index c81c5f407..4f5aa58e1 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -770,37 +770,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 */ @@ -814,8 +817,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_objcode (bytecode, SCM_UNDEFINED); +} + +#undef GEN_CODE #undef META +#undef M_STATIC +#undef CODE #undef OBJCODE_HEADER #undef META_HEADER @@ -878,21 +901,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/libguile/fports.c b/libguile/fports.c index 94ce434d1..067c3e2b5 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 @@ -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> @@ -50,36 +41,23 @@ #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> +#include <sys/select.h> #include <full-write.h> -#include "libguile/iselect.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" -/* 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 +#include "libguile/fports.h" #if SIZEOF_OFF_T == SIZEOF_INT #define OFF_T_MAX INT_MAX @@ -496,48 +474,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 +487,10 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) { SCM port; scm_t_fport *fp; - 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 +500,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 fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport), "file port"); @@ -600,52 +539,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. */ - -#ifdef HAVE_POLL struct pollfd pollfd = { fdes, POLLIN, 0 }; if (poll (&pollfd, 1, 0) < 0) scm_syserror ("fport_input_waiting"); return pollfd.revents & POLLIN ? 1 : 0; - -#elif defined(HAVE_SELECT) - struct timeval timeout; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - FD_SET (fdes, &read_set); - - timeout.tv_sec = 0; - timeout.tv_usec = 0; - - if (select (SELECT_SET_SIZE, - &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) - /* 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); - return remir; - -#else - scm_misc_error ("fport_input_waiting", - "Not fully implemented on this platform", - SCM_EOL); -#endif } diff --git a/libguile/gc.c b/libguile/gc.c index d580a65a0..581bbc527 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, 2013 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 @@ -281,7 +282,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)), @@ -582,7 +589,14 @@ scm_getenv_int (const char *var, int def) 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 8a0d2961c..49d7cbab4 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 @@ -355,7 +355,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); diff --git a/libguile/guile.c b/libguile/guile.c index 133afc43e..03b603eb2 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996, 1997, 2000, 2001, 2006, 2008, - * 2011 Free Software Foundation, Inc. + * 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 @@ -66,15 +66,41 @@ 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 unset, + or set to a nonzero value, we should install the locale via + setlocale(). */ + return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 1); +} + int main (int argc, char **argv) { - /* Install the locale right at the beginning so that string conversion - for command-line arguments, along with possible error messages, use - the right locale. See + /* 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 (setlocale (LC_ALL, "") == NULL) + if (should_install_locale () && setlocale (LC_ALL, "") == NULL) fprintf (stderr, "guile: warning: failed to install locale\n"); scm_install_gmp_memory_functions = 1; 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; diff --git a/libguile/init.c b/libguile/init.c index 684f6eb02..fb952f2d1 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" diff --git a/libguile/iselect.h b/libguile/iselect.h index 760d959d8..1c7b12db0 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -3,7 +3,8 @@ #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 +30,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/list.c b/libguile/list.c index 627640334..1f44ad032 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)) { diff --git a/libguile/load.c b/libguile/load.c index 081c364e6..ebf79a9eb 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. */ @@ -447,6 +460,60 @@ 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 (scm_is_eq (c, SCM_MAKE_CHAR ('/'))) + return 1; +#ifdef __MINGW32__ + if (scm_is_eq (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 (SCM filename) +{ + size_t filename_len = scm_c_string_length (filename); + + if (filename_len >= 1 + && 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_c_string_ref (filename, 1)) +#endif + ) + return 1; + if (filename_len >= 3 + && 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; +} + /* 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 +544,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)) { if ((scm_is_false (require_exts) || scm_c_string_has_an_ext (filename_chars, filename_len, @@ -520,11 +578,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 +607,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 +874,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, 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); diff --git a/libguile/memoize.c b/libguile/memoize.c index 7431d3c0e..f20241c20 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -284,14 +284,33 @@ memoize (SCM exp, SCM env) memoize (REF (exp, SEQ, TAIL), 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/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; diff --git a/libguile/net_db.c b/libguile/net_db.c index 4d63aabcc..d7a12c50f 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 @@ -34,6 +34,17 @@ #include <verify.h> #include <errno.h> +#ifdef HAVE_STRING_H +#include <string.h> +#endif + +#include <sys/types.h> + +#include <sys/socket.h> +#include <netdb.h> +#include <netinet/in.h> +#include <arpa/inet.h> + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/strings.h" @@ -44,38 +55,15 @@ #include "libguile/net_db.h" #include "libguile/socket.h" -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#include <sys/types.h> +#if defined (HAVE_H_ERRNO) +/* Only wrap gethostbyname / gethostbyaddr if h_errno is available. */ -#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" -#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_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"); @@ -204,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. @@ -267,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" @@ -318,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) { @@ -420,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" @@ -436,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" @@ -605,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 " diff --git a/libguile/numbers.c b/libguile/numbers.c index 01f8e05ac..29d266984 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)) @@ -327,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 @@ -436,107 +410,212 @@ 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 +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_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))) + 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 @@ -820,8 +899,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 return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs); @@ -889,6 +969,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 @@ -3888,52 +4046,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) @@ -4666,6 +4830,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); @@ -4723,19 +4907,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" @@ -4746,79 +5030,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 @@ -4998,220 +5260,230 @@ 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: - 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; + /* 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 expon; + 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) */ { - 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 - { - 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--; + } + } } + + expon = k - 1; + if (k <= 0) + { + 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'; + } + } + + 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) + { + 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) + a[ch++] = '0'; + + if (show_exp) + { + a[ch++] = 'e'; + ch += scm_iint2str (expon, radix, a + ch); + } + + mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL); + } return ch; } @@ -5695,7 +5967,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); @@ -5731,7 +6003,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; @@ -5744,30 +6017,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) == '.') { @@ -5800,7 +6096,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 */ @@ -5876,7 +6172,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 */ @@ -5945,9 +6241,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) @@ -5969,7 +6265,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); @@ -7323,8 +7619,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 return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference); } @@ -7850,8 +8147,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; @@ -7870,18 +8167,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 (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 (SCM_INUM1, x); - } + return scm_i_make_ratio_already_reduced (SCM_INUM1, x); else if (SCM_REALP (x)) { double xx = SCM_REAL_VALUE (x); @@ -7910,8 +8199,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 return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide); } @@ -7931,11 +8220,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; @@ -7946,11 +8231,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); @@ -7959,6 +8240,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)) @@ -7985,7 +8269,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 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -8029,43 +8313,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)) { @@ -8075,6 +8340,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)) @@ -8084,7 +8351,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 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -8099,10 +8366,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); @@ -8140,12 +8413,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); @@ -8179,6 +8458,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); } @@ -8196,12 +8478,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)) { @@ -8211,33 +8493,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 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide); } else return 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 @@ -8875,8 +9152,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 return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1, @@ -8973,21 +9251,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 (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; } } } @@ -9423,26 +9715,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 */ @@ -9453,16 +9739,15 @@ 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)))); + (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); } @@ -9610,25 +9895,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))) { @@ -9649,6 +9926,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), @@ -9679,11 +10006,111 @@ 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)) + { + scm_t_inum x = SCM_I_INUM (z); + + if (SCM_LIKELY (x >= 0)) + { + if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG + || x < (1L << (DBL_MANT_DIG - 1)))) + { + double root = sqrt (x); + + /* 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 xx; + scm_t_inum root; + + mpz_init_set_ui (xx, x); + if (mpz_perfect_square_p (xx)) + { + mpz_sqrt (xx, xx); + root = mpz_get_ui (xx); + mpz_clear (xx); + return SCM_I_MAKINUM (root); + } + else + mpz_clear (xx); + } + } + } + else if (SCM_BIGP (z)) + { + if (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 + { + 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)) + { + 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. */ + { + 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 return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt); @@ -9695,8 +10122,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, @@ -9718,18 +10143,25 @@ 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)); + + { + /* 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); + } + + { + /* 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/libguile/numbers.h b/libguile/numbers.h index 3c43ae421..01eb2cfcd 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -205,7 +205,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/libguile/objcodes.c b/libguile/objcodes.c index c2932334b..3f51c70e0 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,4 +1,5 @@ -/* 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 @@ -576,7 +577,7 @@ SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0, SCM_VALIDATE_STRING (1, filename); c_filename = scm_to_locale_string (filename); - fd = open (c_filename, O_RDONLY | O_CLOEXEC); + fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC); free (c_filename); if (fd < 0) SCM_SYSERROR; diff --git a/libguile/poll.c b/libguile/poll.c index 1bb75727b..9ea846b6d 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 @@ -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. */ -#ifdef HAVE_POLL 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 */ @@ -182,12 +177,8 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) static void scm_init_poll (void) { -#if HAVE_POLL 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)); diff --git a/libguile/ports.c b/libguile/ports.c index 0aacacc06..31d338efe 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -383,10 +383,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/posix.c b/libguile/posix.c index 383ab76fd..a6bf90070 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> @@ -168,6 +155,13 @@ extern char *ttyname(); 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. */ @@ -1148,12 +1142,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. */ @@ -1182,12 +1171,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. */ @@ -1221,17 +1205,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. */ @@ -1432,12 +1406,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) @@ -1638,6 +1607,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)); @@ -1922,22 +1897,6 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, #undef FUNC_NAME #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__) SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, (void), "Return a string containing the name of the user logged in on\n" @@ -1953,7 +1912,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, diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 60ba38caa..07845c317 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 @@ -482,7 +482,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; @@ -529,7 +529,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); @@ -577,15 +577,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_unlocked (port); + c_chr = scm_get_byte_or_eof_unlocked (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_unlocked (port) != EOF)); if (c_total == 0) { @@ -645,7 +647,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, c_read = scm_c_read_unlocked (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) { diff --git a/libguile/random.c b/libguile/random.c index 2db19f729..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 @@ -17,7 +18,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 +30,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 +672,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 */ diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 86fce0fe7..497da2f2e 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" + @@ -526,6 +518,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" @@ -541,6 +534,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, diff --git a/libguile/smob.c b/libguile/smob.c index c2347f3be..857773c18 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 @@ -283,6 +284,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. */ @@ -321,14 +326,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_HEAP_OBJECT_P (obj)) /* Mark the returned object. */ @@ -336,42 +341,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_HEAP_OBJECT_P (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 } @@ -452,6 +450,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/socket.c b/libguile/socket.c index 232041479..7e735f43c 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 @@ -25,9 +25,28 @@ #endif #include <errno.h> -#include <gmp.h> #include <verify.h> +#ifdef HAVE_STDINT_H +#include <stdint.h> +#endif +#ifdef HAVE_STRING_H +#include <string.h> +#endif +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#include <sys/types.h> +#include <sys/socket.h> +#ifdef HAVE_UNIX_DOMAIN_SOCKETS +#include <sys/un.h> +#endif +#include <netinet/in.h> +#include <netdb.h> +#include <arpa/inet.h> + +#include <gmp.h> + #include "libguile/_scm.h" #include "libguile/arrays.h" #include "libguile/feature.h" @@ -40,32 +59,11 @@ #include "libguile/validate.h" #include "libguile/socket.h" -#ifdef __MINGW32__ -#include "win32-socket.h" -#include <netdb.h> +#if SCM_ENABLE_DEPRECATED == 1 +# include "libguile/deprecation.h" #endif -#ifdef HAVE_STDINT_H -#include <stdint.h> -#endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#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> -#endif -#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) \ @@ -512,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" @@ -610,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" @@ -1767,6 +1767,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 @@ -1782,10 +1785,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/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} , 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 diff --git a/libguile/strports.c b/libguile/strports.c index 425b08929..40f656e4b 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -464,13 +464,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 (); diff --git a/libguile/struct.c b/libguile/struct.c index db79e7974..c7f410b63 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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 @@ -152,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) { @@ -179,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 97b6768ad..0aecfb979 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) 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))) diff --git a/libguile/threads.c b/libguile/threads.c index 61fc43e7f..ef771dcae 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 @@ -45,6 +45,8 @@ # include <pthread_np.h> #endif +#include <sys/select.h> + #include <assert.h> #include <fcntl.h> #include <nproc.h> @@ -1057,7 +1059,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; @@ -1134,7 +1139,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)); @@ -1867,9 +1875,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; @@ -1892,11 +1900,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; diff --git a/libguile/threads.h b/libguile/threads.h index 3030f6fdc..147e36dd8 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, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, + * 2007, 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 @@ -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; diff --git a/libguile/vm.c b/libguile/vm.c index c26447028..ccc182afe 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 @@ -634,7 +636,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" @@ -671,7 +683,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 *) @@ -1085,6 +1097,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"); diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c deleted file mode 100644 index 825b4c499..000000000 --- a/libguile/win32-socket.c +++ /dev/null @@ -1,632 +0,0 @@ -/* Copyright (C) 2001, 2006 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; -} - -/* 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. */ -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 4ab9b942a..000000000 --- a/libguile/win32-socket.h +++ /dev/null @@ -1,42 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_WIN32_SOCKET_H -#define SCM_WIN32_SOCKET_H - -/* Copyright (C) 2001, 2006 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); - -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 */ 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/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/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/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/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 50102b260..310b6db85 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 @@ -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 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]) @@ -52,11 +52,13 @@ gl_MODULES([ floor fpieee frexp + fstat full-read full-write func gendocs getaddrinfo + getlogin getpeername getsockname getsockopt @@ -85,12 +87,15 @@ gl_MODULES([ nl_langinfo nproc open + pipe-posix pipe2 + poll putenv recv recvfrom regex rename + select send sendto setenv @@ -103,6 +108,7 @@ gl_MODULES([ striconveh string sys_stat + times trunc verify vsnprintf 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..55c003a58 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 @@ -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: @@ -85,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: @@ -144,7 +147,10 @@ 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 poll: + # Code from module poll-h: # Code from module putenv: # Code from module raise: # Code from module read: @@ -158,6 +164,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,13 +197,16 @@ 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: + # 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: @@ -238,6 +248,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 +301,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]) @@ -336,6 +356,11 @@ AC_DEFUN([gl_INIT], 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]) @@ -529,11 +554,24 @@ AC_DEFUN([gl_INIT], 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_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]) + gl_PREREQ_PUTENV fi gl_STDLIB_MODULE_INDICATOR([putenv]) gl_FUNC_RAISE @@ -586,6 +624,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]) @@ -657,12 +700,16 @@ 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 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 @@ -674,6 +721,11 @@ AC_DEFUN([gl_INIT], 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]) @@ -862,6 +914,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 @@ -887,6 +940,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 @@ -905,6 +959,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 @@ -942,6 +997,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 @@ -960,7 +1016,10 @@ AC_DEFUN([gl_FILE_LIST], [ lib/nproc.h lib/open.c 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 @@ -987,6 +1046,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 @@ -1015,14 +1075,19 @@ 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 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 lib/unistr.in.h lib/unistr/u8-mbtouc-aux.c @@ -1041,6 +1106,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 @@ -1063,6 +1129,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 @@ -1082,6 +1149,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 @@ -1141,7 +1209,10 @@ AC_DEFUN([gl_FILE_LIST], [ m4/off_t.m4 m4/open.m4 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 @@ -1153,6 +1224,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 @@ -1175,13 +1247,16 @@ 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 + 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/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/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 +]) 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/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]) +]) 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/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/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_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]) +]) 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_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/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/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 +]) 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 \ diff --git a/meta/Makefile.am b/meta/Makefile.am index c9d6a3fd7..184c0d920 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 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 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) diff --git a/module/Makefile.am b/module/Makefile.am index c070014bf..7f3c8f8e0 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 \ @@ -287,6 +286,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/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5f42ef4dd..69a7fbc27 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -391,6 +391,12 @@ file with the given name already exists, the effect is unspecified." (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...) ...) @@ -1033,13 +1039,32 @@ 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-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))))) @@ -1777,16 +1802,70 @@ written into the port is returned." ;;; {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 (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 + (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) #\:))) + (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))) @@ -1806,7 +1885,7 @@ written into the port is returned." (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)))) @@ -3061,16 +3140,18 @@ written into the port is returned." (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))) @@ -3112,7 +3193,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)) @@ -3795,16 +3877,17 @@ but it fails to load." ;;; {`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 @@ -3817,18 +3900,28 @@ but it fails to load." '(#: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." + ;; 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 - ((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 @@ -3847,14 +3940,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) @@ -3865,55 +3960,41 @@ reading PATH 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 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. - (catch #t - (lambda () - (let ((gostat (and (not %fresh-auto-compile) - (stat go-path #f)))) - (if (and gostat (more-recent? gostat scmstat)) - go-path - (begin - (if gostat - (format (current-warning-port) - ";;; note: source file ~a\n;;; newer than compiled ~a\n" - name go-path)) - (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))) - - (define (absolute-path? path) - (string-prefix? "/" path)) + (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. + (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 #\.))) @@ -3921,52 +4002,51 @@ reading PATH with READER." (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)) - (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) - (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 @@ -4009,22 +4089,22 @@ reading PATH 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 guile-2.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/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/module/ice-9/mapping.scm b/module/ice-9/mapping.scm index 2907a8d89..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))) @@ -50,16 +53,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 +72,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 +92,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)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index ada930755..1225d92df 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1776,11 +1776,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 @@ -1790,11 +1788,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))))) @@ -1803,11 +1800,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 @@ -1817,11 +1812,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))))) @@ -3029,10 +3023,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 90c76d550..1aa54020f 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2173,12 +2173,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))))) @@ -2186,12 +2186,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))))) @@ -3020,13 +3020,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)) 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))) 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 ) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index f5bb699b2..c065474b5 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 @@ -261,20 +261,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))) @@ -702,7 +704,8 @@ ((<seq> head tail) (primitive 'begin) (recurse head) (recurse tail)) - ((<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 a3991b61f..ddcba9938 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 @@ -311,7 +311,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) @@ -397,7 +399,11 @@ This is an implementation of `foldts' as described by Andy Wingo in ((<seq> head tail) (up tree (loop tail (loop head (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 @@ -475,7 +481,9 @@ This is an implementation of `foldts' as described by Andy Wingo in (let-values (((seed ...) (foldts head seed ...))) (foldts tail 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 @@ -549,7 +557,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)) @@ -639,7 +648,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 2536a7155..1db842022 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 @@ -44,6 +44,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-primcall + #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/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 79f4ff9e1..1b6fea69c 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 @@ -344,9 +344,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/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index f8fd1cd9c..f8df3ce55 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 @@ -539,8 +539,10 @@ (return (make-call 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 a32fc4153..65fd58e3c 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 8b380da27..b5586e2b4 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 @@ -311,7 +311,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. (($ <primcall> _ (? bailout-primitive? name) args) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 2d2c30ba6..fe637f0a5 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1439,13 +1439,13 @@ 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 (($ <primcall> _ '@apply - (($ <lambda> _ _ lcase) + (($ <lambda> _ _ (and lcase ($ <lambda-case>))) ($ <lexical-ref> _ _ sym) ...)) (and (equal? sym gensyms) 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-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/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-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/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 29b0393ff..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,10 +36,13 @@ #: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)) + (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 diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index f3e464182..c522b74b5 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))) @@ -57,10 +57,13 @@ (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 + (close-port tmp) (delete-file template))))))) (define (ensure-language x) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 304056de2..c74ae679d 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 @@ -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,16 +75,30 @@ (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) - ((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-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) + + ((string-match "^i[0-9]86$" cpu) 4) + + ;; 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 "^x86_64-.*-gnux32" triplet) 4) ; x32 + + ((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/module/system/repl/command.scm b/module/system/repl/command.scm index aa16f5d8d..a3e43fe18 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 diff --git a/module/texinfo.scm b/module/texinfo.scm index edee5b397..91bb46d8d 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)) @@ -484,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/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm index 83e5e38f9..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 @@ -255,6 +249,7 @@ (sc ,var) (copyright ,(lambda args "(C)")) (result ,(lambda args "==>")) + (dots ,(lambda args "...")) (xref ,ref) (ref ,ref) (pxref ,ref) @@ -296,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 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/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..35169ef5c 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 @@ -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) @@ -971,7 +1002,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*)) @@ -1628,18 +1659,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/module/web/response.scm b/module/web/response.scm index 7e14f4dc0..570a2d7d2 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -267,19 +267,32 @@ 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 - (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) 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?) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index b1e90bac3..b78f599b2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -132,6 +132,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/standalone/Makefile.am b/test-suite/standalone/Makefile.am index be5d91380..eb47f30bc 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -37,7 +37,7 @@ TESTS_ENVIRONMENT = \ @LOCALCHARSET_TESTS_ENVIRONMENT@ \ 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 @@ -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-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; 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>. */ 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; +} diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test index e74d376e5..7b13c5f8c 100644 --- a/test-suite/tests/00-socket.test +++ b/test-suite/tests/00-socket.test @@ -339,7 +339,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)) @@ -412,7 +412,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)) @@ -508,7 +508,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/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index ddbe2eeac..688e7524a 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 @@ -134,6 +134,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) '*)) @@ -154,7 +157,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 @@ -187,6 +191,13 @@ (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) + (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 (call-with-values (lambda () 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/filesys.test b/test-suite/tests/filesys.test index a6bfb6eb5..21b893796 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,72 @@ (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" + (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" + (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)) diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index 9ed846c05..9ad9e81f8 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,31 @@ (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) + (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) + (a 3) + (b 4)) + (eqv? (fluid-ref b) 4)) + #: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) 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/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)))))) diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 72aa0c478..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,12 +143,8 @@ (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 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 +153,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 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/numbers.test b/test-suite/tests/numbers.test index 66aa01ae0..7d30392c8 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -46,15 +46,35 @@ ;; 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-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)) + (e 2 (- e 1))) + ((begin (when (< e -100000000) + (error "Unable to determine dbl-min-exp")) + (= 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) @@ -200,71 +220,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? ;;; @@ -1428,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")) @@ -1456,26 +1429,65 @@ (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) + (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 @@ -1493,7 +1505,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 +1546,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) @@ -3913,21 +3935,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)) @@ -4000,7 +4018,155 @@ ;; 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))) + + (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 @@ -4044,6 +4210,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))) @@ -4272,6 +4441,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 @@ -4282,13 +4458,55 @@ (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 "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))) + + (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 @@ -4317,6 +4535,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)))) @@ -4619,7 +4840,80 @@ (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 '*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) + (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))))) + + ;; 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))) + (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))) @@ -4898,3 +5192,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)) 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) 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/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)) + ) 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))) 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))) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 3b44ba016..ee6446773 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -240,6 +240,16 @@ (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))))) + (use-modules (system syntax)) (with-test-prefix "syntax-local-binding" 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 diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 8a4b593fd..2cb4a7187 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 @@ -417,4 +416,9 @@ (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"))))))) + (test-body "Like this---e.g.@:, at colon." + '((para "Like this---e.g.:, at colon."))) ) 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 diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 6d501ec1c..2ed15c7a9 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" diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test index d9bbbebce..dc54ffa50 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)) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 97f55594a..b2c5c2c2b 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)) @@ -109,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")) @@ -180,6 +290,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 "*" '*)