summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2008-09-10 22:50:04 +0200
committerLudovic Courtès <ludo@gnu.org>2008-09-10 22:50:04 +0200
commit6774820f1e83a388b3232cd61a66340886b395d8 (patch)
tree513cae9f2b9168aea1e4e20c3ce91cf89e0ce817
parentb74e86cf5f50612742609210ad8e04d46069437f (diff)
parent29776e85da637ec4d44b2b2822d6934a50c0084b (diff)
downloadguile-6774820f1e83a388b3232cd61a66340886b395d8.tar.gz
Merge commit '29776e85da637ec4d44b2b2822d6934a50c0084b' into boehm-demers-weiser-gc
Conflicts: libguile/gc-card.c libguile/gc.c libguile/gc.h libguile/ports.c
-rw-r--r--.cvsignore1
-rw-r--r--ChangeLog61
-rw-r--r--Makefile.am7
-rw-r--r--NEWS29
-rwxr-xr-xautogen.sh3
-rwxr-xr-xbuild-aux/config.rpath614
-rw-r--r--configure.in33
-rw-r--r--doc/ref/ChangeLog13
-rw-r--r--doc/ref/slib.texi38
-rw-r--r--doc/ref/srfi-modules.texi192
-rw-r--r--guile-readline/ChangeLog6
-rw-r--r--guile-readline/Makefile.am10
-rw-r--r--ice-9/ChangeLog19
-rw-r--r--ice-9/boot-9.scm16
-rw-r--r--ice-9/slib.scm394
-rw-r--r--libguile/ChangeLog117
-rw-r--r--libguile/Makefile.am14
-rw-r--r--libguile/eval.c57
-rw-r--r--libguile/filesys.c18
-rw-r--r--libguile/fports.c40
-rw-r--r--libguile/i18n.c19
-rw-r--r--libguile/init.c10
-rw-r--r--libguile/ioext.c34
-rw-r--r--libguile/numbers.c35
-rw-r--r--libguile/ports.c134
-rw-r--r--libguile/ports.h8
-rw-r--r--libguile/posix.c51
-rw-r--r--libguile/read.c56
-rw-r--r--libguile/socket.c132
-rw-r--r--libguile/srfi-14.c4
-rw-r--r--libguile/stime.c5
-rw-r--r--libguile/threads.c8
-rw-r--r--libguile/weaks.h1
-rw-r--r--m4/ChangeLog10
-rw-r--r--m4/gnulib-cache.m432
-rw-r--r--srfi/ChangeLog24
-rw-r--r--srfi/Makefile.am20
-rw-r--r--srfi/srfi-35.scm335
-rw-r--r--test-suite/ChangeLog46
-rw-r--r--test-suite/Makefile.am3
-rw-r--r--test-suite/tests/ports.test38
-rw-r--r--test-suite/tests/reader.test10
-rw-r--r--test-suite/tests/srfi-17.test17
-rw-r--r--test-suite/tests/srfi-35.test310
-rw-r--r--test-suite/tests/srfi-9.test12
45 files changed, 2241 insertions, 795 deletions
diff --git a/.cvsignore b/.cvsignore
index 4dae94a82..109038aaa 100644
--- a/.cvsignore
+++ b/.cvsignore
@@ -33,4 +33,3 @@ mkinstalldirs
pre-inst-guile
pre-inst-guile-env
stamp-h1
-texinfo.tex
diff --git a/ChangeLog b/ChangeLog
index db9546de0..18f16fd7b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,64 @@
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention `(ice-9 slib)' fix and threading fix.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention alignment-related bug fixes.
+
+2007-09-03 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Move cexp and clog up into the main
+ funcs check block. Remove carg which is now unused.
+
+2007-09-02 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention memory leak fix in `make-socket-address'.
+
+2007-09-01 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention duplicate binding warnings to stderr.
+
+2007-08-23 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention Solaris bug fixes.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention SRFI-35 and the new reader.
+
+2007-08-08 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention changes to `record-accessor' and
+ `record-modifier'.
+
+2007-07-29 Ludovic Courtès <ludo@gnu.org>
+
+ Added Gnulib support.
+
+ * autogen.sh: Run `gnulib-tool --update'.
+
+ * Makefile.am (SUBDIRS): Added `lib'.
+ (ACLOCAL_AMFLAGS): Added `-I m4'.
+ (EXTRA_DIST): Added `m4/ChangeLog'.
+
+ * NEWS: Comply with Automake's `check-news' option, i.e., have
+ the last "Changes in" line appear within the first 15 lines.
+ Mention use of Gnulib.
+
+ * configure.in: Use `build-aux' as `AC_CONFIG_AUX_DIR', and `m4'
+ as `AC_CONFIG_MACRO_DIR'. Use Automake's `gnu' and `check-news'
+ options.
+ Require Autoconf 2.59. Invoke `gl_EARLY' and `gl_INIT', don't
+ run `AC_AIX', `AC_ISC_POSIX' and `AC_MINIX' since they are
+ implied by `gl_EARLY'. Don't look for <strings.h> and
+ `strncasecmp'. Don't invoke `AC_FUNC_ALLOCA'. Produce
+ `lib/Makefile'.
+
+2007-07-25 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention bug fix for "(set! 'x #f)".
+
2007-07-22 Ludovic Courtès <ludo@gnu.org>
* configure.in: Check for <strings.h> and `strncasecmp ()'.
diff --git a/Makefile.am b/Makefile.am
index 49fc94a8b..d86186ee4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -24,7 +24,7 @@
#
AUTOMAKE_OPTIONS = 1.10
-SUBDIRS = oop libguile ice-9 guile-config guile-readline emacs \
+SUBDIRS = lib oop libguile ice-9 guile-config guile-readline emacs \
scripts srfi doc examples test-suite benchmark-suite lang am
bin_SCRIPTS = guile-tools
@@ -33,11 +33,12 @@ include_HEADERS = libguile.h
# automake sometimes forgets to distribute acconfig.h,
# apparently depending on the phase of the moon.
-EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS
+EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS \
+ m4/ChangeLog
TESTS = check-guile
-ACLOCAL_AMFLAGS = -I guile-config
+ACLOCAL_AMFLAGS = -I guile-config -I m4
DISTCLEANFILES = check-guile.log
diff --git a/NEWS b/NEWS
index 15f2d80cd..e4fbb145b 100644
--- a/NEWS
+++ b/NEWS
@@ -6,21 +6,17 @@ Please send Guile bug reports to bug-guile@gnu.org. Note that you
must be subscribed to this list first, in order to successfully send a
report to it.
-Each release reports the NEWS in the following sections:
-
-* Changes to the distribution
-* Changes to the stand-alone interpreter
-* Changes to Scheme functions and syntax
-* Changes to the C interface
-
-Changes in 1.9.XXXXXXXX:
+Changes in 1.9.0:
* New modules (see the manual for details)
** The `(ice-9 i18n)' module provides internationalization support
* Changes to the distribution
+
+** Guile now uses Gnulib as a portability aid
+
* Changes to the stand-alone interpreter
* Changes to Scheme functions and syntax
@@ -40,8 +36,25 @@ Changes in 1.8.3 (since 1.8.2)
* New modules (see the manual for details)
+** `(srfi srfi-35)'
** `(srfi srfi-37)'
+* Bugs fixed
+
+** The `(ice-9 slib)' module now works as expected
+** Expressions like "(set! 'x #t)" no longer yield a crash
+** Warnings about duplicate bindings now go to stderr
+** A memory leak in `make-socket-address' was fixed
+** Alignment issues (e.g., on SPARC) in network routines were fixed
+** A threading issue that showed up at least on NetBSD was fixed
+** Build problems on Solaris fixed
+
+* Implementation improvements
+
+** The reader is now faster, which reduces startup time
+** Procedures returned by `record-accessor' and `record-modifier' are faster
+
+
Changes in 1.8.2 (since 1.8.1):
diff --git a/autogen.sh b/autogen.sh
index 1a566de1d..a24bd6d97 100755
--- a/autogen.sh
+++ b/autogen.sh
@@ -19,10 +19,13 @@ libtool --version
echo ""
${M4:-/usr/bin/m4} --version
echo ""
+gnulib-tool --version
+echo ""
######################################################################
### update infrastructure
+gnulib-tool --update && \
autoreconf -i --force --verbose
echo "guile-readline..."
diff --git a/build-aux/config.rpath b/build-aux/config.rpath
new file mode 100755
index 000000000..c492a93b6
--- /dev/null
+++ b/build-aux/config.rpath
@@ -0,0 +1,614 @@
+#! /bin/sh
+# Output a system dependent set of variables, describing how to set the
+# run time search path of shared libraries in an executable.
+#
+# Copyright 1996-2006 Free Software Foundation, Inc.
+# Taken from GNU libtool, 2001
+# Originally by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+#
+# The first argument passed to this file is the canonical host specification,
+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
+# The environment variables CC, GCC, LDFLAGS, LD, with_gnu_ld
+# should be set by the caller.
+#
+# The set of defined variables is at the end of this script.
+
+# Known limitations:
+# - On IRIX 6.5 with CC="cc", the run time search patch must not be longer
+# than 256 bytes, otherwise the compiler driver will dump core. The only
+# known workaround is to choose shorter directory names for the build
+# directory and/or the installation directory.
+
+# All known linkers require a `.a' archive for static linking (except MSVC,
+# which needs '.lib').
+libext=a
+shrext=.so
+
+host="$1"
+host_cpu=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+host_vendor=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+host_os=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+
+# Code taken from libtool.m4's _LT_CC_BASENAME.
+
+for cc_temp in $CC""; do
+ case $cc_temp in
+ compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
+ distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'`
+
+# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC.
+
+wl=
+if test "$GCC" = yes; then
+ wl='-Wl,'
+else
+ case "$host_os" in
+ aix*)
+ wl='-Wl,'
+ ;;
+ darwin*)
+ case $cc_basename in
+ xlc*)
+ wl='-Wl,'
+ ;;
+ esac
+ ;;
+ mingw* | pw32* | os2*)
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ wl='-Wl,'
+ ;;
+ irix5* | irix6* | nonstopux*)
+ wl='-Wl,'
+ ;;
+ newsos6)
+ ;;
+ linux*)
+ case $cc_basename in
+ icc* | ecc*)
+ wl='-Wl,'
+ ;;
+ pgcc | pgf77 | pgf90)
+ wl='-Wl,'
+ ;;
+ ccc*)
+ wl='-Wl,'
+ ;;
+ como)
+ wl='-lopt='
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*)
+ wl='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+ osf3* | osf4* | osf5*)
+ wl='-Wl,'
+ ;;
+ sco3.2v5*)
+ ;;
+ solaris*)
+ wl='-Wl,'
+ ;;
+ sunos4*)
+ wl='-Qoption ld '
+ ;;
+ sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*)
+ wl='-Wl,'
+ ;;
+ sysv4*MP*)
+ ;;
+ unicos*)
+ wl='-Wl,'
+ ;;
+ uts4*)
+ ;;
+ esac
+fi
+
+# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS.
+
+hardcode_libdir_flag_spec=
+hardcode_libdir_separator=
+hardcode_direct=no
+hardcode_minus_L=no
+
+case "$host_os" in
+ cygwin* | mingw* | pw32*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+esac
+
+ld_shlibs=yes
+if test "$with_gnu_ld" = yes; then
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ # Unlike libtool, we use -rpath here, not --rpath, since the documented
+ # option of GNU ld is called -rpath, not --rpath.
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ case "$host_os" in
+ aix3* | aix4* | aix5*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ ld_shlibs=no
+ fi
+ ;;
+ amigaos*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ # Samuel A. Falvo II <kc5tja@dolphin.openprojects.net> reports
+ # that the semantics of dynamic libraries on AmigaOS, at least up
+ # to version 4, is to share data among multiple programs linked
+ # with the same dynamic library. Since this doesn't match the
+ # behavior of shared libraries on other platforms, we cannot use
+ # them.
+ ld_shlibs=no
+ ;;
+ beos*)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ cygwin* | mingw* | pw32*)
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ hardcode_libdir_flag_spec='-L$libdir'
+ if $LD --help 2>&1 | grep 'auto-import' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ interix3*)
+ hardcode_direct=no
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ linux*)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ netbsd*)
+ ;;
+ solaris*)
+ if $LD -v 2>&1 | grep 'BFD 2\.8' > /dev/null; then
+ ld_shlibs=no
+ elif $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
+ ld_shlibs=no
+ ;;
+ *)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-rpath,$libdir`'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ ;;
+ sunos4*)
+ hardcode_direct=yes
+ ;;
+ *)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ if test "$ld_shlibs" = no; then
+ hardcode_libdir_flag_spec=
+ fi
+else
+ case "$host_os" in
+ aix3*)
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L=yes
+ if test "$GCC" = yes; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ hardcode_direct=unsupported
+ fi
+ ;;
+ aix4* | aix5*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ else
+ aix_use_runtimelinking=no
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[23]|aix4.[23].*|aix5*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+ fi
+ hardcode_direct=yes
+ hardcode_libdir_separator=':'
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[012]|aix4.[012].*)
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" && \
+ strings "$collect2name" | grep resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ hardcode_direct=yes
+ else
+ # We have old collect2
+ hardcode_direct=unsupported
+ hardcode_minus_L=yes
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_libdir_separator=
+ fi
+ ;;
+ esac
+ fi
+ # Begin _LT_AC_SYS_LIBPATH_AIX.
+ echo 'int main () { return 0; }' > conftest.c
+ ${CC} ${LDFLAGS} conftest.c -o conftest
+ aix_libpath=`dump -H conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
+}'`
+ if test -z "$aix_libpath"; then
+ aix_libpath=`dump -HX64 conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
+}'`
+ fi
+ if test -z "$aix_libpath"; then
+ aix_libpath="/usr/lib:/lib"
+ fi
+ rm -f conftest.c conftest
+ # End _LT_AC_SYS_LIBPATH_AIX.
+ if test "$aix_use_runtimelinking" = yes; then
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ else
+ if test "$host_cpu" = ia64; then
+ hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib'
+ else
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ fi
+ fi
+ ;;
+ amigaos*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ # see comment about different semantics on the GNU ld section
+ ld_shlibs=no
+ ;;
+ bsdi[45]*)
+ ;;
+ cygwin* | mingw* | pw32*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ hardcode_libdir_flag_spec=' '
+ libext=lib
+ ;;
+ darwin* | rhapsody*)
+ hardcode_direct=no
+ if test "$GCC" = yes ; then
+ :
+ else
+ case $cc_basename in
+ xlc*)
+ ;;
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+ fi
+ ;;
+ dgux*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ ;;
+ freebsd1*)
+ ld_shlibs=no
+ ;;
+ freebsd2.2*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ freebsd2*)
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+ freebsd* | kfreebsd*-gnu | dragonfly*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ hpux9*)
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ hpux10*)
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ fi
+ ;;
+ hpux11*)
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ case $host_cpu in
+ hppa*64*|ia64*)
+ hardcode_direct=no
+ ;;
+ *)
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ esac
+ fi
+ ;;
+ irix5* | irix6* | nonstopux*)
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ netbsd*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ newsos6)
+ hardcode_direct=yes
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ openbsd*)
+ hardcode_direct=yes
+ if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ else
+ case "$host_os" in
+ openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ *)
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ ;;
+ os2*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ ;;
+ osf3*)
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ osf4* | osf5*)
+ if test "$GCC" = yes; then
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ else
+ # Both cc and cxx compiler support -rpath directly
+ hardcode_libdir_flag_spec='-rpath $libdir'
+ fi
+ hardcode_libdir_separator=:
+ ;;
+ solaris*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ sunos4*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+ sysv4)
+ case $host_vendor in
+ sni)
+ hardcode_direct=yes # is this really true???
+ ;;
+ siemens)
+ hardcode_direct=no
+ ;;
+ motorola)
+ hardcode_direct=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ ;;
+ sysv4.3*)
+ ;;
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ ld_shlibs=yes
+ fi
+ ;;
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7*)
+ ;;
+ sysv5* | sco3.2v5* | sco5v6*)
+ hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-R,$libdir`'
+ hardcode_libdir_separator=':'
+ ;;
+ uts4*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ ;;
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+fi
+
+# Check dynamic linker characteristics
+# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER.
+libname_spec='lib$name'
+case "$host_os" in
+ aix3*)
+ ;;
+ aix4* | aix5*)
+ ;;
+ amigaos*)
+ ;;
+ beos*)
+ ;;
+ bsdi[45]*)
+ ;;
+ cygwin* | mingw* | pw32*)
+ shrext=.dll
+ ;;
+ darwin* | rhapsody*)
+ shrext=.dylib
+ ;;
+ dgux*)
+ ;;
+ freebsd1*)
+ ;;
+ kfreebsd*-gnu)
+ ;;
+ freebsd* | dragonfly*)
+ ;;
+ gnu*)
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ case $host_cpu in
+ ia64*)
+ shrext=.so
+ ;;
+ hppa*64*)
+ shrext=.sl
+ ;;
+ *)
+ shrext=.sl
+ ;;
+ esac
+ ;;
+ interix3*)
+ ;;
+ irix5* | irix6* | nonstopux*)
+ case "$host_os" in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= ;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 ;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 ;;
+ *) libsuff= shlibsuff= ;;
+ esac
+ ;;
+ esac
+ ;;
+ linux*oldld* | linux*aout* | linux*coff*)
+ ;;
+ linux*)
+ ;;
+ knetbsd*-gnu)
+ ;;
+ netbsd*)
+ ;;
+ newsos6)
+ ;;
+ nto-qnx*)
+ ;;
+ openbsd*)
+ ;;
+ os2*)
+ libname_spec='$name'
+ shrext=.dll
+ ;;
+ osf3* | osf4* | osf5*)
+ ;;
+ solaris*)
+ ;;
+ sunos4*)
+ ;;
+ sysv4 | sysv4.3*)
+ ;;
+ sysv4*MP*)
+ ;;
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ ;;
+ uts4*)
+ ;;
+esac
+
+sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
+escaped_wl=`echo "X$wl" | sed -e 's/^X//' -e "$sed_quote_subst"`
+shlibext=`echo "$shrext" | sed -e 's,^\.,,'`
+escaped_hardcode_libdir_flag_spec=`echo "X$hardcode_libdir_flag_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+
+LC_ALL=C sed -e 's/^\([a-zA-Z0-9_]*\)=/acl_cv_\1=/' <<EOF
+
+# How to pass a linker flag through the compiler.
+wl="$escaped_wl"
+
+# Static library suffix (normally "a").
+libext="$libext"
+
+# Shared library suffix (normally "so").
+shlibext="$shlibext"
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec="$escaped_hardcode_libdir_flag_spec"
+
+# Whether we need a single -rpath flag with a separated argument.
+hardcode_libdir_separator="$hardcode_libdir_separator"
+
+# Set to yes if using DIR/libNAME.so during linking hardcodes DIR into the
+# resulting binary.
+hardcode_direct="$hardcode_direct"
+
+# Set to yes if using the -LDIR flag during linking hardcodes DIR into the
+# resulting binary.
+hardcode_minus_L="$hardcode_minus_L"
+
+EOF
diff --git a/configure.in b/configure.in
index cad32b939..541e3a6d8 100644
--- a/configure.in
+++ b/configure.in
@@ -25,7 +25,7 @@ Boston, MA 02110-1301, USA.
]])
-AC_PREREQ(2.53)
+AC_PREREQ(2.59)
dnl `patsubst' here deletes the newline which "echo" prints. We can't use
dnl "echo -n" since -n is not portable (see autoconf manual "Limitations of
@@ -37,9 +37,11 @@ AC_INIT(patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${PACKAGE}),[
patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${GUILE_VERSION}),[
]),
[bug-guile@gnu.org])
-AC_CONFIG_AUX_DIR([.])
+AC_CONFIG_AUX_DIR([build-aux])
+AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_SRCDIR(GUILE-VERSION)
-AM_INIT_AUTOMAKE([no-define])
+
+AM_INIT_AUTOMAKE([gnu no-define check-news])
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
AC_CONFIG_SRCDIR([GUILE-VERSION])
@@ -66,12 +68,12 @@ AC_LIBTOOL_WIN32_DLL
AC_PROG_INSTALL
AC_PROG_CC
+gl_EARLY
AC_PROG_CPP
AC_PROG_AWK
-AC_AIX
-AC_ISC_POSIX
-AC_MINIX
+dnl Gnulib.
+gl_INIT
AM_PROG_CC_STDC
# for per-target cflags in the libguile subdir
@@ -546,7 +548,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h proces
regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-strings.h direct.h langinfo.h nl_types.h])
+direct.h langinfo.h nl_types.h])
# "complex double" is new in C99, and "complex" is only a keyword if
# <complex.h> is included
@@ -621,6 +623,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# DQNAN - OSF specific
# (DINFINITY and DQNAN are actually global variables, not functions)
# chsize - an MS-DOS-ism, found in mingw
+# cexp, clog - not in various pre-c99 systems, and note that it's possible
+# for gcc to provide the "complex double" type but the system to not
+# have functions like cexp and clog
# clog10 - not in mingw (though others like clog and csqrt are)
# fesetround - available in C99, but not older systems
# ftruncate - posix, but probably not older systems (current mingw
@@ -638,7 +643,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
# nl_langinfo - X/Open, not available on Windows.
#
-AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strncasecmp strcoll strcoll_l newlocale nl_langinfo])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo])
# Reasons for testing:
# netdb.h - not in mingw
@@ -676,7 +681,6 @@ AC_SEARCH_LIBS(crypt, crypt,
#
if test "$ac_cv_type_complex_double" = yes; then
- AC_CHECK_FUNCS(cexp clog carg)
AC_CACHE_CHECK([whether csqrt is usable],
guile_cv_use_csqrt,
[AC_TRY_RUN([
@@ -987,16 +991,6 @@ int main () { return (isnan(x) != 0); }]]),
[Define to 1 if you have the `isnan' macro or function.])],
[AC_MSG_RESULT([no])])
-# We must have a proper stack-using alloca in order for stack-copying
-# continuations to work properly. If we don't find a native one,
-# abort.
-
-AC_FUNC_ALLOCA
-if test "$ALLOCA" = "alloca.o"
-then
- AC_ERROR([No native alloca found.])
-fi
-
# Reasons for checking:
#
# st_rdev
@@ -1362,6 +1356,7 @@ AC_CONFIG_FILES([libguile/gen-scmconfig.h])
AC_CONFIG_FILES([
Makefile
am/Makefile
+ lib/Makefile
benchmark-suite/Makefile
doc/Makefile
doc/goops/Makefile
diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog
index fc2840d55..ebb38fa33 100644
--- a/doc/ref/ChangeLog
+++ b/doc/ref/ChangeLog
@@ -1,3 +1,16 @@
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * slib.texi (SLIB installation): Don't recommend using the site
+ directory for the symlink; instead, suggest either adding a
+ symlink in `/.../share/guile/1.8' (because slib will look for
+ its files in the implementation vicinity by default) or defining
+ `SCHEME_LIBRARY_PATH'. Mention `new-catalog'.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-modules.texi (SRFI-34): New node.
+ (SRFI-35): New node.
+
2007-07-18 Stephen Compall <s11@member.fsf.org>
* srfi-modules.texi: Describe SRFI-37 in a new subsection.
diff --git a/doc/ref/slib.texi b/doc/ref/slib.texi
index 0435b97ac..fc8f91933 100644
--- a/doc/ref/slib.texi
+++ b/doc/ref/slib.texi
@@ -23,7 +23,7 @@ slib, The SLIB Manual}). For example,
@example
(use-modules (ice-9 slib))
(require 'primes)
-(probably-prime? 13)
+(prime? 13)
@result{} #t
@end example
@@ -31,7 +31,7 @@ A few Guile core functions are overridden by the SLIB setups; for
example the SLIB version of @code{delete-file} returns a boolean
indicating success or failure, whereas the Guile core version throws
an error for failure. In general (and as might be expected) when SLIB
-is loaded it's the SLIB specifications which are followed.
+is loaded it's the SLIB specifications that are followed.
@menu
* SLIB installation::
@@ -41,17 +41,30 @@ is loaded it's the SLIB specifications which are followed.
@node SLIB installation
@subsection SLIB installation
-The following seems to work (e.g., with slib versions 2c7 and 2d2):
+The following procedure works, e.g., with SLIB version 3a3
+(@pxref{Installation, SLIB installation,, slib, The SLIB Portable Scheme
+Library}):
@enumerate
@item
-Unpack slib somewhere, e.g., @file{/usr/local/share/slib}.
+Unpack SLIB and install it using @code{make install} from its directory.
+By default, this will install SLIB in @file{/usr/local/lib/slib/}.
+Running @code{make installinfo} installs its documentation, by default
+under @file{/usr/local/info/}.
@item
-Create a symlink in the Guile site directory to slib, e.g.,:
+Define the @code{SCHEME_LIBRARY_PATH} environment variable:
@example
-ln -s /usr/local/share/slib /usr/local/share/guile/site/slib
+$ SCHEME_LIBRARY_PATH=/usr/local/lib/slib/
+$ export SCHEME_LIBRARY_PATH
+@end example
+
+Alternatively, you can create a symlink in the Guile directory to SLIB,
+e.g.:
+
+@example
+ln -s /usr/local/lib/slib /usr/local/share/guile/1.8/slib
@end example
@item
@@ -60,12 +73,12 @@ Use Guile to create the catalog file, e.g.,:
@example
# guile
guile> (use-modules (ice-9 slib))
-guile> (load "/usr/local/share/slib/mklibcat.scm")
+guile> (require 'new-catalog)
guile> (quit)
@end example
The catalog data should now be in
-@file{/usr/local/share/guile/site/slibcat}.
+@file{/usr/local/share/guile/1.8/slibcat}.
If instead you get an error such as:
@@ -77,15 +90,6 @@ then a solution is to get a newer version of Guile,
or to modify @file{ice-9/slib.scm} to use @code{define-public} for the
offending variables.
-@item
-Install the documentation:
-
-@example
-cd /usr/local/share/slib
-rm /usr/local/info/slib.info*
-cp slib.info /usr/local/info
-install-info slib.info /usr/local/info/dir
-@end example
@end enumerate
@node JACAL
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index c71578dab..cacd769c2 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -37,6 +37,8 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-19:: Time/Date library.
* SRFI-26:: Specializing parameters
* SRFI-31:: A special form `rec' for recursive evaluation
+* SRFI-34:: Exception handling.
+* SRFI-35:: Conditions.
* SRFI-37:: args-fold program argument processor
* SRFI-39:: Parameter objects
* SRFI-55:: Requiring Features.
@@ -2402,6 +2404,196 @@ The second syntax can be used to create anonymous recursive functions:
@end lisp
+@node SRFI-34
+@subsection SRFI-34 - Exception handling for programs
+
+@cindex SRFI-34
+Guile provides an implementation of
+@uref{http://srfi.schemers.org/srfi-34/srfi-34.html, SRFI-34's exception
+handling mechanisms} as an alternative to its own built-in mechanisms
+(@pxref{Exceptions}). It can be made available as follows:
+
+@lisp
+(use-modules (srfi srfi-34))
+@end lisp
+
+@c FIXME: Document it.
+
+
+@node SRFI-35
+@subsection SRFI-35 - Conditions
+
+@cindex SRFI-35
+@cindex conditions
+@cindex exceptions
+
+@uref{http://srfi.schemers.org/srfi-35/srfi-35.html, SRFI-35} implements
+@dfn{conditions}, a data structure akin to records designed to convey
+information about exceptional conditions between parts of a program. It
+is normally used in conjunction with SRFI-34's @code{raise}:
+
+@lisp
+(raise (condition (&message
+ (message "An error occurred"))))
+@end lisp
+
+Users can define @dfn{condition types} containing arbitrary information.
+Condition types may inherit from one another. This allows the part of
+the program that handles (or ``catches'') conditions to get accurate
+information about the exceptional condition that arose.
+
+SRFI-35 conditions are made available using:
+
+@lisp
+(use-modules (srfi srfi-35))
+@end lisp
+
+The procedures available to manipulate condition types are the
+following:
+
+@deffn {Scheme Procedure} make-condition-type id parent field-names
+Return a new condition type named @var{id}, inheriting from
+@var{parent}, and with the fields whose names are listed in
+@var{field-names}. @var{field-names} must be a list of symbols and must
+not contain names already used by @var{parent} or one of its supertypes.
+@end deffn
+
+@deffn {Scheme Procedure} condition-type? obj
+Return true if @var{obj} is a condition type.
+@end deffn
+
+Conditions can be created and accessed with the following procedures:
+
+@deffn {Scheme Procedure} make-condition type . field+value
+Return a new condition of type @var{type} with fields initialized as
+specified by @var{field+value}, a sequence of field names (symbols) and
+values as in the following example:
+
+@lisp
+(let* ((&ct (make-condition-type 'foo &condition '(a b c))))
+ (make-condition &ct 'a 1 'b 2 'c 3))
+@end lisp
+
+Note that all fields of @var{type} and its supertypes must be specified.
+@end deffn
+
+@deffn {Scheme Procedure} make-compound-condition . conditions
+Return a new compound condition composed of @var{conditions}. The
+returned condition has the type of each condition of @var{conditions}
+(per @code{condition-has-type?}).
+@end deffn
+
+@deffn {Scheme Procedure} condition-has-type? c type
+Return true if condition @var{c} has type @var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} condition-ref c field-name
+Return the value of the field named @var{field-name} from condition @var{c}.
+
+If @var{c} is a compound condition and several underlying condition
+types contain a field named @var{field-name}, then the value of the
+first such field is returned, using the order in which conditions were
+passed to @var{make-compound-condition}.
+@end deffn
+
+@deffn {Scheme Procedure} extract-condition c type
+Return a condition of condition type @var{type} with the field values
+specified by @var{c}.
+
+If @var{c} is a compound condition, extract the field values from the
+subcondition belonging to @var{type} that appeared first in the call to
+@code{make-compound-condition} that created the the condition.
+@end deffn
+
+Convenience macros are also available to create condition types and
+conditions.
+
+@deffn {library syntax} define-condition-type type supertype predicate field-spec...
+Define a new condition type named @var{type} that inherits from
+@var{supertype}. In addition, bind @var{predicate} to a type predicate
+that returns true when passed a condition of type @var{type} or any of
+its subtypes. @var{field-spec} must have the form @code{(field
+accessor)} where @var{field} is the name of field of @var{type} and
+@var{accessor} is the name of a procedure to access field @var{field} in
+conditions of type @var{type}.
+
+The example below defines condition type @code{&foo}, inheriting from
+@code{&condition} with fields @code{a}, @code{b} and @code{c}:
+
+@lisp
+(define-condition-type &foo &condition
+ foo-condition?
+ (a foo-a)
+ (b foo-b)
+ (c foo-c))
+@end lisp
+@end deffn
+
+@deffn {library syntax} condition type-field-bindings...
+Return a new condition, or compound condition, initialized according to
+@var{type-field-bindings}. Each @var{type-field-binding} must have the
+form @code{(type field-specs...)}, where @var{type} is the name of a
+variable bound to condition type; each @var{field-spec} must have the
+form @code{(field-name value)} where @var{field-name} is a symbol
+denoting the field being initialized to @var{value}. As for
+@code{make-condition}, all fields must be specified.
+
+The following example returns a simple condition:
+
+@lisp
+(condition (&message (message "An error occurred")))
+@end lisp
+
+The one below returns a compound condition:
+
+@lisp
+(condition (&message (message "An error occurred"))
+ (&serious))
+@end lisp
+@end deffn
+
+Finally, SRFI-35 defines a several standard condition types.
+
+@defvar &condition
+This condition type is the root of all condition types. It has no
+fields.
+@end defvar
+
+@defvar &message
+A condition type that carries a message describing the nature of the
+condition to humans.
+@end defvar
+
+@deffn {Scheme Procedure} message-condition? c
+Return true if @var{c} is of type @code{&message} or one of its
+subtypes.
+@end deffn
+
+@deffn {Scheme Procedure} condition-message c
+Return the message associated with message condition @var{c}.
+@end deffn
+
+@defvar &serious
+This type describes conditions serious enough that they cannot safely be
+ignored. It has no fields.
+@end defvar
+
+@deffn {Scheme Procedure} serious-condition? c
+Return true if @var{c} is of type @code{&serious} or one of its
+subtypes.
+@end deffn
+
+@defvar &error
+This condition describes errors, typically caused by something that has
+gone wrong in the interaction of the program with the external world or
+the user.
+@end defvar
+
+@deffn {Scheme Procedure} error? c
+Return true if @var{c} is of type @code{&error} or one of its subtypes.
+@end deffn
+
+
@node SRFI-37
@subsection SRFI-37 - args-fold
@cindex SRFI-37
diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog
index 94cd83e71..a599a6699 100644
--- a/guile-readline/ChangeLog
+++ b/guile-readline/ChangeLog
@@ -1,3 +1,9 @@
+2007-07-29 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (INCLUDES): Add Gnulib includes.
+ (libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD): Added
+ `../lib/libgnu.la'.
+
2007-07-15 Ludovic Courtès <ludo@gnu.org>
* LIBGUILEREADLINE-VERSION
diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am
index f1f038755..50523e5b3 100644
--- a/guile-readline/Makefile.am
+++ b/guile-readline/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -25,15 +25,17 @@ SUBDIRS = ice-9
DEFS = @DEFS@ @EXTRA_DEFS@
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
-## building.
-INCLUDES = -I. -I.. -I$(srcdir)/..
+## building. Also look for Gnulib headers in `lib'.
+INCLUDES = -I. -I.. -I$(srcdir)/.. \
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib
GUILE_SNARF = ../libguile/guile-snarf
lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c
-libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = \
+ ../libguile/libguile.la ../lib/libgnu.la
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic -no-undefined
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index bb2d926ff..b761091c0 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,22 @@
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * slib.scm: Let SLIB's `guile.init' do most of the job. See the
+ `guile-devel@gnu.org' mailing list archive for details.
+
+2007-09-01 Andy Wingo <wingo@pobox.com>
+
+ * boot-9.scm (duplicate-handlers)[warn, warn-override-core]:
+ Send warnings to `stderr' instead of `stdout'.
+
+2007-08-08 Ludovic Courtès <ludo@gnu.org>
+
+ * boot-9.scm (%record-type-check): Renamed to
+ `%record-type-error'.
+ (record-accessor): Directly use `struct-vtable' and
+ `struct-ref', thereby avoiding indirections and procedure-call
+ overhead.
+ (record-modifier): Likewise.
+
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
Implemented lazy duplicate binding handling. Fixed the
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 115abfdfa..6ada33c68 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -429,7 +429,7 @@
(define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
-(define (%record-type-check rtd obj) ;; private helper
+(define (%record-type-error rtd obj) ;; private helper
(or (eq? rtd (record-type-descriptor obj))
(scm-error 'wrong-type-arg "%record-type-check"
"Wrong type record (want `~S'): ~S"
@@ -441,8 +441,9 @@
(if (not pos)
(error 'no-such-field field-name))
(local-eval `(lambda (obj)
- (%record-type-check ',rtd obj)
- (struct-ref obj ,pos))
+ (if (eq? (struct-vtable obj) ,rtd)
+ (struct-ref obj ,pos)
+ (%record-type-error ,rtd obj)))
the-root-environment)))
(define (record-modifier rtd field-name)
@@ -450,8 +451,9 @@
(if (not pos)
(error 'no-such-field field-name))
(local-eval `(lambda (obj val)
- (%record-type-check ',rtd obj)
- (struct-set! obj ,pos val))
+ (if (eq? (struct-vtable obj) ,rtd)
+ (struct-set! obj ,pos val)
+ (%record-type-error ,rtd obj)))
the-root-environment)))
@@ -3061,7 +3063,7 @@ module '(ice-9 q) '(make-q q-length))}."
#f))
(define (warn module name int1 val1 int2 val2 var val)
- (format #t
+ (format (current-error-port)
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
(module-name module)
name
@@ -3083,7 +3085,7 @@ module '(ice-9 q) '(make-q q-length))}."
(define (warn-override-core module name int1 val1 int2 val2 var val)
(and (eq? int1 the-scm-module)
(begin
- (format #t
+ (format (current-error-port)
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
(module-name module)
(module-name int2)
diff --git a/ice-9/slib.scm b/ice-9/slib.scm
index a63edb699..a2b526562 100644
--- a/ice-9/slib.scm
+++ b/ice-9/slib.scm
@@ -1,17 +1,17 @@
;;;; slib.scm --- definitions needed to get SLIB to work with Guile
;;;;
-;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, 2007 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 library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@@ -29,386 +29,14 @@
logical:bit-extract logical:integer-expt logical:ipow-by-squaring
slib:eval-load slib:tab slib:form-feed difftime offset-time
software-type)
- :replace (delete-file open-file provide provided? system)
:no-backtrace)
-
-(define (eval-load <filename> evl)
- (if (not (file-exists? <filename>))
- (set! <filename> (string-append <filename> (scheme-file-suffix))))
- (call-with-input-file <filename>
- (lambda (port)
- (let ((old-load-pathname *load-pathname*))
- (set! *load-pathname* <filename>)
- (do ((o (read port) (read port)))
- ((eof-object? o))
- (evl o))
- (set! *load-pathname* old-load-pathname)))))
-
-
-
-(define slib:exit quit)
-(define slib:error error)
-(define slib:warn warn)
-(define slib:eval (lambda (x) (eval x slib-module)))
-(define defmacro:eval (lambda (x) (eval x (interaction-environment))))
-(define logical:logand logand)
-(define logical:logior logior)
-(define logical:logxor logxor)
-(define logical:lognot lognot)
-(define logical:ash ash)
-(define logical:logcount logcount)
-(define logical:integer-length integer-length)
-(define logical:bit-extract bit-extract)
-(define logical:integer-expt integer-expt)
-(define slib:eval-load eval-load)
-(define slib:tab #\tab)
-(define slib:form-feed #\page)
-
-(define slib-module (current-module))
-
-(define (defined? symbol)
- (module-defined? slib-module symbol))
-
-;;; *FEATURES* should be set to a list of symbols describing features
-;;; of this implementation. Suggestions for features are:
-(set! *features*
- (append
- '(
- source ;can load scheme source files
- ;(slib:load-source "filename")
-; compiled ;can load compiled files
- ;(slib:load-compiled "filename")
-
- ;; Scheme report features
-
-; rev5-report ;conforms to
- eval ;R5RS two-argument eval
-; values ;R5RS multiple values
- dynamic-wind ;R5RS dynamic-wind
-; macro ;R5RS high level macros
- delay ;has DELAY and FORCE
- multiarg-apply ;APPLY can take more than 2 args.
-; rationalize
- rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
- ;LIST->STRING, STRING-COPY,
- ;STRING-FILL!, LIST->VECTOR,
- ;VECTOR->LIST, and VECTOR-FILL!
-
-; rev4-report ;conforms to
-
-; ieee-p1178 ;conforms to
-
-; rev3-report ;conforms to
-
- rev2-procedures ;SUBSTRING-MOVE-LEFT!,
- ;SUBSTRING-MOVE-RIGHT!,
- ;SUBSTRING-FILL!,
- ;STRING-NULL?, APPEND!, 1+,
- ;-1+, <?, <=?, =?, >?, >=?
-; object-hash ;has OBJECT-HASH
-
- multiarg/and- ;/ and - can take more than 2 args.
- with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
-; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
-; ieee-floating-point ;conforms to IEEE Standard 754-1985
- ;IEEE Standard for Binary
- ;Floating-Point Arithmetic.
- full-continuation ;can return multiple times
-
- ;; Other common features
-
-; srfi ;srfi-0, COND-EXPAND finds all srfi-*
-; sicp ;runs code from Structure and
- ;Interpretation of Computer
- ;Programs by Abelson and Sussman.
- defmacro ;has Common Lisp DEFMACRO
-; record ;has user defined data structures
- string-port ;has CALL-WITH-INPUT-STRING and
- ;CALL-WITH-OUTPUT-STRING
-; sort
-; pretty-print
-; object->string
-; format ;Common-lisp output formatting
-; trace ;has macros: TRACE and UNTRACE
-; compiler ;has (COMPILER)
-; ed ;(ED) is editor
-
- ;; core definitions compatible, plus `make-random-state' below
- random
- )
-
- (if (defined? 'getenv)
- '(getenv)
- '())
-
- (if (defined? 'current-time)
- '(current-time)
- '())
-
- (if (defined? 'system)
- '(system)
- '())
-
- (if (defined? 'char-ready?)
- '(char-ready?)
- '())
-
- *features*))
-
-;; The array module specified by slib 3a1 is not the same as what guile
-;; provides, so we must remove `array' from the features list.
-;;
-;; The main difference is `create-array' which is similar to
-;; `make-uniform-array', but the `Ac64' etc prototype procedures incorporate
-;; an initial fill element into the prototype.
-;;
-;; Believe the array-for-each module will need to be taken from slib when
-;; the array module is taken from there, since what the array module creates
-;; won't be understood by the guile functions. So remove `array-for-each'
-;; from the features list too.
-;;
-;; Also, slib 3a1 array-for-each specifies an `array-map' which is not in
-;; guile (but could be implemented quite easily).
-;;
-;; ENHANCE-ME: It'd be nice to implement what's necessary, since the guile
-;; functions should be more efficient than the implementation in slib.
-;;
-;; FIXME: Since the *features* variable is shared by slib and the guile
-;; core, removing these feature symbols has the unhappy effect of making it
-;; look like they aren't in the core either. Let's assume that arrays have
-;; been present unconditionally long enough that no guile-specific code will
-;; bother to test. An alternative would be to make a new separate
-;; *features* variable which the slib stuff operated on, leaving the core
-;; mechanism alone. That might be a good thing anyway.
-;;
-(set! *features* (delq 'array *features*))
-(set! *features* (delq 'array-for-each *features*))
-
-;; The random module in slib 3a1 provides a `random:chunk' which is used by
-;; the random-inexact module. Guile doesn't provide random:chunk so we must
-;; remove 'random from `*features*' to use the slib code.
-;;
-;; ENHANCE-ME: Maybe Guile could provide a `random:chunk', the rest of the
-;; random module is already the same as Guile.
-;;
-;; FIXME: As per the array bits above, *features* is shared by slib and the
-;; guile core, so removing 'random has the unhappy effect of making it look
-;; like this isn't in the core. Let's assume random numbers have been
-;; present unconditionally long enough that no guile-specific code will
-;; bother to test.
-;;
-(set! *features* (delq 'random *features*))
-
-
-;;; FIXME: Because uers want require to search the path, this uses
-;;; load-from-path, which probably isn't a hot idea. slib
-;;; doesn't expect this function to search a path, so I expect to get
-;;; bug reports at some point complaining that the wrong file gets
-;;; loaded when something accidentally appears in the path before
-;;; slib, etc. ad nauseum. However, the right fix seems to involve
-;;; changing catalog:get in slib/require.scm, and I don't expect
-;;; Aubrey will integrate such a change. So I'm just going to punt
-;;; for the time being.
-(define (slib:load name)
- (save-module-excursion
- (lambda ()
- (set-current-module slib-module)
- (let ((errinfo (catch 'system-error
- (lambda ()
- (load-from-path name)
- #f)
- (lambda args args))))
- (if (and errinfo
- (catch 'system-error
- (lambda ()
- (load-from-path
- (string-append name ".scm"))
- #f)
- (lambda args args)))
- (apply throw errinfo))))))
-
-(define slib:load-source slib:load)
-(define defmacro:load slib:load)
-
-(define slib-parent-dir
- (let* ((path (%search-load-path "slib/require.scm")))
- (if path
- (substring path 0 (- (string-length path) 17))
- (error "Could not find slib/require.scm in " %load-path))))
-
-(define (implementation-vicinity)
- (string-append slib-parent-dir "/"))
-(define (library-vicinity)
- (string-append (implementation-vicinity) "slib/"))
-(define home-vicinity
- (let ((home-path (getenv "HOME")))
- (lambda () home-path)))
-(define (scheme-implementation-type) 'guile)
-(define scheme-implementation-version version)
-;;; (scheme-implementation-home-page) should return a (string) URI
-;;; (Uniform Resource Identifier) for this scheme implementation's home
-;;; page; or false if there isn't one.
-(define (scheme-implementation-home-page)
- "http://www.gnu.org/software/guile/guile.html")
-
-;; legacy from r3rs, but slib says all implementations provide these
-;; ("Legacy" section of the "Miscellany" node in the manual)
-(define-public t #t)
-(define-public nil #f)
-
-;; ENHANCE-ME: Could call ioctl TIOCGWINSZ to get the size of a tty (see
-;; "man 4 tty_ioctl" on a GNU/Linux system), on systems with that.
-(define (output-port-width . arg) 80)
-(define (output-port-height . arg) 24)
-
-;; slib 3a1 and up, straight from Template.scm
-(define-public (call-with-open-ports . ports)
- (define proc (car ports))
- (cond ((procedure? proc) (set! ports (cdr ports)))
- (else (set! ports (reverse ports))
- (set! proc (car ports))
- (set! ports (reverse (cdr ports)))))
- (let ((ans (apply proc ports)))
- (for-each close-port ports)
- ans))
-
-;; slib (version 3a1) requires open-file accept a symbol r, rb, w or wb for
-;; MODES, so extend the guile core open-file accordingly.
-;;
-;; slib (version 3a1) also calls open-file with strings "rb" or "wb", not
-;; sure if that's intentional, but in any case this extension continues to
-;; accept strings to make that work.
-;;
-(define-public (open-file filename modes)
- (if (symbol? modes)
- (set! modes (symbol->string modes)))
- ((@ (guile) open-file) filename modes))
-
-;; returning #t/#f instead of throwing an error for failure
-(define-public (delete-file filename)
- (catch 'system-error
- (lambda () ((@ (guile) delete-file) filename) #t)
- (lambda args #f)))
-
-;; Nothing special to do for this, so straight from Template.scm. Maybe
-;; "sensible-browser" for a debian system would be worth trying too (and
-;; would be good on a tty).
-(define-public (browse-url url)
- (define (try cmd end) (zero? (system (string-append cmd url end))))
- (or (try "netscape-remote -remote 'openURL(" ")'")
- (try "netscape -remote 'openURL(" ")'")
- (try "netscape '" "'&")
- (try "netscape '" "'")))
-
-;;; {array-for-each}
-(define (array-indexes ra)
- (let ((ra0 (apply make-array '() (array-shape ra))))
- (array-index-map! ra0 list)
- ra0))
-
-;;; {Random numbers}
-;;;
-(define (make-random-state . args)
- (let ((seed (if (null? args) *random-state* (car args))))
- (cond ((string? seed))
- ((number? seed) (set! seed (number->string seed)))
- (else (let ()
- (require 'object->string)
- (set! seed (object->limited-string seed 50)))))
- (seed->random-state seed)))
-
-;;; {rev2-procedures}
-;;;
-
-(define -1+ 1-)
-(define <? <)
-(define <=? <=)
-(define =? =)
-(define >? >)
-(define >=? >=)
-
-;;; {system}
-;;;
-;; If the program run is killed by a signal, the shell normally gives an
-;; exit code of 128+signum. If the shell itself is killed by a signal then
-;; we do the same 128+signum here.
-;;
-;; "stop-sig" shouldn't arise here, since system shouldn't be calling
-;; waitpid with WUNTRACED, but allow for it anyway, just in case.
-;;
-(if (memq 'system *features*)
- (define-public system
- (lambda (str)
- (let ((st ((@ (guile) system) str)))
- (or (status:exit-val st)
- (+ 128 (or (status:term-sig st)
- (status:stop-sig st))))))))
-
-;;; {Time}
-;;;
-
-(define difftime -)
-(define offset-time +)
-
-
-(define define
- (procedure->memoizing-macro
- (lambda (exp env)
- (if (= (length env) 1)
- `(define-public ,@(cdr exp))
- `(define-private ,@(cdr exp))))))
-
-;;; Hack to make syncase macros work in the slib module
-(if (nested-ref the-root-module '(app modules ice-9 syncase))
- (set-object-property! (module-local-variable (current-module) 'define)
- '*sc-expander*
- '(define)))
-
-(define (software-type)
- "Return a symbol describing the current platform's operating system.
-This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
-THINKC, AMIGA, ATARIST, MACH, or ACORN.
-
-Note that most varieties of Unix are considered to be simply \"UNIX\".
-That is because when a program depends on features that are not present
-on every operating system, it is usually better to test for the presence
-or absence of that specific feature. The return value of
-@code{software-type} should only be used for this purpose when there is
-no other easy or unambiguous way of detecting such features."
- 'UNIX)
-
-(slib:load (in-vicinity (library-vicinity) "require.scm"))
-
-(define require require:require)
-
-;; {Extensions to the require system so that the user can add new
-;; require modules easily.}
-
-(define *vicinity-table*
- (list
- (cons 'implementation (implementation-vicinity))
- (cons 'library (library-vicinity))))
-
-(define (install-require-vicinity name vicinity)
- (let ((entry (assq name *vicinity-table*)))
- (if entry
- (set-cdr! entry vicinity)
- (set! *vicinity-table*
- (acons name vicinity *vicinity-table*)))))
-
-(define (install-require-module name vicinity-name file-name)
- (if (not *catalog*) ;Fix which loads catalog in slib
- (catalog:get 'random)) ;(doesn't load the feature 'random)
- (let ((entry (assq name *catalog*))
- (vicinity (cdr (assq vicinity-name *vicinity-table*))))
- (let ((path-name (in-vicinity vicinity file-name)))
- (if entry
- (set-cdr! entry path-name)
- (set! *catalog*
- (acons name path-name *catalog*))))))
-
-(define (make-exchanger obj)
- (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+;; Initialize SLIB.
+(load-from-path "slib/guile.init")
+
+;; SLIB redefines a few core symbols based on their default definition.
+;; Thus, we only replace them at this point so that their previous definition
+;; is visible when `guile.init' is loaded.
+(module-replace! (current-module)
+ '(delete-file open-file provide provided? system))
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 328e6ec4e..f3dd1c5f7 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,120 @@
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * threads.c (on_thread_exit): Don't call `scm_leave_guile ()'
+ since we're already in non-guile mode. Reported by Greg Toxel
+ for NetBSD.
+
+2007-10-01 Ludovic Courtès <ludo@gnu.org>
+
+ * ports.c (flush_output_port): Expect directly a port instead of
+ a pair. Fixes a bug in the new port table (2007-08-26).
+
+2007-09-11 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_putenv): Confine the putenv("NAME=") bit to mingw, use
+ putenv("NAME") as the fallback everywhere else. In particular this is
+ needed for solaris 9. Reported by Frank Storbeck.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (flush_ws): Handle SCSH block comments.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ Fix alignment issues which showed up at least on SPARC.
+
+ * socket.c (scm_t_max_sockaddr, scm_t_getsockopt_result): New.
+ (scm_inet_pton): Change DST to `scm_t_uint32' for correct
+ alignment.
+ (scm_getsockopt): Change OPTVAL to `scm_t_getsockopt_result' for
+ correct alignment.
+ (_scm_from_sockaddr): Change ADDRESS to `scm_t_max_sockaddr *'.
+ (scm_from_sockaddr): Cast ADDRESS to `scm_t_max_sockaddr *'.
+ (MAX_SIZE_UN, MAX_SIZE_IN6): Removed.
+ (scm_accept, scm_getsockname, scm_getpeername, scm_recvfrom):
+ Use `scm_t_max_sockaddr' instead of "char max_addr[MAX_ADDR_SIZE]".
+
+2007-09-03 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_log): Test HAVE_CLOG as well as HAVE_COMPLEX_DOUBLE
+ before using clog(). It's possible for gcc to provide the "complex
+ double" type, but for the system not to have the complex funcs.
+ (scm_exp): Ditto HAVE_CEXP for cexp().
+ (clog, cexp, carg): Remove fallback definitions. These only
+ duplicated the code within scm_log and scm_exp, and the latter have to
+ exist for the case when there's no "complex double". So better just
+ fix up the conditionals selecting between the complex funcs and plain
+ doubles than worry about fallbacks.
+
+2007-09-02 Ludovic Courtès <ludo@gnu.org>
+
+ * socket.c (scm_make_socket_address): Free C_ADDRESS after use.
+ This fixes a memory leak.
+
+2007-08-26 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * fports.c gc-card.c gc.c gc.h ioext.c ports.c ports.h weaks.h
+ gc.c: replace port table with weak hash table. This simplifies
+ memory management, and fixes freed cells appearing in
+ port-for-each output.
+
+ * init.c (cleanup_for_exit): abort cleanup if init_mutex is still
+ held.
+
+2007-08-23 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (scm_read_quote): Record position and copy source
+ expression when asked to. Reported by Kevin.
+
+ * stime.c: Define `_REENTRANT' only if not already defined.
+
+2007-08-21 Kevin Ryde <user42@zip.com.au>
+
+ * gc-card.c (scm_i_card_statistics): Record scm_tc7_number types as
+ tc16 values so big, real, complex and fraction can be distinguished.
+
+ (scm_i_tag_name): Return "number" for scm_tc7_number, not NULL. NULL
+ was making numbers come out as "type 23" in gc-live-object-stats.
+ Fix tests of the tc16 number types, they were checked under
+ scm_tc7_number, but the values went down the tag>=255 smob case.
+ Put smob case under scm_tc7_smob instead of using tag>=255, per
+ recommendation in comments with scm_tc7_smob to use symbolic values.
+ Use SCM_TC2SMOBNUM to extract scm_smobs index, instead of explicit
+ code. Lose some unnecessary "break" statements.
+
+ (scm_i_card_statistics): Use scm_hashq_create_handle_x and modify the
+ element returned, rather than two lookups scm_hashq_ref and
+ scm_hashq_set_x.
+
+2007-08-17 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c: Add #define _REENTRANT, to get gmtime_r() prototype on
+ solaris 2.6. Reported by anirkko.
+
+2007-07-29 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (INCLUDES): Added Gnulib includes.
+ (gnulib_library): New.
+ (libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD): Added
+ `$(gnulib_library)'.
+ (libguile_la_LIBADD): Likewise.
+
+ * posix.c: Don't define `_GNU_SOURCE' since `gl_EARLY' arranges
+ to define it when available.
+ * srfi-14.c: Likewise.
+ * i18n.c: Likewise. Include Gnulib's <alloca.h>
+ * eval.c: Include Gnulib's <alloca.h>.
+ * filesys.c: Likewise.
+ * read.c: Don't include <strings.h> and don't provide an
+ `strncasecmp ()' replacement; use Gnulib's <string.h> and
+ `strncasecmp ()' instead.
+
+2007-07-25 Ludovic Courtès <ludo@gnu.org>
+
+ * eval.c (macroexp): When `scm_ilength (res) <= 0', return
+ immediately. This used to produce a circular memoized
+ expression, e.g., for `(set (quote x) #t)'.
+
2007-07-22 Ludovic Courtès <ludo@gnu.org>
Overhauled the reader, making it faster.
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 53a6da99e..88287508a 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -25,8 +25,12 @@ AUTOMAKE_OPTIONS = gnu
DEFS = @DEFS@
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
-## building.
-INCLUDES = -I.. -I$(top_srcdir)
+## building. Also look for Gnulib headers in `lib'.
+INCLUDES = -I.. -I$(top_srcdir) \
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib
+
+## The Gnulib Libtool archive.
+gnulib_library = $(top_builddir)/lib/libgnu.la
ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
@@ -114,7 +118,7 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
$(libguile_la_CFLAGS)
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
- libguile.la
+ libguile.la $(gnulib_library)
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
@@ -186,7 +190,7 @@ noinst_HEADERS = convert.i.c \
private-gc.h private-options.h
libguile_la_DEPENDENCIES = @LIBLOBJS@
-libguile_la_LIBADD = @LIBLOBJS@
+libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
# These are headers visible as <guile/mumble.h>
diff --git a/libguile/eval.c b/libguile/eval.c
index 1b18c688a..0e92241a6 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -27,25 +27,9 @@
# include <config.h>
#endif
-#include "libguile/__scm.h"
+#include <alloca.h>
-/* This blob per the Autoconf manual (under "Particular Functions"). */
-#if HAVE_ALLOCA_H
-# include <alloca.h>
-#elif defined __GNUC__
-# define alloca __builtin_alloca
-#elif defined _AIX
-# define alloca __alloca
-#elif defined _MSC_VER
-# include <malloc.h>
-# define alloca _alloca
-#else
-# include <stddef.h>
-# ifdef __cplusplus
-extern "C"
-# endif
-void *alloca (size_t);
-#endif
+#include "libguile/__scm.h"
#include <assert.h>
#include "libguile/_scm.h"
@@ -874,26 +858,29 @@ macroexp (SCM x, SCM env)
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
-
+
if (scm_ilength (res) <= 0)
- res = scm_list_2 (SCM_IM_BEGIN, res);
-
- /* njrev: Several queries here: (1) I don't see how it can be
- correct that the SCM_SETCAR 2 lines below this comment needs
- protection, but the SCM_SETCAR 6 lines above does not, so
- something here is probably wrong. (2) macroexp() is now only
- used in one place - scm_m_generalized_set_x - whereas all other
- macro expansion happens through expand_user_macros. Therefore
- (2.1) perhaps macroexp() could be eliminated completely now?
- (2.2) Does expand_user_macros need any critical section
- protection? */
+ /* Result of expansion is not a list. */
+ return (scm_list_2 (SCM_IM_BEGIN, res));
+ else
+ {
+ /* njrev: Several queries here: (1) I don't see how it can be
+ correct that the SCM_SETCAR 2 lines below this comment needs
+ protection, but the SCM_SETCAR 6 lines above does not, so
+ something here is probably wrong. (2) macroexp() is now only
+ used in one place - scm_m_generalized_set_x - whereas all other
+ macro expansion happens through expand_user_macros. Therefore
+ (2.1) perhaps macroexp() could be eliminated completely now?
+ (2.2) Does expand_user_macros need any critical section
+ protection? */
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (res));
- SCM_SETCDR (x, SCM_CDR (res));
- SCM_CRITICAL_SECTION_END;
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (res));
+ SCM_SETCDR (x, SCM_CDR (res));
+ SCM_CRITICAL_SECTION_END;
- goto macro_tail;
+ goto macro_tail;
+ }
}
/* Start of the memoizers for the standard R5RS builtin macros. */
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 1798bb698..0e90105ec 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -29,23 +29,7 @@
# include <config.h>
#endif
-/* This blob per the Autoconf manual (under "Particular Functions"). */
-#if HAVE_ALLOCA_H
-# include <alloca.h>
-#elif defined __GNUC__
-# define alloca __builtin_alloca
-#elif defined _AIX
-# define alloca __alloca
-#elif defined _MSC_VER
-# include <malloc.h>
-# define alloca _alloca
-#else
-# include <stddef.h>
-# ifdef __cplusplus
-extern "C"
-# endif
-void *alloca (size_t);
-#endif
+#include <alloca.h>
#include <stdio.h>
#include <errno.h>
diff --git a/libguile/fports.c b/libguile/fports.c
index f4c07af0d..171bde644 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -31,6 +31,7 @@
#include "libguile/gc.h"
#include "libguile/posix.h"
#include "libguile/dynwind.h"
+#include "libguile/hashtab.h"
#include "libguile/fports.h"
@@ -220,32 +221,35 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
/* Move ports with the specified file descriptor to new descriptors,
* resetting the revealed count to 0.
*/
-
-void
-scm_evict_ports (int fd)
+static SCM
+scm_i_evict_port (SCM handle, void *closure)
{
- long i;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ int fd = * (int*) closure;
+ SCM port = SCM_CAR (handle);
- for (i = 0; i < scm_i_port_table_size; i++)
+ if (SCM_FPORTP (port))
{
- SCM port = scm_i_port_table[i]->port;
+ scm_t_fport *fp = SCM_FSTREAM (port);
- if (SCM_FPORTP (port))
+ if (fp->fdes == fd)
{
- scm_t_fport *fp = SCM_FSTREAM (port);
-
- if (fp->fdes == fd)
- {
- fp->fdes = dup (fd);
- if (fp->fdes == -1)
- scm_syserror ("scm_evict_ports");
- scm_set_port_revealed_x (port, scm_from_int (0));
- }
+ fp->fdes = dup (fd);
+ if (fp->fdes == -1)
+ scm_syserror ("scm_evict_ports");
+ scm_set_port_revealed_x (port, scm_from_int (0));
}
}
+ return handle;
+}
+
+void
+scm_evict_ports (int fd)
+{
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ scm_internal_hash_for_each_handle (&scm_i_evict_port,
+ (void*) &fd,
+ scm_i_port_weak_hash);
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
}
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 2a778eb91..88652efd2 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -15,28 +15,11 @@
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
-#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */
-
#if HAVE_CONFIG_H
# include <config.h>
#endif
-#if HAVE_ALLOCA_H
-# include <alloca.h>
-#elif defined __GNUC__
-# define alloca __builtin_alloca
-#elif defined _AIX
-# define alloca __alloca
-#elif defined _MSC_VER
-# include <malloc.h>
-# define alloca _alloca
-#else
-# include <stddef.h>
-# ifdef __cplusplus
-extern "C"
-# endif
-void *alloca (size_t);
-#endif
+#include <alloca.h>
#include "libguile/_scm.h"
#include "libguile/feature.h"
diff --git a/libguile/init.c b/libguile/init.c
index b65bc17cb..d9d75242c 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -395,6 +395,14 @@ really_cleanup_for_exit (void *unused)
static void
cleanup_for_exit ()
{
+ if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
+ scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+ else
+ {
+ fprintf (stderr, "Cannot exit gracefully when init is in progress; aborting.\n");
+ abort ();
+ }
+
/* This function might be called in non-guile mode, so we need to
enter it temporarily.
*/
@@ -474,6 +482,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_backtrace (); /* Requires fluids */
scm_init_fports ();
scm_init_strports ();
+ scm_init_ports ();
scm_init_gdbint (); /* Requires strports */
scm_init_hash ();
scm_init_hashtab ();
@@ -492,7 +501,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_numbers ();
scm_init_options ();
scm_init_pairs ();
- scm_init_ports ();
#ifdef HAVE_POSIX
scm_init_filesys ();
scm_init_posix ();
diff --git a/libguile/ioext.c b/libguile/ioext.c
index fd232e48d..60b751fff 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -26,13 +26,14 @@
#include <errno.h>
#include "libguile/_scm.h"
-#include "libguile/ioext.h"
-#include "libguile/fports.h"
+#include "libguile/dynwind.h"
#include "libguile/feature.h"
+#include "libguile/fports.h"
+#include "libguile/hashtab.h"
+#include "libguile/ioext.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
-#include "libguile/dynwind.h"
#include <fcntl.h>
@@ -266,6 +267,19 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
}
#undef FUNC_NAME
+static SCM
+get_matching_port (void *closure, SCM port, SCM val, SCM result)
+{
+ int fd = * (int *) closure;
+ scm_t_port *entry = SCM_PTAB_ENTRY (port);
+
+ if (SCM_OPFPORTP (port)
+ && ((scm_t_fport *) entry->stream)->fdes == fd)
+ result = scm_cons (port, result);
+
+ return result;
+}
+
/* Return a list of ports using a given file descriptor. */
SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
(SCM fd),
@@ -275,18 +289,12 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
#define FUNC_NAME s_scm_fdes_to_ports
{
SCM result = SCM_EOL;
- int int_fd;
- long i;
-
- int_fd = scm_to_int (fd);
+ int int_fd = scm_to_int (fd);
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- for (i = 0; i < scm_i_port_table_size; i++)
- {
- if (SCM_OPFPORTP (scm_i_port_table[i]->port)
- && ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
- result = scm_cons (scm_i_port_table[i]->port, result);
- }
+ result = scm_internal_hash_fold (get_matching_port,
+ (void*) &int_fd, result,
+ scm_i_port_weak_hash);
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return result;
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 305977346..57cf5d266 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
@@ -5998,35 +5998,6 @@ scm_is_number (SCM z)
return scm_is_true (scm_number_p (z));
}
-#ifdef HAVE_COMPLEX_DOUBLE
-#ifndef HAVE_CLOG
-complex double clog (complex double z);
-complex double
-clog (complex double z)
-{
- return log(cabs(z))+I*carg(z);
-}
-#endif
-
-#ifndef HAVE_CEXP
-complex double cexp (complex double z);
-complex double
-cexp (complex double z)
-{
- return exp (cabs (z)) * cos(carg (z) + I*sin(carg (z)));
-}
-#endif
-
-#ifndef HAVE_CARG
-double carg (complex double z);
-double
-carg (complex double z)
-{
- return atan2 (cimag(z), creal(z));
-}
-#endif
-#endif /* HAVE_COMPLEX_DOUBLE */
-
/* In the following functions we dispatch to the real-arg funcs like log()
when we know the arg is real, instead of just handing everything to
@@ -6041,7 +6012,7 @@ SCM_DEFINE (scm_log, "log", 1, 0, 0,
{
if (SCM_COMPLEXP (z))
{
-#if HAVE_COMPLEX_DOUBLE
+#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG
return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
#else
double re = SCM_COMPLEX_REAL (z);
@@ -6107,7 +6078,7 @@ SCM_DEFINE (scm_exp, "exp", 1, 0, 0,
{
if (SCM_COMPLEXP (z))
{
-#if HAVE_COMPLEX_DOUBLE
+#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP
return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
#else
return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
diff --git a/libguile/ports.c b/libguile/ports.c
index fc716bebf..9c6129d11 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -42,12 +42,14 @@
#include "libguile/dynwind.h"
#include "libguile/keywords.h"
+#include "libguile/hashtab.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/mallocs.h"
#include "libguile/validate.h"
#include "libguile/ports.h"
#include "libguile/vectors.h"
+#include "libguile/weaks.h"
#include "libguile/fluids.h"
#ifdef HAVE_STRING_H
@@ -84,7 +86,7 @@
/* scm_ptobs scm_numptob
- * implement a dynamicly resized array of ptob records.
+ * implement a dynamically resized array of ptob records.
* Indexes into this table are used when generating type
* tags for smobjects (if you know a tag you can get an index and conversely).
*/
@@ -485,10 +487,11 @@ scm_i_dynwind_current_load_port (SCM port)
/* The port table --- an array of pointers to ports. */
-scm_t_port **scm_i_port_table = NULL;
-
-long scm_i_port_table_size = 0; /* Number of ports in SCM_I_PORT_TABLE. */
-long scm_i_port_table_room = 20; /* Actual size of the array. */
+/*
+ We need a global registry of ports to flush them all at exit, and to
+ get all the ports matching a file descriptor.
+ */
+SCM scm_i_port_weak_hash;
scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -567,33 +570,15 @@ scm_new_port_table_entry (scm_t_bits tag)
SCM z = scm_cons (SCM_EOL, SCM_EOL);
scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
- if (scm_i_port_table_size == scm_i_port_table_room)
- {
- /* initial malloc is in gc.c. this doesn't use scm_gc_malloc etc.,
- since it can never be freed during gc. */
- /* XXX (Ludo): Why not do it actually? */
- size_t new_size = scm_i_port_table_room * 2;
- /* XXX (Ludo): Can we use `GC_REALLOC' with
- `GC_MALLOC_ATOMIC'-allocated data? */
- void *newt = scm_gc_realloc ((char *) scm_i_port_table,
- scm_i_port_table_room * sizeof (scm_t_port *),
- new_size * sizeof (scm_t_port *),
- "port-table");
- scm_i_port_table = (scm_t_port **) newt;
- scm_i_port_table_room = new_size;
- }
-
- entry->entry = scm_i_port_table_size;
entry->file_name = SCM_BOOL_F;
entry->rw_active = SCM_PORT_NEITHER;
+ entry->port = z;
- scm_i_port_table[scm_i_port_table_size] = entry;
- scm_i_port_table_size++;
+ SCM_SET_CELL_TYPE (z, tag);
+ SCM_SETPTAB_ENTRY (z, entry);
- entry->port = z;
- SCM_SET_CELL_TYPE(z, tag);
- SCM_SETPTAB_ENTRY(z, entry);
+ scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
/* For each new port, register a finalizer so that it port type's free
function can be invoked eventually. */
@@ -611,8 +596,8 @@ scm_add_to_port_table (SCM port)
scm_t_port * pt = SCM_PTAB_ENTRY(z);
pt->port = port;
- SCM_SETCAR(z, SCM_EOL);
- SCM_SETCDR(z, SCM_EOL);
+ SCM_SETCAR (z, SCM_EOL);
+ SCM_SETCDR (z, SCM_EOL);
SCM_SETPTAB_ENTRY (port, pt);
return pt;
}
@@ -622,57 +607,30 @@ scm_add_to_port_table (SCM port)
/* Remove a port from the table and destroy it. */
/* This function is not and should not be thread safe. */
-
void
-scm_remove_from_port_table (SCM port)
-#define FUNC_NAME "scm_remove_from_port_table"
+scm_i_remove_port (SCM port)
+#define FUNC_NAME "scm_remove_port"
{
scm_t_port *p = SCM_PTAB_ENTRY (port);
- long i = p->entry;
-
- if (i >= scm_i_port_table_size)
- SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port));
if (p->putback_buf)
scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
scm_gc_free (p, sizeof (scm_t_port), "port");
- /* Since we have just freed slot i we can shrink the table by moving
- the last entry to that slot... */
- if (i < scm_i_port_table_size - 1)
- {
- scm_i_port_table[i] = scm_i_port_table[scm_i_port_table_size - 1];
- scm_i_port_table[i]->entry = i;
- }
+
SCM_SETPTAB_ENTRY (port, 0);
- scm_i_port_table_size--;
+ scm_hashq_remove_x (scm_i_port_weak_hash, port);
}
#undef FUNC_NAME
-#ifdef GUILE_DEBUG
/* Functions for debugging. */
-
+#ifdef GUILE_DEBUG
SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
(),
"Return the number of ports in the port table. @code{pt-size}\n"
"is only included in @code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_pt_size
{
- return scm_from_int (scm_i_port_table_size);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0,
- (SCM index),
- "Return the port at @var{index} in the port table.\n"
- "@code{pt-member} is only included in\n"
- "@code{--enable-guile-debug} builds.")
-#define FUNC_NAME s_scm_pt_member
-{
- size_t i = scm_to_size_t (index);
- if (i >= scm_i_port_table_size)
- return SCM_BOOL_F;
- else
- return scm_i_port_table[i]->port;
+ return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash));
}
#undef FUNC_NAME
#endif
@@ -833,7 +791,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
else
rv = 0;
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- scm_remove_from_port_table (port);
+ scm_i_remove_port (port);
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
SCM_CLR_PORT_OPEN_FLAG (port);
return scm_from_bool (rv >= 0);
@@ -871,10 +829,20 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0,
}
#undef FUNC_NAME
+static SCM
+scm_i_collect_keys_in_vector (void *closure, SCM key, SCM value, SCM result)
+{
+ int *i = (int*) closure;
+ scm_c_vector_set_x (result, *i, key);
+ (*i)++;
+
+ return result;
+}
+
void
scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
{
- long i;
+ int i = 0;
size_t n;
SCM ports;
@@ -884,20 +852,20 @@ scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
collect the ports into a vector. -mvo */
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- n = scm_i_port_table_size;
+ n = SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash);
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
ports = scm_c_make_vector (n, SCM_BOOL_F);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- if (n > scm_i_port_table_size)
- n = scm_i_port_table_size;
- for (i = 0; i < n; i++)
- SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ ports = scm_internal_hash_fold (scm_i_collect_keys_in_vector, &i,
+ ports, scm_i_port_weak_hash);
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
- for (i = 0; i < n; i++)
- proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
+ for (i = 0; i < n; i++) {
+ SCM p = SCM_SIMPLE_VECTOR_REF (ports, i);
+ if (SCM_PORTP (p))
+ proc (data, p);
+ }
scm_remember_upto_here_1 (ports);
}
@@ -1000,21 +968,21 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
}
#undef FUNC_NAME
+
+static void
+flush_output_port (void *closure, SCM port)
+{
+ if (SCM_OPOUTPORTP (port))
+ scm_flush (port);
+}
+
SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
(),
"Equivalent to calling @code{force-output} on\n"
"all open output ports. The return value is unspecified.")
#define FUNC_NAME s_scm_flush_all_ports
{
- size_t i;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- for (i = 0; i < scm_i_port_table_size; i++)
- {
- if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
- scm_flush (scm_i_port_table[i]->port);
- }
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ scm_c_port_for_each (&flush_output_port, NULL);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1806,6 +1774,8 @@ scm_init_ports ()
cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+ scm_i_port_weak_hash = scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31)));
+
#include "libguile/ports.x"
}
diff --git a/libguile/ports.h b/libguile/ports.h
index ab0449063..b93135e6f 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -47,7 +47,6 @@ typedef enum scm_t_port_rw_active {
typedef struct
{
SCM port; /* Link back to the port object. */
- long entry; /* Index in port table. */
int revealed; /* 0 not revealed, > 1 revealed.
* Revealed ports do not get GC'd.
*/
@@ -109,9 +108,10 @@ typedef struct
size_t putback_buf_size; /* allocated size of putback_buf. */
} scm_t_port;
-SCM_API scm_t_port **scm_i_port_table;
-SCM_API long scm_i_port_table_size; /* Number of ports in scm_i_port_table. */
+
SCM_API scm_i_pthread_mutex_t scm_i_port_table_mutex;
+SCM_API SCM scm_i_port_weak_hash;
+
#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
@@ -241,7 +241,7 @@ SCM_API void scm_dynwind_current_input_port (SCM port);
SCM_API void scm_dynwind_current_output_port (SCM port);
SCM_API void scm_dynwind_current_error_port (SCM port);
SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
-SCM_API void scm_remove_from_port_table (SCM port);
+SCM_API void scm_i_remove_port (SCM port);
SCM_API void scm_grow_port_cbuf (SCM port, size_t requested);
SCM_API SCM scm_pt_size (void);
SCM_API SCM scm_pt_member (SCM member);
diff --git a/libguile/posix.c b/libguile/posix.c
index e0d461075..76dcd3d10 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 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
@@ -21,9 +21,6 @@
# include <config.h>
#endif
-/* Make GNU/Linux libc declare everything it has. */
-#define _GNU_SOURCE
-
#include <stdio.h>
#include <errno.h>
@@ -1343,16 +1340,39 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
if (strchr (c_str, '=') == NULL)
{
-#ifdef HAVE_UNSETENV
- /* No '=' in argument means we should remove the variable from
- the environment. Not all putenvs understand this (for instance
- FreeBSD 4.8 doesn't). To be safe, we do it explicitely using
- unsetenv. */
+ /* We want no "=" in the argument to mean remove the variable from the
+ environment, but not all putenv()s understand this, for example
+ FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
+ painful. What unsetenv() exists, we use that, of course.
+
+ Traditionally putenv("NAME") removes a variable, for example that's
+ what we have to do on Solaris 9 (it doesn't have an unsetenv).
+
+ But on DOS and on that DOS overlay manager thing called W-whatever,
+ putenv("NAME=") must be used (it too doesn't have an unsetenv).
+
+ Supposedly on AIX a putenv("NAME") could cause a segfault, but also
+ supposedly AIX 5.3 and up has unsetenv() available so should be ok
+ with the latter there.
+
+ For the moment we hard code the DOS putenv("NAME=") style under
+ __MINGW32__ and do the traditional everywhere else. Such
+ system-name tests are bad, of course. It'd be possible to use a
+ configure test when doing a a native build. For example GNU R has
+ such a test (see R_PUTENV_AS_UNSETENV in
+ https://svn.r-project.org/R/trunk/m4/R.m4). But when cross
+ compiling there'd want to be a guess, one probably based on the
+ system name (ie. mingw or not), thus landing back in basically the
+ present hard-coded situation. Another possibility for a cross
+ build would be to try "NAME" then "NAME=" at runtime, if that's not
+ too much like overkill. */
+
+#if HAVE_UNSETENV
+ /* when unsetenv() exists then we use it */
unsetenv (c_str);
free (c_str);
-#else
- /* On e.g. Win32 hosts putenv() called with 'name=' removes the
- environment variable 'name'. */
+#elif defined (__MINGW32__)
+ /* otherwise putenv("NAME=") on DOS */
int e;
size_t len = strlen (c_str);
char *ptr = scm_malloc (len + 2);
@@ -1362,7 +1382,12 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
e = errno; free (ptr); free (c_str); errno = e;
if (rv < 0)
SCM_SYSERROR;
-#endif /* !HAVE_UNSETENV */
+#else
+ /* otherwise traditional putenv("NAME") */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
+#endif
}
else
{
diff --git a/libguile/read.c b/libguile/read.c
index 52c4dc265..d1013c586 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -26,9 +26,6 @@
#include <stdio.h>
#include <ctype.h>
#include <string.h>
-#ifdef HAVE_STRINGS_H
-# include <strings.h>
-#endif
#include "libguile/_scm.h"
#include "libguile/chars.h"
@@ -182,29 +179,8 @@ static SCM *scm_read_hash_procedures;
(((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
-#ifndef HAVE_STRNCASECMP
-/* XXX: Use Gnulib's `strncasecmp ()'. */
-
-static int
-strncasecmp (const char *s1, const char *s2, size_t len2)
-{
- while (*s1 && *s2 && len2 > 0)
- {
- int c1 = *s1, c2 = *s2;
-
- if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2))
- return 0;
- else
- {
- ++s1;
- ++s2;
- --len2;
- }
- }
- return !(*s1 || *s2 || len2 > 0);
-}
-#endif
-
+/* Read an SCSH block comment. */
+static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
/* Helper function similar to `scm_read_token ()'. Read from PORT until a
whitespace is read. Return zero if the whole token could fit in BUF,
@@ -272,6 +248,21 @@ flush_ws (SCM port, const char *eoferr)
}
break;
+ case '#':
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ eoferr = "read_sharp";
+ goto goteof;
+ case '!':
+ scm_read_scsh_block_comment (c, port);
+ break;
+ default:
+ scm_ungetc (c, port);
+ return '#';
+ }
+ break;
+
case SCM_LINE_INCREMENTORS:
case SCM_SINGLE_SPACES:
case '\t':
@@ -637,6 +628,8 @@ static SCM
scm_read_quote (int chr, SCM port)
{
SCM p;
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
switch (chr)
{
@@ -670,6 +663,17 @@ scm_read_quote (int chr, SCM port)
}
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+
return p;
}
diff --git a/libguile/socket.c b/libguile/socket.c
index 4ee8a84e5..1e839e0d1 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -67,6 +67,26 @@
+ strlen ((ptr)->sun_path))
#endif
+/* The largest possible socket address. Wrapping it in a union guarantees
+ that the compiler will make it suitably aligned. */
+typedef union
+{
+ struct sockaddr sockaddr;
+ struct sockaddr_in sockaddr_in;
+
+#ifdef HAVE_UNIX_DOMAIN_SOCKETS
+ struct sockaddr_un sockaddr_un;
+#endif
+#ifdef HAVE_IPV6
+ struct sockaddr_in6 sockaddr_in6;
+#endif
+} scm_t_max_sockaddr;
+
+
+/* Maximum size of a socket address. */
+#define MAX_ADDR_SIZE (sizeof (scm_t_max_sockaddr))
+
+
SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
@@ -344,7 +364,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
{
int af;
char *src;
- char dst[16];
+ scm_t_uint32 dst[4];
int rv, eno;
af = scm_to_int (family);
@@ -359,7 +379,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
else if (rv == 0)
SCM_MISC_ERROR ("Bad address", SCM_EOL);
if (af == AF_INET)
- return scm_from_ulong (ntohl (*(scm_t_uint32 *) dst));
+ return scm_from_ulong (ntohl (*dst));
else
return scm_from_ipv6 ((scm_t_uint8 *) dst);
}
@@ -468,6 +488,17 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0,
#undef FUNC_NAME
#endif
+/* Possible results for `getsockopt ()'. Wrapping it into a union guarantees
+ suitable alignment. */
+typedef union
+{
+#ifdef HAVE_STRUCT_LINGER
+ struct linger linger;
+#endif
+ size_t size;
+ int integer;
+} scm_t_getsockopt_result;
+
SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
(SCM sock, SCM level, SCM optname),
"Return an option value from socket port @var{sock}.\n"
@@ -518,13 +549,8 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
{
int fd;
/* size of optval is the largest supported option. */
-#ifdef HAVE_STRUCT_LINGER
- char optval[sizeof (struct linger)];
- socklen_t optlen = sizeof (struct linger);
-#else
- char optval[sizeof (size_t)];
- socklen_t optlen = sizeof (size_t);
-#endif
+ scm_t_getsockopt_result optval;
+ socklen_t optlen = sizeof (optval);
int ilevel;
int ioptname;
@@ -534,7 +560,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
ioptname = scm_to_int (optname);
fd = SCM_FPORT_FDES (sock);
- if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
+ if (getsockopt (fd, ilevel, ioptname, (void *) &optval, &optlen) == -1)
SCM_SYSERROR;
if (ilevel == SOL_SOCKET)
@@ -543,12 +569,12 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
if (ioptname == SO_LINGER)
{
#ifdef HAVE_STRUCT_LINGER
- struct linger *ling = (struct linger *) optval;
+ struct linger *ling = (struct linger *) &optval;
return scm_cons (scm_from_long (ling->l_onoff),
scm_from_long (ling->l_linger));
#else
- return scm_cons (scm_from_long (*(int *) optval),
+ return scm_cons (scm_from_long (*(int *) &optval),
scm_from_int (0));
#endif
}
@@ -563,10 +589,10 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
#endif
)
{
- return scm_from_size_t (*(size_t *) optval);
+ return scm_from_size_t (*(size_t *) &optval);
}
}
- return scm_from_int (*(int *) optval);
+ return scm_from_int (*(int *) &optval);
}
#undef FUNC_NAME
@@ -1011,12 +1037,11 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
/* Put the components of a sockaddr into a new SCM vector. */
static SCM_C_INLINE_KEYWORD SCM
-_scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size,
- const char *proc)
+_scm_from_sockaddr (const scm_t_max_sockaddr *address, unsigned addr_size,
+ const char *proc)
{
- short int fam = address->sa_family;
- SCM result =SCM_EOL;
-
+ SCM result = SCM_EOL;
+ short int fam = ((struct sockaddr *) address)->sa_family;
switch (fam)
{
@@ -1083,7 +1108,8 @@ _scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size,
SCM
scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size)
{
- return (_scm_from_sockaddr (address, addr_size, "scm_from_sockaddr"));
+ return (_scm_from_sockaddr ((scm_t_max_sockaddr *) address,
+ addr_size, "scm_from_sockaddr"));
}
/* Convert ADDRESS, an address object returned by either
@@ -1262,38 +1288,23 @@ SCM_DEFINE (scm_make_socket_address, "make-socket-address", 2, 0, 1,
"@code{connect} for details).")
#define FUNC_NAME s_scm_make_socket_address
{
+ SCM result = SCM_BOOL_F;
struct sockaddr *c_address;
size_t c_address_size;
c_address = scm_c_make_socket_address (family, address, args,
&c_address_size);
- if (!c_address)
- return SCM_BOOL_F;
+ if (c_address != NULL)
+ {
+ result = scm_from_sockaddr (c_address, c_address_size);
+ free (c_address);
+ }
- return (scm_from_sockaddr (c_address, c_address_size));
+ return result;
}
#undef FUNC_NAME
-/* calculate the size of a buffer large enough to hold any supported
- sockaddr type. if the buffer isn't large enough, certain system
- calls will return a truncated address. */
-
-#if defined (HAVE_UNIX_DOMAIN_SOCKETS)
-#define MAX_SIZE_UN sizeof (struct sockaddr_un)
-#else
-#define MAX_SIZE_UN 0
-#endif
-
-#if defined (HAVE_IPV6)
-#define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
-#else
-#define MAX_SIZE_IN6 0
-#endif
-
-#define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
- MAX_SIZE_UN)
-
SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
(SCM sock),
"Accept a connection on a bound, listening socket.\n"
@@ -1315,17 +1326,18 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
SCM address;
SCM newsock;
socklen_t addr_size = MAX_ADDR_SIZE;
- char max_addr[MAX_ADDR_SIZE];
- struct sockaddr *addr = (struct sockaddr *) max_addr;
+ scm_t_max_sockaddr addr;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
- newfd = accept (fd, addr, &addr_size);
+ newfd = accept (fd, (struct sockaddr *) &addr, &addr_size);
if (newfd == -1)
SCM_SYSERROR;
newsock = SCM_SOCK_FD_TO_PORT (newfd);
- address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
+ address = _scm_from_sockaddr (&addr, addr_size,
+ FUNC_NAME);
+
return scm_cons (newsock, address);
}
#undef FUNC_NAME
@@ -1339,15 +1351,15 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
{
int fd;
socklen_t addr_size = MAX_ADDR_SIZE;
- char max_addr[MAX_ADDR_SIZE];
- struct sockaddr *addr = (struct sockaddr *) max_addr;
+ scm_t_max_sockaddr addr;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
- if (getsockname (fd, addr, &addr_size) == -1)
+ if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1)
SCM_SYSERROR;
- return _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
+
+ return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
}
#undef FUNC_NAME
@@ -1361,15 +1373,15 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
{
int fd;
socklen_t addr_size = MAX_ADDR_SIZE;
- char max_addr[MAX_ADDR_SIZE];
- struct sockaddr *addr = (struct sockaddr *) max_addr;
+ scm_t_max_sockaddr addr;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
- if (getpeername (fd, addr, &addr_size) == -1)
+ if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1)
SCM_SYSERROR;
- return _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
+
+ return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
}
#undef FUNC_NAME
@@ -1505,8 +1517,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
size_t cend;
SCM address;
socklen_t addr_size = MAX_ADDR_SIZE;
- char max_addr[MAX_ADDR_SIZE];
- struct sockaddr *addr = (struct sockaddr *) max_addr;
+ scm_t_max_sockaddr addr;
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
@@ -1523,20 +1534,21 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
/* recvfrom will not necessarily return an address. usually nothing
is returned for stream sockets. */
buf = scm_i_string_writable_chars (str);
- addr->sa_family = AF_UNSPEC;
+ ((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
cend - offset, flg,
- addr, &addr_size));
+ (struct sockaddr *) &addr, &addr_size));
scm_i_string_stop_writing ();
if (rv == -1)
SCM_SYSERROR;
- if (addr->sa_family != AF_UNSPEC)
- address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
+ if (((struct sockaddr *) &addr)->sa_family != AF_UNSPEC)
+ address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
else
address = SCM_BOOL_F;
scm_remember_upto_here_1 (str);
+
return scm_cons (scm_from_int (rv), address);
}
#undef FUNC_NAME
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c
index bc2cbf02a..fc047c028 100644
--- a/libguile/srfi-14.c
+++ b/libguile/srfi-14.c
@@ -1,6 +1,6 @@
/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -22,8 +22,6 @@
#endif
-#define _GNU_SOURCE /* Ask for `isblank ()'. */
-
#include <string.h>
#include <ctype.h>
diff --git a/libguile/stime.c b/libguile/stime.c
index 418e80f21..8487b91ca 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007 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
@@ -32,6 +32,9 @@
hard coding __hpux. */
#define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
+#ifndef _REENTRANT
+# define _REENTRANT /* ask solaris for gmtime_r prototype */
+#endif
#ifdef __hpux
#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
#endif
diff --git a/libguile/threads.c b/libguile/threads.c
index c0a6cf110..77dcbb37a 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -487,20 +487,18 @@ do_thread_exit (void *v)
static void
on_thread_exit (void *v)
{
+ /* This handler is executed in non-guile mode. */
scm_i_thread *t = (scm_i_thread *)v, **tp;
scm_i_pthread_setspecific (scm_i_thread_key, v);
/* Unblocking the joining threads needs to happen in guile mode
- since the queue is a SCM data structure.
- */
+ since the queue is a SCM data structure. */
scm_with_guile (do_thread_exit, v);
/* Removing ourself from the list of all threads needs to happen in
non-guile mode since all SCM values on our stack become
- unprotected once we are no longer in the list.
- */
- scm_leave_guile ();
+ unprotected once we are no longer in the list. */
scm_i_pthread_mutex_lock (&thread_admin_mutex);
for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
if (*tp == t)
diff --git a/libguile/weaks.h b/libguile/weaks.h
index 128ee8869..de6ed9a1d 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -99,6 +99,7 @@ SCM_API void scm_i_mark_weak_vector (SCM w);
SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
+
#endif /* SCM_WEAKS_H */
/*
diff --git a/m4/ChangeLog b/m4/ChangeLog
new file mode 100644
index 000000000..769634bdb
--- /dev/null
+++ b/m4/ChangeLog
@@ -0,0 +1,10 @@
+2007-07-29 Ludovic Courtès <ludo@gnu.org>
+
+ * gnulib-cache.m4: New file.
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
new file mode 100644
index 000000000..d921e6729
--- /dev/null
+++ b/m4/gnulib-cache.m4
@@ -0,0 +1,32 @@
+# Copyright (C) 2004-2007 Free Software Foundation, Inc.
+#
+# This file is free software, distributed under the terms of the GNU
+# General Public License. As a special exception to the GNU General
+# Public License, this file may be distributed as part of a program
+# that contains a configuration script generated by Autoconf, under
+# the same distribution terms as the rest of that program.
+#
+# Generated by gnulib-tool.
+#
+# This file represents the specification of how gnulib-tool is used.
+# It acts as a cache: It is written and read by gnulib-tool.
+# In projects using CVS, this file is meant to be stored in CVS,
+# like the configure.ac and various Makefile.am files.
+
+
+# Specification in the form of a command-line invocation:
+# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca strcase
+
+# Specification in the form of a few gnulib-tool.m4 macro invocations:
+gl_LOCAL_DIR([])
+gl_MODULES([alloca strcase])
+gl_AVOID([])
+gl_SOURCE_BASE([lib])
+gl_M4_BASE([m4])
+gl_DOC_BASE([doc])
+gl_TESTS_BASE([tests])
+gl_LIB([libgnu])
+gl_LGPL
+gl_MAKEFILE_NAME([])
+gl_LIBTOOL
+gl_MACRO_PREFIX([gl])
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 673a3ce6f..9f0e412db 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,27 @@
+2007-09-10 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-35.scm (make-compound-condition-type): When PARENTS
+ contains only one element, return its car. This improves the
+ output of `print-condition' for non-compound conditions returned
+ by `make-compound-condition'.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-35.scm: New file.
+ * Makefile.am (srfi_DATA): Added `srfi-35.scm'.
+
+2007-07-29 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (INCLUDES): Added Gnulib includes.
+ (libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LIBADD):
+ Added `../lib/libgnu.la'.
+ (libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LIBADD):
+ Likewise.
+ (libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LIBADD):
+ Likewise.
+ (libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LIBADD):
+ Likewise.
+
2007-07-18 Stephen Compall <s11@member.fsf.org>
* srfi-37.scm: New file.
diff --git a/srfi/Makefile.am b/srfi/Makefile.am
index 46408cba8..8f5976e5c 100644
--- a/srfi/Makefile.am
+++ b/srfi/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 2001, 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
+## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -25,8 +25,9 @@ AUTOMAKE_OPTIONS = gnu
DEFS = @DEFS@ @EXTRA_DEFS@
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
-## building.
-INCLUDES = -I.. -I$(srcdir)/..
+## building. Also look for Gnulib headers in `lib'.
+INCLUDES = -I.. -I$(srcdir)/.. \
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib
srfiincludedir = $(pkgincludedir)/srfi
@@ -42,19 +43,23 @@ lib_LTLIBRARIES = \
BUILT_SOURCES = srfi-1.x srfi-4.x srfi-13.x srfi-14.x srfi-60.x
libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_SOURCES = srfi-1.x srfi-1.c
-libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LIBADD = \
+ $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_1_INTERFACE@
libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_SOURCES = srfi-4.x srfi-4.c
-libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LIBADD = \
+ $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_4_INTERFACE@
libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c
-libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LIBADD = \
+ $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@
libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_SOURCES = srfi-60.x srfi-60.c
-libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LIBADD = \
+ $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_60_INTERFACE@
srfidir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/srfi
@@ -74,6 +79,7 @@ srfi_DATA = srfi-1.scm \
srfi-26.scm \
srfi-31.scm \
srfi-34.scm \
+ srfi-35.scm \
srfi-37.scm \
srfi-39.scm \
srfi-60.scm
diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm
new file mode 100644
index 000000000..c9e25ce12
--- /dev/null
+++ b/srfi/srfi-35.scm
@@ -0,0 +1,335 @@
+;;; srfi-35.scm --- Conditions
+
+;; Copyright (C) 2007 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 library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-35, "Conditions". Conditions are a
+;; means to convey information about exceptional conditions between parts of
+;; a program.
+
+;;; Code:
+
+(define-module (srfi srfi-35)
+ #:use-module (srfi srfi-1)
+ #:export (make-condition-type condition-type?
+ make-condition condition? condition-has-type? condition-ref
+ make-compound-condition extract-condition
+ define-condition-type condition
+ &condition
+ &message message-condition? condition-message
+ &serious serious-condition?
+ &error error?))
+
+
+;;;
+;;; Condition types.
+;;;
+
+(define %condition-type-vtable
+ ;; The vtable of all condition types.
+ ;; vtable fields: vtable, self, printer
+ ;; user fields: id, parent, all-field-names
+ (make-vtable-vtable "prprpr" 0
+ (lambda (ct port)
+ (if (eq? ct %condition-type-vtable)
+ (display "#<condition-type-vtable>")
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+
+(define (condition-type? obj)
+ "Return true if OBJ is a condition type."
+ (and (struct? obj)
+ (eq? (struct-vtable obj)
+ %condition-type-vtable)))
+
+(define (condition-type-id ct)
+ (and (condition-type? ct)
+ (struct-ref ct 3)))
+
+(define (condition-type-parent ct)
+ (and (condition-type? ct)
+ (struct-ref ct 4)))
+
+(define (condition-type-all-fields ct)
+ (and (condition-type? ct)
+ (struct-ref ct 5)))
+
+
+(define (struct-layout-for-condition field-names)
+ ;; Return a string denoting the layout required to hold the fields listed
+ ;; in FIELD-NAMES.
+ (let loop ((field-names field-names)
+ (layout '("pr")))
+ (if (null? field-names)
+ (string-concatenate/shared layout)
+ (loop (cdr field-names)
+ (cons "pr" layout)))))
+
+(define (print-condition c port)
+ (format port "#<condition ~a ~a>"
+ (condition-type-id (condition-type c))
+ (number->string (object-address c) 16)))
+
+(define (make-condition-type id parent field-names)
+ "Return a new condition type named ID, inheriting from PARENT, and with the
+fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of
+symbols and must not contain names already used by PARENT or one of its
+supertypes."
+ (if (symbol? id)
+ (if (condition-type? parent)
+ (let ((parent-fields (condition-type-all-fields parent)))
+ (if (and (every symbol? field-names)
+ (null? (lset-intersection eq?
+ field-names parent-fields)))
+ (let* ((all-fields (append parent-fields field-names))
+ (layout (struct-layout-for-condition all-fields)))
+ (make-struct %condition-type-vtable 0
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id parent all-fields))
+ (error "invalid condition type field names"
+ field-names)))
+ (error "parent is not a condition type" parent))
+ (error "condition type identifier is not a symbol" id)))
+
+(define (make-compound-condition-type id parents)
+ ;; Return a compound condition type made of the types listed in PARENTS.
+ ;; All fields from PARENTS are kept, even same-named ones, since they are
+ ;; needed by `extract-condition'.
+ (cond ((null? parents)
+ (error "`make-compound-condition-type' passed empty parent list"
+ id))
+ ((null? (cdr parents))
+ (car parents))
+ (else
+ (let* ((all-fields (append-map condition-type-all-fields
+ parents))
+ (layout (struct-layout-for-condition all-fields)))
+ (make-struct %condition-type-vtable 0
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id
+ parents ;; list of parents!
+ all-fields
+ all-fields)))))
+
+
+;;;
+;;; Conditions.
+;;;
+
+(define (condition? c)
+ "Return true if C is a condition."
+ (and (struct? c)
+ (condition-type? (struct-vtable c))))
+
+(define (condition-type c)
+ (and (struct? c)
+ (let ((vtable (struct-vtable c)))
+ (if (condition-type? vtable)
+ vtable
+ #f))))
+
+(define (condition-has-type? c type)
+ "Return true if condition C has type TYPE."
+ (if (and (condition? c) (condition-type? type))
+ (let loop ((ct (condition-type c)))
+ (or (eq? ct type)
+ (and ct
+ (let ((parent (condition-type-parent ct)))
+ (if (list? parent)
+ (any loop parent) ;; compound condition
+ (loop (condition-type-parent ct)))))))
+ (throw 'wrong-type-arg "condition-has-type?"
+ "Wrong type argument")))
+
+(define (condition-ref c field-name)
+ "Return the value of the field named FIELD-NAME from condition C."
+ (if (condition? c)
+ (if (symbol? field-name)
+ (let* ((type (condition-type c))
+ (fields (condition-type-all-fields type))
+ (index (list-index (lambda (name)
+ (eq? name field-name))
+ fields)))
+ (if index
+ (struct-ref c index)
+ (error "invalid field name" field-name)))
+ (error "field name is not a symbol" field-name))
+ (throw 'wrong-type-arg "condition-ref"
+ "Wrong type argument: ~S" c)))
+
+(define (make-condition-from-values type values)
+ (apply make-struct type 0 values))
+
+(define (make-condition type . field+value)
+ "Return a new condition of type TYPE with fields initialized as specified
+by FIELD+VALUE, a sequence of field names (symbols) and values."
+ (if (condition-type? type)
+ (let* ((all-fields (condition-type-all-fields type))
+ (inits (fold-right (lambda (field inits)
+ (let ((v (memq field field+value)))
+ (if (pair? v)
+ (cons (cadr v) inits)
+ (error "field not specified"
+ field))))
+ '()
+ all-fields)))
+ (make-condition-from-values type inits))
+ (throw 'wrong-type-arg "make-condition"
+ "Wrong type argument: ~S" type)))
+
+(define (make-compound-condition . conditions)
+ "Return a new compound condition composed of CONDITIONS."
+ (let* ((types (map condition-type conditions))
+ (ct (make-compound-condition-type 'compound types))
+ (inits (append-map (lambda (c)
+ (let ((ct (condition-type c)))
+ (map (lambda (f)
+ (condition-ref c f))
+ (condition-type-all-fields ct))))
+ conditions)))
+ (make-condition-from-values ct inits)))
+
+(define (extract-condition c type)
+ "Return a condition of condition type TYPE with the field values specified
+by C."
+
+ (define (first-field-index parents)
+ ;; Return the index of the first field of TYPE within C.
+ (let loop ((parents parents)
+ (index 0))
+ (let ((parent (car parents)))
+ (cond ((null? parents)
+ #f)
+ ((eq? parent type)
+ index)
+ ((pair? parent)
+ (or (loop parent index)
+ (loop (cdr parents)
+ (+ index
+ (apply + (map condition-type-all-fields
+ parent))))))
+ (else
+ (let ((shift (length (condition-type-all-fields parent))))
+ (loop (cdr parents)
+ (+ index shift))))))))
+
+ (define (list-fields start-index field-names)
+ ;; Return a list of the form `(FIELD-NAME VALUE...)'.
+ (let loop ((index start-index)
+ (field-names field-names)
+ (result '()))
+ (if (null? field-names)
+ (reverse! result)
+ (loop (+ 1 index)
+ (cdr field-names)
+ (cons* (struct-ref c index)
+ (car field-names)
+ result)))))
+
+ (if (and (condition? c) (condition-type? type))
+ (let* ((ct (condition-type c))
+ (parent (condition-type-parent ct)))
+ (cond ((eq? type ct)
+ c)
+ ((pair? parent)
+ ;; C is a compound condition.
+ (let ((field-index (first-field-index parent)))
+ ;;(format #t "field-index: ~a ~a~%" field-index
+ ;; (list-fields field-index
+ ;; (condition-type-all-fields type)))
+ (apply make-condition type
+ (list-fields field-index
+ (condition-type-all-fields type)))))
+ (else
+ ;; C does not have type TYPE.
+ #f)))
+ (throw 'wrong-type-arg "extract-condition"
+ "Wrong type argument")))
+
+
+;;;
+;;; Syntax.
+;;;
+
+(define-macro (define-condition-type name parent pred . field-specs)
+ `(begin
+ (define ,name
+ (make-condition-type ',name ,parent
+ ',(map car field-specs)))
+ (define (,pred c)
+ (condition-has-type? c ,name))
+ ,@(map (lambda (field-spec)
+ (let ((field-name (car field-spec))
+ (accessor (cadr field-spec)))
+ `(define (,accessor c)
+ (condition-ref c ',field-name))))
+ field-specs)))
+
+(define-macro (condition . type-field-bindings)
+ (cond ((null? type-field-bindings)
+ (error "`condition' syntax error" type-field-bindings))
+ (else
+ ;; the poor man's hygienic macro
+ (let ((mc (gensym "mc"))
+ (mcct (gensym "mcct")))
+ `(let ((,mc (@ (srfi srfi-35) make-condition))
+ (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
+ (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
+ ,@(append-map (lambda (type-field-binding)
+ (append-map (lambda (field+value)
+ (let ((f (car field+value))
+ (v (cadr field+value)))
+ `(',f ,v)))
+ (cdr type-field-binding)))
+ type-field-bindings)))))))
+
+
+;;;
+;;; Standard condition types.
+;;;
+
+(define &condition
+ ;; The root condition type.
+ (make-struct %condition-type-vtable 0
+ (make-struct-layout "")
+ (lambda (c port)
+ (display "<&condition>"))
+ '&condition #f '() '()))
+
+(define-condition-type &message &condition
+ message-condition?
+ (message condition-message))
+
+(define-condition-type &serious &condition
+ serious-condition?)
+
+(define-condition-type &error &serious
+ error?)
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; srfi-35.scm ends here
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index af14831fc..f40adfa22 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,43 @@
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test (reading)[block comment finishing sexp]: New
+ test.
+
+2007-08-26 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * tests/ports.test ("port-for-each"): remove unresolved for
+ port-for-each memory test.
+ ("fdes->port"): test fdes->port
+
+2007-08-23 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test (read-options)[positions on quote]: New
+ test, proposed by Kevin Ryde.
+
+2007-08-23 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ports.test (port-for-each): New test for passing freed cell,
+ marked as unresolved since problem not yet fixed.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-35.test: New file.
+ * Makefile.am (SCM_TESTS): Added `tests/srfi-35.test'.
+
+2007-08-08 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-9.test (exception:not-a-record): Removed.
+ (accessor)[get-x on number, get-y on number]: Expect
+ `exception:wrong-type-arg' instead of `exception:not-a-record'.
+ (modifier)[set-y! on number]: Likewise
+
+2007-07-25 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-17.test (%some-variable): New.
+ (set!)[target uses macro]: New test prefix. The
+ "(set! (@@ ...) 1)" test is in accordance with Marius Vollmer's
+ change in `libguile' dated 2003-11-17.
+
2007-07-22 Ludovic Courtès <ludo@gnu.org>
* tests/reader.test: Added a proper header and `define-module'.
@@ -140,7 +180,7 @@
* tests/numbers.test (*): Exercise multiply by exact 0 giving exact 0.
-2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/unif.test (syntax): New test prefix. Check syntax for
negative lower bounds and negative lengths (reported by Gyula
@@ -167,7 +207,7 @@
ensure intended exact vs inexact is checked. Reported by Aaron
M. Ucko, Debian bug 396119.
-2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
* test-suite/tests/vectors.test: Use `define-module'.
(vector->list): New test prefix. "Shared array" test contributed
@@ -187,7 +227,7 @@
* tests/environments.test: Comment out all tests in this file.
-2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a
typo: `thrown' instead of `throw'.
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 08de5b7d9..ea58cbeaf 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2001, 2002, 2003, 2004, 2005, 2006 Software Foundation, Inc.
+## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007 Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -75,6 +75,7 @@ SCM_TESTS = tests/alist.test \
tests/srfi-26.test \
tests/srfi-31.test \
tests/srfi-34.test \
+ tests/srfi-35.test \
tests/srfi-37.test \
tests/srfi-39.test \
tests/srfi-60.test \
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 2d25f420a..f1ba80be0 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -550,6 +550,44 @@
(eqv? n (port-line port)))))
;;;
+;;; port-for-each
+;;;
+
+(with-test-prefix "port-for-each"
+
+ ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
+ ;; its iterator func if a port was inaccessible in the last gc mark but
+ ;; the lazy sweeping has not yet reached it to remove it from the port
+ ;; table (scm_i_port_table). Provoking those gc conditions is a little
+ ;; tricky, but the following code made it happen in 1.8.2.
+ (pass-if "passing freed cell"
+ (let ((lst '()))
+ ;; clear out the heap
+ (gc) (gc) (gc)
+ ;; allocate cells so the opened ports aren't at the start of the heap
+ (make-list 1000)
+ (open-input-file "/dev/null")
+ (make-list 1000)
+ (open-input-file "/dev/null")
+ ;; this gc leaves the above ports unmarked, ie. inaccessible
+ (gc)
+ ;; but they're still in the port table, so this sees them
+ (port-for-each (lambda (port)
+ (set! lst (cons port lst))))
+ ;; this forces completion of the sweeping
+ (gc) (gc) (gc)
+ ;; and (if the bug is present) the cells accumulated in LST are now
+ ;; freed cells, which give #f from `port?'
+ (not (memq #f (map port? lst))))))
+
+(with-test-prefix
+ "fdes->port"
+ (pass-if "fdes->ports finds port"
+ (let ((port (open-file (test-file) "w")))
+
+ (not (not (memq port (fdes->ports (port->fdes port))))))))
+
+;;;
;;; seek
;;;
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 2d9171803..7f24aa695 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -77,6 +77,10 @@
(equal? '(+ 1 2 3)
(read-string "(+ 1 #! this is a\ncomment !# 2 3)")))
+ (pass-if "block comment finishing s-exp"
+ (equal? '(+ 2)
+ (read-string "(+ 2 #! a comment\n!#\n) ")))
+
(pass-if "unprintable symbol"
;; The reader tolerates unprintable characters for symbols.
(equal? (string->symbol "\001\002\003")
@@ -152,5 +156,11 @@
(lambda ()
(read-string "(+ 1 2 3)")))))
(and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 0))))
+ (pass-if "positions on quote"
+ (let ((sexp (with-read-options '(positions)
+ (lambda ()
+ (read-string "'abcde")))))
+ (and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))
diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test
index 0a0b42541..fbacb15a3 100644
--- a/test-suite/tests/srfi-17.test
+++ b/test-suite/tests/srfi-17.test
@@ -48,6 +48,8 @@
;; set!
;;
+(define %some-variable #f)
+
(with-test-prefix "set!"
(with-test-prefix "target is not procedure with setter"
@@ -58,7 +60,20 @@
(pass-if-exception "(set! '#f 1)"
exception:bad-variable
- (eval '(set! '#f 1) (interaction-environment)))))
+ (eval '(set! '#f 1) (interaction-environment))))
+
+ (with-test-prefix "target uses macro"
+
+ (pass-if "(set! (@@ ...) 1)"
+ (eval '(set! (@@ (test-suite test-srfi-17) %some-variable) 1)
+ (interaction-environment))
+ (equal? %some-variable 1))
+
+ ;; The `(quote x)' below used to be memoized as an infinite list before
+ ;; Guile 1.8.3.
+ (pass-if-exception "(set! 'x 1)"
+ exception:bad-variable
+ (eval '(set! 'x 1) (interaction-environment)))))
;;
;; setter
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
new file mode 100644
index 000000000..ec7a104c3
--- /dev/null
+++ b/test-suite/tests/srfi-35.test
@@ -0,0 +1,310 @@
+;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
+;;;; Ludovic Courtès <ludo@gnu.org>
+;;;;
+;;;; Copyright (C) 2007 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 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 General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-35)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-35))
+
+
+(with-test-prefix "condition types"
+ (pass-if "&condition"
+ (condition-type? &condition))
+
+ (pass-if "make-condition-type"
+ (condition-type? (make-condition-type 'foo &condition '(a b)))))
+
+
+
+(with-test-prefix "conditions"
+
+ (pass-if "&condition"
+ (let ((c (make-condition &condition)))
+ (and (condition? c)
+ (condition-has-type? c &condition))))
+
+ (pass-if "simple condition"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (and (condition? c)
+ (condition-has-type? c ct))))
+
+ (pass-if "simple condition with inheritance"
+ (let* ((top (make-condition-type 'foo &condition '(a b)))
+ (ct (make-condition-type 'bar top '(c d)))
+ (c (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
+ (and (condition? c)
+ (condition-has-type? c ct)
+ (condition-has-type? c top))))
+
+ (pass-if "condition-ref"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (and (eq? (condition-ref c 'a) 0)
+ (eq? (condition-ref c 'b) 1))))
+
+ (pass-if "condition-ref with inheritance"
+ (let* ((top (make-condition-type 'foo &condition '(a b)))
+ (ct (make-condition-type 'bar top '(c d)))
+ (c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
+ (and (eq? (condition-ref c 'a) 0)
+ (eq? (condition-ref c 'b) 1)
+ (eq? (condition-ref c 'c) 2)
+ (eq? (condition-ref c 'd) 3))))
+
+ (pass-if "extract-condition"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (equal? c (extract-condition c ct)))))
+
+
+(with-test-prefix "compound conditions"
+ (pass-if "condition-has-type?"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (and (condition? c)
+ (condition-has-type? c t1)
+ (condition-has-type? c t2))))
+
+ (pass-if "condition-ref"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (equal? (map (lambda (field)
+ (condition-ref c field))
+ '(a b c d))
+ '(0 1 2 3))))
+
+ (pass-if "condition-ref with same-named fields"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(a c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'a -1 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (equal? (map (lambda (field)
+ (condition-ref c field))
+ '(a b c d))
+ '(0 1 2 3))))
+
+ (pass-if "extract-condition"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2)))))
+
+ (pass-if "extract-condition with same-named fields"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(a c)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'a -1 'c 2))
+ (c (make-compound-condition c1 c2)))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2))))))
+
+
+
+(with-test-prefix "syntax"
+ (pass-if "define-condition-type"
+ (let ((m (current-module)))
+ (eval '(define-condition-type &chbouib &condition
+ chbouib?
+ (one chbouib-one)
+ (two chbouib-two))
+ m)
+ (eval '(and (condition-type? &chbouib)
+ (procedure? chbouib?)
+ (let ((c (make-condition &chbouib 'one 1 'two 2)))
+ (and (condition? c)
+ (chbouib? c)
+ (eq? (chbouib-one c) 1)
+ (eq? (chbouib-two c) 2))))
+ m)))
+
+ (pass-if "condition"
+ (let* ((t (make-condition-type 'chbouib &condition '(a b)))
+ (c (condition (t (b 2) (a 1)))))
+ (and (condition? c)
+ (condition-has-type? c t)
+ (equal? (map (lambda (f)
+ (condition-ref c f))
+ '(a b))
+ '(1 2)))))
+
+ (pass-if-exception "condition with missing fields"
+ exception:miscellaneous-error
+ (let ((t (make-condition-type 'chbouib &condition '(a b c))))
+ (condition (t (a 1) (b 2)))))
+
+ (pass-if "compound condition"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (condition (t1 (a 0) (b 1))
+ (t2 (c 2) (d 3)))))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2))))))
+
+
+;;;
+;;; Examples from the SRFI.
+;;;
+
+(define-condition-type &c &condition
+ c?
+ (x c-x))
+
+(define-condition-type &c1 &c
+ c1?
+ (a c1-a))
+
+(define-condition-type &c2 &c
+ c2?
+ (b c2-b))
+
+(define v1
+ (make-condition &c1 'x "V1" 'a "a1"))
+
+(define v2
+ (condition (&c2 (x "V2") (b "b2"))))
+
+(define v3
+ (condition (&c1 (x "V3/1") (a "a3"))
+ (&c2 (b "b3"))))
+
+(define v4
+ (make-compound-condition v1 v2))
+
+(define v5
+ (make-compound-condition v2 v3))
+
+
+(with-test-prefix "examples"
+
+ (pass-if "v1"
+ (condition? v1))
+
+ (pass-if "(c? v1)"
+ (c? v1))
+
+ (pass-if "(c1? v1)"
+ (c1? v1))
+
+ (pass-if "(not (c2? v1))"
+ (not (c2? v1)))
+
+ (pass-if "(c-x v1)"
+ (equal? (c-x v1) "V1"))
+
+ (pass-if "(c1-a v1)"
+ (equal? (c1-a v1) "a1"))
+
+
+ (pass-if "v2"
+ (condition? v2))
+
+ (pass-if "(c? v2)"
+ (c? v2))
+
+ (pass-if "(c2? v2)"
+ (c2? v2))
+
+ (pass-if "(not (c1? v2))"
+ (not (c1? v2)))
+
+ (pass-if "(c-x v2)"
+ (equal? (c-x v2) "V2"))
+
+ (pass-if "(c2-b v2)"
+ (equal? (c2-b v2) "b2"))
+
+
+ (pass-if "v3"
+ (condition? v3))
+
+ (pass-if "(c? v3)"
+ (c? v3))
+
+ (pass-if "(c1? v3)"
+ (c1? v3))
+
+ (pass-if "(c2? v3)"
+ (c2? v3))
+
+ (pass-if "(c-x v3)"
+ (equal? (c-x v3) "V3/1"))
+
+ (pass-if "(c1-a v3)"
+ (equal? (c1-a v3) "a3"))
+
+ (pass-if "(c2-b v3)"
+ (equal? (c2-b v3) "b3"))
+
+
+ (pass-if "v4"
+ (condition? v4))
+
+ (pass-if "(c? v4)"
+ (c? v4))
+
+ (pass-if "(c1? v4)"
+ (c1? v4))
+
+ (pass-if "(c2? v4)"
+ (c2? v4))
+
+ (pass-if "(c-x v4)"
+ (equal? (c-x v4) "V1"))
+
+ (pass-if "(c1-a v4)"
+ (equal? (c1-a v4) "a1"))
+
+ (pass-if "(c2-b v4)"
+ (equal? (c2-b v4) "b2"))
+
+
+ (pass-if "v5"
+ (condition? v5))
+
+ (pass-if "(c? v5)"
+ (c? v5))
+
+ (pass-if "(c1? v5)"
+ (c1? v5))
+
+ (pass-if "(c2? v5)"
+ (c2? v5))
+
+ (pass-if "(c-x v5)"
+ (equal? (c-x v5) "V2"))
+
+ (pass-if "(c1-a v5)"
+ (equal? (c1-a v5) "a3"))
+
+ (pass-if "(c2-b v5)"
+ (equal? (c2-b v5) "b2")))
+
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 18fa19328..c212ea6aa 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007 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
@@ -23,10 +23,6 @@
#:use-module (srfi srfi-9))
-(define exception:not-a-record
- (cons 'misc-error "^not-a-record"))
-
-
(define-record-type :foo (make-foo x) foo?
(x get-x) (y get-y set-y!))
@@ -61,9 +57,9 @@
(pass-if "get-y"
(= 2 (get-y f)))
- (pass-if-exception "get-x on number" exception:not-a-record
+ (pass-if-exception "get-x on number" exception:wrong-type-arg
(get-x 999))
- (pass-if-exception "get-y on number" exception:not-a-record
+ (pass-if-exception "get-y on number" exception:wrong-type-arg
(get-y 999))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
@@ -78,7 +74,7 @@
(set-y! f #t)
(eq? #t (get-y f)))
- (pass-if-exception "set-y! on number" exception:not-a-record
+ (pass-if-exception "set-y! on number" exception:wrong-type-arg
(set-y! 999 #t))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced