mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge branch 'stable-2.0'

Browse source 
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
This commit is contained in:
Mark H Weaver 2014-04-25 02:06:01 -04:00
commit 475772ea57
104 changed files with 3619 additions and 2811 deletions
Download patch file Download diff file Expand all files Collapse all files

15
Makefile.am
View file

@ -1,7 +1,8 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007,
## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
## 2008, 2009, 2010, 2011, 2012, 2013,
## 2014 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -45,6 +46,16 @@ libguileinclude_HEADERS = libguile.h
schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
schemelib_DATA = libguile/guile-procedures.txt
# Our own implementation of Gnulib's lock interface.
noinst_HEADERS = lib/glthread/lock.h
# Our lib/glthreads/lock.h header indirectly includes
# libguile/scmconfig.h. Make sure it is built before we recurse into
# lib/.
BUILT_SOURCES = libguile/scmconfig.h
libguile/scmconfig.h:
$(MAKE) -C libguile scmconfig.h
# Build it from here so that all the modules are compiled by the time we
# build it.
libguile/guile-procedures.txt: libguile/guile-procedures.texi
@ -94,7 +105,7 @@ gen-ChangeLog:
mv $(distdir)/cl-t $(distdir)/ChangeLog; \
fi
BUILT_SOURCES = $(top_srcdir)/.version
BUILT_SOURCES += $(top_srcdir)/.version
$(top_srcdir)/.version:
echo $(VERSION) > $@-t && mv $@-t $@
gen-tarball-version:

366
NEWS
View file

@ -378,6 +378,372 @@ longer installed to the libdir. This change should be transparent to
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):

2
README
View file

@ -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

2
THANKS
View file

@ -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

30
configure.ac
View file

@ -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"

6
doc/ref/api-compound.texi
View file

@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@c 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Compound Data Types
@ -673,6 +673,8 @@ that vectors are the special case of one dimensional non-uniform arrays
and that most array procedures operate happily on vectors
(@pxref{Arrays}).
Also see @ref{SRFI-43}, for a comprehensive vector library.
@menu
* Vector Syntax:: Read syntax for vectors.
* Vector Creation:: Dynamic vector creation and validation.

12
doc/ref/api-data.texi
View file

@ -5543,6 +5543,8 @@ approach to properties, see @ref{Object Properties}.
@node Symbol Read Syntax
@subsubsection Extended Read Syntax for Symbols
@cindex r7rs-symbols
The read syntax for a symbol is a sequence of letters, digits, and
@dfn{extended alphabetic characters}, beginning with a character that
cannot begin a number. In addition, the special cases of @code{+},
@ -5603,6 +5605,16 @@ double quotes.
|\| is a vertical bar|
@end example
Note that there's also an @code{r7rs-symbols} print option
(@pxref{Scheme Write}). To enable the use of this notation, evaluate
one or both of the following expressions:
@example
(read-enable 'r7rs-symbols)
(print-enable 'r7rs-symbols)
@end example
@node Symbol Uninterned
@subsubsection Uninterned Symbols

40
doc/ref/api-debug.texi
View file

@ -17,8 +17,9 @@ infrastructure that builds on top of those calls.
@menu
* Evaluation Model:: Evaluation and the Scheme stack.
* Source Properties:: From expressions to source locations.
* Programmatic Error Handling:: Debugging when an error occurs.
* Programmatic Error Handling:: Debugging when an error occurs.
* Traps:: Breakpoints, tracepoints, oh my!
* GDB Support:: C-level debugging with GDB.
@end menu
@node Evaluation Model
@ -1478,6 +1479,43 @@ This is a stepping trap, used to implement the ``step'', ``next'',
``step-instruction'', and ``next-instruction'' REPL commands.
@end deffn
@node GDB Support
@subsection GDB Support
@cindex GDB support
Sometimes, you may find it necessary to debug Guile applications at the
C level. Doing so can be tedious, in particular because the debugger is
oblivious to Guile's @code{SCM} type, and thus unable to display
@code{SCM} values in any meaningful way:
@example
(gdb) frame
#0 scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437
@end example
To address that, Guile comes with an extension of the GNU Debugger (GDB)
that contains a ``pretty-printer'' for @code{SCM} values. With this GDB
extension, the C frame in the example above shows up like this:
@example
(gdb) frame
#0 scm_display (obj=("hello" GDB!), port=#<port file 6f9f30>) at print.c:1437
@end example
@noindent
Here GDB was able to decode the list pointed to by @var{obj}, and to
print it using Scheme's read syntax.
That extension is a @code{.scm} file installed alongside the
@file{libguile} shared library. When GDB 7.8 or later is installed and
compiled with support for extensions written in Guile, the extension is
automatically loaded when debugging a program linked against
@file{libguile} (@pxref{Auto-loading,,, gdb, Debugging with GDB}). Note
that the directory where @file{libguile} is installed must be among
GDB's auto-loading ``safe directories'' (@pxref{Auto-loading safe
path,,, gdb, Debugging with GDB}).
@c Local Variables:
@c TeX-master: "guile.texi"

49
doc/ref/api-evaluation.texi
View file

@ -23,6 +23,7 @@ loading, evaluating, and compiling Scheme code at run time.
* Local Evaluation:: Evaluation in a local lexical environment.
* Local Inclusion:: Compile-time inclusion of one file in another.
* REPL Servers:: Serving a REPL over a socket.
* Cooperative REPL Servers:: REPL server for single-threaded applications.
@end menu
@ -1267,6 +1268,54 @@ with no arguments.
@deffn {Scheme Procedure} stop-server-and-clients!
Closes the connection on all running server sockets.
Please note that in the current implementation, the REPL threads are
cancelled without unwinding their stacks. If any of them are holding
mutexes or are within a critical section, the results are unspecified.
@end deffn
@node Cooperative REPL Servers
@subsection Cooperative REPL Servers
@cindex Cooperative REPL server
The procedures in this section are provided by
@lisp
(use-modules (system repl coop-server))
@end lisp
Whereas ordinary REPL servers run in their own threads (@pxref{REPL
Servers}), sometimes it is more convenient to provide REPLs that run at
specified times within an existing thread, for example in programs
utilizing an event loop or in single-threaded programs. This allows for
safe access and mutation of a program's data structures from the REPL,
without concern for thread synchronization.
Although the REPLs are run in the thread that calls
@code{spawn-coop-repl-server} and @code{poll-coop-repl-server},
dedicated threads are spawned so that the calling thread is not blocked.
The spawned threads read input for the REPLs and to listen for new
connections.
Cooperative REPL servers must be polled periodically to evaluate any
pending expressions by calling @code{poll-coop-repl-server} with the
object returned from @code{spawn-coop-repl-server}. The thread that
calls @code{poll-coop-repl-server} will be blocked for as long as the
expression takes to be evaluated or if the debugger is entered.
@deffn {Scheme Procedure} spawn-coop-repl-server [server-socket]
Create and return a new cooperative REPL server object, and spawn a new
thread to listen for connections on @var{server-socket}. Proper
functioning of the REPL server requires that
@code{poll-coop-repl-server} be called periodically on the returned
server object.
@end deffn
@deffn {Scheme Procedure} poll-coop-repl-server coop-server
Poll the cooperative REPL server @var{coop-server} and apply a pending
operation if there is one, such as evaluating an expression typed at the
REPL prompt. This procedure must be called from the same thread that
called @code{spawn-coop-repl-server}.
@end deffn
@c Local Variables:

2
doc/ref/api-foreign.texi
View file

@ -604,7 +604,7 @@ Unpack the pointer value from a pointer object.
Wrapped pointers are untyped, so they are essentially equivalent to C
@code{void} pointers. As in C, the memory region pointed to by a
pointer can be accessed at the byte level. This is achieved using
@emph{bytevectors} (@pxref{Bytevectors}). The @code{(rnrs bytevector)}
@emph{bytevectors} (@pxref{Bytevectors}). The @code{(rnrs bytevectors)}
module contains procedures that can be used to convert byte sequences to
Scheme objects such as strings, floating point numbers, or integers.

4
doc/ref/srfi-modules.texi
View file

@ -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

5
guile-readline/ice-9/readline.scm
View file

@ -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)))))

71
lib/Makefile.am
View file

@ -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

83
lib/fsync.c Normal file
View file

@ -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 */

1057
lib/glthread/lock.c
View file

File diff suppressed because it is too large Load diff

949
lib/glthread/lock.h
View file

@ -1,927 +1,38 @@
/* Locking in multithreaded situations.
Copyright (C) 2005-2014 Free Software Foundation, Inc.
#ifndef SCM_GLTHREADS_H
#define SCM_GLTHREADS_H
This program 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.
/* 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 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.
/* 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>.) */
You should have received a copy of the GNU Lesser General Public License
along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Bruno Haible <bruno@clisp.org>, 2005.
Based on GCC's gthr-posix.h, gthr-posix95.h, gthr-solaris.h,
gthr-win32.h. */
/* This file contains locking primitives for use with a given thread library.
It does not contain primitives for creating threads or for other
synchronization primitives.
Normal (non-recursive) locks:
Type: gl_lock_t
Declaration: gl_lock_define(extern, name)
Initializer: gl_lock_define_initialized(, name)
Initialization: gl_lock_init (name);
Taking the lock: gl_lock_lock (name);
Releasing the lock: gl_lock_unlock (name);
De-initialization: gl_lock_destroy (name);
Equivalent functions with control of error handling:
Initialization: err = glthread_lock_init (&name);
Taking the lock: err = glthread_lock_lock (&name);
Releasing the lock: err = glthread_lock_unlock (&name);
De-initialization: err = glthread_lock_destroy (&name);
Read-Write (non-recursive) locks:
Type: gl_rwlock_t
Declaration: gl_rwlock_define(extern, name)
Initializer: gl_rwlock_define_initialized(, name)
Initialization: gl_rwlock_init (name);
Taking the lock: gl_rwlock_rdlock (name);
gl_rwlock_wrlock (name);
Releasing the lock: gl_rwlock_unlock (name);
De-initialization: gl_rwlock_destroy (name);
Equivalent functions with control of error handling:
Initialization: err = glthread_rwlock_init (&name);
Taking the lock: err = glthread_rwlock_rdlock (&name);
err = glthread_rwlock_wrlock (&name);
Releasing the lock: err = glthread_rwlock_unlock (&name);
De-initialization: err = glthread_rwlock_destroy (&name);
Recursive locks:
Type: gl_recursive_lock_t
Declaration: gl_recursive_lock_define(extern, name)
Initializer: gl_recursive_lock_define_initialized(, name)
Initialization: gl_recursive_lock_init (name);
Taking the lock: gl_recursive_lock_lock (name);
Releasing the lock: gl_recursive_lock_unlock (name);
De-initialization: gl_recursive_lock_destroy (name);
Equivalent functions with control of error handling:
Initialization: err = glthread_recursive_lock_init (&name);
Taking the lock: err = glthread_recursive_lock_lock (&name);
Releasing the lock: err = glthread_recursive_lock_unlock (&name);
De-initialization: err = glthread_recursive_lock_destroy (&name);
Once-only execution:
Type: gl_once_t
Initializer: gl_once_define(extern, name)
Execution: gl_once (name, initfunction);
Equivalent functions with control of error handling:
Execution: err = glthread_once (&name, initfunction);
*/
#ifndef _LOCK_H
#define _LOCK_H
#include <errno.h>
#include <libguile/threads.h>
#include <stdlib.h>
/* ========================================================================= */
#define gl_lock_define(klass, name) \
klass scm_i_pthread_mutex_t name;
#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
# 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 */

73
lib/glthread/threadlib.c
View file

@ -1,73 +0,0 @@
/* Multithreading primitives.
Copyright (C) 2005-2014 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Bruno Haible <bruno@clisp.org>, 2005. */
#include <config.h>
/* ========================================================================= */
#if USE_POSIX_THREADS
/* Use the POSIX threads library. */
# include <pthread.h>
# include <stdlib.h>
# if PTHREAD_IN_USE_DETECTION_HARD
/* The function to be executed by a dummy thread. */
static void *
dummy_thread_func (void *arg)
{
return arg;
}
int
glthread_in_use (void)
{
static int tested;
static int result; /* 1: linked with -lpthread, 0: only with libc */
if (!tested)
{
pthread_t thread;
if (pthread_create (&thread, NULL, dummy_thread_func, NULL) != 0)
/* Thread creation failed. */
result = 0;
else
{
/* Thread creation works. */
void *retval;
if (pthread_join (thread, &retval) != 0)
abort ();
result = 1;
}
tested = 1;
}
return result;
}
# endif
#endif
/* ========================================================================= */
/* This declaration is solely to ensure that after preprocessing
this file is never empty. */
typedef int dummy;

211
lib/link.c Normal file
View file

@ -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 */

93
lib/mkdir.c Normal file
View file

@ -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;
}

50
lib/mkstemp.c Normal file
View file

@ -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);
}

41
lib/secure_getenv.c Normal file
View file

@ -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
}

54
lib/strdup.c Normal file
View file

@ -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

306
lib/tempname.c Normal file
View file

