[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.0.5-2216-g475772e
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.0.5-2216-g475772e |
|
Date: |
Fri, 25 Apr 2014 06:09:49 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=475772ea57c97d0fa0f9ed9303db137d9798ddd3
The branch, master has been updated
via 475772ea57c97d0fa0f9ed9303db137d9798ddd3 (commit)
via 0e92ef40d047696eb3334405b2dd32f51ca55006 (commit)
via e0da53b4fe4abee2cdcd97fe46eeefcaab1da631 (commit)
via 4755604501948008849dcc9e114e5c84f355624d (commit)
via fd584ec6707ae5b6e7b07fe19443b513fb0ba62b (commit)
via 4a81f5b5d3800aafbc25452e50459c1ba6e29fea (commit)
via 7eaa92ffa9594025d989d5584750b72fe5797c20 (commit)
via d2fcbb193b67106d0c0b57cd1e988acf2d30ace7 (commit)
via b27ad2f394c5e4465f5cdee748534d013919cfa1 (commit)
via 0ece4850c5423d53db3245f57681053486327aa3 (commit)
via 8d124d207738be0b43dfc235a5d72519a2ab5db9 (commit)
via 972fb41f0ce124d97f5cf64bde1075510cd21e18 (commit)
via d4d11cf39de5b30a136f89f1ebc32673e981c70f (commit)
via 0c1f2b0e0d3940fc0d4f3a902d9c487db15f14d5 (commit)
via f2c3d29fd256ff4b6022d9af98543be7c625422e (commit)
via 5dcbcfcef8eefd1f9e57d8ba69efe1ca945c95b1 (commit)
via e26ab067b2073c1eb5ace13d069674515b9f97c6 (commit)
via 2be7131ee0c38336483226657872a8faa62a2562 (commit)
via 92b793da2b43af0ed470c43dc7e41409ca61f1b4 (commit)
via f755f14e32aca8ecaabab759db0dd88072d0ca45 (commit)
via 6a450390caca3fa62bb611843fea53f729be278a (commit)
via 77326d36494f40736a9e05f0ef912cd9763871cb (commit)
via c68b9470e9d03e64e9b82d20d2eadf2d1745ab8b (commit)
via b7faf399c1420567b017cdc7f900009ded175151 (commit)
via 679ffce89c3ddb8f906df452e4884b128ea4655b (commit)
via cdf1ae89831166b4dfda411fdd959d718b0aed41 (commit)
via 580ef7fcf4f9713bb2dc8ed4655649a576665316 (commit)
via f1a13268fdc55a78700317b0e5d68649547db744 (commit)
via f2de4fac885cb2964429657ea45a686e22bb3c2c (commit)
via 2b509a2e37f9d3f98a1c8051629a339f499c0193 (commit)
via 950a966e643c5f979e73ae6fbce4d0424f2a6396 (commit)
via 17d4daa8bd11176c2ebe0d35ac48da3d247094ff (commit)
via 21a7ba9b7e7e97854678677c7da4b42bd9faec66 (commit)
via de32a951c07243a307233ae2f2b478e636276e1e (commit)
via 8cb0d6d7fa9aaac316c29a64c541336b51b6f93d (commit)
via da7e43a6e0dadb2f96e6e33163bb4d94715f7498 (commit)
via c6a2691fff2863209729aba5f54e3f874bbbf1c4 (commit)
via 3aecd36464b1d916991bcc57acd6ec42e1cabbdc (commit)
via e293c94c65d49171c54bb1893c355e36c66806b8 (commit)
via 7f8ad91b994d4922efdd7f9f89400b1ebddeed8f (commit)
via 9fcee9da3f28b4b190d6976aeea72ab3c9f62bb2 (commit)
via 03cce0ce5fba210e4abd8fa5dfddb04022a27e75 (commit)
via 5fbf0e0f99431f54da032bda47d8125f9d34b4b1 (commit)
via 19c0bd22a8f5e7cd76cf1435504c8eca342285ff (commit)
via 3b7601cb34b068a231f6992ad9bbd3c50659efd4 (commit)
via 8f7887d61604073528544ccb09849ca0e2f4df78 (commit)
via de7aa61ac48811610b1b99005ada2464cf1a96f1 (commit)
via ce0ba9d087fd5b03d85a64deddaf3c59bd136a3d (commit)
via b8d7aacd682ce70d496fecf1626365c72132ada0 (commit)
via c3c3032608c9658c5dc5019d85446b6a1c2f7fcc (commit)
via bf0d59e54de22f0a2e384b0fea2aa039769676fb (commit)
via d5f7b6678f40be433bd806309665a36494030293 (commit)
via e1bb79fde62e678c0f8ceb32c7edd2dab0201a5c (commit)
via 6587bcfa53f620142e4f712ad347a25e3c33a9bc (commit)
via bc8e6d7d8ca602c86591466f5e9d816a614700f5 (commit)
via ca6adcc6df462f325dfa7b099295fd6212d02b43 (commit)
via 3243fffcc19144fc0b30e983c3e50d1d1fc19ef4 (commit)
via caa3d99be9932077230303a5571697f7d45f3da2 (commit)
via a8b80d6b29b33ea39c96e5e366a0365886b31dc8 (commit)
via ae8d8a84ef0187a3d732e43c459182ed15536dc1 (commit)
via 8f5dbecb4bfe9862d3603b2848cd115d5a164a4f (commit)
via 359f46a41cd703fcec187459eb11aacf1b05d76a (commit)
via 5f4b817df92b30ae32f934f3c2cf83a5990e1895 (commit)
via f07fa851505c6f4e7040b10ca0e178901bd106ef (commit)
via e1d7a93bb286d691069d47063d1ce5baabd7a35d (commit)
via f9d4a040b4719fca2a433c01b680679d155ec981 (commit)
via b0a31499554fb69160b18ccefac89eec4954e488 (commit)
via 5ecc58113a0a50d7a5840e9bfccce25b4f8b30ce (commit)
via b61025ce0f6f14541b23d93f14dfc60022b91ad6 (commit)
via d0a77f10f23fb95a8f4b1b36d475258a6bd447b8 (commit)
from 7a85f2b68ce8c7c8a28e6bde03b7c9da01004db5 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 475772ea57c97d0fa0f9ed9303db137d9798ddd3
Merge: 0e92ef4 e0da53b
Author: Mark H Weaver <address@hidden>
Date: Fri Apr 25 02:06:01 2014 -0400
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
commit 0e92ef40d047696eb3334405b2dd32f51ca55006
Author: Mark H Weaver <address@hidden>
Date: Fri Apr 25 01:39:59 2014 -0400
print: Fix printing of weak vectors.
* libguile/print.c (print_vector_or_weak_vector): New static function.
(iprin1): Use 'print_vector_or_weak_vector' in the vector and weak
vector cases.
-----------------------------------------------------------------------
Summary of changes:
Makefile.am | 15 +-
NEWS | 366 +++++++
README | 2 +-
THANKS | 2 +
configure.ac | 30 +-
doc/ref/api-compound.texi | 6 +-
doc/ref/api-data.texi | 12 +
doc/ref/api-debug.texi | 40 +-
doc/ref/api-evaluation.texi | 49 +
doc/ref/api-foreign.texi | 2 +-
doc/ref/srfi-modules.texi | 4 +-
guile-readline/ice-9/readline.scm | 5 +-
lib/Makefile.am | 71 ++-
lib/fsync.c | 83 ++
lib/glthread/lock.c | 1057 --------------------
lib/glthread/lock.h | 955 +-----------------
lib/glthread/threadlib.c | 73 --
lib/link.c | 211 ++++
lib/mkdir.c | 93 ++
lib/mkstemp.c | 50 +
lib/secure_getenv.c | 41 +
lib/strdup.c | 54 +
lib/tempname.c | 306 ++++++
lib/tempname.h | 50 +
lib/unistd.in.h | 15 +
libguile/Makefile.am | 55 +-
libguile/async.c | 5 +-
libguile/backtrace.c | 5 +-
libguile/bdw-gc.h | 2 +-
libguile/c-tokenize.lex | 13 +-
libguile/chars.c | 10 +-
libguile/error.c | 2 -
libguile/filesys.c | 46 +-
libguile/finalizers.c | 2 -
libguile/fports.c | 2 -
libguile/gc-malloc.c | 5 +-
libguile/gc.c | 2 -
libguile/guile-snarf.in | 19 +-
libguile/init.c | 5 +-
libguile/ioext.c | 5 +-
libguile/iselect.h | 4 -
libguile/libguile-2.2-gdb.scm | 164 +++
libguile/list.c | 41 +-
libguile/load.c | 5 +-
libguile/mallocs.c | 5 +-
libguile/mkstemp.c | 6 +-
libguile/numbers.c | 16 +-
libguile/numbers.h | 42 +-
libguile/ports.c | 5 +-
libguile/posix.c | 5 +-
libguile/print.c | 60 +-
libguile/r6rs-ports.c | 5 +-
libguile/random.c | 8 +-
libguile/rw.c | 4 +-
libguile/scmsigs.c | 5 +-
libguile/script.c | 26 +-
libguile/simpos.c | 4 +-
libguile/snarf.h | 14 +-
libguile/socket.c | 4 +-
libguile/srfi-4.c | 5 +-
libguile/srfi-60.c | 60 +-
libguile/stime.c | 5 +-
libguile/strports.c | 4 +-
libguile/threads.c | 14 +-
libguile/vm-engine.c | 7 +-
m4/{sockets.m4 => fsync.m4} | 18 +-
m4/gnulib-cache.m4 | 12 +-
m4/gnulib-common.m4 | 56 +
m4/gnulib-comp.m4 | 68 ++-
m4/link.m4 | 55 +
m4/lock.m4 | 42 -
m4/mkdir.m4 | 69 ++
m4/mkstemp.m4 | 82 ++
m4/secure_getenv.m4 | 25 +
m4/strdup.m4 | 36 +
m4/tempname.m4 | 19 +
m4/threadlib.m4 | 371 -------
maint.mk | 35 +-
module/Makefile.am | 4 +-
module/ice-9/ftw.scm | 5 +-
module/rnrs/io/simple.scm | 13 +-
module/scripts/snarf-check-and-output-texi.scm | 15 +-
module/srfi/srfi-18.scm | 8 +-
module/srfi/srfi-19.scm | 9 +-
module/system/base/types.scm | 529 ++++++++++
module/system/repl/coop-server.scm | 193 ++++
module/system/repl/repl.scm | 14 +-
module/system/repl/server.scm | 103 ++-
test-suite/Makefile.am | 15 +
test-suite/guile-test | 8 +-
test-suite/standalone/Makefile.am | 9 +-
test-suite/standalone/test-loose-ends.c | 4 +-
test-suite/standalone/test-num2integral.c | 4 +-
test-suite/standalone/test-round.c | 4 +-
.../standalone/test-scm-c-bind-keyword-arguments.c | 4 +-
test-suite/standalone/test-scm-c-read.c | 4 +-
test-suite/standalone/test-scm-values.c | 4 +-
test-suite/standalone/test-smob-mark.c | 4 +-
test-suite/standalone/test-srfi-4.c | 90 ++
test-suite/tests/format.test | 16 +
test-suite/tests/hash.test | 12 +
test-suite/tests/srfi-18.test | 8 +-
test-suite/tests/srfi-60.test | 89 ++-
test-suite/tests/types.test | 160 +++
104 files changed, 3651 insertions(+), 2853 deletions(-)
create mode 100644 lib/fsync.c
delete mode 100644 lib/glthread/lock.c
delete mode 100644 lib/glthread/threadlib.c
create mode 100644 lib/link.c
create mode 100644 lib/mkdir.c
create mode 100644 lib/mkstemp.c
create mode 100644 lib/secure_getenv.c
create mode 100644 lib/strdup.c
create mode 100644 lib/tempname.c
create mode 100644 lib/tempname.h
create mode 100644 libguile/libguile-2.2-gdb.scm
copy m4/{sockets.m4 => fsync.m4} (52%)
create mode 100644 m4/link.m4
delete mode 100644 m4/lock.m4
create mode 100644 m4/mkdir.m4
create mode 100644 m4/mkstemp.m4
create mode 100644 m4/secure_getenv.m4
create mode 100644 m4/strdup.m4
create mode 100644 m4/tempname.m4
delete mode 100644 m4/threadlib.m4
create mode 100644 module/system/base/types.scm
create mode 100644 module/system/repl/coop-server.scm
create mode 100644 test-suite/standalone/test-srfi-4.c
create mode 100644 test-suite/tests/types.test
diff --git a/Makefile.am b/Makefile.am
index 2ed8370..8f9e014 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) > address@hidden && mv address@hidden $@
gen-tarball-version:
diff --git a/NEWS b/NEWS
index c807155..2c13fb7 100644
--- a/NEWS
+++ b/NEWS
@@ -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
diff --git a/README b/README
index 215f9e5..92d786c 100644
--- a/README
+++ b/README
@@ -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
diff --git a/THANKS b/THANKS
index ddb11c1..d34b951 100644
--- a/THANKS
+++ b/THANKS
@@ -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 57424f7..55bfafc 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 0b14c48..055de99 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.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006,
address@hidden 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007,
address@hidden 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 ba00603..96f9fd0 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
address@hidden 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:
+
address@hidden
+(read-enable 'r7rs-symbols)
+(print-enable 'r7rs-symbols)
address@hidden example
+
+
@node Symbol Uninterned
@subsubsection Uninterned Symbols
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 5dabb84..9b0e564 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
address@hidden GDB Support
address@hidden GDB Support
+
address@hidden 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
address@hidden values in any meaningful way:
+
address@hidden
+(gdb) frame
+#0 scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437
address@hidden 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:
+
address@hidden
+(gdb) frame
+#0 scm_display (obj=("hello" GDB!), port=#<port file 6f9f30>) at print.c:1437
address@hidden example
+
address@hidden
+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
address@hidden 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
address@hidden (@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 dde1643..a23cf1a 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.
address@hidden deffn
+
address@hidden Cooperative REPL Servers
address@hidden Cooperative REPL Servers
+
address@hidden Cooperative REPL server
+
+The procedures in this section are provided by
address@hidden
+(use-modules (system repl coop-server))
address@hidden 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
address@hidden 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.
+
address@hidden {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
address@hidden be called periodically on the returned
+server object.
address@hidden deffn
+
address@hidden {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 381c10d..c2c49ec 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
address@hidden (@pxref{Bytevectors}). The @code{(rnrs bytevector)}
address@hidden (@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 161d372..882b7d3 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 1b2fa56..02e68af 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 5648369..5d9c902 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 0000000..99475ff
--- /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 0454cc2..0000000
--- 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 <address@hidden>, 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 894b1fb..66c78a6 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 <address@hidden>, 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 37a5762..0000000
--- 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 <address@hidden>, 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 0000000..9db1f8c
--- /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 0000000..f1b802b
--- /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 0000000..0af69f9
--- /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 0000000..7b86173
--- /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 0000000..bde5829
--- /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 0000000..f0f7e7f
--- /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 address@hidden
+#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 0000000..bd46f93
--- /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 9880908..8420250 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. */
+
address@hidden@ @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 /* address@hidden@_UNISTD_H */
+#endif /* _GL_INCLUDING_UNISTD_H */
#endif /* address@hidden@_UNISTD_H */
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 2077c4d..f5e8590 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 @@ address@hidden@_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 address@hidden@*; 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)/address@hidden@"*-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 80f561d..1e5bc30 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 fa12a5d..0c0f110 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 2deb97e..6e2f456 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 856224e..03fe989 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 9f50c1e..064fca4 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 b61e90b..2878fa0 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 aa3e671..a2280a5 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 b37dbde..82f292c 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 672f575..e4038de 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 d229b90..894ca06 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 bc35faf..fe93cba 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 c73e8ce..47bbc04 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 81cf997..6de7a21 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 94b0f4f..659eabc 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 1c7b12d..945ad14 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 0000000..93ba1a3
--- /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 1f44ad0..41cc937 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 5019201..d24b4ae 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 b4499bc..9f3584a 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 a7eaf10..d752d07 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 f4e8b27..14d98ff 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 6e382ea..bba336b 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 060c4fb..5fb3424 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 0443f95..ae0f7c3 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 4ad2a95..684b3d4 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -585,6 +585,33 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
static void
+print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
+ SCM port, scm_print_state *pstate)
+{
+ long i;
+ long last = len - 1;
+ int cutp = 0;
+ if (pstate->fancyp && len > pstate->length)
+ {
+ last = pstate->length - 1;
+ cutp = 1;
+ }
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (ref (v, i), port, pstate);
+ scm_putc_unlocked (' ', port);
+ }
+ if (i == last)
+ {
+ /* CHECK_INTS; */
+ scm_iprin1 (ref (v, i), port, pstate);
+ }
+ if (cutp)
+ scm_puts_unlocked (" ...", port);
+ scm_putc_unlocked (')', port);
+}
+
+static void
iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
switch (SCM_ITAG3 (exp))
@@ -766,35 +793,15 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts_unlocked ("#w(", port);
- goto common_vector_printer;
+ print_vector_or_weak_vector (exp, scm_c_weak_vector_length (exp),
+ scm_c_weak_vector_ref, port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts_unlocked ("#(", port);
- common_vector_printer:
- {
- register long i;
- long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
- int cutp = 0;
- if (pstate->fancyp
- && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
- {
- last = pstate->length - 1;
- cutp = 1;
- }
- for (i = 0; i < last; ++i)
- {
- scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
- scm_putc_unlocked (' ', port);
- }
- if (i == last)
- {
- /* CHECK_INTS; */
- scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
- }
- if (cutp)
- scm_puts_unlocked (" ...", port);
- scm_putc_unlocked (')', port);
- }
+ print_vector_or_weak_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp),
+ scm_c_vector_ref, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_port:
@@ -1542,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 db0b3f6..1b0aba4 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 915f17f..1ee0459 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 677e0d8..75c280b 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 d65dcea..a23f151 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 052ab8d..63fbb0f 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 7865da6..a657a8f 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 afc4d8f..d0b6833 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 0516e52..2a9be54 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 d8a264c..057664c 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 1ed3c9e..de97cbc 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 c876925..f656d88 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 dd3bc59..a6a03b4 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 dd04f6f..bcf1e0d 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 86803fd..3c09df2 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/sockets.m4 b/m4/fsync.m4
similarity index 52%
copy from m4/sockets.m4
copy to m4/fsync.m4
index da6ff74..888a65d 100644
--- a/m4/sockets.m4
+++ b/m4/fsync.m4
@@ -1,17 +1,17 @@
-# sockets.m4 serial 7
+# 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_SOCKETS],
+AC_DEFUN([gl_FUNC_FSYNC],
[
- AC_REQUIRE([AC_C_INLINE])
- AC_REQUIRE([gl_SOCKETLIB])
- gl_PREREQ_SOCKETS
+ 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/sockets.c.
-AC_DEFUN([gl_PREREQ_SOCKETS], [
- :
-])
+# Prerequisites of lib/fsync.c.
+AC_DEFUN([gl_PREREQ_FSYNC], [:])
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 7682c1e..26c96b3 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 3b61b23..20ce40e 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 a188709..429fee4 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 0000000..e923d0d
--- /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 73a3c54..0000000
--- 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 0000000..51e78c1
--- /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 0000000..9033a4e
--- /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 0000000..149888d
--- /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 0000000..1681a30
--- /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 0000000..1594e1f
--- /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 a881702..0000000
--- 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.
diff --git a/maint.mk b/maint.mk
index d5bb427..30f2e8e 100644
--- a/maint.mk
+++ b/maint.mk
@@ -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 > address@hidden;
\
+ | $(SED) 's|^$(_dot_escaped_srcdir)/||' | sort -u > address@hidden;
\
diff -u -L $(po_file) -L $(po_file) address@hidden address@hidden
\
|| { printf '$(ME): '$(fix_po_file_diag) 1>&2; exit 1; }; \
rm -f address@hidden address@hidden;
\
@@ -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 'address@hidden' > $(PODIR)/LINGUAS && \
echo 'address@hidden' >> $(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 a6b20af..abc8a73 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 9c9694f..133e9c9 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 031628b..5eb396f 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 6ca07a1..82d71f4 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 684a125..832b436 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 c0a27b1..6d86ee6 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 0000000..6c1d40d
--- /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 0000000..c19dda1
--- /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 1649556..5b27125 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 4f3391c..ff9ee5c 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 05e7134..c38d12b 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 43ea481..4a264b4 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 d2f4300..fa77925 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 b4ea5b9..40b358b 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 c8dc3a7..f5cd879 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 150c881..2cd6fd5 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 ad0722c..f4cd53d 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 4111cd0..5f11e75 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 ece62da..06f57be 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 d9db9a6..86566af 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 0000000..b49e666
--- /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 3349847..cc31942 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 64d10bb..4c21d71 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 47f8f7f..ab05513 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 940934f..1c91943 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 0000000..ea71d3c
--- /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))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.0.5-2216-g475772e,
Mark H Weaver <=