mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

Merge commit '29776e85da' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	libguile/gc-card.c
	libguile/gc.c
	libguile/gc.h
	libguile/ports.c
This commit is contained in:
Ludovic Courtès 2008-09-10 22:50:04 +02:00
commit 6774820f1e
45 changed files with 2244 additions and 798 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.cvsignore
View file

@ -33,4 +33,3 @@ mkinstalldirs
pre-inst-guile
pre-inst-guile-env
stamp-h1
texinfo.tex

61
ChangeLog
View file

@ -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 ()'.

7
Makefile.am
View file

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

29
NEWS
View file

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

3
autogen.sh
View file

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

614
build-aux/config.rpath Executable file
View file

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

33
configure.in
View file

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

13
doc/ref/ChangeLog
View file

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

38
doc/ref/slib.texi
View file

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

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

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

6
guile-readline/ChangeLog
View file

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

10
guile-readline/Makefile.am
View file

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

19
ice-9/ChangeLog
View file

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

16
ice-9/boot-9.scm
View file

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

388
ice-9/slib.scm
View file

@ -1,6 +1,6 @@
;;;; 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
@ -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)
;; Initialize SLIB.
(load-from-path "slib/guile.init")
(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)))
;; 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))

117
libguile/ChangeLog
View file

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

14
libguile/Makefile.am
View file

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

27
libguile/eval.c
View file

@ -27,25 +27,9 @@
# include <config.h>
#endif
#include "libguile/__scm.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"
@ -876,8 +860,10 @@ macroexp (SCM x, SCM env)
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
if (scm_ilength (res) <= 0)
res = scm_list_2 (SCM_IM_BEGIN, res);
/* 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
@ -895,6 +881,7 @@ macroexp (SCM x, SCM env)
goto macro_tail;
}
}
/* Start of the memoizers for the standard R5RS builtin macros. */

16
libguile/filesys.c
View file

@ -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 <stdio.h>
#include <errno.h>

24
libguile/fports.c
View file

@ -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,17 +221,11 @@ 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);
for (i = 0; i < scm_i_port_table_size; i++)
{
SCM port = scm_i_port_table[i]->port;
int fd = * (int*) closure;
SCM port = SCM_CAR (handle);
if (SCM_FPORTP (port))
{
@ -244,8 +239,17 @@ scm_evict_ports (int fd)
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);
}

17
libguile/i18n.c
View file

@ -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 "libguile/_scm.h"
#include "libguile/feature.h"

10
libguile/init.c
View file

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

34
libguile/ioext.c
View file

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

35
libguile/numbers.c
View file

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

128
libguile/ports.c
View file

@ -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,34 +570,16 @@ 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;
scm_i_port_table[scm_i_port_table_size] = entry;
scm_i_port_table_size++;
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. */
register_finalizer_for_port (z);
@ -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"
}

8
libguile/ports.h
View file

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

51
libguile/posix.c
View file

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

56
libguile/read.c
View file

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

128
libguile/socket.c
View file

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

4
libguile/srfi-14.c
View file

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

5
libguile/stime.c
View file

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

8
libguile/threads.c
View file

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

1
libguile/weaks.h
View file

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

10
m4/ChangeLog Normal file
View file

@ -0,0 +1,10 @@
2007-07-29 Ludovic Courtès <ludo@gnu.org>
* gnulib-cache.m4: New file.
;; Local Variables:
;; coding: utf-8
;; End:

32
m4/gnulib-cache.m4 Normal file
View file

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

24
srfi/ChangeLog
View file

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

20
srfi/Makefile.am
View file

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

335
srfi/srfi-35.scm Normal file
View file

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

46
test-suite/ChangeLog
View file

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

3
test-suite/Makefile.am
View file

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

38
test-suite/tests/ports.test
View file

@ -549,6 +549,44 @@
(set-port-line! port n)
(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
;;;

10
test-suite/tests/reader.test
View file

@ -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")
@ -151,6 +155,12 @@
(let ((sexp (with-read-options '(positions)
(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)))))

17
test-suite/tests/srfi-17.test
View file

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

310
test-suite/tests/srfi-35.test Normal file
View file

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

12
test-suite/tests/srfi-9.test
View file

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