@ -0,0 +1,306 @@
/* tempname.c - generate the name of a temporary file.
Copyright (C) 1991-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. */
/* Extracted from glibc sysdeps/posix/tempname.c. See also tmpdir.c. */
#if !_LIBC
# include <config.h>
# include "tempname.h"
#endif
#include <sys/types.h>
#include <assert.h>
#include <errno.h>
#ifndef __set_errno
# define __set_errno(Val) errno = (Val)
#endif
#include <stdio.h>
#ifndef P_tmpdir
# define P_tmpdir "/tmp"
#endif
#ifndef TMP_MAX
# define TMP_MAX 238328
#endif
#ifndef __GT_FILE
# define __GT_FILE 0
# define __GT_DIR 1
# define __GT_NOCREATE 2
#endif
#if !_LIBC && (GT_FILE != __GT_FILE || GT_DIR != __GT_DIR \
|| GT_NOCREATE != __GT_NOCREATE)
# error report this to bug-gnulib@gnu.org
#endif
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <fcntl.h>
#include <sys/time.h>
#include <stdint.h>
#include <unistd.h>
#include <sys/stat.h>
#if _LIBC
# define struct_stat64 struct stat64
#else
# define struct_stat64 struct stat
# define __gen_tempname gen_tempname
# define __getpid getpid
# define __gettimeofday gettimeofday
# define __mkdir mkdir
# define __open open
# define __lxstat64(version, file, buf) lstat (file, buf)
# define __secure_getenv secure_getenv
#endif
#ifdef _LIBC
# include <hp-timing.h>
# if HP_TIMING_AVAIL
# define RANDOM_BITS(Var) \
if (__builtin_expect (value == UINT64_C (0), 0)) \
{ \
/* If this is the first time this function is used initialize \
the variable we accumulate the value in to some somewhat \
random value. If we'd not do this programs at startup time \
might have a reduced set of possible names, at least on slow \
machines. */ \
struct timeval tv; \
__gettimeofday (&tv, NULL); \
value = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; \
} \
HP_TIMING_NOW (Var)
# endif
#endif
/* Use the widest available unsigned type if uint64_t is not
available. The algorithm below extracts a number less than 62**6
(approximately 2**35.725) from uint64_t, so ancient hosts where
uintmax_t is only 32 bits lose about 3.725 bits of randomness,
which is better than not having mkstemp at all. */
#if !defined UINT64_MAX && !defined uint64_t
# define uint64_t uintmax_t
#endif
#if _LIBC
/* Return nonzero if DIR is an existent directory. */
static int
direxists (const char *dir)
{
struct_stat64 buf;
return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode);
}
/* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is
non-null and exists, uses it; otherwise uses the first of $TMPDIR,
P_tmpdir, /tmp that exists. Copies into TMPL a template suitable
for use with mk[s]temp. Will fail (-1) if DIR is non-null and
doesn't exist, none of the searched dirs exists, or there's not
enough space in TMPL. */
int
__path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx,
int try_tmpdir)
{
const char *d;
size_t dlen, plen;
if (!pfx || !pfx[0])
{
pfx = "file";
plen = 4;
}
else
{
plen = strlen (pfx);
if (plen > 5)
plen = 5;
}
if (try_tmpdir)
{
d = __secure_getenv ("TMPDIR");
if (d != NULL && direxists (d))
dir = d;
else if (dir != NULL && direxists (dir))
/* nothing */ ;
else
dir = NULL;
}
if (dir == NULL)
{
if (direxists (P_tmpdir))
dir = P_tmpdir;
else if (strcmp (P_tmpdir, "/tmp") != 0 && direxists ("/tmp"))
dir = "/tmp";
else
{
__set_errno (ENOENT);
return -1;
}
}
dlen = strlen (dir);
while (dlen > 1 && dir[dlen - 1] == '/')
dlen--; /* remove trailing slashes */
/* check we have room for "${dir}/${pfx}XXXXXX\0" */
if (tmpl_len < dlen + 1 + plen + 6 + 1)
{
__set_errno (EINVAL);
return -1;
}
sprintf (tmpl, "%.*s/%.*sXXXXXX", (int) dlen, dir, (int) plen, pfx);
return 0;
}
#endif /* _LIBC */
/* These are the characters used in temporary file names. */
static const char letters[] =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
/* Generate a temporary file name based on TMPL. TMPL must match the
rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix).
The name constructed does not exist at the time of the call to
__gen_tempname. TMPL is overwritten with the result.
KIND may be one of:
__GT_NOCREATE: simply verify that the name does not exist
at the time of the call.
__GT_FILE: create the file using open(O_CREAT|O_EXCL)
and return a read-write fd. The file is mode 0600.
__GT_DIR: create a directory, which will be mode 0700.
We use a clever algorithm to get hard-to-predict names. */
int
__gen_tempname (char *tmpl, int suffixlen, int flags, int kind)
{
int len;
char *XXXXXX;
static uint64_t value;
uint64_t random_time_bits;
unsigned int count;
int fd = -1;
int save_errno = errno;
struct_stat64 st;
/* A lower bound on the number of temporary files to attempt to
generate. The maximum total number of temporary file names that
can exist for a given template is 62**6. It should never be
necessary to try all of these combinations. Instead if a reasonable
number of names is tried (we define reasonable as 62**3) fail to
give the system administrator the chance to remove the problems. */
#define ATTEMPTS_MIN (62 * 62 * 62)
/* The number of times to attempt to generate a temporary file. To
conform to POSIX, this must be no smaller than TMP_MAX. */
#if ATTEMPTS_MIN < TMP_MAX
unsigned int attempts = TMP_MAX;
#else
unsigned int attempts = ATTEMPTS_MIN;
#endif
len = strlen (tmpl);
if (len < 6 + suffixlen || memcmp (&tmpl[len - 6 - suffixlen], "XXXXXX", 6))
{
__set_errno (EINVAL);
return -1;
}
/* This is where the Xs start. */
XXXXXX = &tmpl[len - 6 - suffixlen];
/* Get some more or less random data. */
#ifdef RANDOM_BITS
RANDOM_BITS (random_time_bits);
#else
{
struct timeval tv;
__gettimeofday (&tv, NULL);
random_time_bits = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec;
}
#endif
value += random_time_bits ^ __getpid ();
for (count = 0; count < attempts; value += 7777, ++count)
{
uint64_t v = value;
/* Fill in the random bits. */
XXXXXX[0] = letters[v % 62];
v /= 62;
XXXXXX[1] = letters[v % 62];
v /= 62;
XXXXXX[2] = letters[v % 62];
v /= 62;
XXXXXX[3] = letters[v % 62];
v /= 62;
XXXXXX[4] = letters[v % 62];
v /= 62;
XXXXXX[5] = letters[v % 62];
switch (kind)
{
case __GT_FILE:
fd = __open (tmpl,
(flags & ~O_ACCMODE)
| O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR);
break;
case __GT_DIR:
fd = __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR);
break;
case __GT_NOCREATE:
/* This case is backward from the other three. __gen_tempname
succeeds if __xstat fails because the name does not exist.
Note the continue to bypass the common logic at the bottom
of the loop. */
if (__lxstat64 (_STAT_VER, tmpl, &st) < 0)
{
if (errno == ENOENT)
{
__set_errno (save_errno);
return 0;
}
else
/* Give up now. */
return -1;
}
continue;
default:
assert (! "invalid KIND in __gen_tempname");
abort ();
}
if (fd >= 0)
{
__set_errno (save_errno);
return fd;
}
else if (errno != EEXIST)
return -1;
}
/* We got out of the loop because we ran out of combinations to try. */
__set_errno (EEXIST);
return -1;
}

