mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

Merge commit '7337d56d57' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	libguile/struct.c
This commit is contained in:
Ludovic Courtès 2008-09-10 22:44:31 +02:00
commit e9b8556ec9
66 changed files with 3574 additions and 1459 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.cvsignore
View file

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

102
ChangeLog
View file

@ -1,11 +1,80 @@
2007-07-22 Ludovic Courtès <ludo@gnu.org>
* configure.in: Check for <strings.h> and `strncasecmp ()'.
2007-07-19 Ludovic Courtès <ludo@gnu.org>
* NEWS: Mention `(ice-9 i18n)' and lazy duplicate binding
resolution.
2007-07-18 Ludovic Courtès <ludo@gnu.org>
* NEWS: Mention SRFI-37.
2007-07-15 Ludovic Courtès <ludo@gnu.org>
Guile 1.8.2 released.
* NEWS: Mention HP-UX/IA64 build fixes.
* THANKS: Added people who reported bugs or sent patches since
1.8.1. Converted to UTF-8.
* README: Updated version number.
* Makefile.am (EXTRA_DIST): Removed `BUGS' (was outdated).
* ANON-CVS, HACKING, SNAPSHOTS: New, from the `workbook'
directory of the CVS repository.
* autogen.sh: Removed dependency on the `workbook' CVS
directory.
* GUILE-VERSION (GUILE_MICRO_VERSION): Set to 2.
(LIBGUILE_INTERFACE_CURRENT): Incremented due to new symbols.
(LIBGUILE_INTERFACE_REVISION): Set to 0.
(LIBGUILE_INTERFACE_AGE): Incremented.
(LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION): Incremented due to
bug fixes.
2007-07-11 Ludovic Courtès <ludo@gnu.org>
* NEWS: Mention GOOPS `method-more-specific?' bug fix.
2007-07-09 Ludovic Courtès <ludo@gnu.org>
* NEWS: Mention SRFI-19 `date->julian-day' bug fix.
2007-06-26 Ludovic Courtès <ludo@gnu.org>
* NEWS: Mention fixed memory leaks.
2007-06-12 Ludovic Courtès <ludo@chbouib.org>
* NEWS: Mention `inet-ntop' bug fix.
2007-05-09 Ludovic Courtès <ludo@chbouib.org>
* NEWS: Mention SRFI-19 `time-process' bug fix.
2007-04-17 Ludovic Courtès <ludovic.courtes@laas.fr>
* configure.in (GUILE_FOR_BUILD): Reverted to `$(preinstguile)'
instead of `$(top_builddir_absolute)/$(preinstguile)'.
2007-04-09 Han-Wen Nienhuys <hanwen@lilypond.org>
* configure.in (HAVE_CRYPT): check for cexp, clog, carg
2007-02-24 Neil Jerram <neil@ossau.uklinux.net>
* autogen.sh: Announce versions of autoconf, automake, libtool and
m4.
* pre-inst-guile.in (subdirs_with_ltlibs): Add libguile.
2007-02-18 Neil Jerram <neil@ossau.uklinux.net> 2007-02-18 Neil Jerram <neil@ossau.uklinux.net>
* acinclude.m4 (AM_INTL_SUBDIR): Remove unnecessary dnl.
* configure.in: Remove AM_GNU_GETTEXT_VERSION again.
* Makefile.am (EXTRA_DIST): Add config.rpath.
* config.rpath (Module): New (from gettext package). * config.rpath (Module): New (from gettext package).
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
@ -15,20 +84,29 @@
2007-01-28 Neil Jerram <neil@ossau.uklinux.net> 2007-01-28 Neil Jerram <neil@ossau.uklinux.net>
* configure.in: Do AM_GNU_GETTEXT_VERSION, so that autoreconf will
run autopoint.
* acinclude.m4 (AM_INTL_SUBDIR): Provide dummy definition, to work
around current autoconf/automake/gettext bug.
* INSTALL: New upstream version. * INSTALL: New upstream version.
* ABOUT-NLS: New upstream version. * ABOUT-NLS: New upstream version.
2007-01-23 Kevin Ryde <user42@zip.com.au>
* configure.in (isinf, isnan): Use a volatile global to stop gcc
optimizing out the test. In particular this fixes solaris where there
isn't an isinf or isnan (though gcc still optimizes as if there is).
Reported by Hugh Sasse.
(AC_C_VOLATILE): New.
2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org> 2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org>
* .gitignore: new file. Make using git easier. * .gitignore: new file. Make using git easier.
2007-01-22 Kevin Ryde <user42@zip.com.au>
* configure.in (AC_INIT): Don't use "echo -n", it's not portable and
in particular fails on solaris (resulting in literal "-n"s going into
the output, making the resulting configure unusable). Reported by
Hugh Sasse.
2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org> 2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org>
* autogen.sh (Module): only try to run render-bugs if it exists. * autogen.sh (Module): only try to run render-bugs if it exists.

4
Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in. ## Process this file with automake to produce Makefile.in.
## ##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006 Free Software Foundation, Inc. ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007 Free Software Foundation, Inc.
## ##
## This file is part of GUILE. ## This file is part of GUILE.
## ##
@ -33,7 +33,7 @@ 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 BUGS config.rpath EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS
TESTS = check-guile TESTS = check-guile

34
NEWS
View file

@ -1,5 +1,5 @@
Guile NEWS --- history of user-visible changes. Guile NEWS --- history of user-visible changes.
Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
See the end for copying conditions. See the end for copying conditions.
Please send Guile bug reports to bug-guile@gnu.org. Note that you Please send Guile bug reports to bug-guile@gnu.org. Note that you
@ -16,6 +16,10 @@ Each release reports the NEWS in the following sections:
Changes in 1.9.XXXXXXXX: Changes in 1.9.XXXXXXXX:
* New modules (see the manual for details)
** The `(ice-9 i18n)' module provides internationalization support
* Changes to the distribution * Changes to the distribution
* Changes to the stand-alone interpreter * Changes to the stand-alone interpreter
* Changes to Scheme functions and syntax * Changes to Scheme functions and syntax
@ -23,10 +27,20 @@ Changes in 1.9.XXXXXXXX:
** A new 'memoize-symbol evaluator trap has been added. This trap can ** A new 'memoize-symbol evaluator trap has been added. This trap can
be used for efficiently implementing a Scheme code coverage. be used for efficiently implementing a Scheme code coverage.
** Duplicate bindings among used modules are resolved lazily.
This slightly improves program startup times.
* Changes to the C interface * Changes to the C interface
** Functions for handling scm_option now no longer require an argument ** Functions for handling `scm_option' now no longer require an argument
indicating length of the scm_t_option array. indicating length of the `scm_t_option' array.
Changes in 1.8.3 (since 1.8.2)
* New modules (see the manual for details)
** `(srfi srfi-37)'
Changes in 1.8.2 (since 1.8.1): Changes in 1.8.2 (since 1.8.1):
@ -34,6 +48,7 @@ Changes in 1.8.2 (since 1.8.1):
* New procedures (see the manual for details) * New procedures (see the manual for details)
** set-program-arguments ** set-program-arguments
** make-vtable
* Bugs fixed * Bugs fixed
@ -45,14 +60,21 @@ Changes in 1.8.2 (since 1.8.1):
the core bindings got priority, preventing SRFI replacements or the core bindings got priority, preventing SRFI replacements or
extensions.) extensions.)
** `regexp-exec' doesn't abort() on #\nul in the input or bad flags arg ** `regexp-exec' doesn't abort() on #\nul in the input or bad flags arg
** `kill' on mingw throws an error for a pid other than oneself ** `kill' on mingw throws an error for a PID other than oneself
** Procedure names are attached to procedure-with-setters ** Procedure names are attached to procedure-with-setters
** Array read syntax works with negative lower bound ** Array read syntax works with negative lower bound
** `array-in-bounds?' fix if an array has different lower bounds on each index ** `array-in-bounds?' fix if an array has different lower bounds on each index
** `*' returns exact 0 for "(* inexact 0)" ** `*' returns exact 0 for "(* inexact 0)"
This follows what it always did for "(* 0 inexact)". This follows what it always did for "(* 0 inexact)".
** SRFI-19: Value returned by `(current-time time-process)' was incorrect
** SRFI-19: `date->julian-day' did not account for timezone offset
** `ttyname' no longer crashes when passed a non-tty argument
** `inet-ntop' no longer crashes on SPARC when passed an `AF_INET' address
** Small memory leaks have been fixed in `make-fluid' and `add-history'
** GOOPS: Fixed a bug in `method-more-specific?'
** Build problems on Solaris fixed ** Build problems on Solaris fixed
** Build problems on Mingw fixed ** Build problems on HP-UX IA64 fixed
** Build problems on MinGW fixed
Changes in 1.8.1 (since 1.8.0): Changes in 1.8.1 (since 1.8.0):
@ -78,6 +100,8 @@ Changes in 1.8.1 (since 1.8.0):
** Build problems have been fixed on MacOS, SunOS, and QNX. ** Build problems have been fixed on MacOS, SunOS, and QNX.
** `strftime' fix sign of %z timezone offset.
** A one-dimensional array can now be 'equal?' to a vector. ** A one-dimensional array can now be 'equal?' to a vector.
** Structures, records, and SRFI-9 records can now be compared with `equal?'. ** Structures, records, and SRFI-9 records can now be compared with `equal?'.

23
THANKS
View file

@ -1,6 +1,7 @@
Contributors since the last release: Contributors since the last release:
Rob Browning Rob Browning
Ludovic Courtès
Stefan Jahn Stefan Jahn
Neil Jerram Neil Jerram
Antoine Mathys Antoine Mathys
@ -24,11 +25,11 @@ For fixes or providing information which led to a fix:
Adrian Bunk Adrian Bunk
Michael Carmack Michael Carmack
Stephen Compall Stephen Compall
Ludovic Courtès
Brian Crowder Brian Crowder
Christopher Cramer Christopher Cramer
Hyper Division Hyper Division
Alexandre Duret-Lutz Alexandre Duret-Lutz
Nils Durner
John W Eaton John W Eaton
Clinton Ebadi Clinton Ebadi
Charles Gagnon Charles Gagnon
@ -36,9 +37,11 @@ For fixes or providing information which led to a fix:
Eric Gillespie, Jr Eric Gillespie, Jr
John Goerzen John Goerzen
Mike Gran Mike Gran
Szavai Gyula
Sven Hartrumpf Sven Hartrumpf
Eric Hanchrow Eric Hanchrow
Sam Hocevar Sam Hocevar
Ales Hvezda
Peter Ivanyi Peter Ivanyi
Wolfgang Jaehrling Wolfgang Jaehrling
Aubrey Jaffer Aubrey Jaffer
@ -46,12 +49,15 @@ For fixes or providing information which led to a fix:
Steve Juranich Steve Juranich
Richard Kim Richard Kim
Bruce Korb Bruce Korb
Matthias Köppe Matthias Köppe
Matt Kraai Matt Kraai
Miroslav Lichvar Miroslav Lichvar
Jeff Long Jeff Long
Marco Maggi
Dan McMahill
Han-Wen Nienhuys Han-Wen Nienhuys
Jan Nieuwenhuizen Jan Nieuwenhuizen
Hrvoje Nikšić
Stefan Nordhausen Stefan Nordhausen
Roland Orre Roland Orre
Pieter Pareit Pieter Pareit
@ -62,21 +68,30 @@ For fixes or providing information which led to a fix:
Carlos Pita Carlos Pita
Ken Raeburn Ken Raeburn
Andreas Rottmann Andreas Rottmann
Kevin Ryde Hugh Sasse
Werner Scheinast Werner Scheinast
Bill Schottstaedt Bill Schottstaedt
Scott Shedden
Alex Shinn Alex Shinn
Daniel Skarda Daniel Skarda
Cesar Strauss
Richard Todd Richard Todd
Issac Trotts Issac Trotts
Greg Troxel Greg Troxel
Aaron M. Ucko
Momchil Velikov Momchil Velikov
Panagiotis Vossos Panagiotis Vossos
Neil W. Van Dyke Neil W. Van Dyke
Aaron VanDevender Aaron VanDevender
Andreas Vögele Andreas Vögele
Michael Talbot-Wilson Michael Talbot-Wilson
Michael Tuexen Michael Tuexen
Jon Wilson
Andy Wingo Andy Wingo
Keith Wright Keith Wright
William Xu William Xu
;; Local Variables:
;; coding: utf-8
;; End:

2
acinclude.m4
View file

@ -308,5 +308,3 @@ else
fi fi
AC_LANG_RESTORE AC_LANG_RESTORE
])dnl ACX_PTHREAD ])dnl ACX_PTHREAD
AC_DEFUN([AM_INTL_SUBDIR], [])

38
autogen.sh
View file

@ -1,5 +1,5 @@
#!/bin/sh #!/bin/sh
# Usage: sh -x ./autogen.sh [WORKBOOK] # Usage: sh -x ./autogen.sh
set -e set -e
@ -9,32 +9,16 @@ set -e
} }
###################################################################### ######################################################################
### Find workbook and make symlinks. ### announce build tool versions
echo ""
workbook=../workbook # assume "cvs co hack" autoconf --version
test x$1 = x || workbook=$1 echo ""
if [ ! -d $workbook ] ; then automake --version
echo "ERROR: could not find workbook dir" echo ""
echo " re-run like so: $0 WORKBOOK" libtool --version
exit 1 echo ""
fi ${M4:-/usr/bin/m4} --version
: found workbook at $workbook echo ""
workbook=`(cd $workbook ; pwd)`
workbookdistfiles="ANON-CVS HACKING SNAPSHOTS"
for f in $workbookdistfiles ; do
rm -f $f
ln -s $workbook/build/dist-files/$f $f
done
rm -f examples/example.gdbinit
ln -s $workbook/build/dist-files/.gdbinit examples/example.gdbinit
# TODO: This should be moved to dist-guile
mscripts=../guile-scripts
if test -x $mscripts/render-bugs ; then
rm -f BUGS
$mscripts/render-bugs > BUGS
fi
###################################################################### ######################################################################
### update infrastructure ### update infrastructure

36
configure.in
View file

@ -4,7 +4,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[ define(GUILE_CONFIGURE_COPYRIGHT,[[
Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
This file is part of GUILE This file is part of GUILE
@ -27,8 +27,15 @@ Boston, MA 02110-1301, USA.
AC_PREREQ(2.53) AC_PREREQ(2.53)
AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}), dnl `patsubst' here deletes the newline which "echo" prints. We can't use
m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}), dnl "echo -n" since -n is not portable (see autoconf manual "Limitations of
dnl Builtins"), in particular on solaris it results in a literal "-n" in
dnl the output.
dnl
AC_INIT(patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${PACKAGE}),[
]),
patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${GUILE_VERSION}),[
]),
[bug-guile@gnu.org]) [bug-guile@gnu.org])
AC_CONFIG_AUX_DIR([.]) AC_CONFIG_AUX_DIR([.])
AC_CONFIG_SRCDIR(GUILE-VERSION) AC_CONFIG_SRCDIR(GUILE-VERSION)
@ -218,6 +225,9 @@ AC_CHECK_LIB(uca, __uc_get_ar_bsp)
AC_C_CONST AC_C_CONST
# "volatile" is used in a couple of tests below.
AC_C_VOLATILE
AC_C_INLINE AC_C_INLINE
if test "$ac_cv_c_inline" != no; then if test "$ac_cv_c_inline" != no; then
SCM_I_GSC_C_INLINE="\"${ac_cv_c_inline}\"" SCM_I_GSC_C_INLINE="\"${ac_cv_c_inline}\""
@ -536,7 +546,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 \
direct.h langinfo.h nl_types.h]) strings.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
@ -628,7 +638,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 strcoll strcoll_l newlocale nl_langinfo]) 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])
# Reasons for testing: # Reasons for testing:
# netdb.h - not in mingw # netdb.h - not in mingw
@ -665,6 +675,8 @@ AC_SEARCH_LIBS(crypt, crypt,
# for the principal root. # for the principal root.
# #
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([
@ -957,17 +969,19 @@ AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos trunc)
# use <math.h> so doesn't detect on macro-only systems like HP-UX. # use <math.h> so doesn't detect on macro-only systems like HP-UX.
# #
AC_MSG_CHECKING([for isinf]) AC_MSG_CHECKING([for isinf])
AC_LINK_IFELSE( AC_LINK_IFELSE(AC_LANG_SOURCE(
[#include <math.h> [[#include <math.h>
int main () { return (isinf(0.0) != 0); }], volatile double x = 0.0;
int main () { return (isinf(x) != 0); }]]),
[AC_MSG_RESULT([yes]) [AC_MSG_RESULT([yes])
AC_DEFINE(HAVE_ISINF, 1, AC_DEFINE(HAVE_ISINF, 1,
[Define to 1 if you have the `isinf' macro or function.])], [Define to 1 if you have the `isinf' macro or function.])],
[AC_MSG_RESULT([no])]) [AC_MSG_RESULT([no])])
AC_MSG_CHECKING([for isnan]) AC_MSG_CHECKING([for isnan])
AC_LINK_IFELSE( AC_LINK_IFELSE(AC_LANG_SOURCE(
[#include <math.h> [[#include <math.h>
int main () { return (isnan(0.0) != 0); }], volatile double x = 0.0;
int main () { return (isnan(x) != 0); }]]),
[AC_MSG_RESULT([yes]) [AC_MSG_RESULT([yes])
AC_DEFINE(HAVE_ISNAN, 1, AC_DEFINE(HAVE_ISNAN, 1,
[Define to 1 if you have the `isnan' macro or function.])], [Define to 1 if you have the `isnan' macro or function.])],

60
doc/ref/ChangeLog
View file

@ -1,3 +1,58 @@
2007-07-18 Stephen Compall <s11@member.fsf.org>
* srfi-modules.texi: Describe SRFI-37 in a new subsection.
2007-07-10 Ludovic Courtès <ludo@gnu.org>
* api-data.texi (Arithmetic): Documented `1+' and `1-'.
Suggested by Jon Wilson <j85wilson@fastmail.fm>.
* api-modules.texi (Module System Reflection): Documented
`save-module-excursion', by Jon Wilson <jsw@wilsonjc.us>.
2007-06-07 Ludovic Courtès <ludovic.courtes@laas.fr>
* api-control.texi (Dynamic Wind): Fixed typo. Reported by
Norman Hardy.
2007-05-16 Ludovic Courtès <ludovic.courtes@laas.fr>
* posix.texi (Network Sockets and Communication): Fixed typo:
`make-socket-object' instead of `make-socket-address'.
2007-03-08 Kevin Ryde <user42@zip.com.au>
* api-compound.texi (Structures): Revise and expand variously, add
make-vtable.
* api-io.texi: Add various @cindex entries.
* slib.texi (SLIB): Shorten the bit about core funcs overridden.
Don't want to duplicate the SLIB specs, and the set of modified bits
is likely to change over time and don't want to have to keep up with
that.
2007-02-22 Kevin Ryde <user42@zip.com.au>
* posix.texi (Signals): Merge sleep and usleep, note usleep not
actually microsecond accurate, remove warning usleep not always
available (guile has own code for it now, it's not the system call).
Cross reference scm_std_sleep / scm_std_usleep.
* posix.texi (Signals): Merge getitimer and setitimer, describe what
each timer does, use @defvar to get them indexed, caution may not
actually be microsecond accurate.
2007-02-20 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (EXTRA_DIST): Add lib-version.texi to the
distribution.
2007-02-16 Kevin Ryde <user42@zip.com.au>
* api-compound.texi (Records): In make-record-type, describe optional
print function argument.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* api-data.texi (Conversion): Made cross refs point to `Number * api-data.texi (Conversion): Made cross refs point to `Number
@ -13,6 +68,11 @@
* srfi-modules.texi (SRFI-19 String to date): Mention the * srfi-modules.texi (SRFI-19 String to date): Mention the
internationalization of `string->date'. internationalization of `string->date'.
2007-01-25 Kevin Ryde <user42@zip.com.au>
* posix.texi (Signals): Note signal handlers run via system async and
can hence be delayed quite a while. Struck by William Xu.
2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org> 2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org>
* api-options.texi (Evaluator trap options): document * api-options.texi (Evaluator trap options): document

10
doc/ref/Makefile.am
View file

@ -23,7 +23,6 @@ AUTOMAKE_OPTIONS = gnu
BUILT_SOURCES = lib-version.texi BUILT_SOURCES = lib-version.texi
info_TEXINFOS = guile.texi info_TEXINFOS = guile.texi
guile_TEXINFOS = preface.texi \ guile_TEXINFOS = preface.texi \
@ -94,5 +93,12 @@ lib-version.texi: $(top_srcdir)/GUILE-VERSION
sed 's/^LIBGUILE_\([A-Z0-9_]*\)_MAJOR=\([0-9]\+\)/@set LIBGUILE_\1_MAJOR \2/' \ sed 's/^LIBGUILE_\([A-Z0-9_]*\)_MAJOR=\([0-9]\+\)/@set LIBGUILE_\1_MAJOR \2/' \
> "$@" > "$@"
MAINTAINERCLEANFILES = autoconf-macros.texi MAINTAINERCLEANFILES = autoconf-macros.texi
# To allow "make distcheck" to succeed, lib-version.texi must either
# be cleaned or be included in the distribution. There's no point
# forcing a distribution build to regenerate lib-version.texi, because
# it can't possibly be different on the build machine than where the
# distribution was generated, so we might as well include it in the
# distribution.
EXTRA_DIST = lib-version.texi

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

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006 @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -2611,14 +2611,22 @@ Note that @code{record?} may be true of any Scheme value; there is no
promise that records are disjoint with other Scheme types. promise that records are disjoint with other Scheme types.
@end deffn @end deffn
@deffn {Scheme Procedure} make-record-type type-name field-names @deffn {Scheme Procedure} make-record-type type-name field-names [print]
Return a @dfn{record-type descriptor}, a value representing a new data Create and return a new @dfn{record-type descriptor}.
type disjoint from all others. The @var{type-name} argument must be a
string, but is only used for debugging purposes (such as the printed @var{type-name} is a string naming the type. Currently it's only used
representation of a record of the new type). The @var{field-names} in the printed representation of records, and in diagnostics.
argument is a list of symbols naming the @dfn{fields} of a record of the @var{field-names} is a list of symbols naming the fields of a record
new type. It is an error if the list contains any duplicates. It is of the type. Duplicates are not allowed among these symbols.
unspecified how record-type descriptors are represented.
@example
(make-record-type "employee" '(name age salary))
@end example
The optional @var{print} argument is a function used by
@code{display}, @code{write}, etc, for printing a record of the new
type. It's called as @code{(@var{print} record port)} and should look
at @var{record} and write to @var{port}.
@end deffn @end deffn
@deffn {Scheme Procedure} record-constructor rtd [field-names] @deffn {Scheme Procedure} record-constructor rtd [field-names]
@ -2692,296 +2700,369 @@ created the type represented by @var{rtd}.
@subsection Structures @subsection Structures
@tpindex Structures @tpindex Structures
[FIXME: this is pasted in from Tom Lord's original guile.texi and should A @dfn{structure} is a first class data type which holds Scheme values
be reviewed] or C words in fields numbered 0 upwards. A @dfn{vtable} represents a
structure type, giving field types and permissions, and an optional
print function for @code{write} etc.
A @dfn{structure type} is a first class user-defined data type. A Structures are lower level than records (@pxref{Records}) but have
@dfn{structure} is an instance of a structure type. A structure type is some extra features. The vtable system allows sets of types be
itself a structure. constructed, with class data. The uninterpreted words can
inter-operate with C code, allowing arbitrary pointers or other values
Structures are less abstract and more general than traditional records. to be stored along side usual Scheme @code{SCM} values.
In fact, in Guile Scheme, records are implemented using structures.
@menu @menu
* Structure Concepts:: The structure of Structures * Vtables::
* Structure Layout:: Defining the layout of structure types * Structure Basics::
* Structure Basics:: make-, -ref and -set! procedures for structs * Vtable Contents::
* Vtables:: Accessing type-specific data * Vtable Vtables::
@end menu @end menu
@node Structure Concepts @node Vtables, Structure Basics, Structures, Structures
@subsubsection Structure Concepts @subsubsection Vtables
A structure object consists of a handle, structure data, and a vtable. A vtable is a structure type, specifying its layout, and other
The handle is a Scheme value which points to both the vtable and the information. A vtable is actually itself a structure, but there's no
structure's data. Structure data is a dynamically allocated region of need to worray about that initially (@pxref{Vtable Contents}.)
memory, private to the structure, divided up into typed fields. A
vtable is another structure used to hold type-specific data. Multiple
structures can share a common vtable.
When applied to structures, the @code{equal?} predicate @deffn {Scheme Procedure} make-vtable fields [print]
(@pxref{Equality}) returns @code{#t} if the two structures share a Create a new vtable.
common vtable @emph{and} all their fields satisfy @code{equal?}.
Three concepts are key to understanding structures. @var{fields} is a string describing the fields in the structures to be
created. Each field is represented by two characters, a type letter
and a permissions letter, for example @code{"pw"}. The types are as
follows.
@itemize @bullet{} @itemize @bullet{}
@item @dfn{layout specifications} @item
@code{p} -- a Scheme value. ``p'' stands for ``protected'' meaning
it's protected against garbage collection.
Layout specifications determine how memory allocated to structures is @item
divided up into fields. Programmers must write a layout specification @code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the
whenever a new type of structure is defined. Scheme level it's read and written as an unsigned integer. ``u''
stands for ``uninterpreted'' (it's not treated as a Scheme value), or
``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
size), or all of these things.
@item @dfn{structural accessors} @item
@code{s} -- a self-reference. Such a field holds the @code{SCM} value
Structure access is by field number. There is only one set of of the structure itself (a circular reference). This can be useful in
accessors common to all structure objects. C code where you might have a pointer to the data array, and want to
get the Scheme @code{SCM} handle for the structure. In Scheme code it
@item @dfn{vtables} has no use.
Vtables, themselves structures, are first class representations of
disjoint sub-types of structures in general. In most cases, when a
new structure is created, programmers must specify a vtable for the
new structure. Each vtable has a field describing the layout of its
instances. Vtables can have additional, user-defined fields as well.
@end itemize @end itemize
The second letter for each field is a permission code,
@node Structure Layout
@subsubsection Structure Layout
When a structure is created, a region of memory is allocated to hold its
state. The @dfn{layout} of the structure's type determines how that
memory is divided into fields.
Each field has a specified type. There are only three types allowed, each
corresponding to a one letter code. The allowed types are:
@itemize @bullet{} @itemize @bullet{}
@item 'u' -- unprotected @item
@code{w} -- writable, the field can be read and written.
The field holds binary data that is not GC protected. @item
@code{r} -- read-only, the field can be read but not written.
@item 'p' -- protected @item
@code{o} -- opaque, the field can be neither read nor written at the
The field holds a Scheme value and is GC protected. Scheme level. This can be used for fields which should only be used
from C code.
@item 's' -- self @item
@code{W},@code{R},@code{O} -- a tail array, with permissions for the
The field holds a Scheme value and is GC protected. When a structure is array fields as per @code{w},@code{r},@code{o}.
created with this type of field, the field is initialized to refer to
the structure's own handle. This kind of field is mainly useful when
mixing Scheme and C code in which the C code may need to compute a
structure's handle given only the address of its malloc'd data.
@end itemize @end itemize
A tail array is further fields at the end of a structure. The last
field in the layout string might be for instance @samp{pW} to have a
tail of writable Scheme-valued fields. The @samp{pW} field itself
holds the tail size, and the tail fields come after it.
Each field also has an associated access protection. There are only Here are some examples.
three kinds of protection, each corresponding to a one letter code.
The allowed protections are:
@itemize @bullet{}
@item 'w' -- writable
The field can be read and written.
@item 'r' -- readable
The field can be read, but not written.
@item 'o' -- opaque
The field can be neither read nor written. This kind
of protection is for fields useful only to built-in routines.
@end itemize
A layout specification is described by stringing together pairs
of letters: one to specify a field type and one to specify a field
protection. For example, a traditional cons pair type object could
be described as:
@example @example
; cons pairs have two writable fields of Scheme data (make-vtable "pw") ;; one writable field
"pwpw" (make-vtable "prpw") ;; one read-only and one writable
(make-vtable "pwuwuw") ;; one scheme and two uninterpreted
(make-vtable "prpW") ;; one fixed then a tail array
@end example @end example
A pair object in which the first field is held constant could be: The optional @var{print} argument is a function called by
@code{display} and @code{write} (etc) to give a printed representation
of a structure created from this vtable. It's called
@code{(@var{print} struct port)} and should look at @var{struct} and
write to @var{port}. The default print merely gives a form like
@samp{#<struct ADDR:ADDR>} with a pair of machine addresses.
The following print function for example shows the two fields of its
structure.
@example @example
"prpw" (make-vtable "prpw"
(lambda (struct port)
(display "#<")
(display (struct-ref 0))
(display " and ")
(display (struct-ref 1))
(display ">")))
@end example @end example
@end deffn
Binary fields, (fields of type "u"), hold one @dfn{word} each. The
size of a word is a machine dependent value defined to be equal to the
value of the C expression: @code{sizeof (long)}.
The last field of a structure layout may specify a tail array. @node Structure Basics, Vtable Contents, Vtables, Structures
A tail array is indicated by capitalizing the field's protection @subsubsection Structure Basics
code ('W', 'R' or 'O'). A tail-array field is replaced by
a read-only binary data field containing an array size. The array This section describes the basic procedures for working with
size is determined at the time the structure is created. It is followed structures. @code{make-struct} creates a structure, and
by a corresponding number of fields of the type specified for the @code{struct-ref} and @code{struct-set!} access write fields.
tail array. For example, a conventional Scheme vector can be
described as: @deffn {Scheme Procedure} make-struct vtable tail-size [init...]
@deffnx {C Function} scm_make_struct (vtable, tail_size, init_list)
Create a new structure, with layout per the given @var{vtable}
(@pxref{Vtables}).
@var{tail-size} is the size of the tail array if @var{vtable}
specifies a tail array. @var{tail-size} should be 0 when @var{vtable}
doesn't specify a tail array.
The optional @var{init}@dots{} arguments are initial values for the
fields of the structure (and the tail array). This is the only way to
put values in read-only fields. If there are fewer @var{init}
arguments than fields then the defaults are @code{#f} for a Scheme
field (type @code{p}) or 0 for an uninterpreted field (type @code{u}).
Type @code{s} self-reference fields, permission @code{o} opaque
fields, and the count field of a tail array are all ignored for the
@var{init} arguments, ie.@: an argument is not consumed by such a
field. An @code{s} is always set to the structure itself, an @code{o}
is always set to @code{#f} or 0 (with the intention that C code will
do something to it later), and the tail count is always the given
@var{tail-size}.
For example,
@example @example
; A vector is an arbitrary number of writable fields holding Scheme (define v (make-vtable "prpwpw"))
; values: (define s (make-struct v 0 123 "abc" 456))
"pW" (struct-ref s 0) @result{} 123
(struct-ref s 1) @result{} "abc"
@end example @end example
In the above example, field 0 contains the size of the vector and
fields beginning at 1 contain the vector elements.
A kind of tagged vector (a constant tag followed by conventional
vector elements) might be:
@example @example
"prpW" (define v (make-vtable "prpW"))
(define s (make-struct v 6 "fixed field" 'x 'y))
(struct-ref s 0) @result{} "fixed field"
(struct-ref s 1) @result{} 2 ;; tail size
(struct-ref s 2) @result{} x ;; tail array ...
(struct-ref s 3) @result{} y
(struct-ref s 4) @result{} #f
@end example
@end deffn
@deffn {Scheme Procedure} struct? obj
@deffnx {C Function} scm_struct_p (obj)
Return @code{#t} if @var{obj} is a structure, or @code{#f} if not.
@end deffn
@deffn {Scheme Procedure} struct-ref struct n
@deffnx {C Function} scm_struct_ref (struct, n)
Return the contents of field number @var{n} in @var{struct}. The
first field is number 0.
An error is thrown if @var{n} is out of range, or if the field cannot
be read because it's @code{o} opaque.
@end deffn
@deffn {Scheme Procedure} struct-set! struct n value
@deffnx {C Function} scm_struct_set_x (struct, n, value)
Set field number @var{n} in @var{struct} to @var{value}. The first
field is number 0.
An error is thrown if @var{n} is out of range, or if the field cannot
be written because it's @code{r} read-only or @code{o} opaque.
@end deffn
@deffn {Scheme Procedure} struct-vtable struct
@deffnx {C Function} scm_struct_vtable (struct)
Return the vtable used by @var{struct}.
This can be used to examine the layout of an unknown structure, see
@ref{Vtable Contents}.
@end deffn
@node Vtable Contents, Vtable Vtables, Structure Basics, Structures
@subsubsection Vtable Contents
A vtable is itself a structure, with particular fields that hold
information about the structures to be created. These include the
fields of those structures, and the print function for them. The
variables below allow access to those fields.
@deffn {Scheme Procedure} struct-vtable? obj
@deffnx {C Function} scm_struct_vtable_p (obj)
Return @code{#t} if @var{obj} is a vtable structure.
Note that because vtables are simply structures with a particular
layout, @code{struct-vtable?} can potentially return true on an
application structure which merely happens to look like a vtable.
@end deffn
@defvr {Scheme Variable} vtable-index-layout
@defvrx {C Macro} scm_vtable_index_layout
The field number of the layout specification in a vtable. The layout
specification is a symbol like @code{pwpw} formed from the fields
string passed to @code{make-vtable}, or created by
@code{make-struct-layout} (@pxref{Vtable Vtables}).
@example
(define v (make-vtable "pwpw" 0))
(struct-ref v vtable-index-layout) @result{} pwpw
@end example @end example
This field is read-only, since the layout of structures using a vtable
cannot be changed.
@end defvr
Structure layouts are represented by specially interned symbols whose @defvr {Scheme Variable} vtable-index-vtable
name is a string of type and protection codes. To create a new @defvrx {C Macro} scm_vtable_index_vtable
structure layout, use this procedure: A self-reference to the vtable, ie.@: a type @code{s} field. This is
used by C code within Guile and has no use at the Scheme level.
@end defvr
@defvr {Scheme Variable} vtable-index-printer
@defvrx {C Macro} scm_vtable_index_printer
The field number of the printer function. This field contains @code{#f}
if the default print function should be used.
@example
(define (my-print-func struct port)
...)
(define v (make-vtable "pwpw" my-print-func))
(struct-ref v vtable-index-printer) @result{} my-print-func
@end example
This field is writable, allowing the print function to be changed
dynamically.
@end defvr
@deffn {Scheme Procedure} struct-vtable-name vtable
@deffnx {Scheme Procedure} set-struct-vtable-name! vtable name
@deffnx {C Function} scm_struct_vtable_name (vtable)
@deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name)
Get or set the name of @var{vtable}. @var{name} is a symbol and is
used in the default print function when printing structures created
from @var{vtable}.
@example
(define v (make-vtable "pw"))
(set-struct-vtable-name! v 'my-name)
(define s (make-struct v 0))
(display s) @print{} #<my-name b7ab3ae0:b7ab3730>
@end example
@end deffn
@deffn {Scheme Procedure} struct-vtable-tag vtable
@deffnx {C Function} scm_struct_vtable_tag (vtable)
Return the tag of the given @var{vtable}.
@c
@c FIXME: what can be said about what this means?
@c
@end deffn
@node Vtable Vtables, , Vtable Contents, Structures
@subsubsection Vtable Vtables
As noted above, a vtable is a structure and that structure is itself
described by a vtable. Such a ``vtable of a vtable'' can be created
with @code{make-vtable-vtable} below. This can be used to build sets
of related vtables, possibly with extra application fields.
This second level of vtable can be a little confusing. The ball
example below is a typical use, adding a ``class data'' field to the
vtables, from which instance structures are created. The current
implementation of Guile's own records (@pxref{Records}) does something
similar, a record type descriptor is a vtable with room to hold the
field names of the records to be created from it.
@deffn {Scheme Procedure} make-vtable-vtable user-fields tail-size [print]
@deffnx {C Function} scm_make_vtable_vtable (user_fields, tail_size, print_and_init_list)
Create a ``vtable-vtable'' which can be used to create vtables. This
vtable-vtable is also a vtable, and is self-describing, meaning its
vtable is itself. The following is a simple usage.
@example
(define vt-vt (make-vtable-vtable "" 0))
(define vt (make-struct vt-vt 0
(make-struct-layout "pwpw"))
(define s (make-struct vt 0 123 456))
(struct-ref s 0) @result{} 123
@end example
@code{make-struct} is used to create a vtable from the vtable-vtable.
The first initializer is a layout object (field
@code{vtable-index-layout}), usually obtained from
@code{make-struct-layout} (below). An optional second initializer is
a printer function (field @code{vtable-index-printer}), used as
described under @code{make-vtable} (@pxref{Vtables}).
@sp 1
@var{user-fields} is a layout string giving extra fields to have in
the vtables. A vtable starts with some base fields as per @ref{Vtable
Contents}, and @var{user-fields} is appended. The @var{user-fields}
start at field number @code{vtable-offset-user} (below), and exist in
both the vtable-vtable and in the vtables created from it. Such
fields provide space for ``class data''. For example,
@example
(define vt-of-vt (make-vtable-vtable "pw" 0))
(define vt (make-struct vt-of-vt 0))
(struct-set! vt vtable-offset-user "my class data")
@end example
@var{tail-size} is the size of the tail array in the vtable-vtable
itself, if @var{user-fields} specifies a tail array. This should be 0
if nothing extra is required or the format has no tail array. The
tail array field such as @samp{pW} holds the tail array size, as
usual, and is followed by the extra space.
@example
(define vt-vt (make-vtable-vtable "pW" 20))
(define my-vt-tail-start (1+ vtable-offset-user))
(struct-set! vt-vt (+ 3 my-vt-tail-start) "data in tail")
@end example
The optional @var{print} argument is used by @code{display} and
@code{write} (etc) to print the vtable-vtable and any vtables created
from it. It's called as @code{(@var{print} vtable port)} and should
look at @var{vtable} and write to @var{port}. The default is the
usual structure print function, which just gives machine addresses.
@end deffn
@deffn {Scheme Procedure} make-struct-layout fields @deffn {Scheme Procedure} make-struct-layout fields
@deffnx {C Function} scm_make_struct_layout (fields) @deffnx {C Function} scm_make_struct_layout (fields)
Return a new structure layout object. Return a structure layout symbol, from a @var{fields} string.
@var{fields} is as described under @code{make-vtable}
(@pxref{Vtables}). An invalid @var{fields} string is an error.
@var{fields} must be a string made up of pairs of characters @example
strung together. The first character of each pair describes a field (make-struct-layout "prpW") @result{} prpW
type, the second a field protection. Allowed types are 'p' for (make-struct-layout "blah") @result{} ERROR
GC-protected Scheme data, 'u' for unprotected binary data, and 's' for @end example
a field that points to the structure itself. Allowed protections
are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque
fields. The last field protection specification may be capitalized to
indicate that the field is a tail-array.
@end deffn @end deffn
@defvr {Scheme Variable} vtable-offset-user
@defvrx {C Macro} scm_vtable_offset_user
The first field in a vtable which is available for application use.
Such fields only exist when specified by @var{user-fields} in
@code{make-vtable-vtable} above.
@end defvr
@sp 1
@node Structure Basics Here's an extended vtable-vtable example, creating classes of
@subsubsection Structure Basics ``balls''. Each class has a ``colour'', which is fixed. Instances of
those classes are created, and such each such ball has an ``owner'',
This section describes the basic procedures for creating and accessing which can be changed.
structures.
@deffn {Scheme Procedure} make-struct vtable tail_array_size . init
@deffnx {C Function} scm_make_struct (vtable, tail_array_size, init)
Create a new structure.
@var{type} must be a vtable structure (@pxref{Vtables}).
@var{tail-elts} must be a non-negative integer. If the layout
specification indicated by @var{type} includes a tail-array,
this is the number of elements allocated to that array.
The @var{init1}, @dots{} are optional arguments describing how
successive fields of the structure should be initialized. Only fields
with protection 'r' or 'w' can be initialized, except for fields of
type 's', which are automatically initialized to point to the new
structure itself; fields with protection 'o' can not be initialized by
Scheme programs.
If fewer optional arguments than initializable fields are supplied,
fields of type 'p' get default value #f while fields of type 'u' are
initialized to 0.
Structs are currently the basic representation for record-like data
structures in Guile. The plan is to eventually replace them with a
new representation which will at the same time be easier to use and
more powerful.
For more information, see the documentation for @code{make-vtable-vtable}.
@end deffn
@deffn {Scheme Procedure} struct? x
@deffnx {C Function} scm_struct_p (x)
Return @code{#t} iff @var{x} is a structure object, else
@code{#f}.
@end deffn
@deffn {Scheme Procedure} struct-ref handle pos
@deffnx {Scheme Procedure} struct-set! struct n value
@deffnx {C Function} scm_struct_ref (handle, pos)
@deffnx {C Function} scm_struct_set_x (struct, n, value)
Access (or modify) the @var{n}th field of @var{struct}.
If the field is of type 'p', then it can be set to an arbitrary value.
If the field is of type 'u', then it can only be set to a non-negative
integer value small enough to fit in one machine word.
@end deffn
@node Vtables
@subsubsection Vtables
Vtables are structures that are used to represent structure types. Each
vtable contains a layout specification in field
@code{vtable-index-layout} -- instances of the type are laid out
according to that specification. Vtables contain additional fields
which are used only internally to libguile. The variable
@code{vtable-offset-user} is bound to a field number. Vtable fields
at that position or greater are user definable.
@deffn {Scheme Procedure} struct-vtable handle
@deffnx {C Function} scm_struct_vtable (handle)
Return the vtable structure that describes the type of @var{struct}.
@end deffn
@deffn {Scheme Procedure} struct-vtable? x
@deffnx {C Function} scm_struct_vtable_p (x)
Return @code{#t} iff @var{x} is a vtable structure.
@end deffn
If you have a vtable structure, @code{V}, you can create an instance of
the type it describes by using @code{(make-struct V ...)}. But where
does @code{V} itself come from? One possibility is that @code{V} is an
instance of a user-defined vtable type, @code{V'}, so that @code{V} is
created by using @code{(make-struct V' ...)}. Another possibility is
that @code{V} is an instance of the type it itself describes. Vtable
structures of the second sort are created by this procedure:
@deffn {Scheme Procedure} make-vtable-vtable user_fields tail_array_size . init
@deffnx {C Function} scm_make_vtable_vtable (user_fields, tail_array_size, init)
Return a new, self-describing vtable structure.
@var{user-fields} is a string describing user defined fields of the
vtable beginning at index @code{vtable-offset-user}
(see @code{make-struct-layout}).
@var{tail-size} specifies the size of the tail-array (if any) of
this vtable.
@var{init1}, @dots{} are the optional initializers for the fields of
the vtable.
Vtables have one initializable system field---the struct printer.
This field comes before the user fields in the initializers passed
to @code{make-vtable-vtable} and @code{make-struct}, and thus works as
a third optional argument to @code{make-vtable-vtable} and a fourth to
@code{make-struct} when creating vtables:
If the value is a procedure, it will be called instead of the standard
printer whenever a struct described by this vtable is printed.
The procedure will be called with arguments STRUCT and PORT.
The structure of a struct is described by a vtable, so the vtable is
in essence the type of the struct. The vtable is itself a struct with
a vtable. This could go on forever if it weren't for the
vtable-vtables which are self-describing vtables, and thus terminate
the chain.
There are several potential ways of using structs, but the standard
one is to use three kinds of structs, together building up a type
sub-system: one vtable-vtable working as the root and one or several
"types", each with a set of "instances". (The vtable-vtable should be
compared to the class <class> which is the class of itself.)
@lisp @lisp
(define ball-root (make-vtable-vtable "pr" 0)) (define ball-root (make-vtable-vtable "pr" 0))
@ -3005,22 +3086,6 @@ compared to the class <class> which is the class of itself.)
(define ball (make-ball green 'Nisse)) (define ball (make-ball green 'Nisse))
ball @result{} #<a green ball owned by Nisse> ball @result{} #<a green ball owned by Nisse>
@end lisp @end lisp
@end deffn
@deffn {Scheme Procedure} struct-vtable-name vtable
@deffnx {C Function} scm_struct_vtable_name (vtable)
Return the name of the vtable @var{vtable}.
@end deffn
@deffn {Scheme Procedure} set-struct-vtable-name! vtable name
@deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name)
Set the name of the vtable @var{vtable} to @var{name}.
@end deffn
@deffn {Scheme Procedure} struct-vtable-tag handle
@deffnx {C Function} scm_struct_vtable_tag (handle)
Return the vtable tag of the structure @var{handle}.
@end deffn
@node Dictionary Types @node Dictionary Types

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

@ -1164,7 +1164,7 @@ lexical variables, this will be, well, inconvenient.
Therefore, Guile offers the functions @code{scm_dynwind_begin} and Therefore, Guile offers the functions @code{scm_dynwind_begin} and
@code{scm_dynwind_end} to delimit a dynamic extent. Within this @code{scm_dynwind_end} to delimit a dynamic extent. Within this
dynamic extent, which is calles a @dfn{dynwind context}, you can dynamic extent, which is called a @dfn{dynwind context}, you can
perform various @dfn{dynwind actions} that control what happens when perform various @dfn{dynwind actions} that control what happens when
the dynwind context is entered or left. For example, you can register the dynwind context is entered or left. For example, you can register
a cleanup routine with @code{scm_dynwind_unwind_handler} that is a cleanup routine with @code{scm_dynwind_unwind_handler} that is

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

@ -1117,6 +1117,8 @@ Returns the magnitude or angle of @var{z} as a @code{double}.
@rnindex * @rnindex *
@rnindex - @rnindex -
@rnindex / @rnindex /
@findex 1+
@findex 1-
@rnindex abs @rnindex abs
@rnindex floor @rnindex floor
@rnindex ceiling @rnindex ceiling
@ -1158,6 +1160,16 @@ Divide the first argument by the product of the remaining arguments. If
called with one argument @var{z1}, 1/@var{z1} is returned. called with one argument @var{z1}, 1/@var{z1} is returned.
@end deffn @end deffn
@deffn {Scheme Procedure} 1+ z
@deffnx {C Function} scm_oneplus (z)
Return @math{@var{z} + 1}.
@end deffn
@deffn {Scheme Procedure} 1- z
@deffnx {C function} scm_oneminus (z)
Return @math{@var{z} - 1}.
@end deffn
@c begin (texi-doc-string "guile" "abs") @c begin (texi-doc-string "guile" "abs")
@deffn {Scheme Procedure} abs x @deffn {Scheme Procedure} abs x
@deffnx {C Function} scm_abs (x) @deffnx {C Function} scm_abs (x)

29
doc/ref/api-io.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -24,6 +24,7 @@
@node Ports @node Ports
@subsection Ports @subsection Ports
@cindex Port
Sequential input/output in Scheme is represented by operations on a Sequential input/output in Scheme is represented by operations on a
@dfn{port}. This chapter explains the operations that Guile provides @dfn{port}. This chapter explains the operations that Guile provides
@ -94,10 +95,12 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port?
@node Reading @node Reading
@subsection Reading @subsection Reading
@cindex Reading
[Generic procedures for reading from ports.] [Generic procedures for reading from ports.]
@rnindex eof-object? @rnindex eof-object?
@cindex End of file object
@deffn {Scheme Procedure} eof-object? x @deffn {Scheme Procedure} eof-object? x
@deffnx {C Function} scm_eof_object_p (x) @deffnx {C Function} scm_eof_object_p (x)
Return @code{#t} if @var{x} is an end-of-file object; otherwise Return @code{#t} if @var{x} is an end-of-file object; otherwise
@ -217,6 +220,7 @@ Set the current column or line number of @var{port}.
@node Writing @node Writing
@subsection Writing @subsection Writing
@cindex Writing
[Generic procedures for writing to ports.] [Generic procedures for writing to ports.]
@ -320,6 +324,8 @@ all open output ports. The return value is unspecified.
@node Closing @node Closing
@subsection Closing @subsection Closing
@cindex Closing ports
@cindex Port, close
@deffn {Scheme Procedure} close-port port @deffn {Scheme Procedure} close-port port
@deffnx {C Function} scm_close_port (port) @deffnx {C Function} scm_close_port (port)
@ -354,6 +360,8 @@ open.
@node Random Access @node Random Access
@subsection Random Access @subsection Random Access
@cindex Random access, ports
@cindex Port, random access
@deffn {Scheme Procedure} seek fd_port offset whence @deffn {Scheme Procedure} seek fd_port offset whence
@deffnx {C Function} scm_seek (fd_port, offset, whence) @deffnx {C Function} scm_seek (fd_port, offset, whence)
@ -410,6 +418,8 @@ the current size, but this is not mandatory in the POSIX standard.
@node Line/Delimited @node Line/Delimited
@subsection Line Oriented and Delimited Text @subsection Line Oriented and Delimited Text
@cindex Line input/output
@cindex Port, line input/output
The delimited-I/O module can be accessed with: The delimited-I/O module can be accessed with:
@ -520,6 +530,8 @@ delimiter may be either a newline or the @var{eof-object}; if
@node Block Reading and Writing @node Block Reading and Writing
@subsection Block reading and writing @subsection Block reading and writing
@cindex Block read/write
@cindex Port, block read/write
The Block-string-I/O module can be accessed with: The Block-string-I/O module can be accessed with:
@ -618,6 +630,8 @@ return 0 immediately if the request size is 0 bytes.
@node Default Ports @node Default Ports
@subsection Default Ports for Input, Output and Errors @subsection Default Ports for Input, Output and Errors
@cindex Default ports
@cindex Port, default
@rnindex current-input-port @rnindex current-input-port
@deffn {Scheme Procedure} current-input-port @deffn {Scheme Procedure} current-input-port
@ -693,6 +707,8 @@ initialized with the @var{port} argument.
@node Port Types @node Port Types
@subsection Types of Port @subsection Types of Port
@cindex Types of ports
@cindex Port, types
[Types of port; how to make them.] [Types of port; how to make them.]
@ -706,6 +722,8 @@ initialized with the @var{port} argument.
@node File Ports @node File Ports
@subsubsection File Ports @subsubsection File Ports
@cindex File port
@cindex Port, file
The following procedures are used to open file ports. The following procedures are used to open file ports.
See also @ref{Ports and File Descriptors, open}, for an interface See also @ref{Ports and File Descriptors, open}, for an interface
@ -866,6 +884,8 @@ Determine whether @var{obj} is a port that is related to a file.
@node String Ports @node String Ports
@subsubsection String Ports @subsubsection String Ports
@cindex String port
@cindex Port, string
The following allow string ports to be opened by analogy to R4R* The following allow string ports to be opened by analogy to R4R*
file port facilities: file port facilities:
@ -931,6 +951,8 @@ but trying to extract the file descriptor number will fail.
@node Soft Ports @node Soft Ports
@subsubsection Soft Ports @subsubsection Soft Ports
@cindex Soft port
@cindex Port, soft
A @dfn{soft-port} is a port based on a vector of procedures capable of A @dfn{soft-port} is a port based on a vector of procedures capable of
accepting or delivering characters. It allows emulation of I/O ports. accepting or delivering characters. It allows emulation of I/O ports.
@ -986,6 +1008,8 @@ For example:
@node Void Ports @node Void Ports
@subsubsection Void Ports @subsubsection Void Ports
@cindex Void port
@cindex Port, void
This kind of port causes any data to be discarded when written to, and This kind of port causes any data to be discarded when written to, and
always returns the end-of-file object when read from. always returns the end-of-file object when read from.
@ -1010,6 +1034,8 @@ documentation for @code{open-file} in @ref{File Ports}.
@node C Port Interface @node C Port Interface
@subsubsection C Port Interface @subsubsection C Port Interface
@cindex C port interface
@cindex Port, C interface
This section describes how to use Scheme ports from C. This section describes how to use Scheme ports from C.
@ -1119,6 +1145,7 @@ is set.
@node Port Implementation @node Port Implementation
@subsubsection Port Implementation @subsubsection Port Implementation
@cindex Port implemenation
This section describes how to implement a new port type in C. This section describes how to implement a new port type in C.

14
doc/ref/api-modules.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -602,6 +602,18 @@ Set the current module to @var{module} and return
the previous current module. the previous current module.
@end deffn @end deffn
@deffn {Scheme Procedure} save-module-excursion thunk
Call @var{thunk} within a @code{dynamic-wind} such that the module that
is current at invocation time is restored when @var{thunk}'s dynamic
extent is left (@pxref{Dynamic Wind}).
More precisely, if @var{thunk} escapes non-locally, the current module
(at the time of escape) is saved, and the original current module (at
the time @var{thunk}'s dynamic extent was last entered) is restored. If
@var{thunk}'s dynamic extent is re-entered, then the current module is
saved, and the previously saved inner module is set current again.
@end deffn
@deffn {Scheme Procedure} resolve-module name @deffn {Scheme Procedure} resolve-module name
Find the module named @var{name} and return it. When it has not already Find the module named @var{name} and return it. When it has not already
been defined, try to auto-load it. When it can't be found that way been defined, try to auto-load it. When it can't be found that way

109
doc/ref/posix.texi
View file

@ -1388,17 +1388,17 @@ and @code{command-line} above.
@var{argv} is an array of null-terminated strings, as in a C @var{argv} is an array of null-terminated strings, as in a C
@code{main} function. @var{argc} is the number of strings in @code{main} function. @var{argc} is the number of strings in
@var{argv}, or if it's negative then a @code{NULL} entry in @var{argv} @var{argv}, or if it's negative then a @code{NULL} in @var{argv} marks
marks its end. its end.
@var{first} is an extra string put at the start of the arguments, or @var{first} is an extra string put at the start of the arguments, or
@code{NULL} for no such extra. This is a convenient way to pass the @code{NULL} for no such extra. This is a convenient way to pass the
program name after advancing @var{argv} to strip option arguments. program name after advancing @var{argv} to strip option arguments.
Eg.@:
@example @example
@{ @{
char *progname = argv[0]; char *progname = argv[0];
int i;
for (argv++; argv[0] != NULL && argv[0][0] == '-'; argv++) for (argv++; argv[0] != NULL && argv[0][0] == '-'; argv++)
@{ @{
/* munch option ... */ /* munch option ... */
@ -1409,7 +1409,7 @@ program name after advancing @var{argv} to strip option arguments.
@end example @end example
This sort of thing is often done at startup under This sort of thing is often done at startup under
@code{scm_boot_guile} with any options handled at the C level removed. @code{scm_boot_guile} with options handled at the C level removed.
The given strings are all copied, so the C data is not accessed again The given strings are all copied, so the C data is not accessed again
once @code{scm_set_program_arguments} returns. once @code{scm_set_program_arguments} returns.
@end deftypefn @end deftypefn
@ -1836,7 +1836,13 @@ specified processes.
@subsection Signals @subsection Signals
@cindex signal @cindex signal
Procedures to raise, handle and wait for signals. The following procedures raise, handle and wait for signals.
Scheme code signal handlers are run via a system async (@pxref{System
asyncs}), so they're called in the handler's thread at the next safe
opportunity. Generally this is after any currently executing
primitive procedure finishes (which could be a long time for
primitives that wait for an external event).
@deffn {Scheme Procedure} kill pid sig @deffn {Scheme Procedure} kill pid sig
@deffnx {C Function} scm_kill (pid, sig) @deffnx {C Function} scm_kill (pid, sig)
@ -1961,47 +1967,72 @@ action is to either terminate the current process or invoke a
handler procedure. The return value is unspecified. handler procedure. The return value is unspecified.
@end deffn @end deffn
@deffn {Scheme Procedure} sleep i @deffn {Scheme Procedure} sleep secs
@deffnx {C Function} scm_sleep (i) @deffnx {Scheme Procedure} usleep usecs
Wait for the given number of seconds (an integer) or until a signal @deffnx {C Function} scm_sleep (secs)
arrives. The return value is zero if the time elapses or the number @deffnx {C Function} scm_usleep (usecs)
of seconds remaining otherwise. Wait the given period @var{secs} seconds or @var{usecs} microseconds
@end deffn (both integers). If a signal arrives the wait stops and the return
value is the time remaining, in seconds or microseconds respectively.
If the period elapses with no signal the return is zero.
@deffn {Scheme Procedure} usleep i On most systems the process scheduler is not microsecond accurate and
@deffnx {C Function} scm_usleep (i) the actual period slept by @code{usleep} might be rounded to a system
Sleep for @var{i} microseconds. @code{usleep} is not available on clock tick boundary, which might be 10 milliseconds for instance.
all platforms. [FIXME: so what happens when it isn't?]
@end deffn
@deffn {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds value_seconds value_microseconds See @code{scm_std_sleep} and @code{scm_std_usleep} for equivalents at
@deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, value_seconds, value_microseconds) the C level (@pxref{Blocking}).
Set the timer specified by @var{which_timer} according to the given
@var{interval_seconds}, @var{interval_microseconds},
@var{value_seconds}, and @var{value_microseconds} values.
Return information about the timer's previous setting.
The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},
and @code{ITIMER_PROF}.
The return value will be a list of two cons pairs representing the
current state of the given timer. The first pair is the seconds and
microseconds of the timer @code{it_interval}, and the second pair is
the seconds and microseconds of the timer @code{it_value}.
@end deffn @end deffn
@deffn {Scheme Procedure} getitimer which_timer @deffn {Scheme Procedure} getitimer which_timer
@deffnx {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds periodic_seconds periodic_microseconds
@deffnx {C Function} scm_getitimer (which_timer) @deffnx {C Function} scm_getitimer (which_timer)
Return information about the timer specified by @var{which_timer}. @deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, periodic_seconds, periodic_microseconds)
Get or set the periods programmed in certain system timers. These
timers have a current interval value which counts down and on reaching
zero raises a signal. An optional periodic value can be set to
restart from there each time, for periodic operation.
@var{which_timer} is one of the following values
The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL}, @defvar ITIMER_REAL
and @code{ITIMER_PROF}. A real-time timer, counting down elapsed real time. At zero it raises
@code{SIGALRM}. This is like @code{alarm} above, but with a higher
resolution period.
@end defvar
The return value will be a list of two cons pairs representing the @defvar ITIMER_VIRTUAL
current state of the given timer. The first pair is the seconds and A virtual-time timer, counting down while the current process is
microseconds of the timer @code{it_interval}, and the second pair is actually using CPU. At zero it raises @code{SIGVTALRM}.
the seconds and microseconds of the timer @code{it_value}. @end defvar
@defvar ITIMER_PROF
A profiling timer, counting down while the process is running (like
@code{ITIMER_VIRTUAL}) and also while system calls are running on the
process's behalf. At zero it raises a @code{SIGPROF}.
This timer is intended for profiling where a program is spending its
time (by looking where it is when the timer goes off).
@end defvar
@code{getitimer} returns the current timer value and its programmed
restart value, as a list containing two pairs. Each pair is a time in
seconds and microseconds: @code{((@var{interval_secs}
. @var{interval_usecs}) (@var{periodic_secs}
. @var{periodic_usecs}))}.
@code{setitimer} sets the timer values similarly, in seconds and
microseconds (which must be integers). The periodic value can be zero
to have the timer run down just once. The return value is the timer's
previous setting, in the same form as @code{getitimer} returns.
@example
(setitimer ITIMER_REAL
5 500000 ;; first SIGALRM in 5.5 seconds time
2 0) ;; then repeat every 2 seconds
@end example
Although the timers are programmed in microseconds, the actual
accuracy might not be that high.
@end deffn @end deffn
@ -2872,7 +2903,7 @@ automatically, if not already bound.
@example @example
(bind sock AF_INET INADDR_ANY 12345) (bind sock AF_INET INADDR_ANY 12345)
(bind sock (make-socket-object AF_INET INADDR_ANY 12345)) (bind sock (make-socket-address AF_INET INADDR_ANY 12345))
@end example @end example
@end deffn @end deffn

42
doc/ref/slib.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -27,41 +27,11 @@ slib, The SLIB Manual}). For example,
@result{} #t @result{} #t
@end example @end example
Note that the following Guile core functions are overridden by A few Guile core functions are overridden by the SLIB setups; for
@code{(ice-9 slib)}, to implement SLIB specified semantics. example the SLIB version of @code{delete-file} returns a boolean
indicating success or failure, whereas the Guile core version throws
@table @code an error for failure. In general (and as might be expected) when SLIB
@item delete-file is loaded it's the SLIB specifications which are followed.
@findex delete-file
Returns @code{#t} for success or @code{#f} for failure
(@pxref{Input/Output,,, slib, The SLIB Manual}), as opposed to the
Guile core version unspecified for success and throwing an error for
failure (@pxref{File System}).
@c `provide' is also exported by ice-9 slib, but its definition in
@c slib require.scm is the same as guile boot-9.scm, so believe
@c nothing needs to be said about that.
@item provided?
@findex provided?
Accepts a feature specification containing @code{and} and @code{or}
forms combining symbols (@pxref{Feature,,, slib, The SLIB Manual}), as
opposed to the Guile core taking only plain symbols (@pxref{Feature
Manipulation}).
@item open-file
@findex open-file
Takes a symbol @code{r}, @code{rb}, @code{w} or @code{wb} for the open
mode (@pxref{Input/Output,,, slib, The SLIB Manual}), as opposed to
the Guile core version taking a string (@pxref{File Ports}).
@item system
@findex system
Returns a plain exit code 0 to 255 (@pxref{System Interface,,, slib,
The SLIB Manual}), as opposed to the Guile core version returning a
wait status that must be examined with @code{status:exit-val} etc
(@pxref{Processes}).
@end table
@menu @menu
* SLIB installation:: * SLIB installation::

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

@ -37,6 +37,7 @@ 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-37:: args-fold program argument processor
* SRFI-39:: Parameter objects * SRFI-39:: Parameter objects
* SRFI-55:: Requiring Features. * SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits. * SRFI-60:: Integers as bits.
@ -2401,6 +2402,93 @@ The second syntax can be used to create anonymous recursive functions:
@end lisp @end lisp
@node SRFI-37
@subsection SRFI-37 - args-fold
@cindex SRFI-37
This is a processor for GNU @code{getopt_long}-style program
arguments. It provides an alternative, less declarative interface
than @code{getopt-long} in @code{(ice-9 getopt-long)}
(@pxref{getopt-long,,The (ice-9 getopt-long) Module}). Unlike
@code{getopt-long}, it supports repeated options and any number of
short and long names per option. Access it with:
@lisp
(use-modules (srfi srfi-37))
@end lisp
@acronym{SRFI}-37 principally provides an @code{option} type and the
@code{args-fold} function. To use the library, create a set of
options with @code{option} and use it as a specification for invoking
@code{args-fold}.
Here is an example of a simple argument processor for the typical
@samp{--version} and @samp{--help} options, which returns a backwards
list of files given on the command line:
@lisp
(args-fold (cdr (program-arguments))
(let ((display-and-exit-proc
(lambda (msg)
(lambda (opt name arg loads)
(display msg) (quit)))))
(list (option '(#\v "version") #f #f
(display-and-exit-proc "Foo version 42.0\n"))
(option '(#\h "help") #f #f
(display-and-exit-proc
"Usage: foo scheme-file ..."))))
(lambda (opt name arg loads)
(error "Unrecognized option `~A'" name))
(lambda (op loads) (cons op loads))
'())
@end lisp
@deffn {Scheme Procedure} option names required-arg? optional-arg? processor
Return an object that specifies a single kind of program option.
@var{names} is a list of command-line option names, and should consist of
characters for traditional @code{getopt} short options and strings for
@code{getopt_long}-style long options.
@var{required-arg?} and @var{optional-arg?} are mutually exclusive;
one or both must be @code{#f}. If @var{required-arg?}, the option
must be followed by an argument on the command line, such as
@samp{--opt=value} for long options, or an error will be signalled.
If @var{optional-arg?}, an argument will be taken if available.
@var{processor} is a procedure that takes at least 3 arguments, called
when @code{args-fold} encounters the option: the containing option
object, the name used on the command line, and the argument given for
the option (or @code{#f} if none). The rest of the arguments are
@code{args-fold} ``seeds'', and the @var{processor} should return
seeds as well.
@end deffn
@deffn {Scheme Procedure} option-names opt
@deffnx {Scheme Procedure} option-required-arg? opt
@deffnx {Scheme Procedure} option-optional-arg? opt
@deffnx {Scheme Procedure} option-processor opt
Return the specified field of @var{opt}, an option object, as
described above for @code{option}.
@end deffn
@deffn {Scheme Procedure} args-fold args options unrecognized-option-proc operand-proc seeds @dots{}
Process @var{args}, a list of program arguments such as that returned
by @code{(cdr (program-arguments))}, in order against @var{options}, a
list of option objects as described above. All functions called take
the ``seeds'', or the last multiple-values as multiple arguments,
starting with @var{seeds}, and must return the new seeds. Return the
final seeds.
Call @code{unrecognized-option-proc}, which is like an option object's
processor, for any options not found in @var{options}.
Call @code{operand-proc} with any items on the command line that are
not named options. This includes arguments after @samp{--}. It is
called with the argument in question, as well as the seeds.
@end deffn
@node SRFI-39 @node SRFI-39
@subsection SRFI-39 - Parameters @subsection SRFI-39 - Parameters
@cindex SRFI-39 @cindex SRFI-39

16
guile-readline/ChangeLog
View file

@ -1,3 +1,13 @@
2007-07-15 Ludovic Courtès <ludo@gnu.org>
* LIBGUILEREADLINE-VERSION
(LIBGUILEREADLINE_INTERFACE_REVISION): Incremented for release.
2007-06-26 Ludovic Courtès <ludo@gnu.org>
* readline.c (scm_add_history): Free S after invocation of
`add_history ()'.
2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org> 2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org>
* readline.c: terminate option list with NULL. * readline.c: terminate option list with NULL.
@ -315,7 +325,7 @@
2001-06-14 Marius Vollmer <mvo@zagadka.ping.de> 2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
Thanks to Matthias Köppe! Thanks to Matthias Köppe!
* configure.in: Check for rl_filename_completion_function. * configure.in: Check for rl_filename_completion_function.
* readline.c (s_scm_filename_completion_function): Use * readline.c (s_scm_filename_completion_function): Use
@ -701,3 +711,7 @@ Sun Dec 12 19:56:52 1999 Greg J. Badros <gjb@cs.washington.edu>
* Started guile-readline package. Files are copied from old * Started guile-readline package. Files are copied from old
guile-core package and slightly modified. guile-core package and slightly modified.
;; Local Variables:
;; coding: utf-8
;; End:

3
guile-readline/readline.c
View file

@ -1,6 +1,6 @@
/* readline.c --- line editing support for Guile */ /* readline.c --- line editing support for Guile */
/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc. /* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 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
@ -329,6 +329,7 @@ SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0,
s = scm_to_locale_string (text); s = scm_to_locale_string (text);
add_history (s); add_history (s);
free (s);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }

38
ice-9/ChangeLog
View file

@ -1,3 +1,41 @@
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
Implemented lazy duplicate binding handling. Fixed the
`module-observe-weak' API.
* boot-9.scm: Updated the `module-type' documentation under "{Low
Level Modules}".
(module-type)[import-obarray]: New slot.
[duplicates-interface, observer-id]: Removed.
(make-module): Updated accordingly. Use a weak-key hash table for
weak observers, so that observers aren't unregistered when the
observing closure gets GC'd.
(module-duplicates-interface, set-module-duplicates-interface!,
module-observer-id, set-module-observer-id!): Removed.
(module-import-obarray): New.
(module-observe-weak): Accept a new OBSERVER-ID argument allowing
callers control over when the observer will get unregistered.
(module-call-observers): Use `hash-for-each' rather than
`hash-fold'.
(module-local-variable, module-variable): Removed, now implemented
in C.
(module-make-local-var!): Simplified. No need to check for the
value of a same-named imported binding since the newly created
variable is systematically assigned afterwards.
(module-use!): Check whether MODULE and INTERFACE are `eq?'.
(module-use-interfaces!): Simplified. No longer calls
`process-duplicates'.
(beautify-user-module!): Use `module-use!' rather than
`set-module-uses!' when importing THE-SCM-MODULE.
(process-define-module): Added an AUTOLOADS local variable so that
autoloads are handled separately from regular interfaces.
(make-autoload-interface): Updated `module-constructor'
invocation.
(module-autoload!): New.
(make-duplicates-interface, process-duplicates): Removed.
(top-repl): Use `module-autoload!' rather than
`make-autoload-interface'.
2007-02-18 Neil Jerram <neil@ossau.uklinux.net> 2007-02-18 Neil Jerram <neil@ossau.uklinux.net>
* gds-client.scm (connect-to-gds): Break generation of client name * gds-client.scm (connect-to-gds): Break generation of client name

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

@ -1098,18 +1098,20 @@
;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind ;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
;;; is set, it defaults to 'module. ;;; is set, it defaults to 'module.
;;; ;;;
;;; - duplicates-handlers ;;; - duplicates-handlers: a list of procedures that get called to make a
;;; choice between two duplicate bindings when name clashes occur. See the
;;; `duplicate-handlers' global variable below.
;;; ;;;
;;; - duplicates-interface ;;; - observers: a list of procedures that get called when the module is
;;; modified.
;;; ;;;
;;; - observers ;;; - weak-observers: a weak-key hash table of procedures that get called
;;; ;;; when the module is modified. See `module-observe-weak' for details.
;;; - weak-observers
;;;
;;; - observer-id
;;; ;;;
;;; In addition, the module may (must?) contain a binding for ;;; In addition, the module may (must?) contain a binding for
;;; %module-public-interface... More explanations here... ;;; `%module-public-interface'. This variable should be bound to a module
;;; representing the exported interface of a module. See the
;;; `module-public-interface' and `module-export!' procedures.
;;; ;;;
;;; !!! warning: The interface to lazy binder procedures is going ;;; !!! warning: The interface to lazy binder procedures is going
;;; to be changed in an incompatible way to permit all the basic ;;; to be changed in an incompatible way to permit all the basic
@ -1173,8 +1175,8 @@
(define module-type (define module-type
(make-record-type 'module (make-record-type 'module
'(obarray uses binder eval-closure transformer name kind '(obarray uses binder eval-closure transformer name kind
duplicates-handlers duplicates-interface duplicates-handlers import-obarray
observers weak-observers observer-id) observers weak-observers)
%print-module)) %print-module))
;; make-module &opt size uses binder ;; make-module &opt size uses binder
@ -1190,6 +1192,10 @@
(list-ref args index) (list-ref args index)
default)) default))
(define %default-import-size
;; Typical number of imported bindings actually used by a module.
600)
(if (> (length args) 3) (if (> (length args) 3)
(error "Too many args to make-module." args)) (error "Too many args to make-module." args))
@ -1207,10 +1213,10 @@
"Lazy-binder expected to be a procedure or #f." binder)) "Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-hash-table size) (let ((module (module-constructor (make-hash-table size)
uses binder #f #f #f #f #f #f uses binder #f #f #f #f #f
(make-hash-table %default-import-size)
'() '()
(make-weak-value-hash-table 31) (make-weak-key-hash-table 31))))
0)))
;; We can't pass this as an argument to module-constructor, ;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module ;; because we need it to close over a pointer to the module
@ -1240,17 +1246,13 @@
(record-accessor module-type 'duplicates-handlers)) (record-accessor module-type 'duplicates-handlers))
(define set-module-duplicates-handlers! (define set-module-duplicates-handlers!
(record-modifier module-type 'duplicates-handlers)) (record-modifier module-type 'duplicates-handlers))
(define module-duplicates-interface
(record-accessor module-type 'duplicates-interface))
(define set-module-duplicates-interface!
(record-modifier module-type 'duplicates-interface))
(define module-observers (record-accessor module-type 'observers)) (define module-observers (record-accessor module-type 'observers))
(define set-module-observers! (record-modifier module-type 'observers)) (define set-module-observers! (record-modifier module-type 'observers))
(define module-weak-observers (record-accessor module-type 'weak-observers)) (define module-weak-observers (record-accessor module-type 'weak-observers))
(define module-observer-id (record-accessor module-type 'observer-id))
(define set-module-observer-id! (record-modifier module-type 'observer-id))
(define module? (record-predicate module-type)) (define module? (record-predicate module-type))
(define module-import-obarray (record-accessor module-type 'import-obarray))
(define set-module-eval-closure! (define set-module-eval-closure!
(let ((setter (record-modifier module-type 'eval-closure))) (let ((setter (record-modifier module-type 'eval-closure)))
(lambda (module closure) (lambda (module closure)
@ -1269,11 +1271,19 @@
(set-module-observers! module (cons proc (module-observers module))) (set-module-observers! module (cons proc (module-observers module)))
(cons module proc)) (cons module proc))
(define (module-observe-weak module proc) (define (module-observe-weak module observer-id . proc)
(let ((id (module-observer-id module))) ;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
(hash-set! (module-weak-observers module) id proc) ;; be any Scheme object). PROC is invoked and passed MODULE any time
(set-module-observer-id! module (+ 1 id)) ;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
(cons module id))) ;; (thus, it is never unregistered if OBSERVER-ID is an immediate value,
;; for instance).
;; The two-argument version is kept for backward compatibility: when called
;; with two arguments, the observer gets unregistered when closure PROC
;; gets GC'd (making it impossible to use an anonymous lambda for PROC).
(let ((proc (if (null? proc) observer-id (car proc))))
(hashq-set! (module-weak-observers module) observer-id proc)))
(define (module-unobserve token) (define (module-unobserve token)
(let ((module (car token)) (let ((module (car token))
@ -1311,7 +1321,11 @@
(define (module-call-observers m) (define (module-call-observers m)
(for-each (lambda (proc) (proc m)) (module-observers m)) (for-each (lambda (proc) (proc m)) (module-observers m))
(hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
;; We assume that weak observers don't (un)register themselves as they are
;; called since this would preclude proper iteration over the hash table
;; elements.
(hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m)))
@ -1435,26 +1449,8 @@
;;; ;;;
;;; If the symbol is not found at all, return #f. ;;; If the symbol is not found at all, return #f.
;;; ;;;
(define (module-local-variable m v) ;;; (This is now written in C, see `modules.c'.)
; (caddr ;;;
; (list m v
(let ((b (module-obarray-ref (module-obarray m) v)))
(or (and (variable? b) b)
(and (module-binder m)
((module-binder m) m v #f)))))
;))
;; module-variable module symbol
;;
;; like module-local-variable, except search the uses in the
;; case V is not found in M.
;;
;; NOTE: This function is superseded with C code (see modules.c)
;;; when using the standard eval closure.
;;
(define (module-variable m v)
(module-search module-local-variable m v))
;;; {Mapping modules x symbols --> bindings} ;;; {Mapping modules x symbols --> bindings}
;;; ;;;
@ -1515,18 +1511,9 @@
(module-modified m) (module-modified m)
b))) b)))
;; No local variable yet, so we need to create a new one. That ;; Create a new local variable.
;; new variable is initialized with the old imported value of V, (let ((local-var (make-undefined-variable)))
;; if there is one. (module-add! m v local-var)
(let ((imported-var (module-variable m v))
(local-var (or (and (module-binder m)
((module-binder m) m v #t))
(begin
(let ((answer (make-undefined-variable)))
(module-add! m v answer)
answer)))))
(if (and imported-var (not (variable-bound? local-var)))
(variable-set! local-var (variable-ref imported-var)))
local-var))) local-var)))
;; module-ensure-local-variable! module symbol ;; module-ensure-local-variable! module symbol
@ -1696,46 +1683,29 @@
;; Add INTERFACE to the list of interfaces used by MODULE. ;; Add INTERFACE to the list of interfaces used by MODULE.
;; ;;
(define (module-use! module interface) (define (module-use! module interface)
(if (not (eq? module interface))
(begin
;; Newly used modules must be appended rather than consed, so that
;; `module-variable' traverses the use list starting from the first
;; used module.
(set-module-uses! module (set-module-uses! module
(cons interface (append (filter (lambda (m)
(filter (lambda (m) (not
(not (equal? (module-name m) (equal? (module-name m)
(module-name interface)))) (module-name interface))))
(module-uses module)))) (module-uses module))
(module-modified module)) (list interface)))
(module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces ;; MODULE-USE-INTERFACES! module interfaces
;; ;;
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
;; ;;
(define (module-use-interfaces! module interfaces) (define (module-use-interfaces! module interfaces)
(let* ((duplicates-handlers? (or (module-duplicates-handlers module)
(default-duplicate-binding-procedures)))
(uses (module-uses module)))
;; remove duplicates-interface
(set! uses (delq! (module-duplicates-interface module) uses))
;; remove interfaces to be added
(for-each (lambda (interface)
(set! uses
(filter (lambda (m)
(not (equal? (module-name m)
(module-name interface))))
uses)))
interfaces)
;; add interfaces to use list
(set-module-uses! module uses)
(for-each (lambda (interface)
(and duplicates-handlers?
;; perform duplicate checking
(process-duplicates module interface))
(set! uses (cons interface uses))
(set-module-uses! module uses))
interfaces)
;; add duplicates interface
(if (module-duplicates-interface module)
(set-module-uses! module (set-module-uses! module
(cons (module-duplicates-interface module) uses))) (append (module-uses module) interfaces))
(module-modified module))) (module-modified module))
@ -1861,8 +1831,8 @@
(set-module-public-interface! module interface)))) (set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module))) (if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module))) (not (eq? module the-root-module)))
(set-module-uses! module ;; Import the default set of bindings (from the SCM module) in MODULE.
(append (module-uses module) (list the-scm-module))))) (module-use! module the-scm-module)))
;; NOTE: This binding is used in libguile/modules.c. ;; NOTE: This binding is used in libguile/modules.c.
;; ;;
@ -1893,6 +1863,7 @@
(define process-define-module #f) (define process-define-module #f)
(define process-use-modules #f) (define process-use-modules #f)
(define module-export! #f) (define module-export! #f)
(define default-duplicate-binding-procedures #f)
;; This boots the module system. All bindings needed by modules.c ;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now. ;; must have been defined by now.
@ -2027,7 +1998,8 @@
(reversed-interfaces '()) (reversed-interfaces '())
(exports '()) (exports '())
(re-exports '()) (re-exports '())
(replacements '())) (replacements '())
(autoloads '()))
(if (null? kws) (if (null? kws)
(call-with-deferred-observers (call-with-deferred-observers
@ -2035,7 +2007,9 @@
(module-use-interfaces! module (reverse reversed-interfaces)) (module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports) (module-export! module exports)
(module-replace! module replacements) (module-replace! module replacements)
(module-re-export! module re-exports))) (module-re-export! module re-exports)
(if (not (null? autoloads))
(apply module-autoload! module autoloads))))
(case (car kws) (case (car kws)
((#:use-module #:use-syntax) ((#:use-module #:use-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
@ -2055,31 +2029,35 @@
(cons interface reversed-interfaces) (cons interface reversed-interfaces)
exports exports
re-exports re-exports
replacements))) replacements
autoloads)))
((#:autoload) ((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws))) (or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws)) (unrecognized kws))
(loop (cdddr kws) (loop (cdddr kws)
(cons (make-autoload-interface module reversed-interfaces
(cadr kws)
(caddr kws))
reversed-interfaces)
exports exports
re-exports re-exports
replacements)) replacements
(let ((name (cadr kws))
(bindings (caddr kws)))
(cons* name bindings autoloads))))
((#:no-backtrace) ((#:no-backtrace)
(set-system-module! module #t) (set-system-module! module #t)
(loop (cdr kws) reversed-interfaces exports re-exports replacements)) (loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
((#:pure) ((#:pure)
(purify-module! module) (purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports replacements)) (loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
((#:duplicates) ((#:duplicates)
(if (not (pair? (cdr kws))) (if (not (pair? (cdr kws)))
(unrecognized kws)) (unrecognized kws))
(set-module-duplicates-handlers! (set-module-duplicates-handlers!
module module
(lookup-duplicates-handlers (cadr kws))) (lookup-duplicates-handlers (cadr kws)))
(loop (cddr kws) reversed-interfaces exports re-exports replacements)) (loop (cddr kws) reversed-interfaces exports re-exports
replacements autoloads))
((#:export #:export-syntax) ((#:export #:export-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
(unrecognized kws)) (unrecognized kws))
@ -2087,7 +2065,8 @@
reversed-interfaces reversed-interfaces
(append (cadr kws) exports) (append (cadr kws) exports)
re-exports re-exports
replacements)) replacements
autoloads))
((#:re-export #:re-export-syntax) ((#:re-export #:re-export-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
(unrecognized kws)) (unrecognized kws))
@ -2095,7 +2074,8 @@
reversed-interfaces reversed-interfaces
exports exports
(append (cadr kws) re-exports) (append (cadr kws) re-exports)
replacements)) replacements
autoloads))
((#:replace #:replace-syntax) ((#:replace #:replace-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
(unrecognized kws)) (unrecognized kws))
@ -2103,7 +2083,8 @@
reversed-interfaces reversed-interfaces
exports exports
re-exports re-exports
(append (cadr kws) replacements))) (append (cadr kws) replacements)
autoloads))
(else (else
(unrecognized kws))))) (unrecognized kws)))))
(run-hook module-defined-hook module) (run-hook module-defined-hook module)
@ -2131,8 +2112,26 @@
(if (pair? autoload) (if (pair? autoload)
(set-car! autoload i))) (set-car! autoload i)))
(module-local-variable i sym)))))) (module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
'() (make-weak-value-hash-table 31) 0))) (make-hash-table 0) '() (make-weak-value-hash-table 31))))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
of the symbols listed in @var{bindings} is looked up. @var{args} should be a
list of module-name/binding-list pairs, e.g., as in @code{(module-autoload!
module '(ice-9 q) '(make-q q-length))}."
(let loop ((args args))
(cond ((null? args)
#t)
((null? (cdr args))
(error "invalid name+binding autoload list" args))
(else
(let ((name (car args))
(bindings (cadr args)))
(module-use! module (make-autoload-interface module
name bindings))
(loop (cddr args)))))))
;;; {Compiled module} ;;; {Compiled module}
@ -3133,57 +3132,6 @@
(lookup-duplicates-handlers handler-names)) (lookup-duplicates-handlers handler-names))
handler-names))) handler-names)))
(define (make-duplicates-interface)
(let ((m (make-module)))
(set-module-kind! m 'custom-interface)
(set-module-name! m 'duplicates)
m))
(define (process-duplicates module interface)
(let* ((duplicates-handlers (or (module-duplicates-handlers module)
(default-duplicate-binding-procedures)))
(duplicates-interface (module-duplicates-interface module)))
(module-for-each
(lambda (name var)
(cond ((module-import-interface module name)
=>
(lambda (prev-interface)
(let ((var1 (module-local-variable prev-interface name))
(var2 (module-local-variable interface name)))
(if (not (eq? var1 var2))
(begin
(if (not duplicates-interface)
(begin
(set! duplicates-interface
(make-duplicates-interface))
(set-module-duplicates-interface!
module
duplicates-interface)))
(let* ((var (module-local-variable duplicates-interface
name))
(val (and var
(variable-bound? var)
(variable-ref var))))
(let loop ((duplicates-handlers duplicates-handlers))
(cond ((null? duplicates-handlers))
(((car duplicates-handlers)
module
name
prev-interface
(and (variable-bound? var1)
(variable-ref var1))
interface
(and (variable-bound? var2)
(variable-ref var2))
var
val)
=>
(lambda (var)
(module-add! duplicates-interface name var)))
(else
(loop (cdr duplicates-handlers)))))))))))))
interface)))
;;; {`cond-expand' for SRFI-0 support.} ;;; {`cond-expand' for SRFI-0 support.}
@ -3398,10 +3346,7 @@
'(((ice-9 threads))) '(((ice-9 threads)))
'()))) '())))
;; load debugger on demand ;; load debugger on demand
(module-use! guile-user-module (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
(make-autoload-interface guile-user-module
'(ice-9 debugger) '(debug)))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have

127
libguile/ChangeLog
View file

@ -1,7 +1,118 @@
2007-07-22 Ludovic Courtès <ludo@gnu.org>
Overhauled the reader, making it faster.
* gdbint.c (tok_buf, tok_buf_mark_p): Removed.
(gdb_read): Don't use a token buffer. Use `scm_read ()' instead
of `scm_lreadr ()'.
* read.c: Overhauled. No longer use a token buffer. Use a
on-stack C buffer in the common case and use Scheme strings when
larger buffers are needed.
* read.h (scm_grow_tok_buf, scm_flush_ws, scm_casei_streq,
scm_lreadr, scm_lreadrecparen): Removed.
(scm_i_input_error): Marked as `SCM_NORETURN'.
2007-07-15 Ludovic Courtès <ludo@gnu.org>
* script.c (scm_compile_shell_switches): Updated copyright year.
2007-07-11 Ludovic Courtès <ludo@gnu.org>
* goops.c (scm_sys_method_more_specific_p): Added docstring.
Make sure LEN is greater than or equal to the minimum length of
specializers of M1 and M2. This fixes a segfault later on in
`more_specificp ()' if TARGS is too small. Reported by Marco
Maggi <marco.maggi-ipsu@poste.it>.
2007-06-26 Ludovic Courtès <ludo@gnu.org>
* fluids.c (next_fluid_num): When growing ALLOCATED_FLUIDS, make
sure to free the previous array after the new one has been
installed. This leak is made visible by running
"(define l (map (lambda (i) (make-fluid)) (iota 255)))"
from the REPL within Valgrind.
2007-06-12 Ludovic Courtès <ludo@chbouib.org>
* socket.c (scm_inet_ntop): In the `AF_INET' case, declare `addr4'
as an `scm_t_uint32' rather than re-using `addr6'. This fixes a
bus error on SPARC (and possibly others) due to unaligned access.
2007-06-07 Ludovic Courtès <ludovic.courtes@laas.fr>
* posix.c (scm_ttyname): Check whether RESULT is NULL before
making a string from it (reported by Dan McMahill). Don't call
`scm_from_locale_string ()' before the mutex is released.
2007-05-26 Ludovic Courtès <ludo@chbouib.org>
* eval.c (scm_m_define): Updated comment. Changed order for value
evaluation and `scm_sym2var ()' call, which is perfectly valid per
R5RS. This reverts the change dated 2004-04-22 by Dirk Herrmann.
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
Implemented lazy duplicate binding handling.
* modules.c (scm_export): Renamed to...
(scm_module_export): This. Now public.
(module_variable): Removed.
(default_duplicate_binding_procedures_var): New variable.
(default_duplicate_binding_handlers, resolve_duplicate_binding,
module_imported_variable, scm_module_local_variable,
scm_module_variable): New functions.
(scm_module_import_interface): Rewritten.
(scm_module_reverse_lookup): Exported as a Scheme function.
* modules.h (scm_module_index_duplicate_handlers,
scm_module_index_import_obarray): New macros.
(scm_module_variable, scm_module_local_variable,
scm_module_export): New declarations.
2007-04-17 Ludovic Courtès <ludovic.courtes@laas.fr>
* numbers.c: Commented out trailing `HAVE_COMPLEX_DOUBLE' after
`#endif'. Use `#ifndef HAVE_XXX' rather than `#if !HAVE_XXX'.
2007-04-09 Han-Wen Nienhuys <hanwen@lilypond.org>
* numbers.c (carg): provide carg, cexp, clog in case they are
missing.
2007-03-12 Ludovic Courtès <ludovic.courtes@laas.fr>
* i18n.c (scm_nl_langinfo): `#ifdef'd uses of `GROUPING',
`FRAC_DIGITS', etc., which are GNU extensions. Reported by
Steven Wu.
2007-03-08 Kevin Ryde <user42@zip.com.au>
* struct.c, struct.h (scm_make_vtable): New function, providing
`make-vtable'.
* stacks.c (scm_init_stacks): Use it.
2007-03-06 Kevin Ryde <user42@zip.com.au>
* struct.c (scm_make_struct): Check for R,W,O at end of layout when
allocating a tail array. If there's no such then those tail fields
are uninitialized and garbage SCMs there can cause a segv if printed
(after fetching with struct-ref).
2007-02-22 Kevin Ryde <user42@zip.com.au>
* scmsigs.c (scm_sleep): In docstring, cross refence usleep.
(scm_usleep): Update docstring per manual, cross reference sleep.
* struct.c (scm_make_struct): Move SCM_CRITICAL_SECTION_END up so that
scm_struct_init is not within that section. scm_struct_init can
thrown an error, which within a critical section results in an
abort().
2007-02-19 Neil Jerram <neil@ossau.uklinux.net> 2007-02-19 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (noinst_HEADERS): Add private-options.h, so that it * Makefile.am (noinst_HEADERS): Add private-options.h, so that it
is included in the distribution. is included in the distribution.
(noinst_HEADERS): And the same for eval.i.c.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
@ -38,10 +149,24 @@
acquiring the locale mutex. acquiring the locale mutex.
(scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here. (scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here.
2007-01-27 Kevin Ryde <user42@zip.com.au>
* ports.c (scm_port_line, scm_set_port_line_x), read.c
(scm_i_input_error, scm_lreadr, scm_lreadrecparen): Corrections to
port line number type, should be "long" not "int", as per line_number
field of scm_t_port. (Makes a difference only on 64-bit systems, and
only then for a linenum above 2Gig.)
2007-01-25 Han-Wen Nienhuys <hanwen@lilypond.org> 2007-01-25 Han-Wen Nienhuys <hanwen@lilypond.org>
* vector.c: remove comment as per kryde's request. * vector.c: remove comment as per kryde's request.
2007-01-25 Kevin Ryde <user42@zip.com.au>
* sort.c (scm_stable_sort): Return empty list for input empty list, as
done in guile 1.6 and as always done by plain `sort'. Was falling
through to SCM_WRONG_TYPE_ARG. Reported by Ales Hvezda.
2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org> 2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org>
* vectors.c (s_scm_vector_move_right_x): complain about naming. * vectors.c (s_scm_vector_move_right_x): complain about naming.
@ -755,7 +880,7 @@
scm_t_uint64 and scm_t_uint32 instead of scm_t_int64 and scm_t_uint64 and scm_t_uint32 instead of scm_t_int64 and
scm_t_int32. scm_t_int32.
2006-01-04 Ludovic Court<E8>s <ludovic.courtes@laas.fr> 2006-01-04 Ludovic Courtès <ludovic.courtes@laas.fr>
* gc-segment.c (scm_i_sweep_some_cards): Take a SWEEP_STATS * gc-segment.c (scm_i_sweep_some_cards): Take a SWEEP_STATS
argument. Don't refer to SCM_GC_CELLS_COLLECTED and argument. Don't refer to SCM_GC_CELLS_COLLECTED and

1
libguile/Makefile.am
View file

@ -179,6 +179,7 @@ install-exec-hook:
## working. ## working.
noinst_HEADERS = convert.i.c \ noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \ conv-integer.i.c conv-uinteger.i.c \
eval.i.c \
srfi-4.i.c \ srfi-4.i.c \
quicksort.i.c \ quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \ win32-uname.h win32-dirent.h win32-socket.h \

11
libguile/eval.c
View file

@ -1209,10 +1209,11 @@ canonicalize_define (const SCM expr)
return expr; return expr;
} }
/* According to section 5.2.1 of R5RS we first have to make sure that the /* According to Section 5.2.1 of R5RS we first have to make sure that the
* variable is bound, and then perform the (set! variable expression) variable is bound, and then perform the `(set! variable expression)'
* operation. This means, that within the expression we may already assign operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
* values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */ bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
SCM SCM
scm_m_define (SCM expr, SCM env) scm_m_define (SCM expr, SCM env)
{ {
@ -1222,9 +1223,9 @@ scm_m_define (SCM expr, SCM env)
const SCM canonical_definition = canonicalize_define (expr); const SCM canonical_definition = canonicalize_define (expr);
const SCM cdr_canonical_definition = SCM_CDR (canonical_definition); const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
const SCM variable = SCM_CAR (cdr_canonical_definition); const SCM variable = SCM_CAR (cdr_canonical_definition);
const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
const SCM location const SCM location
= scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
if (SCM_REC_PROCNAMES_P) if (SCM_REC_PROCNAMES_P)
{ {

8
libguile/fluids.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1996,1997,2000,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
@ -219,6 +219,7 @@ next_fluid_num ()
no GC can run while updating these two variables. no GC can run while updating these two variables.
*/ */
char *prev_allocated_fluids;
char *new_allocated_fluids = char *new_allocated_fluids =
scm_malloc (allocated_fluids_len + FLUID_GROW); scm_malloc (allocated_fluids_len + FLUID_GROW);
@ -229,9 +230,14 @@ next_fluid_num ()
memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len); memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len);
memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW); memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
n = allocated_fluids_len; n = allocated_fluids_len;
prev_allocated_fluids = allocated_fluids;
allocated_fluids = new_allocated_fluids; allocated_fluids = new_allocated_fluids;
allocated_fluids_len += FLUID_GROW; allocated_fluids_len += FLUID_GROW;
if (prev_allocated_fluids != NULL)
free (prev_allocated_fluids);
/* Now allocated_fluids and allocated_fluids_len are valid again /* Now allocated_fluids and allocated_fluids_len are valid again
and we can allow GCs to occur. and we can allow GCs to occur.
*/ */

12
libguile/gdbint.c
View file

@ -103,9 +103,6 @@ int scm_print_carefully_p;
static SCM gdb_input_port; static SCM gdb_input_port;
static int port_mark_p, stream_mark_p, string_mark_p; static int port_mark_p, stream_mark_p, string_mark_p;
static SCM tok_buf;
static int tok_buf_mark_p;
static SCM gdb_output_port; static SCM gdb_output_port;
@ -194,10 +191,9 @@ gdb_read (char *str)
scm_puts (str, gdb_input_port); scm_puts (str, gdb_input_port);
scm_truncate_file (gdb_input_port, SCM_UNDEFINED); scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET)); scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
/* Read one object */ /* Read one object */
tok_buf_mark_p = SCM_GC_MARK_P (tok_buf); ans = scm_read (gdb_input_port);
SCM_CLEAR_GC_MARK (tok_buf);
ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
if (SCM_GC_P) if (SCM_GC_P)
{ {
if (SCM_NIMP (ans)) if (SCM_NIMP (ans))
@ -212,8 +208,6 @@ gdb_read (char *str)
if (SCM_NIMP (ans)) if (SCM_NIMP (ans))
scm_permanent_object (ans); scm_permanent_object (ans);
exit: exit:
if (tok_buf_mark_p)
SCM_SET_GC_MARK (tok_buf);
remark_port (gdb_input_port); remark_port (gdb_input_port);
SCM_END_FOREIGN_BLOCK; SCM_END_FOREIGN_BLOCK;
return status; return status;
@ -305,8 +299,6 @@ scm_init_gdbint ()
SCM_OPN | SCM_RDNG | SCM_WRTNG, SCM_OPN | SCM_RDNG | SCM_WRTNG,
s); s);
gdb_input_port = scm_permanent_object (port); gdb_input_port = scm_permanent_object (port);
tok_buf = scm_permanent_object (scm_c_make_string (30, SCM_UNDEFINED));
} }
/* /*

21
libguile/goops.c
View file

@ -2313,26 +2313,33 @@ SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
(SCM m1, SCM m2, SCM targs), (SCM m1, SCM m2, SCM targs),
"") "Return true if method @var{m1} is more specific than @var{m2} "
"given the argument types (classes) listed in @var{targs}.")
#define FUNC_NAME s_scm_sys_method_more_specific_p #define FUNC_NAME s_scm_sys_method_more_specific_p
{ {
SCM l, v, result; SCM l, v, result;
SCM *v_elts; SCM *v_elts;
long i, len; long i, len, m1_specs, m2_specs;
scm_t_array_handle handle; scm_t_array_handle handle;
SCM_VALIDATE_METHOD (1, m1); SCM_VALIDATE_METHOD (1, m1);
SCM_VALIDATE_METHOD (2, m2); SCM_VALIDATE_METHOD (2, m2);
SCM_ASSERT ((len = scm_ilength (targs)) != -1, targs, SCM_ARG3, FUNC_NAME);
/* Verify that all the arguments of targs are classes and place them len = scm_ilength (targs);
in a vector m1_specs = scm_ilength (SPEC_OF (m1));
*/ m2_specs = scm_ilength (SPEC_OF (m2));
SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
targs, SCM_ARG3, FUNC_NAME);
/* Verify that all the arguments of TARGS are classes and place them
in a vector. */
v = scm_c_make_vector (len, SCM_EOL); v = scm_c_make_vector (len, SCM_EOL);
v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL); v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
for (i = 0, l = targs; i < len && scm_is_pair (l); i++, l = SCM_CDR (l)) for (i = 0, l = targs;
i < len && scm_is_pair (l);
i++, l = SCM_CDR (l))
{ {
SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME); SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
v_elts[i] = SCM_CAR (l); v_elts[i] = SCM_CAR (l);

16
libguile/i18n.c
View file

@ -1442,12 +1442,14 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
result = SCM_BOOL_F; result = SCM_BOOL_F;
else else
{ {
char *p;
switch (c_item) switch (c_item)
{ {
#if (defined GROUPING) && (defined MON_GROUPING)
case GROUPING: case GROUPING:
case MON_GROUPING: case MON_GROUPING:
{
char *p;
/* In this cases, the result is to be interpreted as a list of /* In this cases, the result is to be interpreted as a list of
numbers. If the last item is `CHARS_MAX', it has the special numbers. If the last item is `CHARS_MAX', it has the special
meaning "no more grouping". */ meaning "no more grouping". */
@ -1470,7 +1472,10 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
free (c_result); free (c_result);
break; break;
}
#endif
#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
case FRAC_DIGITS: case FRAC_DIGITS:
case INT_FRAC_DIGITS: case INT_FRAC_DIGITS:
/* This is to be interpreted as a single integer. */ /* This is to be interpreted as a single integer. */
@ -1482,19 +1487,25 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
free (c_result); free (c_result);
break; break;
#endif
#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
case P_CS_PRECEDES: case P_CS_PRECEDES:
case N_CS_PRECEDES: case N_CS_PRECEDES:
case INT_P_CS_PRECEDES: case INT_P_CS_PRECEDES:
case INT_N_CS_PRECEDES: case INT_N_CS_PRECEDES:
#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
case P_SEP_BY_SPACE: case P_SEP_BY_SPACE:
case N_SEP_BY_SPACE: case N_SEP_BY_SPACE:
#endif
/* This is to be interpreted as a boolean. */ /* This is to be interpreted as a boolean. */
result = scm_from_bool (*c_result); result = scm_from_bool (*c_result);
free (c_result); free (c_result);
break; break;
#endif
#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
case P_SIGN_POSN: case P_SIGN_POSN:
case N_SIGN_POSN: case N_SIGN_POSN:
case INT_P_SIGN_POSN: case INT_P_SIGN_POSN:
@ -1527,6 +1538,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
result = scm_from_locale_symbol ("unspecified"); result = scm_from_locale_symbol ("unspecified");
} }
break; break;
#endif
default: default:
/* FIXME: `locale_string ()' is not appropriate here because of /* FIXME: `locale_string ()' is not appropriate here because of

293
libguile/modules.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1998,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 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
@ -162,12 +162,8 @@ scm_c_use_module (const char *name)
static SCM module_export_x_var; static SCM module_export_x_var;
SCM
/* scm_module_export (SCM module, SCM namelist)
TODO: should export this function? --hwn.
*/
static SCM
scm_export (SCM module, SCM namelist)
{ {
return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var), return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
module, namelist); module, namelist);
@ -203,7 +199,7 @@ scm_c_export (const char *name, ...)
tail = SCM_CDRLOC (*tail); tail = SCM_CDRLOC (*tail);
} }
va_end (ap); va_end (ap);
scm_export (scm_current_module(), names); scm_module_export (scm_current_module (), names);
} }
} }
@ -278,42 +274,220 @@ SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
* release. * release.
*/ */
static SCM module_make_local_var_x_var; /* The `module-make-local-var!' variable. */
static SCM module_make_local_var_x_var = SCM_UNSPECIFIED;
static SCM /* The `default-duplicate-binding-procedures' variable. */
module_variable (SCM module, SCM sym) static SCM default_duplicate_binding_procedures_var = SCM_UNSPECIFIED;
/* Return the list of default duplicate binding handlers (procedures). */
static inline SCM
default_duplicate_binding_handlers (void)
{
SCM get_handlers;
get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
return (scm_call_0 (get_handlers));
}
/* Resolve the import of SYM in MODULE, where SYM is currently provided by
both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
duplicate binding handlers or `#f'. */
static inline SCM
resolve_duplicate_binding (SCM module, SCM sym,
SCM iface1, SCM var1,
SCM iface2, SCM var2)
{
SCM result = SCM_BOOL_F;
if (!scm_is_eq (var1, var2))
{
SCM val1, val2;
SCM handlers, h, handler_args;
val1 = SCM_VARIABLE_REF (var1);
val2 = SCM_VARIABLE_REF (var2);
val1 = (val1 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
val2 = (val2 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
if (scm_is_false (handlers))
handlers = default_duplicate_binding_handlers ();
handler_args = scm_list_n (module, sym,
iface1, val1, iface2, val2,
var1, val1,
SCM_UNDEFINED);
for (h = handlers;
scm_is_pair (h) && scm_is_false (result);
h = SCM_CDR (h))
{
result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
}
}
else
result = var1;
return result;
}
/* Lookup SYM as an imported variable of MODULE. */
static inline SCM
module_imported_variable (SCM module, SCM sym)
{
#define SCM_BOUND_THING_P scm_is_true
register SCM var, imports;
/* Search cached imported bindings. */
imports = SCM_MODULE_IMPORT_OBARRAY (module);
var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (var))
return var;
{
/* Search the use list for yet uncached imported bindings, possibly
resolving duplicates as needed and caching the result in the import
obarray. */
SCM uses;
SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
for (uses = SCM_MODULE_USES (module);
scm_is_pair (uses);
uses = SCM_CDR (uses))
{
SCM iface;
iface = SCM_CAR (uses);
var = scm_module_variable (iface, sym);
if (SCM_BOUND_THING_P (var))
{
if (SCM_BOUND_THING_P (found_var))
{
/* SYM is a duplicate binding (imported more than once) so we
need to resolve it. */
found_var = resolve_duplicate_binding (module, sym,
found_iface, found_var,
iface, var);
if (scm_is_eq (found_var, var))
found_iface = iface;
}
else
/* Keep track of the variable we found and check for other
occurences of SYM in the use list. */
found_var = var, found_iface = iface;
}
}
if (SCM_BOUND_THING_P (found_var))
{
/* Save the lookup result for future reference. */
(void) scm_hashq_set_x (imports, sym, found_var);
return found_var;
}
}
return SCM_BOOL_F;
#undef SCM_BOUND_THING_P
}
SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
(SCM module, SCM sym),
"Return the variable bound to @var{sym} in @var{module}. Return "
"@code{#f} is @var{sym} is not bound locally in @var{module}.")
#define FUNC_NAME s_scm_module_local_variable
{ {
#define SCM_BOUND_THING_P(b) \ #define SCM_BOUND_THING_P(b) \
(scm_is_true (b)) (scm_is_true (b))
register SCM b;
/* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
evaluated. */
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
/* 1. Check module obarray */ /* 1. Check module obarray */
SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (b)) if (SCM_BOUND_THING_P (b))
return b; return b;
/* 2. Search imported bindings. In order to be consistent with
`module-variable', the binder gets called only when no imported binding
matches SYM. */
b = module_imported_variable (module, sym);
if (SCM_BOUND_THING_P (b))
return SCM_BOOL_F;
{ {
/* 3. Query the custom binder. */
SCM binder = SCM_MODULE_BINDER (module); SCM binder = SCM_MODULE_BINDER (module);
if (scm_is_true (binder)) if (scm_is_true (binder))
/* 2. Custom binder */
{ {
b = scm_call_3 (binder, module, sym, SCM_BOOL_F); b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b)) if (SCM_BOUND_THING_P (b))
return b; return b;
} }
} }
{
/* 3. Search the use list */
SCM uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses))
{
b = module_variable (SCM_CAR (uses), sym);
if (SCM_BOUND_THING_P (b))
return b;
uses = SCM_CDR (uses);
}
return SCM_BOOL_F; return SCM_BOOL_F;
}
#undef SCM_BOUND_THING_P #undef SCM_BOUND_THING_P
} }
#undef FUNC_NAME
SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
(SCM module, SCM sym),
"Return the variable bound to @var{sym} in @var{module}. This "
"may be both a local variable or an imported variable. Return "
"@code{#f} is @var{sym} is not bound in @var{module}.")
#define FUNC_NAME s_scm_module_variable
{
#define SCM_BOUND_THING_P(b) \
(scm_is_true (b))
register SCM var;
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
/* 1. Check module obarray */
var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (var))
return var;
/* 2. Search among the imported variables. */
var = module_imported_variable (module, sym);
if (SCM_BOUND_THING_P (var))
return var;
{
/* 3. Query the custom binder. */
SCM binder;
binder = SCM_MODULE_BINDER (module);
if (scm_is_true (binder))
{
var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (var))
return var;
}
}
return SCM_BOOL_F;
#undef SCM_BOUND_THING_P
}
#undef FUNC_NAME
scm_t_bits scm_tc16_eval_closure; scm_t_bits scm_tc16_eval_closure;
@ -335,7 +509,7 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
module, sym); module, sym);
} }
else else
return module_variable (module, sym); return scm_module_variable (module, sym);
} }
SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
@ -398,38 +572,44 @@ scm_current_module_transformer ()
SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
(SCM module, SCM sym), (SCM module, SCM sym),
"") "Return the module or interface from which @var{sym} is imported "
"in @var{module}. If @var{sym} is not imported (i.e., it is not "
"defined in @var{module} or it is a module-local binding instead "
"of an imported one), then @code{#f} is returned.")
#define FUNC_NAME s_scm_module_import_interface #define FUNC_NAME s_scm_module_import_interface
{ {
#define SCM_BOUND_THING_P(b) (scm_is_true (b)) SCM var, result = SCM_BOOL_F;
SCM uses;
SCM_VALIDATE_MODULE (SCM_ARG1, module); SCM_VALIDATE_MODULE (1, module);
/* Search the use list */ SCM_VALIDATE_SYMBOL (2, sym);
uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses)) var = scm_module_variable (module, sym);
if (scm_is_true (var))
{ {
SCM _interface = SCM_CAR (uses); /* Look for the module that provides VAR. */
/* 1. Check module obarray */ SCM local_var;
SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b)) local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
return _interface; SCM_UNDEFINED);
if (scm_is_eq (local_var, var))
result = module;
else
{ {
SCM binder = SCM_MODULE_BINDER (_interface); /* Look for VAR among the used modules. */
if (scm_is_true (binder)) SCM uses, imported_var;
/* 2. Custom binder */
for (uses = SCM_MODULE_USES (module);
scm_is_pair (uses) && scm_is_false (result);
uses = SCM_CDR (uses))
{ {
b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F); imported_var = scm_module_variable (SCM_CAR (uses), sym);
if (SCM_BOUND_THING_P (b)) if (scm_is_eq (imported_var, var))
return _interface; result = SCM_CAR (uses);
} }
} }
/* 3. Search use list recursively. */
_interface = scm_module_import_interface (_interface, sym);
if (scm_is_true (_interface))
return _interface;
uses = SCM_CDR (uses);
} }
return SCM_BOOL_F;
return result;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -560,9 +740,13 @@ scm_define (SCM sym, SCM value)
return var; return var;
} }
SCM SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
scm_module_reverse_lookup (SCM module, SCM variable) (SCM module, SCM variable),
#define FUNC_NAME "module-reverse-lookup" "Return the symbol under which @var{variable} is bound in "
"@var{module} or @var{#f} if @var{variable} is not visible "
"from @var{module}. If @var{module} is @code{#f}, then the "
"pre-module obarray is used.")
#define FUNC_NAME s_scm_module_reverse_lookup
{ {
SCM obarray; SCM obarray;
long i, n; long i, n;
@ -604,8 +788,7 @@ scm_module_reverse_lookup (SCM module, SCM variable)
} }
} }
/* Try the `uses' list. /* Try the `uses' list. */
*/
{ {
SCM uses = SCM_MODULE_USES (module); SCM uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses)) while (scm_is_pair (uses))
@ -678,6 +861,8 @@ scm_post_boot_init_modules ()
process_use_modules_var = PERM (scm_c_lookup ("process-use-modules")); process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
module_export_x_var = PERM (scm_c_lookup ("module-export!")); module_export_x_var = PERM (scm_c_lookup ("module-export!"));
the_root_module_var = PERM (scm_c_lookup ("the-root-module")); the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
default_duplicate_binding_procedures_var =
PERM (scm_c_lookup ("default-duplicate-binding-procedures"));
scm_module_system_booted_p = 1; scm_module_system_booted_p = 1;
} }

11
libguile/modules.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_MODULES_H #ifndef SCM_MODULES_H
#define SCM_MODULES_H #define SCM_MODULES_H
/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc. /* Copyright (C) 1998, 2000, 2001, 2002, 2003, 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
@ -45,6 +45,8 @@ SCM_API scm_t_bits scm_module_tag;
#define scm_module_index_binder 2 #define scm_module_index_binder 2
#define scm_module_index_eval_closure 3 #define scm_module_index_eval_closure 3
#define scm_module_index_transformer 4 #define scm_module_index_transformer 4
#define scm_module_index_duplicate_handlers 7
#define scm_module_index_import_obarray 8
#define SCM_MODULE_OBARRAY(module) \ #define SCM_MODULE_OBARRAY(module) \
SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray]) SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray])
@ -56,6 +58,10 @@ SCM_API scm_t_bits scm_module_tag;
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure]) SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure])
#define SCM_MODULE_TRANSFORMER(module) \ #define SCM_MODULE_TRANSFORMER(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer]) SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer])
#define SCM_MODULE_DUPLICATE_HANDLERS(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_duplicate_handlers])
#define SCM_MODULE_IMPORT_OBARRAY(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_import_obarray])
SCM_API scm_t_bits scm_tc16_eval_closure; SCM_API scm_t_bits scm_tc16_eval_closure;
@ -64,6 +70,8 @@ SCM_API scm_t_bits scm_tc16_eval_closure;
SCM_API SCM scm_current_module (void); SCM_API SCM scm_current_module (void);
SCM_API SCM scm_module_variable (SCM module, SCM sym);
SCM_API SCM scm_module_local_variable (SCM module, SCM sym);
SCM_API SCM scm_interaction_environment (void); SCM_API SCM scm_interaction_environment (void);
SCM_API SCM scm_set_current_module (SCM module); SCM_API SCM scm_set_current_module (SCM module);
@ -80,6 +88,7 @@ SCM_API SCM scm_c_module_lookup (SCM module, const char *name);
SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val); SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val);
SCM_API SCM scm_module_lookup (SCM module, SCM symbol); SCM_API SCM scm_module_lookup (SCM module, SCM symbol);
SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val); SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val);
SCM_API SCM scm_module_export (SCM module, SCM symbol_list);
SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable); SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);
SCM_API SCM scm_c_resolve_module (const char *name); SCM_API SCM scm_c_resolve_module (const char *name);

29
libguile/numbers.c
View file

@ -5998,6 +5998,35 @@ 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

6
libguile/ports.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 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
@ -1613,7 +1613,7 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
{ {
port = SCM_COERCE_OUTPORT (port); port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
return scm_from_int (SCM_LINUM (port)); return scm_from_long (SCM_LINUM (port));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1625,7 +1625,7 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
{ {
port = SCM_COERCE_OUTPORT (port); port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port); SCM_VALIDATE_OPENPORT (1, port);
SCM_PTAB_ENTRY (port)->line_number = scm_to_int (line); SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME

10
libguile/posix.c
View file

@ -842,7 +842,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
{ {
char *result; char *result;
int fd, err; int fd, err;
SCM ret; SCM ret = SCM_BOOL_F;
port = SCM_COERCE_OUTPORT (port); port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1, port); SCM_VALIDATE_OPPORT (1, port);
@ -851,9 +851,12 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
fd = SCM_FPORT_FDES (port); fd = SCM_FPORT_FDES (port);
scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
SCM_SYSCALL (result = ttyname (fd)); SCM_SYSCALL (result = ttyname (fd));
err = errno; err = errno;
ret = scm_from_locale_string (result); if (result != NULL)
result = strdup (result);
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
if (!result) if (!result)
@ -861,6 +864,9 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
errno = err; errno = err;
SCM_SYSERROR; SCM_SYSERROR;
} }
else
ret = scm_take_locale_string (result);
return ret; return ret;
} }
#undef FUNC_NAME #undef FUNC_NAME

1455
libguile/read.c
View file

File diff suppressed because it is too large Load diff

8
libguile/read.h
View file

@ -53,16 +53,12 @@ SCM_API SCM scm_sym_dot;
SCM_API SCM scm_read_options (SCM setting); SCM_API SCM scm_read_options (SCM setting);
SCM_API SCM scm_read (SCM port); SCM_API SCM scm_read (SCM port);
SCM_API char * scm_grow_tok_buf (SCM * tok_buf);
SCM_API int scm_flush_ws (SCM port, const char *eoferr);
SCM_API int scm_casei_streq (char * s1, char * s2);
SCM_API SCM scm_lreadr (SCM * tok_buf, SCM port, SCM *copy);
SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird); SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_lreadrecparen (SCM * tok_buf, SCM port, char *name, SCM *copy);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc); SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
SCM_API void scm_i_input_error (const char *func, SCM port, SCM_API void scm_i_input_error (const char *func, SCM port,
const char *message, SCM arg); const char *message, SCM arg)
SCM_NORETURN;
SCM_API void scm_init_read (void); SCM_API void scm_init_read (void);

18
libguile/scmsigs.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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
@ -610,7 +610,9 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
(SCM i), (SCM i),
"Wait for the given number of seconds (an integer) or until a signal\n" "Wait for the given number of seconds (an integer) or until a signal\n"
"arrives. The return value is zero if the time elapses or the number\n" "arrives. The return value is zero if the time elapses or the number\n"
"of seconds remaining otherwise.") "of seconds remaining otherwise.\n"
"\n"
"See also @code{usleep}.")
#define FUNC_NAME s_scm_sleep #define FUNC_NAME s_scm_sleep
{ {
return scm_from_uint (scm_std_sleep (scm_to_uint (i))); return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
@ -619,7 +621,17 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0, SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
(SCM i), (SCM i),
"Sleep for @var{i} microseconds.") "Wait the given period @var{usecs} microseconds (an integer).\n"
"If a signal arrives the wait stops and the return value is the\n"
"time remaining, in microseconds. If the period elapses with no\n"
"signal the return is zero.\n"
"\n"
"On most systems the process scheduler is not microsecond accurate and\n"
"the actual period slept by @code{usleep} may be rounded to a system\n"
"clock tick boundary. Traditionally such ticks were 10 milliseconds\n"
"apart, and that interval is often still used.\n"
"\n"
"See also @code{sleep}.")
#define FUNC_NAME s_scm_usleep #define FUNC_NAME s_scm_usleep
{ {
return scm_from_ulong (scm_std_usleep (scm_to_ulong (i))); return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));

4
libguile/script.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. /* Copyright (C) 1994, 1995, 1996, 1997, 1998, 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
* License as published by the Free Software Foundation; either * License as published by the Free Software Foundation; either
@ -635,7 +635,7 @@ scm_compile_shell_switches (int argc, char **argv)
{ {
/* Print version number. */ /* Print version number. */
printf ("Guile %s\n" printf ("Guile %s\n"
"Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation\n" "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation\n"
"Guile may be distributed under the terms of the GNU General Public Licence;\n" "Guile may be distributed under the terms of the GNU General Public Licence;\n"
"certain other uses are permitted as well. For details, see the file\n" "certain other uses are permitted as well. For details, see the file\n"
"`COPYING', which is included in the Guile distribution.\n" "`COPYING', which is included in the Guile distribution.\n"

20
libguile/socket.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. /* Copyright (C) 1996,1997,1998,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
@ -386,16 +386,28 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0,
#else #else
char dst[46]; char dst[46];
#endif #endif
char addr6[16]; const char *result;
af = scm_to_int (family); af = scm_to_int (family);
SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6); SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6);
if (af == AF_INET) if (af == AF_INET)
*(scm_t_uint32 *) addr6 = htonl (SCM_NUM2ULONG (2, address)); {
scm_t_uint32 addr4;
addr4 = htonl (SCM_NUM2ULONG (2, address));
result = inet_ntop (af, &addr4, dst, sizeof (dst));
}
else else
{
char addr6[16];
scm_to_ipv6 ((scm_t_uint8 *) addr6, address); scm_to_ipv6 ((scm_t_uint8 *) addr6, address);
if (inet_ntop (af, &addr6, dst, sizeof dst) == NULL) result = inet_ntop (af, &addr6, dst, sizeof (dst));
}
if (result == NULL)
SCM_SYSERROR; SCM_SYSERROR;
return scm_from_locale_string (dst); return scm_from_locale_string (dst);
} }
#undef FUNC_NAME #undef FUNC_NAME

5
libguile/sort.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1999,2000,2001,2002, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1999,2000,2001,2002, 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
* License as published by the Free Software Foundation; either * License as published by the Free Software Foundation; either
@ -531,6 +531,9 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
"This is a stable sort.") "This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort #define FUNC_NAME s_scm_stable_sort
{ {
if (SCM_NULL_OR_NIL_P (items))
return SCM_EOL;
if (scm_is_pair (items)) if (scm_is_pair (items))
return scm_stable_sort_x (scm_list_copy (items), less); return scm_stable_sort_x (scm_list_copy (items), less);
else if (scm_is_vector (items)) else if (scm_is_vector (items))

14
libguile/stacks.c
View file

@ -1,5 +1,5 @@
/* Representation of stack frame debug information /* Representation of stack frame debug information
* Copyright (C) 1996,1997,2000,2001, 2006 Free Software Foundation * Copyright (C) 1996,1997,2000,2001, 2006, 2007 Free Software Foundation
* *
* 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
@ -741,14 +741,10 @@ SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
void void
scm_init_stacks () scm_init_stacks ()
{ {
SCM vtable; scm_stack_type =
SCM stack_layout scm_permanent_object
= scm_make_struct_layout (scm_from_locale_string (SCM_STACK_LAYOUT)); (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); SCM_UNDEFINED));
scm_stack_type
= scm_permanent_object (scm_make_struct (vtable, SCM_INUM0,
scm_cons (stack_layout,
SCM_EOL)));
scm_set_struct_vtable_name_x (scm_stack_type, scm_set_struct_vtable_name_x (scm_stack_type,
scm_from_locale_symbol ("stack")); scm_from_locale_symbol ("stack"));
#include "libguile/stacks.x" #include "libguile/stacks.x"

60
libguile/struct.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1996,1997,1998,1999,2000,2001, 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
@ -390,6 +390,26 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
layout = SCM_PACK (c_vtable [scm_vtable_index_layout]); layout = SCM_PACK (c_vtable [scm_vtable_index_layout]);
basic_size = scm_i_symbol_length (layout) / 2; basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size); tail_elts = scm_to_size_t (tail_array_size);
/* A tail array is only allowed if the layout fields string ends in "R",
"W" or "O". */
if (tail_elts != 0)
{
SCM layout_str, last_char;
if (basic_size == 0)
{
bad_tail:
SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL);
}
layout_str = scm_symbol_to_string (layout);
last_char = scm_string_ref (layout_str,
scm_from_size_t (2 * basic_size - 1));
if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
goto bad_tail;
}
SCM_CRITICAL_SECTION_START; SCM_CRITICAL_SECTION_START;
if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
{ {
@ -406,7 +426,6 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
handle = scm_double_cell ((((scm_t_bits) c_vtable) handle = scm_double_cell ((((scm_t_bits) c_vtable)
+ scm_tc3_struct), + scm_tc3_struct),
(scm_t_bits) data, 0, 0); (scm_t_bits) data, 0, 0);
scm_struct_init (handle, layout, data, tail_elts, init);
if (c_vtable[scm_struct_i_free]) if (c_vtable[scm_struct_i_free])
{ {
@ -424,6 +443,16 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
} }
SCM_CRITICAL_SECTION_END; SCM_CRITICAL_SECTION_END;
/* In guile 1.8.1 and earlier, the SCM_CRITICAL_SECTION_END above covered
also the following scm_struct_init. But that meant if scm_struct_init
finds an invalid type for a "u" field then there's an error throw in a
critical section, which results in an abort(). Not sure if we need any
protection across scm_struct_init. The data array contains garbage at
this point, but until we return it's not visible to anyone except
`gc'. */
scm_struct_init (handle, layout, data, tail_elts, init);
return handle; return handle;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -507,6 +536,28 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
#undef FUNC_NAME #undef FUNC_NAME
static SCM scm_i_vtable_vtable_no_extra_fields;
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
"Create a vtable, for creating structures with the given\n"
"@var{fields}.\n"
"\n"
"The optional @var{printer} argument is a function to be called\n"
"@code{(@var{printer} struct port)} on the structures created.\n"
"It should look at @var{struct} and write to @var{port}.")
#define FUNC_NAME s_scm_make_vtable
{
if (SCM_UNBNDP (printer))
printer = SCM_BOOL_F;
return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
scm_list_2 (scm_make_struct_layout (fields),
printer));
}
#undef FUNC_NAME
/* Return true if S1 and S2 are equal structures, i.e., if their vtable and /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
contents are the same. Field protections are honored. Thus, it is an contents are the same. Field protections are honored. Thus, it is an
error to test the equality of structures that contain opaque fields. */ error to test the equality of structures that contain opaque fields. */
@ -822,6 +873,11 @@ scm_init_struct ()
= scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31))); = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
required_vtable_fields = scm_from_locale_string ("prsrpw"); required_vtable_fields = scm_from_locale_string ("prsrpw");
scm_permanent_object (required_vtable_fields); scm_permanent_object (required_vtable_fields);
scm_i_vtable_vtable_no_extra_fields =
scm_permanent_object
(scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));
scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout)); scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable)); scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable));
scm_c_define ("vtable-index-printer", scm_c_define ("vtable-index-printer",

3
libguile/struct.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H #ifndef SCM_STRUCT_H
#define SCM_STRUCT_H #define SCM_STRUCT_H
/* Copyright (C) 1995,1997,1999,2000,2001, 2006 Free Software Foundation, Inc. /* Copyright (C) 1995,1997,1999,2000,2001, 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
@ -88,6 +88,7 @@ SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x); SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x); SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init); SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init); SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2); SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos); SCM_API SCM scm_struct_ref (SCM handle, SCM pos);

5
oop/ChangeLog
View file

@ -1,3 +1,8 @@
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
* goops/internal.scm: Use the public module API rather than hack
with `%module-public-interface', `nested-ref', et al.
2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se> 2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* accessors.scm, simple.scm: New files. * accessors.scm, simple.scm: New files.

9
oop/goops/internal.scm
View file

@ -21,5 +21,10 @@
(define-module (oop goops internal) (define-module (oop goops internal)
:use-module (oop goops)) :use-module (oop goops))
(set-module-uses! %module-public-interface ;; Export all the bindings that are internal to `(oop goops)'.
(list (nested-ref the-root-module '(app modules oop goops)))) (let ((public-i (module-public-interface (current-module))))
(module-for-each (lambda (name var)
(if (eq? name '%module-public-interface)
#t
(module-add! public-i name var)))
(resolve-module '(oop goops))))

2
pre-inst-guile.in
View file

@ -43,7 +43,7 @@
# Code: # Code:
# config # config
subdirs_with_ltlibs="srfi guile-readline" # maintain me subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me
# env (set by configure) # env (set by configure)
top_srcdir="@top_srcdir_absolute@" top_srcdir="@top_srcdir_absolute@"

16
srfi/ChangeLog
View file

@ -1,3 +1,19 @@
2007-07-18 Stephen Compall <s11@member.fsf.org>
* srfi-37.scm: New file.
* Makefile.am: Add it.
2007-07-09 Ludovic Courtès <ludo@gnu.org>
* srfi-19.scm (date->julian-day): Take OFFSET into account.
Patch by Jon Wilson <j85wilson@fastmail.fm>.
2007-05-09 Ludovic Courtès <ludo@chbouib.org>
* srfi-19.scm (priv:current-time-process): Removed shadowing
definition that returned a list. Use the right argument order to
`make-time'. Reported by Scott Shedden.
2007-02-04 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-02-04 Ludovic Courtès <ludovic.courtes@laas.fr>
* srfi/srfi-19.scm (priv:locale-abbr-weekday): Add one to the day * srfi/srfi-19.scm (priv:locale-abbr-weekday): Add one to the day

1
srfi/Makefile.am
View file

@ -74,6 +74,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-37.scm \
srfi-39.scm \ srfi-39.scm \
srfi-60.scm srfi-60.scm

16
srfi/srfi-19.scm
View file

@ -1,6 +1,6 @@
;;; srfi-19.scm --- Time/Date Library ;;; srfi-19.scm --- Time/Date Library
;; Copyright (C) 2001, 2002, 2003, 2005, 2006 Free Software Foundation, Inc. ;; Copyright (C) 2001, 2002, 2003, 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
@ -350,14 +350,6 @@
(let ((run-time (get-internal-run-time))) (let ((run-time (get-internal-run-time)))
(make-time (make-time
time-process time-process
(quotient run-time internal-time-units-per-second)
(* (remainder run-time internal-time-units-per-second)
priv:ns-per-guile-tick))))
(define (priv:current-time-process)
(let ((run-time (get-internal-run-time)))
(list
'time-process
(* (remainder run-time internal-time-units-per-second) (* (remainder run-time internal-time-units-per-second)
priv:ns-per-guile-tick) priv:ns-per-guile-tick)
(quotient run-time internal-time-units-per-second)))) (quotient run-time internal-time-units-per-second))))
@ -819,10 +811,12 @@
(hour (date-hour date)) (hour (date-hour date))
(day (date-day date)) (day (date-day date))
(month (date-month date)) (month (date-month date))
(year (date-year date))) (year (date-year date))
(offset (date-zone-offset date)))
(+ (priv:encode-julian-day-number day month year) (+ (priv:encode-julian-day-number day month year)
(- 1/2) (- 1/2)
(+ (/ (+ (* hour 60 60) (+ (/ (+ (- offset)
(* hour 60 60)
(* minute 60) (* minute 60)
second second
(/ nanosecond priv:nano)) (/ nanosecond priv:nano))

228
srfi/srfi-37.scm Normal file
View file

@ -0,0 +1,228 @@
;;; srfi-37.scm --- args-fold
;; 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
;;; Commentary:
;;
;; To use this module with Guile, use (cdr (program-arguments)) as
;; the ARGS argument to `args-fold'. Here is a short example:
;;
;; (args-fold (cdr (program-arguments))
;; (let ((display-and-exit-proc
;; (lambda (msg)
;; (lambda (opt name arg)
;; (display msg) (quit) (values)))))
;; (list (option '(#\v "version") #f #f
;; (display-and-exit-proc "Foo version 42.0\n"))
;; (option '(#\h "help") #f #f
;; (display-and-exit-proc
;; "Usage: foo scheme-file ..."))))
;; (lambda (opt name arg)
;; (error "Unrecognized option `~A'" name))
;; (lambda (op) (load op) (values)))
;;
;;; Code:
;;;; Module definition & exports
(define-module (srfi srfi-37)
#:use-module (srfi srfi-9)
#:export (option option-names option-required-arg?
option-optional-arg? option-processor
args-fold))
(cond-expand-provide (current-module) '(srfi-37))
;;;; args-fold and periphery procedures
;;; An option as answered by `option'. `names' is a list of
;;; characters and strings, representing associated short-options and
;;; long-options respectively that should use this option's
;;; `processor' in an `args-fold' call.
;;;
;;; `required-arg?' and `optional-arg?' are mutually exclusive
;;; booleans and indicate whether an argument must be or may be
;;; provided. Besides the obvious, this affects semantics of
;;; short-options, as short-options with a required or optional
;;; argument cannot be followed by other short options in the same
;;; program-arguments string, as they will be interpreted collectively
;;; as the option's argument.
;;;
;;; `processor' is called when this option is encountered. It should
;;; accept the containing option, the element of `names' (by `equal?')
;;; encountered, the option's argument (or #f if none), and the seeds
;;; as variadic arguments, answering the new seeds as values.
(define-record-type srfi-37:option
(option names required-arg? optional-arg? processor)
option?
(names option-names)
(required-arg? option-required-arg?)
(optional-arg? option-optional-arg?)
(processor option-processor))
(define (error-duplicate-option option-name)
(scm-error 'program-error "args-fold"
"Duplicate option name `~A~A'"
(list (if (char? option-name) #\- "--")
option-name)
#f))
(define (build-options-lookup options)
"Answer an `equal?' Guile hash-table that maps OPTIONS' names back
to the containing options, signalling an error if a name is
encountered more than once."
(let ((lookup (make-hash-table (* 2 (length options)))))
(for-each
(lambda (opt)
(for-each (lambda (name)
(let ((assoc (hash-create-handle!
lookup name #f)))
(if (cdr assoc)
(error-duplicate-option (car assoc))
(set-cdr! assoc opt))))
(option-names opt)))
options)
lookup))
(define (args-fold args options unrecognized-option-proc
operand-proc . seeds)
"Answer the results of folding SEEDS as multiple values against the
program-arguments in ARGS, as decided by the OPTIONS'
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
(let ((lookup (build-options-lookup options)))
;; I don't like Guile's `error' here
(define (error msg . args)
(scm-error 'misc-error "args-fold" msg args #f))
(define (mutate-seeds! procedure . params)
(set! seeds (call-with-values
(lambda ()
(apply procedure (append params seeds)))
list)))
;; Clean up the rest of ARGS, assuming they're all operands.
(define (rest-operands)
(for-each (lambda (arg) (mutate-seeds! operand-proc arg))
args)
(set! args '()))
;; Call OPT's processor with OPT, NAME, an argument to be decided,
;; and the seeds. Depending on OPT's *-arg? specification, get
;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
;; if no argument is allowed, call NO-ARG-PROC thunk.
(define (invoke-option-processor
opt name req-arg-proc opt-arg-proc no-arg-proc)
(mutate-seeds!
(option-processor opt) opt name
(cond ((option-required-arg? opt) (req-arg-proc))
((option-optional-arg? opt) (opt-arg-proc))
(else (no-arg-proc) #f))))
;; Compute and answer a short option argument, advancing ARGS as
;; necessary, for the short option whose character is at POSITION
;; in the current ARG.
(define (short-option-argument position)
(cond ((< (1+ position) (string-length (car args)))
(let ((result (substring (car args) (1+ position))))
(set! args (cdr args))
result))
((pair? (cdr args))
(let ((result (cadr args)))
(set! args (cddr args))
result))
(else #f)))
;; Interpret the short-option at index POSITION in (car ARGS),
;; followed by the remaining short options in (car ARGS).
(define (short-option position)
(if (>= position (string-length (car args)))
(next-arg)
(let* ((opt-name (string-ref (car args) position))
(option-here (hash-ref lookup opt-name)))
(cond ((not option-here)
(mutate-seeds! unrecognized-option-proc
(option (list opt-name) #f #f
unrecognized-option-proc)
opt-name #f)
(short-option (1+ position)))
(else
(invoke-option-processor
option-here opt-name
(lambda ()
(or (short-option-argument position)
(error "Missing required argument after `-~A'" opt-name)))
(lambda ()
;; edge case: -xo -zf or -xo -- where opt-name=#\o
;; GNU getopt_long resolves these like I do
(short-option-argument position))
(lambda () #f))
(if (not (or (option-required-arg? option-here)
(option-optional-arg? option-here)))
(short-option (1+ position))))))))
;; Process the long option in (car ARGS). We make the
;; interesting, possibly non-standard assumption that long option
;; names might contain #\=, so keep looking for more #\= in (car
;; ARGS) until we find a named option in lookup.
(define (long-option)
(let ((arg (car args)))
(let place-=-after ((start-pos 2))
(let* ((index (string-index arg #\= start-pos))
(opt-name (substring arg 2 (or index (string-length arg))))
(option-here (hash-ref lookup opt-name)))
(if (not option-here)
;; look for a later #\=, unless there can't be one
(if index
(place-=-after (1+ index))
(mutate-seeds!
unrecognized-option-proc
(option (list opt-name) #f #f unrecognized-option-proc)
opt-name #f))
(invoke-option-processor
option-here opt-name
(lambda ()
(if index
(substring arg (1+ index))
(error "Missing required argument after `--~A'" opt-name)))
(lambda () (and index (substring arg (1+ index))))
(lambda ()
(if index
(error "Extraneous argument after `--~A'" opt-name))))))))
(set! args (cdr args)))
;; Process the remaining in ARGS. Basically like calling
;; `args-fold', but without having to regenerate `lookup' and the
;; funcs above.
(define (next-arg)
(if (null? args)
(apply values seeds)
(let ((arg (car args)))
(cond ((or (not (char=? #\- (string-ref arg 0)))
(= 1 (string-length arg))) ;"-"
(mutate-seeds! operand-proc arg)
(set! args (cdr args)))
((char=? #\- (string-ref arg 1))
(if (= 2 (string-length arg)) ;"--"
(begin (set! args (cdr args)) (rest-operands))
(long-option)))
(else (short-option 1)))
(next-arg))))
(next-arg)))
;;; srfi-37.scm ends here

101
test-suite/ChangeLog
View file

@ -1,3 +1,90 @@
2007-07-22 Ludovic Courtès <ludo@gnu.org>
* tests/reader.test: Added a proper header and `define-module'.
(exception:unterminated-block-comment,
exception:unknown-character-name,
exception:unknown-sharp-object, exception:eof-in-string,
exception:illegal-escape, with-read-options): New.
(reading)[block comment, unprintable symbol]: New tests.
(exceptions): New test prefix.
(read-options): New test prefix.
2007-07-18 Stephen Compall <s11@member.fsf.org>
* tests/syntax.test: Add SRFI-61 `cond' tests.
* tests/srfi-37.test: New file.
* Makefile.am: Add it.
2007-07-11 Ludovic Courtès <ludo@gnu.org>
* tests/goops.test (defining methods): New test prefix.
2007-07-09 Ludovic Courtès <ludo@gnu.org>
* tests/srfi-19.test (`time-utc->julian-day' honors timezone):
New. Suggested by Jon Wilson <j85wilson@fastmail.fm>.
2007-06-26 Ludovic Courtès <ludo@gnu.org>
* tests/socket.test (htonl): Only executed if `htonl' is defined.
(ntohl): Likewise. Reported by Marijn Schouten (hkBst)
<hkBst@gentoo.org>.
2007-06-12 Ludovic Courtès <ludo@chbouib.org>
* tests/socket.test: Renamed module to `(test-suite test-socket)'.
(inet-ntop): New test prefix.
2007-06-07 Ludovic Courtès <ludovic.courtes@laas.fr>
* lib.scm (exception:system-error): New variable.
* tests/posix.test (ttyname): New test prefix. Catches a bug
reported by Dan McMahill.
2007-05-26 Ludovic Courtès <ludo@chbouib.org>
* tests/syntax.test (top-level define)[binding is created before
expression is evaluated]: Moved to "internal define", using `let'
instead of `begin'. The test was not necessarily valid for
top-level defines, according to Section 5.2.1 or R5RS.
[redefinition]: New.
2007-05-09 Ludovic Courtès <ludo@chbouib.org>
* tests/srfi-19.test ((current-time time-tai) works): Use `time?'.
((current-time time-process) works): New test, catches a bug
reported by Scott Shedden.
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
* tests/modules.test: Use `define-module'. Use `(srfi srfi-1)'.
(foundations, observers, duplicate bindings, lazy binder): New
test prefixes.
(autoload)[module-autoload!]: New test.
2007-03-08 Kevin Ryde <user42@zip.com.au>
* tests/structs.test (make-struct): Exercise the error check on tail
array size != 0 when layout spec doesn't have tail array.
(make-vtable): Exercise this.
2007-02-22 Kevin Ryde <user42@zip.com.au>
* tests/structs.test (make-struct): New test of type check on a "u"
field, which had been causing an abort().
2007-02-20 Neil Jerram <neil@ossau.uklinux.net>
* standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so
that it gets into the distribution.
2007-02-19 Neil Jerram <neil@ossau.uklinux.net>
* standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so
that it gets into the distribution.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/i18n.test: Use `(srfi srfi-1)'. * tests/i18n.test: Use `(srfi srfi-1)'.
@ -13,6 +100,20 @@
(SRFI date/time library)[string->date understands days and (SRFI date/time library)[string->date understands days and
months]: New test. months]: New test.
2007-01-27 Kevin Ryde <user42@zip.com.au>
* tests/ports.test (port-line): Check not truncated to "int" on 64-bit
systems.
2007-01-25 Kevin Ryde <user42@zip.com.au>
* tests/sort.test (stable-sort): New test, exercising empty list
input. As reported by Ales Hvezda.
* tests/time.test (gmtime in another thread): Catch #t all errors from
gmtime in the thread, since it can be a system error not a scheme
out-of-range on 64-bit systems. Reported by Marijn Schouten.
2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/eval.test (values): New test prefix. Values are structs, * tests/eval.test (values): New test prefix. Values are structs,

1
test-suite/Makefile.am
View file

@ -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-37.test \
tests/srfi-39.test \ tests/srfi-39.test \
tests/srfi-60.test \ tests/srfi-60.test \
tests/srfi-4.test \ tests/srfi-4.test \

3
test-suite/lib.scm
View file

@ -29,6 +29,7 @@
exception:wrong-num-args exception:wrong-type-arg exception:wrong-num-args exception:wrong-type-arg
exception:numerical-overflow exception:numerical-overflow
exception:struct-set!-denied exception:struct-set!-denied
exception:system-error
exception:miscellaneous-error exception:miscellaneous-error
exception:string-contains-nul exception:string-contains-nul
@ -257,6 +258,8 @@
(cons 'numerical-overflow "^Numerical overflow")) (cons 'numerical-overflow "^Numerical overflow"))
(define exception:struct-set!-denied (define exception:struct-set!-denied
(cons 'misc-error "^set! denied for field")) (cons 'misc-error "^set! denied for field"))
(define exception:system-error
(cons 'system-error ".*"))
(define exception:miscellaneous-error (define exception:miscellaneous-error
(cons 'misc-error "^.*")) (cons 'misc-error "^.*"))

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

@ -104,6 +104,7 @@ check_PROGRAMS += test-conversion
TESTS += test-conversion TESTS += test-conversion
# test-use-srfi # test-use-srfi
check_SCRIPTS += test-use-srfi
TESTS += test-use-srfi TESTS += test-use-srfi
all-local: all-local:

33
test-suite/tests/goops.test
View file

@ -177,6 +177,39 @@
(null? (generic-function-methods foo))) (null? (generic-function-methods foo)))
(current-module))))) (current-module)))))
(with-test-prefix "defining methods"
(pass-if "define-method"
(let ((m (current-module)))
(eval '(define-method (my-plus (s1 <string>) (s2 <string>))
(string-append s1 s2))
m)
(eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
(+ i1 i2))
m)
(eval '(and (is-a? my-plus <generic>)
(= (length (generic-function-methods my-plus))
2))
m)))
(pass-if "method-more-specific?"
(eval '(let* ((m+ (generic-function-methods my-plus))
(m1 (car m+))
(m2 (cadr m+))
(arg-types (list <string> <string>)))
(if (memq <string> (method-specializers m1))
(method-more-specific? m1 m2 arg-types)
(method-more-specific? m2 m1 arg-types)))
(current-module)))
(pass-if-exception "method-more-specific? (failure)"
exception:wrong-type-arg
(eval '(let* ((m+ (generic-function-methods my-plus))
(m1 (car m+))
(m2 (cadr m+)))
(method-more-specific? m1 m2 '()))
(current-module))))
(with-test-prefix "defining accessors" (with-test-prefix "defining accessors"
(with-test-prefix "define-accessor" (with-test-prefix "define-accessor"

271
test-suite/tests/modules.test
View file

@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
;;;; Copyright (C) 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 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
@ -16,10 +16,277 @@
;;;; License along with this library; if not, write to the Free Software ;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib)) (define-module (test-suite test-modules)
:use-module (srfi srfi-1)
:use-module ((ice-9 streams) ;; for test purposes
#:renamer (symbol-prefix-proc 's:))
:use-module (test-suite lib))
(define (every? . args)
(not (not (apply every args))))
;;;
;;; Foundations.
;;;
(with-test-prefix "foundations"
(pass-if "module-add!"
(let ((m (make-module))
(value (cons 'x 'y)))
(module-add! m 'something (make-variable value))
(eq? (module-ref m 'something) value)))
(pass-if "module-define!"
(let ((m (make-module))
(value (cons 'x 'y)))
(module-define! m 'something value)
(eq? (module-ref m 'something) value)))
(pass-if "module-use!"
(let ((m (make-module))
(import (make-module)))
(module-define! m 'something 'something)
(module-define! import 'imported 'imported)
(module-use! m import)
(and (eq? (module-ref m 'something) 'something)
(eq? (module-ref m 'imported) 'imported)
(module-local-variable m 'something)
(not (module-local-variable m 'imported))
#t)))
(pass-if "module-use! (duplicates local binding)"
;; Imported bindings can't override locale bindings.
(let ((m (make-module))
(import (make-module)))
(module-define! m 'something 'something)
(module-define! import 'something 'imported)
(module-use! m import)
(eq? (module-ref m 'something) 'something)))
(pass-if "module-locally-bound?"
(let ((m (make-module))
(import (make-module)))
(module-define! m 'something #t)
(module-define! import 'imported #t)
(module-use! m import)
(and (module-locally-bound? m 'something)
(not (module-locally-bound? m 'imported)))))
(pass-if "module-{local-,}variable"
(let ((m (make-module))
(import (make-module)))
(module-define! m 'local #t)
(module-define! import 'imported #t)
(module-use! m import)
(and (module-local-variable m 'local)
(not (module-local-variable m 'imported))
(eq? (module-variable m 'local)
(module-local-variable m 'local))
(eq? (module-local-variable import 'imported)
(module-variable m 'imported)))))
(pass-if "module-import-interface"
(and (every? (lambda (sym iface)
(eq? (module-import-interface (current-module) sym)
iface))
'(current-module exception:bad-variable every)
(cons the-scm-module
(map resolve-interface
'((test-suite lib) (srfi srfi-1)))))
;; For renamed bindings, a custom interface is used so we can't
;; check for equality with `eq?'.
(every? (lambda (sym iface)
(let ((import
(module-import-interface (current-module) sym)))
(equal? (module-name import)
(module-name iface))))
'(s:make-stream s:stream-car s:stream-cdr)
(make-list 3 (resolve-interface '(ice-9 streams))))))
(pass-if "module-reverse-lookup"
(let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams)))
(syms '(every exception:bad-variable make-stream))
(locals '(every exception:bad-variable s:make-stream)))
(every? (lambda (var sym)
(eq? (module-reverse-lookup (current-module) var)
sym))
(map module-variable
(map resolve-interface mods)
syms)
locals))))
;;;
;;; Observers.
;;;
(with-test-prefix "observers"
(pass-if "weak observer invoked"
(let* ((m (make-module))
(invoked 0))
(module-observe-weak m (lambda (mod)
(if (eq? mod m)
(set! invoked (+ invoked 1)))))
(module-define! m 'something 2)
(module-define! m 'something-else 1)
(= invoked 2)))
(pass-if "all weak observers invoked"
;; With the two-argument `module-observe-weak' available in previous
;; versions, the observer would get unregistered as soon as the observing
;; closure gets GC'd, making it impossible to use an anonymous lambda as
;; the observing procedure.
(let* ((m (make-module))
(observer-count 500)
(observer-ids (let loop ((i observer-count)
(ids '()))
(if (= i 0)
ids
(loop (- i 1) (cons (make-module) ids)))))
(observers-invoked (make-hash-table observer-count)))
;; register weak observers
(for-each (lambda (id)
(module-observe-weak m id
(lambda (m)
(hashq-set! observers-invoked
id #t))))
observer-ids)
(gc)
;; invoke them
(module-call-observers m)
;; make sure all of them were invoked
(->bool (every (lambda (id)
(hashq-ref observers-invoked id))
observer-ids))))
(pass-if "imported bindings updated"
(let ((m (make-module))
(imported (make-module)))
;; Beautify them, notably adding them a public interface.
(beautify-user-module! m)
(beautify-user-module! imported)
(module-use! m (module-public-interface imported))
(module-define! imported 'imported-binding #t)
;; At this point, `imported-binding' is local to IMPORTED.
(and (not (module-variable m 'imported-binding))
(begin
;; Export `imported-binding' from IMPORTED.
(module-export! imported '(imported-binding))
;; Make sure it is now visible from M.
(module-ref m 'imported-binding))))))
;;;
;;; Duplicate bindings handling.
;;;
(with-test-prefix "duplicate bindings"
(pass-if "simple duplicate handler"
;; Import the same binding twice.
(let* ((m (make-module))
(import1 (make-module))
(import2 (make-module))
(handler-invoked? #f)
(handler (lambda (module name int1 val1 int2 val2 var val)
(set! handler-invoked? #t)
;; Keep the first binding.
(or var (module-local-variable int1 name)))))
(set-module-duplicates-handlers! m (list handler))
(module-define! m 'something 'something)
(set-module-name! import1 'imported-module-1)
(set-module-name! import2 'imported-module-2)
(module-define! import1 'imported 'imported-1)
(module-define! import2 'imported 'imported-2)
(module-use! m import1)
(module-use! m import2)
(and (eq? (module-ref m 'imported) 'imported-1)
handler-invoked?))))
;;;
;;; Lazy binder.
;;;
(with-test-prefix "lazy binder"
(pass-if "not invoked"
(let ((m (make-module))
(invoked? #f))
(module-define! m 'something 2)
(set-module-binder! m (lambda args (set! invoked? #t) #f))
(and (module-ref m 'something)
(not invoked?))))
(pass-if "not invoked (module-add!)"
(let ((m (make-module))
(invoked? #f))
(set-module-binder! m (lambda args (set! invoked? #t) #f))
(module-add! m 'something (make-variable 2))
(and (module-ref m 'something)
(not invoked?))))
(pass-if "invoked (module-ref)"
(let ((m (make-module))
(invoked? #f))
(set-module-binder! m (lambda args (set! invoked? #t) #f))
(false-if-exception (module-ref m 'something))
invoked?))
(pass-if "invoked (module-define!)"
(let ((m (make-module))
(invoked? #f))
(set-module-binder! m (lambda args (set! invoked? #t) #f))
(module-define! m 'something 2)
(and invoked?
(eq? (module-ref m 'something) 2))))
(pass-if "honored (ref)"
(let ((m (make-module))
(invoked? #f)
(value (cons 'x 'y)))
(set-module-binder! m
(lambda (mod sym define?)
(set! invoked? #t)
(cond ((not (eq? m mod))
(error "invalid module" mod))
(define?
(error "DEFINE? shouldn't be set"))
(else
(make-variable value)))))
(and (eq? (module-ref m 'something) value)
invoked?))))
;;;
;;; Higher-level features.
;;;
(with-test-prefix "autoload" (with-test-prefix "autoload"
(pass-if "module-autoload!"
(let ((m (make-module)))
(module-autoload! m '(ice-9 q) '(make-q))
(not (not (module-ref m 'make-q)))))
(pass-if "autoloaded" (pass-if "autoloaded"
(catch #t (catch #t
(lambda () (lambda ()

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

@ -1,7 +1,7 @@
;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- ;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;; ;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2001, 2004, 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
@ -538,6 +538,17 @@
(while (not (eof-object? (read-char port)))) (while (not (eof-object? (read-char port))))
(= 8 (port-column port)))))) (= 8 (port-column port))))))
(with-test-prefix "port-line"
;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
;; scm_t_port actually holds a long; this restricted the range on 64-bit
;; systems
(pass-if "set most-positive-fixnum/2"
(let ((n (quotient most-positive-fixnum 2))
(port (open-output-string)))
(set-port-line! port n)
(eqv? n (port-line port)))))
;;; ;;;
;;; seek ;;; seek
;;; ;;;

21
test-suite/tests/posix.test
View file

@ -1,6 +1,6 @@
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*- ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;; ;;;;
;;;; Copyright 2003, 2004, 2006 Free Software Foundation, Inc. ;;;; Copyright 2003, 2004, 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
@ -17,7 +17,8 @@
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA ;;;; Boston, MA 02110-1301 USA
(use-modules (test-suite lib)) (define-module (test-suite test-posix)
:use-module (test-suite lib))
;; FIXME: The following exec tests are disabled since on an i386 debian with ;; FIXME: The following exec tests are disabled since on an i386 debian with
@ -145,3 +146,19 @@
(putenv "FOO=") (putenv "FOO=")
(unsetenv "FOO") (unsetenv "FOO")
(not (getenv "FOO")))) (not (getenv "FOO"))))
;;
;; ttyname
;;
(with-test-prefix "ttyname"
(pass-if-exception "non-tty argument" exception:system-error
;; This used to crash in 1.8.1 and earlier.
(let ((file (false-if-exception
(open-output-file "/dev/null"))))
(if (not file)
(throw 'unsupported)
(ttyname file)))))

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

@ -1,15 +1,55 @@
;;;; reader.test --- test the Guile parser -*- scheme -*- ;;;; reader.test --- Exercise the reader. -*- Scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;;
;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; 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
(define-module (test-suite reader)
:use-module (test-suite lib))
(define exception:eof (define exception:eof
(cons 'read-error "end of file$")) (cons 'read-error "end of file$"))
(define exception:unexpected-rparen (define exception:unexpected-rparen
(cons 'read-error "unexpected \")\"$")) (cons 'read-error "unexpected \")\"$"))
(define exception:unterminated-block-comment
(cons 'read-error "unterminated `#! ... !#' comment$"))
(define exception:unknown-character-name
(cons 'read-error "unknown character name .*$"))
(define exception:unknown-sharp-object
(cons 'read-error "Unknown # object: .*$"))
(define exception:eof-in-string
(cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
(define (read-string s) (define (read-string s)
(with-input-from-string s (lambda () (read)))) (with-input-from-string s (lambda () (read))))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
(dynamic-wind
(lambda ()
(read-options opts))
thunk
(lambda ()
(read-options saved-options)))))
(with-test-prefix "reading" (with-test-prefix "reading"
(pass-if "0" (pass-if "0"
(equal? (read-string "0") 0)) (equal? (read-string "0") 0))
@ -31,8 +71,18 @@
(lambda (key subr message args rest) (lambda (key subr message args rest)
(apply format #f message args) (apply format #f message args)
;; message and args are ok ;; message and args are ok
#t)))) #t)))
(pass-if "block comment"
(equal? '(+ 1 2 3)
(read-string "(+ 1 #! this is a\ncomment !# 2 3)")))
(pass-if "unprintable symbol"
;; The reader tolerates unprintable characters for symbols.
(equal? (string->symbol "\001\002\003")
(read-string "\001\002\003"))))
(pass-if-exception "radix passed to number->string can't be zero" (pass-if-exception "radix passed to number->string can't be zero"
exception:out-of-range exception:out-of-range
(number->string 10 0)) (number->string 10 0))
@ -40,6 +90,7 @@
exception:out-of-range exception:out-of-range
(number->string 10 1)) (number->string 10 1))
(with-test-prefix "mismatching parentheses" (with-test-prefix "mismatching parentheses"
(pass-if-exception "opening parenthesis" (pass-if-exception "opening parenthesis"
exception:eof exception:eof
@ -53,3 +104,53 @@
(pass-if-exception "closing parenthesis following mismatched vector opening" (pass-if-exception "closing parenthesis following mismatched vector opening"
exception:unexpected-rparen exception:unexpected-rparen
(read-string ")"))) (read-string ")")))
(with-test-prefix "exceptions"
;; Reader exceptions: although they are not documented, they may be relied
;; on by some programs, hence these tests.
(pass-if-exception "unterminated block comment"
exception:unterminated-block-comment
(read-string "(+ 1 #! comment\n..."))
(pass-if-exception "unknown character name"
exception:unknown-character-name
(read-string "#\\theunknowncharacter"))
(pass-if-exception "unknown sharp object"
exception:unknown-sharp-object
(read-string "#?"))
(pass-if-exception "eof in string"
exception:eof-in-string
(read-string "\"the string that never ends"))
(pass-if-exception "illegal escape in string"
exception:illegal-escape
(read-string "\"some string \\???\"")))
(with-test-prefix "read-options"
(pass-if "case-sensitive"
(not (eq? 'guile 'GuiLe)))
(pass-if "case-insensitive"
(eq? 'guile
(with-read-options '(case-insensitive)
(lambda ()
(read-string "GuiLe")))))
(pass-if "prefix keywords"
(eq? #:keyword
(with-read-options '(keywords prefix case-insensitive)
(lambda ()
(read-string ":KeyWord")))))
(pass-if "no positions"
(let ((sexp (with-read-options '()
(lambda ()
(read-string "(+ 1 2 3)")))))
(and (not (source-property sexp 'line))
(not (source-property sexp 'column)))))
(pass-if "positions"
(let ((sexp (with-read-options '(positions)
(lambda ()
(read-string "(+ 1 2 3)")))))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))

26
test-suite/tests/socket.test
View file

@ -1,6 +1,6 @@
;;;; socket.test --- test socket functions -*- scheme -*- ;;;; socket.test --- test socket functions -*- scheme -*-
;;;; ;;;;
;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 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
@ -16,7 +16,7 @@
;;;; License along with this library; if not, write to the Free Software ;;;; License along with this library; if not, write to the Free Software
;;;; 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-module (test-suite test-numbers) (define-module (test-suite test-socket)
#:use-module (test-suite lib)) #:use-module (test-suite lib))
@ -25,6 +25,7 @@
;;; htonl ;;; htonl
;;; ;;;
(if (defined? 'htonl)
(with-test-prefix "htonl" (with-test-prefix "htonl"
(pass-if "0" (eqv? 0 (htonl 0))) (pass-if "0" (eqv? 0 (htonl 0)))
@ -38,7 +39,7 @@
(htonl (ash 1 32))) (htonl (ash 1 32)))
(pass-if-exception "2^1024" exception:out-of-range (pass-if-exception "2^1024" exception:out-of-range
(htonl (ash 1 1024)))) (htonl (ash 1 1024)))))
;;; ;;;
@ -101,6 +102,22 @@
(inet-pton AF_INET6 (inet-pton AF_INET6
"0000:0000:0000:0000:0000:0000:0000:00F0")))))) "0000:0000:0000:0000:0000:0000:0000:00F0"))))))
(if (defined? 'inet-ntop)
(with-test-prefix "inet-ntop"
(with-test-prefix "ipv4"
(pass-if "127.0.0.1"
(equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))
(if (defined? 'AF_INET6)
(with-test-prefix "ipv6"
(pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
(string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
(inet-ntop AF_INET6 (- (expt 2 128) 1))))
(pass-if "::1"
(equal? "::1" (inet-ntop AF_INET6 1)))))))
;;; ;;;
;;; make-socket-address ;;; make-socket-address
@ -135,6 +152,7 @@
;;; ntohl ;;; ntohl
;;; ;;;
(if (defined? 'ntohl)
(with-test-prefix "ntohl" (with-test-prefix "ntohl"
(pass-if "0" (eqv? 0 (ntohl 0))) (pass-if "0" (eqv? 0 (ntohl 0)))
@ -148,7 +166,7 @@
(ntohl (ash 1 32))) (ntohl (ash 1 32)))
(pass-if-exception "2^1024" exception:out-of-range (pass-if-exception "2^1024" exception:out-of-range
(ntohl (ash 1 1024)))) (ntohl (ash 1 1024)))))

15
test-suite/tests/sort.test
View file

@ -1,5 +1,5 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*- ;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 2003, 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
@ -63,3 +63,16 @@
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000) (randomize-vector! v 1000)
(sorted? (stable-sort! v <) <)))) (sorted? (stable-sort! v <) <))))
;;;
;;; stable-sort
;;;
(with-test-prefix "stable-sort"
;; in guile 1.8.0 and 1.8.1 this test failed, an empty list provoked a
;; wrong-type-arg exception (where it shouldn't)
(pass-if "empty list"
(eq? '() (stable-sort '() <))))

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

@ -1,7 +1,7 @@
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 2001, 2003, 2004, 2005, 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
@ -109,7 +109,9 @@ incomplete numerical tower implementation.)"
add-duration add-duration
#t)) #t))
(pass-if "(current-time time-tai) works" (pass-if "(current-time time-tai) works"
(begin (current-time time-tai) #t)) (time? (current-time time-tai)))
(pass-if "(current-time time-process) works"
(time? (current-time time-process)))
(test-time-conversion time-utc time-tai) (test-time-conversion time-utc time-tai)
(test-time-conversion time-utc time-monotonic) (test-time-conversion time-utc time-monotonic)
(test-time-conversion time-tai time-monotonic) (test-time-conversion time-tai time-monotonic)
@ -139,6 +141,12 @@ incomplete numerical tower implementation.)"
(test-dst time-monotonic->date date->time-monotonic) (test-dst time-monotonic->date date->time-monotonic)
(test-dst julian-day->date date->julian-day) (test-dst julian-day->date date->julian-day)
(test-dst modified-julian-day->date date->modified-julian-day) (test-dst modified-julian-day->date date->modified-julian-day)
(pass-if "`date->julian-day' honors timezone"
(let ((now (current-date -14400)))
(time=? (date->time-utc (julian-day->date (date->julian-day now)))
(date->time-utc now))))
(pass-if "string->date respects local DST if no time zone is read" (pass-if "string->date respects local DST if no time zone is read"
(time=? (date->time-utc (time=? (date->time-utc
(with-tz "EST5EDT" (with-tz "EST5EDT"

97
test-suite/tests/srfi-37.test Normal file
View file

@ -0,0 +1,97 @@
;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
;;;;
;;;; 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-37)
#:use-module (test-suite lib)
#:use-module (srfi srfi-37))
(with-test-prefix "SRFI-37"
(pass-if "empty calls with count-modified seeds"
(equal? (list 21 42)
(call-with-values
(lambda ()
(args-fold '("1" "3" "4") '()
(lambda (opt name arg seed seed2)
(values 1 2))
(lambda (op seed seed2)
(values (1+ seed) (+ 2 seed2)))
18 36))
list)))
(pass-if "short opt params"
(let ((a-set #f) (b-set #f) (c-val #f) (d-val #f) (no-fail #t) (no-operands #t))
(args-fold '("-abcdoit" "-ad" "whatev")
(list (option '(#\a) #f #f (lambda (opt name arg)
(set! a-set #t)
(values)))
(option '(#\b) #f #f (lambda (opt name arg)
(set! b-set #t)
(values)))
(option '("cdoit" #\c) #f #t
(lambda (opt name arg)
(set! c-val arg)
(values)))
(option '(#\d) #f #t
(lambda (opt name arg)
(set! d-val arg)
(values))))
(lambda (opt name arg) (set! no-fail #f) (values))
(lambda (oper) (set! no-operands #f) (values)))
(equal? '(#t #t "doit" "whatev" #t #t)
(list a-set b-set c-val d-val no-fail no-operands))))
(pass-if "single unrecognized long-opt"
(equal? "fake"
(args-fold '("--fake" "-i2")
(list (option '(#\i) #t #f
(lambda (opt name arg k) k)))
(lambda (opt name arg k) name)
(lambda (operand k) #f)
#f)))
(pass-if "long req'd/optional"
(equal? '(#f "bsquare" "apple")
(args-fold '("--x=pple" "--y=square" "--y")
(list (option '("x") #t #f
(lambda (opt name arg k)
(cons (string-append "a" arg) k)))
(option '("y") #f #t
(lambda (opt name arg k)
(cons (if arg
(string-append "b" arg)
#f) k))))
(lambda (opt name arg k) #f)
(lambda (opt name arg k) #f)
'())))
;; this matches behavior of getopt_long in libc 2.4
(pass-if "short options absorb special markers in the next arg"
(let ((arg-proc (lambda (opt name arg k)
(acons name arg k))))
(equal? '((#\y . "-z") (#\x . "--") (#\z . #f))
(args-fold '("-zx" "--" "-y" "-z" "--")
(list (option '(#\x) #f #t arg-proc)
(option '(#\z) #f #f arg-proc)
(option '(#\y) #t #f arg-proc))
(lambda (opt name arg k) #f)
(lambda (opt name arg k) #f)
'()))))
)

54
test-suite/tests/structs.test
View file

@ -102,6 +102,60 @@
(equal? (make-ball red "Bob") (make-ball red "Bill")))))) (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
;;
;; make-struct
;;
(define exception:bad-tail
(cons 'misc-error "tail array not allowed unless"))
(with-test-prefix "make-struct"
;; in guile 1.8.1 and earlier, this caused an error throw out of an
;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
;; the program
;;
(pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
(let* ((vv (make-vtable-vtable "" 0))
(v (make-struct vv 0 (make-struct-layout "uw"))))
(make-struct v 0 'x)))
;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
;; on a tail array being created without an R/W/O type for it. This left
;; it uninitialized by scm_struct_init(), resulting in garbage getting
;; into an SCM when struct-ref read it (and attempting to print a garbage
;; SCM can cause a segv).
;;
(pass-if-exception "no R/W/O for tail array" exception:bad-tail
(let* ((vv (make-vtable-vtable "" 0))
(v (make-struct vv 0 (make-struct-layout "pw"))))
(make-struct v 123 'x))))
;;
;; make-vtable
;;
(with-test-prefix "make-vtable"
(pass-if "without printer"
(let* ((vtable (make-vtable "pwpr"))
(struct (make-struct vtable 0 'x 'y)))
(and (eq? 'x (struct-ref struct 0))
(eq? 'y (struct-ref struct 1)))))
(pass-if "with printer"
(let ()
(define (print struct port)
(display "hello" port))
(let* ((vtable (make-vtable "pwpr" print))
(struct (make-struct vtable 0 'x 'y))
(str (call-with-output-string
(lambda (port)
(display struct port)))))
(equal? str "hello")))))
;;; Local Variables: ;;; Local Variables:
;;; coding: latin-1 ;;; coding: latin-1
;;; End: ;;; End:

74
test-suite/tests/syntax.test
View file

@ -557,6 +557,50 @@
(let ((=> 'foo)) (let ((=> 'foo))
(eq? (cond (else => identity)) identity))))) (eq? (cond (else => identity)) identity)))))
(with-test-prefix "SRFI-61"
(pass-if "always available"
(cond-expand (srfi-61 #t) (else #f)))
(pass-if "single value consequent"
(eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
(pass-if "single value alternate"
(eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
(pass-if-exception "doesn't affect standard =>"
exception:wrong-num-args
(cond ((values 1 2) => (lambda (x y) #t))))
(pass-if "multiple values consequent"
(equal? '(2 1) (cond ((values 1 2)
(lambda (one two)
(and (= 1 one) (= 2 two))) =>
(lambda (one two) (list two one)))
(else #f))))
(pass-if "multiple values alternate"
(eq? 'ok (cond ((values 2 3 4)
(lambda args (equal? '(1 2 3) args)) =>
(lambda (x y z) #f))
(else 'ok))))
(pass-if "zero values"
(eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
(else #f))))
(pass-if "bound => is handled correctly"
(let ((=> 'ok))
(eq? 'ok (cond (#t identity =>) (else #f)))))
(pass-if-exception "missing recipient"
'(syntax-error . "Missing recipient")
(cond (#t identity =>)))
(pass-if-exception "extra recipient"
'(syntax-error . "Extra expression")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization" (with-test-prefix "unmemoization"
(pass-if "normal clauses" (pass-if "normal clauses"
@ -725,15 +769,16 @@
(with-test-prefix "top-level define" (with-test-prefix "top-level define"
(pass-if "binding is created before expression is evaluated" (pass-if "redefinition"
(= (eval '(begin (let ((m (make-module)))
(define foo (beautify-user-module! m)
(begin
(set! foo 1) ;; The previous value of `round' must still be visible at the time the
(+ foo 1))) ;; new `round' is defined. According to R5RS (Section 5.2.1), `define'
foo) ;; should behave like `set!' in this case (except that in the case of
(interaction-environment)) ;; Guile, we respect module boundaries).
2)) (eval '(define round round) m)
(eq? (module-ref m 'round) round)))
(with-test-prefix "currying" (with-test-prefix "currying"
@ -780,6 +825,17 @@
(eq? 'c (a 2) (a 5)))) (eq? 'c (a 2) (a 5))))
(interaction-environment))) (interaction-environment)))
(pass-if "binding is created before expression is evaluated"
;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
(= (eval '(let ()
(define foo
(begin
(set! foo 1)
(+ foo 1)))
foo)
(interaction-environment))
2))
(pass-if "internal defines with begin" (pass-if "internal defines with begin"
(false-if-exception (false-if-exception
(eval '(let ((a identity) (b identity) (c identity)) (eval '(let ((a identity) (b identity) (c identity))

4
test-suite/tests/time.test
View file

@ -1,7 +1,7 @@
;;;; time.test --- test suite for Guile's time functions -*- scheme -*- ;;;; time.test --- test suite for Guile's time functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004 ;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004
;;;; ;;;;
;;;; Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2004, 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
@ -34,7 +34,7 @@
(alarm 5) (alarm 5)
(false-if-exception (gmtime t)) (false-if-exception (gmtime t))
(join-thread (begin-thread (catch 'out-of-range (join-thread (begin-thread (catch #t
(lambda () (gmtime t)) (lambda () (gmtime t))
(lambda args #f)))) (lambda args #f))))
(alarm 0) (alarm 0)