diff --git a/.cvsignore b/.cvsignore index 109038aaa..4dae94a82 100644 --- a/.cvsignore +++ b/.cvsignore @@ -33,3 +33,4 @@ mkinstalldirs pre-inst-guile pre-inst-guile-env stamp-h1 +texinfo.tex diff --git a/ChangeLog b/ChangeLog index c44ca297f..db9546de0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,11 +1,80 @@ +2007-07-22 Ludovic Courtès + + * configure.in: Check for and `strncasecmp ()'. + +2007-07-19 Ludovic Courtès + + * NEWS: Mention `(ice-9 i18n)' and lazy duplicate binding + resolution. + +2007-07-18 Ludovic Courtès + + * NEWS: Mention SRFI-37. + +2007-07-15 Ludovic Courtès + + 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 + + * NEWS: Mention GOOPS `method-more-specific?' bug fix. + +2007-07-09 Ludovic Courtès + + * NEWS: Mention SRFI-19 `date->julian-day' bug fix. + +2007-06-26 Ludovic Courtès + + * NEWS: Mention fixed memory leaks. + +2007-06-12 Ludovic Courtès + + * NEWS: Mention `inet-ntop' bug fix. + +2007-05-09 Ludovic Courtès + + * NEWS: Mention SRFI-19 `time-process' bug fix. + +2007-04-17 Ludovic Courtès + + * configure.in (GUILE_FOR_BUILD): Reverted to `$(preinstguile)' + instead of `$(top_builddir_absolute)/$(preinstguile)'. + +2007-04-09 Han-Wen Nienhuys + + * configure.in (HAVE_CRYPT): check for cexp, clog, carg + +2007-02-24 Neil Jerram + + * autogen.sh: Announce versions of autoconf, automake, libtool and + m4. + + * pre-inst-guile.in (subdirs_with_ltlibs): Add libguile. + 2007-02-18 Neil Jerram - * 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 @@ -15,20 +84,29 @@ 2007-01-28 Neil Jerram - * 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 + + * 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 * .gitignore: new file. Make using git easier. +2007-01-22 Kevin Ryde + + * 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 * autogen.sh (Module): only try to run render-bugs if it exists. diff --git a/Makefile.am b/Makefile.am index 7ead71f4b..49fc94a8b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 diff --git a/NEWS b/NEWS index 9ea9cc7aa..15f2d80cd 100644 --- a/NEWS +++ b/NEWS @@ -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?'. diff --git a/THANKS b/THANKS index 6c805fe31..f195effd2 100644 --- a/THANKS +++ b/THANKS @@ -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: diff --git a/acinclude.m4 b/acinclude.m4 index 356c8218a..345e323b3 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -308,5 +308,3 @@ else fi AC_LANG_RESTORE ])dnl ACX_PTHREAD - -AC_DEFUN([AM_INTL_SUBDIR], []) diff --git a/autogen.sh b/autogen.sh index 18e639b8c..1a566de1d 100755 --- a/autogen.sh +++ b/autogen.sh @@ -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 diff --git a/configure.in b/configure.in index 1be4a9f3f..cad32b939 100644 --- a/configure.in +++ b/configure.in @@ -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 # 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 so doesn't detect on macro-only systems like HP-UX. # AC_MSG_CHECKING([for isinf]) -AC_LINK_IFELSE( -[#include -int main () { return (isinf(0.0) != 0); }], +AC_LINK_IFELSE(AC_LANG_SOURCE( +[[#include +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 -int main () { return (isnan(0.0) != 0); }], +AC_LINK_IFELSE(AC_LANG_SOURCE( +[[#include +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.])], diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index c09bc96d0..fc2840d55 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,58 @@ +2007-07-18 Stephen Compall + + * srfi-modules.texi: Describe SRFI-37 in a new subsection. + +2007-07-10 Ludovic Courtès + + * api-data.texi (Arithmetic): Documented `1+' and `1-'. + Suggested by Jon Wilson . + + * api-modules.texi (Module System Reflection): Documented + `save-module-excursion', by Jon Wilson . + +2007-06-07 Ludovic Courtès + + * api-control.texi (Dynamic Wind): Fixed typo. Reported by + Norman Hardy. + +2007-05-16 Ludovic Courtès + + * posix.texi (Network Sockets and Communication): Fixed typo: + `make-socket-object' instead of `make-socket-address'. + +2007-03-08 Kevin Ryde + + * 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 + + * 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 + + * Makefile.am (EXTRA_DIST): Add lib-version.texi to the + distribution. + +2007-02-16 Kevin Ryde + + * api-compound.texi (Records): In make-record-type, describe optional + print function argument. + 2007-01-31 Ludovic Courtès * 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 + + * 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 * api-options.texi (Evaluator trap options): document diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 7d009ff52..6ab2171af 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -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 diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 44410d158..c551c4d10 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -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{#} 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{} # +@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 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 which is the class of itself.) (define ball (make-ball green 'Nisse)) ball @result{} # @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 diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 512733cd5..ed6411f29 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -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 diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index df913b2cd..41bb9ac9c 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -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) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 0d30c4d2a..f69d07ede 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -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. diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index c12e31dca..415c9cba6 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -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 diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index faf57d6b1..f81abbc6b 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -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 diff --git a/doc/ref/slib.texi b/doc/ref/slib.texi index a719494b6..0435b97ac 100644 --- a/doc/ref/slib.texi +++ b/doc/ref/slib.texi @@ -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:: diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index df356cc58..c71578dab 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -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 diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 51979c783..94cd83e71 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,13 @@ +2007-07-15 Ludovic Courtès + + * LIBGUILEREADLINE-VERSION + (LIBGUILEREADLINE_INTERFACE_REVISION): Incremented for release. + +2007-06-26 Ludovic Courtès + + * readline.c (scm_add_history): Free S after invocation of + `add_history ()'. + 2007-01-19 Han-Wen Nienhuys * readline.c: terminate option list with NULL. @@ -315,7 +325,7 @@ 2001-06-14 Marius Vollmer - 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 * Started guile-readline package. Files are copied from old guile-core package and slightly modified. + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 4d2be7302..5a8ced64a 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -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; } diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f3848f1e0..bb2d926ff 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,41 @@ +2007-05-05 Ludovic Courtès + + 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 * gds-client.scm (connect-to-gds): Break generation of client name diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e8f5bb691..115abfdfa 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -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 diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2762daec6..328e6ec4e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,7 +1,118 @@ +2007-07-22 Ludovic Courtès + + 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 + + * script.c (scm_compile_shell_switches): Updated copyright year. + +2007-07-11 Ludovic Courtès + + * 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 . + +2007-06-26 Ludovic Courtès + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + + * 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 + + * numbers.c (carg): provide carg, cexp, clog in case they are + missing. + +2007-03-12 Ludovic Courtès + + * 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 + + * struct.c, struct.h (scm_make_vtable): New function, providing + `make-vtable'. + * stacks.c (scm_init_stacks): Use it. + +2007-03-06 Kevin Ryde + + * 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 + + * 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 * 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 @@ -38,10 +149,24 @@ acquiring the locale mutex. (scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here. +2007-01-27 Kevin Ryde + + * 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 * vector.c: remove comment as per kryde's request. +2007-01-25 Kevin Ryde + + * 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 * 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 Courts +2006-01-04 Ludovic Courtès * gc-segment.c (scm_i_sweep_some_cards): Take a SWEEP_STATS argument. Don't refer to SCM_GC_CELLS_COLLECTED and diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 3944f2e46..53a6da99e 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -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 \ diff --git a/libguile/eval.c b/libguile/eval.c index 95dd95974..1b18c688a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -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) { diff --git a/libguile/fluids.c b/libguile/fluids.c index 8099a2ef2..b5334dbdb 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -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. */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 1062b9915..b1ec99d2e 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -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)); } /* diff --git a/libguile/goops.c b/libguile/goops.c index 9b764c191..1674b39e3 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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; diff --git a/libguile/i18n.c b/libguile/i18n.c index e23f79072..2a778eb91 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -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 diff --git a/libguile/modules.c b/libguile/modules.c index b1f312a92..e4a2df037 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -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; } diff --git a/libguile/modules.h b/libguile/modules.h index 882deb90c..6e4f4d970 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -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); diff --git a/libguile/numbers.c b/libguile/numbers.c index a8c8996fa..305977346 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -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 diff --git a/libguile/ports.c b/libguile/ports.c index 3fcc0efaa..fc716bebf 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -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 diff --git a/libguile/posix.c b/libguile/posix.c index 81539baf2..e0d461075 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -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 diff --git a/libguile/read.c b/libguile/read.c index de2e87bed..52c4dc265 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006 Free Software +/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007 Free Software * Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -19,7 +19,17 @@ +#ifdef HAVE_CONFIG_H +# include +#endif + #include +#include +#include +#ifdef HAVE_STRINGS_H +# include +#endif + #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" @@ -36,6 +46,7 @@ #include "libguile/vectors.h" #include "libguile/validate.h" #include "libguile/srfi-4.h" +#include "libguile/srfi-13.h" #include "libguile/read.h" #include "libguile/private-options.h" @@ -91,7 +102,7 @@ scm_i_input_error (char const *function, scm_simple_format (string_port, scm_from_locale_string ("~A:~S:~S: ~A"), scm_list_4 (fn, - scm_from_int (SCM_LINUM (port) + 1), + scm_from_long (SCM_LINUM (port) + 1), scm_from_int (SCM_COL (port) + 1), scm_from_locale_string (message))); @@ -124,77 +135,114 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, /* An association list mapping extra hash characters to procedures. */ static SCM *scm_read_hash_procedures; -SCM_DEFINE (scm_read, "read", 0, 1, 0, - (SCM port), - "Read an s-expression from the input port @var{port}, or from\n" - "the current input port if @var{port} is not specified.\n" - "Any whitespace before the next token is discarded.") -#define FUNC_NAME s_scm_read + + +/* Token readers. */ + + +/* Size of the C buffer used to read symbols and numbers. */ +#define READER_BUFFER_SIZE 128 + +/* Size of the C buffer used to read strings. */ +#define READER_STRING_BUFFER_SIZE 512 + +/* The maximum size of Scheme character names. */ +#define READER_CHAR_NAME_MAX_SIZE 50 + + +/* `isblank' is only in C99. */ +#define CHAR_IS_BLANK_(_chr) \ + (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n') \ + || ((_chr) == '\f')) + +#ifdef MSDOS +# define CHAR_IS_BLANK(_chr) \ + ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26)) +#else +# define CHAR_IS_BLANK CHAR_IS_BLANK_ +#endif + + +/* R5RS one-character delimiters (see section 7.1.1, ``Lexical + structure''). */ +#define CHAR_IS_R5RS_DELIMITER(c) \ + (CHAR_IS_BLANK (c) \ + || (c == ')') || (c == '(') || (c == ';') || (c == '"')) + +#define CHAR_IS_DELIMITER CHAR_IS_R5RS_DELIMITER + +/* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical + Structure''. */ +#define CHAR_IS_EXPONENT_MARKER(_chr) \ + (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \ + || ((_chr) == 'd') || ((_chr) == 'l')) + +/* An inlinable version of `scm_c_downcase ()'. */ +#define CHAR_DOWNCASE(_chr) \ + (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr)) + + +#ifndef HAVE_STRNCASECMP +/* XXX: Use Gnulib's `strncasecmp ()'. */ + +static int +strncasecmp (const char *s1, const char *s2, size_t len2) { - int c; - SCM tok_buf, copy; - - if (SCM_UNBNDP (port)) - port = scm_current_input_port (); - SCM_VALIDATE_OPINPORT (1, port); - - c = scm_flush_ws (port, (char *) NULL); - if (EOF == c) - return SCM_EOF_VAL; - scm_ungetc (c, port); - - tok_buf = scm_c_make_string (30, SCM_UNDEFINED); - return scm_lreadr (&tok_buf, port, ©); -} -#undef FUNC_NAME - - - -char * -scm_grow_tok_buf (SCM *tok_buf) -{ - size_t oldlen = scm_i_string_length (*tok_buf); - const char *olddata = scm_i_string_chars (*tok_buf); - char *newdata; - SCM newstr = scm_i_make_string (2 * oldlen, &newdata); - size_t i; - - for (i = 0; i != oldlen; ++i) - newdata[i] = olddata[i]; - - *tok_buf = newstr; - return newdata; -} - -/* Consume an SCSH-style block comment. Assume that we've already - read the initial `#!', and eat characters until we get a - exclamation-point/sharp-sign sequence. -*/ - -static void -skip_scsh_block_comment (SCM port) -{ - int bang_seen = 0; - - for (;;) + while (*s1 && *s2 && len2 > 0) { - int c = scm_getc (port); - - if (c == EOF) - scm_i_input_error ("skip_block_comment", port, - "unterminated `#! ... !#' comment", SCM_EOL); + int c1 = *s1, c2 = *s2; - if (c == '!') - bang_seen = 1; - else if (c == '#' && bang_seen) - return; + if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2)) + return 0; else - bang_seen = 0; + { + ++s1; + ++s2; + --len2; + } } + return !(*s1 || *s2 || len2 > 0); +} +#endif + + +/* Helper function similar to `scm_read_token ()'. Read from PORT until a + whitespace is read. Return zero if the whole token could fit in BUF, + non-zero otherwise. */ +static inline int +read_token (SCM port, char *buf, size_t buf_size, size_t *read) +{ + *read = 0; + + while (*read < buf_size) + { + int chr; + + chr = scm_getc (port); + chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr); + + if (chr == EOF) + return 0; + else if (CHAR_IS_DELIMITER (chr)) + { + scm_ungetc (chr, port); + return 0; + } + else + { + *buf = (char) chr; + buf++, (*read)++; + } + } + + return 1; } -int -scm_flush_ws (SCM port, const char *eoferr) + +/* Skip whitespace from PORT and return the first non-whitespace character + read. Raise an error on end-of-file. */ +static int +flush_ws (SCM port, const char *eoferr) { register int c; while (1) @@ -210,6 +258,7 @@ scm_flush_ws (SCM port, const char *eoferr) SCM_EOL); } return c; + case ';': lp: switch (c = scm_getc (port)) @@ -222,63 +271,833 @@ scm_flush_ws (SCM port, const char *eoferr) break; } break; - case '#': - switch (c = scm_getc (port)) - { - case EOF: - eoferr = "read_sharp"; - goto goteof; - case '!': - skip_scsh_block_comment (port); - break; - default: - scm_ungetc (c, port); - return '#'; - } - break; + case SCM_LINE_INCREMENTORS: case SCM_SINGLE_SPACES: case '\t': break; + default: return c; } + + return 0; } + +/* Token readers. */ -int -scm_casei_streq (char *s1, char *s2) +static SCM scm_read_expression (SCM port); +static SCM scm_read_sharp (int chr, SCM port); +static SCM scm_get_hash_procedure (int c); +static SCM recsexpr (SCM obj, long line, int column, SCM filename); + + +static SCM +scm_read_sexp (int chr, SCM port) +#define FUNC_NAME "scm_i_lreadparen" { - while (*s1 && *s2) - if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2)) - return 0; - else - { - ++s1; - ++s2; - } - return !(*s1 || *s2); -} + register int c; + register SCM tmp; + register SCM tl, ans = SCM_EOL; + SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;; + static const int terminating_char = ')'; -static int -scm_i_casei_streq (const char *s1, const char *s2, size_t len2) + /* Need to capture line and column numbers here. */ + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + + + c = flush_ws (port, FUNC_NAME); + if (terminating_char == c) + return SCM_EOL; + + scm_ungetc (c, port); + if (scm_is_eq (scm_sym_dot, + (tmp = scm_read_expression (port)))) + { + ans = scm_read_expression (port); + if (terminating_char != (c = flush_ws (port, FUNC_NAME))) + scm_i_input_error (FUNC_NAME, port, "missing close paren", + SCM_EOL); + return ans; + } + + /* Build the head of the list structure. */ + ans = tl = scm_cons (tmp, SCM_EOL); + + if (SCM_COPY_SOURCE_P) + ans2 = tl2 = scm_cons (scm_is_pair (tmp) + ? copy + : tmp, + SCM_EOL); + + while (terminating_char != (c = flush_ws (port, FUNC_NAME))) + { + SCM new_tail; + + scm_ungetc (c, port); + if (scm_is_eq (scm_sym_dot, + (tmp = scm_read_expression (port)))) + { + SCM_SETCDR (tl, tmp = scm_read_expression (port)); + + if (SCM_COPY_SOURCE_P) + SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp, + SCM_EOL)); + + c = flush_ws (port, FUNC_NAME); + if (terminating_char != c) + scm_i_input_error (FUNC_NAME, port, + "in pair: missing close paren", SCM_EOL); + goto exit; + } + + new_tail = scm_cons (tmp, SCM_EOL); + SCM_SETCDR (tl, new_tail); + tl = new_tail; + + if (SCM_COPY_SOURCE_P) + { + SCM new_tail2 = scm_cons (scm_is_pair (tmp) + ? copy + : tmp, SCM_EOL); + SCM_SETCDR (tl2, new_tail2); + tl2 = new_tail2; + } + } + + exit: + if (SCM_RECORD_POSITIONS_P) + scm_whash_insert (scm_source_whash, + ans, + scm_make_srcprops (line, column, + SCM_FILENAME (port), + SCM_COPY_SOURCE_P + ? ans2 + : SCM_UNDEFINED, + SCM_EOL)); + return ans; +} +#undef FUNC_NAME + +static SCM +scm_read_string (int chr, SCM port) +#define FUNC_NAME "scm_lreadr" { - while (*s1 && len2 > 0) - if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2)) - return 0; - else - { - ++s1; - ++s2; - --len2; - } - return !(*s1 || len2 > 0); + /* For strings smaller than C_STR, this function creates only one Scheme + object (the string returned). */ + + SCM str = SCM_BOOL_F; + char c_str[READER_STRING_BUFFER_SIZE]; + unsigned c_str_len = 0; + int c; + + while ('"' != (c = scm_getc (port))) + { + if (c == EOF) + str_eof: scm_i_input_error (FUNC_NAME, port, + "end of file in string constant", + SCM_EOL); + + if (c_str_len + 1 >= sizeof (c_str)) + { + /* Flush the C buffer onto a Scheme string. */ + SCM addy; + + if (str == SCM_BOOL_F) + str = scm_c_make_string (0, SCM_MAKE_CHAR ('X')); + + addy = scm_from_locale_stringn (c_str, c_str_len); + str = scm_string_append_shared (scm_list_2 (str, addy)); + + c_str_len = 0; + } + + if (c == '\\') + switch (c = scm_getc (port)) + { + case EOF: + goto str_eof; + case '"': + case '\\': + break; +#if SCM_ENABLE_ELISP + case '(': + case ')': + if (SCM_ESCAPED_PARENS_P) + break; + goto bad_escaped; +#endif + case '\n': + continue; + case '0': + c = '\0'; + break; + case 'f': + c = '\f'; + break; + case 'n': + c = '\n'; + break; + case 'r': + c = '\r'; + break; + case 't': + c = '\t'; + break; + case 'a': + c = '\007'; + break; + case 'v': + c = '\v'; + break; + case 'x': + { + int a, b; + a = scm_getc (port); + if (a == EOF) goto str_eof; + b = scm_getc (port); + if (b == EOF) goto str_eof; + if ('0' <= a && a <= '9') a -= '0'; + else if ('A' <= a && a <= 'F') a = a - 'A' + 10; + else if ('a' <= a && a <= 'f') a = a - 'a' + 10; + else goto bad_escaped; + if ('0' <= b && b <= '9') b -= '0'; + else if ('A' <= b && b <= 'F') b = b - 'A' + 10; + else if ('a' <= b && b <= 'f') b = b - 'a' + 10; + else goto bad_escaped; + c = a * 16 + b; + break; + } + default: + bad_escaped: + scm_i_input_error (FUNC_NAME, port, + "illegal character in escape sequence: ~S", + scm_list_1 (SCM_MAKE_CHAR (c))); + } + c_str[c_str_len++] = c; + } + + if (c_str_len > 0) + { + SCM addy; + + addy = scm_from_locale_stringn (c_str, c_str_len); + if (str == SCM_BOOL_F) + str = addy; + else + str = scm_string_append_shared (scm_list_2 (str, addy)); + } + else + str = (str == SCM_BOOL_F) ? scm_nullstr : str; + + return str; +} +#undef FUNC_NAME + + +static SCM +scm_read_number (int chr, SCM port) +{ + SCM result, str = SCM_EOL; + char buffer[READER_BUFFER_SIZE]; + size_t read; + int overflow = 0; + + scm_ungetc (chr, port); + do + { + overflow = read_token (port, buffer, sizeof (buffer), &read); + + if ((overflow) || (scm_is_pair (str))) + str = scm_cons (scm_from_locale_stringn (buffer, read), str); + } + while (overflow); + + if (scm_is_pair (str)) + { + /* The slow path. */ + + str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); + result = scm_string_to_number (str, SCM_UNDEFINED); + if (!scm_is_true (result)) + /* Return a symbol instead of a number. */ + result = scm_string_to_symbol (str); + } + else + { + result = scm_c_locale_stringn_to_number (buffer, read, 10); + if (!scm_is_true (result)) + /* Return a symbol instead of a number. */ + result = scm_from_locale_symboln (buffer, read); + } + + return result; } -/* recsexpr is used when recording expressions - * constructed by read:sharp. - */ +static SCM +scm_read_mixed_case_symbol (int chr, SCM port) +{ + SCM result, str = SCM_EOL; + int overflow = 0; + char buffer[READER_BUFFER_SIZE]; + size_t read = 0; + + scm_ungetc (chr, port); + do + { + overflow = read_token (port, buffer, sizeof (buffer), &read); + + if ((overflow) || (scm_is_pair (str))) + str = scm_cons (scm_from_locale_stringn (buffer, read), str); + } + while (overflow); + + if (scm_is_pair (str)) + { + str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); + result = scm_string_to_symbol (str); + } + else + /* For symbols smaller than `sizeof (buffer)', we don't need to recur to + Scheme strings. Therefore, we only create one Scheme object (a + symbol) per symbol read. */ + result = scm_from_locale_symboln (buffer, read); + + return result; +} + +static SCM +scm_read_number_and_radix (int chr, SCM port) +#define FUNC_NAME "scm_lreadr" +{ + SCM result, str = SCM_EOL; + size_t read; + char buffer[READER_BUFFER_SIZE]; + unsigned int radix; + int overflow = 0; + + switch (chr) + { + case 'B': + case 'b': + radix = 2; + break; + + case 'o': + case 'O': + radix = 8; + break; + + case 'd': + case 'D': + radix = 10; + break; + + case 'x': + case 'X': + radix = 16; + break; + + default: + scm_ungetc (chr, port); + scm_ungetc ('#', port); + radix = 10; + } + + do + { + overflow = read_token (port, buffer, sizeof (buffer), &read); + + if ((overflow) || (scm_is_pair (str))) + str = scm_cons (scm_from_locale_stringn (buffer, read), str); + } + while (overflow); + + if (scm_is_pair (str)) + { + str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); + result = scm_string_to_number (str, scm_from_uint (radix)); + } + else + result = scm_c_locale_stringn_to_number (buffer, read, radix); + + if (scm_is_true (result)) + return result; + + scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +static SCM +scm_read_quote (int chr, SCM port) +{ + SCM p; + + switch (chr) + { + case '`': + p = scm_sym_quasiquote; + break; + + case '\'': + p = scm_sym_quote; + break; + + case ',': + { + int c; + + c = scm_getc (port); + if ('@' == c) + p = scm_sym_uq_splicing; + else + { + scm_ungetc (c, port); + p = scm_sym_unquote; + } + break; + } + + default: + fprintf (stderr, "%s: unhandled quote character (%i)\n", + __FUNCTION__, chr); + abort (); + } + + p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); + + return p; +} + +static inline SCM +scm_read_semicolon_comment (int chr, SCM port) +{ + int c; + + for (c = scm_getc (port); + (c != EOF) && (c != '\n'); + c = scm_getc (port)); + + return SCM_UNSPECIFIED; +} + + +/* Sharp readers, i.e. readers called after a `#' sign has been read. */ + +static SCM +scm_read_boolean (int chr, SCM port) +{ + switch (chr) + { + case 't': + case 'T': + return SCM_BOOL_T; + + case 'f': + case 'F': + return SCM_BOOL_F; + } + + return SCM_UNSPECIFIED; +} + +static SCM +scm_read_character (int chr, SCM port) +#define FUNC_NAME "scm_lreadr" +{ + unsigned c; + char charname[READER_CHAR_NAME_MAX_SIZE]; + size_t charname_len; + + if (read_token (port, charname, sizeof (charname), &charname_len)) + goto char_error; + + if (charname_len == 0) + { + chr = scm_getc (port); + if (chr == EOF) + scm_i_input_error (FUNC_NAME, port, "unexpected end of file " + "while reading character", SCM_EOL); + + /* CHR must be a token delimiter, like a whitespace. */ + return (SCM_MAKE_CHAR (chr)); + } + + if (charname_len == 1) + return SCM_MAKE_CHAR (charname[0]); + + if (*charname >= '0' && *charname < '8') + { + /* Dirk:FIXME:: This type of character syntax is not R5RS + * compliant. Further, it should be verified that the constant + * does only consist of octal digits. Finally, it should be + * checked whether the resulting fixnum is in the range of + * characters. */ + SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8); + if (SCM_I_INUMP (p)) + return SCM_MAKE_CHAR (SCM_I_INUM (p)); + } + + for (c = 0; c < scm_n_charnames; c++) + if (scm_charnames[c] + && (!strncasecmp (scm_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_charnums[c]); + + char_error: + scm_i_input_error (FUNC_NAME, port, "unknown character name ~a", + scm_list_1 (scm_from_locale_stringn (charname, + charname_len))); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static inline SCM +scm_read_keyword (int chr, SCM port) +{ + SCM symbol; + + /* Read the symbol that comprises the keyword. Doing this instead of + invoking a specific symbol reader function allows `scm_read_keyword ()' + to adapt to the delimiters currently valid of symbols. + + XXX: This implementation allows sloppy syntaxes like `#: key'. */ + symbol = scm_read_expression (port); + if (!scm_is_symbol (symbol)) + scm_i_input_error (__FUNCTION__, port, + "keyword prefix `~a' not followed by a symbol: ~s", + scm_list_2 (SCM_MAKE_CHAR (chr), symbol)); + + return (scm_symbol_to_keyword (symbol)); +} + +static inline SCM +scm_read_vector (int chr, SCM port) +{ + /* Note: We call `scm_read_sexp ()' rather than READER here in order to + guarantee that it's going to do what we want. After all, this is an + implementation detail of `scm_read_vector ()', not a desirable + property. */ + return (scm_vector (scm_read_sexp (chr, port))); +} + +static inline SCM +scm_read_srfi4_vector (int chr, SCM port) +{ + return scm_i_read_array (port, chr); +} + +static SCM +scm_read_guile_bit_vector (int chr, SCM port) +{ + /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is + terribly inefficient but who cares? */ + SCM s_bits = SCM_EOL; + + for (chr = scm_getc (port); + (chr != EOF) && ((chr == '0') || (chr == '1')); + chr = scm_getc (port)) + { + s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits); + } + + if (chr != EOF) + scm_ungetc (chr, port); + + return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)); +} + +static inline SCM +scm_read_scsh_block_comment (int chr, SCM port) +{ + int bang_seen = 0; + + for (;;) + { + int c = scm_getc (port); + + if (c == EOF) + scm_i_input_error ("skip_block_comment", port, + "unterminated `#! ... !#' comment", SCM_EOL); + + if (c == '!') + bang_seen = 1; + else if (c == '#' && bang_seen) + break; + else + bang_seen = 0; + } + + return SCM_UNSPECIFIED; +} + +static SCM +scm_read_extended_symbol (int chr, SCM port) +{ + /* Guile's extended symbol read syntax looks like this: + + #{This is all a symbol name}# + + So here, CHR is expected to be `{'. */ + SCM result; + int saw_brace = 0, finished = 0; + size_t len = 0; + char buf[1024]; + + result = scm_c_make_string (0, SCM_MAKE_CHAR ('X')); + + while ((chr = scm_getc (port)) != EOF) + { + if (saw_brace) + { + if (chr == '#') + { + finished = 1; + break; + } + else + { + saw_brace = 0; + buf[len++] = '}'; + buf[len++] = chr; + } + } + else if (chr == '}') + saw_brace = 1; + else + buf[len++] = chr; + + if (len >= sizeof (buf) - 2) + { + scm_string_append (scm_list_2 (result, + scm_from_locale_stringn (buf, len))); + len = 0; + } + + if (finished) + break; + } + + if (len) + result = scm_string_append (scm_list_2 + (result, + scm_from_locale_stringn (buf, len))); + + return (scm_string_to_symbol (result)); +} + + + +/* Top-level token readers, i.e., dispatchers. */ + +static SCM +scm_read_sharp_extension (int chr, SCM port) +{ + SCM proc; + + proc = scm_get_hash_procedure (chr); + if (scm_is_true (scm_procedure_p (proc))) + { + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 2; + SCM got; + + got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); + if (!scm_is_eq (got, SCM_UNSPECIFIED)) + { + if (SCM_RECORD_POSITIONS_P) + return (recsexpr (got, line, column, + SCM_FILENAME (port))); + else + return got; + } + } + + return SCM_UNSPECIFIED; +} + +/* The reader for the sharp `#' character. It basically dispatches reads + among the above token readers. */ +static SCM +scm_read_sharp (int chr, SCM port) +#define FUNC_NAME "scm_lreadr" +{ + SCM result; + + chr = scm_getc (port); + + result = scm_read_sharp_extension (chr, port); + if (!scm_is_eq (result, SCM_UNSPECIFIED)) + return result; + + switch (chr) + { + case '\\': + return (scm_read_character (chr, port)); + case '(': + return (scm_read_vector (chr, port)); + case 's': + case 'u': + case 'f': + /* This one may return either a boolean or an SRFI-4 vector. */ + return (scm_read_srfi4_vector (chr, port)); + case '*': + return (scm_read_guile_bit_vector (chr, port)); + case 't': + case 'T': + case 'F': + /* This one may return either a boolean or an SRFI-4 vector. */ + return (scm_read_boolean (chr, port)); + case ':': + return (scm_read_keyword (chr, port)); + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '@': +#if SCM_ENABLE_DEPRECATED + /* See below for 'i' and 'e'. */ + case 'a': + case 'c': + case 'y': + case 'h': + case 'l': +#endif + return (scm_i_read_array (port, chr)); + + case 'i': + case 'e': +#if SCM_ENABLE_DEPRECATED + { + /* When next char is '(', it really is an old-style + uniform array. */ + int next_c = scm_getc (port); + if (next_c != EOF) + scm_ungetc (next_c, port); + if (next_c == '(') + return scm_i_read_array (port, chr); + /* Fall through. */ + } +#endif + case 'b': + case 'B': + case 'o': + case 'O': + case 'd': + case 'D': + case 'x': + case 'X': + case 'I': + case 'E': + return (scm_read_number_and_radix (chr, port)); + case '{': + return (scm_read_extended_symbol (chr, port)); + case '!': + return (scm_read_scsh_block_comment (chr, port)); + default: + result = scm_read_sharp_extension (chr, port); + if (scm_is_eq (result, SCM_UNSPECIFIED)) + scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S", + scm_list_1 (SCM_MAKE_CHAR (chr))); + else + return result; + } + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static SCM +scm_read_expression (SCM port) +#define FUNC_NAME "scm_read_expression" +{ + while (1) + { + register int chr; + + chr = scm_getc (port); + + switch (chr) + { + case SCM_WHITE_SPACES: + case SCM_LINE_INCREMENTORS: + break; + case ';': + (void) scm_read_semicolon_comment (chr, port); + break; + case '(': + return (scm_read_sexp (chr, port)); + case '"': + return (scm_read_string (chr, port)); + case '\'': + case '`': + case ',': + return (scm_read_quote (chr, port)); + case '#': + { + SCM result; + result = scm_read_sharp (chr, port); + if (scm_is_eq (result, SCM_UNSPECIFIED)) + /* We read a comment or some such. */ + break; + else + return result; + } + case ')': + scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL); + break; + case EOF: + return SCM_EOF_VAL; + case ':': + if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) + return scm_symbol_to_keyword (scm_read_expression (port)); + /* Fall through. */ + + default: + { + if (((chr >= '0') && (chr <= '9')) + || (strchr ("+-.", chr))) + return (scm_read_number (chr, port)); + else + return (scm_read_mixed_case_symbol (chr, port)); + } + } + } +} +#undef FUNC_NAME + + +/* Actual reader. */ + +SCM_DEFINE (scm_read, "read", 0, 1, 0, + (SCM port), + "Read an s-expression from the input port @var{port}, or from\n" + "the current input port if @var{port} is not specified.\n" + "Any whitespace before the next token is discarded.") +#define FUNC_NAME s_scm_read +{ + int c; + + if (SCM_UNBNDP (port)) + port = scm_current_input_port (); + SCM_VALIDATE_OPINPORT (1, port); + + c = flush_ws (port, (char *) NULL); + if (EOF == c) + return SCM_EOF_VAL; + scm_ungetc (c, port); + + return (scm_read_expression (port)); +} +#undef FUNC_NAME + + + + +/* Used when recording expressions constructed by `scm_read_sharp ()'. */ static SCM recsexpr (SCM obj, long line, int column, SCM filename) { @@ -325,572 +1144,6 @@ recsexpr (SCM obj, long line, int column, SCM filename) } } - -static SCM scm_get_hash_procedure(int c); -static SCM scm_i_lreadparen (SCM *, SCM, char *, SCM *, char); - -static char s_list[]="list"; -#if SCM_ENABLE_ELISP -static char s_vector[]="vector"; -#endif - -SCM -scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) -#define FUNC_NAME "scm_lreadr" -{ - int c; - size_t j; - SCM p; - - tryagain: - c = scm_flush_ws (port, s_scm_read); - switch (c) - { - case EOF: - return SCM_EOF_VAL; - - case '(': - return SCM_RECORD_POSITIONS_P - ? scm_lreadrecparen (tok_buf, port, s_list, copy) - : scm_i_lreadparen (tok_buf, port, s_list, copy, ')'); - case ')': - scm_i_input_error (FUNC_NAME, port,"unexpected \")\"", SCM_EOL); - goto tryagain; - -#if SCM_ENABLE_ELISP - case '[': - if (SCM_ELISP_VECTORS_P) - { - p = scm_i_lreadparen (tok_buf, port, s_vector, copy, ']'); - return scm_is_null (p) ? scm_nullvect : scm_vector (p); - } - goto read_token; -#endif - case '\'': - p = scm_sym_quote; - goto recquote; - case '`': - p = scm_sym_quasiquote; - goto recquote; - case ',': - c = scm_getc (port); - if ('@' == c) - p = scm_sym_uq_splicing; - else - { - scm_ungetc (c, port); - p = scm_sym_unquote; - } - recquote: - p = scm_cons2 (p, - scm_lreadr (tok_buf, port, copy), - SCM_EOL); - if (SCM_RECORD_POSITIONS_P) - scm_whash_insert (scm_source_whash, - p, - scm_make_srcprops (SCM_LINUM (port), - SCM_COL (port) - 1, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? (*copy = scm_cons2 (SCM_CAR (p), - SCM_CAR (SCM_CDR (p)), - SCM_EOL)) - : SCM_UNDEFINED, - SCM_EOL)); - return p; - case '#': - c = scm_getc (port); - - { - /* Check for user-defined hash procedure first, to allow - overriding of builtin hash read syntaxes. */ - SCM sharp = scm_get_hash_procedure (c); - if (scm_is_true (sharp)) - { - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 2; - SCM got; - - got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); - if (scm_is_eq (got, SCM_UNSPECIFIED)) - goto handle_sharp; - if (SCM_RECORD_POSITIONS_P) - return *copy = recsexpr (got, line, column, - SCM_FILENAME (port)); - else - return got; - } - } - handle_sharp: - switch (c) - { - /* Vector, arrays, both uniform and not are handled by this - one function. It also disambiguates between '#f' and - '#f32' and '#f64'. - */ - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - case 'u': case 's': case 'f': - case '@': - case '(': -#if SCM_ENABLE_DEPRECATED - /* See below for 'i' and 'e'. */ - case 'a': - case 'c': - case 'y': - case 'h': - case 'l': -#endif - return scm_i_read_array (port, c); - - case 't': - case 'T': - return SCM_BOOL_T; - - case 'F': - /* See above for lower case 'f'. */ - return SCM_BOOL_F; - - - case 'i': - case 'e': -#if SCM_ENABLE_DEPRECATED - { - /* When next char is '(', it really is an old-style - uniform array. */ - int next_c = scm_getc (port); - if (next_c != EOF) - scm_ungetc (next_c, port); - if (next_c == '(') - return scm_i_read_array (port, c); - /* Fall through. */ - } -#endif - case 'b': - case 'B': - case 'o': - case 'O': - case 'd': - case 'D': - case 'x': - case 'X': - case 'I': - case 'E': - scm_ungetc (c, port); - c = '#'; - goto num; - - case '!': - /* should never happen, #!...!# block comments are skipped - over in scm_flush_ws. */ - abort (); - - case '*': - j = scm_read_token (c, tok_buf, port, 0); - p = scm_istr2bve (scm_c_substring_shared (*tok_buf, 1, j)); - if (scm_is_true (p)) - return p; - else - goto unkshrp; - - case '{': - j = scm_read_token (c, tok_buf, port, 1); - return scm_string_to_symbol (scm_c_substring_copy (*tok_buf, 0, j)); - - case '\\': - c = scm_getc (port); - j = scm_read_token (c, tok_buf, port, 0); - if (j == 1) - return SCM_MAKE_CHAR (c); - if (c >= '0' && c < '8') - { - /* Dirk:FIXME:: This type of character syntax is not R5RS - * compliant. Further, it should be verified that the constant - * does only consist of octal digits. Finally, it should be - * checked whether the resulting fixnum is in the range of - * characters. */ - p = scm_c_locale_stringn_to_number (scm_i_string_chars (*tok_buf), - j, 8); - if (SCM_I_INUMP (p)) - return SCM_MAKE_CHAR (SCM_I_INUM (p)); - } - for (c = 0; c < scm_n_charnames; c++) - if (scm_charnames[c] - && (scm_i_casei_streq (scm_charnames[c], - scm_i_string_chars (*tok_buf), j))) - return SCM_MAKE_CHAR (scm_charnums[c]); - scm_i_input_error (FUNC_NAME, port, "unknown character name ~a", - scm_list_1 (scm_c_substring (*tok_buf, 0, j))); - - /* #:SYMBOL is a syntax for keywords supported in all contexts. */ - case ':': - return scm_symbol_to_keyword (scm_read (port)); - - default: - callshrp: - { - SCM sharp = scm_get_hash_procedure (c); - - if (scm_is_true (sharp)) - { - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 2; - SCM got; - - got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); - if (scm_is_eq (got, SCM_UNSPECIFIED)) - goto unkshrp; - if (SCM_RECORD_POSITIONS_P) - return *copy = recsexpr (got, line, column, - SCM_FILENAME (port)); - else - return got; - } - } - unkshrp: - scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S", - scm_list_1 (SCM_MAKE_CHAR (c))); - } - - case '"': - j = 0; - while ('"' != (c = scm_getc (port))) - { - if (c == EOF) - str_eof: scm_i_input_error (FUNC_NAME, port, - "end of file in string constant", - SCM_EOL); - - while (j + 2 >= scm_i_string_length (*tok_buf)) - scm_grow_tok_buf (tok_buf); - - if (c == '\\') - switch (c = scm_getc (port)) - { - case EOF: - goto str_eof; - case '"': - case '\\': - break; -#if SCM_ENABLE_ELISP - case '(': - case ')': - if (SCM_ESCAPED_PARENS_P) - break; - goto bad_escaped; -#endif - case '\n': - continue; - case '0': - c = '\0'; - break; - case 'f': - c = '\f'; - break; - case 'n': - c = '\n'; - break; - case 'r': - c = '\r'; - break; - case 't': - c = '\t'; - break; - case 'a': - c = '\007'; - break; - case 'v': - c = '\v'; - break; - case 'x': - { - int a, b; - a = scm_getc (port); - if (a == EOF) goto str_eof; - b = scm_getc (port); - if (b == EOF) goto str_eof; - if ('0' <= a && a <= '9') a -= '0'; - else if ('A' <= a && a <= 'F') a = a - 'A' + 10; - else if ('a' <= a && a <= 'f') a = a - 'a' + 10; - else goto bad_escaped; - if ('0' <= b && b <= '9') b -= '0'; - else if ('A' <= b && b <= 'F') b = b - 'A' + 10; - else if ('a' <= b && b <= 'f') b = b - 'a' + 10; - else goto bad_escaped; - c = a * 16 + b; - break; - } - default: - bad_escaped: - scm_i_input_error(FUNC_NAME, port, - "illegal character in escape sequence: ~S", - scm_list_1 (SCM_MAKE_CHAR (c))); - } - scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c)); - ++j; - } - if (j == 0) - return scm_nullstr; - - /* Change this to scm_c_substring_read_only when - SCM_STRING_CHARS has been removed. - */ - return scm_c_substring_copy (*tok_buf, 0, j); - - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - case '.': - case '-': - case '+': - num: - j = scm_read_token (c, tok_buf, port, 0); - if (j == 1 && (c == '+' || c == '-')) - /* Shortcut: Detected symbol '+ or '- */ - goto tok; - - p = scm_c_locale_stringn_to_number (scm_i_string_chars (*tok_buf), j, 10); - if (scm_is_true (p)) - return p; - if (c == '#') - { - if ((j == 2) && (scm_getc (port) == '(')) - { - scm_ungetc ('(', port); - c = scm_i_string_chars (*tok_buf)[1]; - goto callshrp; - } - scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); - } - goto tok; - - case ':': - if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) - return scm_symbol_to_keyword (scm_read (port)); - - /* fallthrough */ - default: -#if SCM_ENABLE_ELISP - read_token: -#endif - j = scm_read_token (c, tok_buf, port, 0); - /* fallthrough */ - - tok: - return scm_string_to_symbol (scm_c_substring (*tok_buf, 0, j)); - } -} -#undef FUNC_NAME - - -#ifdef _UNICOS -_Pragma ("noopt"); /* # pragma _CRI noopt */ -#endif - -size_t -scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) -{ - size_t j; - int c; - - c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(ic) : ic); - - if (weird) - j = 0; - else - { - j = 0; - while (j + 2 >= scm_i_string_length (*tok_buf)) - scm_grow_tok_buf (tok_buf); - scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c)); - ++j; - } - - while (1) - { - while (j + 2 >= scm_i_string_length (*tok_buf)) - scm_grow_tok_buf (tok_buf); - c = scm_getc (port); - switch (c) - { - case '(': - case ')': -#if SCM_ENABLE_ELISP - case '[': - case ']': -#endif - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - if (weird -#if SCM_ENABLE_ELISP - || ((!SCM_ELISP_VECTORS_P) && ((c == '[') || (c == ']'))) -#endif - ) - goto default_case; - - scm_ungetc (c, port); - case EOF: - eof_case: - return j; - case '\\': - if (!weird) - goto default_case; - else - { - c = scm_getc (port); - if (c == EOF) - goto eof_case; - else - goto default_case; - } - case '}': - if (!weird) - goto default_case; - - c = scm_getc (port); - if (c == '#') - { - return j; - } - else - { - scm_ungetc (c, port); - c = '}'; - goto default_case; - } - - default: - default_case: - { - c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(c) : c); - scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c)); - ++j; - } - - } - } -} - -#ifdef _UNICOS -_Pragma ("opt"); /* # pragma _CRI opt */ -#endif - -static SCM -scm_i_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy, char term_char) -#define FUNC_NAME "scm_i_lreadparen" -{ - SCM tmp; - SCM tl; - SCM ans; - int c; - - c = scm_flush_ws (port, name); - if (term_char == c) - return SCM_EOL; - scm_ungetc (c, port); - if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) - { - ans = scm_lreadr (tok_buf, port, copy); - closeit: - if (term_char != (c = scm_flush_ws (port, name))) - scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); - return ans; - } - ans = tl = scm_cons (tmp, SCM_EOL); - while (term_char != (c = scm_flush_ws (port, name))) - { - scm_ungetc (c, port); - if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) - { - SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy)); - goto closeit; - } - SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); - tl = SCM_CDR (tl); - } - return ans; -} -#undef FUNC_NAME - - -SCM -scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) -#define FUNC_NAME "scm_lreadrecparen" -{ - register int c; - register SCM tmp; - register SCM tl, tl2 = SCM_EOL; - SCM ans, ans2 = SCM_EOL; - /* Need to capture line and column numbers here. */ - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; - - c = scm_flush_ws (port, name); - if (')' == c) - return SCM_EOL; - scm_ungetc (c, port); - if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) - { - ans = scm_lreadr (tok_buf, port, copy); - if (')' != (c = scm_flush_ws (port, name))) - scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); - return ans; - } - /* Build the head of the list structure. */ - ans = tl = scm_cons (tmp, SCM_EOL); - if (SCM_COPY_SOURCE_P) - ans2 = tl2 = scm_cons (scm_is_pair (tmp) - ? *copy - : tmp, - SCM_EOL); - while (')' != (c = scm_flush_ws (port, name))) - { - SCM new_tail; - - scm_ungetc (c, port); - if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) - { - SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy)); - if (SCM_COPY_SOURCE_P) - SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) - ? *copy - : tmp, - SCM_EOL)); - if (')' != (c = scm_flush_ws (port, name))) - scm_i_input_error (FUNC_NAME, port, - "missing close paren", SCM_EOL); - goto exit; - } - - new_tail = scm_cons (tmp, SCM_EOL); - SCM_SETCDR (tl, new_tail); - tl = new_tail; - - if (SCM_COPY_SOURCE_P) - { - SCM new_tail2 = scm_cons (scm_is_pair (tmp) ? *copy : tmp, SCM_EOL); - SCM_SETCDR (tl2, new_tail2); - tl2 = new_tail2; - } - } -exit: - scm_whash_insert (scm_source_whash, - ans, - scm_make_srcprops (line, - column, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? *copy = ans2 - : SCM_UNDEFINED, - SCM_EOL)); - return ans; -} -#undef FUNC_NAME - - - - /* Manipulate the read-hash-procedures alist. This could be written in Scheme, but maybe it will also be used by C code during initialisation. */ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, diff --git a/libguile/read.h b/libguile/read.h index 9ff362603..128ba3d34 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -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); diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 9b1c96d42..989ddcab1 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -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))); diff --git a/libguile/script.c b/libguile/script.c index e3425e108..b024378c1 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -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" diff --git a/libguile/socket.c b/libguile/socket.c index 5d09c615b..4ee8a84e5 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -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 diff --git a/libguile/sort.c b/libguile/sort.c index ff33e1ee8..f8e440c02 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -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)) diff --git a/libguile/stacks.c b/libguile/stacks.c index 922c52231..7490db215 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -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" diff --git a/libguile/struct.c b/libguile/struct.c index e96a4912a..a263f9667 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -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", diff --git a/libguile/struct.h b/libguile/struct.h index 515e05997..215f99331 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -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); diff --git a/oop/ChangeLog b/oop/ChangeLog index ecb9445f2..4f86d7ad5 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2007-05-05 Ludovic Courtès + + * goops/internal.scm: Use the public module API rather than hack + with `%module-public-interface', `nested-ref', et al. + 2005-03-24 Mikael Djurfeldt * accessors.scm, simple.scm: New files. diff --git a/oop/goops/internal.scm b/oop/goops/internal.scm index 4288bd6f2..d996805e4 100644 --- a/oop/goops/internal.scm +++ b/oop/goops/internal.scm @@ -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)))) diff --git a/pre-inst-guile.in b/pre-inst-guile.in index ea8e4b1b4..4b7c97e4b 100644 --- a/pre-inst-guile.in +++ b/pre-inst-guile.in @@ -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@" diff --git a/srfi/ChangeLog b/srfi/ChangeLog index fbc5e5d0f..673a3ce6f 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,19 @@ +2007-07-18 Stephen Compall + + * srfi-37.scm: New file. + * Makefile.am: Add it. + +2007-07-09 Ludovic Courtès + + * srfi-19.scm (date->julian-day): Take OFFSET into account. + Patch by Jon Wilson . + +2007-05-09 Ludovic Courtès + + * 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 * srfi/srfi-19.scm (priv:locale-abbr-weekday): Add one to the day diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 569c79dff..46408cba8 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -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 diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 1b71a16bd..08302d0c8 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -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)) diff --git a/srfi/srfi-37.scm b/srfi/srfi-37.scm new file mode 100644 index 000000000..481789ed3 --- /dev/null +++ b/srfi/srfi-37.scm @@ -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 diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 999c0c7d8..af14831fc 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,90 @@ +2007-07-22 Ludovic Courtès + + * 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 + + * tests/syntax.test: Add SRFI-61 `cond' tests. + + * tests/srfi-37.test: New file. + * Makefile.am: Add it. + +2007-07-11 Ludovic Courtès + + * tests/goops.test (defining methods): New test prefix. + +2007-07-09 Ludovic Courtès + + * tests/srfi-19.test (`time-utc->julian-day' honors timezone): + New. Suggested by Jon Wilson . + +2007-06-26 Ludovic Courtès + + * tests/socket.test (htonl): Only executed if `htonl' is defined. + (ntohl): Likewise. Reported by Marijn Schouten (hkBst) + . + +2007-06-12 Ludovic Courtès + + * tests/socket.test: Renamed module to `(test-suite test-socket)'. + (inet-ntop): New test prefix. + +2007-06-07 Ludovic Courtès + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so + that it gets into the distribution. + +2007-02-19 Neil Jerram + + * standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so + that it gets into the distribution. + 2007-01-31 Ludovic Courtès * 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 + + * tests/ports.test (port-line): Check not truncated to "int" on 64-bit + systems. + +2007-01-25 Kevin Ryde + + * 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 * tests/eval.test (values): New test prefix. Values are structs, diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index be5e0a9af..08de5b7d9 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -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 \ diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 111d470e1..2daf95c60 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -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 "^.*")) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index b95fdd0f9..e41f168c0 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -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: diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index dd61369c5..8ed697c59 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -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 ) (s2 )) + (string-append s1 s2)) + m) + (eval '(define-method (my-plus (i1 ) (i2 )) + (+ i1 i2)) + m) + (eval '(and (is-a? my-plus ) + (= (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 ))) + (if (memq (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" diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 9541f0662..43e35d8b7 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -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 () diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 9690122b5..2d25f420a 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1,7 +1,7 @@ ;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- ;;;; Jim Blandy --- 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 ;;; diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index cd76a44ec..e93d1689f 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -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))))) + + diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 6108c74e9..2d9171803 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -1,15 +1,55 @@ -;;;; reader.test --- test the Guile parser -*- scheme -*- -;;;; Jim Blandy --- September 1999 +;;;; reader.test --- Exercise the reader. -*- Scheme -*- +;;;; +;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007 Free Software Foundation, Inc. +;;;; Jim Blandy +;;;; +;;;; 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))))) + diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index 7663b56b7..f5fc2be89 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -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))))) diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index af4578ca0..a49c04857 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -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 '() <)))) + diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 33e667cfc..a553ce4f8 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -1,7 +1,7 @@ ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- ;;;; Matthias Koeppe --- 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" diff --git a/test-suite/tests/srfi-37.test b/test-suite/tests/srfi-37.test new file mode 100644 index 000000000..73647c004 --- /dev/null +++ b/test-suite/tests/srfi-37.test @@ -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) + '())))) + +) diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 5df4665a3..127115eb2 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -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: diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 37d608ce7..1277e5204 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -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)) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index e228dfb09..ebc4499fd 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -1,7 +1,7 @@ ;;;; time.test --- test suite for Guile's time functions -*- scheme -*- ;;;; Jim Blandy --- 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))