50
lib/tempname.h Normal file
View file

@ -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 */

15
lib/unistd.in.h
View file

@ -21,9 +21,23 @@
#endif
@PRAGMA_COLUMNS@
#ifdef _GL_INCLUDING_UNISTD_H
/* Special invocation convention:
- On Mac OS X 10.3.9 we have a sequence of nested includes
<unistd.h> -> <signal.h> -> <pthread.h> -> <unistd.h>
In this situation, the functions are not yet declared, therefore we cannot
provide the C++ aliases. */
#@INCLUDE_NEXT@ @NEXT_UNISTD_H@
#else
/* Normal invocation convention. */
/* The include_next requires a split double-inclusion guard. */
#if @HAVE_UNISTD_H@
# define _GL_INCLUDING_UNISTD_H
# @INCLUDE_NEXT@ @NEXT_UNISTD_H@
# undef _GL_INCLUDING_UNISTD_H
#endif
/* Get all possible declarations of gethostname(). */
@ -1539,4 +1553,5 @@ _GL_CXXALIASWARN (write);
_GL_INLINE_HEADER_END
#endif /* _@GUARD_PREFIX@_UNISTD_H */
#endif /* _GL_INCLUDING_UNISTD_H */
#endif /* _@GUARD_PREFIX@_UNISTD_H */

55
libguile/Makefile.am
View file

@ -92,11 +92,12 @@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c
## Override default rule; this should be compiled for BUILD host.
## For some reason, OBJEXT does not include the dot
c-tokenize.$(OBJEXT): c-tokenize.c
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) -I$(top_builddir) -c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) -DCROSS_COMPILING=1 -I$(top_builddir) \
-c -o "$@" "$<"; \
else \
$(COMPILE) -c -o "$@" "$<"; \
fi
## Override default rule; this should run on BUILD host.
@ -460,6 +461,37 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \
install-exec-hook:
rm -f $(DESTDIR)$(bindir)/guile-snarf.awk
install-data-hook: libguile-2.2-gdb.scm
@$(MKDIR_P) $(DESTDIR)$(libdir)
## We want to install libguile-2.2-gdb.scm as SOMETHING-gdb.scm.
## SOMETHING is the full name of the final library. We want to ignore
## symlinks, the .la file, and any previous -gdb.py file. This is
## inherently fragile, but there does not seem to be a better option,
## because libtool hides the real names from us. (Trick courtesy of
## GNU libstdc++.)
@here=`pwd`; cd $(DESTDIR)$(libdir); \
for file in libguile-@GUILE_EFFECTIVE_VERSION@*; do \
case $$file in \
*-gdb.scm) ;; \
*.la) ;; \
*) if test -h $$file; then \
continue; \
fi; \
libname=$$file;; \
esac; \
done; \
cd $$here; \
echo " $(INSTALL_DATA) $< \
$(DESTDIR)$(libdir)/$$libname-gdb.scm"; \
$(INSTALL_DATA) "$<" \
"$(DESTDIR)$(libdir)/$$libname-gdb.scm"
# Remove the GDB support file and the Info 'dir' file that
# 'install-info' 5.x installs.
uninstall-hook:
-rm "$(DESTDIR)$(libdir)/libguile-@GUILE_EFFECTIVE_VERSION@"*-gdb.scm
-rm -f "$(DESTDIR)$(infodir)/dir"
## This is kind of nasty... there are ".c" files that we don't want to
## compile, since they are #included. So instead we list them here.
## Perhaps we can deal with them normally once the merge seems to be
@ -650,12 +682,13 @@ bin_SCRIPTS = guile-snarf
# and people feel like maintaining them. For now, this is not the case.
noinst_SCRIPTS = guile-snarf-docs
EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \
guile-func-name-check \
cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
c-tokenize.lex \
scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map
EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \
guile-func-name-check \
cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
c-tokenize.lex \
scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \
libguile-2.2-gdb.scm
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi

5
libguile/async.c
View file

@ -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>

5
libguile/backtrace.c
View file

@ -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

2
libguile/bdw-gc.h
View file

@ -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

13
libguile/c-tokenize.lex
View file

@ -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>

10
libguile/chars.c
View file

@ -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
};

2
libguile/error.c
View file

@ -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

46
libguile/filesys.c
View file

@ -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"

2
libguile/finalizers.c
View file

@ -23,9 +23,7 @@
# include <config.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <fcntl.h>
#include <full-write.h>

2
libguile/fports.c
View file

@ -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

5
libguile/gc-malloc.c
View file

@ -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

2
libguile/gc.c
View file

@ -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)

19
libguile/guile-snarf.in
View file

@ -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}
}

5
libguile/init.c
View file

@ -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

5
libguile/ioext.c
View file

@ -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,

4
libguile/iselect.h
View file

@ -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 */
/*

164
libguile/libguile-2.2-gdb.scm Normal file
View file

@ -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

41
libguile/list.c
View file

@ -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

5
libguile/load.c
View file

@ -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>

5
libguile/mallocs.c
View file

@ -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

6
libguile/mkstemp.c
View file

@ -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

16
libguile/numbers.c
View file

@ -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);

42
libguile/numbers.h
View file

@ -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))
#else
# define SCM_SRS(x, y) ((x) < 0 ? ~((~(x)) >> (y)) : ((x) >> (y)))
#endif /* (-1 == (((-1) << 2) + 2) >> 2) */
/* 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 \
? -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)

5
libguile/ports.c
View file

@ -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>

5
libguile/posix.c
View file

@ -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>

1
libguile/print.c
View file

@ -1549,6 +1549,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
if (scm_is_eq (destination, SCM_BOOL_T))
{
destination = port = scm_current_output_port ();
SCM_VALIDATE_OPORT_VALUE (1, destination);
}
else if (scm_is_false (destination))
{

5
libguile/r6rs-ports.c
View file

@ -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>

8
libguile/random.c
View file

@ -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

4
libguile/rw.c
View file

@ -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

5
libguile/scmsigs.c
View file

@ -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>

26
libguile/script.c
View file

@ -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);

4
libguile/simpos.c
View file

@ -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

14
libguile/snarf.h
View file

@ -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? */ \

4
libguile/socket.c
View file

@ -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

5
libguile/srfi-4.c
View file

@ -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); \

58
libguile/srfi-60.c
View file

@ -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 */
/* 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;
return scm_from_long (above
| ((ff << cc) & fmask)
| ((ff >> (ww-cc)) & fmask)
| below);
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);

5
libguile/stime.c
View file

@ -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

4
libguile/strports.c
View file

@ -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"

14
libguile/threads.c
View file

@ -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,

7
libguile/vm-engine.c
View file

@ -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 */

17
m4/fsync.m4 Normal file
View file

@ -0,0 +1,17 @@
# fsync.m4 serial 2
dnl Copyright (C) 2008-2014 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_FUNC_FSYNC],
[
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
AC_CHECK_FUNCS_ONCE([fsync])
if test $ac_cv_func_fsync = no; then
HAVE_FSYNC=0
fi
])
# Prerequisites of lib/fsync.c.
AC_DEFUN([gl_PREREQ_FSYNC], [:])

12
m4/gnulib-cache.m4
View file

@ -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([])

56
m4/gnulib-common.m4
View file

@ -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
])])])

68
m4/gnulib-comp.m4
View file

@ -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

55
m4/link.m4 Normal file
View file

@ -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
])

42
m4/lock.m4
View file

@ -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], [:])

69
m4/mkdir.m4 Normal file
View file

@ -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
])

82
m4/mkstemp.m4 Normal file
View file

@ -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],
[
])

25
m4/secure_getenv.m4 Normal file
View file

@ -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
])

36
m4/strdup.m4 Normal file
View file

@ -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], [:])

19
m4/tempname.m4 Normal file
View file

@ -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],
[
:
])

371
m4/threadlib.m4
View file

@ -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.

35
maint.mk
View file

@ -76,7 +76,7 @@ _dot_escaped_srcdir = $(subst .,\.,$(srcdir))
ifeq ($(srcdir),.)
_prepend_srcdir_prefix =
else
_prepend_srcdir_prefix = | sed 's|^|$(srcdir)/|'
_prepend_srcdir_prefix = | $(SED) 's|^|$(srcdir)/|'
endif
# In order to be able to consistently filter "."-relative names,
@ -85,7 +85,7 @@ endif
_sc_excl = \
$(or $(exclude_file_name_regexp--$@),^$$)
VC_LIST_EXCEPT = \
$(VC_LIST) | sed 's|^$(_dot_escaped_srcdir)/||' \
$(VC_LIST) | $(SED) 's|^$(_dot_escaped_srcdir)/||' \
| if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \
else grep -Ev -e "$${VC_LIST_EXCEPT_DEFAULT-ChangeLog}"; fi \
| grep -Ev -e '($(VC_LIST_ALWAYS_EXCLUDE_REGEX)|$(_sc_excl))' \
@ -158,8 +158,8 @@ export LC_ALL = C
_cfg_mk := $(wildcard $(srcdir)/cfg.mk)
# Collect the names of rules starting with 'sc_'.
syntax-check-rules := $(sort $(shell sed -n 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' \
$(srcdir)/$(ME) $(_cfg_mk)))
syntax-check-rules := $(sort $(shell $(SED) -n \
's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' $(srcdir)/$(ME) $(_cfg_mk)))
.PHONY: $(syntax-check-rules)
ifeq ($(shell $(VC_LIST) >/dev/null 2>&1; echo $$?),0)
@ -448,7 +448,7 @@ sc_require_config_h_first:
@if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
fail=0; \
for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \
grep '^# *include\>' $$i | sed 1q \
grep '^# *include\>' $$i | $(SED) 1q \
| grep -E '^# *include $(config_h_header)' > /dev/null \
|| { echo $$i; fail=1; }; \
done; \
@ -468,7 +468,7 @@ sc_prohibit_HAVE_MBRTOWC:
# re: a regular expression that matches IFF something provided by $h is used.
define _sc_header_without_use
dummy=; : so we do not need a semicolon before each use; \
h_esc=`echo '[<"]'"$$h"'[">]'|sed 's/\./\\\\./g'`; \
h_esc=`echo '[<"]'"$$h"'[">]'|$(SED) 's/\./\\\\./g'`; \
if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
files=$$(grep -l '^# *include '"$$h_esc" \
$$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \
@ -789,7 +789,7 @@ sc_useless_cpp_parens:
# #if HAVE_HEADER_H that you remove, be sure that your project explicitly
# requires the gnulib module that guarantees the usability of that header.
gl_assured_headers_ = \
cd $(gnulib_dir)/lib && echo *.in.h|sed 's/\.in\.h//g'
cd $(gnulib_dir)/lib && echo *.in.h|$(SED) 's/\.in\.h//g'
# Convert the list of names to upper case, and replace each space with "|".
az_ = abcdefghijklmnopqrstuvwxyz
@ -840,7 +840,7 @@ define def_sym_regex
&& perl -lne '$(gl_extract_significant_defines_)' $$f; \
done; \
) | sort -u \
| sed 's/^/^ *# *(define|undef) */;s/$$/\\>/'
| $(SED) 's/^/^ *# *(define|undef) */;s/$$/\\>/'
endef
# Don't define macros that we already get from gnulib header files.
@ -1054,12 +1054,12 @@ sc_const_long_option:
$(_sc_search_regexp)
NEWS_hash = \
$$(sed -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \
$$($(SED) -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \
$(srcdir)/NEWS \
| perl -0777 -pe \
's/^Copyright.+?Free\sSoftware\sFoundation,\sInc\.\n//ms' \
| md5sum - \
| sed 's/ .*//')
| $(SED) 's/ .*//')
# Ensure that we don't accidentally insert an entry into an old NEWS block.
sc_immutable_NEWS:
@ -1097,7 +1097,7 @@ sc_makefile_at_at_check:
&& { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || :
news-check: NEWS
$(AM_V_GEN)if sed -n $(news-check-lines-spec)p $< \
$(AM_V_GEN)if $(SED) -n $(news-check-lines-spec)p $< \
| grep -E $(news-check-regexp) >/dev/null; then \
:; \
else \
@ -1146,7 +1146,7 @@ sc_po_check:
files="$$files $$file"; \
done; \
grep -E -l '$(_gl_translatable_string_re)' $$files \
| sed 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \
| $(SED) 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \
diff -u -L $(po_file) -L $(po_file) $@-1 $@-2 \
|| { printf '$(ME): '$(fix_po_file_diag) 1>&2; exit 1; }; \
rm -f $@-1 $@-2; \
@ -1511,7 +1511,7 @@ refresh-gnulib-patches:
test -n "$$t" && gl=$$t; \
fi; \
for diff in $$(cd $$gl; git ls-files | grep '\.diff$$'); do \
b=$$(printf %s "$$diff"|sed 's/\.diff$$//'); \
b=$$(printf %s "$$diff"|$(SED) 's/\.diff$$//'); \
VERSION_CONTROL=none \
patch "$(gnulib_dir)/$$b" "$$gl/$$diff" || exit 1; \
( cd $(gnulib_dir) || exit 1; \
@ -1530,7 +1530,8 @@ refresh-po:
wget --no-verbose --directory-prefix $(PODIR) --no-directories --recursive --level 1 --accept .po --accept .po.1 $(POURL) && \
echo 'en@boldquot' > $(PODIR)/LINGUAS && \
echo 'en@quot' >> $(PODIR)/LINGUAS && \
ls $(PODIR)/*.po | sed 's/\.po//;s,$(PODIR)/,,' | sort >> $(PODIR)/LINGUAS
ls $(PODIR)/*.po | $(SED) 's/\.po//;s,$(PODIR)/,,' | \
sort >> $(PODIR)/LINGUAS
# Running indent once is not idempotent, but running it twice is.
INDENT_SOURCES ?= $(C_SOURCES)
@ -1640,18 +1641,18 @@ _gl_tight_scope: $(bin_PROGRAMS)
test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \
( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_functions); \
grep -h -A1 '^extern .*[^;]$$' $$src \
| grep -vE '^(extern |--)' | sed 's/ .*//'; \
| grep -vE '^(extern |--)' | $(SED) 's/ .*//'; \
perl -lne \
'$(_gl_TS_function_match) and print "^$$1\$$"' $$hdr; \
) | sort -u > $$t; \
nm -e $(_gl_TS_obj_files) | sed -n 's/.* T //p'|grep -Ev -f $$t \
nm -e $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \
&& { echo the above functions should have static scope >&2; \
exit 1; } || : ; \
( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \
perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \
$$hdr $(_gl_TS_other_headers) \
) | sort -u > $$t; \
nm -e $(_gl_TS_obj_files) | sed -n 's/.* [BCDGRS] //p' \
nm -e $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \
| sort -u | grep -Ev -f $$t \
&& { echo the above variables should have static scope >&2; \
exit 1; } || :

4
module/Makefile.am
View file

@ -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 \

5
module/ice-9/ftw.scm
View file

@ -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))

13
module/rnrs/io/simple.scm
View file

@ -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)

15
module/scripts/snarf-check-and-output-texi.scm
View file

@ -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)))

8
module/srfi/srfi-18.scm
View file

@ -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
;; srfi-18.scm ends here

9
module/srfi/srfi-19.scm
View file

@ -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)

529
module/system/base/types.scm Normal file
View file

@ -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

193
module/system/repl/coop-server.scm Normal file
View file

@ -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)))))))

14
module/system/repl/repl.scm
View file

@ -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)))

103
module/system/repl/server.scm
View file

@ -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))))))

15
test-suite/Makefile.am
View file

@ -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 \

8
test-suite/guile-test
View file

@ -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:

9
test-suite/standalone/Makefile.am
View file

@ -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

4
test-suite/standalone/test-loose-ends.c
View file

@ -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>

4
test-suite/standalone/test-num2integral.c
View file

@ -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>

4
test-suite/standalone/test-round.c
View file

@ -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>

4
test-suite/standalone/test-scm-c-bind-keyword-arguments.c
View file

@ -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>

4
test-suite/standalone/test-scm-c-read.c
View file

@ -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>

4
test-suite/standalone/test-scm-values.c
View file

@ -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>

4
test-suite/standalone/test-smob-mark.c
View file

@ -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>

90
test-suite/standalone/test-srfi-4.c Normal file
View file

@ -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;
}

16
test-suite/tests/format.test
View file

@ -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"

Some files were not shown because too many files have changed in this diff Show more