mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +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-env
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>
* 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).
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
@ -15,20 +84,29 @@
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.
* 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>
* .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>
* 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.
##
## 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.
##
@ -33,7 +33,7 @@ include_HEADERS = libguile.h
# automake sometimes forgets to distribute acconfig.h,
# apparently depending on the phase of the moon.
EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS config.rpath
EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS
TESTS = check-guile

36
NEWS
View file

@ -1,5 +1,5 @@
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.
Please send Guile bug reports to bug-guile@gnu.org. Note that you
@ -16,17 +16,31 @@ Each release reports the NEWS in the following sections:
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 stand-alone interpreter
* Changes to Scheme functions and syntax
** 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.
** Duplicate bindings among used modules are resolved lazily.
This slightly improves program startup times.
* Changes to the C interface
** Functions for handling scm_option now no longer require an argument
indicating length of the scm_t_option array.
** Functions for handling `scm_option' now no longer require an argument
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):
@ -34,6 +48,7 @@ Changes in 1.8.2 (since 1.8.1):
* New procedures (see the manual for details)
** set-program-arguments
** make-vtable
* Bugs fixed
@ -45,14 +60,21 @@ Changes in 1.8.2 (since 1.8.1):
the core bindings got priority, preventing SRFI replacements or
extensions.)
** `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
** Array read syntax works with negative lower bound
** `array-in-bounds?' fix if an array has different lower bounds on each index
** `*' returns exact 0 for "(* inexact 0)"
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 Mingw fixed
** Build problems on HP-UX IA64 fixed
** Build problems on MinGW fixed
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.
** `strftime' fix sign of %z timezone offset.
** A one-dimensional array can now be 'equal?' to a vector.
** 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:
Rob Browning
Ludovic Courtès
Stefan Jahn
Neil Jerram
Antoine Mathys
@ -24,11 +25,11 @@ For fixes or providing information which led to a fix:
Adrian Bunk
Michael Carmack
Stephen Compall
Ludovic Courtès
Brian Crowder
Christopher Cramer
Hyper Division
Alexandre Duret-Lutz
Nils Durner
John W Eaton
Clinton Ebadi
Charles Gagnon
@ -36,9 +37,11 @@ For fixes or providing information which led to a fix:
Eric Gillespie, Jr
John Goerzen
Mike Gran
Szavai Gyula
Sven Hartrumpf
Eric Hanchrow
Sam Hocevar
Ales Hvezda
Peter Ivanyi
Wolfgang Jaehrling
Aubrey Jaffer
@ -46,12 +49,15 @@ For fixes or providing information which led to a fix:
Steve Juranich
Richard Kim
Bruce Korb
Matthias Köppe
Matthias Köppe
Matt Kraai
Miroslav Lichvar
Jeff Long
Marco Maggi
Dan McMahill
Han-Wen Nienhuys
Jan Nieuwenhuizen
Hrvoje Nikšić
Stefan Nordhausen
Roland Orre
Pieter Pareit
@ -62,21 +68,30 @@ For fixes or providing information which led to a fix:
Carlos Pita
Ken Raeburn
Andreas Rottmann
Kevin Ryde
Hugh Sasse
Werner Scheinast
Bill Schottstaedt
Scott Shedden
Alex Shinn
Daniel Skarda
Cesar Strauss
Richard Todd
Issac Trotts
Greg Troxel
Aaron M. Ucko
Momchil Velikov
Panagiotis Vossos
Neil W. Van Dyke
Aaron VanDevender
Andreas Vögele
Andreas Vögele
Michael Talbot-Wilson
Michael Tuexen
Jon Wilson
Andy Wingo
Keith Wright
William Xu
;; Local Variables:
;; coding: utf-8
;; End:

2
acinclude.m4
View file

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

38
autogen.sh
View file

@ -1,5 +1,5 @@
#!/bin/sh
# Usage: sh -x ./autogen.sh [WORKBOOK]
# Usage: sh -x ./autogen.sh
set -e
@ -9,32 +9,16 @@ set -e
}
######################################################################
### Find workbook and make symlinks.
workbook=../workbook # assume "cvs co hack"
test x$1 = x || workbook=$1
if [ ! -d $workbook ] ; then
echo "ERROR: could not find workbook dir"
echo " re-run like so: $0 WORKBOOK"
exit 1
fi
: found workbook at $workbook
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
### announce build tool versions
echo ""
autoconf --version
echo ""
automake --version
echo ""
libtool --version
echo ""
${M4:-/usr/bin/m4} --version
echo ""
######################################################################
### update infrastructure

36
configure.in
View file

@ -4,7 +4,7 @@ dnl
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
@ -27,8 +27,15 @@ Boston, MA 02110-1301, USA.
AC_PREREQ(2.53)
AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}),
m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}),
dnl `patsubst' here deletes the newline which "echo" prints. We can't use
dnl "echo -n" since -n is not portable (see autoconf manual "Limitations of
dnl 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])
AC_CONFIG_AUX_DIR([.])
AC_CONFIG_SRCDIR(GUILE-VERSION)
@ -218,6 +225,9 @@ AC_CHECK_LIB(uca, __uc_get_ar_bsp)
AC_C_CONST
# "volatile" is used in a couple of tests below.
AC_C_VOLATILE
AC_C_INLINE
if test "$ac_cv_c_inline" != no; then
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 \
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 \
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.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
# 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:
# netdb.h - not in mingw
@ -665,6 +675,8 @@ AC_SEARCH_LIBS(crypt, crypt,
# for the principal root.
#
if test "$ac_cv_type_complex_double" = yes; then
AC_CHECK_FUNCS(cexp clog carg)
AC_CACHE_CHECK([whether csqrt is usable],
guile_cv_use_csqrt,
[AC_TRY_RUN([
@ -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.
#
AC_MSG_CHECKING([for isinf])
AC_LINK_IFELSE(
[#include <math.h>
int main () { return (isinf(0.0) != 0); }],
AC_LINK_IFELSE(AC_LANG_SOURCE(
[[#include <math.h>
volatile double x = 0.0;
int main () { return (isinf(x) != 0); }]]),
[AC_MSG_RESULT([yes])
AC_DEFINE(HAVE_ISINF, 1,
[Define to 1 if you have the `isinf' macro or function.])],
[AC_MSG_RESULT([no])])
AC_MSG_CHECKING([for isnan])
AC_LINK_IFELSE(
[#include <math.h>
int main () { return (isnan(0.0) != 0); }],
AC_LINK_IFELSE(AC_LANG_SOURCE(
[[#include <math.h>
volatile double x = 0.0;
int main () { return (isnan(x) != 0); }]]),
[AC_MSG_RESULT([yes])
AC_DEFINE(HAVE_ISNAN, 1,
[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>
* api-data.texi (Conversion): Made cross refs point to `Number
@ -13,6 +68,11 @@
* srfi-modules.texi (SRFI-19 String to date): Mention the
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>
* 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
info_TEXINFOS = guile.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/' \
> "$@"
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 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 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.
@end deffn
@deffn {Scheme Procedure} make-record-type type-name field-names
Return a @dfn{record-type descriptor}, a value representing a new data
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
representation of a record of the new type). The @var{field-names}
argument is a list of symbols naming the @dfn{fields} of a record of the
new type. It is an error if the list contains any duplicates. It is
unspecified how record-type descriptors are represented.
@deffn {Scheme Procedure} make-record-type type-name field-names [print]
Create and return a new @dfn{record-type descriptor}.
@var{type-name} is a string naming the type. Currently it's only used
in the printed representation of records, and in diagnostics.
@var{field-names} is a list of symbols naming the fields of a record
of the type. Duplicates are not allowed among these symbols.
@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
@deffn {Scheme Procedure} record-constructor rtd [field-names]
@ -2692,296 +2700,369 @@ created the type represented by @var{rtd}.
@subsection Structures
@tpindex Structures
[FIXME: this is pasted in from Tom Lord's original guile.texi and should
be reviewed]
A @dfn{structure} is a first class data type which holds Scheme values
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
@dfn{structure} is an instance of a structure type. A structure type is
itself a structure.
Structures are less abstract and more general than traditional records.
In fact, in Guile Scheme, records are implemented using structures.
Structures are lower level than records (@pxref{Records}) but have
some extra features. The vtable system allows sets of types be
constructed, with class data. The uninterpreted words can
inter-operate with C code, allowing arbitrary pointers or other values
to be stored along side usual Scheme @code{SCM} values.
@menu
* Structure Concepts:: The structure of Structures
* Structure Layout:: Defining the layout of structure types
* Structure Basics:: make-, -ref and -set! procedures for structs
* Vtables:: Accessing type-specific data
* Vtables::
* Structure Basics::
* Vtable Contents::
* Vtable Vtables::
@end menu
@node Structure Concepts
@subsubsection Structure Concepts
@node Vtables, Structure Basics, Structures, Structures
@subsubsection Vtables
A structure object consists of a handle, structure data, and a vtable.
The handle is a Scheme value which points to both the vtable and the
structure's data. Structure data is a dynamically allocated region of
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.
A vtable is a structure type, specifying its layout, and other
information. A vtable is actually itself a structure, but there's no
need to worray about that initially (@pxref{Vtable Contents}.)
When applied to structures, the @code{equal?} predicate
(@pxref{Equality}) returns @code{#t} if the two structures share a
common vtable @emph{and} all their fields satisfy @code{equal?}.
@deffn {Scheme Procedure} make-vtable fields [print]
Create a new vtable.
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{}
@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
divided up into fields. Programmers must write a layout specification
whenever a new type of structure is defined.
@item
@code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the
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}
Structure access is by field number. There is only one set of
accessors common to all structure objects.
@item @dfn{vtables}
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.
@item
@code{s} -- a self-reference. Such a field holds the @code{SCM} value
of the structure itself (a circular reference). This can be useful in
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
has no use.
@end itemize
@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:
The second letter for each field is a permission code,
@itemize @bullet{}
@item 'u' -- unprotected
The field holds binary data that is not GC protected.
@item 'p' -- protected
The field holds a Scheme value and is GC protected.
@item 's' -- self
The field holds a Scheme value and is GC protected. When a structure is
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.
@item
@code{w} -- writable, the field can be read and written.
@item
@code{r} -- read-only, the field can be read but not written.
@item
@code{o} -- opaque, the field can be neither read nor written at the
Scheme level. This can be used for fields which should only be used
from C code.
@item
@code{W},@code{R},@code{O} -- a tail array, with permissions for the
array fields as per @code{w},@code{r},@code{o}.
@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
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:
Here are some examples.
@example
; cons pairs have two writable fields of Scheme data
"pwpw"
(make-vtable "pw") ;; one writable field
(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
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
"prpw"
(make-vtable "prpw"
(lambda (struct port)
(display "#<")
(display (struct-ref 0))
(display " and ")
(display (struct-ref 1))
(display ">")))
@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.
A tail array is indicated by capitalizing the field's protection
code ('W', 'R' or 'O'). A tail-array field is replaced by
a read-only binary data field containing an array size. The array
size is determined at the time the structure is created. It is followed
by a corresponding number of fields of the type specified for the
tail array. For example, a conventional Scheme vector can be
described as:
@node Structure Basics, Vtable Contents, Vtables, Structures
@subsubsection Structure Basics
This section describes the basic procedures for working with
structures. @code{make-struct} creates a structure, and
@code{struct-ref} and @code{struct-set!} access write fields.
@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
; A vector is an arbitrary number of writable fields holding Scheme
; values:
"pW"
(define v (make-vtable "prpwpw"))
(define s (make-struct v 0 123 "abc" 456))
(struct-ref s 0) @result{} 123
(struct-ref s 1) @result{} "abc"
@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
"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
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
name is a string of type and protection codes. To create a new
structure layout, use this procedure:
@defvr {Scheme Variable} vtable-index-vtable
@defvrx {C Macro} scm_vtable_index_vtable
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
@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
strung together. The first character of each pair describes a field
type, the second a field protection. Allowed types are 'p' for
GC-protected Scheme data, 'u' for unprotected binary data, and 's' for
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.
@example
(make-struct-layout "prpW") @result{} prpW
(make-struct-layout "blah") @result{} ERROR
@end example
@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
@node Structure Basics
@subsubsection Structure Basics
This section describes the basic procedures for creating and accessing
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.)
@sp 1
Here's an extended vtable-vtable example, creating classes of
``balls''. Each class has a ``colour'', which is fixed. Instances of
those classes are created, and such each such ball has an ``owner'',
which can be changed.
@lisp
(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))
ball @result{} #<a green ball owned by Nisse>
@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

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
@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
the dynwind context is entered or left. For example, you can register
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 /
@findex 1+
@findex 1-
@rnindex abs
@rnindex floor
@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.
@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")
@deffn {Scheme Procedure} abs x
@deffnx {C Function} scm_abs (x)

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

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@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 See the file guile.texi for copying conditions.
@ -24,6 +24,7 @@
@node Ports
@subsection Ports
@cindex Port
Sequential input/output in Scheme is represented by operations on a
@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
@subsection Reading
@cindex Reading
[Generic procedures for reading from ports.]
@rnindex eof-object?
@cindex End of file object
@deffn {Scheme Procedure} eof-object? x
@deffnx {C Function} scm_eof_object_p (x)
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
@subsection Writing
@cindex Writing
[Generic procedures for writing to ports.]
@ -320,6 +324,8 @@ all open output ports. The return value is unspecified.
@node Closing
@subsection Closing
@cindex Closing ports
@cindex Port, close
@deffn {Scheme Procedure} close-port port
@deffnx {C Function} scm_close_port (port)
@ -354,6 +360,8 @@ open.
@node Random Access
@subsection Random Access
@cindex Random access, ports
@cindex Port, random access
@deffn {Scheme Procedure} 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
@subsection Line Oriented and Delimited Text
@cindex Line input/output
@cindex Port, line input/output
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
@subsection Block reading and writing
@cindex Block read/write
@cindex Port, block read/write
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
@subsection Default Ports for Input, Output and Errors
@cindex Default ports
@cindex Port, default
@rnindex current-input-port
@deffn {Scheme Procedure} current-input-port
@ -693,6 +707,8 @@ initialized with the @var{port} argument.
@node Port Types
@subsection Types of Port
@cindex Types of ports
@cindex Port, types
[Types of port; how to make them.]
@ -706,6 +722,8 @@ initialized with the @var{port} argument.
@node File Ports
@subsubsection File Ports
@cindex File port
@cindex Port, file
The following procedures are used to open file ports.
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
@subsubsection String Ports
@cindex String port
@cindex Port, string
The following allow string ports to be opened by analogy to R4R*
file port facilities:
@ -931,6 +951,8 @@ but trying to extract the file descriptor number will fail.
@node 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
accepting or delivering characters. It allows emulation of I/O ports.
@ -986,6 +1008,8 @@ For example:
@node 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
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
@subsubsection C Port Interface
@cindex C port interface
@cindex Port, C interface
This section describes how to use Scheme ports from C.
@ -1119,6 +1145,7 @@ is set.
@node Port Implementation
@subsubsection Port Implementation
@cindex Port implemenation
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 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 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.
@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
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

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
@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}
marks its end.
@var{argv}, or if it's negative then a @code{NULL} in @var{argv} marks
its end.
@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
program name after advancing @var{argv} to strip option arguments.
Eg.@:
@example
@{
char *progname = argv[0];
int i;
for (argv++; argv[0] != NULL && argv[0][0] == '-'; argv++)
@{
/* munch option ... */
@ -1409,7 +1409,7 @@ program name after advancing @var{argv} to strip option arguments.
@end example
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
once @code{scm_set_program_arguments} returns.
@end deftypefn
@ -1836,7 +1836,13 @@ specified processes.
@subsection Signals
@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
@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.
@end deffn
@deffn {Scheme Procedure} sleep i
@deffnx {C Function} scm_sleep (i)
Wait for the given number of seconds (an integer) or until a signal
arrives. The return value is zero if the time elapses or the number
of seconds remaining otherwise.
@end deffn
@deffn {Scheme Procedure} sleep secs
@deffnx {Scheme Procedure} usleep usecs
@deffnx {C Function} scm_sleep (secs)
@deffnx {C Function} scm_usleep (usecs)
Wait the given period @var{secs} seconds or @var{usecs} microseconds
(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
@deffnx {C Function} scm_usleep (i)
Sleep for @var{i} microseconds. @code{usleep} is not available on
all platforms. [FIXME: so what happens when it isn't?]
@end deffn
On most systems the process scheduler is not microsecond accurate and
the actual period slept by @code{usleep} might be rounded to a system
clock tick boundary, which might be 10 milliseconds for instance.
@deffn {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds value_seconds value_microseconds
@deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, value_seconds, value_microseconds)
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}.
See @code{scm_std_sleep} and @code{scm_std_usleep} for equivalents at
the C level (@pxref{Blocking}).
@end deffn
@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)
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},
and @code{ITIMER_PROF}.
@defvar ITIMER_REAL
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
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}.
@defvar ITIMER_VIRTUAL
A virtual-time timer, counting down while the current process is
actually using CPU. At zero it raises @code{SIGVTALRM}.
@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
@ -2872,7 +2903,7 @@ automatically, if not already bound.
@example
(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 deffn

42
doc/ref/slib.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@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 See the file guile.texi for copying conditions.
@ -27,41 +27,11 @@ slib, The SLIB Manual}). For example,
@result{} #t
@end example
Note that the following Guile core functions are overridden by
@code{(ice-9 slib)}, to implement SLIB specified semantics.
@table @code
@item delete-file
@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
A few Guile core functions are overridden by the SLIB setups; for
example the SLIB version of @code{delete-file} returns a boolean
indicating success or failure, whereas the Guile core version throws
an error for failure. In general (and as might be expected) when SLIB
is loaded it's the SLIB specifications which are followed.
@menu
* 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-26:: Specializing parameters
* SRFI-31:: A special form `rec' for recursive evaluation
* SRFI-37:: args-fold program argument processor
* SRFI-39:: Parameter objects
* SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits.
@ -2401,6 +2402,93 @@ The second syntax can be used to create anonymous recursive functions:
@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
@subsection SRFI-39 - Parameters
@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>
* readline.c: terminate option list with NULL.
@ -315,7 +325,7 @@
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.
* 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
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 */
/* 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
* 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);
add_history (s);
free (s);
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>
* gds-client.scm (connect-to-gds): Break generation of client name

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

@ -1098,18 +1098,20 @@
;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
;;; 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
;;;
;;; - observer-id
;;; - weak-observers: a weak-key hash table of procedures that get called
;;; when the module is modified. See `module-observe-weak' for details.
;;;
;;; 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
;;; to be changed in an incompatible way to permit all the basic
@ -1173,8 +1175,8 @@
(define module-type
(make-record-type 'module
'(obarray uses binder eval-closure transformer name kind
duplicates-handlers duplicates-interface
observers weak-observers observer-id)
duplicates-handlers import-obarray
observers weak-observers)
%print-module))
;; make-module &opt size uses binder
@ -1190,6 +1192,10 @@
(list-ref args index)
default))
(define %default-import-size
;; Typical number of imported bindings actually used by a module.
600)
(if (> (length args) 3)
(error "Too many args to make-module." args))
@ -1207,10 +1213,10 @@
"Lazy-binder expected to be a procedure or #f." binder))
(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)
0)))
(make-weak-key-hash-table 31))))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
@ -1240,17 +1246,13 @@
(record-accessor module-type 'duplicates-handlers))
(define set-module-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 set-module-observers! (record-modifier module-type '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-import-obarray (record-accessor module-type 'import-obarray))
(define set-module-eval-closure!
(let ((setter (record-modifier module-type 'eval-closure)))
(lambda (module closure)
@ -1269,11 +1271,19 @@
(set-module-observers! module (cons proc (module-observers module)))
(cons module proc))
(define (module-observe-weak module proc)
(let ((id (module-observer-id module)))
(hash-set! (module-weak-observers module) id proc)
(set-module-observer-id! module (+ 1 id))
(cons module id)))
(define (module-observe-weak module observer-id . proc)
;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
;; be any Scheme object). PROC is invoked and passed MODULE any time
;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
;; (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)
(let ((module (car token))
@ -1311,7 +1321,11 @@
(define (module-call-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.
;;;
(define (module-local-variable m v)
; (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))
;;; (This is now written in C, see `modules.c'.)
;;;
;;; {Mapping modules x symbols --> bindings}
;;;
@ -1515,19 +1511,10 @@
(module-modified m)
b)))
;; No local variable yet, so we need to create a new one. That
;; new variable is initialized with the old imported value of V,
;; if there is one.
(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)))
;; Create a new local variable.
(let ((local-var (make-undefined-variable)))
(module-add! m v local-var)
local-var)))
;; module-ensure-local-variable! module symbol
;;
@ -1696,46 +1683,29 @@
;; Add INTERFACE to the list of interfaces used by MODULE.
;;
(define (module-use! module interface)
(set-module-uses! module
(cons interface
(filter (lambda (m)
(not (equal? (module-name m)
(module-name interface))))
(module-uses module))))
(module-modified module))
(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
(append (filter (lambda (m)
(not
(equal? (module-name m)
(module-name interface))))
(module-uses module))
(list interface)))
(module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces
;;
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
;;
(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
(cons (module-duplicates-interface module) uses)))
(module-modified module)))
(set-module-uses! module
(append (module-uses module) interfaces))
(module-modified module))
@ -1861,8 +1831,8 @@
(set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
(set-module-uses! module
(append (module-uses module) (list the-scm-module)))))
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
;; NOTE: This binding is used in libguile/modules.c.
;;
@ -1893,6 +1863,7 @@
(define process-define-module #f)
(define process-use-modules #f)
(define module-export! #f)
(define default-duplicate-binding-procedures #f)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
@ -2027,7 +1998,8 @@
(reversed-interfaces '())
(exports '())
(re-exports '())
(replacements '()))
(replacements '())
(autoloads '()))
(if (null? kws)
(call-with-deferred-observers
@ -2035,7 +2007,9 @@
(module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports)
(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)
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
@ -2055,31 +2029,35 @@
(cons interface reversed-interfaces)
exports
re-exports
replacements)))
replacements
autoloads)))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
(loop (cdddr kws)
(cons (make-autoload-interface module
(cadr kws)
(caddr kws))
reversed-interfaces)
reversed-interfaces
exports
re-exports
replacements))
replacements
(let ((name (cadr kws))
(bindings (caddr kws)))
(cons* name bindings autoloads))))
((#:no-backtrace)
(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)
(purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports replacements))
(loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
(set-module-duplicates-handlers!
module
(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)
(or (pair? (cdr kws))
(unrecognized kws))
@ -2087,7 +2065,8 @@
reversed-interfaces
(append (cadr kws) exports)
re-exports
replacements))
replacements
autoloads))
((#:re-export #:re-export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@ -2095,7 +2074,8 @@
reversed-interfaces
exports
(append (cadr kws) re-exports)
replacements))
replacements
autoloads))
((#:replace #:replace-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@ -2103,7 +2083,8 @@
reversed-interfaces
exports
re-exports
(append (cadr kws) replacements)))
(append (cadr kws) replacements)
autoloads))
(else
(unrecognized kws)))))
(run-hook module-defined-hook module)
@ -2131,8 +2112,26 @@
(if (pair? autoload)
(set-car! autoload i)))
(module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
'() (make-weak-value-hash-table 31) 0)))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
(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}
@ -3133,57 +3132,6 @@
(lookup-duplicates-handlers 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.}
@ -3398,10 +3346,7 @@
'(((ice-9 threads)))
'())))
;; load debugger on demand
(module-use! guile-user-module
(make-autoload-interface guile-user-module
'(ice-9 debugger) '(debug)))
(module-autoload! guile-user-module '(ice-9 debugger) '(debug))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; 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>
* Makefile.am (noinst_HEADERS): Add private-options.h, so that it
is included in the distribution.
(noinst_HEADERS): And the same for eval.i.c.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
@ -38,10 +149,24 @@
acquiring the locale mutex.
(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>
* 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>
* 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_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
argument. Don't refer to SCM_GC_CELLS_COLLECTED and

1
libguile/Makefile.am
View file

@ -179,6 +179,7 @@ install-exec-hook:
## working.
noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \
eval.i.c \
srfi-4.i.c \
quicksort.i.c \
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;
}
/* 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)
* operation. This means, that within the expression we may already assign
* values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
/* 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)'
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
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_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 cdr_canonical_definition = SCM_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
= 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)
{

12
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
* modify it under the terms of the GNU Lesser General Public
@ -219,7 +219,8 @@ next_fluid_num ()
no GC can run while updating these two variables.
*/
char *new_allocated_fluids =
char *prev_allocated_fluids;
char *new_allocated_fluids =
scm_malloc (allocated_fluids_len + FLUID_GROW);
/* Copy over old values and initialize rest. GC can not run
@ -229,9 +230,14 @@ next_fluid_num ()
memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len);
memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
n = allocated_fluids_len;
prev_allocated_fluids = allocated_fluids;
allocated_fluids = new_allocated_fluids;
allocated_fluids_len += FLUID_GROW;
if (prev_allocated_fluids != NULL)
free (prev_allocated_fluids);
/* Now allocated_fluids and allocated_fluids_len are valid again
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 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;
@ -194,10 +191,9 @@ gdb_read (char *str)
scm_puts (str, gdb_input_port);
scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
/* Read one object */
tok_buf_mark_p = SCM_GC_MARK_P (tok_buf);
SCM_CLEAR_GC_MARK (tok_buf);
ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
ans = scm_read (gdb_input_port);
if (SCM_GC_P)
{
if (SCM_NIMP (ans))
@ -212,8 +208,6 @@ gdb_read (char *str)
if (SCM_NIMP (ans))
scm_permanent_object (ans);
exit:
if (tok_buf_mark_p)
SCM_SET_GC_MARK (tok_buf);
remark_port (gdb_input_port);
SCM_END_FOREIGN_BLOCK;
return status;
@ -305,8 +299,6 @@ scm_init_gdbint ()
SCM_OPN | SCM_RDNG | SCM_WRTNG,
s);
gdb_input_port = scm_permanent_object (port);
tok_buf = scm_permanent_object (scm_c_make_string (30, SCM_UNDEFINED));
}
/*

23
libguile/goops.c
View file

@ -2313,29 +2313,36 @@ 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 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
{
SCM l, v, result;
SCM *v_elts;
long i, len;
long i, len, m1_specs, m2_specs;
scm_t_array_handle handle;
SCM_VALIDATE_METHOD (1, m1);
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
in a vector
*/
len = scm_ilength (targs);
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_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);
v_elts[i] = SCM_CAR(l);
v_elts[i] = SCM_CAR (l);
}
result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;

52
libguile/i18n.c
View file

@ -1442,35 +1442,40 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
result = SCM_BOOL_F;
else
{
char *p;
switch (c_item)
{
#if (defined GROUPING) && (defined MON_GROUPING)
case GROUPING:
case MON_GROUPING:
/* 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
meaning "no more grouping". */
result = SCM_EOL;
for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
{
SCM last_pair = result;
char *p;
result = scm_reverse_x (result, SCM_EOL);
/* 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
meaning "no more grouping". */
result = SCM_EOL;
for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
if (*p != CHAR_MAX)
{
/* Cyclic grouping information. */
if (last_pair != SCM_EOL)
SCM_SETCDR (last_pair, result);
}
{
SCM last_pair = result;
result = scm_reverse_x (result, SCM_EOL);
if (*p != CHAR_MAX)
{
/* Cyclic grouping information. */
if (last_pair != SCM_EOL)
SCM_SETCDR (last_pair, result);
}
}
free (c_result);
break;
}
#endif
free (c_result);
break;
#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
case FRAC_DIGITS:
case INT_FRAC_DIGITS:
/* 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);
break;
#endif
#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
case P_CS_PRECEDES:
case N_CS_PRECEDES:
case INT_P_CS_PRECEDES:
case INT_N_CS_PRECEDES:
#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
case P_SEP_BY_SPACE:
case N_SEP_BY_SPACE:
#endif
/* This is to be interpreted as a boolean. */
result = scm_from_bool (*c_result);
free (c_result);
break;
#endif
#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
case P_SIGN_POSN:
case N_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");
}
break;
#endif
default:
/* FIXME: `locale_string ()' is not appropriate here because of

305
libguile/modules.c
View file

@ -1,5 +1,5 @@
/* 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
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
@ -162,12 +162,8 @@ scm_c_use_module (const char *name)
static SCM module_export_x_var;
/*
TODO: should export this function? --hwn.
*/
static SCM
scm_export (SCM module, SCM namelist)
SCM
scm_module_export (SCM module, SCM namelist)
{
return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
module, namelist);
@ -203,7 +199,7 @@ scm_c_export (const char *name, ...)
tail = SCM_CDRLOC (*tail);
}
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.
*/
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
module_variable (SCM module, SCM sym)
/* The `default-duplicate-binding-procedures' variable. */
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) \
(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 */
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))
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);
if (scm_is_true (binder))
/* 2. Custom binder */
{
b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (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 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;
@ -335,7 +509,7 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
module, sym);
}
else
return module_variable (module, sym);
return scm_module_variable (module, sym);
}
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 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 SCM_BOUND_THING_P(b) (scm_is_true (b))
SCM uses;
SCM_VALIDATE_MODULE (SCM_ARG1, module);
/* Search the use list */
uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses))
SCM var, result = SCM_BOOL_F;
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
var = scm_module_variable (module, sym);
if (scm_is_true (var))
{
SCM _interface = SCM_CAR (uses);
/* 1. Check module obarray */
SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b))
return _interface;
{
SCM binder = SCM_MODULE_BINDER (_interface);
if (scm_is_true (binder))
/* 2. Custom binder */
{
b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b))
return _interface;
}
}
/* 3. Search use list recursively. */
_interface = scm_module_import_interface (_interface, sym);
if (scm_is_true (_interface))
return _interface;
uses = SCM_CDR (uses);
/* Look for the module that provides VAR. */
SCM local_var;
local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
SCM_UNDEFINED);
if (scm_is_eq (local_var, var))
result = module;
else
{
/* Look for VAR among the used modules. */
SCM uses, imported_var;
for (uses = SCM_MODULE_USES (module);
scm_is_pair (uses) && scm_is_false (result);
uses = SCM_CDR (uses))
{
imported_var = scm_module_variable (SCM_CAR (uses), sym);
if (scm_is_eq (imported_var, var))
result = SCM_CAR (uses);
}
}
}
return SCM_BOOL_F;
return result;
}
#undef FUNC_NAME
@ -560,9 +740,13 @@ scm_define (SCM sym, SCM value)
return var;
}
SCM
scm_module_reverse_lookup (SCM module, SCM variable)
#define FUNC_NAME "module-reverse-lookup"
SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
(SCM module, SCM variable),
"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;
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);
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"));
module_export_x_var = PERM (scm_c_lookup ("module-export!"));
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;
}

11
libguile/modules.h
View file

@ -3,7 +3,7 @@
#ifndef 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
* 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_eval_closure 3
#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) \
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])
#define SCM_MODULE_TRANSFORMER(module) \
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;
@ -64,6 +70,8 @@ SCM_API scm_t_bits scm_tc16_eval_closure;
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_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_module_lookup (SCM module, SCM symbol);
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_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));
}
#ifdef HAVE_COMPLEX_DOUBLE
#ifndef HAVE_CLOG
complex double clog (complex double z);
complex double
clog (complex double z)
{
return log(cabs(z))+I*carg(z);
}
#endif
#ifndef HAVE_CEXP
complex double cexp (complex double z);
complex double
cexp (complex double z)
{
return exp (cabs (z)) * cos(carg (z) + I*sin(carg (z)));
}
#endif
#ifndef HAVE_CARG
double carg (complex double z);
double
carg (complex double z)
{
return atan2 (cimag(z), creal(z));
}
#endif
#endif /* HAVE_COMPLEX_DOUBLE */
/* In the following functions we dispatch to the real-arg funcs like log()
when we know the arg is real, instead of just handing everything to

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
* 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);
SCM_VALIDATE_OPENPORT (1, port);
return scm_from_int (SCM_LINUM (port));
return scm_from_long (SCM_LINUM (port));
}
#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);
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;
}
#undef FUNC_NAME

10
libguile/posix.c
View file

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

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

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
* 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),
"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"
"of seconds remaining otherwise.")
"of seconds remaining otherwise.\n"
"\n"
"See also @code{usleep}.")
#define FUNC_NAME s_scm_sleep
{
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 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
{
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
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
@ -635,7 +635,7 @@ scm_compile_shell_switches (int argc, char **argv)
{
/* Print version number. */
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"
"certain other uses are permitted as well. For details, see the file\n"
"`COPYING', which is included in the Guile distribution.\n"

22
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
* 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
char dst[46];
#endif
char addr6[16];
const char *result;
af = scm_to_int (family);
SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6);
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
scm_to_ipv6 ((scm_t_uint8 *) addr6, address);
if (inet_ntop (af, &addr6, dst, sizeof dst) == NULL)
{
char addr6[16];
scm_to_ipv6 ((scm_t_uint8 *) addr6, address);
result = inet_ntop (af, &addr6, dst, sizeof (dst));
}
if (result == NULL)
SCM_SYSERROR;
return scm_from_locale_string (dst);
}
#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
* modify it under the terms of the GNU Lesser General Public
* 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.")
#define FUNC_NAME s_scm_stable_sort
{
if (SCM_NULL_OR_NIL_P (items))
return SCM_EOL;
if (scm_is_pair (items))
return scm_stable_sort_x (scm_list_copy (items), less);
else if (scm_is_vector (items))

14
libguile/stacks.c
View file

@ -1,5 +1,5 @@
/* 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
* 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
scm_init_stacks ()
{
SCM vtable;
SCM stack_layout
= scm_make_struct_layout (scm_from_locale_string (SCM_STACK_LAYOUT));
vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
scm_stack_type
= scm_permanent_object (scm_make_struct (vtable, SCM_INUM0,
scm_cons (stack_layout,
SCM_EOL)));
scm_stack_type =
scm_permanent_object
(scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
SCM_UNDEFINED));
scm_set_struct_vtable_name_x (scm_stack_type,
scm_from_locale_symbol ("stack"));
#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
* 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]);
basic_size = scm_i_symbol_length (layout) / 2;
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;
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)
+ scm_tc3_struct),
(scm_t_bits) data, 0, 0);
scm_struct_init (handle, layout, data, tail_elts, init);
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;
/* 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;
}
#undef FUNC_NAME
@ -507,6 +536,28 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
#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
contents are the same. Field protections are honored. Thus, it is an
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)));
required_vtable_fields = scm_from_locale_string ("prsrpw");
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-vtable", scm_from_int (scm_vtable_index_vtable));
scm_c_define ("vtable-index-printer",

3
libguile/struct.h
View file

@ -3,7 +3,7 @@
#ifndef 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
* 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_vtable_p (SCM x);
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_i_struct_equalp (SCM s1, SCM s2);
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>
* accessors.scm, simple.scm: New files.

9
oop/goops/internal.scm
View file

@ -21,5 +21,10 @@
(define-module (oop goops internal)
:use-module (oop goops))
(set-module-uses! %module-public-interface
(list (nested-ref the-root-module '(app modules oop goops))))
;; Export all the bindings that are internal to `(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:
# config
subdirs_with_ltlibs="srfi guile-readline" # maintain me
subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me
# env (set by configure)
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>
* 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-31.scm \
srfi-34.scm \
srfi-37.scm \
srfi-39.scm \
srfi-60.scm

16
srfi/srfi-19.scm
View file

@ -1,6 +1,6 @@
;;; 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
;; modify it under the terms of the GNU Lesser General Public
@ -350,14 +350,6 @@
(let ((run-time (get-internal-run-time)))
(make-time
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)
priv:ns-per-guile-tick)
(quotient run-time internal-time-units-per-second))))
@ -819,10 +811,12 @@
(hour (date-hour date))
(day (date-day 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)
(- 1/2)
(+ (/ (+ (* hour 60 60)
(+ (/ (+ (- offset)
(* hour 60 60)
(* minute 60)
second
(/ 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>
* tests/i18n.test: Use `(srfi srfi-1)'.
@ -13,6 +100,20 @@
(SRFI date/time library)[string->date understands days and
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>
* 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-31.test \
tests/srfi-34.test \
tests/srfi-37.test \
tests/srfi-39.test \
tests/srfi-60.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:numerical-overflow
exception:struct-set!-denied
exception:system-error
exception:miscellaneous-error
exception:string-contains-nul
@ -257,6 +258,8 @@
(cons 'numerical-overflow "^Numerical overflow"))
(define exception:struct-set!-denied
(cons 'misc-error "^set! denied for field"))
(define exception:system-error
(cons 'system-error ".*"))
(define exception:miscellaneous-error
(cons 'misc-error "^.*"))

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

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

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

@ -177,6 +177,39 @@
(null? (generic-function-methods foo)))
(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 "define-accessor"

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

@ -1,6 +1,6 @@
;;;; 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
;;;; 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
;;;; 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"
(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"
(catch #t
(lambda ()

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

@ -1,7 +1,7 @@
;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
;;;; 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
;;;; it under the terms of the GNU General Public License as published by
@ -538,6 +538,17 @@
(while (not (eof-object? (read-char 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
;;;

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

@ -1,6 +1,6 @@
;;;; 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
;;;; 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,
;;;; 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
@ -145,3 +146,19 @@
(putenv "FOO=")
(unsetenv "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 -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;; reader.test --- Exercise the reader. -*- Scheme -*-
;;;;
;;;; 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
(cons 'read-error "end of file$"))
(define exception:unexpected-rparen
(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)
(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"
(pass-if "0"
(equal? (read-string "0") 0))
@ -31,8 +71,18 @@
(lambda (key subr message args rest)
(apply format #f message args)
;; 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"
exception:out-of-range
(number->string 10 0))
@ -40,6 +90,7 @@
exception:out-of-range
(number->string 10 1))
(with-test-prefix "mismatching parentheses"
(pass-if-exception "opening parenthesis"
exception:eof
@ -53,3 +104,53 @@
(pass-if-exception "closing parenthesis following mismatched vector opening"
exception:unexpected-rparen
(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)))))

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

@ -1,6 +1,6 @@
;;;; 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
;;;; 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
;;;; 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))
@ -25,20 +25,21 @@
;;; htonl
;;;
(with-test-prefix "htonl"
(if (defined? 'htonl)
(with-test-prefix "htonl"
(pass-if "0" (eqv? 0 (htonl 0)))
(pass-if "0" (eqv? 0 (htonl 0)))
(pass-if-exception "-1" exception:out-of-range
(htonl -1))
(pass-if-exception "-1" exception:out-of-range
(htonl -1))
;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
;; an overflow for values 2^32 <= x < 2^63
(pass-if-exception "2^32" exception:out-of-range
(htonl (ash 1 32)))
;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
;; an overflow for values 2^32 <= x < 2^63
(pass-if-exception "2^32" exception:out-of-range
(htonl (ash 1 32)))
(pass-if-exception "2^1024" exception:out-of-range
(htonl (ash 1 1024))))
(pass-if-exception "2^1024" exception:out-of-range
(htonl (ash 1 1024)))))
;;;
@ -101,6 +102,22 @@
(inet-pton AF_INET6
"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
@ -135,20 +152,21 @@
;;; ntohl
;;;
(with-test-prefix "ntohl"
(if (defined? 'ntohl)
(with-test-prefix "ntohl"
(pass-if "0" (eqv? 0 (ntohl 0)))
(pass-if "0" (eqv? 0 (ntohl 0)))
(pass-if-exception "-1" exception:out-of-range
(ntohl -1))
(pass-if-exception "-1" exception:out-of-range
(ntohl -1))
;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
;; an overflow for values 2^32 <= x < 2^63
(pass-if-exception "2^32" exception:out-of-range
(ntohl (ash 1 32)))
;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
;; an overflow for values 2^32 <= x < 2^63
(pass-if-exception "2^32" exception:out-of-range
(ntohl (ash 1 32)))
(pass-if-exception "2^1024" exception:out-of-range
(ntohl (ash 1 1024))))
(pass-if-exception "2^1024" exception:out-of-range
(ntohl (ash 1 1024)))))

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

@ -1,5 +1,5 @@
;;;; 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
;;;; 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)))
(randomize-vector! v 1000)
(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 -*-
;;;; 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
;;;; it under the terms of the GNU General Public License as published by
@ -109,7 +109,9 @@ incomplete numerical tower implementation.)"
add-duration
#t))
(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-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 julian-day->date date->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"
(time=? (date->time-utc
(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"))))))
;;
;; 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:
;;; coding: latin-1
;;; End:

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

@ -557,6 +557,50 @@
(let ((=> 'foo))
(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"
(pass-if "normal clauses"
@ -725,15 +769,16 @@
(with-test-prefix "top-level define"
(pass-if "binding is created before expression is evaluated"
(= (eval '(begin
(define foo
(begin
(set! foo 1)
(+ foo 1)))
foo)
(interaction-environment))
2))
(pass-if "redefinition"
(let ((m (make-module)))
(beautify-user-module! m)
;; The previous value of `round' must still be visible at the time the
;; new `round' is defined. According to R5RS (Section 5.2.1), `define'
;; should behave like `set!' in this case (except that in the case of
;; Guile, we respect module boundaries).
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
(with-test-prefix "currying"
@ -780,6 +825,17 @@
(eq? 'c (a 2) (a 5))))
(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"
(false-if-exception
(eval '(let ((a identity) (b identity) (c identity))

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

@ -1,7 +1,7 @@
;;;; time.test --- test suite for Guile's time functions -*- scheme -*-
;;;; 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
;;;; it under the terms of the GNU General Public License as published by
@ -34,9 +34,9 @@
(alarm 5)
(false-if-exception (gmtime t))
(join-thread (begin-thread (catch 'out-of-range
(lambda () (gmtime t))
(lambda args #f))))
(join-thread (begin-thread (catch #t
(lambda () (gmtime t))
(lambda args #f))))
(alarm 0)
#t))