diff options
author | Ludovic Courtès <ludo@gnu.org> | 2008-09-10 22:50:04 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2008-09-10 22:50:04 +0200 |
commit | 6774820f1e83a388b3232cd61a66340886b395d8 (patch) | |
tree | 513cae9f2b9168aea1e4e20c3ce91cf89e0ce817 | |
parent | b74e86cf5f50612742609210ad8e04d46069437f (diff) | |
parent | 29776e85da637ec4d44b2b2822d6934a50c0084b (diff) | |
download | guile-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
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 @@ -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 @@ -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 |