diff options
| author | Mark H Weaver <mhw@netris.org> | 2014-04-25 02:06:01 -0400 |
|---|---|---|
| committer | Mark H Weaver <mhw@netris.org> | 2014-04-25 02:06:01 -0400 |
| commit | 475772ea57c97d0fa0f9ed9303db137d9798ddd3 (patch) | |
| tree | 99a9ba2ea0b044552016d41c5c9197bbac66d97f | |
| parent | 0e92ef40d047696eb3334405b2dd32f51ca55006 (diff) | |
| parent | e0da53b4fe4abee2cdcd97fe46eeefcaab1da631 (diff) | |
Merge branch 'stable-2.0'
Conflicts:
GUILE-VERSION
NEWS
guile-readline/ice-9/readline.scm
libguile/async.c
libguile/backtrace.c
libguile/deprecated.h
libguile/gc-malloc.c
libguile/gdbint.c
libguile/init.c
libguile/ioext.c
libguile/mallocs.c
libguile/print.c
libguile/rw.c
libguile/scmsigs.c
libguile/script.c
libguile/simpos.c
libguile/snarf.h
libguile/strports.c
libguile/threads.c
libguile/vm-i-scheme.c
libguile/vm-i-system.c
module/srfi/srfi-18.scm
test-suite/Makefile.am
test-suite/standalone/test-num2integral.c
104 files changed, 3625 insertions, 2817 deletions
diff --git a/Makefile.am b/Makefile.am index 2ed837046..8f9e014c7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,7 +1,8 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, +## 2014 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -45,6 +46,16 @@ libguileinclude_HEADERS = libguile.h schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION) schemelib_DATA = libguile/guile-procedures.txt +# Our own implementation of Gnulib's lock interface. +noinst_HEADERS = lib/glthread/lock.h + +# Our lib/glthreads/lock.h header indirectly includes +# libguile/scmconfig.h. Make sure it is built before we recurse into +# lib/. +BUILT_SOURCES = libguile/scmconfig.h +libguile/scmconfig.h: + $(MAKE) -C libguile scmconfig.h + # 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 @@ -94,7 +105,7 @@ gen-ChangeLog: mv $(distdir)/cl-t $(distdir)/ChangeLog; \ fi -BUILT_SOURCES = $(top_srcdir)/.version +BUILT_SOURCES += $(top_srcdir)/.version $(top_srcdir)/.version: echo $(VERSION) > $@-t && mv $@-t $@ gen-tarball-version: @@ -379,6 +379,372 @@ users, but packagers may be interested. +Changes in 2.0.11 (since 2.0.10): + +This release fixes an embarrassing regression introduced in the C +interface to SRFI-4 vectors. See +<https://lists.gnu.org/archive/html/guile-devel/2014-03/msg00047.html> +for details. + + +Changes in 2.0.10 (since 2.0.9): + +* Notable changes + +** New GDB extension to support Guile + +Guile now comes with an extension for GDB 7.8 or later (unreleased at +the time of writing) that simplifies debugging of C code that uses +Guile. See "GDB Support" in the manual. + +** Improved integration between R6RS and native Guile exceptions + +R6RS exception handlers, established using 'with-exception-handler' or +'guard', are now able to catch native Guile exceptions, which are +automatically converted into appropriate R6RS condition objects. + +** Support for HTTP proxies + +Guile's built-in web client now honors the 'http_proxy' environment +variable, as well as the new 'current-http-proxy' parameter. See +"Web Client" in the manual for details. + +** Lexical syntax improvements + +*** Support |...| symbol notation. + +Guile's core reader and printer now support the R7RS |...| notation +for writing symbols with arbitrary characters, as a more portable and +attractive alternative to Guile's native #{...}# notation. To enable +this notation by default, put one or both of the following in your +~/.guile: + + (read-enable 'r7rs-symbols) + (print-enable 'r7rs-symbols) + +*** Support '#true' and '#false' notation for booleans. + +The booleans '#t' and '#f' may now be written as '#true' and '#false' +for improved readability, per R7RS. + +*** Recognize '#\escape' character name. + +The escape character '#\esc' may now be written as '#\escape', per R7RS. + +*** Accept "\|" in string literals. + +The pipe character may now be preceded by a backslash, per R7RS. + +** Custom binary input ports now support 'setvbuf'. + +Until now, ports returned by 'make-custom-binary-input-port' were always +full-buffered. Now, their buffering mode can be changed using 'setvbuf'. + +** SRFI-4 predicates and length accessors no longer accept arrays. + +Given that the SRFI-4 accessors don't work for arrays, the fact that the +predicates and length accessors returned true for arrays was a bug. + +** GUILE_PROGS now supports specifying a minimum required version. + +The 'GUILE_PROGS' autoconf macro in guile.m4 now allows an optional +argument to specify a minimum required Guile version. By default, it +requires Guile >= 2.0. A micro version can also be specified, e.g.: +GUILE_PROGS([2.0.10]) + +** Error reporting improvements + +*** Improved run-time error reporting in (ice-9 match). + +If no pattern matches in a 'match' form, the datum that failed to match +is printed along with the location of the failed 'match' invocation. + +*** Print the faulty object upon invalid-keyword errors. +*** Improved error reporting of procedures defined by define-inlinable. +*** Improved error reporting for misplaced ellipses in macro definitions. +*** Improved error checking in 'define-public' and 'module-add!'. +*** Improved error when 'include' form with relative path is not in a file. + +** Speed improvements + +*** 'scm_c_read' on ISO-8859-1 (e.g. binary) unbuffered ports is faster. +*** New inline asm for VM fixnum multiply, for faster overflow checking. +*** New inline asm for VM fixnum operations on ARM and 32-bit x86. +*** 'positive?' and 'negative?' are now compiled to VM primitives. +*** Numerical comparisons with more than 2 arguments are compiled to VM code. +*** Several R6RS bitwise operators have been optimized. + +** Miscellaneous + +*** Web: 'content-disposition' headers are now supported. +*** Web: 'uri-encode' hexadecimal percent-encoding is now uppercase. +*** Size argument to 'make-doubly-weak-hash-table' is now optional. +*** Timeout for 'unlock-mutex' and SRFI-18 'mutex-unlock!' may now be #f. + +** Gnulib update + +Guile's copy of Gnulib was updated to v0.1-92-g546ff82. The following +modules were imported from Gnulib: copysign, fsync, isfinite, link, +lstat, mkdir, mkstemp, readlink, rename, rmdir, and unistd. + +* New interfaces + +** Cooperative REPL servers + +This new facility supports REPLs that run at specified times within an +existing thread, for example in programs utilizing an event loop or in +single-threaded programs. This allows for safe access and mutation of +a program's data structures from the REPL without concern for thread +synchronization. See "Cooperative REPL Servers" in the manual for +details. + +** SRFI-43 (Vector Library) + +Guile now includes SRFI-43, a comprehensive library of vector operations +analogous to the SRFI-1 list library. See "SRFI-43" in the manual for +details. + +** SRFI-64 (A Scheme API for test suites) + +Guile now includes SRFI-64, a flexible framework for creating test +suites. The reference implementation of SRFI-64 has also been updated +to fully support earlier versions of Guile. + +** SRFI-111 (Boxes) + +See "SRFI-111" in the manual. + +** 'define-values' + +See "Binding multiple return values" in the manual. + +** Custom ellipsis identifiers using 'with-ellipsis' or SRFI-46. + +Guile now allows macro definitions to use identifiers other than '...' +as the ellipsis. This is convenient when writing macros that generate +macro definitions. The desired ellipsis identifier can be given as the +first operand to 'syntax-rules', as specified in SRFI-46 and R7RS, or by +using the new 'with-ellipsis' special form in procedural macros. With +this addition, Guile now fully supports SRFI-46. + +See "Specifying a Custom Ellipsis Identifier" and "Custom Ellipsis +Identifiers for syntax-case Macros" in the manual for details. + +** R7RS 'syntax-error' + +Guile now supports 'syntax-error', as specified by R7RS, allowing for +improved compile-time error reporting from 'syntax-rules' macros. See +"Reporting Syntax Errors in Macros" in the manual for details. + +** New procedures to convert association lists into hash tables + +Guile now includes the convenience procedures 'alist->hash-table', +'alist->hashq-table', 'alist->hashv-table', and 'alist->hashx-table'. +See "Hash Table Reference" in the manual. + +** New predicates: 'exact-integer?' and 'scm_is_exact_integer' + +See "Integers" in the manual. + +** 'weak-vector-length', 'weak-vector-ref', and 'weak-vector-set!' + +These should now be used to access weak vectors, instead of +'vector-length', 'vector-ref', and 'vector-set!'. + +* Manual updates + +** Improve docs for 'eval-when'. + +Each 'eval-when' condition is now explained in detail, including +'expand' which was previously undocumented. (expand load eval) is now +the recommended set of conditions, instead of (compile load eval). +See "Eval When" in the manual, for details. + +** Update the section on SMOBs and memory management. + +See "Defining New Types (Smobs)" in the manual. + +** Fixes + +*** GOOPS: #:dsupers is the init keyword for the dsupers slot. +*** 'unfold-right' takes a tail, not a tail generator. +*** Clarify that 'append!' and 'reverse!' might not mutate. +*** Fix doc that incorrectly claimed (integer? +inf.0) => #t. + (http://bugs.gnu.org/16356) +*** Document that we support SRFI-62 (S-expression comments). +*** Document that we support SRFI-87 (=> in case clauses). +*** Document 'equal?' in the list of R6RS incompatibilities. +*** Remove outdated documentation of LTDL_LIBRARY_PATH. +*** Fix 'weak-vector?' doc: Weak hash tables are not weak vectors. +*** Fix 'my-or' examples to use let-bound variable. + (http://bugs.gnu.org/14203) + +* New deprecations + +** General 'uniform-vector' interface + +This interface lacked both generality and specificity. The general +replacements are 'array-length', 'array-ref', and friends on the scheme +side, and the array handle interface on the C side. On the specific +side of things, there are the specific bytevector, SRFI-4, and bitvector +interfaces. + +** Use of the vector interface on arrays +** 'vector-length', 'vector-ref', and 'vector-set!' on weak vectors +** 'vector-length', 'vector-ref', and 'vector-set!' as primitive-generics + +Making the vector interface operate only on a single representation will +allow future versions of Guile to compile loops involving vectors to +more efficient native code. + +** 'htons', 'htonl', 'ntohs', 'ntohl' + +These procedures, like their C counterpart, were used to convert numbers +to/from network byte order, typically in conjunction with the +now-deprecated uniform vector API. + +This functionality is now covered by the bytevector and binary I/O APIs. +See "Interpreting Bytevector Contents as Integers" in the manual. + +** 'gc-live-object-stats' + +It hasn't worked in the whole 2.0 series. There is no replacement, +unfortunately. + +** 'scm_c_program_source' + +This internal VM function was not meant to be public. Use +'scm_procedure_source' instead. + +* Build fixes + +** Fix build with Clang 3.4. + +** MinGW build fixes +*** Do not add $(EXEEXT) to guild or guile-tools. +*** tests: Use double quotes around shell arguments, for Windows. +*** tests: Don't rely on $TMPDIR and /tmp on Windows. +*** tests: Skip FFI tests that use `qsort' when it's not accessible. +*** tests: Remove symlink only when it exists. +*** tests: Don't rely on `scm_call_2' being visible. + +** Fix computation of LIBLOBJS so dependencies work properly. + (http://bugs.gnu.org/14193) + +* Bug fixes + +** Web: Fix web client with methods other than GET. + (http://bugs.gnu.org/15908) +** Web: Add Content-Length header for empty bodies. +** Web: Accept "UTC" as the zone offset in date headers. + (http://bugs.gnu.org/14128) +** Web: Don't throw if a response is longer than its Content-Length says. +** Web: Write out HTTP Basic auth headers correctly. + (http://bugs.gnu.org/14370) +** Web: Always print a path component in 'write-request-line'. +** Fix 'define-public' from (ice-9 curried-definitions). +** psyntax: toplevel variable definitions discard previous syntactic binding. + (http://bugs.gnu.org/11988) +** Fix thread-unsafe lazy initializations. +** Make (ice-9 popen) thread-safe. + (http://bugs.gnu.org/15683) +** Make guardians thread-safe. +** Make regexp_exec thread-safe. + (http://bugs.gnu.org/14404) +** vm: Gracefully handle stack overflows. + (http://bugs.gnu.org/15065) +** Fix 'rationalize'. + (http://bugs.gnu.org/14905) +** Fix inline asm for VM fixnum operations on x32. +** Fix 'SCM_SYSCALL' to really swallow EINTR. +** Hide EINTR returns from 'accept'. +** SRFI-19: Update the table of leap seconds. +** Add missing files to the test-suite Makefile. +** Make sure 'ftw' allows directory traversal when running as root. +** Fix 'hash-for-each' for weak hash tables. +** SRFI-18: Export 'current-thread'. + (http://bugs.gnu.org/16890) +** Fix inlining of tail list to apply. + (http://bugs.gnu.org/15533) +** Fix bug in remqueue in threads.c when removing last element. +** Fix build when '>>' on negative integers is not arithmetic. +** Fix 'bitwise-bit-count' for negative arguments. + (http://bugs.gnu.org/14864) +** Fix VM 'ash' for right shifts by large amounts. + (http://bugs.gnu.org/14864) +** Fix rounding in scm_i_divide2double for negative arguments. +** Avoid lossy conversion from inum to double in numerical comparisons. +** Fix numerical comparison of fractions to infinities. +** Allow fl+ and fl* to accept zero arguments. + (http://bugs.gnu.org/14869) +** flonum? returns false for complex number objects. + (http://bugs.gnu.org/14866) +** flfinite? applied to a NaN returns false. + (http://bugs.gnu.org/14868) +** Flonum operations always return flonums. + (http://bugs.gnu.org/14871) +** min and max: NaNs beat infinities, per R6RS errata. + (http://bugs.gnu.org/14865) +** Fix 'fxbit-count' for negative arguments. +** 'gcd' and 'lcm' support inexact integer arguments. + (http://bugs.gnu.org/14870) +** Fix R6RS 'fixnum-width'. + (http://bugs.gnu.org/14879) +** tests: Use shell constructs that /bin/sh on Solaris 10 can understand. + (http://bugs.gnu.org/14042) +** Fix display of symbols containing backslashes. + (http://bugs.gnu.org/15033) +** Fix truncated-print for uniform vectors. +** Define `AF_UNIX' only when Unix-domain sockets are supported. +** Decompiler: fix handling of empty 'case-lambda' expressions. +** Fix handling of signed zeroes and infinities in 'numerator' and 'denominator'. +** dereference-pointer: check for null pointer. +** Optimizer: Numerical comparisons are not negatable, for correct NaN handling. +** Compiler: Evaluate '-' and '/' in left-to-right order. + (for more robust floating-point arithmetic) +** snarf.h: Declare static const function name vars as SCM_UNUSED. +** chars.c: Remove duplicate 'const' specifiers. +** Modify SCM_UNPACK type check to avoid warnings in clang. +** Arrange so that 'file-encoding' does not truncate the encoding name. + (http://bugs.gnu.org/16463) +** Improve error checking in bytevector->uint-list and bytevector->sint-list. + (http://bugs.gnu.org/15100) +** Fix (ash -1 SCM_I_FIXNUM_BIT-1) to return a fixnum instead of a bignum. +** i18n: Fix null pointer dereference when locale info is missing. +** Fix 'string-copy!' to work properly with overlapping src/dest. +** Fix hashing of vectors to run in bounded time. +** 'port-position' works on CBIPs that do not support 'set-port-position!'. +** Custom binary input ports sanity-check the return value of 'read!'. +** bdw-gc.h: Check SCM_USE_PTHREAD_THREADS using #if not #ifdef. +** REPL Server: Don't establish a SIGINT handler. +** REPL Server: Redirect warnings to client socket. +** REPL Server: Improve robustness of 'stop-server-and-clients!'. +** Add srfi-16, srfi-30, srfi-46, srfi-62, srfi-87 to %cond-expand-features. +** Fix trap handlers to handle applicable structs. + (http://bugs.gnu.org/15691) +** Fix optional end argument in `uniform-vector-read!'. + (http://bugs.gnu.org/15370) +** Fix brainfuck->scheme compiler. +** texinfo: Fix newline preservation in @example with lines beginning with @ + +** C standards conformance improvements + +Improvements and bug fixes were made to the C part of Guile's run-time +support (libguile). + +*** Don't use the identifier 'noreturn'. + (http://bugs.gnu.org/15798) +*** Rewrite SCM_I_INUM to avoid unspecified behavior when not using GNU C. +*** Improve fallback implemention of SCM_SRS to avoid unspecified behavior. +*** SRFI-60: Reimplement 'rotate-bit-field' on inums to be more portable. +*** Improve compliance with C standards regarding signed integer shifts. +*** Avoid signed overflow in random.c. +*** VM: Avoid signed overflows in 'add1' and 'sub1'. +*** VM: Avoid overflow in ASM_ADD when the result is most-positive-fixnum. +*** read: Avoid signed integer overflow in 'read_decimal_integer'. + + + Changes in 2.0.9 (since 2.0.7): Note: 2.0.8 was a brown paper bag release that was never announced, but @@ -82,7 +82,7 @@ Guile requires the following external packages: libgc (aka. the Boehm-Demers-Weiser garbage collector) is the conservative garbage collector used by Guile. It is available - from http://www.hpl.hp.com/personal/Hans_Boehm/gc/ . + from http://www.hboehm.info/gc/ . - libffi @@ -5,6 +5,7 @@ Contributors since the last release: Aleix Conchillo Flaqué Ludovic Courtès Jason Earl + Paul Eggert Brian Gough Volker Grabsch Julian Graham @@ -183,6 +184,7 @@ For fixes or providing information which led to a fix: Andreas Vögele Michael Talbot-Wilson Michael Tuexen + Xin Wang Thomas Wawrzinek Mark H. Weaver Göran Weinholt diff --git a/configure.ac b/configure.ac index 57424f78a..55bfafcec 100644 --- a/configure.ac +++ b/configure.ac @@ -51,6 +51,10 @@ GUILE_VERSION="$PACKAGE_VERSION" AC_CONFIG_HEADERS([config.h]) AH_TOP(/*GUILE_CONFIGURE_COPYRIGHT*/) +dnl We require the pkg.m4 set of macros from pkg-config. +dnl Make sure it's available. +m4_pattern_forbid([PKG_CHECK_MODULES]) + #-------------------------------------------------------------------- AC_LANG([C]) @@ -72,6 +76,13 @@ AM_PROG_AR dnl Gnulib. gl_INIT +dnl We provide our own lib/glthread/lock.h, so let other Gnulib modules +dnl know that we have it. This allows them to be compiled with adequate +dnl locking support. See <http://bugs.gnu.org/14404>. +AC_DEFINE([GNULIB_LOCK], [1], + [Define to allow Gnulib modules to use Guile's locks.]) + + AC_PROG_CC_C89 # for per-target cflags in the libguile subdir @@ -1409,10 +1420,13 @@ AM_CONDITIONAL([BUILD_PTHREAD_SUPPORT], [test "x$build_pthread_support" = "xyes"]) -## Check whether pthread_attr_getstack works for the main thread - if test "$with_threads" = pthreads; then +dnl Normally Gnulib's 'threadlib' module would define this macro, but +dnl since we don't use it, define it by ourselves. +AC_DEFINE([USE_POSIX_THREADS], [1], + [Define to let Gnulib modules know that we use POSIX threads.]) + AC_MSG_CHECKING([whether pthread_attr_getstack works for the main thread]) old_CFLAGS="$CFLAGS" CFLAGS="$PTHREAD_CFLAGS $CFLAGS" @@ -1488,7 +1502,8 @@ AC_SUBST(HOST_CC) GUILE_CHECK_GUILE_FOR_BUILD -## If we're using GCC, ask for aggressive warnings. +## If we're using GCC, add flags to reduce strictness of undefined +## behavior, and ask for aggressive warnings. GCC_CFLAGS="" case "$GCC" in yes ) @@ -1498,13 +1513,13 @@ case "$GCC" in ## -Wundef was removed because Gnulib prevented it (see ## <http://thread.gmane.org/gmane.lisp.guile.bugs/5329>.) - ## Build with `-fno-strict-aliasing' to prevent miscompilation on - ## some platforms. See + ## Build with `-fno-strict-aliasing' and `-fwrapv' to prevent + ## miscompilation on some platforms. See ## <http://lists.gnu.org/archive/html/guile-devel/2012-01/msg00487.html>. POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \ -Wdeclaration-after-statement -Wpointer-arith \ - -Wswitch-enum -fno-strict-aliasing" + -Wswitch-enum -fno-strict-aliasing -fwrapv" # Do this here so we don't screw up any of the tests above that might # not be "warning free" if test "${GUILE_ERROR_ON_WARNING}" = yes @@ -1597,6 +1612,9 @@ AC_SUBST(top_builddir_absolute) top_srcdir_absolute=`(cd $srcdir && pwd)` AC_SUBST(top_srcdir_absolute) +dnl Add -I flag so that lib/glthread/lock.h finds <libguile/threads.h>. +CPPFLAGS="-I$top_srcdir_absolute $CPPFLAGS" + dnl `sitedir' goes into libpath.h and the pkg-config file. pkgdatadir="$datadir/$PACKAGE_TARNAME" sitedir="$pkgdatadir/site/$GUILE_EFFECTIVE_VERSION" diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 0b14c4889..055de9935 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.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, 2005, 2006, -@c 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Compound Data Types @@ -673,6 +673,8 @@ that vectors are the special case of one dimensional non-uniform arrays and that most array procedures operate happily on vectors (@pxref{Arrays}). +Also see @ref{SRFI-43}, for a comprehensive vector library. + @menu * Vector Syntax:: Read syntax for vectors. * Vector Creation:: Dynamic vector creation and validation. diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index ba00603b8..96f9fd017 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -5543,6 +5543,8 @@ approach to properties, see @ref{Object Properties}. @node Symbol Read Syntax @subsubsection Extended Read Syntax for Symbols +@cindex r7rs-symbols + The read syntax for a symbol is a sequence of letters, digits, and @dfn{extended alphabetic characters}, beginning with a character that cannot begin a number. In addition, the special cases of @code{+}, @@ -5603,6 +5605,16 @@ double quotes. |\| is a vertical bar| @end example +Note that there's also an @code{r7rs-symbols} print option +(@pxref{Scheme Write}). To enable the use of this notation, evaluate +one or both of the following expressions: + +@example +(read-enable 'r7rs-symbols) +(print-enable 'r7rs-symbols) +@end example + + @node Symbol Uninterned @subsubsection Uninterned Symbols diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 5dabb8403..9b0e56448 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -17,8 +17,9 @@ infrastructure that builds on top of those calls. @menu * Evaluation Model:: Evaluation and the Scheme stack. * Source Properties:: From expressions to source locations. -* Programmatic Error Handling:: Debugging when an error occurs. +* Programmatic Error Handling:: Debugging when an error occurs. * Traps:: Breakpoints, tracepoints, oh my! +* GDB Support:: C-level debugging with GDB. @end menu @node Evaluation Model @@ -1478,6 +1479,43 @@ This is a stepping trap, used to implement the ``step'', ``next'', ``step-instruction'', and ``next-instruction'' REPL commands. @end deffn +@node GDB Support +@subsection GDB Support + +@cindex GDB support + +Sometimes, you may find it necessary to debug Guile applications at the +C level. Doing so can be tedious, in particular because the debugger is +oblivious to Guile's @code{SCM} type, and thus unable to display +@code{SCM} values in any meaningful way: + +@example +(gdb) frame +#0 scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437 +@end example + +To address that, Guile comes with an extension of the GNU Debugger (GDB) +that contains a ``pretty-printer'' for @code{SCM} values. With this GDB +extension, the C frame in the example above shows up like this: + +@example +(gdb) frame +#0 scm_display (obj=("hello" GDB!), port=#<port file 6f9f30>) at print.c:1437 +@end example + +@noindent +Here GDB was able to decode the list pointed to by @var{obj}, and to +print it using Scheme's read syntax. + +That extension is a @code{.scm} file installed alongside the +@file{libguile} shared library. When GDB 7.8 or later is installed and +compiled with support for extensions written in Guile, the extension is +automatically loaded when debugging a program linked against +@file{libguile} (@pxref{Auto-loading,,, gdb, Debugging with GDB}). Note +that the directory where @file{libguile} is installed must be among +GDB's auto-loading ``safe directories'' (@pxref{Auto-loading safe +path,,, gdb, Debugging with GDB}). + @c Local Variables: @c TeX-master: "guile.texi" diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index dde164372..a23cf1ae4 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -23,6 +23,7 @@ loading, evaluating, and compiling Scheme code at run time. * Local Evaluation:: Evaluation in a local lexical environment. * Local Inclusion:: Compile-time inclusion of one file in another. * REPL Servers:: Serving a REPL over a socket. +* Cooperative REPL Servers:: REPL server for single-threaded applications. @end menu @@ -1267,6 +1268,54 @@ with no arguments. @deffn {Scheme Procedure} stop-server-and-clients! Closes the connection on all running server sockets. + +Please note that in the current implementation, the REPL threads are +cancelled without unwinding their stacks. If any of them are holding +mutexes or are within a critical section, the results are unspecified. +@end deffn + +@node Cooperative REPL Servers +@subsection Cooperative REPL Servers + +@cindex Cooperative REPL server + +The procedures in this section are provided by +@lisp +(use-modules (system repl coop-server)) +@end lisp + +Whereas ordinary REPL servers run in their own threads (@pxref{REPL +Servers}), sometimes it is more convenient to provide REPLs that run at +specified times within an existing thread, for example in programs +utilizing an event loop or in single-threaded programs. This allows for +safe access and mutation of a program's data structures from the REPL, +without concern for thread synchronization. + +Although the REPLs are run in the thread that calls +@code{spawn-coop-repl-server} and @code{poll-coop-repl-server}, +dedicated threads are spawned so that the calling thread is not blocked. +The spawned threads read input for the REPLs and to listen for new +connections. + +Cooperative REPL servers must be polled periodically to evaluate any +pending expressions by calling @code{poll-coop-repl-server} with the +object returned from @code{spawn-coop-repl-server}. The thread that +calls @code{poll-coop-repl-server} will be blocked for as long as the +expression takes to be evaluated or if the debugger is entered. + +@deffn {Scheme Procedure} spawn-coop-repl-server [server-socket] +Create and return a new cooperative REPL server object, and spawn a new +thread to listen for connections on @var{server-socket}. Proper +functioning of the REPL server requires that +@code{poll-coop-repl-server} be called periodically on the returned +server object. +@end deffn + +@deffn {Scheme Procedure} poll-coop-repl-server coop-server +Poll the cooperative REPL server @var{coop-server} and apply a pending +operation if there is one, such as evaluating an expression typed at the +REPL prompt. This procedure must be called from the same thread that +called @code{spawn-coop-repl-server}. @end deffn @c Local Variables: diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 381c10d63..c2c49ec48 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -604,7 +604,7 @@ Unpack the pointer value from a pointer object. Wrapped pointers are untyped, so they are essentially equivalent to C @code{void} pointers. As in C, the memory region pointed to by a pointer can be accessed at the byte level. This is achieved using -@emph{bytevectors} (@pxref{Bytevectors}). The @code{(rnrs bytevector)} +@emph{bytevectors} (@pxref{Bytevectors}). The @code{(rnrs bytevectors)} module contains procedures that can be used to convert byte sequences to Scheme objects such as strings, floating point numbers, or integers. diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 161d3725e..882b7d371 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -4626,8 +4626,8 @@ comparisons are performed is unspecified. @subsubsection SRFI-43 Selectors @deffn {Scheme Procedure} vector-ref vec i -Return the value that the location in @var{vec} at @var{i} is mapped to -in the store. Indexing is based on zero. +Return the element at index @var{i} in @var{vec}. Indexing is based on +zero. @end deffn @deffn {Scheme Procedure} vector-length vec diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 1b2fa5650..02e68af0f 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -1,6 +1,7 @@ ;;;; readline.scm --- support functions for command-line editing ;;;; -;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011, +;;;; 2013, 2014 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 @@ -105,7 +106,7 @@ (set! history-buffer (if history-buffer (string-append history-buffer - " " + "\n" str) str))) str))))) diff --git a/lib/Makefile.am b/lib/Makefile.am index 564836953..5d9c902fc 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign 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 isfinite 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 time times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync 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 isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits subdir-objects @@ -69,7 +69,6 @@ libgnu_la_LDFLAGS += $(LOG1P_LIBM) libgnu_la_LDFLAGS += $(LOG_LIBM) libgnu_la_LDFLAGS += $(LTLIBICONV) libgnu_la_LDFLAGS += $(LTLIBINTL) -libgnu_la_LDFLAGS += $(LTLIBTHREAD) libgnu_la_LDFLAGS += $(LTLIBUNISTRING) libgnu_la_LDFLAGS += $(ROUND_LIBM) libgnu_la_LDFLAGS += $(SERVENT_LIB) @@ -567,6 +566,15 @@ EXTRA_libgnu_la_SOURCES += fstat.c ## end gnulib module fstat +## begin gnulib module fsync + + +EXTRA_DIST += fsync.c + +EXTRA_libgnu_la_SOURCES += fsync.c + +## end gnulib module fsync + ## begin gnulib module full-read libgnu_la_SOURCES += full-read.h full-read.c @@ -905,6 +913,15 @@ EXTRA_DIST += libunistring.valgrind ## end gnulib module libunistring +## begin gnulib module link + + +EXTRA_DIST += link.c + +EXTRA_libgnu_la_SOURCES += link.c + +## end gnulib module link + ## begin gnulib module listen @@ -1032,12 +1049,6 @@ EXTRA_libgnu_la_SOURCES += localeconv.c ## end gnulib module localeconv -## begin gnulib module lock - -libgnu_la_SOURCES += glthread/lock.h glthread/lock.c - -## end gnulib module lock - ## begin gnulib module log @@ -1417,6 +1428,24 @@ EXTRA_libgnu_la_SOURCES += memchr.c ## end gnulib module memchr +## begin gnulib module mkdir + + +EXTRA_DIST += mkdir.c + +EXTRA_libgnu_la_SOURCES += mkdir.c + +## end gnulib module mkdir + +## begin gnulib module mkstemp + + +EXTRA_DIST += mkstemp.c + +EXTRA_libgnu_la_SOURCES += mkstemp.c + +## end gnulib module mkstemp + ## begin gnulib module msvc-inval @@ -1701,6 +1730,15 @@ EXTRA_DIST += same-inode.h ## end gnulib module same-inode +## begin gnulib module secure_getenv + + +EXTRA_DIST += secure_getenv.c + +EXTRA_libgnu_la_SOURCES += secure_getenv.c + +## end gnulib module secure_getenv + ## begin gnulib module select @@ -2318,6 +2356,15 @@ EXTRA_DIST += stdlib.in.h ## end gnulib module stdlib +## begin gnulib module strdup-posix + + +EXTRA_DIST += strdup.c + +EXTRA_libgnu_la_SOURCES += strdup.c + +## end gnulib module strdup-posix + ## begin gnulib module streq @@ -2737,13 +2784,13 @@ EXTRA_DIST += sys_uio.in.h ## end gnulib module sys_uio -## begin gnulib module threadlib +## begin gnulib module tempname -libgnu_la_SOURCES += glthread/threadlib.c +libgnu_la_SOURCES += tempname.c -EXTRA_DIST += $(top_srcdir)/build-aux/config.rpath +EXTRA_DIST += tempname.h -## end gnulib module threadlib +## end gnulib module tempname ## begin gnulib module time diff --git a/lib/fsync.c b/lib/fsync.c new file mode 100644 index 000000000..99475ff65 --- /dev/null +++ b/lib/fsync.c @@ -0,0 +1,83 @@ +/* Emulate fsync on platforms that lack it, primarily Windows and + cross-compilers like MinGW. + + This is derived from sqlite3 sources. + http://www.sqlite.org/cvstrac/rlog?f=sqlite/src/os_win.c + http://www.sqlite.org/copyright.html + + Written by Richard W.M. Jones <rjones.at.redhat.com> + + Copyright (C) 2008-2014 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 2.1 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 program. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> +#include <unistd.h> + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +/* FlushFileBuffers */ +# define WIN32_LEAN_AND_MEAN +# include <windows.h> + +# include <errno.h> + +/* Get _get_osfhandle. */ +# include "msvc-nothrow.h" + +int +fsync (int fd) +{ + HANDLE h = (HANDLE) _get_osfhandle (fd); + DWORD err; + + if (h == INVALID_HANDLE_VALUE) + { + errno = EBADF; + return -1; + } + + if (!FlushFileBuffers (h)) + { + /* Translate some Windows errors into rough approximations of Unix + * errors. MSDN is useless as usual - in this case it doesn't + * document the full range of errors. + */ + err = GetLastError (); + switch (err) + { + case ERROR_ACCESS_DENIED: + /* For a read-only handle, fsync should succeed, even though we have + no way to sync the access-time changes. */ + return 0; + + /* eg. Trying to fsync a tty. */ + case ERROR_INVALID_HANDLE: + errno = EINVAL; + break; + + default: + errno = EIO; + } + return -1; + } + + return 0; +} + +#else /* !Windows */ + +# error "This platform lacks fsync function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib." + +#endif /* !Windows */ diff --git a/lib/glthread/lock.c b/lib/glthread/lock.c deleted file mode 100644 index 0454cc251..000000000 --- a/lib/glthread/lock.c +++ /dev/null @@ -1,1057 +0,0 @@ -/* Locking in multithreaded situations. - Copyright (C) 2005-2014 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 Bruno Haible <bruno@clisp.org>, 2005. - Based on GCC's gthr-posix.h, gthr-posix95.h, gthr-solaris.h, - gthr-win32.h. */ - -#include <config.h> - -#include "glthread/lock.h" - -/* ========================================================================= */ - -#if USE_POSIX_THREADS - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -# if HAVE_PTHREAD_RWLOCK - -# if !defined PTHREAD_RWLOCK_INITIALIZER - -int -glthread_rwlock_init_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_rwlock_init (&lock->rwlock, NULL); - if (err != 0) - return err; - lock->initialized = 1; - return 0; -} - -int -glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock) -{ - if (!lock->initialized) - { - int err; - - err = pthread_mutex_lock (&lock->guard); - if (err != 0) - return err; - if (!lock->initialized) - { - err = glthread_rwlock_init_multithreaded (lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->guard); - return err; - } - } - err = pthread_mutex_unlock (&lock->guard); - if (err != 0) - return err; - } - return pthread_rwlock_rdlock (&lock->rwlock); -} - -int -glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock) -{ - if (!lock->initialized) - { - int err; - - err = pthread_mutex_lock (&lock->guard); - if (err != 0) - return err; - if (!lock->initialized) - { - err = glthread_rwlock_init_multithreaded (lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->guard); - return err; - } - } - err = pthread_mutex_unlock (&lock->guard); - if (err != 0) - return err; - } - return pthread_rwlock_wrlock (&lock->rwlock); -} - -int -glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock) -{ - if (!lock->initialized) - return EINVAL; - return pthread_rwlock_unlock (&lock->rwlock); -} - -int -glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock) -{ - int err; - - if (!lock->initialized) - return EINVAL; - err = pthread_rwlock_destroy (&lock->rwlock); - if (err != 0) - return err; - lock->initialized = 0; - return 0; -} - -# endif - -# else - -int -glthread_rwlock_init_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_init (&lock->lock, NULL); - if (err != 0) - return err; - err = pthread_cond_init (&lock->waiting_readers, NULL); - if (err != 0) - return err; - err = pthread_cond_init (&lock->waiting_writers, NULL); - if (err != 0) - return err; - lock->waiting_writers_count = 0; - lock->runcount = 0; - return 0; -} - -int -glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_lock (&lock->lock); - if (err != 0) - return err; - /* Test whether only readers are currently running, and whether the runcount - field will not overflow. */ - /* POSIX says: "It is implementation-defined whether the calling thread - acquires the lock when a writer does not hold the lock and there are - writers blocked on the lock." Let's say, no: give the writers a higher - priority. */ - while (!(lock->runcount + 1 > 0 && lock->waiting_writers_count == 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_readers. */ - err = pthread_cond_wait (&lock->waiting_readers, &lock->lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->lock); - return err; - } - } - lock->runcount++; - return pthread_mutex_unlock (&lock->lock); -} - -int -glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_lock (&lock->lock); - if (err != 0) - return err; - /* Test whether no readers or writers are currently running. */ - while (!(lock->runcount == 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_writers. */ - lock->waiting_writers_count++; - err = pthread_cond_wait (&lock->waiting_writers, &lock->lock); - if (err != 0) - { - lock->waiting_writers_count--; - pthread_mutex_unlock (&lock->lock); - return err; - } - lock->waiting_writers_count--; - } - lock->runcount--; /* runcount becomes -1 */ - return pthread_mutex_unlock (&lock->lock); -} - -int -glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_lock (&lock->lock); - if (err != 0) - return err; - if (lock->runcount < 0) - { - /* Drop a writer lock. */ - if (!(lock->runcount == -1)) - { - pthread_mutex_unlock (&lock->lock); - return EINVAL; - } - lock->runcount = 0; - } - else - { - /* Drop a reader lock. */ - if (!(lock->runcount > 0)) - { - pthread_mutex_unlock (&lock->lock); - return EINVAL; - } - lock->runcount--; - } - if (lock->runcount == 0) - { - /* POSIX recommends that "write locks shall take precedence over read - locks", to avoid "writer starvation". */ - if (lock->waiting_writers_count > 0) - { - /* Wake up one of the waiting writers. */ - err = pthread_cond_signal (&lock->waiting_writers); - if (err != 0) - { - pthread_mutex_unlock (&lock->lock); - return err; - } - } - else - { - /* Wake up all waiting readers. */ - err = pthread_cond_broadcast (&lock->waiting_readers); - if (err != 0) - { - pthread_mutex_unlock (&lock->lock); - return err; - } - } - } - return pthread_mutex_unlock (&lock->lock); -} - -int -glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_destroy (&lock->lock); - if (err != 0) - return err; - err = pthread_cond_destroy (&lock->waiting_readers); - if (err != 0) - return err; - err = pthread_cond_destroy (&lock->waiting_writers); - if (err != 0) - return err; - return 0; -} - -# endif - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -# if HAVE_PTHREAD_MUTEX_RECURSIVE - -# if defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER || defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - pthread_mutexattr_t attributes; - int err; - - err = pthread_mutexattr_init (&attributes); - if (err != 0) - return err; - err = pthread_mutexattr_settype (&attributes, PTHREAD_MUTEX_RECURSIVE); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutex_init (lock, &attributes); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutexattr_destroy (&attributes); - if (err != 0) - return err; - return 0; -} - -# else - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - pthread_mutexattr_t attributes; - int err; - - err = pthread_mutexattr_init (&attributes); - if (err != 0) - return err; - err = pthread_mutexattr_settype (&attributes, PTHREAD_MUTEX_RECURSIVE); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutex_init (&lock->recmutex, &attributes); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutexattr_destroy (&attributes); - if (err != 0) - return err; - lock->initialized = 1; - return 0; -} - -int -glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock) -{ - if (!lock->initialized) - { - int err; - - err = pthread_mutex_lock (&lock->guard); - if (err != 0) - return err; - if (!lock->initialized) - { - err = glthread_recursive_lock_init_multithreaded (lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->guard); - return err; - } - } - err = pthread_mutex_unlock (&lock->guard); - if (err != 0) - return err; - } - return pthread_mutex_lock (&lock->recmutex); -} - -int -glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock) -{ - if (!lock->initialized) - return EINVAL; - return pthread_mutex_unlock (&lock->recmutex); -} - -int -glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock) -{ - int err; - - if (!lock->initialized) - return EINVAL; - err = pthread_mutex_destroy (&lock->recmutex); - if (err != 0) - return err; - lock->initialized = 0; - return 0; -} - -# endif - -# else - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - int err; - - err = pthread_mutex_init (&lock->mutex, NULL); - if (err != 0) - return err; - lock->owner = (pthread_t) 0; - lock->depth = 0; - return 0; -} - -int -glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock) -{ - pthread_t self = pthread_self (); - if (lock->owner != self) - { - int err; - - err = pthread_mutex_lock (&lock->mutex); - if (err != 0) - return err; - lock->owner = self; - } - if (++(lock->depth) == 0) /* wraparound? */ - { - lock->depth--; - return EAGAIN; - } - return 0; -} - -int -glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != pthread_self ()) - return EPERM; - if (lock->depth == 0) - return EINVAL; - if (--(lock->depth) == 0) - { - lock->owner = (pthread_t) 0; - return pthread_mutex_unlock (&lock->mutex); - } - else - return 0; -} - -int -glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != (pthread_t) 0) - return EBUSY; - return pthread_mutex_destroy (&lock->mutex); -} - -# endif - -/* -------------------------- gl_once_t datatype -------------------------- */ - -static const pthread_once_t fresh_once = PTHREAD_ONCE_INIT; - -int -glthread_once_singlethreaded (pthread_once_t *once_control) -{ - /* We don't know whether pthread_once_t is an integer type, a floating-point - type, a pointer type, or a structure type. */ - char *firstbyte = (char *)once_control; - if (*firstbyte == *(const char *)&fresh_once) - { - /* First time use of once_control. Invert the first byte. */ - *firstbyte = ~ *(const char *)&fresh_once; - return 1; - } - else - return 0; -} - -#endif - -/* ========================================================================= */ - -#if USE_PTH_THREADS - -/* Use the GNU Pth threads library. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* -------------------------- gl_once_t datatype -------------------------- */ - -static void -glthread_once_call (void *arg) -{ - void (**gl_once_temp_addr) (void) = (void (**) (void)) arg; - void (*initfunction) (void) = *gl_once_temp_addr; - initfunction (); -} - -int -glthread_once_multithreaded (pth_once_t *once_control, void (*initfunction) (void)) -{ - void (*temp) (void) = initfunction; - return (!pth_once (once_control, glthread_once_call, &temp) ? errno : 0); -} - -int -glthread_once_singlethreaded (pth_once_t *once_control) -{ - /* We know that pth_once_t is an integer type. */ - if (*once_control == PTH_ONCE_INIT) - { - /* First time use of once_control. Invert the marker. */ - *once_control = ~ PTH_ONCE_INIT; - return 1; - } - else - return 0; -} - -#endif - -/* ========================================================================= */ - -#if USE_SOLARIS_THREADS - -/* Use the old Solaris threads library. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - int err; - - err = mutex_init (&lock->mutex, USYNC_THREAD, NULL); - if (err != 0) - return err; - lock->owner = (thread_t) 0; - lock->depth = 0; - return 0; -} - -int -glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock) -{ - thread_t self = thr_self (); - if (lock->owner != self) - { - int err; - - err = mutex_lock (&lock->mutex); - if (err != 0) - return err; - lock->owner = self; - } - if (++(lock->depth) == 0) /* wraparound? */ - { - lock->depth--; - return EAGAIN; - } - return 0; -} - -int -glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != thr_self ()) - return EPERM; - if (lock->depth == 0) - return EINVAL; - if (--(lock->depth) == 0) - { - lock->owner = (thread_t) 0; - return mutex_unlock (&lock->mutex); - } - else - return 0; -} - -int -glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != (thread_t) 0) - return EBUSY; - return mutex_destroy (&lock->mutex); -} - -/* -------------------------- gl_once_t datatype -------------------------- */ - -int -glthread_once_multithreaded (gl_once_t *once_control, void (*initfunction) (void)) -{ - if (!once_control->inited) - { - int err; - - /* Use the mutex to guarantee that if another thread is already calling - the initfunction, this thread waits until it's finished. */ - err = mutex_lock (&once_control->mutex); - if (err != 0) - return err; - if (!once_control->inited) - { - once_control->inited = 1; - initfunction (); - } - return mutex_unlock (&once_control->mutex); - } - else - return 0; -} - -int -glthread_once_singlethreaded (gl_once_t *once_control) -{ - /* We know that gl_once_t contains an integer type. */ - if (!once_control->inited) - { - /* First time use of once_control. Invert the marker. */ - once_control->inited = ~ 0; - return 1; - } - else - return 0; -} - -#endif - -/* ========================================================================= */ - -#if USE_WINDOWS_THREADS - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -void -glthread_lock_init_func (gl_lock_t *lock) -{ - InitializeCriticalSection (&lock->lock); - lock->guard.done = 1; -} - -int -glthread_lock_lock_func (gl_lock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_lock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - EnterCriticalSection (&lock->lock); - return 0; -} - -int -glthread_lock_unlock_func (gl_lock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_lock_destroy_func (gl_lock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - DeleteCriticalSection (&lock->lock); - lock->guard.done = 0; - return 0; -} - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* In this file, the waitqueues are implemented as circular arrays. */ -#define gl_waitqueue_t gl_carray_waitqueue_t - -static void -gl_waitqueue_init (gl_waitqueue_t *wq) -{ - wq->array = NULL; - wq->count = 0; - wq->alloc = 0; - wq->offset = 0; -} - -/* Enqueues the current thread, represented by an event, in a wait queue. - Returns INVALID_HANDLE_VALUE if an allocation failure occurs. */ -static HANDLE -gl_waitqueue_add (gl_waitqueue_t *wq) -{ - HANDLE event; - unsigned int index; - - if (wq->count == wq->alloc) - { - unsigned int new_alloc = 2 * wq->alloc + 1; - HANDLE *new_array = - (HANDLE *) realloc (wq->array, new_alloc * sizeof (HANDLE)); - if (new_array == NULL) - /* No more memory. */ - return INVALID_HANDLE_VALUE; - /* Now is a good opportunity to rotate the array so that its contents - starts at offset 0. */ - if (wq->offset > 0) - { - unsigned int old_count = wq->count; - unsigned int old_alloc = wq->alloc; - unsigned int old_offset = wq->offset; - unsigned int i; - if (old_offset + old_count > old_alloc) - { - unsigned int limit = old_offset + old_count - old_alloc; - for (i = 0; i < limit; i++) - new_array[old_alloc + i] = new_array[i]; - } - for (i = 0; i < old_count; i++) - new_array[i] = new_array[old_offset + i]; - wq->offset = 0; - } - wq->array = new_array; - wq->alloc = new_alloc; - } - /* Whether the created event is a manual-reset one or an auto-reset one, - does not matter, since we will wait on it only once. */ - event = CreateEvent (NULL, TRUE, FALSE, NULL); - if (event == INVALID_HANDLE_VALUE) - /* No way to allocate an event. */ - return INVALID_HANDLE_VALUE; - index = wq->offset + wq->count; - if (index >= wq->alloc) - index -= wq->alloc; - wq->array[index] = event; - wq->count++; - return event; -} - -/* Notifies the first thread from a wait queue and dequeues it. */ -static void -gl_waitqueue_notify_first (gl_waitqueue_t *wq) -{ - SetEvent (wq->array[wq->offset + 0]); - wq->offset++; - wq->count--; - if (wq->count == 0 || wq->offset == wq->alloc) - wq->offset = 0; -} - -/* Notifies all threads from a wait queue and dequeues them all. */ -static void -gl_waitqueue_notify_all (gl_waitqueue_t *wq) -{ - unsigned int i; - - for (i = 0; i < wq->count; i++) - { - unsigned int index = wq->offset + i; - if (index >= wq->alloc) - index -= wq->alloc; - SetEvent (wq->array[index]); - } - wq->count = 0; - wq->offset = 0; -} - -void -glthread_rwlock_init_func (gl_rwlock_t *lock) -{ - InitializeCriticalSection (&lock->lock); - gl_waitqueue_init (&lock->waiting_readers); - gl_waitqueue_init (&lock->waiting_writers); - lock->runcount = 0; - lock->guard.done = 1; -} - -int -glthread_rwlock_rdlock_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_rwlock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - EnterCriticalSection (&lock->lock); - /* Test whether only readers are currently running, and whether the runcount - field will not overflow. */ - if (!(lock->runcount + 1 > 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_readers. */ - HANDLE event = gl_waitqueue_add (&lock->waiting_readers); - if (event != INVALID_HANDLE_VALUE) - { - DWORD result; - LeaveCriticalSection (&lock->lock); - /* Wait until another thread signals this event. */ - result = WaitForSingleObject (event, INFINITE); - if (result == WAIT_FAILED || result == WAIT_TIMEOUT) - abort (); - CloseHandle (event); - /* The thread which signalled the event already did the bookkeeping: - removed us from the waiting_readers, incremented lock->runcount. */ - if (!(lock->runcount > 0)) - abort (); - return 0; - } - else - { - /* Allocation failure. Weird. */ - do - { - LeaveCriticalSection (&lock->lock); - Sleep (1); - EnterCriticalSection (&lock->lock); - } - while (!(lock->runcount + 1 > 0)); - } - } - lock->runcount++; - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_rwlock_wrlock_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_rwlock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - EnterCriticalSection (&lock->lock); - /* Test whether no readers or writers are currently running. */ - if (!(lock->runcount == 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_writers. */ - HANDLE event = gl_waitqueue_add (&lock->waiting_writers); - if (event != INVALID_HANDLE_VALUE) - { - DWORD result; - LeaveCriticalSection (&lock->lock); - /* Wait until another thread signals this event. */ - result = WaitForSingleObject (event, INFINITE); - if (result == WAIT_FAILED || result == WAIT_TIMEOUT) - abort (); - CloseHandle (event); - /* The thread which signalled the event already did the bookkeeping: - removed us from the waiting_writers, set lock->runcount = -1. */ - if (!(lock->runcount == -1)) - abort (); - return 0; - } - else - { - /* Allocation failure. Weird. */ - do - { - LeaveCriticalSection (&lock->lock); - Sleep (1); - EnterCriticalSection (&lock->lock); - } - while (!(lock->runcount == 0)); - } - } - lock->runcount--; /* runcount becomes -1 */ - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_rwlock_unlock_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - EnterCriticalSection (&lock->lock); - if (lock->runcount < 0) - { - /* Drop a writer lock. */ - if (!(lock->runcount == -1)) - abort (); - lock->runcount = 0; - } - else - { - /* Drop a reader lock. */ - if (!(lock->runcount > 0)) - { - LeaveCriticalSection (&lock->lock); - return EPERM; - } - lock->runcount--; - } - if (lock->runcount == 0) - { - /* POSIX recommends that "write locks shall take precedence over read - locks", to avoid "writer starvation". */ - if (lock->waiting_writers.count > 0) - { - /* Wake up one of the waiting writers. */ - lock->runcount--; - gl_waitqueue_notify_first (&lock->waiting_writers); - } - else - { - /* Wake up all waiting readers. */ - lock->runcount += lock->waiting_readers.count; - gl_waitqueue_notify_all (&lock->waiting_readers); - } - } - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_rwlock_destroy_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - if (lock->runcount != 0) - return EBUSY; - DeleteCriticalSection (&lock->lock); - if (lock->waiting_readers.array != NULL) - free (lock->waiting_readers.array); - if (lock->waiting_writers.array != NULL) - free (lock->waiting_writers.array); - lock->guard.done = 0; - return 0; -} - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -void -glthread_recursive_lock_init_func (gl_recursive_lock_t *lock) -{ - lock->owner = 0; - lock->depth = 0; - InitializeCriticalSection (&lock->lock); - lock->guard.done = 1; -} - -int -glthread_recursive_lock_lock_func (gl_recursive_lock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_recursive_lock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - { - DWORD self = GetCurrentThreadId (); - if (lock->owner != self) - { - EnterCriticalSection (&lock->lock); - lock->owner = self; - } - if (++(lock->depth) == 0) /* wraparound? */ - { - lock->depth--; - return EAGAIN; - } - } - return 0; -} - -int -glthread_recursive_lock_unlock_func (gl_recursive_lock_t *lock) -{ - if (lock->owner != GetCurrentThreadId ()) - return EPERM; - if (lock->depth == 0) - return EINVAL; - if (--(lock->depth) == 0) - { - lock->owner = 0; - LeaveCriticalSection (&lock->lock); - } - return 0; -} - -int -glthread_recursive_lock_destroy_func (gl_recursive_lock_t *lock) -{ - if (lock->owner != 0) - return EBUSY; - DeleteCriticalSection (&lock->lock); - lock->guard.done = 0; - return 0; -} - -/* -------------------------- gl_once_t datatype -------------------------- */ - -void -glthread_once_func (gl_once_t *once_control, void (*initfunction) (void)) -{ - if (once_control->inited <= 0) - { - if (InterlockedIncrement (&once_control->started) == 0) - { - /* This thread is the first one to come to this once_control. */ - InitializeCriticalSection (&once_control->lock); - EnterCriticalSection (&once_control->lock); - once_control->inited = 0; - initfunction (); - once_control->inited = 1; - LeaveCriticalSection (&once_control->lock); - } - else - { - /* Undo last operation. */ - InterlockedDecrement (&once_control->started); - /* Some other thread has already started the initialization. - Yield the CPU while waiting for the other thread to finish - initializing and taking the lock. */ - while (once_control->inited < 0) - Sleep (0); - if (once_control->inited <= 0) - { - /* Take the lock. This blocks until the other thread has - finished calling the initfunction. */ - EnterCriticalSection (&once_control->lock); - LeaveCriticalSection (&once_control->lock); - if (!(once_control->inited > 0)) - abort (); - } - } - } -} - -#endif - -/* ========================================================================= */ diff --git a/lib/glthread/lock.h b/lib/glthread/lock.h index 894b1fbaa..66c78a6cd 100644 --- a/lib/glthread/lock.h +++ b/lib/glthread/lock.h @@ -1,927 +1,38 @@ -/* Locking in multithreaded situations. - Copyright (C) 2005-2014 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 Bruno Haible <bruno@clisp.org>, 2005. - Based on GCC's gthr-posix.h, gthr-posix95.h, gthr-solaris.h, - gthr-win32.h. */ - -/* This file contains locking primitives for use with a given thread library. - It does not contain primitives for creating threads or for other - synchronization primitives. - - Normal (non-recursive) locks: - Type: gl_lock_t - Declaration: gl_lock_define(extern, name) - Initializer: gl_lock_define_initialized(, name) - Initialization: gl_lock_init (name); - Taking the lock: gl_lock_lock (name); - Releasing the lock: gl_lock_unlock (name); - De-initialization: gl_lock_destroy (name); - Equivalent functions with control of error handling: - Initialization: err = glthread_lock_init (&name); - Taking the lock: err = glthread_lock_lock (&name); - Releasing the lock: err = glthread_lock_unlock (&name); - De-initialization: err = glthread_lock_destroy (&name); - - Read-Write (non-recursive) locks: - Type: gl_rwlock_t - Declaration: gl_rwlock_define(extern, name) - Initializer: gl_rwlock_define_initialized(, name) - Initialization: gl_rwlock_init (name); - Taking the lock: gl_rwlock_rdlock (name); - gl_rwlock_wrlock (name); - Releasing the lock: gl_rwlock_unlock (name); - De-initialization: gl_rwlock_destroy (name); - Equivalent functions with control of error handling: - Initialization: err = glthread_rwlock_init (&name); - Taking the lock: err = glthread_rwlock_rdlock (&name); - err = glthread_rwlock_wrlock (&name); - Releasing the lock: err = glthread_rwlock_unlock (&name); - De-initialization: err = glthread_rwlock_destroy (&name); - - Recursive locks: - Type: gl_recursive_lock_t - Declaration: gl_recursive_lock_define(extern, name) - Initializer: gl_recursive_lock_define_initialized(, name) - Initialization: gl_recursive_lock_init (name); - Taking the lock: gl_recursive_lock_lock (name); - Releasing the lock: gl_recursive_lock_unlock (name); - De-initialization: gl_recursive_lock_destroy (name); - Equivalent functions with control of error handling: - Initialization: err = glthread_recursive_lock_init (&name); - Taking the lock: err = glthread_recursive_lock_lock (&name); - Releasing the lock: err = glthread_recursive_lock_unlock (&name); - De-initialization: err = glthread_recursive_lock_destroy (&name); - - Once-only execution: - Type: gl_once_t - Initializer: gl_once_define(extern, name) - Execution: gl_once (name, initfunction); - Equivalent functions with control of error handling: - Execution: err = glthread_once (&name, initfunction); -*/ - - -#ifndef _LOCK_H -#define _LOCK_H - -#include <errno.h> +#ifndef SCM_GLTHREADS_H +#define SCM_GLTHREADS_H + +/* Copyright (C) 2014 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 + */ + +/* This file implements Gnulib's glthreads/lock.h interface in terms of + Guile's locking API. This allows Gnulib modules such as 'regex' to + be built with thread-safety support via Guile's locks (see + <http://bugs.gnu.org/14404>.) */ + +#include <libguile/threads.h> #include <stdlib.h> -/* ========================================================================= */ - -#if USE_POSIX_THREADS - -/* Use the POSIX threads library. */ - -# include <pthread.h> - -# ifdef __cplusplus -extern "C" { -# endif - -# if PTHREAD_IN_USE_DETECTION_HARD - -/* The pthread_in_use() detection needs to be done at runtime. */ -# define pthread_in_use() \ - glthread_in_use () -extern int glthread_in_use (void); - -# endif - -# if USE_POSIX_THREADS_WEAK - -/* Use weak references to the POSIX threads library. */ - -/* Weak references avoid dragging in external libraries if the other parts - of the program don't use them. Here we use them, because we don't want - every program that uses libintl to depend on libpthread. This assumes - that libpthread would not be loaded after libintl; i.e. if libintl is - loaded first, by an executable that does not depend on libpthread, and - then a module is dynamically loaded that depends on libpthread, libintl - will not be multithread-safe. */ - -/* The way to test at runtime whether libpthread is present is to test - whether a function pointer's value, such as &pthread_mutex_init, is - non-NULL. However, some versions of GCC have a bug through which, in - PIC mode, &foo != NULL always evaluates to true if there is a direct - call to foo(...) in the same function. To avoid this, we test the - address of a function in libpthread that we don't use. */ - -# pragma weak pthread_mutex_init -# pragma weak pthread_mutex_lock -# pragma weak pthread_mutex_unlock -# pragma weak pthread_mutex_destroy -# pragma weak pthread_rwlock_init -# pragma weak pthread_rwlock_rdlock -# pragma weak pthread_rwlock_wrlock -# pragma weak pthread_rwlock_unlock -# pragma weak pthread_rwlock_destroy -# pragma weak pthread_once -# pragma weak pthread_cond_init -# pragma weak pthread_cond_wait -# pragma weak pthread_cond_signal -# pragma weak pthread_cond_broadcast -# pragma weak pthread_cond_destroy -# pragma weak pthread_mutexattr_init -# pragma weak pthread_mutexattr_settype -# pragma weak pthread_mutexattr_destroy -# ifndef pthread_self -# pragma weak pthread_self -# endif - -# if !PTHREAD_IN_USE_DETECTION_HARD -# pragma weak pthread_cancel -# define pthread_in_use() (pthread_cancel != NULL) -# endif - -# else - -# if !PTHREAD_IN_USE_DETECTION_HARD -# define pthread_in_use() 1 -# endif - -# endif - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef pthread_mutex_t gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - PTHREAD_MUTEX_INITIALIZER -# define glthread_lock_init(LOCK) \ - (pthread_in_use () ? pthread_mutex_init (LOCK, NULL) : 0) -# define glthread_lock_lock(LOCK) \ - (pthread_in_use () ? pthread_mutex_lock (LOCK) : 0) -# define glthread_lock_unlock(LOCK) \ - (pthread_in_use () ? pthread_mutex_unlock (LOCK) : 0) -# define glthread_lock_destroy(LOCK) \ - (pthread_in_use () ? pthread_mutex_destroy (LOCK) : 0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -# if HAVE_PTHREAD_RWLOCK - -# ifdef PTHREAD_RWLOCK_INITIALIZER - -typedef pthread_rwlock_t gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pthread_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - PTHREAD_RWLOCK_INITIALIZER -# define glthread_rwlock_init(LOCK) \ - (pthread_in_use () ? pthread_rwlock_init (LOCK, NULL) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pthread_in_use () ? pthread_rwlock_rdlock (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pthread_in_use () ? pthread_rwlock_wrlock (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pthread_in_use () ? pthread_rwlock_unlock (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (pthread_in_use () ? pthread_rwlock_destroy (LOCK) : 0) - -# else - -typedef struct - { - int initialized; - pthread_mutex_t guard; /* protects the initialization */ - pthread_rwlock_t rwlock; /* read-write lock */ - } - gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - { 0, PTHREAD_MUTEX_INITIALIZER } -# define glthread_rwlock_init(LOCK) \ - (pthread_in_use () ? glthread_rwlock_init_multithreaded (LOCK) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_rdlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_wrlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_unlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (pthread_in_use () ? glthread_rwlock_destroy_multithreaded (LOCK) : 0) -extern int glthread_rwlock_init_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock); - -# endif +#define gl_lock_define(klass, name) \ + klass scm_i_pthread_mutex_t name; -# else - -typedef struct - { - pthread_mutex_t lock; /* protects the remaining fields */ - pthread_cond_t waiting_readers; /* waiting readers */ - pthread_cond_t waiting_writers; /* waiting writers */ - unsigned int waiting_writers_count; /* number of waiting writers */ - int runcount; /* number of readers running, or -1 when a writer runs */ - } - gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - { PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER, PTHREAD_COND_INITIALIZER, 0, 0 } -# define glthread_rwlock_init(LOCK) \ - (pthread_in_use () ? glthread_rwlock_init_multithreaded (LOCK) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_rdlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_wrlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_unlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (pthread_in_use () ? glthread_rwlock_destroy_multithreaded (LOCK) : 0) -extern int glthread_rwlock_init_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock); - -# endif - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -# if HAVE_PTHREAD_MUTEX_RECURSIVE - -# if defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER || defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP - -typedef pthread_mutex_t gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME = gl_recursive_lock_initializer; -# ifdef PTHREAD_RECURSIVE_MUTEX_INITIALIZER -# define gl_recursive_lock_initializer \ - PTHREAD_RECURSIVE_MUTEX_INITIALIZER -# else -# define gl_recursive_lock_initializer \ - PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP -# endif -# define glthread_recursive_lock_init(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pthread_in_use () ? pthread_mutex_lock (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pthread_in_use () ? pthread_mutex_unlock (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (pthread_in_use () ? pthread_mutex_destroy (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); - -# else - -typedef struct - { - pthread_mutex_t recmutex; /* recursive mutex */ - pthread_mutex_t guard; /* protects the initialization */ - int initialized; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { PTHREAD_MUTEX_INITIALIZER, PTHREAD_MUTEX_INITIALIZER, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_lock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_unlock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_destroy_multithreaded (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock); - -# endif - -# else - -/* Old versions of POSIX threads on Solaris did not have recursive locks. - We have to implement them ourselves. */ - -typedef struct - { - pthread_mutex_t mutex; - pthread_t owner; - unsigned long depth; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { PTHREAD_MUTEX_INITIALIZER, (pthread_t) 0, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_lock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_unlock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_destroy_multithreaded (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock); - -# endif - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef pthread_once_t gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_once_t NAME = PTHREAD_ONCE_INIT; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (pthread_in_use () \ - ? pthread_once (ONCE_CONTROL, INITFUNCTION) \ - : (glthread_once_singlethreaded (ONCE_CONTROL) ? (INITFUNCTION (), 0) : 0)) -extern int glthread_once_singlethreaded (pthread_once_t *once_control); - -# ifdef __cplusplus -} -# endif +#define glthread_lock_init(lock) scm_i_pthread_mutex_init ((lock), NULL) +#define glthread_lock_destroy scm_i_pthread_mutex_destroy +#define glthread_lock_lock scm_i_pthread_mutex_lock +#define glthread_lock_unlock scm_i_pthread_mutex_unlock #endif - -/* ========================================================================= */ - -#if USE_PTH_THREADS - -/* Use the GNU Pth threads library. */ - -# include <pth.h> - -# ifdef __cplusplus -extern "C" { -# endif - -# if USE_PTH_THREADS_WEAK - -/* Use weak references to the GNU Pth threads library. */ - -# pragma weak pth_mutex_init -# pragma weak pth_mutex_acquire -# pragma weak pth_mutex_release -# pragma weak pth_rwlock_init -# pragma weak pth_rwlock_acquire -# pragma weak pth_rwlock_release -# pragma weak pth_once - -# pragma weak pth_cancel -# define pth_in_use() (pth_cancel != NULL) - -# else - -# define pth_in_use() 1 - -# endif - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef pth_mutex_t gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - PTH_MUTEX_INIT -# define glthread_lock_init(LOCK) \ - (pth_in_use () && !pth_mutex_init (LOCK) ? errno : 0) -# define glthread_lock_lock(LOCK) \ - (pth_in_use () && !pth_mutex_acquire (LOCK, 0, NULL) ? errno : 0) -# define glthread_lock_unlock(LOCK) \ - (pth_in_use () && !pth_mutex_release (LOCK) ? errno : 0) -# define glthread_lock_destroy(LOCK) \ - ((void)(LOCK), 0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -typedef pth_rwlock_t gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pth_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - PTH_RWLOCK_INIT -# define glthread_rwlock_init(LOCK) \ - (pth_in_use () && !pth_rwlock_init (LOCK) ? errno : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pth_in_use () && !pth_rwlock_acquire (LOCK, PTH_RWLOCK_RD, 0, NULL) ? errno : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pth_in_use () && !pth_rwlock_acquire (LOCK, PTH_RWLOCK_RW, 0, NULL) ? errno : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pth_in_use () && !pth_rwlock_release (LOCK) ? errno : 0) -# define glthread_rwlock_destroy(LOCK) \ - ((void)(LOCK), 0) - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* In Pth, mutexes are recursive by default. */ -typedef pth_mutex_t gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - PTH_MUTEX_INIT -# define glthread_recursive_lock_init(LOCK) \ - (pth_in_use () && !pth_mutex_init (LOCK) ? errno : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pth_in_use () && !pth_mutex_acquire (LOCK, 0, NULL) ? errno : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pth_in_use () && !pth_mutex_release (LOCK) ? errno : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - ((void)(LOCK), 0) - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef pth_once_t gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_once_t NAME = PTH_ONCE_INIT; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (pth_in_use () \ - ? glthread_once_multithreaded (ONCE_CONTROL, INITFUNCTION) \ - : (glthread_once_singlethreaded (ONCE_CONTROL) ? (INITFUNCTION (), 0) : 0)) -extern int glthread_once_multithreaded (pth_once_t *once_control, void (*initfunction) (void)); -extern int glthread_once_singlethreaded (pth_once_t *once_control); - -# ifdef __cplusplus -} -# endif - -#endif - -/* ========================================================================= */ - -#if USE_SOLARIS_THREADS - -/* Use the old Solaris threads library. */ - -# include <thread.h> -# include <synch.h> - -# ifdef __cplusplus -extern "C" { -# endif - -# if USE_SOLARIS_THREADS_WEAK - -/* Use weak references to the old Solaris threads library. */ - -# pragma weak mutex_init -# pragma weak mutex_lock -# pragma weak mutex_unlock -# pragma weak mutex_destroy -# pragma weak rwlock_init -# pragma weak rw_rdlock -# pragma weak rw_wrlock -# pragma weak rw_unlock -# pragma weak rwlock_destroy -# pragma weak thr_self - -# pragma weak thr_suspend -# define thread_in_use() (thr_suspend != NULL) - -# else - -# define thread_in_use() 1 - -# endif - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef mutex_t gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS mutex_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS mutex_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - DEFAULTMUTEX -# define glthread_lock_init(LOCK) \ - (thread_in_use () ? mutex_init (LOCK, USYNC_THREAD, NULL) : 0) -# define glthread_lock_lock(LOCK) \ - (thread_in_use () ? mutex_lock (LOCK) : 0) -# define glthread_lock_unlock(LOCK) \ - (thread_in_use () ? mutex_unlock (LOCK) : 0) -# define glthread_lock_destroy(LOCK) \ - (thread_in_use () ? mutex_destroy (LOCK) : 0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -typedef rwlock_t gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - DEFAULTRWLOCK -# define glthread_rwlock_init(LOCK) \ - (thread_in_use () ? rwlock_init (LOCK, USYNC_THREAD, NULL) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (thread_in_use () ? rw_rdlock (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (thread_in_use () ? rw_wrlock (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (thread_in_use () ? rw_unlock (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (thread_in_use () ? rwlock_destroy (LOCK) : 0) - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* Old Solaris threads did not have recursive locks. - We have to implement them ourselves. */ - -typedef struct - { - mutex_t mutex; - thread_t owner; - unsigned long depth; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { DEFAULTMUTEX, (thread_t) 0, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_lock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_unlock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_destroy_multithreaded (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock); - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef struct - { - volatile int inited; - mutex_t mutex; - } - gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_once_t NAME = { 0, DEFAULTMUTEX }; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (thread_in_use () \ - ? glthread_once_multithreaded (ONCE_CONTROL, INITFUNCTION) \ - : (glthread_once_singlethreaded (ONCE_CONTROL) ? (INITFUNCTION (), 0) : 0)) -extern int glthread_once_multithreaded (gl_once_t *once_control, void (*initfunction) (void)); -extern int glthread_once_singlethreaded (gl_once_t *once_control); - -# ifdef __cplusplus -} -# endif - -#endif - -/* ========================================================================= */ - -#if USE_WINDOWS_THREADS - -# define WIN32_LEAN_AND_MEAN /* avoid including junk */ -# include <windows.h> - -# ifdef __cplusplus -extern "C" { -# endif - -/* We can use CRITICAL_SECTION directly, rather than the native Windows Event, - Mutex, Semaphore types, because - - we need only to synchronize inside a single process (address space), - not inter-process locking, - - we don't need to support trylock operations. (TryEnterCriticalSection - does not work on Windows 95/98/ME. Packages that need trylock usually - define their own mutex type.) */ - -/* There is no way to statically initialize a CRITICAL_SECTION. It needs - to be done lazily, once only. For this we need spinlocks. */ - -typedef struct { volatile int done; volatile long started; } gl_spinlock_t; - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef struct - { - gl_spinlock_t guard; /* protects the initialization */ - CRITICAL_SECTION lock; - } - gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_lock_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_lock_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - { { 0, -1 } } -# define glthread_lock_init(LOCK) \ - (glthread_lock_init_func (LOCK), 0) -# define glthread_lock_lock(LOCK) \ - glthread_lock_lock_func (LOCK) -# define glthread_lock_unlock(LOCK) \ - glthread_lock_unlock_func (LOCK) -# define glthread_lock_destroy(LOCK) \ - glthread_lock_destroy_func (LOCK) -extern void glthread_lock_init_func (gl_lock_t *lock); -extern int glthread_lock_lock_func (gl_lock_t *lock); -extern int glthread_lock_unlock_func (gl_lock_t *lock); -extern int glthread_lock_destroy_func (gl_lock_t *lock); - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* It is impossible to implement read-write locks using plain locks, without - introducing an extra thread dedicated to managing read-write locks. - Therefore here we need to use the low-level Event type. */ - -typedef struct - { - HANDLE *array; /* array of waiting threads, each represented by an event */ - unsigned int count; /* number of waiting threads */ - unsigned int alloc; /* length of allocated array */ - unsigned int offset; /* index of first waiting thread in array */ - } - gl_carray_waitqueue_t; -typedef struct - { - gl_spinlock_t guard; /* protects the initialization */ - CRITICAL_SECTION lock; /* protects the remaining fields */ - gl_carray_waitqueue_t waiting_readers; /* waiting readers */ - gl_carray_waitqueue_t waiting_writers; /* waiting writers */ - int runcount; /* number of readers running, or -1 when a writer runs */ - } - gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - { { 0, -1 } } -# define glthread_rwlock_init(LOCK) \ - (glthread_rwlock_init_func (LOCK), 0) -# define glthread_rwlock_rdlock(LOCK) \ - glthread_rwlock_rdlock_func (LOCK) -# define glthread_rwlock_wrlock(LOCK) \ - glthread_rwlock_wrlock_func (LOCK) -# define glthread_rwlock_unlock(LOCK) \ - glthread_rwlock_unlock_func (LOCK) -# define glthread_rwlock_destroy(LOCK) \ - glthread_rwlock_destroy_func (LOCK) -extern void glthread_rwlock_init_func (gl_rwlock_t *lock); -extern int glthread_rwlock_rdlock_func (gl_rwlock_t *lock); -extern int glthread_rwlock_wrlock_func (gl_rwlock_t *lock); -extern int glthread_rwlock_unlock_func (gl_rwlock_t *lock); -extern int glthread_rwlock_destroy_func (gl_rwlock_t *lock); - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* The native Windows documentation says that CRITICAL_SECTION already - implements a recursive lock. But we need not rely on it: It's easy to - implement a recursive lock without this assumption. */ - -typedef struct - { - gl_spinlock_t guard; /* protects the initialization */ - DWORD owner; - unsigned long depth; - CRITICAL_SECTION lock; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { { 0, -1 }, 0, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (glthread_recursive_lock_init_func (LOCK), 0) -# define glthread_recursive_lock_lock(LOCK) \ - glthread_recursive_lock_lock_func (LOCK) -# define glthread_recursive_lock_unlock(LOCK) \ - glthread_recursive_lock_unlock_func (LOCK) -# define glthread_recursive_lock_destroy(LOCK) \ - glthread_recursive_lock_destroy_func (LOCK) -extern void glthread_recursive_lock_init_func (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_func (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_func (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_func (gl_recursive_lock_t *lock); - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef struct - { - volatile int inited; - volatile long started; - CRITICAL_SECTION lock; - } - gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_once_t NAME = { -1, -1 }; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (glthread_once_func (ONCE_CONTROL, INITFUNCTION), 0) -extern void glthread_once_func (gl_once_t *once_control, void (*initfunction) (void)); - -# ifdef __cplusplus -} -# endif - -#endif - -/* ========================================================================= */ - -#if !(USE_POSIX_THREADS || USE_PTH_THREADS || USE_SOLARIS_THREADS || USE_WINDOWS_THREADS) - -/* Provide dummy implementation if threads are not supported. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef int gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) -# define gl_lock_define_initialized(STORAGECLASS, NAME) -# define glthread_lock_init(NAME) 0 -# define glthread_lock_lock(NAME) 0 -# define glthread_lock_unlock(NAME) 0 -# define glthread_lock_destroy(NAME) 0 - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -typedef int gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) -# define glthread_rwlock_init(NAME) 0 -# define glthread_rwlock_rdlock(NAME) 0 -# define glthread_rwlock_wrlock(NAME) 0 -# define glthread_rwlock_unlock(NAME) 0 -# define glthread_rwlock_destroy(NAME) 0 - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -typedef int gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) -# define glthread_recursive_lock_init(NAME) 0 -# define glthread_recursive_lock_lock(NAME) 0 -# define glthread_recursive_lock_unlock(NAME) 0 -# define glthread_recursive_lock_destroy(NAME) 0 - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef int gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_once_t NAME = 0; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (*(ONCE_CONTROL) == 0 ? (*(ONCE_CONTROL) = ~ 0, INITFUNCTION (), 0) : 0) - -#endif - -/* ========================================================================= */ - -/* Macros with built-in error handling. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -#define gl_lock_init(NAME) \ - do \ - { \ - if (glthread_lock_init (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_lock_lock(NAME) \ - do \ - { \ - if (glthread_lock_lock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_lock_unlock(NAME) \ - do \ - { \ - if (glthread_lock_unlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_lock_destroy(NAME) \ - do \ - { \ - if (glthread_lock_destroy (&NAME)) \ - abort (); \ - } \ - while (0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -#define gl_rwlock_init(NAME) \ - do \ - { \ - if (glthread_rwlock_init (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_rdlock(NAME) \ - do \ - { \ - if (glthread_rwlock_rdlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_wrlock(NAME) \ - do \ - { \ - if (glthread_rwlock_wrlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_unlock(NAME) \ - do \ - { \ - if (glthread_rwlock_unlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_destroy(NAME) \ - do \ - { \ - if (glthread_rwlock_destroy (&NAME)) \ - abort (); \ - } \ - while (0) - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -#define gl_recursive_lock_init(NAME) \ - do \ - { \ - if (glthread_recursive_lock_init (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_recursive_lock_lock(NAME) \ - do \ - { \ - if (glthread_recursive_lock_lock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_recursive_lock_unlock(NAME) \ - do \ - { \ - if (glthread_recursive_lock_unlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_recursive_lock_destroy(NAME) \ - do \ - { \ - if (glthread_recursive_lock_destroy (&NAME)) \ - abort (); \ - } \ - while (0) - -/* -------------------------- gl_once_t datatype -------------------------- */ - -#define gl_once(NAME, INITFUNCTION) \ - do \ - { \ - if (glthread_once (&NAME, INITFUNCTION)) \ - abort (); \ - } \ - while (0) - -/* ========================================================================= */ - -#endif /* _LOCK_H */ diff --git a/lib/glthread/threadlib.c b/lib/glthread/threadlib.c deleted file mode 100644 index 37a5762d8..000000000 --- a/lib/glthread/threadlib.c +++ /dev/null @@ -1,73 +0,0 @@ -/* Multithreading primitives. - Copyright (C) 2005-2014 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 Bruno Haible <bruno@clisp.org>, 2005. */ - -#include <config.h> - -/* ========================================================================= */ - -#if USE_POSIX_THREADS - -/* Use the POSIX threads library. */ - -# include <pthread.h> -# include <stdlib.h> - -# if PTHREAD_IN_USE_DETECTION_HARD - -/* The function to be executed by a dummy thread. */ -static void * -dummy_thread_func (void *arg) -{ - return arg; -} - -int -glthread_in_use (void) -{ - static int tested; - static int result; /* 1: linked with -lpthread, 0: only with libc */ - - if (!tested) - { - pthread_t thread; - - if (pthread_create (&thread, NULL, dummy_thread_func, NULL) != 0) - /* Thread creation failed. */ - result = 0; - else - { - /* Thread creation works. */ - void *retval; - if (pthread_join (thread, &retval) != 0) - abort (); - result = 1; - } - tested = 1; - } - return result; -} - -# endif - -#endif - -/* ========================================================================= */ - -/* This declaration is solely to ensure that after preprocessing - this file is never empty. */ -typedef int dummy; diff --git a/lib/link.c b/lib/link.c new file mode 100644 index 000000000..9db1f8cef --- /dev/null +++ b/lib/link.c @@ -0,0 +1,211 @@ +/* Emulate link on platforms that lack it, namely native Windows platforms. + + Copyright (C) 2009-2014 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> + +#include <unistd.h> + +#include <errno.h> +#include <stdlib.h> +#include <string.h> +#include <sys/stat.h> + +#if !HAVE_LINK +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +# define WIN32_LEAN_AND_MEAN +# include <windows.h> + +/* CreateHardLink was introduced only in Windows 2000. */ +typedef BOOL (WINAPI * CreateHardLinkFuncType) (LPCTSTR lpFileName, + LPCTSTR lpExistingFileName, + LPSECURITY_ATTRIBUTES lpSecurityAttributes); +static CreateHardLinkFuncType CreateHardLinkFunc = NULL; +static BOOL initialized = FALSE; + +static void +initialize (void) +{ + HMODULE kernel32 = GetModuleHandle ("kernel32.dll"); + if (kernel32 != NULL) + { + CreateHardLinkFunc = + (CreateHardLinkFuncType) GetProcAddress (kernel32, "CreateHardLinkA"); + } + initialized = TRUE; +} + +int +link (const char *file1, const char *file2) +{ + char *dir; + size_t len1 = strlen (file1); + size_t len2 = strlen (file2); + if (!initialized) + initialize (); + if (CreateHardLinkFunc == NULL) + { + /* System does not support hard links. */ + errno = EPERM; + return -1; + } + /* Reject trailing slashes on non-directories; mingw does not + support hard-linking directories. */ + if ((len1 && (file1[len1 - 1] == '/' || file1[len1 - 1] == '\\')) + || (len2 && (file2[len2 - 1] == '/' || file2[len2 - 1] == '\\'))) + { + struct stat st; + if (stat (file1, &st) == 0 && S_ISDIR (st.st_mode)) + errno = EPERM; + else + errno = ENOTDIR; + return -1; + } + /* CreateHardLink("b/.","a",NULL) creates file "b", so we must check + that dirname(file2) exists. */ + dir = strdup (file2); + if (!dir) + return -1; + { + struct stat st; + char *p = strchr (dir, '\0'); + while (dir < p && (*--p != '/' && *p != '\\')); + *p = '\0'; + if (p != dir && stat (dir, &st) == -1) + { + int saved_errno = errno; + free (dir); + errno = saved_errno; + return -1; + } + free (dir); + } + /* Now create the link. */ + if (CreateHardLinkFunc (file2, file1, NULL) == 0) + { + /* It is not documented which errors CreateHardLink() can produce. + * The following conversions are based on tests on a Windows XP SP2 + * system. */ + DWORD err = GetLastError (); + switch (err) + { + case ERROR_ACCESS_DENIED: + errno = EACCES; + break; + + case ERROR_INVALID_FUNCTION: /* fs does not support hard links */ + errno = EPERM; + break; + + case ERROR_NOT_SAME_DEVICE: + errno = EXDEV; + break; + + case ERROR_PATH_NOT_FOUND: + case ERROR_FILE_NOT_FOUND: + errno = ENOENT; + break; + + case ERROR_INVALID_PARAMETER: + errno = ENAMETOOLONG; + break; + + case ERROR_TOO_MANY_LINKS: + errno = EMLINK; + break; + + case ERROR_ALREADY_EXISTS: + errno = EEXIST; + break; + + default: + errno = EIO; + } + return -1; + } + + return 0; +} + +# else /* !Windows */ + +# error "This platform lacks a link function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib." + +# endif /* !Windows */ +#else /* HAVE_LINK */ + +# undef link + +/* Create a hard link from FILE1 to FILE2, working around platform bugs. */ +int +rpl_link (char const *file1, char const *file2) +{ + size_t len1; + size_t len2; + struct stat st; + + /* Don't allow IRIX to dereference dangling file2 symlink. */ + if (!lstat (file2, &st)) + { + errno = EEXIST; + return -1; + } + + /* Reject trailing slashes on non-directories. */ + len1 = strlen (file1); + len2 = strlen (file2); + if ((len1 && file1[len1 - 1] == '/') + || (len2 && file2[len2 - 1] == '/')) + { + /* Let link() decide whether hard-linking directories is legal. + If stat() fails, then link() should fail for the same reason + (although on Solaris 9, link("file/","oops") mistakenly + succeeds); if stat() succeeds, require a directory. */ + if (stat (file1, &st)) + return -1; + if (!S_ISDIR (st.st_mode)) + { + errno = ENOTDIR; + return -1; + } + } + else + { + /* Fix Cygwin 1.5.x bug where link("a","b/.") creates file "b". */ + char *dir = strdup (file2); + char *p; + if (!dir) + return -1; + /* We already know file2 does not end in slash. Strip off the + basename, then check that the dirname exists. */ + p = strrchr (dir, '/'); + if (p) + { + *p = '\0'; + if (stat (dir, &st) == -1) + { + int saved_errno = errno; + free (dir); + errno = saved_errno; + return -1; + } + } + free (dir); + } + return link (file1, file2); +} +#endif /* HAVE_LINK */ diff --git a/lib/mkdir.c b/lib/mkdir.c new file mode 100644 index 000000000..f1b802b57 --- /dev/null +++ b/lib/mkdir.c @@ -0,0 +1,93 @@ +/* On some systems, mkdir ("foo/", 0700) fails because of the trailing + slash. On those systems, this wrapper removes the trailing slash. + + Copyright (C) 2001, 2003, 2006, 2008-2014 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 Jim Meyering */ + +#include <config.h> + +/* Specification. */ +#include <sys/stat.h> + +#include <errno.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include "dirname.h" + +/* Disable the definition of mkdir to rpl_mkdir (from the <sys/stat.h> + substitute) in this file. Otherwise, we'd get an endless recursion. */ +#undef mkdir + +/* mingw's _mkdir() function has 1 argument, but we pass 2 arguments. + Additionally, it declares _mkdir (and depending on compile flags, an + alias mkdir), only in the nonstandard includes <direct.h> and <io.h>, + which are included in the <sys/stat.h> override. */ +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +# define mkdir(name,mode) _mkdir (name) +# define maybe_unused _GL_UNUSED +#else +# define maybe_unused /* empty */ +#endif + +/* This function is required at least for NetBSD 1.5.2. */ + +int +rpl_mkdir (char const *dir, mode_t mode maybe_unused) +{ + int ret_val; + char *tmp_dir; + size_t len = strlen (dir); + + if (len && dir[len - 1] == '/') + { + tmp_dir = strdup (dir); + if (!tmp_dir) + { + /* Rather than rely on strdup-posix, we set errno ourselves. */ + errno = ENOMEM; + return -1; + } + strip_trailing_slashes (tmp_dir); + } + else + { + tmp_dir = (char *) dir; + } +#if FUNC_MKDIR_DOT_BUG + /* Additionally, cygwin 1.5 mistakenly creates a directory "d/./". */ + { + char *last = last_component (tmp_dir); + if (*last == '.' && (last[1] == '\0' + || (last[1] == '.' && last[2] == '\0'))) + { + struct stat st; + if (stat (tmp_dir, &st) == 0) + errno = EEXIST; + return -1; + } + } +#endif /* FUNC_MKDIR_DOT_BUG */ + + ret_val = mkdir (tmp_dir, mode); + + if (tmp_dir != dir) + free (tmp_dir); + + return ret_val; +} diff --git a/lib/mkstemp.c b/lib/mkstemp.c new file mode 100644 index 000000000..0af69f9c3 --- /dev/null +++ b/lib/mkstemp.c @@ -0,0 +1,50 @@ +/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2014 Free Software + Foundation, Inc. + This file is derived from the one in 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 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/>. */ + +#if !_LIBC +# include <config.h> +#endif + +#include <stdlib.h> + +#if !_LIBC +# include "tempname.h" +# define __gen_tempname gen_tempname +# ifndef __GT_FILE +# define __GT_FILE GT_FILE +# endif +#endif + +#include <stdio.h> + +#ifndef __GT_FILE +# define __GT_FILE 0 +#endif + +/* Generate a unique temporary file name from XTEMPLATE. + The last six characters of XTEMPLATE must be "XXXXXX"; + they are replaced with a string that makes the file name unique. + Then open the file and return a fd. + + If you are creating temporary files which will later be removed, + consider using the clean-temp module, which avoids several pitfalls + of using mkstemp directly. */ +int +mkstemp (char *xtemplate) +{ + return __gen_tempname (xtemplate, 0, 0, __GT_FILE); +} diff --git a/lib/secure_getenv.c b/lib/secure_getenv.c new file mode 100644 index 000000000..7b86173bb --- /dev/null +++ b/lib/secure_getenv.c @@ -0,0 +1,41 @@ +/* Look up an environment variable more securely. + + Copyright 2013-2014 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/>. */ + +#include <config.h> + +#include <stdlib.h> + +#if !HAVE___SECURE_GETENV +# if HAVE_ISSETUGID +# include <unistd.h> +# else +# undef issetugid +# define issetugid() 1 +# endif +#endif + +char * +secure_getenv (char const *name) +{ +#if HAVE___SECURE_GETENV + return __secure_getenv (name); +#else + if (issetugid ()) + return 0; + return getenv (name); +#endif +} diff --git a/lib/strdup.c b/lib/strdup.c new file mode 100644 index 000000000..bde582927 --- /dev/null +++ b/lib/strdup.c @@ -0,0 +1,54 @@ +/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2014 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. + + 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 _LIBC +# include <config.h> +#endif + +/* Get specification. */ +#include <string.h> + +#include <stdlib.h> + +#undef __strdup +#ifdef _LIBC +# undef strdup +#endif + +#ifndef weak_alias +# define __strdup strdup +#endif + +/* Duplicate S, returning an identical malloc'd string. */ +char * +__strdup (const char *s) +{ + size_t len = strlen (s) + 1; + void *new = malloc (len); + + if (new == NULL) + return NULL; + + return (char *) memcpy (new, s, len); +} +#ifdef libc_hidden_def +libc_hidden_def (__strdup) +#endif +#ifdef weak_alias +weak_alias (__strdup, strdup) +#endif diff --git a/lib/tempname.c b/lib/tempname.c new file mode 100644 index 000000000..f0f7e7f29 --- /dev/null +++ b/lib/tempname.c @@ -0,0 +1,306 @@ +/* tempname.c - generate the name of a temporary file. + + Copyright (C) 1991-2003, 2005-2007, 2009-2014 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/>. */ + +/* Extracted from glibc sysdeps/posix/tempname.c. See also tmpdir.c. */ + +#if !_LIBC +# include <config.h> +# include "tempname.h" +#endif + +#include <sys/types.h> +#include <assert.h> + +#include <errno.h> +#ifndef __set_errno +# define __set_errno(Val) errno = (Val) +#endif + +#include <stdio.h> +#ifndef P_tmpdir +# define P_tmpdir "/tmp" +#endif +#ifndef TMP_MAX +# define TMP_MAX 238328 +#endif +#ifndef __GT_FILE +# define __GT_FILE 0 +# define __GT_DIR 1 +# define __GT_NOCREATE 2 +#endif +#if !_LIBC && (GT_FILE != __GT_FILE || GT_DIR != __GT_DIR \ + || GT_NOCREATE != __GT_NOCREATE) +# error report this to bug-gnulib@gnu.org +#endif + +#include <stddef.h> +#include <stdlib.h> +#include <string.h> + +#include <fcntl.h> +#include <sys/time.h> +#include <stdint.h> +#include <unistd.h> + +#include <sys/stat.h> + +#if _LIBC +# define struct_stat64 struct stat64 +#else +# define struct_stat64 struct stat +# define __gen_tempname gen_tempname +# define __getpid getpid +# define __gettimeofday gettimeofday +# define __mkdir mkdir +# define __open open +# define __lxstat64(version, file, buf) lstat (file, buf) +# define __secure_getenv secure_getenv +#endif + +#ifdef _LIBC +# include <hp-timing.h> +# if HP_TIMING_AVAIL +# define RANDOM_BITS(Var) \ + if (__builtin_expect (value == UINT64_C (0), 0)) \ + { \ + /* If this is the first time this function is used initialize \ + the variable we accumulate the value in to some somewhat \ + random value. If we'd not do this programs at startup time \ + might have a reduced set of possible names, at least on slow \ + machines. */ \ + struct timeval tv; \ + __gettimeofday (&tv, NULL); \ + value = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; \ + } \ + HP_TIMING_NOW (Var) +# endif +#endif + +/* Use the widest available unsigned type if uint64_t is not + available. The algorithm below extracts a number less than 62**6 + (approximately 2**35.725) from uint64_t, so ancient hosts where + uintmax_t is only 32 bits lose about 3.725 bits of randomness, + which is better than not having mkstemp at all. */ +#if !defined UINT64_MAX && !defined uint64_t +# define uint64_t uintmax_t +#endif + +#if _LIBC +/* Return nonzero if DIR is an existent directory. */ +static int +direxists (const char *dir) +{ + struct_stat64 buf; + return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode); +} + +/* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is + non-null and exists, uses it; otherwise uses the first of $TMPDIR, + P_tmpdir, /tmp that exists. Copies into TMPL a template suitable + for use with mk[s]temp. Will fail (-1) if DIR is non-null and + doesn't exist, none of the searched dirs exists, or there's not + enough space in TMPL. */ +int +__path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx, + int try_tmpdir) +{ + const char *d; + size_t dlen, plen; + + if (!pfx || !pfx[0]) + { + pfx = "file"; + plen = 4; + } + else + { + plen = strlen (pfx); + if (plen > 5) + plen = 5; + } + + if (try_tmpdir) + { + d = __secure_getenv ("TMPDIR"); + if (d != NULL && direxists (d)) + dir = d; + else if (dir != NULL && direxists (dir)) + /* nothing */ ; + else + dir = NULL; + } + if (dir == NULL) + { + if (direxists (P_tmpdir)) + dir = P_tmpdir; + else if (strcmp (P_tmpdir, "/tmp") != 0 && direxists ("/tmp")) + dir = "/tmp"; + else + { + __set_errno (ENOENT); + return -1; + } + } + + dlen = strlen (dir); + while (dlen > 1 && dir[dlen - 1] == '/') + dlen--; /* remove trailing slashes */ + + /* check we have room for "${dir}/${pfx}XXXXXX\0" */ + if (tmpl_len < dlen + 1 + plen + 6 + 1) + { + __set_errno (EINVAL); + return -1; + } + + sprintf (tmpl, "%.*s/%.*sXXXXXX", (int) dlen, dir, (int) plen, pfx); + return 0; +} +#endif /* _LIBC */ + +/* These are the characters used in temporary file names. */ +static const char letters[] = +"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; + +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + __gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + __GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + __GT_FILE: create the file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + __GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +int +__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +{ + int len; + char *XXXXXX; + static uint64_t value; + uint64_t random_time_bits; + unsigned int count; + int fd = -1; + int save_errno = errno; + struct_stat64 st; + + /* A lower bound on the number of temporary files to attempt to + generate. The maximum total number of temporary file names that + can exist for a given template is 62**6. It should never be + necessary to try all of these combinations. Instead if a reasonable + number of names is tried (we define reasonable as 62**3) fail to + give the system administrator the chance to remove the problems. */ +#define ATTEMPTS_MIN (62 * 62 * 62) + + /* The number of times to attempt to generate a temporary file. To + conform to POSIX, this must be no smaller than TMP_MAX. */ +#if ATTEMPTS_MIN < TMP_MAX + unsigned int attempts = TMP_MAX; +#else + unsigned int attempts = ATTEMPTS_MIN; +#endif + + len = strlen (tmpl); + if (len < 6 + suffixlen || memcmp (&tmpl[len - 6 - suffixlen], "XXXXXX", 6)) + { + __set_errno (EINVAL); + return -1; + } + + /* This is where the Xs start. */ + XXXXXX = &tmpl[len - 6 - suffixlen]; + + /* Get some more or less random data. */ +#ifdef RANDOM_BITS + RANDOM_BITS (random_time_bits); +#else + { + struct timeval tv; + __gettimeofday (&tv, NULL); + random_time_bits = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; + } +#endif + value += random_time_bits ^ __getpid (); + + for (count = 0; count < attempts; value += 7777, ++count) + { + uint64_t v = value; + + /* Fill in the random bits. */ + XXXXXX[0] = letters[v % 62]; + v /= 62; + XXXXXX[1] = letters[v % 62]; + v /= 62; + XXXXXX[2] = letters[v % 62]; + v /= 62; + XXXXXX[3] = letters[v % 62]; + v /= 62; + XXXXXX[4] = letters[v % 62]; + v /= 62; + XXXXXX[5] = letters[v % 62]; + + switch (kind) + { + case __GT_FILE: + fd = __open (tmpl, + (flags & ~O_ACCMODE) + | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); + break; + + case __GT_DIR: + fd = __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); + break; + + case __GT_NOCREATE: + /* This case is backward from the other three. __gen_tempname + succeeds if __xstat fails because the name does not exist. + Note the continue to bypass the common logic at the bottom + of the loop. */ + if (__lxstat64 (_STAT_VER, tmpl, &st) < 0) + { + if (errno == ENOENT) + { + __set_errno (save_errno); + return 0; + } + else + /* Give up now. */ + return -1; + } + continue; + + default: + assert (! "invalid KIND in __gen_tempname"); + abort (); + } + + if (fd >= 0) + { + __set_errno (save_errno); + return fd; + } + else if (errno != EEXIST) + return -1; + } + + /* We got out of the loop because we ran out of combinations to try. */ + __set_errno (EEXIST); + return -1; +} diff --git a/lib/tempname.h b/lib/tempname.h new file mode 100644 index 000000000..bd46f93f9 --- /dev/null +++ b/lib/tempname.h @@ -0,0 +1,50 @@ +/* Create a temporary file or directory. + + Copyright (C) 2006, 2009-2014 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/>. */ + +/* header written by Eric Blake */ + +#ifndef GL_TEMPNAME_H +# define GL_TEMPNAME_H + +# include <stdio.h> + +# ifdef __GT_FILE +# define GT_FILE __GT_FILE +# define GT_DIR __GT_DIR +# define GT_NOCREATE __GT_NOCREATE +# else +# define GT_FILE 0 +# define GT_DIR 1 +# define GT_NOCREATE 2 +# endif + +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + GT_FILE: create a large file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); + +#endif /* GL_TEMPNAME_H */ diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 988090814..842025024 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -21,9 +21,23 @@ #endif @PRAGMA_COLUMNS@ +#ifdef _GL_INCLUDING_UNISTD_H +/* Special invocation convention: + - On Mac OS X 10.3.9 we have a sequence of nested includes + <unistd.h> -> <signal.h> -> <pthread.h> -> <unistd.h> + In this situation, the functions are not yet declared, therefore we cannot + provide the C++ aliases. */ + +#@INCLUDE_NEXT@ @NEXT_UNISTD_H@ + +#else +/* Normal invocation convention. */ + /* The include_next requires a split double-inclusion guard. */ #if @HAVE_UNISTD_H@ +# define _GL_INCLUDING_UNISTD_H # @INCLUDE_NEXT@ @NEXT_UNISTD_H@ +# undef _GL_INCLUDING_UNISTD_H #endif /* Get all possible declarations of gethostname(). */ @@ -1539,4 +1553,5 @@ _GL_CXXALIASWARN (write); _GL_INLINE_HEADER_END #endif /* _@GUARD_PREFIX@_UNISTD_H */ +#endif /* _GL_INCLUDING_UNISTD_H */ #endif /* _@GUARD_PREFIX@_UNISTD_H */ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 2077c4dac..f5e859023 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -92,11 +92,12 @@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c ## Override default rule; this should be compiled for BUILD host. ## For some reason, OBJEXT does not include the dot c-tokenize.$(OBJEXT): c-tokenize.c - $(AM_V_GEN) \ - if [ "$(cross_compiling)" = "yes" ]; then \ - $(CC_FOR_BUILD) -I$(top_builddir) -c -o $@ $<; \ - else \ - $(COMPILE) -c -o $@ $<; \ + $(AM_V_GEN) \ + if [ "$(cross_compiling)" = "yes" ]; then \ + $(CC_FOR_BUILD) -DCROSS_COMPILING=1 -I$(top_builddir) \ + -c -o "$@" "$<"; \ + else \ + $(COMPILE) -c -o "$@" "$<"; \ fi ## Override default rule; this should run on BUILD host. @@ -460,6 +461,37 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ install-exec-hook: rm -f $(DESTDIR)$(bindir)/guile-snarf.awk +install-data-hook: libguile-2.2-gdb.scm + @$(MKDIR_P) $(DESTDIR)$(libdir) +## We want to install libguile-2.2-gdb.scm as SOMETHING-gdb.scm. +## SOMETHING is the full name of the final library. We want to ignore +## symlinks, the .la file, and any previous -gdb.py file. This is +## inherently fragile, but there does not seem to be a better option, +## because libtool hides the real names from us. (Trick courtesy of +## GNU libstdc++.) + @here=`pwd`; cd $(DESTDIR)$(libdir); \ + for file in libguile-@GUILE_EFFECTIVE_VERSION@*; do \ + case $$file in \ + *-gdb.scm) ;; \ + *.la) ;; \ + *) if test -h $$file; then \ + continue; \ + fi; \ + libname=$$file;; \ + esac; \ + done; \ + cd $$here; \ + echo " $(INSTALL_DATA) $< \ +$(DESTDIR)$(libdir)/$$libname-gdb.scm"; \ + $(INSTALL_DATA) "$<" \ + "$(DESTDIR)$(libdir)/$$libname-gdb.scm" + +# Remove the GDB support file and the Info 'dir' file that +# 'install-info' 5.x installs. +uninstall-hook: + -rm "$(DESTDIR)$(libdir)/libguile-@GUILE_EFFECTIVE_VERSION@"*-gdb.scm + -rm -f "$(DESTDIR)$(infodir)/dir" + ## This is kind of nasty... there are ".c" files that we don't want to ## compile, since they are #included. So instead we list them here. ## Perhaps we can deal with them normally once the merge seems to be @@ -650,12 +682,13 @@ bin_SCRIPTS = guile-snarf # and people feel like maintaining them. For now, this is not the case. noinst_SCRIPTS = guile-snarf-docs -EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ - ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \ - guile-func-name-check \ - cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ - c-tokenize.lex \ - scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map +EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ + ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \ + guile-func-name-check \ + cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ + c-tokenize.lex \ + scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \ + libguile-2.2-gdb.scm # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi diff --git a/libguile/async.c b/libguile/async.c index 80f561d10..1e5bc302d 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, + * 2009, 2010, 2011, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -36,9 +37,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include <full-write.h> diff --git a/libguile/backtrace.c b/libguile/backtrace.c index fa12a5dd0..0c0f11007 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -1,5 +1,6 @@ /* Printing of backtraces and error messages - * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2014 Free Software Foundation + * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, + * 2010, 2011, 2014 Free Software Foundation * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -26,9 +27,7 @@ #include "libguile/_scm.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_IO_H #include <io.h> #endif diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h index 2deb97e94..6e2f4561b 100644 --- a/libguile/bdw-gc.h +++ b/libguile/bdw-gc.h @@ -23,7 +23,7 @@ #include "libguile/scmconfig.h" -#ifdef SCM_USE_PTHREAD_THREADS +#if SCM_USE_PTHREAD_THREADS /* When pthreads are used, let `libgc' know about it and redirect allocation calls such as `GC_MALLOC ()' to (contention-free, faster) thread-local diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index 856224e46..03fe9898c 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -1,3 +1,14 @@ +%top{ +/* Include <config.h> before anything else because Gnulib headers such + as <stdio.h> rely on it. + + However, when cross-compiling, don't include <config.h> because it + contains information about the host, not about the build. */ +#ifndef CROSS_COMPILING +# include <config.h> +#endif +} + %option noyywrap %option nounput %pointer @@ -14,8 +25,6 @@ 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/chars.c b/libguile/chars.c index 9f50c1e25..064fca40a 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -536,7 +536,7 @@ static const char *const scm_r5rs_charnames[] = { "space", "newline" }; -static const scm_t_uint32 const scm_r5rs_charnums[] = { +static const scm_t_uint32 scm_r5rs_charnums[] = { 0x20, 0x0a }; @@ -548,7 +548,7 @@ static const char *const scm_r6rs_charnames[] = { /* 'space' and 'newline' are already included from the R5RS list. */ }; -static const scm_t_uint32 const scm_r6rs_charnums[] = { +static const scm_t_uint32 scm_r6rs_charnums[] = { 0x00, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x1b, 0x7f }; @@ -559,7 +559,7 @@ static const char *const scm_r7rs_charnames[] = { "escape" }; -static const scm_t_uint32 const scm_r7rs_charnums[] = { +static const scm_t_uint32 scm_r7rs_charnums[] = { 0x1b }; @@ -575,7 +575,7 @@ static const char *const scm_C0_control_charnames[] = { "sp", "del" }; -static const scm_t_uint32 const scm_C0_control_charnums[] = { +static const scm_t_uint32 scm_C0_control_charnums[] = { 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, @@ -589,7 +589,7 @@ static const char *const scm_alt_charnames[] = { "null", "nl", "np" }; -static const scm_t_uint32 const scm_alt_charnums[] = { +static const scm_t_uint32 scm_alt_charnums[] = { 0x00, 0x0a, 0x0c }; diff --git a/libguile/error.c b/libguile/error.c index b61e90b37..2878fa0dd 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -40,9 +40,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* For Windows... */ #ifdef HAVE_IO_H diff --git a/libguile/filesys.c b/libguile/filesys.c index aa3e67165..a2280a51a 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, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014 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,9 +71,7 @@ # endif #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef LIBC_H_WITH_UNISTD_H #include <libc.h> @@ -109,12 +107,6 @@ #include <full-write.h> -/* Some more definitions for the native Windows port. */ -#ifdef __MINGW32__ -# define fsync(fd) _commit (fd) -#endif /* __MINGW32__ */ - - /* Two helper macros for an often used pattern */ @@ -564,7 +556,6 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, } #undef FUNC_NAME -#ifdef HAVE_LSTAT SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, (SCM str), "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n" @@ -587,7 +578,6 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, return scm_stat2scm (&stat_temp); } #undef FUNC_NAME -#endif /* HAVE_LSTAT */ #ifdef HAVE_POSIX @@ -595,7 +585,6 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, /* {Modifying Directories} */ -#ifdef HAVE_LINK SCM_DEFINE (scm_link, "link", 2, 0, 0, (SCM oldpath, SCM newpath), "Creates a new name @var{newpath} in the file system for the\n" @@ -614,7 +603,6 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* HAVE_LINK */ /* {Navigating Directories} @@ -1017,7 +1005,6 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, #undef FUNC_NAME #endif /* HAVE_SYMLINK */ -#ifdef HAVE_READLINK SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, (SCM path), "Return the value of the symbolic link named by @var{path} (a\n" @@ -1056,7 +1043,6 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, return result; } #undef FUNC_NAME -#endif /* HAVE_READLINK */ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, (SCM oldfile, SCM newfile), @@ -1259,7 +1245,6 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_GETCWD */ -#ifdef HAVE_MKDIR SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, (SCM path, SCM mode), "Create a new directory named by @var{path}. If @var{mode} is omitted\n" @@ -1286,9 +1271,7 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* HAVE_MKDIR */ -#ifdef HAVE_RMDIR SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, (SCM path), "Remove the existing directory named by @var{path}. The directory must\n" @@ -1303,27 +1286,6 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif - -#ifdef HAVE_RENAME -#define my_rename rename -#else -static int -my_rename (const char *oldname, const char *newname) -{ - int rv; - - SCM_SYSCALL (rv = link (oldname, newname)); - if (rv == 0) - { - SCM_SYSCALL (rv = unlink (oldname)); - if (rv != 0) - /* unlink failed. remove new name */ - SCM_SYSCALL (unlink (newname)); - } - return rv; -} -#endif SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, (SCM oldname, SCM newname), @@ -1335,7 +1297,7 @@ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, STRING2_SYSCALL (oldname, c_oldname, newname, c_newname, - rv = my_rename (c_oldname, c_newname)); + rv = rename (c_oldname, c_newname)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1470,10 +1432,6 @@ SCM_DEFINE (scm_umask, "umask", 0, 1, 0, } #undef FUNC_NAME -#ifndef HAVE_MKSTEMP -extern int mkstemp (char *); -#endif - SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, (SCM tmpl), "Create a new unique file in the file system and return a new\n" diff --git a/libguile/finalizers.c b/libguile/finalizers.c index b37dbde6b..82f292cd2 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -23,9 +23,7 @@ # include <config.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include <fcntl.h> #include <full-write.h> diff --git a/libguile/fports.c b/libguile/fports.c index 672f575a8..e4038def6 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -33,9 +33,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_IO_H #include <io.h> #endif diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index d229b90d9..894ca0668 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -56,9 +57,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will diff --git a/libguile/gc.c b/libguile/gc.c index bc35faf33..fe93cbaf9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -66,9 +66,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* Size in bytes of the initial heap. This should be about the size of result of 'guile -c "(display (assq-ref (gc-stats) diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index c73e8ce1e..47bbc0422 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -1,7 +1,8 @@ #!/bin/sh # Extract the initialization actions from source files. # -# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, +# 2009, 2014 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 @@ -51,19 +52,21 @@ modern_snarf () # writes stdout ## empty file. echo "/* cpp arguments: $@ */" ; ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true - sed -ne 's/ *\^ *: *\^/\ + sed -ne 's/ *\^ *\^ */\ / -h -s/\n.*// +s/.*\n// t x d : x -s/.*\^ *\^ *\(.*\)/\1;/ +s/ *\^ *: *\^ */;\ +/ t y -d +N +s/\n\(#.*\)/ / +s/\n/ / +t x : y -p -x +P D' ${temp} } diff --git a/libguile/init.c b/libguile/init.c index 81cf99707..6de7a2192 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2004, 2006, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -144,9 +145,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif diff --git a/libguile/ioext.c b/libguile/ioext.c index 94b0f4f0f..659eabcf5 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, + * 2011, 2014 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 @@ -41,9 +42,7 @@ #ifdef HAVE_IO_H #include <io.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, diff --git a/libguile/iselect.h b/libguile/iselect.h index 1c7b12db0..945ad14af 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -29,8 +29,6 @@ /* Needed for FD_SET on some systems. */ #include <sys/types.h> -#if SCM_HAVE_SYS_SELECT_H - #include <sys/select.h> SCM_API int scm_std_select (int fds, @@ -41,8 +39,6 @@ SCM_API int scm_std_select (int fds, #define SELECT_TYPE fd_set -#endif /* SCM_HAVE_SYS_SELECT_H */ - #endif /* SCM_ISELECT_H */ /* diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm new file mode 100644 index 000000000..93ba1a3ea --- /dev/null +++ b/libguile/libguile-2.2-gdb.scm @@ -0,0 +1,164 @@ +;;; GDB debugging support for Guile. +;;; +;;; Copyright 2014 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 +;;; 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guile-gdb) + #:use-module (system base types) + #:use-module ((gdb) #:hide (symbol?)) + #:use-module (gdb printing) + #:use-module (srfi srfi-11) + #:export (%gdb-memory-backend + display-vm-frames)) + +;;; Commentary: +;;; +;;; This file defines GDB extensions to pretty-print 'SCM' objects, and +;;; to walk Guile's virtual machine stack. +;;; +;;; This file is installed under a name that follows the convention that +;;; allows GDB to auto-load it anytime the user is debugging libguile +;;; (info "(gdb) objfile-gdbdotext file"). +;;; +;;; Code: + +(define (type-name-from-descriptor descriptor-array type-number) + "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f +if the information is not available." + (let ((descriptors (lookup-global-symbol descriptor-array))) + (and descriptors + (let ((code (type-code (symbol-type descriptors)))) + (or (= TYPE_CODE_ARRAY code) + (= TYPE_CODE_PTR code))) + (let* ((type-descr (value-subscript (symbol-value descriptors) + type-number)) + (name (value-field type-descr "name"))) + (value->string name))))) + +(define %gdb-memory-backend + ;; The GDB back-end to access the inferior's memory. + (let ((void* (type-pointer (lookup-type "void")))) + (define (dereference-word address) + ;; Return the word at ADDRESS. + (value->integer + (value-dereference (value-cast (make-value address) + (type-pointer void*))))) + + (define (open address size) + ;; Return a port to the SIZE bytes starting at ADDRESS. + (if size + (open-memory #:start address #:size size) + (open-memory #:start address))) + + (define (type-name kind number) + ;; Return the type name of KIND type NUMBER. + (type-name-from-descriptor (case kind + ((smob) "scm_smobs") + ((port) "scm_ptobs")) + number)) + + (memory-backend dereference-word open type-name))) + + +;;; +;;; GDB pretty-printer registration. +;;; + +(define scm-value->string + (lambda* (value #:optional (backend %gdb-memory-backend)) + "Return a representation of value VALUE as a string." + (object->string (scm->object (value->integer value) backend)))) + +(define %scm-pretty-printer + (make-pretty-printer "SCM" + (lambda (pp value) + (let ((name (type-name (value-type value)))) + (and (and name (string=? name "SCM")) + (make-pretty-printer-worker + #f ; display hint + (lambda (printer) + (scm-value->string value %gdb-memory-backend)) + #f)))))) + +(define* (register-pretty-printer #:optional objfile) + (prepend-pretty-printer! objfile %scm-pretty-printer)) + +(register-pretty-printer) + + +;;; +;;; VM stack walking. +;;; + +(define (find-vm-engine-frame) + "Return the bottom-most frame containing a call to the VM engine." + (define (vm-engine-frame? frame) + (let ((sym (frame-function frame))) + (and sym + (member (symbol-name sym) + '("vm_debug_engine" "vm_regular_engine"))))) + + (let loop ((frame (newest-frame))) + (and frame + (if (vm-engine-frame? frame) + frame + (loop (frame-older frame)))))) + +(define (vm-stack-pointer) + "Return the current value of the VM stack pointer or #f." + (let ((frame (find-vm-engine-frame))) + (and frame + (frame-read-var frame "sp")))) + +(define (vm-frame-pointer) + "Return the current value of the VM frame pointer or #f." + (let ((frame (find-vm-engine-frame))) + (and frame + (frame-read-var frame "fp")))) + +(define* (display-vm-frames #:optional (port (current-output-port))) + "Display the VM frames on PORT." + (define (display-objects start end) + ;; Display all the objects (arguments and local variables) located + ;; between START and END. + (let loop ((number 0) + (address start)) + (when (and (> start 0) (<= address end)) + (let ((object (dereference-word %gdb-memory-backend address))) + ;; TODO: Push onto GDB's value history. + (format port " slot ~a -> ~s~%" + number (scm->object object %gdb-memory-backend))) + (loop (+ 1 number) (+ address %word-size))))) + + (let loop ((number 0) + (sp (value->integer (vm-stack-pointer))) + (fp (value->integer (vm-frame-pointer)))) + (unless (zero? fp) + (let-values (((ra mvra link proc) + (vm-frame fp %gdb-memory-backend))) + (format port "#~a ~s~%" number (scm->object proc %gdb-memory-backend)) + (display-objects fp sp) + (loop (+ 1 number) (- fp (* 5 %word-size)) link))))) + +;; See libguile/frames.h. +(define* (vm-frame fp #:optional (backend %gdb-memory-backend)) + "Return the components of the stack frame at FP." + (let ((caller (dereference-word backend (- fp %word-size))) + (ra (dereference-word backend (- fp (* 2 %word-size)))) + (mvra (dereference-word backend (- fp (* 3 %word-size)))) + (link (dereference-word backend (- fp (* 4 %word-size))))) + (values ra mvra link caller))) + +;;; libguile-2.2-gdb.scm ends here diff --git a/libguile/list.c b/libguile/list.c index 1f44ad032..41cc937f7 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -374,18 +374,49 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, "@code{reverse!}") #define FUNC_NAME s_scm_reverse_x { - SCM_VALIDATE_LIST (1, lst); + SCM old_lst = lst; + SCM tail = SCM_BOOL_F; + if (SCM_UNBNDP (new_tail)) new_tail = SCM_EOL; - while (!SCM_NULL_OR_NIL_P (lst)) + if (SCM_NULL_OR_NIL_P (lst)) + return new_tail; + + /* SCM_VALIDATE_LIST would run through the whole list to make sure it + is not eventually circular. In contrast to most list operations, + reverse! cannot get stuck in an infinite loop but arrives back at + the start when given an eventually or fully circular list. Because + of that, we can save the cost of an upfront proper list check at + the price of having to do a double reversal in the error case. + */ + + while (scm_is_pair (lst)) { SCM old_tail = SCM_CDR (lst); - SCM_SETCDR (lst, new_tail); - new_tail = lst; + SCM_SETCDR (lst, tail); + tail = lst; lst = old_tail; } - return new_tail; + + if (SCM_LIKELY (SCM_NULL_OR_NIL_P (lst))) + { + SCM_SETCDR (old_lst, new_tail); + return tail; + } + + /* We did not start with a proper list. Undo the reversal. */ + + while (scm_is_pair (tail)) + { + SCM old_tail = SCM_CDR (tail); + SCM_SETCDR (tail, lst); + lst = tail; + tail = old_tail; + } + + SCM_WRONG_TYPE_ARG (1, lst); + return lst; } #undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index 5019201dc..d24b4ae02 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -49,10 +49,7 @@ #include <sys/types.h> #include <sys/stat.h> - -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* HAVE_UNISTD_H */ #ifdef HAVE_PWD_H #include <pwd.h> diff --git a/libguile/mallocs.c b/libguile/mallocs.c index b4499bc6d..9f3584a09 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -1,5 +1,6 @@ /* classes: src_files - * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011 Free Software Foundation, Inc. + * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011, + * 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -32,9 +33,7 @@ #include "libguile/mallocs.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c index a7eaf105b..d752d0714 100644 --- a/libguile/mkstemp.c +++ b/libguile/mkstemp.c @@ -1,4 +1,6 @@ -/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013, + 2014 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. @@ -33,9 +35,7 @@ #include <errno.h> #include <stdio.h> #include <fcntl.h> -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_SYS_TIME_H #include <sys/time.h> #endif diff --git a/libguile/numbers.c b/libguile/numbers.c index f4e8b2710..14d98ffea 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, - * 2013 Free Software Foundation, Inc. + * 2013, 2014 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -4679,9 +4679,15 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, if (SCM_I_INUMP (j)) { - /* bits above what's in an inum follow the sign bit */ - iindex = min (iindex, SCM_LONG_BIT - 1); - return scm_from_bool ((1L << iindex) & SCM_I_INUM (j)); + if (iindex < SCM_LONG_BIT - 1) + /* Arrange for the number to be converted to unsigned before + checking the bit, to ensure that we're testing the bit in a + two's complement representation (regardless of the native + representation. */ + return scm_from_bool ((1UL << iindex) & SCM_I_INUM (j)); + else + /* Portably check the sign. */ + return scm_from_bool (SCM_I_INUM (j) < 0); } else if (SCM_BIGP (j)) { @@ -4991,7 +4997,7 @@ left_shift_exact_integer (SCM n, long count) 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); + return SCM_I_MAKINUM (nn < 0 ? -(-nn << count) : (nn << count)); else { SCM result = scm_i_inum2big (nn); diff --git a/libguile/numbers.h b/libguile/numbers.h index 6e382ea35..bba336bd4 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -4,7 +4,7 @@ #define SCM_NUMBERS_H /* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, - * 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. + * 2008, 2009, 2010, 2011, 2013, 2014 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 @@ -49,19 +49,43 @@ typedef scm_t_int32 scm_t_wchar; #define SCM_MOST_POSITIVE_FIXNUM ((SCM_T_SIGNED_BITS_MAX-3)/4) #define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) -/* SCM_SRS is signed right shift */ -#if (-1 == (((-1) << 2) + 2) >> 2) -# define SCM_SRS(x, y) ((x) >> (y)) +/* SCM_SRS (X, Y) is signed right shift, defined as floor (X / 2^Y), + where Y must be non-negative and less than the width in bits of X. + It's common for >> to do this, but the C standards do not specify + what happens when X is negative. + + NOTE: X must not perform side effects. */ +#if (-1 >> 2 == -1) && (-4 >> 2 == -1) && (-5 >> 2 == -2) && (-8 >> 2 == -2) +# define SCM_SRS(x, y) ((x) >> (y)) #else -# define SCM_SRS(x, y) ((x) < 0 ? ~((~(x)) >> (y)) : ((x) >> (y))) -#endif /* (-1 == (((-1) << 2) + 2) >> 2) */ +# define SCM_SRS(x, y) \ + ((x) < 0 \ + ? -1 - (scm_t_signed_bits) (~(scm_t_bits)(x) >> (y)) \ + : ((x) >> (y))) +#endif + +/* The first implementation of SCM_I_INUM below depends on behavior that + is specified by GNU C but not by C standards, namely that when + casting to a signed integer of width N, the value is reduced modulo + 2^N to be within range of the type. The second implementation below + should be portable to all conforming C implementations, but may be + less efficient if the compiler is not sufficiently clever. + + NOTE: X must not perform side effects. */ +#ifdef __GNUC__ +# define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) +#else +# define SCM_I_INUM(x) \ + (SCM_UNPACK (x) > LONG_MAX \ + ? -1 - (scm_t_signed_bits) (~SCM_UNPACK (x) >> 2) \ + : (scm_t_signed_bits) (SCM_UNPACK (x) >> 2)) +#endif #define SCM_I_INUMP(x) (2 & SCM_UNPACK (x)) #define SCM_I_NINUMP(x) (!SCM_I_INUMP (x)) #define SCM_I_MAKINUM(x) \ - (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int)) -#define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) + (SCM_PACK ((((scm_t_bits) (x)) << 2) + scm_tc2_int)) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ #define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) diff --git a/libguile/ports.c b/libguile/ports.c index 060c4fb31..5fb34248c 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006, - * 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -70,9 +71,7 @@ #include <io.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_SYS_IOCTL_H #include <sys/ioctl.h> diff --git a/libguile/posix.c b/libguile/posix.c index 0443f95ea..ae0f7c3c3 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -46,9 +47,7 @@ # endif #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef LIBC_H_WITH_UNISTD_H #include <libc.h> diff --git a/libguile/print.c b/libguile/print.c index b79eb3ffe..684b3d410 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1549,6 +1549,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, if (scm_is_eq (destination, SCM_BOOL_T)) { destination = port = scm_current_output_port (); + SCM_VALIDATE_OPORT_VALUE (1, destination); } else if (scm_is_false (destination)) { diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index db0b3f6c3..1b0aba406 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -20,10 +20,7 @@ # include <config.h> #endif -#ifdef HAVE_UNISTD_H -# include <unistd.h> -#endif - +#include <unistd.h> #include <string.h> #include <stdio.h> #include <assert.h> diff --git a/libguile/random.c b/libguile/random.c index 915f17feb..1ee0459de 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,5 +1,6 @@ /* Copyright (C) 1999, 2000, 2001, 2003, 2005, 2006, 2009, 2010, - * 2012, 2013 Free Software Foundation, Inc. + * 2012, 2013, 2014 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 @@ -31,10 +32,7 @@ #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" @@ -257,7 +255,7 @@ scm_i_mask32 (scm_t_uint32 m) ? scm_masktab[m >> 8] << 8 | 0xff : (m < 0x1000000 ? scm_masktab[m >> 16] << 16 | 0xffff - : scm_masktab[m >> 24] << 24 | 0xffffff))); + : ((scm_t_uint32) scm_masktab[m >> 24]) << 24 | 0xffffff))); } scm_t_uint32 diff --git a/libguile/rw.c b/libguile/rw.c index 677e0d8df..75c280b4e 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2006, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2009, 2011, 2014 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,9 +37,7 @@ #include "libguile/modules.h" #include "libguile/strports.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_IO_H #include <io.h> #endif diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index d65dcea84..a23f151a2 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, + * 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -32,9 +33,7 @@ #include <process.h> /* for mingw */ #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_SYS_TIME_H #include <sys/time.h> diff --git a/libguile/script.c b/libguile/script.c index 052ab8d42..63fbb0f3f 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1994-1998, 2000-2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1994-1998, 2000-2011, 2013, 2014 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 @@ -45,9 +46,7 @@ #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> /* for X_OK define */ -#endif #ifdef HAVE_IO_H #include <io.h> @@ -220,6 +219,21 @@ script_get_backslash (FILE *f) } #undef FUNC_NAME +/* + * Like `realloc', but free memory on failure; + * unlike `scm_realloc', return NULL, not aborts. +*/ +static void* +realloc0 (void *ptr, size_t size) +{ + void *new_ptr = realloc (ptr, size); + if (!new_ptr) + { + free (ptr); + } + return new_ptr; +} + static char * script_read_arg (FILE *f) @@ -245,7 +259,7 @@ script_read_arg (FILE *f) if (len >= size) { size = (size + 1) * 2; - buf = realloc (buf, size); + buf = realloc0 (buf, size); if (! buf) return 0; } @@ -328,9 +342,9 @@ scm_get_meta_args (int argc, char **argv) found_args: /* FIXME: we leak the result of calling script_read_arg. */ while ((narg = script_read_arg (f))) - if (!(nargv = (char **) realloc (nargv, + if (!(nargv = (char **) realloc0 (nargv, (1 + ++nargc) * sizeof (char *)))) - return 0L; + return 0L; else nargv[nargi++] = narg; fclose (f); diff --git a/libguile/simpos.c b/libguile/simpos.c index 7865da647..a657a8f09 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009, - * 2010, 2012, 2013 Free Software Foundation, Inc. + * 2010, 2012, 2013, 2014 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 @@ -40,9 +40,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #if HAVE_SYS_WAIT_H # include <sys/wait.h> #endif diff --git a/libguile/snarf.h b/libguile/snarf.h index afc4d8f2a..d0b683308 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -4,7 +4,7 @@ #define SCM_SNARF_H /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. + * 2004, 2006, 2009, 2010, 2011, 2013, 2014 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 @@ -87,7 +87,7 @@ DOCSTRING ^^ } #define SCM_DEFINE_GSUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ +SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(\ @@ -102,7 +102,7 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ +SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \ static SCM g_ ## FNAME; \ SCM FNAME ARGLIST\ )\ @@ -116,7 +116,7 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ +SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(\ @@ -127,12 +127,12 @@ scm_c_export (s_ ## FNAME, NULL); \ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -SCM_SNARF_HERE(static const char RANAME[]=STR) \ +SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN)) #define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -SCM_SNARF_HERE(static const char RANAME[]=STR) \ +SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \ SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \ @@ -140,7 +140,7 @@ SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \ #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ SCM_SNARF_HERE(\ -static const char RANAME[]=STR;\ +SCM_UNUSED static const char RANAME[]=STR;\ static SCM GF \ )SCM_SNARF_INIT(\ GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \ diff --git a/libguile/socket.c b/libguile/socket.c index 0516e5267..2a9be5471 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -33,9 +33,7 @@ #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 @@ -66,7 +64,7 @@ #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) -#define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ +#define SUN_LEN(ptr) (offsetof (struct sockaddr_un, sun_path) \ + strlen ((ptr)->sun_path)) #endif diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index d8a264c54..057664c58 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -137,12 +137,13 @@ scm_t_array_handle *h, \ size_t *lenp, ssize_t *incp) \ { \ + size_t byte_width = width * sizeof (ctype); \ if (!scm_is_bytevector (uvec) \ - || (scm_c_bytevector_length (uvec) % width)) \ + || (scm_c_bytevector_length (uvec) % byte_width)) \ scm_wrong_type_arg_msg (NULL, 0, uvec, #tag "vector"); \ scm_array_get_handle (uvec, h); \ if (lenp) \ - *lenp = scm_c_bytevector_length (uvec) / width; \ + *lenp = scm_c_bytevector_length (uvec) / byte_width; \ if (incp) \ *incp = 1; \ return ((ctype *)h->writable_elements); \ diff --git a/libguile/srfi-60.c b/libguile/srfi-60.c index 1ed3c9e81..de97cbc60 100644 --- a/libguile/srfi-60.c +++ b/libguile/srfi-60.c @@ -1,6 +1,6 @@ /* srfi-60.c --- Integers as Bits * - * Copyright (C) 2005, 2006, 2008, 2010 Free Software Foundation, Inc. + * Copyright (C) 2005, 2006, 2008, 2010, 2014 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 @@ -155,7 +155,12 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, SCM_ASSERT_RANGE (3, end, (ee >= ss)); ww = ee - ss; - cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); + /* we must avoid division by zero, and a field whose width is 0 or 1 + will be left unchanged anyway, so in that case we set cc to 0. */ + if (ww <= 1) + cc = 0; + else + cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); if (SCM_I_INUMP (n)) { @@ -163,22 +168,40 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, if (ee <= SCM_LONG_BIT-1) { - /* all within a long */ - long below = nn & ((1L << ss) - 1); /* before start */ - long above = nn & (-1L << ee); /* above end */ - long fmask = (-1L << ss) & ((1L << ee) - 1); /* field mask */ - long ff = nn & fmask; /* field */ - - return scm_from_long (above - | ((ff << cc) & fmask) - | ((ff >> (ww-cc)) & fmask) - | below); + /* Everything fits within a long. To avoid undefined behavior + when shifting negative numbers, we do all operations using + unsigned values, and then convert to signed at the end. */ + unsigned long unn = nn; + unsigned long below = unn & ((1UL << ss) - 1); /* below start */ + unsigned long above = unn & ~((1UL << ee) - 1); /* above end */ + unsigned long fmask = ((1UL << ww) - 1) << ss; /* field mask */ + unsigned long ff = unn & fmask; /* field */ + unsigned long uresult = (above + | ((ff << cc) & fmask) + | ((ff >> (ww-cc)) & fmask) + | below); + long result; + + if (uresult > LONG_MAX) + /* The high bit is set in uresult, so the result is + negative. We have to handle the conversion to signed + integer carefully, to avoid undefined behavior. First we + compute ~uresult, equivalent to (ULONG_MAX - uresult), + which will be between 0 and LONG_MAX (inclusive): exactly + the set of numbers that can be represented as both signed + and unsigned longs and thus convertible between them. We + cast that difference to a signed long and then substract + it from -1. */ + result = -1 - (long) ~uresult; + else + result = (long) uresult; + + return scm_from_long (result); } else { - /* either no movement, or a field of only 0 or 1 bits, result - unchanged, avoid creating a bignum */ - if (cc == 0 || ww <= 1) + /* if there's no movement, avoid creating a bignum. */ + if (cc == 0) return n; n = scm_i_long2big (nn); @@ -190,9 +213,8 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, mpz_t tmp; SCM r; - /* either no movement, or in a field of only 0 or 1 bits, result - unchanged, avoid creating a new bignum */ - if (cc == 0 || ww <= 1) + /* if there's no movement, avoid creating a new bignum. */ + if (cc == 0) return n; big: @@ -209,7 +231,7 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, mpz_mul_2exp (tmp, tmp, ss + cc); mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); - /* field high part, count bits from end-count go to start */ + /* field low part, count bits from end-count go to start */ mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc); mpz_fdiv_r_2exp (tmp, tmp, cc); mpz_mul_2exp (tmp, tmp, ss); diff --git a/libguile/stime.c b/libguile/stime.c index c87692518..f656d886c 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, + * 2007, 2008, 2009, 2011, 2013, 2014 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 @@ -59,9 +60,7 @@ #include "libguile/validate.h" #include "libguile/stime.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_CLOCK_GETTIME diff --git a/libguile/strports.c b/libguile/strports.c index dd3bc59d4..a6a03b4eb 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006, - * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -27,9 +27,7 @@ #include "libguile/_scm.h" #include <stdio.h> -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include "libguile/bytevectors.h" #include "libguile/eval.h" diff --git a/libguile/threads.c b/libguile/threads.c index dd04f6ff9..bcf1e0d63 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, - * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 - * Free Software Foundation, Inc. + * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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,9 +29,7 @@ #include "libguile/_scm.h" #include <stdlib.h> -#if HAVE_UNISTD_H #include <unistd.h> -#endif #include <stdio.h> #ifdef HAVE_STRING_H @@ -1779,14 +1777,6 @@ 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, fd_set *readfds, diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 86803fd24..3c09df21e 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,4 +1,5 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -2481,7 +2482,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, && ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) <= 1)) - RETURN (SCM_I_MAKINUM (nn << bits_to_shift)); + RETURN (SCM_I_MAKINUM (nn < 0 + ? -(-nn << bits_to_shift) + : (nn << bits_to_shift))); /* fall through */ } /* fall through */ diff --git a/m4/fsync.m4 b/m4/fsync.m4 new file mode 100644 index 000000000..888a65def --- /dev/null +++ b/m4/fsync.m4 @@ -0,0 +1,17 @@ +# fsync.m4 serial 2 +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl This file is free software; the Free 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_FSYNC], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([fsync]) + if test $ac_cv_func_fsync = no; then + HAVE_FSYNC=0 + fi +]) + +# Prerequisites of lib/fsync.c. +AC_DEFUN([gl_PREREQ_FSYNC], [:]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 7682c1ec6..26c96b3e3 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign 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 isfinite 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 time times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync 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 isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -55,6 +55,7 @@ gl_MODULES([ fpieee frexp fstat + fsync full-read full-write func @@ -80,13 +81,17 @@ gl_MODULES([ lib-symbol-versions lib-symbol-visibility libunistring + link listen localcharset locale log1p + lstat maintainer-makefile malloc-gnu malloca + mkdir + mkstemp nl_langinfo nproc open @@ -94,10 +99,12 @@ gl_MODULES([ pipe2 poll putenv + readlink recv recvfrom regex rename + rmdir select send sendto @@ -114,12 +121,13 @@ gl_MODULES([ time times trunc + unistd verify vsnprintf warnings wchar ]) -gl_AVOID([]) +gl_AVOID([lock]) gl_SOURCE_BASE([lib]) gl_M4_BASE([m4]) gl_PO_BASE([]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 3b61b239b..20ce40e74 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -379,3 +379,59 @@ AC_DEFUN([gl_CACHE_VAL_SILENT], # AS_VAR_COPY was added in autoconf 2.63b m4_define_default([AS_VAR_COPY], [AS_LITERAL_IF([$1[]$2], [$1=$$2], [eval $1=\$$2])]) + +# AC_PROG_SED was added in autoconf 2.59b +m4_ifndef([AC_PROG_SED], +[AC_DEFUN([AC_PROG_SED], +[AC_CACHE_CHECK([for a sed that does not truncate output], ac_cv_path_SED, + [dnl ac_script should not contain more than 99 commands (for HP-UX sed), + dnl but more than about 7000 bytes, to catch a limit in Solaris 8 /usr/ucb/sed. + ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ + for ac_i in 1 2 3 4 5 6 7; do + ac_script="$ac_script$as_nl$ac_script" + done + echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed + AS_UNSET([ac_script]) + if test -z "$SED"; then + ac_path_SED_found=false + _AS_PATH_WALK([], [ + for ac_prog in sed gsed; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_SED="$as_dir/$ac_prog$ac_exec_ext" + AS_EXECUTABLE_P(["$ac_path_SED"]) || continue + case `"$ac_path_SED" --version 2>&1` in + *GNU*) ac_cv_path_SED=$ac_path_SED ac_path_SED_found=:;; + *) + ac_count=0 + _AS_ECHO_N([0123456789]) >conftest.in + while : + do + cat conftest.in conftest.in >conftest.tmp + mv conftest.tmp conftest.in + cp conftest.in conftest.nl + echo >> conftest.nl + "$ac_path_SED" -f conftest.sed <conftest.nl >conftest.out 2>/dev/null || break + diff conftest.out conftest.nl >/dev/null 2>&1 || break + ac_count=`expr $ac_count + 1` + if test $ac_count -gt ${ac_path_SED_max-0}; then + # Best so far, but keep looking for better + ac_cv_path_SED=$ac_path_SED + ac_path_SED_max=$ac_count + fi + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; + esac + $ac_path_SED_found && break 3 + done + done]) + if test -z "$ac_cv_path_SED"; then + AC_ERROR([no acceptable sed could be found in \$PATH]) + fi + else + ac_cv_path_SED=$SED + fi + SED="$ac_cv_path_SED" + AC_SUBST([SED])dnl + rm -f conftest.sed +])])]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index a18870900..429fee422 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -84,6 +84,7 @@ AC_DEFUN([gl_EARLY], AC_REQUIRE([gl_FP_IEEE]) # Code from module frexp: # Code from module fstat: + # Code from module fsync: # Code from module full-read: # Code from module full-write: # Code from module func: @@ -127,11 +128,11 @@ AC_DEFUN([gl_EARLY], # Code from module lib-symbol-versions: # Code from module lib-symbol-visibility: # Code from module libunistring: + # Code from module link: # Code from module listen: # Code from module localcharset: # Code from module locale: # Code from module localeconv: - # Code from module lock: # Code from module log: # Code from module log1p: # Code from module lstat: @@ -144,6 +145,8 @@ AC_DEFUN([gl_EARLY], # Code from module mbsinit: # Code from module mbtowc: # Code from module memchr: + # Code from module mkdir: + # Code from module mkstemp: # Code from module msvc-inval: # Code from module msvc-nothrow: # Code from module multiarch: @@ -171,6 +174,7 @@ AC_DEFUN([gl_EARLY], # Code from module safe-read: # Code from module safe-write: # Code from module same-inode: + # Code from module secure_getenv: # Code from module select: # Code from module send: # Code from module sendto: @@ -200,6 +204,7 @@ AC_DEFUN([gl_EARLY], # Code from module stdint: # Code from module stdio: # Code from module stdlib: + # Code from module strdup-posix: # Code from module streq: # Code from module strftime: # Code from module striconveh: @@ -212,8 +217,7 @@ AC_DEFUN([gl_EARLY], # Code from module sys_times: # Code from module sys_types: # Code from module sys_uio: - # Code from module threadlib: - gl_THREADLIB_EARLY + # Code from module tempname: # Code from module time: # Code from module time_r: # Code from module times: @@ -362,6 +366,12 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_FSTAT fi gl_SYS_STAT_MODULE_INDICATOR([fstat]) + gl_FUNC_FSYNC + if test $HAVE_FSYNC = 0; then + AC_LIBOBJ([fsync]) + gl_PREREQ_FSYNC + fi + gl_UNISTD_MODULE_INDICATOR([fsync]) gl_FUNC gl_GETADDRINFO if test $HAVE_GETADDRINFO = 0; then @@ -496,6 +506,11 @@ AC_SUBST([LTALLOCA]) gl_LD_VERSION_SCRIPT gl_VISIBILITY gl_LIBUNISTRING + gl_FUNC_LINK + if test $HAVE_LINK = 0 || test $REPLACE_LINK = 1; then + AC_LIBOBJ([link]) + fi + gl_UNISTD_MODULE_INDICATOR([link]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) if test "$ac_cv_header_winsock2_h" = yes; then AC_LIBOBJ([listen]) @@ -511,8 +526,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_LOCALECONV fi gl_LOCALE_MODULE_INDICATOR([localeconv]) - gl_LOCK - gl_MODULE_INDICATOR([lock]) AC_REQUIRE([gl_FUNC_LOG]) if test $REPLACE_LOG = 1; then AC_LIBOBJ([log]) @@ -531,6 +544,7 @@ AC_SUBST([LTALLOCA]) gl_SYS_STAT_MODULE_INDICATOR([lstat]) AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER], [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])]) + AC_REQUIRE([AC_PROG_SED]) gl_FUNC_MALLOC_GNU if test $REPLACE_MALLOC = 1; then AC_LIBOBJ([malloc]) @@ -567,6 +581,16 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_MEMCHR fi gl_STRING_MODULE_INDICATOR([memchr]) + gl_FUNC_MKDIR + if test $REPLACE_MKDIR = 1; then + AC_LIBOBJ([mkdir]) + fi + gl_FUNC_MKSTEMP + if test $HAVE_MKSTEMP = 0 || test $REPLACE_MKSTEMP = 1; then + AC_LIBOBJ([mkstemp]) + gl_PREREQ_MKSTEMP + fi + gl_STDLIB_MODULE_INDICATOR([mkstemp]) gl_MSVC_INVAL if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then AC_LIBOBJ([msvc-inval]) @@ -662,6 +686,12 @@ AC_SUBST([LTALLOCA]) gl_MATH_MODULE_INDICATOR([round]) gl_PREREQ_SAFE_READ gl_PREREQ_SAFE_WRITE + gl_FUNC_SECURE_GETENV + if test $HAVE_SECURE_GETENV = 0; then + AC_LIBOBJ([secure_getenv]) + gl_PREREQ_SECURE_GETENV + fi + gl_STDLIB_MODULE_INDICATOR([secure_getenv]) gl_FUNC_SELECT if test $REPLACE_SELECT = 1; then AC_LIBOBJ([select]) @@ -737,6 +767,12 @@ AC_SUBST([LTALLOCA]) gl_STDINT_H gl_STDIO_H gl_STDLIB_H + gl_FUNC_STRDUP_POSIX + if test $ac_cv_func_strdup = no || test $REPLACE_STRDUP = 1; then + AC_LIBOBJ([strdup]) + gl_PREREQ_STRDUP + fi + gl_STRING_MODULE_INDICATOR([strdup]) gl_FUNC_GNU_STRFTIME if test $gl_cond_libtool = false; then gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" @@ -759,7 +795,7 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_UIO AC_PROG_MKDIR_P - gl_THREADLIB + gl_FUNC_GEN_TEMPNAME gl_HEADER_TIME_H gl_TIME_R if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then @@ -1000,6 +1036,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/floor.c lib/frexp.c lib/fstat.c + lib/fsync.c lib/full-read.c lib/full-read.h lib/full-write.c @@ -1012,9 +1049,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/getsockopt.c lib/gettext.h lib/gettimeofday.c - lib/glthread/lock.c - lib/glthread/lock.h - lib/glthread/threadlib.c lib/iconv.c lib/iconv.in.h lib/iconv_close.c @@ -1039,6 +1073,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/itold.c lib/langinfo.in.h lib/libunistring.valgrind + lib/link.c lib/listen.c lib/localcharset.c lib/localcharset.h @@ -1059,6 +1094,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/mbtowc.c lib/memchr.c lib/memchr.valgrind + lib/mkdir.c + lib/mkstemp.c lib/msvc-inval.c lib/msvc-inval.h lib/msvc-nothrow.c @@ -1100,6 +1137,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/safe-write.c lib/safe-write.h lib/same-inode.h + lib/secure_getenv.c lib/select.c lib/send.c lib/sendto.c @@ -1124,6 +1162,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/stdint.in.h lib/stdio.in.h lib/stdlib.in.h + lib/strdup.c lib/streq.h lib/strftime.c lib/strftime.h @@ -1140,6 +1179,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/sys_times.in.h lib/sys_types.in.h lib/sys_uio.in.h + lib/tempname.c + lib/tempname.h lib/time.in.h lib/time_r.c lib/times.c @@ -1205,6 +1246,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/fpieee.m4 m4/frexp.m4 m4/fstat.m4 + m4/fsync.m4 m4/func.m4 m4/getaddrinfo.m4 m4/getlogin.m4 @@ -1237,13 +1279,13 @@ AC_DEFUN([gl_FILE_LIST], [ m4/lib-prefix.m4 m4/libunistring-base.m4 m4/libunistring.m4 + m4/link.m4 m4/localcharset.m4 m4/locale-fr.m4 m4/locale-ja.m4 m4/locale-zh.m4 m4/locale_h.m4 m4/localeconv.m4 - m4/lock.m4 m4/log.m4 m4/log1p.m4 m4/longlong.m4 @@ -1257,6 +1299,8 @@ AC_DEFUN([gl_FILE_LIST], [ m4/mbstate_t.m4 m4/mbtowc.m4 m4/memchr.m4 + m4/mkdir.m4 + m4/mkstemp.m4 m4/mmap-anon.m4 m4/mode_t.m4 m4/msvc-inval.m4 @@ -1285,6 +1329,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/round.m4 m4/safe-read.m4 m4/safe-write.m4 + m4/secure_getenv.m4 m4/select.m4 m4/servent.m4 m4/setenv.m4 @@ -1306,6 +1351,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/stdint_h.m4 m4/stdio_h.m4 m4/stdlib_h.m4 + m4/strdup.m4 m4/strftime.m4 m4/string_h.m4 m4/sys_file_h.m4 @@ -1316,7 +1362,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/sys_times_h.m4 m4/sys_types_h.m4 m4/sys_uio_h.m4 - m4/threadlib.m4 + m4/tempname.m4 m4/time_h.m4 m4/time_r.m4 m4/times.m4 diff --git a/m4/link.m4 b/m4/link.m4 new file mode 100644 index 000000000..e923d0d02 --- /dev/null +++ b/m4/link.m4 @@ -0,0 +1,55 @@ +# link.m4 serial 8 +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl This file is free software; the Free 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_LINK], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CHECK_FUNCS_ONCE([link]) + if test $ac_cv_func_link = no; then + HAVE_LINK=0 + else + AC_CACHE_CHECK([whether link obeys POSIX], + [gl_cv_func_link_works], + [touch conftest.a + # Assume that if we have lstat, we can also check symlinks. + if test $ac_cv_func_lstat = yes; then + ln -s conftest.a conftest.lnk + fi + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[#include <unistd.h> + ]], + [[int result = 0; + if (!link ("conftest.a", "conftest.b/")) + result |= 1; +#if HAVE_LSTAT + if (!link ("conftest.lnk/", "conftest.b")) + result |= 2; + if (rename ("conftest.a", "conftest.b")) + result |= 4; + if (!link ("conftest.b", "conftest.lnk")) + result |= 8; +#endif + return result; + ]])], + [gl_cv_func_link_works=yes], [gl_cv_func_link_works=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_link_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_link_works="guessing no" ;; + esac + ]) + rm -f conftest.a conftest.b conftest.lnk]) + case "$gl_cv_func_link_works" in + *yes) ;; + *) + REPLACE_LINK=1 + ;; + esac + fi +]) diff --git a/m4/lock.m4 b/m4/lock.m4 deleted file mode 100644 index 73a3c54ce..000000000 --- a/m4/lock.m4 +++ /dev/null @@ -1,42 +0,0 @@ -# lock.m4 serial 13 (gettext-0.18.2) -dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. -dnl This file is free software; the Free 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 From Bruno Haible. - -AC_DEFUN([gl_LOCK], -[ - AC_REQUIRE([gl_THREADLIB]) - if test "$gl_threads_api" = posix; then - # OSF/1 4.0 and Mac OS X 10.1 lack the pthread_rwlock_t type and the - # pthread_rwlock_* functions. - AC_CHECK_TYPE([pthread_rwlock_t], - [AC_DEFINE([HAVE_PTHREAD_RWLOCK], [1], - [Define if the POSIX multithreading library has read/write locks.])], - [], - [#include <pthread.h>]) - # glibc defines PTHREAD_MUTEX_RECURSIVE as enum, not as a macro. - AC_COMPILE_IFELSE([ - AC_LANG_PROGRAM( - [[#include <pthread.h>]], - [[ -#if __FreeBSD__ == 4 -error "No, in FreeBSD 4.0 recursive mutexes actually don't work." -#elif (defined __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ \ - && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1070) -error "No, in Mac OS X < 10.7 recursive mutexes actually don't work." -#else -int x = (int)PTHREAD_MUTEX_RECURSIVE; -return !x; -#endif - ]])], - [AC_DEFINE([HAVE_PTHREAD_MUTEX_RECURSIVE], [1], - [Define if the <pthread.h> defines PTHREAD_MUTEX_RECURSIVE.])]) - fi - gl_PREREQ_LOCK -]) - -# Prerequisites of lib/glthread/lock.c. -AC_DEFUN([gl_PREREQ_LOCK], [:]) diff --git a/m4/mkdir.m4 b/m4/mkdir.m4 new file mode 100644 index 000000000..51e78c13d --- /dev/null +++ b/m4/mkdir.m4 @@ -0,0 +1,69 @@ +# serial 11 + +# Copyright (C) 2001, 2003-2004, 2006, 2008-2014 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. + +# On some systems, mkdir ("foo/", 0700) fails because of the trailing slash. +# On others, mkdir ("foo/./", 0700) mistakenly succeeds. +# On such systems, arrange to use a wrapper function. +AC_DEFUN([gl_FUNC_MKDIR], +[dnl + AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CHECK_HEADERS_ONCE([unistd.h]) + AC_CACHE_CHECK([whether mkdir handles trailing slash], + [gl_cv_func_mkdir_trailing_slash_works], + [rm -rf conftest.dir + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +# include <sys/types.h> +# include <sys/stat.h> +]], [return mkdir ("conftest.dir/", 0700);])], + [gl_cv_func_mkdir_trailing_slash_works=yes], + [gl_cv_func_mkdir_trailing_slash_works=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_mkdir_trailing_slash_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_mkdir_trailing_slash_works="guessing no" ;; + esac + ]) + rm -rf conftest.dir + ] + ) + case "$gl_cv_func_mkdir_trailing_slash_works" in + *yes) ;; + *) + REPLACE_MKDIR=1 + ;; + esac + + AC_CACHE_CHECK([whether mkdir handles trailing dot], + [gl_cv_func_mkdir_trailing_dot_works], + [rm -rf conftest.dir + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +# include <sys/types.h> +# include <sys/stat.h> +]], [return !mkdir ("conftest.dir/./", 0700);])], + [gl_cv_func_mkdir_trailing_dot_works=yes], + [gl_cv_func_mkdir_trailing_dot_works=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_mkdir_trailing_dot_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_mkdir_trailing_dot_works="guessing no" ;; + esac + ]) + rm -rf conftest.dir + ] + ) + case "$gl_cv_func_mkdir_trailing_dot_works" in + *yes) ;; + *) + REPLACE_MKDIR=1 + AC_DEFINE([FUNC_MKDIR_DOT_BUG], [1], [Define to 1 if mkdir mistakenly + creates a directory given with a trailing dot component.]) + ;; + esac +]) diff --git a/m4/mkstemp.m4 b/m4/mkstemp.m4 new file mode 100644 index 000000000..9033a4e60 --- /dev/null +++ b/m4/mkstemp.m4 @@ -0,0 +1,82 @@ +#serial 23 + +# Copyright (C) 2001, 2003-2007, 2009-2014 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. + +# On some hosts (e.g., HP-UX 10.20, SunOS 4.1.4, Solaris 2.5.1), mkstemp has a +# silly limit that it can create no more than 26 files from a given template. +# Other systems lack mkstemp altogether. +# On OSF1/Tru64 V4.0F, the system-provided mkstemp function can create +# only 32 files per process. +# On some hosts, mkstemp creates files with mode 0666, which is a security +# problem and a violation of POSIX 2008. +# On systems like the above, arrange to use the replacement function. +AC_DEFUN([gl_FUNC_MKSTEMP], +[ + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + + AC_CHECK_FUNCS_ONCE([mkstemp]) + if test $ac_cv_func_mkstemp = yes; then + AC_CACHE_CHECK([for working mkstemp], + [gl_cv_func_working_mkstemp], + [ + mkdir conftest.mkstemp + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [AC_INCLUDES_DEFAULT], + [[int result = 0; + int i; + off_t large = (off_t) 4294967295u; + if (large < 0) + large = 2147483647; + umask (0); + for (i = 0; i < 70; i++) + { + char templ[] = "conftest.mkstemp/coXXXXXX"; + int (*mkstemp_function) (char *) = mkstemp; + int fd = mkstemp_function (templ); + if (fd < 0) + result |= 1; + else + { + struct stat st; + if (lseek (fd, large, SEEK_SET) != large) + result |= 2; + if (fstat (fd, &st) < 0) + result |= 4; + else if (st.st_mode & 0077) + result |= 8; + if (close (fd)) + result |= 16; + } + } + return result;]])], + [gl_cv_func_working_mkstemp=yes], + [gl_cv_func_working_mkstemp=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_working_mkstemp="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_working_mkstemp="guessing no" ;; + esac + ]) + rm -rf conftest.mkstemp + ]) + case "$gl_cv_func_working_mkstemp" in + *yes) ;; + *) + REPLACE_MKSTEMP=1 + ;; + esac + else + HAVE_MKSTEMP=0 + fi +]) + +# Prerequisites of lib/mkstemp.c. +AC_DEFUN([gl_PREREQ_MKSTEMP], +[ +]) diff --git a/m4/secure_getenv.m4 b/m4/secure_getenv.m4 new file mode 100644 index 000000000..149888df4 --- /dev/null +++ b/m4/secure_getenv.m4 @@ -0,0 +1,25 @@ +# Look up an environment variable more securely. +dnl Copyright 2013-2014 Free Software Foundation, Inc. +dnl This file is free software; the Free 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_SECURE_GETENV], +[ + dnl Persuade glibc <stdlib.h> to declare secure_getenv(). + AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) + + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([secure_getenv]) + if test $ac_cv_func_secure_getenv = no; then + HAVE_SECURE_GETENV=0 + fi +]) + +# Prerequisites of lib/secure_getenv.c. +AC_DEFUN([gl_PREREQ_SECURE_GETENV], [ + AC_CHECK_FUNCS([__secure_getenv]) + if test $ac_cv_func___secure_getenv = no; then + AC_CHECK_FUNCS([issetugid]) + fi +]) diff --git a/m4/strdup.m4 b/m4/strdup.m4 new file mode 100644 index 000000000..1681a30eb --- /dev/null +++ b/m4/strdup.m4 @@ -0,0 +1,36 @@ +# strdup.m4 serial 13 + +dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. + +dnl This file is free software; the Free 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_STRDUP], +[ + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([strdup]) + AC_CHECK_DECLS_ONCE([strdup]) + if test $ac_cv_have_decl_strdup = no; then + HAVE_DECL_STRDUP=0 + fi +]) + +AC_DEFUN([gl_FUNC_STRDUP_POSIX], +[ + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + AC_REQUIRE([gl_CHECK_MALLOC_POSIX]) + AC_CHECK_FUNCS_ONCE([strdup]) + if test $ac_cv_func_strdup = yes; then + if test $gl_cv_func_malloc_posix != yes; then + REPLACE_STRDUP=1 + fi + fi + AC_CHECK_DECLS_ONCE([strdup]) + if test $ac_cv_have_decl_strdup = no; then + HAVE_DECL_STRDUP=0 + fi +]) + +# Prerequisites of lib/strdup.c. +AC_DEFUN([gl_PREREQ_STRDUP], [:]) diff --git a/m4/tempname.m4 b/m4/tempname.m4 new file mode 100644 index 000000000..1594e1f5d --- /dev/null +++ b/m4/tempname.m4 @@ -0,0 +1,19 @@ +#serial 5 + +# Copyright (C) 2006-2007, 2009-2014 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. + +# glibc provides __gen_tempname as a wrapper for mk[ds]temp. Expose +# it as a public API, and provide it on systems that are lacking. +AC_DEFUN([gl_FUNC_GEN_TEMPNAME], +[ + gl_PREREQ_TEMPNAME +]) + +# Prerequisites of lib/tempname.c. +AC_DEFUN([gl_PREREQ_TEMPNAME], +[ + : +]) diff --git a/m4/threadlib.m4 b/m4/threadlib.m4 deleted file mode 100644 index a88170261..000000000 --- a/m4/threadlib.m4 +++ /dev/null @@ -1,371 +0,0 @@ -# threadlib.m4 serial 10 (gettext-0.18.2) -dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. -dnl This file is free software; the Free 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 From Bruno Haible. - -dnl gl_THREADLIB -dnl ------------ -dnl Tests for a multithreading library to be used. -dnl If the configure.ac contains a definition of the gl_THREADLIB_DEFAULT_NO -dnl (it must be placed before the invocation of gl_THREADLIB_EARLY!), then the -dnl default is 'no', otherwise it is system dependent. In both cases, the user -dnl can change the choice through the options --enable-threads=choice or -dnl --disable-threads. -dnl Defines at most one of the macros USE_POSIX_THREADS, USE_SOLARIS_THREADS, -dnl USE_PTH_THREADS, USE_WINDOWS_THREADS -dnl Sets the variables LIBTHREAD and LTLIBTHREAD to the linker options for use -dnl in a Makefile (LIBTHREAD for use without libtool, LTLIBTHREAD for use with -dnl libtool). -dnl Sets the variables LIBMULTITHREAD and LTLIBMULTITHREAD similarly, for -dnl programs that really need multithread functionality. The difference -dnl between LIBTHREAD and LIBMULTITHREAD is that on platforms supporting weak -dnl symbols, typically LIBTHREAD="" whereas LIBMULTITHREAD="-lpthread". -dnl Adds to CPPFLAGS the flag -D_REENTRANT or -D_THREAD_SAFE if needed for -dnl multithread-safe programs. - -AC_DEFUN([gl_THREADLIB_EARLY], -[ - AC_REQUIRE([gl_THREADLIB_EARLY_BODY]) -]) - -dnl The guts of gl_THREADLIB_EARLY. Needs to be expanded only once. - -AC_DEFUN([gl_THREADLIB_EARLY_BODY], -[ - dnl Ordering constraints: This macro modifies CPPFLAGS in a way that - dnl influences the result of the autoconf tests that test for *_unlocked - dnl declarations, on AIX 5 at least. Therefore it must come early. - AC_BEFORE([$0], [gl_FUNC_GLIBC_UNLOCKED_IO])dnl - AC_BEFORE([$0], [gl_ARGP])dnl - - AC_REQUIRE([AC_CANONICAL_HOST]) - dnl _GNU_SOURCE is needed for pthread_rwlock_t on glibc systems. - dnl AC_USE_SYSTEM_EXTENSIONS was introduced in autoconf 2.60 and obsoletes - dnl AC_GNU_SOURCE. - m4_ifdef([AC_USE_SYSTEM_EXTENSIONS], - [AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])], - [AC_REQUIRE([AC_GNU_SOURCE])]) - dnl Check for multithreading. - m4_ifdef([gl_THREADLIB_DEFAULT_NO], - [m4_divert_text([DEFAULTS], [gl_use_threads_default=no])], - [m4_divert_text([DEFAULTS], [gl_use_threads_default=])]) - AC_ARG_ENABLE([threads], -AC_HELP_STRING([--enable-threads={posix|solaris|pth|windows}], [specify multithreading API])m4_ifdef([gl_THREADLIB_DEFAULT_NO], [], [ -AC_HELP_STRING([--disable-threads], [build without multithread safety])]), - [gl_use_threads=$enableval], - [if test -n "$gl_use_threads_default"; then - gl_use_threads="$gl_use_threads_default" - else -changequote(,)dnl - case "$host_os" in - dnl Disable multithreading by default on OSF/1, because it interferes - dnl with fork()/exec(): When msgexec is linked with -lpthread, its - dnl child process gets an endless segmentation fault inside execvp(). - dnl Disable multithreading by default on Cygwin 1.5.x, because it has - dnl bugs that lead to endless loops or crashes. See - dnl <http://cygwin.com/ml/cygwin/2009-08/msg00283.html>. - osf*) gl_use_threads=no ;; - cygwin*) - case `uname -r` in - 1.[0-5].*) gl_use_threads=no ;; - *) gl_use_threads=yes ;; - esac - ;; - *) gl_use_threads=yes ;; - esac -changequote([,])dnl - fi - ]) - if test "$gl_use_threads" = yes || test "$gl_use_threads" = posix; then - # For using <pthread.h>: - case "$host_os" in - osf*) - # On OSF/1, the compiler needs the flag -D_REENTRANT so that it - # groks <pthread.h>. cc also understands the flag -pthread, but - # we don't use it because 1. gcc-2.95 doesn't understand -pthread, - # 2. putting a flag into CPPFLAGS that has an effect on the linker - # causes the AC_LINK_IFELSE test below to succeed unexpectedly, - # leading to wrong values of LIBTHREAD and LTLIBTHREAD. - CPPFLAGS="$CPPFLAGS -D_REENTRANT" - ;; - esac - # Some systems optimize for single-threaded programs by default, and - # need special flags to disable these optimizations. For example, the - # definition of 'errno' in <errno.h>. - case "$host_os" in - aix* | freebsd*) CPPFLAGS="$CPPFLAGS -D_THREAD_SAFE" ;; - solaris*) CPPFLAGS="$CPPFLAGS -D_REENTRANT" ;; - esac - fi -]) - -dnl The guts of gl_THREADLIB. Needs to be expanded only once. - -AC_DEFUN([gl_THREADLIB_BODY], -[ - AC_REQUIRE([gl_THREADLIB_EARLY_BODY]) - gl_threads_api=none - LIBTHREAD= - LTLIBTHREAD= - LIBMULTITHREAD= - LTLIBMULTITHREAD= - if test "$gl_use_threads" != no; then - dnl Check whether the compiler and linker support weak declarations. - AC_CACHE_CHECK([whether imported symbols can be declared weak], - [gl_cv_have_weak], - [gl_cv_have_weak=no - dnl First, test whether the compiler accepts it syntactically. - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[extern void xyzzy (); -#pragma weak xyzzy]], - [[xyzzy();]])], - [gl_cv_have_weak=maybe]) - if test $gl_cv_have_weak = maybe; then - dnl Second, test whether it actually works. On Cygwin 1.7.2, with - dnl gcc 4.3, symbols declared weak always evaluate to the address 0. - AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ -#include <stdio.h> -#pragma weak fputs -int main () -{ - return (fputs == NULL); -}]])], - [gl_cv_have_weak=yes], - [gl_cv_have_weak=no], - [dnl When cross-compiling, assume that only ELF platforms support - dnl weak symbols. - AC_EGREP_CPP([Extensible Linking Format], - [#ifdef __ELF__ - Extensible Linking Format - #endif - ], - [gl_cv_have_weak="guessing yes"], - [gl_cv_have_weak="guessing no"]) - ]) - fi - ]) - if test "$gl_use_threads" = yes || test "$gl_use_threads" = posix; then - # On OSF/1, the compiler needs the flag -pthread or -D_REENTRANT so that - # it groks <pthread.h>. It's added above, in gl_THREADLIB_EARLY_BODY. - AC_CHECK_HEADER([pthread.h], - [gl_have_pthread_h=yes], [gl_have_pthread_h=no]) - if test "$gl_have_pthread_h" = yes; then - # Other possible tests: - # -lpthreads (FSU threads, PCthreads) - # -lgthreads - gl_have_pthread= - # Test whether both pthread_mutex_lock and pthread_mutexattr_init exist - # in libc. IRIX 6.5 has the first one in both libc and libpthread, but - # the second one only in libpthread, and lock.c needs it. - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[#include <pthread.h>]], - [[pthread_mutex_lock((pthread_mutex_t*)0); - pthread_mutexattr_init((pthread_mutexattr_t*)0);]])], - [gl_have_pthread=yes]) - # Test for libpthread by looking for pthread_kill. (Not pthread_self, - # since it is defined as a macro on OSF/1.) - if test -n "$gl_have_pthread"; then - # The program links fine without libpthread. But it may actually - # need to link with libpthread in order to create multiple threads. - AC_CHECK_LIB([pthread], [pthread_kill], - [LIBMULTITHREAD=-lpthread LTLIBMULTITHREAD=-lpthread - # On Solaris and HP-UX, most pthread functions exist also in libc. - # Therefore pthread_in_use() needs to actually try to create a - # thread: pthread_create from libc will fail, whereas - # pthread_create will actually create a thread. - case "$host_os" in - solaris* | hpux*) - AC_DEFINE([PTHREAD_IN_USE_DETECTION_HARD], [1], - [Define if the pthread_in_use() detection is hard.]) - esac - ]) - else - # Some library is needed. Try libpthread and libc_r. - AC_CHECK_LIB([pthread], [pthread_kill], - [gl_have_pthread=yes - LIBTHREAD=-lpthread LTLIBTHREAD=-lpthread - LIBMULTITHREAD=-lpthread LTLIBMULTITHREAD=-lpthread]) - if test -z "$gl_have_pthread"; then - # For FreeBSD 4. - AC_CHECK_LIB([c_r], [pthread_kill], - [gl_have_pthread=yes - LIBTHREAD=-lc_r LTLIBTHREAD=-lc_r - LIBMULTITHREAD=-lc_r LTLIBMULTITHREAD=-lc_r]) - fi - fi - if test -n "$gl_have_pthread"; then - gl_threads_api=posix - AC_DEFINE([USE_POSIX_THREADS], [1], - [Define if the POSIX multithreading library can be used.]) - if test -n "$LIBMULTITHREAD" || test -n "$LTLIBMULTITHREAD"; then - if case "$gl_cv_have_weak" in *yes) true;; *) false;; esac; then - AC_DEFINE([USE_POSIX_THREADS_WEAK], [1], - [Define if references to the POSIX multithreading library should be made weak.]) - LIBTHREAD= - LTLIBTHREAD= - fi - fi - fi - fi - fi - if test -z "$gl_have_pthread"; then - if test "$gl_use_threads" = yes || test "$gl_use_threads" = solaris; then - gl_have_solaristhread= - gl_save_LIBS="$LIBS" - LIBS="$LIBS -lthread" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[ -#include <thread.h> -#include <synch.h> - ]], - [[thr_self();]])], - [gl_have_solaristhread=yes]) - LIBS="$gl_save_LIBS" - if test -n "$gl_have_solaristhread"; then - gl_threads_api=solaris - LIBTHREAD=-lthread - LTLIBTHREAD=-lthread - LIBMULTITHREAD="$LIBTHREAD" - LTLIBMULTITHREAD="$LTLIBTHREAD" - AC_DEFINE([USE_SOLARIS_THREADS], [1], - [Define if the old Solaris multithreading library can be used.]) - if case "$gl_cv_have_weak" in *yes) true;; *) false;; esac; then - AC_DEFINE([USE_SOLARIS_THREADS_WEAK], [1], - [Define if references to the old Solaris multithreading library should be made weak.]) - LIBTHREAD= - LTLIBTHREAD= - fi - fi - fi - fi - if test "$gl_use_threads" = pth; then - gl_save_CPPFLAGS="$CPPFLAGS" - AC_LIB_LINKFLAGS([pth]) - gl_have_pth= - gl_save_LIBS="$LIBS" - LIBS="$LIBS $LIBPTH" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([[#include <pth.h>]], [[pth_self();]])], - [gl_have_pth=yes]) - LIBS="$gl_save_LIBS" - if test -n "$gl_have_pth"; then - gl_threads_api=pth - LIBTHREAD="$LIBPTH" - LTLIBTHREAD="$LTLIBPTH" - LIBMULTITHREAD="$LIBTHREAD" - LTLIBMULTITHREAD="$LTLIBTHREAD" - AC_DEFINE([USE_PTH_THREADS], [1], - [Define if the GNU Pth multithreading library can be used.]) - if test -n "$LIBMULTITHREAD" || test -n "$LTLIBMULTITHREAD"; then - if case "$gl_cv_have_weak" in *yes) true;; *) false;; esac; then - AC_DEFINE([USE_PTH_THREADS_WEAK], [1], - [Define if references to the GNU Pth multithreading library should be made weak.]) - LIBTHREAD= - LTLIBTHREAD= - fi - fi - else - CPPFLAGS="$gl_save_CPPFLAGS" - fi - fi - if test -z "$gl_have_pthread"; then - case "$gl_use_threads" in - yes | windows | win32) # The 'win32' is for backward compatibility. - if { case "$host_os" in - mingw*) true;; - *) false;; - esac - }; then - gl_threads_api=windows - AC_DEFINE([USE_WINDOWS_THREADS], [1], - [Define if the native Windows multithreading API can be used.]) - fi - ;; - esac - fi - fi - AC_MSG_CHECKING([for multithread API to use]) - AC_MSG_RESULT([$gl_threads_api]) - AC_SUBST([LIBTHREAD]) - AC_SUBST([LTLIBTHREAD]) - AC_SUBST([LIBMULTITHREAD]) - AC_SUBST([LTLIBMULTITHREAD]) -]) - -AC_DEFUN([gl_THREADLIB], -[ - AC_REQUIRE([gl_THREADLIB_EARLY]) - AC_REQUIRE([gl_THREADLIB_BODY]) -]) - - -dnl gl_DISABLE_THREADS -dnl ------------------ -dnl Sets the gl_THREADLIB default so that threads are not used by default. -dnl The user can still override it at installation time, by using the -dnl configure option '--enable-threads'. - -AC_DEFUN([gl_DISABLE_THREADS], [ - m4_divert_text([INIT_PREPARE], [gl_use_threads_default=no]) -]) - - -dnl Survey of platforms: -dnl -dnl Platform Available Compiler Supports test-lock -dnl flavours option weak result -dnl --------------- --------- --------- -------- --------- -dnl Linux 2.4/glibc posix -lpthread Y OK -dnl -dnl GNU Hurd/glibc posix -dnl -dnl FreeBSD 5.3 posix -lc_r Y -dnl posix -lkse ? Y -dnl posix -lpthread ? Y -dnl posix -lthr Y -dnl -dnl FreeBSD 5.2 posix -lc_r Y -dnl posix -lkse Y -dnl posix -lthr Y -dnl -dnl FreeBSD 4.0,4.10 posix -lc_r Y OK -dnl -dnl NetBSD 1.6 -- -dnl -dnl OpenBSD 3.4 posix -lpthread Y OK -dnl -dnl Mac OS X 10.[123] posix -lpthread Y OK -dnl -dnl Solaris 7,8,9 posix -lpthread Y Sol 7,8: 0.0; Sol 9: OK -dnl solaris -lthread Y Sol 7,8: 0.0; Sol 9: OK -dnl -dnl HP-UX 11 posix -lpthread N (cc) OK -dnl Y (gcc) -dnl -dnl IRIX 6.5 posix -lpthread Y 0.5 -dnl -dnl AIX 4.3,5.1 posix -lpthread N AIX 4: 0.5; AIX 5: OK -dnl -dnl OSF/1 4.0,5.1 posix -pthread (cc) N OK -dnl -lpthread (gcc) Y -dnl -dnl Cygwin posix -lpthread Y OK -dnl -dnl Any of the above pth -lpth 0.0 -dnl -dnl Mingw windows N OK -dnl -dnl BeOS 5 -- -dnl -dnl The test-lock result shows what happens if in test-lock.c EXPLICIT_YIELD is -dnl turned off: -dnl OK if all three tests terminate OK, -dnl 0.5 if the first test terminates OK but the second one loops endlessly, -dnl 0.0 if the first test already loops endlessly. @@ -76,7 +76,7 @@ _dot_escaped_srcdir = $(subst .,\.,$(srcdir)) ifeq ($(srcdir),.) _prepend_srcdir_prefix = else - _prepend_srcdir_prefix = | sed 's|^|$(srcdir)/|' + _prepend_srcdir_prefix = | $(SED) 's|^|$(srcdir)/|' endif # In order to be able to consistently filter "."-relative names, @@ -85,7 +85,7 @@ endif _sc_excl = \ $(or $(exclude_file_name_regexp--$@),^$$) VC_LIST_EXCEPT = \ - $(VC_LIST) | sed 's|^$(_dot_escaped_srcdir)/||' \ + $(VC_LIST) | $(SED) 's|^$(_dot_escaped_srcdir)/||' \ | if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \ else grep -Ev -e "$${VC_LIST_EXCEPT_DEFAULT-ChangeLog}"; fi \ | grep -Ev -e '($(VC_LIST_ALWAYS_EXCLUDE_REGEX)|$(_sc_excl))' \ @@ -158,8 +158,8 @@ export LC_ALL = C _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' \ - $(srcdir)/$(ME) $(_cfg_mk))) +syntax-check-rules := $(sort $(shell $(SED) -n \ + 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' $(srcdir)/$(ME) $(_cfg_mk))) .PHONY: $(syntax-check-rules) ifeq ($(shell $(VC_LIST) >/dev/null 2>&1; echo $$?),0) @@ -448,7 +448,7 @@ sc_require_config_h_first: @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ fail=0; \ for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \ - grep '^# *include\>' $$i | sed 1q \ + grep '^# *include\>' $$i | $(SED) 1q \ | grep -E '^# *include $(config_h_header)' > /dev/null \ || { echo $$i; fail=1; }; \ done; \ @@ -468,7 +468,7 @@ sc_prohibit_HAVE_MBRTOWC: # re: a regular expression that matches IFF something provided by $h is used. define _sc_header_without_use dummy=; : so we do not need a semicolon before each use; \ - h_esc=`echo '[<"]'"$$h"'[">]'|sed 's/\./\\\\./g'`; \ + h_esc=`echo '[<"]'"$$h"'[">]'|$(SED) 's/\./\\\\./g'`; \ if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ files=$$(grep -l '^# *include '"$$h_esc" \ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \ @@ -789,7 +789,7 @@ sc_useless_cpp_parens: # #if HAVE_HEADER_H that you remove, be sure that your project explicitly # requires the gnulib module that guarantees the usability of that header. gl_assured_headers_ = \ - cd $(gnulib_dir)/lib && echo *.in.h|sed 's/\.in\.h//g' + cd $(gnulib_dir)/lib && echo *.in.h|$(SED) 's/\.in\.h//g' # Convert the list of names to upper case, and replace each space with "|". az_ = abcdefghijklmnopqrstuvwxyz @@ -840,7 +840,7 @@ define def_sym_regex && perl -lne '$(gl_extract_significant_defines_)' $$f; \ done; \ ) | sort -u \ - | sed 's/^/^ *# *(define|undef) */;s/$$/\\>/' + | $(SED) 's/^/^ *# *(define|undef) */;s/$$/\\>/' endef # Don't define macros that we already get from gnulib header files. @@ -1054,12 +1054,12 @@ sc_const_long_option: $(_sc_search_regexp) NEWS_hash = \ - $$(sed -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \ + $$($(SED) -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \ $(srcdir)/NEWS \ | perl -0777 -pe \ 's/^Copyright.+?Free\sSoftware\sFoundation,\sInc\.\n//ms' \ | md5sum - \ - | sed 's/ .*//') + | $(SED) 's/ .*//') # Ensure that we don't accidentally insert an entry into an old NEWS block. sc_immutable_NEWS: @@ -1097,7 +1097,7 @@ sc_makefile_at_at_check: && { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || : news-check: NEWS - $(AM_V_GEN)if sed -n $(news-check-lines-spec)p $< \ + $(AM_V_GEN)if $(SED) -n $(news-check-lines-spec)p $< \ | grep -E $(news-check-regexp) >/dev/null; then \ :; \ else \ @@ -1146,7 +1146,7 @@ sc_po_check: files="$$files $$file"; \ done; \ grep -E -l '$(_gl_translatable_string_re)' $$files \ - | sed 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \ + | $(SED) 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \ diff -u -L $(po_file) -L $(po_file) $@-1 $@-2 \ || { printf '$(ME): '$(fix_po_file_diag) 1>&2; exit 1; }; \ rm -f $@-1 $@-2; \ @@ -1511,7 +1511,7 @@ refresh-gnulib-patches: test -n "$$t" && gl=$$t; \ fi; \ for diff in $$(cd $$gl; git ls-files | grep '\.diff$$'); do \ - b=$$(printf %s "$$diff"|sed 's/\.diff$$//'); \ + b=$$(printf %s "$$diff"|$(SED) 's/\.diff$$//'); \ VERSION_CONTROL=none \ patch "$(gnulib_dir)/$$b" "$$gl/$$diff" || exit 1; \ ( cd $(gnulib_dir) || exit 1; \ @@ -1530,7 +1530,8 @@ refresh-po: wget --no-verbose --directory-prefix $(PODIR) --no-directories --recursive --level 1 --accept .po --accept .po.1 $(POURL) && \ echo 'en@boldquot' > $(PODIR)/LINGUAS && \ echo 'en@quot' >> $(PODIR)/LINGUAS && \ - ls $(PODIR)/*.po | sed 's/\.po//;s,$(PODIR)/,,' | sort >> $(PODIR)/LINGUAS + ls $(PODIR)/*.po | $(SED) 's/\.po//;s,$(PODIR)/,,' | \ + sort >> $(PODIR)/LINGUAS # Running indent once is not idempotent, but running it twice is. INDENT_SOURCES ?= $(C_SOURCES) @@ -1640,18 +1641,18 @@ _gl_tight_scope: $(bin_PROGRAMS) test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ grep -h -A1 '^extern .*[^;]$$' $$src \ - | grep -vE '^(extern |--)' | sed 's/ .*//'; \ + | grep -vE '^(extern |--)' | $(SED) 's/ .*//'; \ perl -lne \ '$(_gl_TS_function_match) and print "^$$1\$$"' $$hdr; \ ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files) | sed -n 's/.* T //p'|grep -Ev -f $$t \ + nm -e $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ && { echo the above functions should have static scope >&2; \ exit 1; } || : ; \ ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \ perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \ $$hdr $(_gl_TS_other_headers) \ ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files) | sed -n 's/.* [BCDGRS] //p' \ + nm -e $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ | sort -u | grep -Ev -f $$t \ && { echo the above variables should have static scope >&2; \ exit 1; } || : diff --git a/module/Makefile.am b/module/Makefile.am index a6b20aff9..abc8a7363 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -202,6 +202,7 @@ SYSTEM_BASE_SOURCES = \ system/base/lalr.scm \ system/base/message.scm \ system/base/target.scm \ + system/base/types.scm \ system/base/ck.scm ICE_9_SOURCES = \ @@ -386,7 +387,8 @@ SYSTEM_SOURCES = \ system/repl/common.scm \ system/repl/command.scm \ system/repl/repl.scm \ - system/repl/server.scm + system/repl/server.scm \ + system/repl/coop-server.scm LIB_SOURCES = \ statprof.scm \ diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 9c9694fd7..133e9c9b5 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -1,6 +1,6 @@ ;;;; ftw.scm --- file system tree walk -;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014 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 @@ -259,7 +259,8 @@ (let* ((perms (stat:perms s)) (perms-bit-set? (lambda (mask) (not (= 0 (logand mask perms)))))) - (or (and (= uid (stat:uid s)) + (or (zero? uid) + (and (= uid (stat:uid s)) (perms-bit-set? #o400)) (and (= gid (stat:gid s)) (perms-bit-set? #o040)) diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm index 031628b38..5eb396f0e 100644 --- a/module/rnrs/io/simple.scm +++ b/module/rnrs/io/simple.scm @@ -1,6 +1,6 @@ ;;; simple.scm --- The R6RS simple I/O library -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2014 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 @@ -91,6 +91,7 @@ eof-object eof-object? file-options + buffer-mode native-transcoder get-char lookahead-char @@ -131,10 +132,16 @@ (lambda (port) (with-output-to-port port thunk)))) (define (open-input-file filename) - (open-file-input-port filename (file-options) (native-transcoder))) + (open-file-input-port filename + (file-options) + (buffer-mode block) + (native-transcoder))) (define (open-output-file filename) - (open-file-output-port filename (file-options) (native-transcoder))) + (open-file-output-port filename + (file-options) + (buffer-mode block) + (native-transcoder))) (define close-input-port close-port) (define close-output-port close-port) diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm index 6ca07a1f4..82d71f4a9 100644 --- a/module/scripts/snarf-check-and-output-texi.scm +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -1,6 +1,6 @@ ;;; snarf-check-and-output-texi --- called by the doc snarfer. -;; Copyright (C) 2001, 2002, 2006, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2011, 2014 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 @@ -63,7 +63,7 @@ (let loop ((s s)) (cond ((stream-null? s) #t) - ((eq? 'eol (stream-car s)) + ((memq (stream-car s) '(eol hash)) (loop (stream-cdr s))) (else (cons (stream-car s) (stream-cdr s)))))) (port->stream port read))))) @@ -265,17 +265,6 @@ (set! *file* file) (set! *line* line)) - ;; newer gccs like to throw around more location markers into the - ;; preprocessed source; these (hash . hash) bits are what they translate to - ;; in snarfy terms. - (('location ('string . file) ('int . line) ('hash . 'hash)) - (set! *file* file) - (set! *line* line)) - - (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash)) - (set! *file* file) - (set! *line* line)) - (('arglist rest ...) (set! *args* (do-arglist rest))) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 684a1254e..832b43606 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -1,6 +1,6 @@ ;;; srfi-18.scm --- Multithreading support -;; Copyright (C) 2008, 2009, 2010, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2009, 2010, 2012, 2014 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 @@ -82,7 +82,7 @@ uncaught-exception? uncaught-exception-reason ) - :re-export (thread? mutex? condition-variable?) + :re-export (current-thread thread? mutex? condition-variable?) :replace (current-time make-thread make-mutex @@ -236,7 +236,7 @@ (list timeout) '())))) (secs (inexact->exact (truncate t))) - (usecs (inexact->exact (truncate (* (- t secs) 1000))))) + (usecs (inexact->exact (truncate (* (- t secs) 1000000))))) (and (> secs 0) (sleep secs)) (and (> usecs 0) (usleep usecs)) *unspecified*)) @@ -380,4 +380,4 @@ (cons (inexact->exact fx) (inexact->exact (truncate (* (- x fx) 1000000))))))) -;; srfi-18.scm ends here
\ No newline at end of file +;; srfi-18.scm ends here diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index c0a27b1a2..6d86ee638 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1,6 +1,7 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, +;; 2011, 2014 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 @@ -171,7 +172,7 @@ ;; A table of leap seconds ;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat ;; and update as necessary. -;; this procedures reads the file in the abover +;; this procedures reads the file in the above ;; format and creates the leap second table ;; it also calls the almost standard, but not R5 procedures read-line ;; & open-input-string @@ -202,7 +203,9 @@ ;; each entry is (tai seconds since epoch . # seconds to subtract for utc) ;; note they go higher to lower, and end in 1972. (define leap-second-table - '((1136073600 . 33) + '((1341100800 . 35) + (1230768000 . 34) + (1136073600 . 33) (915148800 . 32) (867715200 . 31) (820454400 . 30) diff --git a/module/system/base/types.scm b/module/system/base/types.scm new file mode 100644 index 000000000..6c1d40d7f --- /dev/null +++ b/module/system/base/types.scm @@ -0,0 +1,529 @@ +;;; 'SCM' type tag decoding. +;;; Copyright (C) 2014 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 program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (system base types) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-60) + #:use-module (ice-9 match) + #:use-module (ice-9 iconv) + #:use-module (ice-9 format) + #:use-module (ice-9 vlist) + #:use-module (system foreign) + #:export (%word-size + + memory-backend + memory-backend? + %ffi-memory-backend + dereference-word + memory-port + type-number->name + + inferior-object? + inferior-object-kind + inferior-object-sub-kind + inferior-object-address + + inferior-fluid? + inferior-fluid-number + + inferior-struct? + inferior-struct-name + inferior-struct-fields + + scm->object)) + +;;; Commentary: +;;; +;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB. +;;; +;;; Code: + + +;;; +;;; Memory back-ends. +;;; + +(define %word-size + ;; The pointer size. + (sizeof '*)) + +(define-record-type <memory-backend> + (memory-backend peek open type-name) + memory-backend? + (peek memory-backend-peek) + (open memory-backend-open) + (type-name memory-backend-type-name)) ; for SMOBs and ports + +(define %ffi-memory-backend + ;; The FFI back-end to access the current process's memory. The main + ;; purpose of this back-end is to allow testing. + (let () + (define (dereference-word address) + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + + (define (open address size) + (define current-address address) + + (define (read-memory! bv index count) + (let* ((ptr (make-pointer current-address)) + (mem (pointer->bytevector ptr count))) + (bytevector-copy! mem 0 bv index count) + (set! current-address (+ current-address count)) + count)) + + (if size + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr size))) + (open-bytevector-input-port bv)) + (let ((port (make-custom-binary-input-port "ffi-memory" + read-memory! + #f #f #f))) + (setvbuf port _IONBF) + port))) + + (memory-backend dereference-word open #f))) + +(define-inlinable (dereference-word backend address) + "Return the word at ADDRESS, using BACKEND." + (let ((peek (memory-backend-peek backend))) + (peek address))) + +(define-syntax memory-port + (syntax-rules () + "Return an input port to the SIZE bytes at ADDRESS, using BACKEND. When +SIZE is omitted, return an unbounded port to the memory at ADDRESS." + ((_ backend address) + (let ((open (memory-backend-open backend))) + (open address #f))) + ((_ backend address size) + (let ((open (memory-backend-open backend))) + (open address size))))) + +(define (get-word port) + "Read a word from PORT and return it as an integer." + (let ((bv (get-bytevector-n port %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + +(define-inlinable (type-number->name backend kind number) + "Return the name of the type NUMBER of KIND, where KIND is one of +'smob or 'port, or #f if the information is unavailable." + (let ((proc (memory-backend-type-name backend))) + (and proc (proc kind number)))) + + +;;; +;;; Matching bit patterns and cells. +;;; + +(define-syntax match-cell-words + (syntax-rules (bytevector) + ((_ port ((bytevector name len) rest ...) body) + (let ((name (get-bytevector-n port len)) + (remainder (modulo len %word-size))) + (unless (zero? remainder) + (get-bytevector-n port (- %word-size remainder))) + (match-cell-words port (rest ...) body))) + ((_ port (name rest ...) body) + (let ((name (get-word port))) + (match-cell-words port (rest ...) body))) + ((_ port () body) + body))) + +(define-syntax match-bit-pattern + (syntax-rules (& || = _) + ((match-bit-pattern bits ((a || b) & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + (let ((b tag) + (a (logand bits (bitwise-not n)))) + consequent) + alternate))) + ((match-bit-pattern bits (x & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + (let ((x bits)) + consequent) + alternate))) + ((match-bit-pattern bits (_ & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + consequent + alternate))) + ((match-bit-pattern bits ((a << n) || c) consequent alternate) + (let ((tag (bitwise-and bits (- (expt 2 n) 1)))) + (if (= tag c) + (let ((a (arithmetic-shift bits (- n)))) + consequent) + alternate))))) + +(define-syntax match-cell-clauses + (syntax-rules () + ((_ port tag (((tag-pattern thing ...) body) rest ...)) + (match-bit-pattern tag tag-pattern + (match-cell-words port (thing ...) body) + (match-cell-clauses port tag (rest ...)))) + ((_ port tag ()) + (inferior-object 'unmatched-tag tag)))) + +(define-syntax match-cell + (syntax-rules () + "Match a cell---i.e., a non-immediate value other than a pair. The +cell's contents are read from PORT." + ((_ port (pattern body ...) ...) + (let ((port* port) + (tag (get-word port))) + (match-cell-clauses port* tag + ((pattern (begin body ...)) + ...)))))) + +(define-syntax match-scm-clauses + (syntax-rules () + ((_ bits + (bit-pattern body ...) + rest ...) + (match-bit-pattern bits bit-pattern + (begin body ...) + (match-scm-clauses bits rest ...))) + ((_ bits) + 'unmatched-scm))) + +(define-syntax match-scm + (syntax-rules () + "Match BITS, an integer representation of an 'SCM' value, against +CLAUSES. Each clause must have the form: + + (PATTERN BODY ...) + +PATTERN is a bit pattern that may specify bitwise operations on BITS to +determine if it matches. TEMPLATE specify the name of the variable to bind +the matching bits, possibly with bitwise operations to extract it from BITS." + ((_ bits clauses ...) + (let ((bits* bits)) + (match-scm-clauses bits* clauses ...))))) + + +;;; +;;; Tags---keep in sync with libguile/tags.h! +;;; + +;; Immediate values. +(define %tc2-int 2) +(define %tc3-imm24 4) + +(define %tc3-cons 0) +(define %tc3-int1 %tc2-int) +(define %tc3-int2 (+ %tc2-int 4)) + +(define %tc8-char (+ 8 %tc3-imm24)) +(define %tc8-flag (+ %tc3-imm24 0)) + +;; Cell types. +(define %tc3-struct 1) +(define %tc7-symbol 5) +(define %tc7-vector 13) +(define %tc7-wvect 15) +(define %tc7-string 21) +(define %tc7-number 23) +(define %tc7-hashtable 29) +(define %tc7-pointer 31) +(define %tc7-fluid 37) +(define %tc7-stringbuf 39) +(define %tc7-dynamic-state 45) +(define %tc7-frame 47) +(define %tc7-program 69) +(define %tc7-vm-continuation 71) +(define %tc7-bytevector 77) +(define %tc7-weak-set 85) +(define %tc7-weak-table 87) +(define %tc7-array 93) +(define %tc7-bitvector 95) +(define %tc7-port 125) +(define %tc7-smob 127) + +(define %tc16-bignum (+ %tc7-number (* 1 256))) +(define %tc16-real (+ %tc7-number (* 2 256))) +(define %tc16-complex (+ %tc7-number (* 3 256))) +(define %tc16-fraction (+ %tc7-number (* 4 256))) + + +;; "Stringbufs". +(define-record-type <stringbuf> + (stringbuf string) + stringbuf? + (string stringbuf-contents)) + +(set-record-type-printer! <stringbuf> + (lambda (stringbuf port) + (display "#<stringbuf " port) + (write (stringbuf-contents stringbuf) port) + (display "#>" port))) + +;; Structs. +(define-record-type <inferior-struct> + (inferior-struct name fields) + inferior-struct? + (name inferior-struct-name) + (fields inferior-struct-fields set-inferior-struct-fields!)) + +(define print-inferior-struct + (let ((%printed-struct (make-parameter vlist-null))) + (lambda (struct port) + (if (vhash-assq struct (%printed-struct)) + (format port "#-1#") + (begin + (format port "#<struct ~a" + (inferior-struct-name struct)) + (parameterize ((%printed-struct + (vhash-consq struct #t (%printed-struct)))) + (for-each (lambda (field) + (if (eq? field struct) + (display " #0#" port) + (format port " ~s" field))) + (inferior-struct-fields struct))) + (format port " ~x>" (object-address struct))))))) + +(set-record-type-printer! <inferior-struct> print-inferior-struct) + +;; Fluids. +(define-record-type <inferior-fluid> + (inferior-fluid number value) + inferior-fluid? + (number inferior-fluid-number) + (value inferior-fluid-value)) + +(set-record-type-printer! <inferior-fluid> + (lambda (fluid port) + (match fluid + (($ <inferior-fluid> number) + (format port "#<fluid ~a ~x>" + number + (object-address fluid)))))) + +;; Object type to represent complex objects from the inferior process that +;; cannot be really converted to usable Scheme objects in the current +;; process. +(define-record-type <inferior-object> + (%inferior-object kind sub-kind address) + inferior-object? + (kind inferior-object-kind) + (sub-kind inferior-object-sub-kind) + (address inferior-object-address)) + +(define inferior-object + (case-lambda + "Return an object representing an inferior object at ADDRESS, of type +KIND/SUB-KIND." + ((kind address) + (%inferior-object kind #f address)) + ((kind sub-kind address) + (%inferior-object kind sub-kind address)))) + +(set-record-type-printer! <inferior-object> + (lambda (io port) + (match io + (($ <inferior-object> kind sub-kind address) + (format port "#<~a ~:[~*~;~a ~]~x>" + kind sub-kind sub-kind + address))))) + +(define (inferior-smob backend type-number address) + "Return an object representing the SMOB at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'smob + (or (type-number->name backend 'smob type-number) + type-number) + address)) + +(define (inferior-port backend type-number address) + "Return an object representing the port at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'port + (or (type-number->name backend 'port type-number) + type-number) + address)) + +(define %visited-cells + ;; Vhash of mapping addresses of already visited cells to the + ;; corresponding inferior object. This is used to detect and represent + ;; cycles. + (make-parameter vlist-null)) + +(define-syntax visited + (syntax-rules (->) + ((_ (address -> object) body ...) + (parameterize ((%visited-cells (vhash-consv address object + (%visited-cells)))) + body ...)))) + +(define (address->inferior-struct address vtable-data-address backend) + "Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct' +object representing it." + (define %vtable-layout-index 0) + (define %vtable-name-index 5) + + (let* ((layout-address (+ vtable-data-address + (* %vtable-layout-index %word-size))) + (layout-bits (dereference-word backend layout-address)) + (layout (scm->object layout-bits backend)) + (name-address (+ vtable-data-address + (* %vtable-name-index %word-size))) + (name-bits (dereference-word backend name-address)) + (name (scm->object name-bits backend))) + (if (symbol? layout) + (let* ((layout (symbol->string layout)) + (len (/ (string-length layout) 2)) + (slots (dereference-word backend (+ address %word-size))) + (port (memory-port backend slots (* len %word-size))) + (fields (get-bytevector-n port (* len %word-size))) + (result (inferior-struct name #f))) + + ;; Keep track of RESULT so callees can refer to it if we are + ;; decoding a circular struct. + (visited (address -> result) + (let ((values (map (cut scm->object <> backend) + (bytevector->uint-list fields + (native-endianness) + %word-size)))) + (set-inferior-struct-fields! result values) + result))) + (inferior-object 'invalid-struct address)))) + +(define* (cell->object address #:optional (backend %ffi-memory-backend)) + "Return an object representing the object at ADDRESS, reading from memory +using BACKEND." + (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object + (let ((port (memory-port backend address))) + (match-cell port + (((vtable-data-address & 7 = %tc3-struct)) + (address->inferior-struct address + (- vtable-data-address %tc3-struct) + backend)) + (((_ & #x7f = %tc7-symbol) buf hash props) + (match (cell->object buf backend) + (($ <stringbuf> string) + (string->symbol string)))) + (((_ & #x7f = %tc7-string) buf start len) + (match (cell->object buf backend) + (($ <stringbuf> string) + (substring string start (+ start len))))) + (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len)) + (stringbuf (bytevector->string buf "ISO-8859-1"))) + (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf)) + len (bytevector buf (* 4 len))) + (stringbuf (bytevector->string buf (match (native-endianness) + ('little "UTF-32LE") + ('big "UTF-32BE"))))) + (((_ & #x7f = %tc7-bytevector) len address) + (let ((bv-port (memory-port backend address len))) + (get-bytevector-all bv-port))) + ((((len << 8) || %tc7-vector)) + (let ((words (get-bytevector-n port (* len %word-size))) + (vector (make-vector len))) + (visited (address -> vector) + (fold (lambda (element index) + (vector-set! vector index element) + (+ 1 index)) + 0 + (map (cut scm->object <> backend) + (bytevector->uint-list words (native-endianness) + %word-size))) + vector))) + (((_ & #x7f = %tc7-wvect)) + (inferior-object 'weak-vector address)) ; TODO: show elements + ((((n << 8) || %tc7-fluid) init-value) + (inferior-fluid n #f)) ; TODO: show current value + (((_ & #x7f = %tc7-dynamic-state)) + (inferior-object 'dynamic-state address)) + ((((flags+type << 8) || %tc7-port)) + (inferior-port backend (logand flags+type #xff) address)) + (((_ & #x7f = %tc7-program)) + (inferior-object 'program address)) + (((_ & #xffff = %tc16-bignum)) + (inferior-object 'bignum address)) + (((_ & #xffff = %tc16-real) pad) + (let* ((address (+ address (* 2 %word-size))) + (port (memory-port backend address (sizeof double))) + (words (get-bytevector-n port (sizeof double)))) + (bytevector-ieee-double-ref words 0 (native-endianness)))) + (((_ & #x7f = %tc7-number) mpi) + (inferior-object 'number address)) + (((_ & #x7f = %tc7-hashtable) buckets meta-data unused) + (inferior-object 'hash-table address)) + (((_ & #x7f = %tc7-pointer) address) + (make-pointer address)) + (((_ & #x7f = %tc7-vm-continuation)) + (inferior-object 'vm-continuation address)) + (((_ & #x7f = %tc7-weak-set)) + (inferior-object 'weak-set address)) + (((_ & #x7f = %tc7-weak-table)) + (inferior-object 'weak-table address)) + (((_ & #x7f = %tc7-array)) + (inferior-object 'array address)) + (((_ & #x7f = %tc7-bitvector)) + (inferior-object 'bitvector address)) + ((((smob-type << 8) || %tc7-smob) word1) + (inferior-smob backend smob-type address)))))) + + +(define* (scm->object bits #:optional (backend %ffi-memory-backend)) + "Return the Scheme object corresponding to BITS, the bits of an 'SCM' +object." + (match-scm bits + (((integer << 2) || %tc2-int) + integer) + ((address & 6 = %tc3-cons) + (let* ((type (dereference-word backend address)) + (pair? (not (bit-set? 0 type)))) + (if pair? + (or (and=> (vhash-assv address (%visited-cells)) cdr) + (let ((car type) + (cdrloc (+ address %word-size)) + (pair (cons *unspecified* *unspecified*))) + (visited (address -> pair) + (set-car! pair (scm->object car backend)) + (set-cdr! pair + (scm->object (dereference-word backend cdrloc) + backend)) + pair))) + (cell->object address backend)))) + (((char << 8) || %tc8-char) + (integer->char char)) + (((flag << 8) || %tc8-flag) + (case flag + ((0) #f) + ((1) #nil) + ((3) '()) + ((4) #t) + ((8) (if #f #f)) + ((9) (inferior-object 'undefined bits)) + ((10) (eof-object)) + ((11) (inferior-object 'unbound bits)))))) + +;;; Local Variables: +;;; eval: (put 'match-scm 'scheme-indent-function 1) +;;; eval: (put 'match-cell 'scheme-indent-function 1) +;;; eval: (put 'visited 'scheme-indent-function 1) +;;; End: + +;;; types.scm ends here diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm new file mode 100644 index 000000000..c19dda191 --- /dev/null +++ b/module/system/repl/coop-server.scm @@ -0,0 +1,193 @@ +;;; Cooperative REPL server + +;; Copyright (C) 2014 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 (system repl coop-server) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 threads) + #:use-module (ice-9 q) + #:use-module (srfi srfi-9) + #:use-module ((system repl repl) + #:select (start-repl* prompting-meta-read)) + #:use-module ((system repl server) + #:select (run-server* make-tcp-server-socket + add-open-socket! close-socket!)) + #:export (spawn-coop-repl-server + poll-coop-repl-server)) + +(define-record-type <coop-repl-server> + (%make-coop-repl-server mutex queue) + coop-repl-server? + (mutex coop-repl-server-mutex) + (queue coop-repl-server-queue)) + +(define (make-coop-repl-server) + (%make-coop-repl-server (make-mutex) (make-q))) + +(define (coop-repl-server-eval coop-server opcode . args) + "Queue a new instruction with the symbolic name OPCODE and an arbitrary +number of arguments, to be processed the next time COOP-SERVER is polled." + (with-mutex (coop-repl-server-mutex coop-server) + (enq! (coop-repl-server-queue coop-server) + (cons opcode args)))) + +(define-record-type <coop-repl> + (%make-coop-repl mutex condvar thunk cont) + coop-repl? + (mutex coop-repl-mutex) + (condvar coop-repl-condvar) ; signaled when thunk becomes non-#f + (thunk coop-repl-read-thunk set-coop-repl-read-thunk!) + (cont coop-repl-cont set-coop-repl-cont!)) + +(define (make-coop-repl) + (%make-coop-repl (make-mutex) (make-condition-variable) #f #f)) + +(define (coop-repl-read coop-repl) + "Read an expression via the thunk stored in COOP-REPL." + (let ((thunk + (with-mutex (coop-repl-mutex coop-repl) + (unless (coop-repl-read-thunk coop-repl) + (wait-condition-variable (coop-repl-condvar coop-repl) + (coop-repl-mutex coop-repl))) + (let ((thunk (coop-repl-read-thunk coop-repl))) + (unless thunk + (error "coop-repl-read: condvar signaled, but thunk is #f!")) + (set-coop-repl-read-thunk! coop-repl #f) + thunk)))) + (thunk))) + +(define (store-repl-cont cont coop-repl) + "Save the partial continuation CONT within COOP-REPL." + (set-coop-repl-cont! coop-repl + (lambda (exp) + (coop-repl-prompt + (lambda () (cont exp)))))) + +(define (coop-repl-prompt thunk) + "Apply THUNK within a prompt for cooperative REPLs." + (call-with-prompt 'coop-repl-prompt thunk store-repl-cont)) + +(define (make-coop-reader coop-repl) + "Return a new procedure for reading user input from COOP-REPL. The +generated procedure passes the responsibility of reading input to +another thread and aborts the cooperative REPL prompt." + (lambda (repl) + (let ((read-thunk + ;; Need to preserve the REPL stack and current module across + ;; threads. + (let ((stack (fluid-ref *repl-stack*)) + (module (current-module))) + (lambda () + (with-fluids ((*repl-stack* stack)) + (set-current-module module) + (prompting-meta-read repl)))))) + (with-mutex (coop-repl-mutex coop-repl) + (when (coop-repl-read-thunk coop-repl) + (error "coop-reader: read-thunk is not #f!")) + (set-coop-repl-read-thunk! coop-repl read-thunk) + (signal-condition-variable (coop-repl-condvar coop-repl)))) + (abort-to-prompt 'coop-repl-prompt coop-repl))) + +(define (reader-loop coop-server coop-repl) + "Run an unbounded loop that reads an expression for COOP-REPL and +stores the expression within COOP-SERVER for later evaluation." + (coop-repl-server-eval coop-server 'eval coop-repl + (coop-repl-read coop-repl)) + (reader-loop coop-server coop-repl)) + +(define (poll-coop-repl-server coop-server) + "Poll the cooperative REPL server COOP-SERVER and apply a pending +operation if there is one, such as evaluating an expression typed at the +REPL prompt. This procedure must be called from the same thread that +called spawn-coop-repl-server." + (let ((op (with-mutex (coop-repl-server-mutex coop-server) + (let ((queue (coop-repl-server-queue coop-server))) + (and (not (q-empty? queue)) + (deq! queue)))))) + (when op + (match op + (('new-repl client) + (start-repl-client coop-server client)) + (('eval coop-repl exp) + ((coop-repl-cont coop-repl) exp)))) + *unspecified*)) + +(define (start-coop-repl coop-server) + "Start a new cooperative REPL process for COOP-SERVER." + ;; Calling stop-server-and-clients! from a REPL will cause an + ;; exception to be thrown when trying to read from the socket that has + ;; been closed, so we catch that here. + (false-if-exception + (let ((coop-repl (make-coop-repl))) + (make-thread reader-loop coop-server coop-repl) + (start-repl* (current-language) #f (make-coop-reader coop-repl))))) + +(define (run-coop-repl-server coop-server server-socket) + "Start the cooperative REPL server for COOP-SERVER using the socket +SERVER-SOCKET." + (run-server* server-socket (make-coop-client-proc coop-server))) + +(define* (spawn-coop-repl-server + #:optional (server-socket (make-tcp-server-socket))) + "Create and return a new cooperative REPL server object, and spawn a +new thread to listen for connections on SERVER-SOCKET. Proper +functioning of the REPL server requires that poll-coop-repl-server be +called periodically on the returned server object." + (let ((coop-server (make-coop-repl-server))) + (make-thread run-coop-repl-server + coop-server + server-socket) + coop-server)) + +(define (make-coop-client-proc coop-server) + "Return a new procedure that is used to schedule the creation of a new +cooperative REPL for COOP-SERVER." + (lambda (client addr) + (coop-repl-server-eval coop-server 'new-repl client))) + +(define (start-repl-client coop-server client) + "Run a cooperative REPL for COOP-SERVER within a prompt. All input +and output is sent over the socket CLIENT." + + ;; Add the client to the list of open sockets, with a 'force-close' + ;; procedure that closes the underlying file descriptor. We do it + ;; this way because we cannot close the port itself safely from + ;; another thread. + (add-open-socket! client (lambda () (close-fdes (fileno client)))) + + (with-continuation-barrier + (lambda () + (coop-repl-prompt + (lambda () + (parameterize ((current-input-port client) + (current-output-port client) + (current-error-port client) + (current-warning-port client)) + (with-fluids ((*repl-stack* '())) + (save-module-excursion + (lambda () + (start-coop-repl coop-server))))) + + ;; This may fail if 'stop-server-and-clients!' is called, + ;; because the 'force-close' procedure above closes the + ;; underlying file descriptor instead of the port itself. + (false-if-exception + (close-socket! client))))))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 16495560c..5b27125f1 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -1,6 +1,7 @@ ;;; Read-Eval-Print Loop -;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2011, 2013, +;; 2014 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 @@ -107,6 +108,8 @@ ;; to be able to re-use the existing readline machinery. ;; ;; Catches read errors, returning *unspecified* in that case. +;; +;; Note: although not exported, this is used by (system repl coop-server) (define (prompting-meta-read repl) (catch #t (lambda () @@ -129,10 +132,14 @@ ;;; (define* (start-repl #:optional (lang (current-language)) #:key debug) + (start-repl* lang debug prompting-meta-read)) + +;; Note: although not exported, this is used by (system repl coop-server) +(define (start-repl* lang debug prompting-meta-read) ;; ,language at the REPL will update the current-language. Make ;; sure that it does so in a new dynamic scope. (parameterize ((current-language lang)) - (run-repl (make-repl lang debug)))) + (run-repl* (make-repl lang debug) prompting-meta-read))) ;; (put 'abort-on-error 'scheme-indent-function 1) (define-syntax-rule (abort-on-error string exp) @@ -144,6 +151,9 @@ (abort)))) (define (run-repl repl) + (run-repl* repl prompting-meta-read)) + +(define (run-repl* repl prompting-meta-read) (define (with-stack-and-prompt thunk) (call-with-prompt (default-prompt-tag) (lambda () (start-stack #t (thunk))) diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index 4f3391c0b..ff9ee5cbc 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -22,34 +22,45 @@ (define-module (system repl server) #:use-module (system repl repl) #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (make-tcp-server-socket make-unix-domain-server-socket run-server spawn-server stop-server-and-clients!)) +;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a +;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down +;; the socket. (define *open-sockets* '()) (define sockets-lock (make-mutex)) +;; WARNING: it is unsafe to call 'close-socket!' from another thread. +;; Note: although not exported, this is used by (system repl coop-server) (define (close-socket! s) (with-mutex sockets-lock - (set! *open-sockets* (delq! s *open-sockets*))) + (set! *open-sockets* (assq-remove! *open-sockets* s))) ;; Close-port could block or raise an exception flushing buffered ;; output. Hmm. (close-port s)) -(define (add-open-socket! s) +;; Note: although not exported, this is used by (system repl coop-server) +(define (add-open-socket! s force-close) (with-mutex sockets-lock - (set! *open-sockets* (cons s *open-sockets*)))) + (set! *open-sockets* (acons s force-close *open-sockets*)))) (define (stop-server-and-clients!) (cond ((with-mutex sockets-lock - (and (pair? *open-sockets*) - (car *open-sockets*))) - => (lambda (s) - (close-socket! s) + (match *open-sockets* + (() #f) + (((s . force-close) . rest) + (set! *open-sockets* rest) + force-close))) + => (lambda (force-close) + (force-close) (stop-server-and-clients!))))) (define* (make-tcp-server-socket #:key @@ -67,37 +78,82 @@ (bind sock AF_UNIX path) sock)) +;; List of errno values from 'select' or 'accept' that should lead to a +;; retry in 'run-server'. +(define errs-to-retry + (delete-duplicates + (filter-map (lambda (name) + (and=> (module-variable the-root-module name) + variable-ref)) + '(EINTR EAGAIN EWOULDBLOCK)))) + (define* (run-server #:optional (server-socket (make-tcp-server-socket))) + (run-server* server-socket serve-client)) + +;; Note: although not exported, this is used by (system repl coop-server) +(define (run-server* server-socket serve-client) + ;; We use a pipe to notify the server when it should shut down. + (define shutdown-pipes (pipe)) + (define shutdown-read-pipe (car shutdown-pipes)) + (define shutdown-write-pipe (cdr shutdown-pipes)) + + ;; 'shutdown-server' is called by 'stop-server-and-clients!'. + (define (shutdown-server) + (display #\! shutdown-write-pipe) + (force-output shutdown-write-pipe)) + + (define monitored-ports + (list server-socket + shutdown-read-pipe)) + (define (accept-new-client) (catch #t - (lambda () (accept server-socket)) - (lambda (k . args) - (cond - ((port-closed? server-socket) - ;; Shutting down. - #f) - (else - (warn "Error accepting client" k args) - ;; Retry after a timeout. - (sleep 1) - (accept-new-client)))))) - + (lambda () + (let ((ready-ports (car (select monitored-ports '() '())))) + ;; If we've been asked to shut down, return #f. + (and (not (memq shutdown-read-pipe ready-ports)) + (accept server-socket)))) + (lambda k-args + (let ((err (system-error-errno k-args))) + (cond + ((memv err errs-to-retry) + (accept-new-client)) + (else + (warn "Error accepting client" k-args) + ;; Retry after a timeout. + (sleep 1) + (accept-new-client))))))) + + ;; Put the socket into non-blocking mode. + (fcntl server-socket F_SETFL + (logior O_NONBLOCK + (fcntl server-socket F_GETFL))) + (sigaction SIGPIPE SIG_IGN) - (add-open-socket! server-socket) + (add-open-socket! server-socket shutdown-server) (listen server-socket 5) (let lp ((client (accept-new-client))) ;; If client is false, we are shutting down. (if client (let ((client-socket (car client)) (client-addr (cdr client))) - (add-open-socket! client-socket) (make-thread serve-client client-socket client-addr) - (lp (accept-new-client)))))) + (lp (accept-new-client))) + (begin (close shutdown-write-pipe) + (close shutdown-read-pipe) + (close server-socket))))) (define* (spawn-server #:optional (server-socket (make-tcp-server-socket))) (make-thread run-server server-socket)) (define (serve-client client addr) + + (let ((thread (current-thread))) + ;; Close the socket when this thread exits, even if canceled. + (set-thread-cleanup! thread (lambda () (close-socket! client))) + ;; Arrange to cancel this thread to forcefully shut down the socket. + (add-open-socket! client (lambda () (cancel-thread thread)))) + (with-continuation-barrier (lambda () (parameterize ((current-input-port client) @@ -105,5 +161,4 @@ (current-error-port client) (current-warning-port client)) (with-fluids ((*repl-stack* '())) - (start-repl))))) - (close-socket! client)) + (start-repl)))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 05e713406..c38d12ba0 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -36,12 +36,17 @@ SCM_TESTS = tests/00-initial-env.test \ tests/chars.test \ tests/coding.test \ tests/common-list.test \ + tests/compiler.test \ tests/control.test \ tests/continuations.test \ tests/coverage.test \ tests/cross-compilation.test \ tests/curried-definitions.test \ tests/dwarf.test \ + tests/encoding-escapes.test \ + tests/encoding-iso88591.test \ + tests/encoding-iso88597.test \ + tests/encoding-utf8.test \ tests/ecmascript.test \ tests/elisp.test \ tests/elisp-compiler.test \ @@ -77,6 +82,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/numbers.test \ tests/optargs.test \ tests/options.test \ + tests/pairs.test \ tests/parameters.test \ tests/peg.test \ tests/peval.test \ @@ -113,12 +119,14 @@ SCM_TESTS = tests/00-initial-env.test \ tests/random.test \ tests/rdelim.test \ tests/reader.test \ + tests/records.test \ tests/receive.test \ tests/regexp.test \ tests/rtl.test \ tests/rtl-compilation.test \ tests/session.test \ tests/signals.test \ + tests/sort.test \ tests/srcprop.test \ tests/srfi-1.test \ tests/srfi-6.test \ @@ -126,6 +134,8 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-11.test \ tests/srfi-13.test \ tests/srfi-14.test \ + tests/srfi-17.test \ + tests/srfi-18.test \ tests/srfi-19.test \ tests/srfi-26.test \ tests/srfi-27.test \ @@ -144,11 +154,13 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-67.test \ tests/srfi-69.test \ tests/srfi-88.test \ + tests/srfi-98.test \ tests/srfi-105.test \ tests/srfi-111.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ + tests/streams.test \ tests/strings.test \ tests/structs.test \ tests/sxml.fold.test \ @@ -167,9 +179,12 @@ SCM_TESTS = tests/00-initial-env.test \ tests/threads.test \ tests/time.test \ tests/tree-il.test \ + tests/types.test \ tests/version.test \ + tests/vectors.test \ tests/vlist.test \ tests/weaks.test \ + tests/web-client.test \ tests/web-http.test \ tests/web-request.test \ tests/web-response.test \ diff --git a/test-suite/guile-test b/test-suite/guile-test index 43ea48174..4a264b426 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -239,9 +239,10 @@ (lambda () (for-each (lambda (test) (display (string-append "Running " test "\n")) - (with-locale "C" - (with-test-prefix test - (load (test-file-name test))))) + (when (defined? 'setlocale) + (setlocale LC_ALL "C")) + (with-test-prefix test + (load (test-file-name test)))) tests)))) (if (opt 'coverage #f) (let-values (((coverage-data _) @@ -263,5 +264,4 @@ ;;; Local Variables: ;;; mode: scheme -;;; eval: (put 'with-locale 'scheme-indent-function 1) ;;; End: diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index d2f430050..fa77925d9 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -139,7 +139,7 @@ TESTS += test-list # test-unwind test_unwind_SOURCES = test-unwind.c test_unwind_CFLAGS = ${test_cflags} -test_unwind_LDADD = $(LIBGUILE_LDADD) +test_unwind_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la check_PROGRAMS += test-unwind TESTS += test-unwind @@ -211,6 +211,13 @@ test_scm_c_bind_keyword_arguments_LDADD = $(LIBGUILE_LDADD) check_PROGRAMS += test-scm-c-bind-keyword-arguments TESTS += test-scm-c-bind-keyword-arguments +# test-srfi-4 +test_srfi_4_SOURCES = test-srfi-4.c +test_srfi_4_CFLAGS = ${test_cflags} +test_srfi_4_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-srfi-4 +TESTS += test-srfi-4 + if HAVE_SHARED_LIBRARIES # test-extensions diff --git a/test-suite/standalone/test-loose-ends.c b/test-suite/standalone/test-loose-ends.c index b4ea5b94a..40b358b99 100644 --- a/test-suite/standalone/test-loose-ends.c +++ b/test-suite/standalone/test-loose-ends.c @@ -3,7 +3,7 @@ * Test items of the Guile C API that aren't covered by any other tests. */ -/* Copyright (C) 2009, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2012, 2014 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 +#undef NDEBUG + #include <libguile.h> #include <stdio.h> diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index c8dc3a7e4..f5cd87938 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -1,5 +1,5 @@ /* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011 - * 2012 Free Software Foundation, Inc. + * 2012, 2014 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 @@ -21,6 +21,8 @@ # include <config.h> #endif +#undef NDEBUG + #include <libguile.h> #include <stdio.h> diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index 150c8816e..2cd6fd54e 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2004, 2006, 2008, 2009, 2011, 2014 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 @@ -20,6 +20,8 @@ # include <config.h> #endif +#undef NDEBUG + #include <assert.h> #include <math.h> #include <stdio.h> diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index ad0722ce8..f4cd53d84 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2013 Free Software Foundation, Inc. +/* Copyright (C) 2013, 2014 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 @@ -20,6 +20,8 @@ # include <config.h> #endif +#undef NDEBUG + #include <libguile.h> #include <assert.h> diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 4111cd0f5..5f11e7565 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2008 Free Software Foundation, Inc. +/* Copyright (C) 2008, 2014 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 @@ -23,6 +23,8 @@ # include <config.h> #endif +#undef NDEBUG + #include <libguile.h> #include <assert.h> diff --git a/test-suite/standalone/test-scm-values.c b/test-suite/standalone/test-scm-values.c index ece62dab6..06f57bedd 100644 --- a/test-suite/standalone/test-scm-values.c +++ b/test-suite/standalone/test-scm-values.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2012 Free Software Foundation, Inc. +/* Copyright (C) 2012, 2014 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 @@ -20,6 +20,8 @@ # include <config.h> #endif +#undef NDEBUG + #include <assert.h> #include <libguile.h> #include <stdlib.h> diff --git a/test-suite/standalone/test-smob-mark.c b/test-suite/standalone/test-smob-mark.c index d9db9a651..86566af76 100644 --- a/test-suite/standalone/test-smob-mark.c +++ b/test-suite/standalone/test-smob-mark.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2013 Free Software Foundation, Inc. +/* Copyright (C) 2013, 2014 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 @@ -20,6 +20,8 @@ #include <config.h> #endif +#undef NDEBUG + #include <assert.h> #include <libguile.h> #include <stdio.h> diff --git a/test-suite/standalone/test-srfi-4.c b/test-suite/standalone/test-srfi-4.c new file mode 100644 index 000000000..b49e666cc --- /dev/null +++ b/test-suite/standalone/test-srfi-4.c @@ -0,0 +1,90 @@ +/* Copyright (C) 2014 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 + +/* Make sure the assertions are tested. */ +#undef NDEBUG + +#include <libguile.h> + +#include <stdio.h> +#include <assert.h> + +static void +test_writable_elements () +{ + SCM elts = scm_list_4 (scm_from_int (1), scm_from_int (2), + scm_from_int (3), scm_from_int (4)); + + { + SCM v = scm_u32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + scm_t_uint32 *elts = scm_u32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1); + assert (elts[3] == 4); + scm_array_handle_release (&h); + } + + { + SCM v = scm_f32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + float *elts = scm_f32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1.0); + assert (elts[3] == 4.0); + scm_array_handle_release (&h); + } + + { + SCM v = scm_c32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + float *elts = scm_c32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1.0); + assert (elts[1] == 0.0); + assert (elts[6] == 4.0); + assert (elts[7] == 0.0); + scm_array_handle_release (&h); + } +} + +static void +tests (void *data, int argc, char **argv) +{ + test_writable_elements (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index 334984703..cc31942cc 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -24,6 +24,22 @@ #:use-module (ice-9 format)) +(with-test-prefix "simple-format" + (pass-if-exception "current-output-port is closed" + exception:wrong-type-arg + ;; This used to segfault in Guile <= 2.0.10. + (let ((old (current-output-port)) + (new (%make-void-port "w"))) + (dynamic-wind + (lambda () + (set-current-output-port new) + (close-port new)) + (lambda () + (simple-format #t "hello, closed port!") + #t) + (lambda () + (set-current-output-port old)))))) + ;;; FORMAT Basic Output (with-test-prefix "format basic output" diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 64d10bb38..4c21d7129 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -347,3 +347,15 @@ (pass-if (equal? 2 (hash-count (lambda (k v) (string? v)) table))))) + +;;; +;;; weak key hash table +;;; + +(with-test-prefix "weak key hash table" + (pass-if "hash-for-each after gc" + (let ((table (make-weak-key-hash-table))) + (hashq-set! table (list 'foo) 'bar) + (gc) + ;; Iterate over deleted weak ref without crashing. + (unspecified? (hash-for-each (lambda (key value) key) table))))) diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index 47f8f7f40..ab055132e 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -96,6 +96,12 @@ (let ((old-secs (car (current-time)))) (unspecified? (thread-sleep! (+ (time->seconds (current-time))))))) + (pass-if "thread sleeps fractions of a second" + (let* ((current (time->seconds (current-time))) + (future (+ current 0.5))) + (thread-sleep! future) + (>= (time->seconds (current-time)) future))) + (pass-if "thread does not sleep on past time" (let ((past-time (seconds->time (- (time->seconds (current-time)) 2)))) (unspecified? (thread-sleep! past-time))))) @@ -479,4 +485,4 @@ (eq? (uncaught-exception-reason obj) 'foo) (set! success #t))) (lambda () (thread-join! t))) - success)))))
\ No newline at end of file + success))))) diff --git a/test-suite/tests/srfi-60.test b/test-suite/tests/srfi-60.test index 940934f3e..1c91943a4 100644 --- a/test-suite/tests/srfi-60.test +++ b/test-suite/tests/srfi-60.test @@ -268,27 +268,74 @@ ;; (with-test-prefix "rotate-bit-field" - (pass-if (eqv? #b110 (rotate-bit-field #b110 1 1 2))) - (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4))) - (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4))) - - (pass-if (eqv? #b0 (rotate-bit-field #b0 128 0 256))) - (pass-if (eqv? #b1 (rotate-bit-field #b1 128 1 256))) - (pass-if - (eqv? #x100000000000000000000000000000000 - (rotate-bit-field #x100000000000000000000000000000000 128 0 64))) - (pass-if - (eqv? #x100000000000000000000000000000008 - (rotate-bit-field #x100000000000000000000000000000001 3 0 64))) - (pass-if - (eqv? #x100000000000000002000000000000000 - (rotate-bit-field #x100000000000000000000000000000001 -3 0 64))) - - (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10))) - (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256))) - - (pass-if "bignum becomes inum" - (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129)))) + (define-syntax-rule (check expected x count start end) + (begin + (pass-if-equal expected (rotate-bit-field x count start end)) + (pass-if-equal (lognot expected) + (rotate-bit-field (lognot x) count start end)))) + + (check #b110 #b110 1 1 2) + (check #b1010 #b110 1 2 4) + (check #b1011 #b0111 -1 1 4) + + (check #b0 #b0 128 0 256) + (check #b1 #b1 128 1 256) + (check #x100000000000000000000000000000000 + #x100000000000000000000000000000000 128 0 64) + (check #x100000000000000000000000000000008 + #x100000000000000000000000000000001 3 0 64) + (check #x100000000000000002000000000000000 + #x100000000000000000000000000000001 -3 0 64) + + (check #b110 #b110 0 0 10) + (check #b110 #b110 0 0 256) + + (check #b110 #b110 1 1 1) + + (check #b10111010001100111101110010101 + #b11010001100111101110001110101 -26 5 28) + (check #b11000110011110111000111011001 + #b11010001100111101110001110101 28 2 28) + + (check #b01111010001100111101110010101 + #b11010001100111101110001110101 -3 5 29) + (check #b10100011001111011100011101101 + #b11010001100111101110001110101 28 2 29) + + (check #b110110100011001111011100010101 + #b011010001100111101110001110101 48 5 30) + (check #b110100011001111011100011101001 + #b011010001100111101110001110101 85 2 30) + (check #b011010001100111101110001110101 + #b110100011001111011100011101001 83 2 30) + + (check + #b1101100110101001110000111110011010000111011101011101110111011 + #b1100110101001110000111110011010000111011101011101110110111011 -3 5 60) + (check + #b1011010100111000011111001101000011101110101110111011011101110 + #b1100110101001110000111110011010000111011101011101110110111011 62 0 60) + + (check + #b1011100110101001110000111110011010000111011101011101110111011 + #b1100110101001110000111110011010000111011101011101110110111011 53 5 61) + (check + #b1001101010011100001111100110100001110111010111011101101110111 + #b1100110101001110000111110011010000111011101011101110110111011 62 0 61) + + (check + #b11011001101010011100001111100110100001110111010111011100111011 + #b01100110101001110000111110011010000111011101011101110110111011 53 7 62) + (check + #b11011001101010011100001111100110100001110111010111011100111011 + #b01100110101001110000111110011010000111011101011101110110111011 -2 7 62) + (check + #b01100110101001110000111110011010000111011101011101110110111011 + #b11011001101010011100001111100110100001110111010111011100111011 2 7 62) + + (pass-if-equal "bignum becomes inum" + 1 + (rotate-bit-field #x100000000000000000000000000000000 1 0 129))) ;; ;; reverse-bit-field diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test new file mode 100644 index 000000000..ea71d3ceb --- /dev/null +++ b/test-suite/tests/types.test @@ -0,0 +1,160 @@ +;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;;; +;;;; This file is part of GNU Guile. +;;;; +;;;; GNU Guile 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. +;;;; +;;;; GNU Guile 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/>. + +(define-module (test-types) + #:use-module (test-suite lib) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 weak-vector) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:use-module (system vm vm) + #:use-module (system base types)) + +(define-syntax test-cloneable + (syntax-rules () + "Test whether each simple OBJECT is properly decoded." + ((_ object rest ...) + (begin + (let ((obj object)) + (pass-if-equal (object->string obj) obj + (scm->object (object-address obj)))) + (test-cloneable rest ...))) + ((_) + *unspecified*))) + +;; Test objects that can be directly cloned. +(with-test-prefix "clonable objects" + (test-cloneable + #t #f #nil (if #f #f) (eof-object) + 42 (expt 2 28) 3.14 + "narrow string" "wide στρινγ" + 'symbol 'λ + ;; NB: keywords are SMOBs. + '(2 . 3) (iota 123) '(1 (two ("three"))) + #(1 2 3) #(foo bar baz) + #vu8(255 254 253) + (make-pointer 123) (make-pointer #xdeadbeef))) + +;; Circular objects cannot be compared with 'equal?', so here's their +;; home. +(with-test-prefix "clonable circular objects" + + (pass-if "list" + (let* ((lst (circular-list 0 1)) + (result (scm->object (object-address lst)))) + (match result + ((0 1 . self) + (eq? self result))))) + + (pass-if "vector" + (define (circular-vector) + (let ((v (make-vector 3 'hey))) + (vector-set! v 2 v) + v)) + + (let* ((vec (circular-vector)) + (result (scm->object (object-address vec)))) + (match result + (#('hey 'hey self) + (eq? self result)))))) + +(define-syntax test-inferior-objects + (syntax-rules () + "Test whether each OBJECT is recognized and wrapped as an +'inferior-object'." + ((_ (object kind sub-kind-pattern) rest ...) + (begin + (let ((obj object)) + (pass-if (object->string obj) + (let ((result (scm->object (object-address obj)))) + (and (inferior-object? result) + (eq? 'kind (inferior-object-kind result)) + (match (inferior-object-sub-kind result) + (sub-kind-pattern #t) + (_ #f)))))) + (test-inferior-objects rest ...))) + ((_) + *unspecified*))) + +(with-test-prefix "opaque objects" + (test-inferior-objects + ((make-guardian) smob (? integer?)) + (#:keyword smob (? integer?)) + ((%make-void-port "w") port (? integer?)) + ((open-input-string "hello") port (? integer?)) + ((lambda () #t) program _) + ((make-weak-vector 3 #t) weak-vector _) + ((make-weak-key-hash-table) weak-table _) + ((make-weak-value-hash-table) weak-table _) + ((make-doubly-weak-hash-table) weak-table _) + (#2((1 2 3) (4 5 6)) array _) + (#*00000110 bitvector _) + ((expt 2 70) bignum _)) + + (pass-if "fluid" + (let ((fluid (make-fluid))) + (inferior-fluid? (scm->object (object-address fluid)))))) + +(define-record-type <some-struct> + (some-struct x y z) + some-struct? + (x struct-x set-struct-x!) + (y struct-y) + (z struct-z)) + +(with-test-prefix "structs" + + (pass-if-equal "simple struct" + '(<some-struct> a b c) + (let* ((struct (some-struct 'a 'b 'c)) + (result (scm->object (object-address struct)))) + (and (inferior-struct? result) + (cons (inferior-struct-name result) + (inferior-struct-fields result))))) + + (pass-if "circular struct" + (let ((struct (some-struct #f 'b 'c))) + (set-struct-x! struct struct) + (let ((result (scm->object (object-address struct)))) + (and (inferior-struct? result) + (eq? (inferior-struct-name result) '<some-struct>) + (match (inferior-struct-fields result) + ((self 'b 'c) + (eq? self result))))))) + + (pass-if "printed circular struct" + (->bool + (string-match "#<struct <some-struct> #0# b c [[:xdigit:]]+>" + (let ((struct (some-struct #f 'b 'c))) + (set-struct-x! struct struct) + (object->string (scm->object (object-address struct))))))) + + (pass-if "printed deep circular struct" + (->bool + (string-match + "#<struct <some-struct> \ +#<struct <some-struct> #-1# 3 4 [[:xdigit:]]+> \ +1 2 [[:xdigit:]]+>" + (let* ((a (some-struct #f 1 2)) + (b (some-struct a 3 4))) + (set-struct-x! a b) + (object->string (scm->object (object-address a)))))))) |