mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
Merge commit '29776e85da' into boehm-demers-weiser-gc
Conflicts: libguile/gc-card.c libguile/gc.c libguile/gc.h libguile/ports.c
This commit is contained in:
Ludovic Courtès
commit
6774820f1e
45 changed files with 2244 additions and 798 deletions
|
|
@ -33,4 +33,3 @@ mkinstalldirs
|
||||||
pre-inst-guile
|
pre-inst-guile
|
||||||
pre-inst-guile-env
|
pre-inst-guile-env
|
||||||
stamp-h1
|
stamp-h1
|
||||||
texinfo.tex
|
|
||||||
|
|
|
||||||
61
ChangeLog
61
ChangeLog
|
|
@ -1,3 +1,64 @@
|
||||||
|
2007-10-02 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention `(ice-9 slib)' fix and threading fix.
|
||||||
|
|
||||||
|
2007-09-03 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention alignment-related bug fixes.
|
||||||
|
|
||||||
|
2007-09-03 Kevin Ryde <user42@zip.com.au>
|
||||||
|
|
||||||
|
* configure.in (AC_CHECK_FUNCS): Move cexp and clog up into the main
|
||||||
|
funcs check block. Remove carg which is now unused.
|
||||||
|
|
||||||
|
2007-09-02 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention memory leak fix in `make-socket-address'.
|
||||||
|
|
||||||
|
2007-09-01 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention duplicate binding warnings to stderr.
|
||||||
|
|
||||||
|
2007-08-23 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention Solaris bug fixes.
|
||||||
|
|
||||||
|
2007-08-11 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention SRFI-35 and the new reader.
|
||||||
|
|
||||||
|
2007-08-08 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention changes to `record-accessor' and
|
||||||
|
`record-modifier'.
|
||||||
|
|
||||||
|
2007-07-29 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
Added Gnulib support.
|
||||||
|
|
||||||
|
* autogen.sh: Run `gnulib-tool --update'.
|
||||||
|
|
||||||
|
* Makefile.am (SUBDIRS): Added `lib'.
|
||||||
|
(ACLOCAL_AMFLAGS): Added `-I m4'.
|
||||||
|
(EXTRA_DIST): Added `m4/ChangeLog'.
|
||||||
|
|
||||||
|
* NEWS: Comply with Automake's `check-news' option, i.e., have
|
||||||
|
the last "Changes in" line appear within the first 15 lines.
|
||||||
|
Mention use of Gnulib.
|
||||||
|
|
||||||
|
* configure.in: Use `build-aux' as `AC_CONFIG_AUX_DIR', and `m4'
|
||||||
|
as `AC_CONFIG_MACRO_DIR'. Use Automake's `gnu' and `check-news'
|
||||||
|
options.
|
||||||
|
Require Autoconf 2.59. Invoke `gl_EARLY' and `gl_INIT', don't
|
||||||
|
run `AC_AIX', `AC_ISC_POSIX' and `AC_MINIX' since they are
|
||||||
|
implied by `gl_EARLY'. Don't look for <strings.h> and
|
||||||
|
`strncasecmp'. Don't invoke `AC_FUNC_ALLOCA'. Produce
|
||||||
|
`lib/Makefile'.
|
||||||
|
|
||||||
|
2007-07-25 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
|
* NEWS: Mention bug fix for "(set! 'x #f)".
|
||||||
|
|
||||||
2007-07-22 Ludovic Courtès <ludo@gnu.org>
|
2007-07-22 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
* configure.in: Check for <strings.h> and `strncasecmp ()'.
|
* configure.in: Check for <strings.h> and `strncasecmp ()'.
|
||||||
|
|
|
||||||
|
|
@ -24,7 +24,7 @@
|
||||||
#
|
#
|
||||||
AUTOMAKE_OPTIONS = 1.10
|
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
|
scripts srfi doc examples test-suite benchmark-suite lang am
|
||||||
|
|
||||||
bin_SCRIPTS = guile-tools
|
bin_SCRIPTS = guile-tools
|
||||||
|
|
@ -33,11 +33,12 @@ include_HEADERS = libguile.h
|
||||||
|
|
||||||
# automake sometimes forgets to distribute acconfig.h,
|
# automake sometimes forgets to distribute acconfig.h,
|
||||||
# apparently depending on the phase of the moon.
|
# 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
|
TESTS = check-guile
|
||||||
|
|
||||||
ACLOCAL_AMFLAGS = -I guile-config
|
ACLOCAL_AMFLAGS = -I guile-config -I m4
|
||||||
|
|
||||||
DISTCLEANFILES = check-guile.log
|
DISTCLEANFILES = check-guile.log
|
||||||
|
|
||||||
|
|
|
||||||
29
NEWS
29
NEWS
|
|
@ -6,21 +6,17 @@ Please send Guile bug reports to bug-guile@gnu.org. Note that you
|
||||||
must be subscribed to this list first, in order to successfully send a
|
must be subscribed to this list first, in order to successfully send a
|
||||||
report to it.
|
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)
|
* New modules (see the manual for details)
|
||||||
|
|
||||||
** The `(ice-9 i18n)' module provides internationalization support
|
** The `(ice-9 i18n)' module provides internationalization support
|
||||||
|
|
||||||
* Changes to the distribution
|
* Changes to the distribution
|
||||||
|
|
||||||
|
** Guile now uses Gnulib as a portability aid
|
||||||
|
|
||||||
* Changes to the stand-alone interpreter
|
* Changes to the stand-alone interpreter
|
||||||
* Changes to Scheme functions and syntax
|
* 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)
|
* New modules (see the manual for details)
|
||||||
|
|
||||||
|
** `(srfi srfi-35)'
|
||||||
** `(srfi srfi-37)'
|
** `(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):
|
Changes in 1.8.2 (since 1.8.1):
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -19,10 +19,13 @@ libtool --version
|
||||||
echo ""
|
echo ""
|
||||||
${M4:-/usr/bin/m4} --version
|
${M4:-/usr/bin/m4} --version
|
||||||
echo ""
|
echo ""
|
||||||
|
gnulib-tool --version
|
||||||
|
echo ""
|
||||||
|
|
||||||
######################################################################
|
######################################################################
|
||||||
### update infrastructure
|
### update infrastructure
|
||||||
|
|
||||||
|
gnulib-tool --update && \
|
||||||
autoreconf -i --force --verbose
|
autoreconf -i --force --verbose
|
||||||
|
|
||||||
echo "guile-readline..."
|
echo "guile-readline..."
|
||||||
|
|
|
||||||
614
build-aux/config.rpath
Executable file
614
build-aux/config.rpath
Executable 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
33
configure.in
|
|
@ -25,7 +25,7 @@ Boston, MA 02110-1301, USA.
|
||||||
|
|
||||||
]])
|
]])
|
||||||
|
|
||||||
AC_PREREQ(2.53)
|
AC_PREREQ(2.59)
|
||||||
|
|
||||||
dnl `patsubst' here deletes the newline which "echo" prints. We can't use
|
dnl `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
|
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}),[
|
patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${GUILE_VERSION}),[
|
||||||
]),
|
]),
|
||||||
[bug-guile@gnu.org])
|
[bug-guile@gnu.org])
|
||||||
AC_CONFIG_AUX_DIR([.])
|
AC_CONFIG_AUX_DIR([build-aux])
|
||||||
|
AC_CONFIG_MACRO_DIR([m4])
|
||||||
AC_CONFIG_SRCDIR(GUILE-VERSION)
|
AC_CONFIG_SRCDIR(GUILE-VERSION)
|
||||||
AM_INIT_AUTOMAKE([no-define])
|
|
||||||
|
AM_INIT_AUTOMAKE([gnu no-define check-news])
|
||||||
|
|
||||||
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
|
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
|
||||||
AC_CONFIG_SRCDIR([GUILE-VERSION])
|
AC_CONFIG_SRCDIR([GUILE-VERSION])
|
||||||
|
|
@ -66,12 +68,12 @@ AC_LIBTOOL_WIN32_DLL
|
||||||
|
|
||||||
AC_PROG_INSTALL
|
AC_PROG_INSTALL
|
||||||
AC_PROG_CC
|
AC_PROG_CC
|
||||||
|
gl_EARLY
|
||||||
AC_PROG_CPP
|
AC_PROG_CPP
|
||||||
AC_PROG_AWK
|
AC_PROG_AWK
|
||||||
|
|
||||||
AC_AIX
|
dnl Gnulib.
|
||||||
AC_ISC_POSIX
|
gl_INIT
|
||||||
AC_MINIX
|
|
||||||
|
|
||||||
AM_PROG_CC_STDC
|
AM_PROG_CC_STDC
|
||||||
# for per-target cflags in the libguile subdir
|
# 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 \
|
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/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 \
|
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 double" is new in C99, and "complex" is only a keyword if
|
||||||
# <complex.h> is included
|
# <complex.h> is included
|
||||||
|
|
@ -621,6 +623,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
|
||||||
# DQNAN - OSF specific
|
# DQNAN - OSF specific
|
||||||
# (DINFINITY and DQNAN are actually global variables, not functions)
|
# (DINFINITY and DQNAN are actually global variables, not functions)
|
||||||
# chsize - an MS-DOS-ism, found in mingw
|
# 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)
|
# clog10 - not in mingw (though others like clog and csqrt are)
|
||||||
# fesetround - available in C99, but not older systems
|
# fesetround - available in C99, but not older systems
|
||||||
# ftruncate - posix, but probably not older systems (current mingw
|
# 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
|
# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
|
||||||
# nl_langinfo - X/Open, not available on Windows.
|
# 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:
|
# Reasons for testing:
|
||||||
# netdb.h - not in mingw
|
# netdb.h - not in mingw
|
||||||
|
|
@ -676,7 +681,6 @@ AC_SEARCH_LIBS(crypt, crypt,
|
||||||
#
|
#
|
||||||
if test "$ac_cv_type_complex_double" = yes; then
|
if test "$ac_cv_type_complex_double" = yes; then
|
||||||
|
|
||||||
AC_CHECK_FUNCS(cexp clog carg)
|
|
||||||
AC_CACHE_CHECK([whether csqrt is usable],
|
AC_CACHE_CHECK([whether csqrt is usable],
|
||||||
guile_cv_use_csqrt,
|
guile_cv_use_csqrt,
|
||||||
[AC_TRY_RUN([
|
[AC_TRY_RUN([
|
||||||
|
|
@ -987,16 +991,6 @@ int main () { return (isnan(x) != 0); }]]),
|
||||||
[Define to 1 if you have the `isnan' macro or function.])],
|
[Define to 1 if you have the `isnan' macro or function.])],
|
||||||
[AC_MSG_RESULT([no])])
|
[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:
|
# Reasons for checking:
|
||||||
#
|
#
|
||||||
# st_rdev
|
# st_rdev
|
||||||
|
|
@ -1362,6 +1356,7 @@ AC_CONFIG_FILES([libguile/gen-scmconfig.h])
|
||||||
AC_CONFIG_FILES([
|
AC_CONFIG_FILES([
|
||||||
Makefile
|
Makefile
|
||||||
am/Makefile
|
am/Makefile
|
||||||
|
lib/Makefile
|
||||||
benchmark-suite/Makefile
|
benchmark-suite/Makefile
|
||||||
doc/Makefile
|
doc/Makefile
|
||||||
doc/goops/Makefile
|
doc/goops/Makefile
|
||||||
|
|
|
||||||
|
|
@ -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>
|
2007-07-18 Stephen Compall <s11@member.fsf.org>
|
||||||
|
|
||||||
* srfi-modules.texi: Describe SRFI-37 in a new subsection.
|
* srfi-modules.texi: Describe SRFI-37 in a new subsection.
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ slib, The SLIB Manual}). For example,
|
||||||
@example
|
@example
|
||||||
(use-modules (ice-9 slib))
|
(use-modules (ice-9 slib))
|
||||||
(require 'primes)
|
(require 'primes)
|
||||||
(probably-prime? 13)
|
(prime? 13)
|
||||||
@result{} #t
|
@result{} #t
|
||||||
@end example
|
@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
|
example the SLIB version of @code{delete-file} returns a boolean
|
||||||
indicating success or failure, whereas the Guile core version throws
|
indicating success or failure, whereas the Guile core version throws
|
||||||
an error for failure. In general (and as might be expected) when SLIB
|
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
|
@menu
|
||||||
* SLIB installation::
|
* SLIB installation::
|
||||||
|
|
@ -41,17 +41,30 @@ is loaded it's the SLIB specifications which are followed.
|
||||||
@node SLIB installation
|
@node SLIB installation
|
||||||
@subsection 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
|
@enumerate
|
||||||
@item
|
@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
|
@item
|
||||||
Create a symlink in the Guile site directory to slib, e.g.,:
|
Define the @code{SCHEME_LIBRARY_PATH} environment variable:
|
||||||
|
|
||||||
@example
|
@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
|
@end example
|
||||||
|
|
||||||
@item
|
@item
|
||||||
|
|
@ -60,12 +73,12 @@ Use Guile to create the catalog file, e.g.,:
|
||||||
@example
|
@example
|
||||||
# guile
|
# guile
|
||||||
guile> (use-modules (ice-9 slib))
|
guile> (use-modules (ice-9 slib))
|
||||||
guile> (load "/usr/local/share/slib/mklibcat.scm")
|
guile> (require 'new-catalog)
|
||||||
guile> (quit)
|
guile> (quit)
|
||||||
@end example
|
@end example
|
||||||
|
|
||||||
The catalog data should now be in
|
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:
|
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
|
or to modify @file{ice-9/slib.scm} to use @code{define-public} for the
|
||||||
offending variables.
|
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
|
@end enumerate
|
||||||
|
|
||||||
@node JACAL
|
@node JACAL
|
||||||
|
|
|
||||||
|
|
@ -37,6 +37,8 @@ get the relevant SRFI documents from the SRFI home page
|
||||||
* SRFI-19:: Time/Date library.
|
* SRFI-19:: Time/Date library.
|
||||||
* SRFI-26:: Specializing parameters
|
* SRFI-26:: Specializing parameters
|
||||||
* SRFI-31:: A special form `rec' for recursive evaluation
|
* SRFI-31:: A special form `rec' for recursive evaluation
|
||||||
|
* SRFI-34:: Exception handling.
|
||||||
|
* SRFI-35:: Conditions.
|
||||||
* SRFI-37:: args-fold program argument processor
|
* SRFI-37:: args-fold program argument processor
|
||||||
* SRFI-39:: Parameter objects
|
* SRFI-39:: Parameter objects
|
||||||
* SRFI-55:: Requiring Features.
|
* SRFI-55:: Requiring Features.
|
||||||
|
|
@ -2402,6 +2404,196 @@ The second syntax can be used to create anonymous recursive functions:
|
||||||
@end lisp
|
@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
|
@node SRFI-37
|
||||||
@subsection SRFI-37 - args-fold
|
@subsection SRFI-37 - args-fold
|
||||||
@cindex SRFI-37
|
@cindex SRFI-37
|
||||||
|
|
|
||||||
|
|
@ -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>
|
2007-07-15 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
* LIBGUILEREADLINE-VERSION
|
* LIBGUILEREADLINE-VERSION
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
## Process this file with Automake to create Makefile.in
|
## 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.
|
## This file is part of GUILE.
|
||||||
##
|
##
|
||||||
|
|
@ -25,15 +25,17 @@ SUBDIRS = ice-9
|
||||||
DEFS = @DEFS@ @EXTRA_DEFS@
|
DEFS = @DEFS@ @EXTRA_DEFS@
|
||||||
## Check for headers in $(srcdir)/.., so that #include
|
## Check for headers in $(srcdir)/.., so that #include
|
||||||
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
||||||
## building.
|
## building. Also look for Gnulib headers in `lib'.
|
||||||
INCLUDES = -I. -I.. -I$(srcdir)/..
|
INCLUDES = -I. -I.. -I$(srcdir)/.. \
|
||||||
|
-I$(top_srcdir)/lib -I$(top_builddir)/lib
|
||||||
|
|
||||||
GUILE_SNARF = ../libguile/guile-snarf
|
GUILE_SNARF = ../libguile/guile-snarf
|
||||||
|
|
||||||
lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
|
lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
|
||||||
|
|
||||||
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c
|
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
|
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic -no-undefined
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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>
|
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
|
||||||
|
|
||||||
Implemented lazy duplicate binding handling. Fixed the
|
Implemented lazy duplicate binding handling. Fixed the
|
||||||
|
|
|
||||||
|
|
@ -429,7 +429,7 @@
|
||||||
(define (record-predicate rtd)
|
(define (record-predicate rtd)
|
||||||
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
|
(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))
|
(or (eq? rtd (record-type-descriptor obj))
|
||||||
(scm-error 'wrong-type-arg "%record-type-check"
|
(scm-error 'wrong-type-arg "%record-type-check"
|
||||||
"Wrong type record (want `~S'): ~S"
|
"Wrong type record (want `~S'): ~S"
|
||||||
|
|
@ -441,8 +441,9 @@
|
||||||
(if (not pos)
|
(if (not pos)
|
||||||
(error 'no-such-field field-name))
|
(error 'no-such-field field-name))
|
||||||
(local-eval `(lambda (obj)
|
(local-eval `(lambda (obj)
|
||||||
(%record-type-check ',rtd obj)
|
(if (eq? (struct-vtable obj) ,rtd)
|
||||||
(struct-ref obj ,pos))
|
(struct-ref obj ,pos)
|
||||||
|
(%record-type-error ,rtd obj)))
|
||||||
the-root-environment)))
|
the-root-environment)))
|
||||||
|
|
||||||
(define (record-modifier rtd field-name)
|
(define (record-modifier rtd field-name)
|
||||||
|
|
@ -450,8 +451,9 @@
|
||||||
(if (not pos)
|
(if (not pos)
|
||||||
(error 'no-such-field field-name))
|
(error 'no-such-field field-name))
|
||||||
(local-eval `(lambda (obj val)
|
(local-eval `(lambda (obj val)
|
||||||
(%record-type-check ',rtd obj)
|
(if (eq? (struct-vtable obj) ,rtd)
|
||||||
(struct-set! obj ,pos val))
|
(struct-set! obj ,pos val)
|
||||||
|
(%record-type-error ,rtd obj)))
|
||||||
the-root-environment)))
|
the-root-environment)))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -3061,7 +3063,7 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
(define (warn module name int1 val1 int2 val2 var val)
|
(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"
|
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
|
||||||
(module-name module)
|
(module-name module)
|
||||||
name
|
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)
|
(define (warn-override-core module name int1 val1 int2 val2 var val)
|
||||||
(and (eq? int1 the-scm-module)
|
(and (eq? int1 the-scm-module)
|
||||||
(begin
|
(begin
|
||||||
(format #t
|
(format (current-error-port)
|
||||||
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
|
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
|
||||||
(module-name module)
|
(module-name module)
|
||||||
(module-name int2)
|
(module-name int2)
|
||||||
|
|
|
||||||
388
ice-9/slib.scm
388
ice-9/slib.scm
|
|
@ -1,6 +1,6 @@
|
||||||
;;;; slib.scm --- definitions needed to get SLIB to work with Guile
|
;;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; 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
|
logical:bit-extract logical:integer-expt logical:ipow-by-squaring
|
||||||
slib:eval-load slib:tab slib:form-feed difftime offset-time
|
slib:eval-load slib:tab slib:form-feed difftime offset-time
|
||||||
software-type)
|
software-type)
|
||||||
:replace (delete-file open-file provide provided? system)
|
|
||||||
:no-backtrace)
|
:no-backtrace)
|
||||||
|
|
||||||
|
|
||||||
|
;; Initialize SLIB.
|
||||||
|
(load-from-path "slib/guile.init")
|
||||||
|
|
||||||
(define (eval-load <filename> evl)
|
;; SLIB redefines a few core symbols based on their default definition.
|
||||||
(if (not (file-exists? <filename>))
|
;; Thus, we only replace them at this point so that their previous definition
|
||||||
(set! <filename> (string-append <filename> (scheme-file-suffix))))
|
;; is visible when `guile.init' is loaded.
|
||||||
(call-with-input-file <filename>
|
(module-replace! (current-module)
|
||||||
(lambda (port)
|
'(delete-file open-file provide provided? system))
|
||||||
(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)))
|
|
||||||
|
|
|
||||||
|
|
@ -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>
|
2007-07-22 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
Overhauled the reader, making it faster.
|
Overhauled the reader, making it faster.
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
## Process this file with Automake to create Makefile.in
|
## 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.
|
## This file is part of GUILE.
|
||||||
##
|
##
|
||||||
|
|
@ -25,8 +25,12 @@ AUTOMAKE_OPTIONS = gnu
|
||||||
DEFS = @DEFS@
|
DEFS = @DEFS@
|
||||||
## Check for headers in $(srcdir)/.., so that #include
|
## Check for headers in $(srcdir)/.., so that #include
|
||||||
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
||||||
## building.
|
## building. Also look for Gnulib headers in `lib'.
|
||||||
INCLUDES = -I.. -I$(top_srcdir)
|
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/' \
|
ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
|
||||||
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
|
--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_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
|
||||||
$(libguile_la_CFLAGS)
|
$(libguile_la_CFLAGS)
|
||||||
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
|
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
|
||||||
libguile.la
|
libguile.la $(gnulib_library)
|
||||||
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
|
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
|
||||||
-module -L$(builddir) -lguile \
|
-module -L$(builddir) -lguile \
|
||||||
-version-info @LIBGUILE_I18N_INTERFACE@
|
-version-info @LIBGUILE_I18N_INTERFACE@
|
||||||
|
|
@ -186,7 +190,7 @@ noinst_HEADERS = convert.i.c \
|
||||||
private-gc.h private-options.h
|
private-gc.h private-options.h
|
||||||
|
|
||||||
libguile_la_DEPENDENCIES = @LIBLOBJS@
|
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
|
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>
|
# These are headers visible as <guile/mumble.h>
|
||||||
|
|
|
||||||
|
|
@ -27,25 +27,9 @@
|
||||||
# include <config.h>
|
# include <config.h>
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#include "libguile/__scm.h"
|
|
||||||
|
|
||||||
/* This blob per the Autoconf manual (under "Particular Functions"). */
|
|
||||||
#if HAVE_ALLOCA_H
|
|
||||||
#include <alloca.h>
|
#include <alloca.h>
|
||||||
#elif defined __GNUC__
|
|
||||||
# define alloca __builtin_alloca
|
#include "libguile/__scm.h"
|
||||||
#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 <assert.h>
|
#include <assert.h>
|
||||||
#include "libguile/_scm.h"
|
#include "libguile/_scm.h"
|
||||||
|
|
@ -876,8 +860,10 @@ macroexp (SCM x, SCM env)
|
||||||
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
|
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
|
||||||
|
|
||||||
if (scm_ilength (res) <= 0)
|
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
|
/* njrev: Several queries here: (1) I don't see how it can be
|
||||||
correct that the SCM_SETCAR 2 lines below this comment needs
|
correct that the SCM_SETCAR 2 lines below this comment needs
|
||||||
protection, but the SCM_SETCAR 6 lines above does not, so
|
protection, but the SCM_SETCAR 6 lines above does not, so
|
||||||
|
|
@ -895,6 +881,7 @@ macroexp (SCM x, SCM env)
|
||||||
|
|
||||||
goto macro_tail;
|
goto macro_tail;
|
||||||
}
|
}
|
||||||
|
}
|
||||||
|
|
||||||
/* Start of the memoizers for the standard R5RS builtin macros. */
|
/* Start of the memoizers for the standard R5RS builtin macros. */
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -29,23 +29,7 @@
|
||||||
# include <config.h>
|
# include <config.h>
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* This blob per the Autoconf manual (under "Particular Functions"). */
|
|
||||||
#if HAVE_ALLOCA_H
|
|
||||||
#include <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 <stdio.h>
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
|
|
|
||||||
|
|
@ -31,6 +31,7 @@
|
||||||
#include "libguile/gc.h"
|
#include "libguile/gc.h"
|
||||||
#include "libguile/posix.h"
|
#include "libguile/posix.h"
|
||||||
#include "libguile/dynwind.h"
|
#include "libguile/dynwind.h"
|
||||||
|
#include "libguile/hashtab.h"
|
||||||
|
|
||||||
#include "libguile/fports.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,
|
/* Move ports with the specified file descriptor to new descriptors,
|
||||||
* resetting the revealed count to 0.
|
* resetting the revealed count to 0.
|
||||||
*/
|
*/
|
||||||
|
static SCM
|
||||||
void
|
scm_i_evict_port (SCM handle, void *closure)
|
||||||
scm_evict_ports (int fd)
|
|
||||||
{
|
{
|
||||||
long i;
|
int fd = * (int*) closure;
|
||||||
|
SCM port = SCM_CAR (handle);
|
||||||
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;
|
|
||||||
|
|
||||||
if (SCM_FPORTP (port))
|
if (SCM_FPORTP (port))
|
||||||
{
|
{
|
||||||
|
|
@ -244,8 +239,17 @@ scm_evict_ports (int fd)
|
||||||
scm_set_port_revealed_x (port, scm_from_int (0));
|
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);
|
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -15,28 +15,11 @@
|
||||||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
* 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
|
#if HAVE_CONFIG_H
|
||||||
# include <config.h>
|
# include <config.h>
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if HAVE_ALLOCA_H
|
|
||||||
#include <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/_scm.h"
|
||||||
#include "libguile/feature.h"
|
#include "libguile/feature.h"
|
||||||
|
|
|
||||||
|
|
@ -395,6 +395,14 @@ really_cleanup_for_exit (void *unused)
|
||||||
static void
|
static void
|
||||||
cleanup_for_exit ()
|
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
|
/* This function might be called in non-guile mode, so we need to
|
||||||
enter it temporarily.
|
enter it temporarily.
|
||||||
*/
|
*/
|
||||||
|
|
@ -474,6 +482,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
||||||
scm_init_backtrace (); /* Requires fluids */
|
scm_init_backtrace (); /* Requires fluids */
|
||||||
scm_init_fports ();
|
scm_init_fports ();
|
||||||
scm_init_strports ();
|
scm_init_strports ();
|
||||||
|
scm_init_ports ();
|
||||||
scm_init_gdbint (); /* Requires strports */
|
scm_init_gdbint (); /* Requires strports */
|
||||||
scm_init_hash ();
|
scm_init_hash ();
|
||||||
scm_init_hashtab ();
|
scm_init_hashtab ();
|
||||||
|
|
@ -492,7 +501,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
||||||
scm_init_numbers ();
|
scm_init_numbers ();
|
||||||
scm_init_options ();
|
scm_init_options ();
|
||||||
scm_init_pairs ();
|
scm_init_pairs ();
|
||||||
scm_init_ports ();
|
|
||||||
#ifdef HAVE_POSIX
|
#ifdef HAVE_POSIX
|
||||||
scm_init_filesys ();
|
scm_init_filesys ();
|
||||||
scm_init_posix ();
|
scm_init_posix ();
|
||||||
|
|
|
||||||
|
|
@ -26,13 +26,14 @@
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
|
|
||||||
#include "libguile/_scm.h"
|
#include "libguile/_scm.h"
|
||||||
#include "libguile/ioext.h"
|
#include "libguile/dynwind.h"
|
||||||
#include "libguile/fports.h"
|
|
||||||
#include "libguile/feature.h"
|
#include "libguile/feature.h"
|
||||||
|
#include "libguile/fports.h"
|
||||||
|
#include "libguile/hashtab.h"
|
||||||
|
#include "libguile/ioext.h"
|
||||||
#include "libguile/ports.h"
|
#include "libguile/ports.h"
|
||||||
#include "libguile/strings.h"
|
#include "libguile/strings.h"
|
||||||
#include "libguile/validate.h"
|
#include "libguile/validate.h"
|
||||||
#include "libguile/dynwind.h"
|
|
||||||
|
|
||||||
#include <fcntl.h>
|
#include <fcntl.h>
|
||||||
|
|
||||||
|
|
@ -266,6 +267,19 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#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. */
|
/* Return a list of ports using a given file descriptor. */
|
||||||
SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
|
SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
|
||||||
(SCM fd),
|
(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
|
#define FUNC_NAME s_scm_fdes_to_ports
|
||||||
{
|
{
|
||||||
SCM result = SCM_EOL;
|
SCM result = SCM_EOL;
|
||||||
int int_fd;
|
int int_fd = scm_to_int (fd);
|
||||||
long i;
|
|
||||||
|
|
||||||
int_fd = scm_to_int (fd);
|
|
||||||
|
|
||||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
||||||
for (i = 0; i < scm_i_port_table_size; i++)
|
result = scm_internal_hash_fold (get_matching_port,
|
||||||
{
|
(void*) &int_fd, result,
|
||||||
if (SCM_OPFPORTP (scm_i_port_table[i]->port)
|
scm_i_port_weak_hash);
|
||||||
&& ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
|
|
||||||
result = scm_cons (scm_i_port_table[i]->port, result);
|
|
||||||
}
|
|
||||||
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -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
|
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
|
||||||
* and Bellcore. See scm_divide.
|
* and Bellcore. See scm_divide.
|
||||||
|
|
@ -5998,35 +5998,6 @@ scm_is_number (SCM z)
|
||||||
return scm_is_true (scm_number_p (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()
|
/* 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
|
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 (SCM_COMPLEXP (z))
|
||||||
{
|
{
|
||||||
#if HAVE_COMPLEX_DOUBLE
|
#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG
|
||||||
return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
|
return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
|
||||||
#else
|
#else
|
||||||
double re = SCM_COMPLEX_REAL (z);
|
double re = SCM_COMPLEX_REAL (z);
|
||||||
|
|
@ -6107,7 +6078,7 @@ SCM_DEFINE (scm_exp, "exp", 1, 0, 0,
|
||||||
{
|
{
|
||||||
if (SCM_COMPLEXP (z))
|
if (SCM_COMPLEXP (z))
|
||||||
{
|
{
|
||||||
#if HAVE_COMPLEX_DOUBLE
|
#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP
|
||||||
return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
|
return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
|
||||||
#else
|
#else
|
||||||
return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
|
return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
|
||||||
|
|
|
||||||
128
libguile/ports.c
128
libguile/ports.c
|
|
@ -42,12 +42,14 @@
|
||||||
#include "libguile/dynwind.h"
|
#include "libguile/dynwind.h"
|
||||||
|
|
||||||
#include "libguile/keywords.h"
|
#include "libguile/keywords.h"
|
||||||
|
#include "libguile/hashtab.h"
|
||||||
#include "libguile/root.h"
|
#include "libguile/root.h"
|
||||||
#include "libguile/strings.h"
|
#include "libguile/strings.h"
|
||||||
#include "libguile/mallocs.h"
|
#include "libguile/mallocs.h"
|
||||||
#include "libguile/validate.h"
|
#include "libguile/validate.h"
|
||||||
#include "libguile/ports.h"
|
#include "libguile/ports.h"
|
||||||
#include "libguile/vectors.h"
|
#include "libguile/vectors.h"
|
||||||
|
#include "libguile/weaks.h"
|
||||||
#include "libguile/fluids.h"
|
#include "libguile/fluids.h"
|
||||||
|
|
||||||
#ifdef HAVE_STRING_H
|
#ifdef HAVE_STRING_H
|
||||||
|
|
@ -84,7 +86,7 @@
|
||||||
|
|
||||||
|
|
||||||
/* scm_ptobs scm_numptob
|
/* 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
|
* Indexes into this table are used when generating type
|
||||||
* tags for smobjects (if you know a tag you can get an index and conversely).
|
* 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. */
|
/* The port table --- an array of pointers to ports. */
|
||||||
|
|
||||||
scm_t_port **scm_i_port_table = NULL;
|
/*
|
||||||
|
We need a global registry of ports to flush them all at exit, and to
|
||||||
long scm_i_port_table_size = 0; /* Number of ports in SCM_I_PORT_TABLE. */
|
get all the ports matching a file descriptor.
|
||||||
long scm_i_port_table_room = 20; /* Actual size of the array. */
|
*/
|
||||||
|
SCM scm_i_port_weak_hash;
|
||||||
|
|
||||||
scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
|
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 z = scm_cons (SCM_EOL, SCM_EOL);
|
||||||
scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
|
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->file_name = SCM_BOOL_F;
|
||||||
entry->rw_active = SCM_PORT_NEITHER;
|
entry->rw_active = SCM_PORT_NEITHER;
|
||||||
|
|
||||||
scm_i_port_table[scm_i_port_table_size] = entry;
|
|
||||||
scm_i_port_table_size++;
|
|
||||||
|
|
||||||
entry->port = z;
|
entry->port = z;
|
||||||
|
|
||||||
SCM_SET_CELL_TYPE (z, tag);
|
SCM_SET_CELL_TYPE (z, tag);
|
||||||
SCM_SETPTAB_ENTRY (z, entry);
|
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
|
/* For each new port, register a finalizer so that it port type's free
|
||||||
function can be invoked eventually. */
|
function can be invoked eventually. */
|
||||||
register_finalizer_for_port (z);
|
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. */
|
/* Remove a port from the table and destroy it. */
|
||||||
|
|
||||||
/* This function is not and should not be thread safe. */
|
/* This function is not and should not be thread safe. */
|
||||||
|
|
||||||
void
|
void
|
||||||
scm_remove_from_port_table (SCM port)
|
scm_i_remove_port (SCM port)
|
||||||
#define FUNC_NAME "scm_remove_from_port_table"
|
#define FUNC_NAME "scm_remove_port"
|
||||||
{
|
{
|
||||||
scm_t_port *p = SCM_PTAB_ENTRY (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)
|
if (p->putback_buf)
|
||||||
scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
|
scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
|
||||||
scm_gc_free (p, sizeof (scm_t_port), "port");
|
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_SETPTAB_ENTRY (port, 0);
|
||||||
scm_i_port_table_size--;
|
scm_hashq_remove_x (scm_i_port_weak_hash, port);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
|
||||||
#ifdef GUILE_DEBUG
|
|
||||||
/* Functions for debugging. */
|
/* Functions for debugging. */
|
||||||
|
#ifdef GUILE_DEBUG
|
||||||
SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
|
SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
|
||||||
(),
|
(),
|
||||||
"Return the number of ports in the port table. @code{pt-size}\n"
|
"Return the number of ports in the port table. @code{pt-size}\n"
|
||||||
"is only included in @code{--enable-guile-debug} builds.")
|
"is only included in @code{--enable-guile-debug} builds.")
|
||||||
#define FUNC_NAME s_scm_pt_size
|
#define FUNC_NAME s_scm_pt_size
|
||||||
{
|
{
|
||||||
return scm_from_int (scm_i_port_table_size);
|
return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash));
|
||||||
}
|
|
||||||
#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;
|
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
#endif
|
#endif
|
||||||
|
|
@ -833,7 +791,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
|
||||||
else
|
else
|
||||||
rv = 0;
|
rv = 0;
|
||||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
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_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||||
SCM_CLR_PORT_OPEN_FLAG (port);
|
SCM_CLR_PORT_OPEN_FLAG (port);
|
||||||
return scm_from_bool (rv >= 0);
|
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
|
#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
|
void
|
||||||
scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
|
scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
|
||||||
{
|
{
|
||||||
long i;
|
int i = 0;
|
||||||
size_t n;
|
size_t n;
|
||||||
SCM ports;
|
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 */
|
collect the ports into a vector. -mvo */
|
||||||
|
|
||||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
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);
|
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||||
|
|
||||||
ports = scm_c_make_vector (n, SCM_BOOL_F);
|
ports = scm_c_make_vector (n, SCM_BOOL_F);
|
||||||
|
|
||||||
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
|
scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
|
||||||
if (n > scm_i_port_table_size)
|
ports = scm_internal_hash_fold (scm_i_collect_keys_in_vector, &i,
|
||||||
n = scm_i_port_table_size;
|
ports, scm_i_port_weak_hash);
|
||||||
for (i = 0; i < n; i++)
|
|
||||||
SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
|
|
||||||
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
|
||||||
|
|
||||||
for (i = 0; i < n; i++)
|
for (i = 0; i < n; i++) {
|
||||||
proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
|
SCM p = SCM_SIMPLE_VECTOR_REF (ports, i);
|
||||||
|
if (SCM_PORTP (p))
|
||||||
|
proc (data, p);
|
||||||
|
}
|
||||||
|
|
||||||
scm_remember_upto_here_1 (ports);
|
scm_remember_upto_here_1 (ports);
|
||||||
}
|
}
|
||||||
|
|
@ -1000,21 +968,21 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#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,
|
SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
|
||||||
(),
|
(),
|
||||||
"Equivalent to calling @code{force-output} on\n"
|
"Equivalent to calling @code{force-output} on\n"
|
||||||
"all open output ports. The return value is unspecified.")
|
"all open output ports. The return value is unspecified.")
|
||||||
#define FUNC_NAME s_scm_flush_all_ports
|
#define FUNC_NAME s_scm_flush_all_ports
|
||||||
{
|
{
|
||||||
size_t i;
|
scm_c_port_for_each (&flush_output_port, NULL);
|
||||||
|
|
||||||
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);
|
|
||||||
return SCM_UNSPECIFIED;
|
return SCM_UNSPECIFIED;
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
@ -1806,6 +1774,8 @@ scm_init_ports ()
|
||||||
cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
|
cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
|
||||||
cur_loadport_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"
|
#include "libguile/ports.x"
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -47,7 +47,6 @@ typedef enum scm_t_port_rw_active {
|
||||||
typedef struct
|
typedef struct
|
||||||
{
|
{
|
||||||
SCM port; /* Link back to the port object. */
|
SCM port; /* Link back to the port object. */
|
||||||
long entry; /* Index in port table. */
|
|
||||||
int revealed; /* 0 not revealed, > 1 revealed.
|
int revealed; /* 0 not revealed, > 1 revealed.
|
||||||
* Revealed ports do not get GC'd.
|
* Revealed ports do not get GC'd.
|
||||||
*/
|
*/
|
||||||
|
|
@ -109,9 +108,10 @@ typedef struct
|
||||||
size_t putback_buf_size; /* allocated size of putback_buf. */
|
size_t putback_buf_size; /* allocated size of putback_buf. */
|
||||||
} scm_t_port;
|
} 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_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)
|
#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_output_port (SCM port);
|
||||||
SCM_API void scm_dynwind_current_error_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 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 void scm_grow_port_cbuf (SCM port, size_t requested);
|
||||||
SCM_API SCM scm_pt_size (void);
|
SCM_API SCM scm_pt_size (void);
|
||||||
SCM_API SCM scm_pt_member (SCM member);
|
SCM_API SCM scm_pt_member (SCM member);
|
||||||
|
|
|
||||||
|
|
@ -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
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public
|
* modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -21,9 +21,6 @@
|
||||||
# include <config.h>
|
# include <config.h>
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* Make GNU/Linux libc declare everything it has. */
|
|
||||||
#define _GNU_SOURCE
|
|
||||||
|
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
|
|
||||||
|
|
@ -1343,16 +1340,39 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
|
||||||
|
|
||||||
if (strchr (c_str, '=') == NULL)
|
if (strchr (c_str, '=') == NULL)
|
||||||
{
|
{
|
||||||
#ifdef HAVE_UNSETENV
|
/* We want no "=" in the argument to mean remove the variable from the
|
||||||
/* No '=' in argument means we should remove the variable from
|
environment, but not all putenv()s understand this, for example
|
||||||
the environment. Not all putenvs understand this (for instance
|
FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
|
||||||
FreeBSD 4.8 doesn't). To be safe, we do it explicitely using
|
painful. What unsetenv() exists, we use that, of course.
|
||||||
unsetenv. */
|
|
||||||
|
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);
|
unsetenv (c_str);
|
||||||
free (c_str);
|
free (c_str);
|
||||||
#else
|
#elif defined (__MINGW32__)
|
||||||
/* On e.g. Win32 hosts putenv() called with 'name=' removes the
|
/* otherwise putenv("NAME=") on DOS */
|
||||||
environment variable 'name'. */
|
|
||||||
int e;
|
int e;
|
||||||
size_t len = strlen (c_str);
|
size_t len = strlen (c_str);
|
||||||
char *ptr = scm_malloc (len + 2);
|
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;
|
e = errno; free (ptr); free (c_str); errno = e;
|
||||||
if (rv < 0)
|
if (rv < 0)
|
||||||
SCM_SYSERROR;
|
SCM_SYSERROR;
|
||||||
#endif /* !HAVE_UNSETENV */
|
#else
|
||||||
|
/* otherwise traditional putenv("NAME") */
|
||||||
|
rv = putenv (c_str);
|
||||||
|
if (rv < 0)
|
||||||
|
SCM_SYSERROR;
|
||||||
|
#endif
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
|
|
|
||||||
|
|
@ -26,9 +26,6 @@
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
#include <ctype.h>
|
#include <ctype.h>
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
#ifdef HAVE_STRINGS_H
|
|
||||||
# include <strings.h>
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#include "libguile/_scm.h"
|
#include "libguile/_scm.h"
|
||||||
#include "libguile/chars.h"
|
#include "libguile/chars.h"
|
||||||
|
|
@ -182,29 +179,8 @@ static SCM *scm_read_hash_procedures;
|
||||||
(((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
|
(((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
|
||||||
|
|
||||||
|
|
||||||
#ifndef HAVE_STRNCASECMP
|
/* Read an SCSH block comment. */
|
||||||
/* XXX: Use Gnulib's `strncasecmp ()'. */
|
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
|
|
||||||
/* Helper function similar to `scm_read_token ()'. Read from PORT until a
|
/* 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,
|
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;
|
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_LINE_INCREMENTORS:
|
||||||
case SCM_SINGLE_SPACES:
|
case SCM_SINGLE_SPACES:
|
||||||
case '\t':
|
case '\t':
|
||||||
|
|
@ -637,6 +628,8 @@ static SCM
|
||||||
scm_read_quote (int chr, SCM port)
|
scm_read_quote (int chr, SCM port)
|
||||||
{
|
{
|
||||||
SCM p;
|
SCM p;
|
||||||
|
long line = SCM_LINUM (port);
|
||||||
|
int column = SCM_COL (port) - 1;
|
||||||
|
|
||||||
switch (chr)
|
switch (chr)
|
||||||
{
|
{
|
||||||
|
|
@ -670,6 +663,17 @@ scm_read_quote (int chr, SCM port)
|
||||||
}
|
}
|
||||||
|
|
||||||
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
|
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;
|
return p;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -67,6 +67,26 @@
|
||||||
+ strlen ((ptr)->sun_path))
|
+ strlen ((ptr)->sun_path))
|
||||||
#endif
|
#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,
|
SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
|
||||||
|
|
@ -344,7 +364,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
|
||||||
{
|
{
|
||||||
int af;
|
int af;
|
||||||
char *src;
|
char *src;
|
||||||
char dst[16];
|
scm_t_uint32 dst[4];
|
||||||
int rv, eno;
|
int rv, eno;
|
||||||
|
|
||||||
af = scm_to_int (family);
|
af = scm_to_int (family);
|
||||||
|
|
@ -359,7 +379,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
|
||||||
else if (rv == 0)
|
else if (rv == 0)
|
||||||
SCM_MISC_ERROR ("Bad address", SCM_EOL);
|
SCM_MISC_ERROR ("Bad address", SCM_EOL);
|
||||||
if (af == AF_INET)
|
if (af == AF_INET)
|
||||||
return scm_from_ulong (ntohl (*(scm_t_uint32 *) dst));
|
return scm_from_ulong (ntohl (*dst));
|
||||||
else
|
else
|
||||||
return scm_from_ipv6 ((scm_t_uint8 *) dst);
|
return scm_from_ipv6 ((scm_t_uint8 *) dst);
|
||||||
}
|
}
|
||||||
|
|
@ -468,6 +488,17 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0,
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
#endif
|
#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_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
||||||
(SCM sock, SCM level, SCM optname),
|
(SCM sock, SCM level, SCM optname),
|
||||||
"Return an option value from socket port @var{sock}.\n"
|
"Return an option value from socket port @var{sock}.\n"
|
||||||
|
|
@ -518,13 +549,8 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
||||||
{
|
{
|
||||||
int fd;
|
int fd;
|
||||||
/* size of optval is the largest supported option. */
|
/* size of optval is the largest supported option. */
|
||||||
#ifdef HAVE_STRUCT_LINGER
|
scm_t_getsockopt_result optval;
|
||||||
char optval[sizeof (struct linger)];
|
socklen_t optlen = sizeof (optval);
|
||||||
socklen_t optlen = sizeof (struct linger);
|
|
||||||
#else
|
|
||||||
char optval[sizeof (size_t)];
|
|
||||||
socklen_t optlen = sizeof (size_t);
|
|
||||||
#endif
|
|
||||||
int ilevel;
|
int ilevel;
|
||||||
int ioptname;
|
int ioptname;
|
||||||
|
|
||||||
|
|
@ -534,7 +560,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
||||||
ioptname = scm_to_int (optname);
|
ioptname = scm_to_int (optname);
|
||||||
|
|
||||||
fd = SCM_FPORT_FDES (sock);
|
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;
|
SCM_SYSERROR;
|
||||||
|
|
||||||
if (ilevel == SOL_SOCKET)
|
if (ilevel == SOL_SOCKET)
|
||||||
|
|
@ -543,12 +569,12 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
||||||
if (ioptname == SO_LINGER)
|
if (ioptname == SO_LINGER)
|
||||||
{
|
{
|
||||||
#ifdef HAVE_STRUCT_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),
|
return scm_cons (scm_from_long (ling->l_onoff),
|
||||||
scm_from_long (ling->l_linger));
|
scm_from_long (ling->l_linger));
|
||||||
#else
|
#else
|
||||||
return scm_cons (scm_from_long (*(int *) optval),
|
return scm_cons (scm_from_long (*(int *) &optval),
|
||||||
scm_from_int (0));
|
scm_from_int (0));
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
@ -563,10 +589,10 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
||||||
#endif
|
#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
|
#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. */
|
/* Put the components of a sockaddr into a new SCM vector. */
|
||||||
static SCM_C_INLINE_KEYWORD SCM
|
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)
|
const char *proc)
|
||||||
{
|
{
|
||||||
short int fam = address->sa_family;
|
|
||||||
SCM result = SCM_EOL;
|
SCM result = SCM_EOL;
|
||||||
|
short int fam = ((struct sockaddr *) address)->sa_family;
|
||||||
|
|
||||||
switch (fam)
|
switch (fam)
|
||||||
{
|
{
|
||||||
|
|
@ -1083,7 +1108,8 @@ _scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size,
|
||||||
SCM
|
SCM
|
||||||
scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size)
|
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
|
/* 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).")
|
"@code{connect} for details).")
|
||||||
#define FUNC_NAME s_scm_make_socket_address
|
#define FUNC_NAME s_scm_make_socket_address
|
||||||
{
|
{
|
||||||
|
SCM result = SCM_BOOL_F;
|
||||||
struct sockaddr *c_address;
|
struct sockaddr *c_address;
|
||||||
size_t c_address_size;
|
size_t c_address_size;
|
||||||
|
|
||||||
c_address = scm_c_make_socket_address (family, address, args,
|
c_address = scm_c_make_socket_address (family, address, args,
|
||||||
&c_address_size);
|
&c_address_size);
|
||||||
if (!c_address)
|
if (c_address != NULL)
|
||||||
return SCM_BOOL_F;
|
{
|
||||||
|
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
|
#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_DEFINE (scm_accept, "accept", 1, 0, 0,
|
||||||
(SCM sock),
|
(SCM sock),
|
||||||
"Accept a connection on a bound, listening socket.\n"
|
"Accept a connection on a bound, listening socket.\n"
|
||||||
|
|
@ -1315,17 +1326,18 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
|
||||||
SCM address;
|
SCM address;
|
||||||
SCM newsock;
|
SCM newsock;
|
||||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||||
char max_addr[MAX_ADDR_SIZE];
|
scm_t_max_sockaddr addr;
|
||||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
|
||||||
|
|
||||||
sock = SCM_COERCE_OUTPORT (sock);
|
sock = SCM_COERCE_OUTPORT (sock);
|
||||||
SCM_VALIDATE_OPFPORT (1, sock);
|
SCM_VALIDATE_OPFPORT (1, sock);
|
||||||
fd = SCM_FPORT_FDES (sock);
|
fd = SCM_FPORT_FDES (sock);
|
||||||
newfd = accept (fd, addr, &addr_size);
|
newfd = accept (fd, (struct sockaddr *) &addr, &addr_size);
|
||||||
if (newfd == -1)
|
if (newfd == -1)
|
||||||
SCM_SYSERROR;
|
SCM_SYSERROR;
|
||||||
newsock = SCM_SOCK_FD_TO_PORT (newfd);
|
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);
|
return scm_cons (newsock, address);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
@ -1339,15 +1351,15 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
|
||||||
{
|
{
|
||||||
int fd;
|
int fd;
|
||||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||||
char max_addr[MAX_ADDR_SIZE];
|
scm_t_max_sockaddr addr;
|
||||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
|
||||||
|
|
||||||
sock = SCM_COERCE_OUTPORT (sock);
|
sock = SCM_COERCE_OUTPORT (sock);
|
||||||
SCM_VALIDATE_OPFPORT (1, sock);
|
SCM_VALIDATE_OPFPORT (1, sock);
|
||||||
fd = SCM_FPORT_FDES (sock);
|
fd = SCM_FPORT_FDES (sock);
|
||||||
if (getsockname (fd, addr, &addr_size) == -1)
|
if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1)
|
||||||
SCM_SYSERROR;
|
SCM_SYSERROR;
|
||||||
return _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
|
||||||
|
return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
|
@ -1361,15 +1373,15 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
|
||||||
{
|
{
|
||||||
int fd;
|
int fd;
|
||||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||||
char max_addr[MAX_ADDR_SIZE];
|
scm_t_max_sockaddr addr;
|
||||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
|
||||||
|
|
||||||
sock = SCM_COERCE_OUTPORT (sock);
|
sock = SCM_COERCE_OUTPORT (sock);
|
||||||
SCM_VALIDATE_OPFPORT (1, sock);
|
SCM_VALIDATE_OPFPORT (1, sock);
|
||||||
fd = SCM_FPORT_FDES (sock);
|
fd = SCM_FPORT_FDES (sock);
|
||||||
if (getpeername (fd, addr, &addr_size) == -1)
|
if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1)
|
||||||
SCM_SYSERROR;
|
SCM_SYSERROR;
|
||||||
return _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
|
||||||
|
return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
|
@ -1505,8 +1517,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
|
||||||
size_t cend;
|
size_t cend;
|
||||||
SCM address;
|
SCM address;
|
||||||
socklen_t addr_size = MAX_ADDR_SIZE;
|
socklen_t addr_size = MAX_ADDR_SIZE;
|
||||||
char max_addr[MAX_ADDR_SIZE];
|
scm_t_max_sockaddr addr;
|
||||||
struct sockaddr *addr = (struct sockaddr *) max_addr;
|
|
||||||
|
|
||||||
SCM_VALIDATE_OPFPORT (1, sock);
|
SCM_VALIDATE_OPFPORT (1, sock);
|
||||||
fd = SCM_FPORT_FDES (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
|
/* recvfrom will not necessarily return an address. usually nothing
|
||||||
is returned for stream sockets. */
|
is returned for stream sockets. */
|
||||||
buf = scm_i_string_writable_chars (str);
|
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,
|
SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
|
||||||
cend - offset, flg,
|
cend - offset, flg,
|
||||||
addr, &addr_size));
|
(struct sockaddr *) &addr, &addr_size));
|
||||||
scm_i_string_stop_writing ();
|
scm_i_string_stop_writing ();
|
||||||
|
|
||||||
if (rv == -1)
|
if (rv == -1)
|
||||||
SCM_SYSERROR;
|
SCM_SYSERROR;
|
||||||
if (addr->sa_family != AF_UNSPEC)
|
if (((struct sockaddr *) &addr)->sa_family != AF_UNSPEC)
|
||||||
address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME);
|
address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
|
||||||
else
|
else
|
||||||
address = SCM_BOOL_F;
|
address = SCM_BOOL_F;
|
||||||
|
|
||||||
scm_remember_upto_here_1 (str);
|
scm_remember_upto_here_1 (str);
|
||||||
|
|
||||||
return scm_cons (scm_from_int (rv), address);
|
return scm_cons (scm_from_int (rv), address);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
/* srfi-14.c --- SRFI-14 procedures for Guile
|
/* 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
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public
|
* modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -22,8 +22,6 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
||||||
#define _GNU_SOURCE /* Ask for `isblank ()'. */
|
|
||||||
|
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
#include <ctype.h>
|
#include <ctype.h>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public
|
* modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -32,6 +32,9 @@
|
||||||
hard coding __hpux. */
|
hard coding __hpux. */
|
||||||
|
|
||||||
#define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
|
#define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
|
||||||
|
#ifndef _REENTRANT
|
||||||
|
# define _REENTRANT /* ask solaris for gmtime_r prototype */
|
||||||
|
#endif
|
||||||
#ifdef __hpux
|
#ifdef __hpux
|
||||||
#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
|
#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
|
||||||
#endif
|
#endif
|
||||||
|
|
|
||||||
|
|
@ -487,20 +487,18 @@ do_thread_exit (void *v)
|
||||||
static void
|
static void
|
||||||
on_thread_exit (void *v)
|
on_thread_exit (void *v)
|
||||||
{
|
{
|
||||||
|
/* This handler is executed in non-guile mode. */
|
||||||
scm_i_thread *t = (scm_i_thread *)v, **tp;
|
scm_i_thread *t = (scm_i_thread *)v, **tp;
|
||||||
|
|
||||||
scm_i_pthread_setspecific (scm_i_thread_key, v);
|
scm_i_pthread_setspecific (scm_i_thread_key, v);
|
||||||
|
|
||||||
/* Unblocking the joining threads needs to happen in guile mode
|
/* 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);
|
scm_with_guile (do_thread_exit, v);
|
||||||
|
|
||||||
/* Removing ourself from the list of all threads needs to happen in
|
/* Removing ourself from the list of all threads needs to happen in
|
||||||
non-guile mode since all SCM values on our stack become
|
non-guile mode since all SCM values on our stack become
|
||||||
unprotected once we are no longer in the list.
|
unprotected once we are no longer in the list. */
|
||||||
*/
|
|
||||||
scm_leave_guile ();
|
|
||||||
scm_i_pthread_mutex_lock (&thread_admin_mutex);
|
scm_i_pthread_mutex_lock (&thread_admin_mutex);
|
||||||
for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
|
for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
|
||||||
if (*tp == t)
|
if (*tp == t)
|
||||||
|
|
|
||||||
|
|
@ -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 int scm_i_mark_weak_vectors_non_weaks (void);
|
||||||
SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
|
SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
|
||||||
|
|
||||||
|
|
||||||
#endif /* SCM_WEAKS_H */
|
#endif /* SCM_WEAKS_H */
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
|
||||||
10
m4/ChangeLog
Normal file
10
m4/ChangeLog
Normal 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
32
m4/gnulib-cache.m4
Normal 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])
|
||||||
|
|
@ -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>
|
2007-07-18 Stephen Compall <s11@member.fsf.org>
|
||||||
|
|
||||||
* srfi-37.scm: New file.
|
* srfi-37.scm: New file.
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
## Process this file with Automake to create Makefile.in
|
## 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.
|
## This file is part of GUILE.
|
||||||
##
|
##
|
||||||
|
|
@ -25,8 +25,9 @@ AUTOMAKE_OPTIONS = gnu
|
||||||
DEFS = @DEFS@ @EXTRA_DEFS@
|
DEFS = @DEFS@ @EXTRA_DEFS@
|
||||||
## Check for headers in $(srcdir)/.., so that #include
|
## Check for headers in $(srcdir)/.., so that #include
|
||||||
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
|
||||||
## building.
|
## building. Also look for Gnulib headers in `lib'.
|
||||||
INCLUDES = -I.. -I$(srcdir)/..
|
INCLUDES = -I.. -I$(srcdir)/.. \
|
||||||
|
-I$(top_srcdir)/lib -I$(top_builddir)/lib
|
||||||
|
|
||||||
srfiincludedir = $(pkgincludedir)/srfi
|
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
|
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_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_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_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_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_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_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_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@
|
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
|
srfidir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/srfi
|
||||||
|
|
@ -74,6 +79,7 @@ srfi_DATA = srfi-1.scm \
|
||||||
srfi-26.scm \
|
srfi-26.scm \
|
||||||
srfi-31.scm \
|
srfi-31.scm \
|
||||||
srfi-34.scm \
|
srfi-34.scm \
|
||||||
|
srfi-35.scm \
|
||||||
srfi-37.scm \
|
srfi-37.scm \
|
||||||
srfi-39.scm \
|
srfi-39.scm \
|
||||||
srfi-60.scm
|
srfi-60.scm
|
||||||
|
|
|
||||||
335
srfi/srfi-35.scm
Normal file
335
srfi/srfi-35.scm
Normal 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
|
||||||
|
|
@ -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>
|
2007-07-22 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
|
||||||
* tests/reader.test: Added a proper header and `define-module'.
|
* 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.
|
* 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
|
* tests/unif.test (syntax): New test prefix. Check syntax for
|
||||||
negative lower bounds and negative lengths (reported by Gyula
|
negative lower bounds and negative lengths (reported by Gyula
|
||||||
|
|
@ -167,7 +207,7 @@
|
||||||
ensure intended exact vs inexact is checked. Reported by Aaron
|
ensure intended exact vs inexact is checked. Reported by Aaron
|
||||||
M. Ucko, Debian bug 396119.
|
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'.
|
* test-suite/tests/vectors.test: Use `define-module'.
|
||||||
(vector->list): New test prefix. "Shared array" test contributed
|
(vector->list): New test prefix. "Shared array" test contributed
|
||||||
|
|
@ -187,7 +227,7 @@
|
||||||
|
|
||||||
* tests/environments.test: Comment out all tests in this file.
|
* 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
|
* tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a
|
||||||
typo: `thrown' instead of `throw'.
|
typo: `thrown' instead of `throw'.
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
## Process this file with automake to produce Makefile.in.
|
## 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.
|
## This file is part of GUILE.
|
||||||
##
|
##
|
||||||
|
|
@ -75,6 +75,7 @@ SCM_TESTS = tests/alist.test \
|
||||||
tests/srfi-26.test \
|
tests/srfi-26.test \
|
||||||
tests/srfi-31.test \
|
tests/srfi-31.test \
|
||||||
tests/srfi-34.test \
|
tests/srfi-34.test \
|
||||||
|
tests/srfi-35.test \
|
||||||
tests/srfi-37.test \
|
tests/srfi-37.test \
|
||||||
tests/srfi-39.test \
|
tests/srfi-39.test \
|
||||||
tests/srfi-60.test \
|
tests/srfi-60.test \
|
||||||
|
|
|
||||||
|
|
@ -549,6 +549,44 @@
|
||||||
(set-port-line! port n)
|
(set-port-line! port n)
|
||||||
(eqv? n (port-line port)))))
|
(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
|
;;; seek
|
||||||
;;;
|
;;;
|
||||||
|
|
|
||||||
|
|
@ -77,6 +77,10 @@
|
||||||
(equal? '(+ 1 2 3)
|
(equal? '(+ 1 2 3)
|
||||||
(read-string "(+ 1 #! this is a\ncomment !# 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"
|
(pass-if "unprintable symbol"
|
||||||
;; The reader tolerates unprintable characters for symbols.
|
;; The reader tolerates unprintable characters for symbols.
|
||||||
(equal? (string->symbol "\001\002\003")
|
(equal? (string->symbol "\001\002\003")
|
||||||
|
|
@ -151,6 +155,12 @@
|
||||||
(let ((sexp (with-read-options '(positions)
|
(let ((sexp (with-read-options '(positions)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(read-string "(+ 1 2 3)")))))
|
(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)
|
(and (equal? (source-property sexp 'line) 0)
|
||||||
(equal? (source-property sexp 'column) 0)))))
|
(equal? (source-property sexp 'column) 0)))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -48,6 +48,8 @@
|
||||||
;; set!
|
;; set!
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
(define %some-variable #f)
|
||||||
|
|
||||||
(with-test-prefix "set!"
|
(with-test-prefix "set!"
|
||||||
|
|
||||||
(with-test-prefix "target is not procedure with setter"
|
(with-test-prefix "target is not procedure with setter"
|
||||||
|
|
@ -58,7 +60,20 @@
|
||||||
|
|
||||||
(pass-if-exception "(set! '#f 1)"
|
(pass-if-exception "(set! '#f 1)"
|
||||||
exception:bad-variable
|
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
|
;; setter
|
||||||
|
|
|
||||||
310
test-suite/tests/srfi-35.test
Normal file
310
test-suite/tests/srfi-35.test
Normal 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")))
|
||||||
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
|
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
|
||||||
;;;; Martin Grabmueller, 2001-05-10
|
;;;; 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
|
;;;; 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
|
;;;; it under the terms of the GNU General Public License as published by
|
||||||
|
|
@ -23,10 +23,6 @@
|
||||||
#:use-module (srfi srfi-9))
|
#:use-module (srfi srfi-9))
|
||||||
|
|
||||||
|
|
||||||
(define exception:not-a-record
|
|
||||||
(cons 'misc-error "^not-a-record"))
|
|
||||||
|
|
||||||
|
|
||||||
(define-record-type :foo (make-foo x) foo?
|
(define-record-type :foo (make-foo x) foo?
|
||||||
(x get-x) (y get-y set-y!))
|
(x get-x) (y get-y set-y!))
|
||||||
|
|
||||||
|
|
@ -61,9 +57,9 @@
|
||||||
(pass-if "get-y"
|
(pass-if "get-y"
|
||||||
(= 2 (get-y f)))
|
(= 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))
|
(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))
|
(get-y 999))
|
||||||
|
|
||||||
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
|
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
|
||||||
|
|
@ -78,7 +74,7 @@
|
||||||
(set-y! f #t)
|
(set-y! f #t)
|
||||||
(eq? #t (get-y f)))
|
(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))
|
(set-y! 999 #t))
|
||||||
|
|
||||||
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
|
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue