diff options
99 files changed, 5062 insertions, 970 deletions
diff --git a/.cvsignore b/.cvsignore index 14d3b2fa4..109038aaa 100644 --- a/.cvsignore +++ b/.cvsignore @@ -27,6 +27,7 @@ install-sh libtool ltconfig ltmain.sh +mdate-sh missing mkinstalldirs pre-inst-guile @@ -1,10 +1,66 @@ -2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr> + + * GUILE-VERSION: Added `LIBGUILE_I18N_*'. + + * configure.in: Look for `strcoll_l ()' and `newlocale ()'. + Substitute the `LIBGUILE_I18N_' variables. + + * NEWS: Mention `(ice-9 i18n)'. + +2006-11-17 Neil Jerram <neil@ossau.uklinux.net> + + * README: Note need for subscription to bug-guile@gnu.org. + + * NEWS: Note need for subscription to bug-guile@gnu.org. + +2006-11-08 Ludovic Courtès <ludovic.courtes@laas.fr> + + * configure.in: Pass `bug-guile@gnu.org' as a third argument to + `AC_INIT'. + +2006-10-25 Neil Jerram <neil@ossau.uklinux.net> + + IA64 HP-UX patch from Hrvoje NikÅ¡ić. (Thanks!) + + * configure.in: New check for uca lib (needed for IA64 on HP-UX). + +2006-10-06 Rob Browning <rlb@defaultvalue.org> + + Guile 1.8.1 released. + + * GUILE-VERSION (GUILE_MICRO_VERSION): Increment for release. + (LIBGUILE_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): Increment for release. + (LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION): Increment for release. + + * Makefile.am (EXTRA_DIST): Add LICENSE. + +2006-09-28 Kevin Ryde <user42@zip.com.au> + + * configure.in (chsize, ftruncate, truncate): New tests, for mingw. + +2006-09-27 Kevin Ryde <user42@zip.com.au> + + * configure.in (clog10): New test, not in mingw. + +2006-09-23 Kevin Ryde <user42@zip.com.au> + + * configure.in (complex.h, complex double, csqrt): New tests. + +2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> * configure.in: Check for `isblank ()'. * NEWS: Mentioned the interaction between `setlocale' and SRFI-14 standard char sets. - + +2006-08-22 Kevin Ryde <user42@zip.com.au> + + * configure.in: Test if need braces around PTHREAD_ONCE_INIT, set + AC_OUTPUT of SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT. + 2006-08-18 Neil Jerram <neil@ossau.uklinux.net> * configure.in: Generate Makefile for emacs subdir. @@ -13,7 +69,21 @@ * configure.in: Generate Makefile for ice-9/debugging subdir. -2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-07-25 Kevin Ryde <user42@zip.com.au> + + * configure.in (AC_CHECK_FUNCS): Add pthread_getattr_np. + +2006-07-24 Kevin Ryde <user42@zip.com.au> + + * configure.in (AC_CHECK_DECLS): Add sethostname for Solaris 10. + (AC_CHECK_FUNCS): Remove dirfd, it's a macro. + Reported by Claes Wallin. + +2006-06-25 Kevin Ryde <user42@zip.com.au> + + * configure.in (AC_CHECK_MEMBERS): Test struct tm.tm_gmtoff. + +2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> * NEWS: Mentioned the new behavior of `equal?' for structures. @@ -216,7 +286,7 @@ * acinclude.m4 (ACX_PTHREAD): New. * configure.in: Use it instead of simply looking for -lpthread. - Thanks to Andreas Vögele! + Thanks to Andreas Vögele! 2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de> @@ -269,7 +339,7 @@ 2004-07-09 Marius Vollmer <mvo@zagadka.de> * configure.in: Bugfix: set SCM_I_GSC_T_UINTMAX, not - SCM_I_GSC_T_INTMAX in two places. Thanks to Andreas Vögele! + SCM_I_GSC_T_INTMAX in two places. Thanks to Andreas Vögele! 2004-07-07 Marius Vollmer <marius.vollmer@uni-dortmund.de> @@ -1988,7 +2058,7 @@ Tue Dec 14 09:12:22 1999 Greg J. Badros <gjb@cs.washington.edu> 1999-07-19 Jim Blandy <jimb@savonarola.red-bean.com> - Fixes for EMX from Mikael Ståldal. + Fixes for EMX from Mikael StÃ¥ldal. * configure.in: Check for <io.h>. * configure: Regenerated. @@ -2923,3 +2993,8 @@ Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com> Makefile. Build doc/Makefile from doc/Makefile.in. * doc/Makefile.in: New file. + + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/GUILE-VERSION b/GUILE-VERSION index 9bc0caf4f..c23f8f6f9 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -54,3 +54,9 @@ LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT=3 LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION=0 LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE=0 LIBGUILE_SRFI_SRFI_60_INTERFACE="${LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE}" + +LIBGUILE_I18N_MAJOR=0 +LIBGUILE_I18N_INTERFACE_CURRENT=0 +LIBGUILE_I18N_INTERFACE_REVISION=0 +LIBGUILE_I18N_INTERFACE_AGE=0 +LIBGUILE_I18N_INTERFACE="${LIBGUILE_I18N_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_I18N_INTERFACE_AGE}" diff --git a/Makefile.am b/Makefile.am index aba01bf7c..ab72bed9f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -30,7 +30,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. -EXTRA_DIST = HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS +EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS TESTS = check-guile @@ -2,7 +2,9 @@ Guile NEWS --- history of user-visible changes. Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. See the end for copying conditions. -Please send Guile bug reports to bug-guile@gnu.org. +Please send Guile bug reports to bug-guile@gnu.org. Note that you +must be subscribed to this list first, in order to successfully send a +report to it. Each release reports the NEWS in the following sections: @@ -22,34 +24,75 @@ Changes in 1.9.XXXXXXXX: Changes in 1.8.1 (since 1.8.0): -* Changes to the distribution +* LFS functions are now used to access 64-bit files on 32-bit systems. -** New primitive-_exit giving the _exit() system call. +* New procedures (see the manual for details) -* Changes to Scheme functions and syntax +** primitive-_exit - [Scheme] the-root-module +** scm_primitive__exit - [C] +** make-completion-function - [Scheme] (ice-9 readline) +** scm_c_locale_stringn_to_number - [C] +** scm_srfi1_append_reverse [C] +** scm_srfi1_append_reverse_x [C] +** scm_log - [C] +** scm_log10 - [C] +** scm_exp - [C] +** scm_sqrt - [C] + +* New `(ice-9 i18n)' module (see the manual for details) + +* Bugs fixed + +** Build problems have been fixed on MacOS, SunOS, and QNX. ** A one-dimensional array can now be 'equal?' to a vector. + ** Structures, records, and SRFI-9 records can now be compared with `equal?'. -** SRFI-14 standard char sets are now recomputed upon successful `setlocale'. -* Changes to the C interface +** SRFI-14 standard char sets are recomputed upon a successful `setlocale'. + +** `record-accessor' and `record-modifier' now have strict type checks. + +Record accessor and modifier procedures now throw an error if the +record type of the record they're given is not the type expected. +(Previously accessors returned #f and modifiers silently did nothing). + +** It is now OK to use both autoload and use-modules on a given module. + +** `apply' checks the number of arguments more carefully on "0 or 1" funcs. + +Previously there was no checking on primatives like make-vector that +accept "one or two" arguments. Now there is. + +** The srfi-1 assoc function now calls its equality predicate properly. + +Previously srfi-1 assoc would call the equality predicate with the key +last. According to the SRFI, the key should be first. + +** A bug in n-par-for-each and n-for-each-par-map has been fixed. + +** The array-set! procedure no longer segfaults when given a bit vector. + +** Bugs in make-shared-array have been fixed. + +** string<? and friends now follow char<? etc order on 8-bit chars. + +** The format procedure now handles inf and nan values for ~f correctly. + +** exact->inexact should no longer overflow when given certain large fractions. + +** srfi-9 accessor and modifier procedures now have strict record type checks. -** New function scm_c_locale_stringn_to_number. +This matches the srfi-9 specification. -* Bug fixes. +** (ice-9 ftw) procedures won't ignore different files with same inode number. -** array-set! with bit vector. -** make-shared-array fixes, including examples in the manual which failed. -** string<? and friends follow char<? etc order on 8-bit chars. -** n-par-for-each, n-for-each-par-map for "futures" variable. -** module autoload and explicit use-modules cooperate. -** ice-9 format ~f with infs and nans. -** exact->inexact overflows on fractions with big num/den but small result. -** srfi-1 assoc "=" procedure argument order. -** Build problems on MacOS, SunOS, QNX. +Previously the (ice-9 ftw) procedures would ignore any file that had +the same inode number as a file they had already seen, even if that +file was on a different device. -Changes since the 1.6.x series: +Changes in 1.8.0 (changes since the 1.6.x series): * Changes to the distribution @@ -16,7 +16,9 @@ This has been the case since the 1.3.* series. The next stable release will likely be version 1.10.0. -Please send bug reports to bug-guile@gnu.org. +Please send bug reports to bug-guile@gnu.org. Note that you must be +subscribed to this list first, in order to successfully send a report +to it. See the LICENSE file for the specific terms that apply to Guile. @@ -59,6 +59,7 @@ For fixes or providing information which led to a fix: Arno Peters Ron Peterson David Pirotte + Carlos Pita Ken Raeburn Andreas Rottmann Kevin Ryde @@ -78,3 +79,4 @@ For fixes or providing information which led to a fix: Michael Tuexen Andy Wingo Keith Wright + William Xu diff --git a/benchmark-suite/ChangeLog b/benchmark-suite/ChangeLog index 2e3cbdcf8..0ec92fdb0 100644 --- a/benchmark-suite/ChangeLog +++ b/benchmark-suite/ChangeLog @@ -1,3 +1,7 @@ +2006-11-17 Neil Jerram <neil@ossau.uklinux.net> + + * README: Note need for subscription to bug-guile@gnu.org. + 2006-05-02 Marius Vollmer <mvo@zagadka.de> * Makefile.am (SCM_BENCHMARKS_DIRS, dist-hook): Removed, they are diff --git a/benchmark-suite/README b/benchmark-suite/README index 186a74351..51051996b 100644 --- a/benchmark-suite/README +++ b/benchmark-suite/README @@ -12,7 +12,9 @@ You can reference the file `lib.scm' from your own code as the module (benchmark-suite lib); it also has comments at the top and before each function explaining what's going on. -Please write more Guile benchmarks, and send them to bug-guile@gnu.org. -We'll merge them into the distribution. All benchmark suites must be -licensed for our use under the GPL, but I don't think we're going to -collect assignment papers for them. +Please write more Guile benchmarks, and send them to +bug-guile@gnu.org. (Note that you must be subscribed to this list +first, in order to successfully send a message to it.) We'll merge +them into the distribution. All benchmark suites must be licensed for +our use under the GPL, but I don't think we're going to collect +assignment papers for them. diff --git a/configure.in b/configure.in index 6255cc2d8..c51ee3dbc 100644 --- a/configure.in +++ b/configure.in @@ -28,7 +28,8 @@ 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})) + m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}), + [bug-guile@gnu.org]) AC_CONFIG_AUX_DIR([.]) AC_CONFIG_SRCDIR(GUILE-VERSION) AM_INIT_AUTOMAKE([no-define]) @@ -212,6 +213,7 @@ if test "$enable_elisp" = yes; then else SCM_I_GSC_ENABLE_ELISP=0 fi +AC_CHECK_LIB(uca, __uc_get_ar_bsp) AC_C_CONST @@ -221,6 +223,7 @@ if test "$ac_cv_c_inline" != no; then else SCM_I_GSC_C_INLINE=NULL fi +AC_CHECK_LIB(uca, __uc_get_ar_bsp) AC_C_BIGENDIAN @@ -523,14 +526,22 @@ AC_HEADER_TIME AC_HEADER_SYS_WAIT # Reasons for testing: +# complex.h - new in C99 # fenv.h - available in C99, but not older systems # -AC_CHECK_HEADERS([fenv.h io.h libc.h limits.h malloc.h memory.h string.h \ +AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h string.h \ regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \ sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \ sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \ direct.h]) +# "complex double" is new in C99, and "complex" is only a keyword if +# <complex.h> is included +AC_CHECK_TYPES(complex double,,, +[#if HAVE_COMPLEX_H +#include <complex.h> +#endif]) + # On MacOS X <sys/socklen.h> contains socklen_t, so must include that # when testing. AC_CHECK_TYPE(socklen_t, , @@ -592,23 +603,32 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # DINFINITY - OSF specific # DQNAN - OSF specific # (DINFINITY and DQNAN are actually global variables, not functions) +# chsize - an MS-DOS-ism, found in mingw +# clog10 - not in mingw (though others like clog and csqrt are) # fesetround - available in C99, but not older systems +# ftruncate - posix, but probably not older systems (current mingw +# has it as an inline for chsize) # ioctl - not in mingw. # gmtime_r - recent posix, not on old systems # readdir_r - recent posix, not on old systems # stat64 - SuS largefile stuff, not on old systems # sysconf - not on old systems +# truncate - not in mingw # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific +# strcoll_l, newlocale - GNU extensions (glibc) # -AC_CHECK_FUNCS([DINFINITY DQNAN ctermid fesetround ftime fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice 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 unsetenv isblank _NSGetEnviron]) +AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice 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]) # Reasons for testing: # netdb.h - not in mingw # sys/param.h - not in mingw +# sethostname - the function itself check because it's not in mingw, +# the DECL is checked because Solaris 10 doens't have in any header # AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) +AC_CHECK_DECLS([sethostname]) # crypt() may or may not be available, for instance in some countries there # are restrictions on cryptography. @@ -627,6 +647,38 @@ AC_SEARCH_LIBS(crypt, crypt, [AC_DEFINE(HAVE_CRYPT,1, [Define to 1 if you have the `crypt' function.])]) +# glibc 2.3.6 (circa 2006) and various prior versions had a bug where +# csqrt(-i) returned a negative real part, when it should be positive +# for the principal root. +# +if test "$ac_cv_type_complex_double" = yes; then + AC_CACHE_CHECK([whether csqrt is usable], + guile_cv_use_csqrt, + [AC_TRY_RUN([ +#include <complex.h> +/* "volatile" is meant to prevent gcc from calculating the sqrt as a + constant, we want to test libc. */ +volatile complex double z = - _Complex_I; +int +main (void) +{ + z = csqrt (z); + if (creal (z) > 0.0) + return 0; /* good */ + else + return 1; /* bad */ +}], + [guile_cv_use_csqrt=yes], + [guile_cv_use_csqrt="no, glibc 2.3 bug"], + [guile_cv_use_csqrt="yes, hopefully (cross-compiling)"])]) + case $guile_cv_use_csqrt in + yes*) + AC_DEFINE(HAVE_USABLE_CSQRT, 1, [Define to 1 if csqrt is bug-free]) + ;; + esac +fi + + dnl GMP tests AC_CHECK_LIB([gmp], [__gmpz_init], , [AC_MSG_ERROR([GNU MP not found, see README])]) @@ -878,10 +930,9 @@ AC_CHECK_HEADERS(floatingpoint.h ieeefp.h nan.h) # Reasons for testing: # asinh, acosh, atanh, trunc - C99 standard, generally not available on # older systems -# dirfd - mainly BSD derived, not in older systems # sincos - GLIBC extension # -AC_CHECK_FUNCS(asinh acosh atanh copysign dirfd finite sincos trunc) +AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos trunc) # C99 specifies isinf and isnan as macros. # HP-UX provides only macros, no functions. @@ -924,6 +975,7 @@ fi # st_rdev # st_blksize # st_blocks not in mingw +# tm_gmtoff BSD+GNU, not in C99 # # Note AC_STRUCT_ST_BLOCKS is not used here because we don't want the # AC_LIBOBJ(fileblocks) replacement which that macro gives. @@ -931,8 +983,22 @@ fi AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct stat.st_blocks]) AC_STRUCT_TIMEZONE +AC_CHECK_MEMBERS([struct tm.tm_gmtoff],,, +[#include <time.h> +#ifdef TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif +]) GUILE_STRUCT_UTIMBUF + #-------------------------------------------------------------------- # # Which way does the stack grow? @@ -1009,6 +1075,8 @@ AC_SUBST([SCM_I_GSC_USE_NULL_THREADS]) AC_ARG_WITH(threads, [ --with-threads thread interface], , with_threads=yes) +AC_SUBST(SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT, 0) + case "$with_threads" in "yes" | "pthread" | "pthreads" | "pthread-threads" | "") ACX_PTHREAD(CC="$PTHREAD_CC" @@ -1019,7 +1087,32 @@ case "$with_threads" in old_CFLAGS="$CFLAGS" CFLAGS="$PTHREAD_CFLAGS $CFLAGS" - AC_CHECK_FUNCS(pthread_attr_getstack) + + # Reasons for testing: + # pthread_getattr_np - "np" meaning "non portable" says it + # all; not present on MacOS X or Solaris 10 + # + AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np) + + # On past versions of Solaris, believe 8 through 10 at least, you + # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };". + # This is contrary to posix: + # http://www.opengroup.org/onlinepubs/000095399/functions/pthread_once.html + # Check here if this style is required. + # + # glibc (2.3.6 at least) works both with or without braces, so the + # test checks whether it works without. + # + AC_CACHE_CHECK([whether PTHREAD_ONCE_INIT needs braces], + guile_cv_need_braces_on_pthread_once_init, + [AC_TRY_COMPILE([#include <pthread.h>], + [pthread_once_t foo = PTHREAD_ONCE_INIT;], + [guile_cv_need_braces_on_pthread_once_init=no], + [guile_cv_need_braces_on_pthread_once_init=yes])]) + if test "$guile_cv_need_braces_on_pthread_once_init" = yes; then + SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT=1 + fi + CFLAGS="$old_CFLAGS" # On Solaris, sched_yield lives in -lrt. @@ -1195,6 +1288,13 @@ AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION) AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE) AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE) +AC_SUBST(LIBGUILE_I18N_MAJOR) +AC_SUBST(LIBGUILE_I18N_INTERFACE_CURRENT) +AC_SUBST(LIBGUILE_I18N_INTERFACE_REVISION) +AC_SUBST(LIBGUILE_I18N_INTERFACE_AGE) +AC_SUBST(LIBGUILE_I18N_INTERFACE) + + ####################################################################### dnl Tell guile-config what flags guile users should compile and link with. diff --git a/doc/goops/ChangeLog b/doc/goops/ChangeLog index 22a5c82c2..b0e742b71 100644 --- a/doc/goops/ChangeLog +++ b/doc/goops/ChangeLog @@ -1,4 +1,4 @@ -2006-09-27 Neil Jerram <neil@ossau.uklinux.net> +2006-09-28 Neil Jerram <neil@ossau.uklinux.net> * goops.texi (Slot Options): Added example from Ludovic Courtès about difference between init-value, -form and -thunk. diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0768f1d8d..8b8e0befe 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,80 @@ +2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr> + + * Makefile.am (BUILT_SOURCES): New variable. + (lib-version.texi): New target. + + * guile.texi: Include `lib-version.texi'. + + * api-data.texi (Conversion): Link to `The ice-9 i18n Module' when + describing `string->number'. + (String Comparison): Likewise. + + * api-i18n.texi (Internationalization)[The ice-9 i18n Module]: New + node. + [Gettext Support]: New node; contains text formerly in + `Internationalization'. + + * posix.texi (Locales): Added a link to the glibc manual + describing the various locale categories. Mention locale objects + and link to `The ice-9 i18n Module' when describing `setlocale'. + +2006-11-17 Neil Jerram <neil@ossau.uklinux.net> + + * intro.texi (Reporting Bugs): Note need for subscription to + bug-guile@gnu.org. + +2006-10-10 Neil Jerram <neil@ossau.uklinux.net> + + * scheme-using.texi (Setting and Managing Breakpoints): New text + about what happens when a breakpoint is created. + (Listing and Deleting Breakpoints, Moving and Losing Breakpoints): + New. + +2006-10-08 Neil Jerram <neil@ossau.uklinux.net> + + * scheme-using.texi (Working with GDS in Scheme Buffers): New + subsection, to group (Access to Guile Help and Completion, Setting + and Managing Breakpoints, Evaluating Scheme Code) together. + (GDS Getting Started): Editorial updates. + +2006-10-06 Neil Jerram <neil@ossau.uklinux.net> + + * scheme-using.texi (Using Guile in Emacs): Subnodes reordered, + from (Displaying the Scheme Stack, Continuing Execution, + Evaluating Scheme Code, Setting and Managing Breakpoints, Access + to Guile Help and Completion) to (Access to Guile Help and + Completion, Setting and Managing Breakpoints, Evaluating Scheme + Code, Displaying the Scheme Stack, Continuing Execution). + (Access to Guile Help and Completion): Mention where keys are + defined. + (Setting and Managing Breakpoints): Update text on how to set + breakpoints. + +2006-10-05 Kevin Ryde <user42@zip.com.au> + + * misc-modules.texi (File Tree Walk): Corrections to BASE parameter + and symlink vs stale-symlink types in nftw. + * misc-modules.texi, guile.texi (Buffered Input): New section, + describing (ice-9 buffered-input). + + * posix.texi (User Information): Clarify getpwent returns #f at end of + file. + + * repl-modules.texi (Readline Functions): New section on how to call + readline from scheme code. + +2006-10-03 Neil Jerram <neil@ossau.uklinux.net> + + * scheme-using.texi (GDS Getting Started): Editorial updates. + +2006-09-28 Neil Jerram <neil@ossau.uklinux.net> + + * scheme-using.texi (GDS Introduction, GDS Getting Started): Minor + edits. + + * api-data.texi (Symbol Props): Remove unnecessarily specific + parenthesis about Guile 1.6's use of extra symbol slots. + 2006-09-26 Neil Jerram <neil@ossau.uklinux.net> * scheme-using.texi (Using Guile in Emacs, GDS Introduction): @@ -7,6 +84,12 @@ (GDS Getting Started, How to Use GDS): Merged; editorial updates; subsections reordered. +2006-09-26 Kevin Ryde <user42@zip.com.au> + + * api-io.texi (Random Access): In truncate-file, tweak wording for + clarity, note cannot always extend file this way. + (Ports): File access uses LFS. + 2006-09-25 Neil Jerram <neil@ossau.uklinux.net> * scheme-using.texi (Error Handling, Interactive Debugger): Minor @@ -19,11 +102,31 @@ minor improvements. Removed doc for `trace-finish', which no longer exists. -2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-09-22 Kevin Ryde <user42@zip.com.au> + + * api-data.texi (Scientific): In sqrt, note it's the positive root + which is returned (as per R5RS). + +2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> * api-data.texi (Standard Character Sets): Documented the charset recomputation upon successful `setlocale'. +2006-09-08 Kevin Ryde <user42@zip.com.au> + + * misc-modules.texi (Formatted Output): Show ":@" rather than "@:", + because ":@" is traditional common lisp, though either way works. + Break a couple of example lines to avoid overflowing DVI page width. + + * scheme-debugging.texi (Debug Last Error): Line break in "Type + (backtrace) to get ..." which overflowed the line in both info and + DVI. Reported by Percy Tiglao. + +2006-09-05 Kevin Ryde <user42@zip.com.au> + + * posix.texi (Network Sockets and Communication): Tweak description, + note not multi-threading. + 2006-09-04 Neil Jerram <neil@ossau.uklinux.net> * api-control.texi (Dynamic Wind): Doc for scm_dynwind_free. @@ -37,6 +140,11 @@ * api-debug.texi (Debug on Error): Added paragraph on need to use debugging evaluator. Added text on what the Guile REPL code does. +2006-08-29 Kevin Ryde <user42@zip.com.au> + + * api-control.texi (Dynamic Wind): Reformat example a bit to avoid + going off the right edge of the paper. Reported by Percy Tiglao. + 2006-08-28 Neil Jerram <neil@ossau.uklinux.net> * api-debug.texi (Examining the Stack): Minor improvements to @@ -55,6 +163,11 @@ (GDS Introduction): New node, containing GDS-specific introductory text. +2006-08-22 Kevin Ryde <user42@zip.com.au> + + * api-i18n.texi (Internationalization): Cross reference gettext manual + on plural forms. + 2006-08-18 Neil Jerram <neil@ossau.uklinux.net> * scheme-using.texi (Using Guile in Emacs): Unignore extra GDS @@ -110,12 +223,23 @@ * Makefile.am (guile_TEXINFOS): Include new scheme-using.texi file. -2006-06-16 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-07-24 Kevin Ryde <user42@zip.com.au> + + * api-evaluation.texi (Fly Evaluation): Add scm_c_eval_string. + (Loading): Add scm_c_primitive_load. + Reported by Jon Wilson. + +2006-06-25 Kevin Ryde <user42@zip.com.au> + + * posix.texi (Time): In tm:gmtoff, give example values, note not the + same as C tm_gmtoff. + +2006-06-16 Ludovic Courtès <ludovic.courtes@laas.fr> * api-utility.texi (Equality): Mentioned the behavior of `equal?' for structures (as suggested by Kevin Ryde). -2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> * api-compound.texi (Structure Concepts): Mentioned the behavior of `equal?' for structures. @@ -182,7 +306,7 @@ SCM_SIMPLE_VECTOR_SET not SCM_SIMPLE_VECTOR_SET_X, the former is what's in vector.h. -2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr> * api-data.texi (Conversion): Add scm_c_locale_stringn_to_number. @@ -234,7 +358,7 @@ contexts. Renamed all functions from scm_frame_ to scm_dynwind_. Updated documentation. -2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr> * api-data.texi (Operations Related to Symbols): Documented `scm_take_locale_symbol ()'. @@ -276,7 +400,7 @@ 2005-11-06 Kevin Ryde <user42@zip.com.au> - From Ludovic Courtès, partial rework by me: + From Ludovic Courtès, partial rework by me: * doc/ref/api-modules.texi (Creating Guile Modules): In define-module, describe #:re-export, #:export-syntax, #:re-export-syntax, #:replace and #:duplicates. Add re-export. @@ -289,7 +413,7 @@ * posix.texi (Network Socket Address): Add scm_make_socket_address, scm_c_make_socket_address, scm_from_sockaddr, scm_to_sockaddr. This - change by Ludovic Courtès and revised a bit by me. + change by Ludovic Courtès and revised a bit by me. 2005-10-27 Kevin Ryde <user42@zip.com.au> @@ -2395,3 +2519,8 @@ The change log for files in this directory continues backwards from 2001-08-27 in ../ChangeLog, as all the Guile documentation prior to this date was contained in a single directory. + + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 76a66f0c9..7d009ff52 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -21,6 +21,9 @@ AUTOMAKE_OPTIONS = gnu +BUILT_SOURCES = lib-version.texi + + info_TEXINFOS = guile.texi guile_TEXINFOS = preface.texi \ @@ -86,4 +89,10 @@ autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4 $(preinstguiletool)/snarf-guile-m4-docs $< > $(srcdir)/$@ +lib-version.texi: $(top_srcdir)/GUILE-VERSION + cat "$^" | grep '^LIBGUILE_.*_MAJOR' | \ + sed 's/^LIBGUILE_\([A-Z0-9_]*\)_MAJOR=\([0-9]\+\)/@set LIBGUILE_\1_MAJOR \2/' \ + > "$@" + + MAINTAINERCLEANFILES = autoconf-macros.texi diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index dbb51cf6f..11a276a13 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1234,28 +1234,29 @@ non-locally, @var{out_guard} is called. If the dynamic extent of the dynamic-wind is re-entered, @var{in_guard} is called. Thus @var{in_guard} and @var{out_guard} may be called any number of times. + @lisp (define x 'normal-binding) @result{} x -(define a-cont (call-with-current-continuation - (lambda (escape) - (let ((old-x x)) - (dynamic-wind - ;; in-guard: - ;; - (lambda () (set! x 'special-binding)) - - ;; thunk - ;; - (lambda () (display x) (newline) - (call-with-current-continuation escape) - (display x) (newline) - x) - - ;; out-guard: - ;; - (lambda () (set! x old-x))))))) - +(define a-cont + (call-with-current-continuation + (lambda (escape) + (let ((old-x x)) + (dynamic-wind + ;; in-guard: + ;; + (lambda () (set! x 'special-binding)) + + ;; thunk + ;; + (lambda () (display x) (newline) + (call-with-current-continuation escape) + (display x) (newline) + x) + + ;; out-guard: + ;; + (lambda () (set! x old-x))))))) ;; Prints: special-binding ;; Evaluates to: diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 15eac2e4b..abcb28de1 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.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, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1012,6 +1012,12 @@ zero. @rnindex number->string @rnindex string->number +The following procedures read and write numbers according to their +external representation as defined by R5RS (@pxref{Lexical structure, +R5RS Lexical Structure,, r5rs, The Revised^5 Report on the Algorithmic +Language Scheme}). @xref{The ice-9 i18n Module, the @code{(ice-9 +i18n)} module}, for locale-dependent number parsing. + @deffn {Scheme Procedure} number->string n [radix] @deffnx {C Function} scm_number_to_string (n, radix) Return a string holding the external representation of the @@ -1214,7 +1220,16 @@ including complex numbers. @rnindex sqrt @c begin (texi-doc-string "guile" "sqrt") @deffn {Scheme Procedure} sqrt z -Return the square root of @var{z}. +Return the square root of @var{z}. Of the two possible roots +(positive and negative), the one with the a positive real part is +returned, or if that's zero then a positive imaginary part. Thus, + +@example +(sqrt 9.0) @result{} 3.0 +(sqrt -9.0) @result{} 0.0+3.0i +(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i +(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i +@end example @end deffn @rnindex expt @@ -2934,7 +2949,8 @@ predicates (@pxref{Characters}), but are defined on character sequences. The first set is specified in R5RS and has names that end in @code{?}. The second set is specified in SRFI-13 and the names have no ending @code{?}. The predicates ending in @code{-ci} ignore the character case -when comparing strings. +when comparing strings. @xref{The ice-9 i18n Module, the @code{(ice-9 +i18n)} module}, for locale-dependent string comparison. @rnindex string=? @deffn {Scheme Procedure} string=? s1 s2 @@ -4674,10 +4690,8 @@ see @code{symbol-property}. @end deffn Support for these extra slots may be removed in a future release, and it -is probably better to avoid using them. (In release 1.6, Guile itself -uses the property list slot sparingly, and the function slot not at -all.) For a more modern and Schemely approach to properties, see -@ref{Object Properties}. +is probably better to avoid using them. For a more modern and Schemely +approach to properties, see @ref{Object Properties}. @node Symbol Read Syntax diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 6f29f1d7c..1da13de43 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.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, 2005, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -357,6 +357,11 @@ While the code is evaluated, the given module is made the current one. The current module is restored when this procedure returns. @end deffn +@deftypefn {C Function} SCM scm_c_eval_string (const char *string) +@code{scm_eval_string}, but taking a C string instead of an +@code{SCM}. +@end deftypefn + @deffn {Scheme Procedure} apply proc arg1 @dots{} argN arglst @deffnx {C Function} scm_apply_0 (proc, arglst) @deffnx {C Function} scm_apply_1 (proc, arg1, arglst) @@ -446,6 +451,11 @@ that will be called before any code is loaded. See the documentation for @code{%load-hook} later in this section. @end deffn +@deftypefn {C Function} SCM scm_c_primitive_load (const char *filename) +@code{scm_primitive_load}, but taking a C string instead of an +@code{SCM}. +@end deftypefn + @deffn {Scheme Procedure} primitive-load-path filename @deffnx {C Function} scm_primitive_load_path (filename) Search @code{%load-path} for the file named @var{filename} and diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi index 995e27e90..1927a755b 100644 --- a/doc/ref/api-i18n.texi +++ b/doc/ref/api-i18n.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, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -8,6 +8,292 @@ @node Internationalization @section Support for Internationalization +@cindex internationalization +@cindex i18n + +Guile provides internationalization support for Scheme programs in two +ways. First, procedures to manipulate text and data in a way that +conforms to particular cultural conventions (i.e., in a +``locale-dependent'' way) are provided in the @code{(ice-9 i18n)}. +Second, Guile allows the use of GNU @code{gettext} to translate +program message strings. + +@menu +* The ice-9 i18n Module:: Honoring cultural conventions. +* Gettext Support:: Translating message strings. +@end menu + + +@node The ice-9 i18n Module +@subsection The @code{(ice-9 i18n)} Module + +In order to make use of the following functions, one must import the +@code{(ice-9 i18n)} module in the usual way: + +@example +(use-modules (ice-9 i18n)) +@end example + +@cindex libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR} + +C programs can use the C functions corresponding to the procedures of +this module by including @code{<libguile/i18n.h>} and by linking +against @code{libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR}}. + +@cindex cultural conventions + +The @code{(ice-9 i18n)} module provides procedures to manipulate text +and other data in a way that conforms to the cultural conventions +chosen by the user. Each region of the world or language has its own +customs to, for instance, represent real numbers, classify characters, +collate text, etc. All these aspects comprise the so-called +``cultural conventions'' of that region or language. + +@cindex locale +@cindex locale category + +Computer systems typically refer to a set of cultural conventions as a +@dfn{locale}. For each particular aspect that comprise those cultural +conventions, a @dfn{locale category} is defined. For instance, the +way characters are classified is defined by the @code{LC_CTYPE} +category, while the language in which program messages are issued to +the user is defined by the @code{LC_MESSAGES} category +(@pxref{Locales, General Locale Information} for details). + +@cindex locale object + +The procedures provided by this module allow the development of +programs that adapt automatically to any locale setting. As we will +see later, many of the locale-dependent procedures provided by this +module can optionally take a @dfn{locale object} argument. This +additional argument defines the locale settings that must be followed +by the invoked procedure. When it is omitted, then the current locale +settings of the process are followed (@pxref{Locales, +@code{setlocale}}). + +The following procedures allow the manipulation of such locale +objects. + +@deffn {Scheme Procedure} make-locale category-mask locale-name [base-locale] +@deffnx {C Function} scm_make_locale (category_mask, locale_name, base_locale) +Return a reference to a data structure representing a set of locale +datasets. @var{locale-name} should be a string denoting a particular +locale, e.g., @code{"aa_DJ"}. Unlike for the @var{category} parameter +for @code{setlocale}, the @var{category-mask} parameter here uses a +single bit for each category, made by OR'ing together @code{LC_*_MASK} +bits. The optional @var{base-locale} argument can be used to specify +a locale object whose settings are to be used as a basis for the +locale object being returned. + +The available locale category masks are the following: + +@defvar LC_COLLATE_MASK +Represents the collation locale category. +@end defvar +@defvar LC_CTYPE_MASK +Represents the character classification locale category. +@end defvar +@defvar LC_MESSAGES_MASK +Represents the messages locale category. +@end defvar +@defvar LC_MONETARY_MASK +Represents the monetary locale category. +@end defvar +@defvar LC_NUMERIC_MASK +Represents the way numbers are displayed. +@end defvar +@defvar LC_TIME_MASK +Represents the way date and time are displayed +@end defvar + +The following category masks are also available but will not have any +effect on systems that do not support them: + +@defvar LC_PAPER_MASK +@defvarx LC_NAME_MASK +@defvarx LC_ADDRESS_MASK +@defvarx LC_TELEPHONE_MASK +@defvarx LC_MEASUREMENT_MASK +@defvarx LC_IDENTIFICATION_MASK +@end defvar + +Finally, there is also: + +@defvar LC_ALL_MASK +This represents all the locale categories supported by the system. +@end defvar + +The @code{LC_*_MASK} variables are bound to integers which may be OR'd +together using @code{logior} (@pxref{Primitive Numerics, +@code{logior}}). For instance, the following invocation creates a +locale object that combines the use of Esperanto for messages and +character classification with the default settings for the other +categories (i.e., the settings of the default @code{C} locale which +usually represents conventions in use in the USA): + +@example +(make-locale (logior LC_MESSAGE_MASK LC_CTYPE_MASK) "eo_EO") +@end example + +The following example combines the use of Swedish conventions with +monetary conventions from Croatia: + +@example +(make-locale LC_MONETARY_MASK "hr_HR" + (make-locale LC_ALL_MASK "sv_SE")) +@end example + +A @code{system-error} exception (@pxref{Handling Errors}) is raised by +@code{make-locale} when @var{locale-name} does not match any of the +locales compiled on the system. Note that on non-GNU systems, this +error may be raised later, when the locale object is actually used. + +@end deffn + +@deffn {Scheme Procedure} locale? obj +@deffnx {C Function} scm_locale_p (obj) +Return true if @var{obj} is a locale object. +@end deffn + +The following procedures provide support for text collation. + +@deffn {Scheme Procedure} string-locale<? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_lt (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a locale-dependent way. If +@var{locale} is provided, it should be locale object (as returned by +@code{make-locale}) and will be used to perform the comparison; +otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} string-locale>? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_gt (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a locale-dependent way. If +@var{locale} is provided, it should be locale object (as returned by +@code{make-locale}) and will be used to perform the comparison; +otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} string-locale-ci<? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a case-insensitive, and +locale-dependent way. If @var{locale} is provided, it should be +locale object (as returned by @code{make-locale}) and will be used to +perform the comparison; otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} string-locale-ci>? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a case-insensitive, and +locale-dependent way. If @var{locale} is provided, it should be +locale object (as returned by @code{make-locale}) and will be used to +perform the comparison; otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} string-locale-ci=? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_eq (s1, s2, locale) +Compare strings @var{s1} and @var{s2} in a case-insensitive, and +locale-dependent way. If @var{locale} is provided, it should be +locale object (as returned by @code{make-locale}) and will be used to +perform the comparison; otherwise, the current system locale is used. +@end deffn + +@deffn {Scheme Procedure} char-locale<? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_lt (c1, c2, locale) +Return true if character @var{c1} is lower than @var{c2} according to +@var{locale} or to the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale>? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_gt (c1, c2, locale) +Return true if character @var{c1} is greater than @var{c2} according +to @var{locale} or to the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-ci<? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_ci_lt (c1, c2, locale) +Return true if character @var{c1} is lower than @var{c2}, in a case +insensitive way according to @var{locale} or to the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-ci>? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_ci_gt (c1, c2, locale) +Return true if character @var{c1} is greater than @var{c2}, in a case +insensitive way according to @var{locale} or to the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale] +@deffnx {C Function} scm_char_locale_ci_eq (c1, c2, locale) +Return true if character @var{c1} is equal to @var{c2}, in a case +insensitive way according to @var{locale} or to the current locale. +@end deffn + +The procedures below provide support for ``character case mapping'', +i.e., to convert characters or strings to their upper-case or +lower-case equivalent. Note that SRFI-13 provides procedures that +look similar (@pxref{Alphabetic Case Mapping}). However, the SRFI-13 +procedures are locale-independent. Therefore, they do not take into +account specificities of the customs in use in a particular language +or region of the world. For instance, while most languages using the +Latin alphabet map lower-case letter ``i'' to upper-case letter ``I'', +Turkish maps lower-case ``i'' to ``Latin capital letter I with dot +above''. The following procedures allow to provide idiomatic +character mapping. + +@deffn {Scheme Procedure} char-locale-downcase chr [locale] +@deffnx {C Function} scm_char_locale_upcase (chr, locale) +Return the lowercase character that corresponds to @var{chr} according +to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-upcase chr [locale] +@deffnx {C Function} scm_char_locale_downcase (chr, locale) +Return the uppercase character that corresponds to @var{chr} according +to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} string-locale-upcase str [locale] +@deffnx {C Function} scm_string_locale_upcase (str, locale) +Return a new string that is the uppercase version of @var{str} +according to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} string-locale-downcase str [locale] +@deffnx {C Function} scm_string_locale_downcase (str, locale) +Return a new string that is the down-case version of @var{str} +according to either @var{locale} or the current locale. +@end deffn + +Finally, the following procedures allow programs to read numbers +written according to a particular locale. As an example, in English, +``ten thousand and a half'' is usually written @code{10,000.5} while +in French it is written @code{10000,5}. These procedures allow to +account for these differences. + +@deffn {Scheme Procedure} locale-string->integer str [base [locale]] +@deffnx {C Function} scm_locale_string_to_integer (str, base, locale) +Convert string @var{str} into an integer according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +the current process locale. If @var{base} is specified, then it +determines the base of the integer being read (e.g., @code{16} for an +hexadecimal number, @code{10} for a decimal number); by default, +decimal numbers are read. Return two values: an integer (on success) +or @code{#f}, and the number of characters read from @var{str} +(@code{0} on failure). +@end deffn + +@deffn {Scheme Procedure} locale-string->inexact str [locale] +@deffnx {C Function} scm_locale_string_to_inexact (str, locale) +Convert string @var{str} into an inexact number according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +the current process locale. Return two values: an inexact number (on +success) or @code{#f}, and the number of characters read from +@var{str} (@code{0} on failure). +@end deffn + + +@node Gettext Support +@subsection Gettext Support + Guile provides an interface to GNU @code{gettext} for translating message strings (@pxref{Introduction,,, gettext, GNU @code{gettext} utilities}). @@ -19,7 +305,8 @@ catalog filename). When @code{gettext} is not available, or if Guile was configured @samp{--without-nls}, dummy functions doing no translation are -provided. +provided. When @code{gettext} support is available in Guile, the +@code{i18n} feature is provided (@pxref{Feature Tracking}). @deffn {Scheme Procedure} gettext msg [domain [category]] @deffnx {C Function} scm_gettext (msg, domain, category) @@ -85,7 +372,8 @@ example, It's important to use @code{ngettext} rather than plain @code{gettext} for plurals, since the rules for singular and plural forms in English are not the same in other languages. Only @code{ngettext} will allow -translators to give correct forms. +translators to give correct forms (@pxref{Plural forms,, Additional +functions for plural forms, gettext, GNU @code{gettext} utilities}). @end deffn @deffn {Scheme Procedure} textdomain [domain] @@ -154,4 +442,5 @@ future. @c Local Variables: @c TeX-master: "guile.texi" +@c ispell-local-dictionary: "american" @c End: diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 6eb95db3d..0d30c4d2a 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -64,6 +64,10 @@ rely on that to keep it away from system limits. An explicit call to If program flow makes it hard to be certain when to close then this may be an acceptable way to control resource usage. +All file access uses the ``LFS'' large file support functions when +available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be +read and written on a 32-bit system. + @rnindex input-port? @deffn {Scheme Procedure} input-port? x @deffnx {C Function} scm_input_port_p (x) @@ -390,14 +394,18 @@ Return an integer representing the current position of @findex truncate @findex ftruncate -@deffn {Scheme Procedure} truncate-file object [length] -@deffnx {C Function} scm_truncate_file (object, length) -Truncates the object referred to by @var{object} to at most -@var{length} bytes. @var{object} can be a string containing a -file name or an integer file descriptor or a port. -@var{length} may be omitted if @var{object} is not a file name, -in which case the truncation occurs at the current port -position. The return value is unspecified. +@deffn {Scheme Procedure} truncate-file file [length] +@deffnx {C Function} scm_truncate_file (file, length) +Truncate @var{file} to @var{length} bytes. @var{file} can be a +filename string, a port object, or an integer file descriptor. The +return value is unspecified. + +For a port or file descriptor @var{length} can be omitted, in which +case the file is truncated at the current position (per @code{ftell} +above). + +On most systems a file can be extended by giving a length greater than +the current size, but this is not mandatory in the POSIX standard. @end deffn @node Line/Delimited diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 627c8cbb2..109a50b7f 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -7,6 +7,7 @@ @set MANUAL-EDITION 1.1 @c %**end of header @include version.texi +@include lib-version.texi @copying This reference manual documents Guile, GNU's Ubiquitous Intelligent @@ -137,7 +138,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.46 2006-08-01 21:51:12 ossau Exp $ +@c @subtitle $Id: guile.texi,v 1.48 2006-11-18 18:14:55 civodul Exp $ @c See preface.texi for the list of authors @author The Guile Developers @@ -347,6 +348,7 @@ available through both Scheme and C interfaces. * File Tree Walk:: Traversing the file system. * Queues:: First-in first-out queuing. * Streams:: Sequences of values. +* Buffered Input:: Ports made from a reader function. * Expect:: Controlling interactive programs with Guile. * The Scheme shell (scsh):: Using scsh interfaces in Guile. @end menu diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi index a31fe30f8..1494b81ee 100644 --- a/doc/ref/intro.texi +++ b/doc/ref/intro.texi @@ -420,7 +420,8 @@ purpose to check whether your code still relies on them. @section Reporting Bugs Any problems with the installation should be reported to -@email{bug-guile@@gnu.org}. +@email{bug-guile@@gnu.org}. Please note that you must be subscribed to +this list first, in order to successfully send a report to it. Whenever you have found a bug in Guile you are encouraged to report it to the Guile developers, so they can fix it. They may also be able to diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index f3a3c4093..db90c419a 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-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, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -270,13 +270,13 @@ With no parameters output is in words as a cardinal like ``ten'', or @end example And also with no parameters, @nicode{~@@r} gives roman numerals and -@nicode{~@@:r} gives old roman numerals. In old roman numerals +@nicode{~:@@r} gives old roman numerals. In old roman numerals there's no ``subtraction'', so 9 is @nicode{VIIII} instead of @nicode{IX}. In both cases only positive numbers can be output. @example (format #t "~@@r" 89) @print{} LXXXIX ;; roman -(format #t "~@@:r" 89) @print{} LXXXVIIII ;; old roman +(format #t "~:@@r" 89) @print{} LXXXVIIII ;; old roman @end example When a parameter is given it means numeric output in the specified @@ -507,7 +507,7 @@ puts the padding after the sign. @example (format #f "~,,8$" -1.5) @result{} " -1.50" (format #f "~,,8:$" -1.5) @result{} "- 1.50" -(format #f "~,,8,'.@@:$" 3) @result{} "+...3.00" +(format #f "~,,8,'.:@@$" 3) @result{} "+...3.00" @end example Note that floating point for dollar amounts is generally not a good @@ -567,7 +567,7 @@ one, which can be convenient when printing some sort of count. @example (format #t "~d cat~:p" 9) @print{} 9 cats -(format #t "~d pupp~@@:p" 5) @print{} 5 puppies +(format #t "~d pupp~:@@p" 5) @print{} 5 puppies @end example @nicode{~p} is designed for English plurals and there's no attempt to @@ -777,14 +777,14 @@ The modifiers on @nicode{~(} control the conversion. @c rest lower case. @c @item -@nicode{~@@:(} --- upper case. +@nicode{~:@@(} --- upper case. @end itemize For example, @example (format #t "~(Hello~)") @print{} hello -(format #t "~@@:(Hello~)") @print{} HELLO +(format #t "~:@@(Hello~)") @print{} HELLO @end example In the future it's intended the modifiers @nicode{:} and @nicode{@@} @@ -813,8 +813,10 @@ elements from it. This is a convenient way to output a whole list. @nicode{~:@{} takes a single argument which is a list of lists, each of those contained lists gives the arguments for the iterated format. +@c @print{} on a new line here to avoid overflowing page width in DVI @example -(format #t "~:@{~dx~d ~@}" '((1 2) (3 4) (5 6))) @print{} 1x2 3x4 5x6 +(format #t "~:@{~dx~d ~@}" '((1 2) (3 4) (5 6))) +@print{} 1x2 3x4 5x6 @end example @nicode{~@@@{} takes arguments directly, with each iteration @@ -825,11 +827,13 @@ successively consuming arguments. (format #t "~@@@{~s=~d ~@}" "x" 1 "y" 2) @print{} "x"=1 "y"=2 @end example -@nicode{~@@:@{} takes list arguments, one argument for each iteration, +@nicode{~:@@@{} takes list arguments, one argument for each iteration, using that list for the format. +@c @print{} on a new line here to avoid overflowing page width in DVI @example -(format #t "~@@:@{~dx~d ~@}" '(1 2) '(3 4) '(5 6)) @print{} 1x2 3x4 5x6 +(format #t "~:@@@{~dx~d ~@}" '(1 2) '(3 4) '(5 6)) +@print{} 1x2 3x4 5x6 @end example Iterating stops when there are no more arguments or when the @@ -1094,27 +1098,28 @@ Walk the filesystem tree starting at @var{startname}, calling @var{proc} for each file and directory. @code{nftw} has extra features over the basic @code{ftw} described above. -Hard links and symbolic links are followed, but a file or directory is -reported to @var{proc} only once, and skipped if seen again in another -place. One consequence of this is that @code{nftw} is safe against -circular linked directory structures. +Like @code{ftw}, hard links and symbolic links are followed. A file +or directory is reported to @var{proc} only once, and skipped if seen +again in another place. One consequence of this is that @code{nftw} +is safe against circular linked directory structures. Each @var{proc} call is @code{(@var{proc} filename statinfo flag -basename level)} and it should return @code{#t} to continue, or any +base level)} and it should return @code{#t} to continue, or any other value to stop. @var{filename} is the item visited, being @var{startname} plus a further path and the name of the item. @var{statinfo} is the return -from @code{stat} on @var{filename} (@pxref{File System}). -@var{basename} it the item name without any path. @var{level} is an -integer giving the directory nesting level, starting from 0 for the -contents of @var{startname} (or that item itself if it's a file). -@var{flag} is one of the following symbols, +from @code{stat} on @var{filename} (@pxref{File System}). @var{base} +is an integer offset into @var{filename} which is where the basename +for this item begins. @var{level} is an integer giving the directory +nesting level, starting from 0 for the contents of @var{startname} (or +that item itself if it's a file). @var{flag} is one of the following +symbols, @table @code @item regular -@var{filename} is a file, this includes special files like devices, -named pipes, etc. +@var{filename} is a file, including special files like devices, named +pipes, etc. @item directory @var{filename} is a directory. @@ -1132,19 +1137,15 @@ nothing is known about it. @var{statinfo} is @code{#f} in this case. @var{filename} is a directory, but one which cannot be read and hence won't be recursed into. -@item symlink -@var{filename} is a dangling symbolic link. Symbolic links are -normally followed and their target reported, the link itself is -reported if the target does not exist. - -Under the @code{physical} option described below, @code{symlink} is -instead given for symbolic links whose target does exist. - @item stale-symlink -Under the @code{physical} option described below, this indicates -@var{filename} is a dangling symbolic link, meaning its target does -not exist. Without the @code{physical} option plain @code{symlink} -indicates this. +@var{filename} is a dangling symbolic link. Links are normally +followed and their target reported, the link itself is reported if its +target does not exist. + +@item symlink +When the @code{physical} option described below is used, this +indicates @var{filename} is a symbolic link whose target exists (and +is not being followed). @end table The following optional arguments can be given to modify the way @@ -1156,10 +1157,11 @@ takes a following integer value). Change to the directory containing the item before calling @var{proc}. When @code{nftw} returns the original current directory is restored. -Under this option, generally the @var{basename} parameter should be -used to access the item in each @var{proc} call. The @var{filename} -parameter still has a path as normal and this will only be valid if -the @var{startname} directory was absolute. +Under this option, generally the @var{base} parameter to each +@var{proc} call should be used to pick out the base part of the +@var{filename}. The @var{filename} is still a path but with a changed +directory it won't be valid (unless the @var{startname} directory was +absolute). @item @code{depth} Visit files ``depth first'', meaning @var{proc} is called for the @@ -1175,11 +1177,12 @@ Set the size of the hash table used to track items already visited. @item @code{mount} Don't cross a mount point, meaning only visit items on the same -filesystem as @var{startname}. (Ie.@: the same @code{stat:dev}.) +filesystem as @var{startname} (ie.@: the same @code{stat:dev}). @item @code{physical} Don't follow symbolic links, instead report them to @var{proc} as -@code{symlink}, and report dangling links as @code{stale-symlink}. +@code{symlink}. Dangling links (those whose target doesn't exist) are +still reported as @code{stale-symlink}. @end table The return value from @code{nftw} is @code{#t} if it ran to @@ -1461,6 +1464,69 @@ ends when the end of the shortest given @var{stream} is reached. @end defun +@node Buffered Input +@section Buffered Input +@cindex Buffered input +@cindex Line continuation + +The following functions are provided by + +@example +(use-modules (ice-9 buffered-input)) +@end example + +A buffered input port allows a reader function to return chunks of +characters which are to be handed out on reading the port. A notion +of further input for an application level logical expression is +maintained too, and passed through to the reader. + +@defun make-buffered-input-port reader +Create an input port which returns characters obtained from the given +@var{reader} function. @var{reader} is called (@var{reader} cont), +and should return a string or an EOF object. + +The new port gives precisely the characters returned by @var{reader}, +nothing is added, so if any newline characters or other separators are +desired they must come from the reader function. + +The @var{cont} parameter to @var{reader} is @code{#f} for initial +input, or @code{#t} when continuing an expression. This is an +application level notion, set with +@code{set-buffered-input-continuation?!} below. If the user has +entered a partial expression then it allows @var{reader} for instance +to give a different prompt to show more is required. +@end defun + +@defun make-line-buffered-input-port reader +@cindex Line buffered input +Create an input port which returns characters obtained from the +specified @var{reader} function, similar to +@code{make-buffered-input-port} above, but where @var{reader} is +expected to be a line-oriented. + +@var{reader} is called (@var{reader} cont), and should return a string +or an EOF object as above. Each string is a line of input without a +newline character, the port code inserts a newline after each string. +@end defun + +@defun set-buffered-input-continuation?! port cont +Set the input continuation flag for a given buffered input +@var{port}. + +An application uses this by calling with a @var{cont} flag of +@code{#f} when beginning to read a new logical expression. For +example with the Scheme @code{read} function (@pxref{Scheme Read}), + +@example +(define my-port (make-buffered-input-port my-reader)) + +(set-buffered-input-continuation?! my-port #f) +(let ((obj (read my-port))) + ... +@end example +@end defun + + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 6a1d0f1b2..6f496fe8d 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.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, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1008,8 +1008,8 @@ return value is unspecified. @end deffn @deffn {Scheme Procedure} getpwent -Return the next entry in the user database, using the stream set by -@code{setpwent}. +Read the next entry in the user database stream. The return is a +passwd user object as above, or @code{#f} when no more entries. @end deffn @deffn {Scheme Procedure} endpwent @@ -1170,6 +1170,13 @@ Daylight saving indicator (0 for ``no'', greater than 0 for ``yes'', less than @deffn {Scheme Procedure} tm:gmtoff tm @deffnx {Scheme Procedure} set-tm:gmtoff tm val Time zone offset in seconds west of @acronym{UTC} (-46800 to 43200). +For example on East coast USA (zone @samp{EST+5}) this would be 18000 +(ie.@: @m{5\times60\times60,5*60*60}) in winter, or 14400 +(ie.@: @m{4\times60\times60,4*60*60}) during daylight savings. + +Note @code{tm:gmtoff} is not the same as @code{tm_gmtoff} in the C +@code{tm} structure. @code{tm_gmtoff} is seconds east and hence the +negative of the value here. @end deffn @deffn {Scheme Procedure} tm:zone tm @deffnx {Scheme Procedure} set-tm:zone tm val @@ -2909,32 +2916,37 @@ any unflushed buffered port data is ignored. @deffn {Scheme Procedure} recvfrom! sock str [flags [start [end]]] @deffnx {C Function} scm_recvfrom (sock, str, flags, start, end) -Return data from the socket port @var{sock} and also -information about where the data was received from. -@var{sock} must already be bound to the address from which -data is to be received. @code{str}, is a string into which the -data will be written. The size of @var{str} limits the amount -of data which can be received: in the case of packet protocols, -if a packet larger than this limit is encountered then some -data will be irrevocably lost. +Receive data from socket port @var{sock}, returning the originating +address as well as the data. This function is usually for datagram +sockets, but can be used on stream-oriented sockets too. + +The data received is stored in the given @var{str}, the whole string +or just the region between the optional @var{start} and @var{end} +positions. The size of @var{str} limits the amount of data which can +be received. For datagram protocols if a packet larger than this is +received then excess bytes are irrevocably lost. + +The return value is a pair. The @code{car} is the number of bytes +read. The @code{cdr} is a socket address object (@pxref{Network +Socket Address}) which is where the data came from, or @code{#f} if +the origin is unknown. @vindex MSG_OOB @vindex MSG_PEEK @vindex MSG_DONTROUTE -The optional @var{flags} argument is a value or bitwise OR of -@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. +The optional @var{flags} argument is a or bitwise-OR (@code{logior}) +of @code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. -The value returned is a pair: the @acronym{CAR} is the number of -bytes read from the socket and the @acronym{CDR} an address object -in the same form as returned by @code{accept}. The address -will given as @code{#f} if not available, as is usually the -case for stream sockets. +Data is read directly from the socket file descriptor, any buffered +port data is ignored. -The @var{start} and @var{end} arguments specify a substring of -@var{str} to which the data should be written. - -Note that the data is read directly from the socket file -descriptor: any unread buffered port data is ignored. +@c This was linux kernel 2.6.15 and glibc 2.3.6, not sure what any +@c specs are supposed to say about recvfrom threading. +@c +On a GNU/Linux system @code{recvfrom!} is not multi-threading, all +threads stop while a @code{recvfrom!} call is in progress. An +application may need to use @code{select}, @code{O_NONBLOCK} or +@code{MSG_DONTWAIT} to avoid this. @end deffn @deffn {Scheme Procedure} sendto sock message sockaddr [flags] @@ -3127,10 +3139,11 @@ specified. Get or set the current locale, used for various internationalizations. Locales are strings, such as @samp{sv_SE}. -If @var{locale} is given then the locale for the given @var{category} is set -and the new value returned. If @var{locale} is not given then the -current value is returned. @var{category} should be one of the -following values +If @var{locale} is given then the locale for the given @var{category} +is set and the new value returned. If @var{locale} is not given then +the current value is returned. @var{category} should be one of the +following values (@pxref{Locale Categories, Categories of Activities +that Locales Affect,, libc, The GNU C Library Reference Manual}): @defvar LC_ALL @defvarx LC_COLLATE @@ -3147,6 +3160,10 @@ categories based on standard environment variables (@code{LANG} etc). For full details on categories and locale names @pxref{Locales,, Locales and Internationalization, libc, The GNU C Library Reference Manual}. + +Note that @code{setlocale} affects locale settings for the whole +process. @xref{The ice-9 i18n Module, locale objects and +@code{make-locale}}, for a thread-safe alternative. @end deffn @node Encryption diff --git a/doc/ref/repl-modules.texi b/doc/ref/repl-modules.texi index 45f410c3a..5f274e253 100644 --- a/doc/ref/repl-modules.texi +++ b/doc/ref/repl-modules.texi @@ -23,6 +23,7 @@ history entries. @menu * Loading Readline Support:: How to load readline support into Guile. * Readline Options:: How to modify readline's behaviour. +* Readline Functions:: Programming with readline. @end menu @@ -32,7 +33,6 @@ history entries. The module is not loaded by default and so has to be loaded and activated explicitly. This is done with two simple lines of code: -@findex activate-readline @lisp (use-modules (ice-9 readline)) (activate-readline) @@ -91,7 +91,7 @@ $endif The readline interface module can be configured in several ways to better suit the user's needs. Configuration is done via the readline module's options interface, in a similar way to the evaluator and -debugging options (@pxref{User level options interfaces}.) +debugging options (@pxref{Runtime Options}). @findex readline-options @findex readline-enable @@ -119,6 +119,141 @@ usage of the history file using the following call. The readline options interface can only be used @emph{after} loading the readline module, because it is defined in that module. +@node Readline Functions +@subsection Readline Functions + +The following functions are provided by + +@example +(use-modules (ice-9 readline)) +@end example + +There are two ways to use readline from Scheme code, either make calls +to @code{readline} directly to get line by line input, or use the +readline port below with all the usual reading functions. + +@defun readline [prompt] +Read a line of input from the user and return it as a string (without +a newline at the end). @var{prompt} is the prompt to show, or the +default is the string set in @code{set-readline-prompt!} below. + +@example +(readline "Type something: ") @result{} "hello" +@end example +@end defun + +@defun set-readline-input-port! port +@defunx set-readline-output-port! port +Set the input and output port the readline function should read from +and write to. @var{port} must be a file port (@pxref{File Ports}), +and should usually be a terminal. + +The default is the @code{current-input-port} and +@code{current-output-port} (@pxref{Default Ports}) when @code{(ice-9 +readline)} loads, which in an interactive user session means the Unix +``standard input'' and ``standard output''. +@end defun + +@subsubsection Readline Port + +@defun readline-port +Return a buffered input port (@pxref{Buffered Input}) which calls the +@code{readline} function above to get input. This port can be used +with all the usual reading functions (@code{read}, @code{read-char}, +etc), and the user gets the interactive editing features of readline. + +There's only a single readline port created. @code{readline-port} +creates it when first called, and on subsequent calls just returns +what it previously made. +@end defun + +@defun activate-readline +If the @code{current-input-port} is a terminal (@pxref{Terminals and +Ptys,, @code{isatty?}}) then enable readline for all reading from +@code{current-input-port} (@pxref{Default Ports}) and enable readline +features in the interactive REPL (@pxref{The REPL}). + +@example +(activate-readline) +(read-char) +@end example + +@code{activate-readline} enables readline on @code{current-input-port} +simply by a @code{set-current-input-port} to the @code{readline-port} +above. An application can do that directly if the extra REPL features +that @code{activate-readline} adds are not wanted. +@end defun + +@defun set-readline-prompt! prompt1 [prompt2] +Set the prompt string to print when reading input. This is used when +reading through @code{readline-port}, and is also the default prompt +for the @code{readline} function above. + +@var{prompt1} is the initial prompt shown. If a user might enter an +expression across multiple lines, then @var{prompt2} is a different +prompt to show further input required. In the Guile REPL for instance +this is an ellipsis (@samp{...}). + +See @code{set-buffered-input-continuation?!} (@pxref{Buffered Input}) +for an application to indicate the boundaries of logical expressions +(assuming of course an application has such a notion). +@end defun + +@subsubsection Completion + +@defun with-readline-completion-function completer thunk +Call @code{(@var{thunk})} with @var{completer} as the readline tab +completion function to be used in any readline calls within that +@var{thunk}. @var{completer} can be @code{#f} for no completion. + +@var{completer} will be called as @code{(@var{completer} text state)}, +as described in (@pxref{How Completing Works,,, readline, GNU Readline +Library}). @var{text} is a partial word to be completed, and each +@var{completer} call should return a possible completion string or +@code{#f} when no more. @var{state} is @code{#f} for the first call +asking about a new @var{text} then @code{#t} while getting further +completions of that @var{text}. + +Here's an example @var{completer} for user login names from the +password file (@pxref{User Information}), much like readline's own +@code{rl_username_completion_function}, + +@example +(define (username-completer-function text state) + (if (not state) + (setpwent)) ;; new, go to start of database + (let more ((pw (getpwent))) + (if pw + (if (string-prefix? text (passwd:name pw)) + (passwd:name pw) ;; this name matches, return it + (more (getpwent))) ;; doesn't match, look at next + (begin + ;; end of database, close it and return #f + (endpwent) + #f)))) +@end example +@end defun + +@defun apropos-completion-function text state +A completion function offering completions for Guile functions and +variables (all @code{define}s). This is the default completion +function. +@c +@c FIXME: Cross reference the ``apropos'' stuff when it's documented. +@c +@end defun + +@defun filename-completion-function text state +A completion function offering filename completions. This is +readline's @code{rl_filename_completion_function} (@pxref{Completion +Functions,,, readline, GNU Readline Library}). +@end defun + +@defun make-completion-function string-list +Return a completion function which offers completions from the +possibilities in @var{string-list}. Matching is case-sensitive. +@end defun + @page @node Value History diff --git a/doc/ref/scheme-debugging.texi b/doc/ref/scheme-debugging.texi index a9d1691d1..32a6a46bd 100644 --- a/doc/ref/scheme-debugging.texi +++ b/doc/ref/scheme-debugging.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, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -511,3 +511,8 @@ behaviour as well as the more traditional @code{trace-here}. The older mechanism will probably become obsolete eventually, but it's worth keeping it around for a while until we are sure that the new mechanism is correct and does what programmers need. + + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index c19823683..93d0949f8 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -449,11 +449,9 @@ section. * GDS Introduction:: * GDS Architecture:: * GDS Getting Started:: +* Working with GDS in Scheme Buffers:: * Displaying the Scheme Stack:: * Continuing Execution:: -* Evaluating Scheme Code:: -* Setting and Managing Breakpoints:: -* Access to Guile Help and Completion:: * Associating Buffers with Clients:: * An Example GDS Session:: @end menu @@ -501,7 +499,6 @@ existing ones @item continue execution, either normally or step by step. @end itemize -@end enumerate The presentation makes it very easy to move up and down the stack, showing whenever possible the source code for each frame in another @@ -509,11 +506,12 @@ Emacs buffer. It also provides convenient keystrokes for telling Guile what to do next; for example, you can select a stack frame and tell Guile to run until that frame completes, at which point GDS will display the frame's return value. +@end enumerate -Combinations of the above work well too. You can evaluate a fragment of -code (in a Scheme buffer) that contains a breakpoint, then use the -debugging interface to step through the code at the breakpoint. You can -also run a program until it hits a breakpoint, then examine, modify and +Combinations of these well too. You can evaluate a fragment of code (in +a Scheme buffer) that contains a breakpoint, then use the debugging +interface to step through the code at the breakpoint. You can also run +a program until it hits a breakpoint, then examine, modify and reevaluate some of the relevant code, and then tell the program to continue running. @@ -642,7 +640,6 @@ files or modules by sending it @code{load} or @code{use-modules} expressions. You can set breakpoints and evaluate code which hits those breakpoints, and GDS will pop up the stack at the breakpoint so you can explore your code by single-stepping and evaluating test expressions. - For a hands-on, tutorial introduction to using GDS in this way, use Emacs to open the file @file{gds-tutorial.txt} (which should have been installed as part of Guile, perhaps under @file{/usr/share/doc/guile}), @@ -655,21 +652,33 @@ following subsections describe the various ways of doing this. @subsubsection Setting Specific Breakpoints +The first option is to use @code{break-in} or @code{break-at} to set +specific breakpoints in the application's code. This requires code like +the following. + @lisp (use-modules (ice-9 debugging breakpoints) (ice-9 gds-client)) (break-in 'fact2 "ice-9/debugging/example-fns" #:behaviour gds-debug-trap) +(break-in 'facti "ice-9/debugging/example-fns" + #:behaviour gds-debug-trap) @end lisp -In this example, the program chooses to define its breakpoint explicitly -in its code, rather than downloading definitions from GDS, but it still -uses GDS to control what happens when the breakpoint is hit, by -specifying @code{gds-debug-trap} as the breakpoint behaviour. +@noindent +The @code{#:behaviour gds-debug-trap} clauses mean to use GDS to display +the stack when one of these breakpoints is hit. For more on +breakpoints, @code{break-in} and @code{break-at}, see @ref{Intro to +Breakpoints}. @subsubsection Setting GDS-managed Breakpoints +Instead of listing specific breakpoints in application code, you can use +GDS to manage the set of breakpoints that you want from Emacs, and tell +the application to download the breakpoints that it should set from +GDS. The code for this is: + @lisp (use-modules (ice-9 gds-client)) (set-gds-breakpoints) @@ -680,11 +689,52 @@ a set of breakpoint definitions. The program sets those breakpoints in its code, then continues running. When the program later hits one of the breakpoints, it will use GDS to -display the stack and wait for instruction on what to do next, as -described above. +display the stack and wait for instruction on what to do next. @subsubsection Invoking GDS when an Exception Occurs +Another option is to use GDS to catch and display any exceptions that +are thrown by the application's code. If you already have a +@code{lazy-catch} or @code{with-throw-handler} around the area of code +that you want to monitor, you just need to add the following to the +handler code: + +@lisp +(gds-debug-trap (throw->trap-context key args)) +@end lisp + +@noindent +where @code{key} and @code{args} are the first and rest arguments that +Guile passes to the handler. (In other words, they assume the handler +signature @code{(lambda (key . args) @dots{})}.) With Guile 1.8 or +later, you can also do this with a @code{catch}, by adding this same +code to the catch's pre-unwind handler. + +If you don't already have any of these, insert a whole +@code{with-throw-handler} expression (or @code{lazy-catch} if your Guile +is pre-1.8) around the code of interest like this: + +@lisp +(with-throw-handler #t + (lambda () + ;; Protected code here. + ) + (lambda (key . args) + (gds-debug-trap (throw->trap-context key args)))) +@end lisp + +In all cases you will need to use the @code{(ice-9 gds-client)} and +@code{(ice-9 debugging traps)} modules. + +Two special cases of this are the lazy-catch that the Guile REPL code +uses to catch exceptions in user code, and the lazy-catch inside the +@code{stack-catch} utility procedure that is provided by the +@code{(ice-9 stack-catch)} module. Both of these use a handler called +@code{lazy-handler-dispatch} (defined in @file{boot-9.scm}), which you +can hook into such that it calls GDS to display the stack when an +exception occurs. To do this, use the @code{on-lazy-handler-dispatch} +procedure as follows. + @lisp (use-modules (ice-9 gds-client) (ice-9 debugging traps)) @@ -692,18 +742,10 @@ described above. (on-lazy-handler-dispatch gds-debug-trap) @end lisp -This means that the program will use GDS to display the stack whenever -it hits an exception that is protected by a @code{lazy-catch} using -Guile's standard @code{lazy-catch-handler} (defined in -@file{boot-9.scm}). - -@code{lazy-catch-handler} is used by the @code{stack-catch} procedure, -provided by the @code{(ice-9 stack-catch)} module, so this will include -exceptions within a @code{stack-catch}. @code{lazy-catch-handler} is -also used by the standard Guile REPL, when you run Guile interactively, -so you can add the above lines to your @file{.guile} file if you want to -use GDS whenever something that you type into the REPL throws an -exception. +@noindent +After this the program will use GDS to display the stack whenever it +hits an exception that is protected by a @code{lazy-catch} using +@code{lazy-handler-dispatch}. @subsubsection Accepting GDS Instructions at Any Time @@ -745,14 +787,11 @@ This approach is not yet implemented, though. @subsubsection Utility Guile Implementation -We bring this subsection full circle by noting that the ``utility'' Guile -client, which GDS starts automatically when you use GDS as described -under approach 1 above, is really just a special case of ``a Guile -program or script which is started independently'' (approach 2), and -provides the services that the GDS front end needs by a simple -combination of some of the code fragments just described. +We conclude this subsection with an aside, by noting that the +``utility'' Guile client described above is nothing more than a +combination of the previous options. -To be precise, the code for the utility Guile client is essentially +To be precise, the code for the utility Guile client is essentially just this: @lisp @@ -765,12 +804,11 @@ this: @code{set-gds-breakpoints} works as already described. The @code{named-module-use!} line ensures that the client can process -@code{help} and @code{apropos} expressions, which is what the front end -sends to implement lookups in Guile's online help. The @code{#f} -parameter to @code{gds-accept-input} means that the @code{continue} -instruction will not cause the instruction loop to exit, which makes -sense here because the utility client has nothing to do except to -process GDS instructions. +@code{help} and @code{apropos} expressions, to implement lookups in +Guile's online help. The @code{#f} parameter to @code{gds-accept-input} +means that the @code{continue} instruction will not cause the +instruction loop to exit, which makes sense here because the utility +client has nothing to do except to process GDS instructions. (The utility client does not use @code{on-lazy-handler-dispatch}, because it has its own mechanism for catching and reporting exceptions @@ -780,6 +818,176 @@ stack, so the end result is very similar to what @code{on-lazy-handler-dispatch} provides.) +@node Working with GDS in Scheme Buffers +@subsection Working with GDS in Scheme Buffers + +The following subsections describe the facilities and key sequences that +GDS provides for working on code in @code{scheme-mode} buffers. + +@menu +* Access to Guile Help and Completion:: +* Setting and Managing Breakpoints:: +* Listing and Deleting Breakpoints:: +* Moving and Losing Breakpoints:: +* Evaluating Scheme Code:: +@end menu + + +@node Access to Guile Help and Completion +@subsubsection Access to Guile Help and Completion + +The following keystrokes provide fast and convenient access to Guile's +built in help, and to completion with respect to the set of defined and +accessible symbols. + +@table @kbd +@item C-h g +@findex gds-help-symbol +Get Guile help for a particular symbol, with the same results as if +you had typed @code{(help SYMBOL)} into the Guile REPL +(@code{gds-help-symbol}). The symbol to query defaults to the word at +or before the cursor but can also be entered or edited in the +minibuffer. The available help is popped up in a temporary Emacs +window. + +@item C-h C-g +@findex gds-apropos +List all accessible Guile symbols matching a given regular expression, +with the same results as if you had typed @code{(apropos REGEXP)} into +the Guile REPL (@code{gds-apropos}). The regexp to query defaults to +the word at or before the cursor but can also be entered or edited in +the minibuffer. The list of matching symbols is popped up in a +temporary Emacs window. + +@item M-@key{TAB} +@findex gds-complete-symbol +Try to complete the symbol at the cursor by matching it against the +set of all defined and accessible bindings in the associated Guile +process (@code{gds-complete-symbol}). If there are any extra +characters that can be definitively added to the symbol at point, they +are inserted. Otherwise, if there are any completions available, they +are popped up in a temporary Emacs window, where one of them can be +selected using either @kbd{@key{RET}} or the mouse. +@end table + + +@node Setting and Managing Breakpoints +@subsubsection Setting and Managing Breakpoints + +You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a +Scheme mode buffer. To create a breakpoint on calls to a procedure --- +i.e. the equivalent of calling @code{break-in} --- place the cursor +anywhere within the procedure's definition, make sure that the region is +unset, and type @kbd{C-x @key{SPC}}. To create breakpoints on a +particular expression, or on the series of expressions in a particular +region --- i.e. as with @code{break-at} --- select a region containing +the open parentheses of the expressions where you want breakpoints, and +type @kbd{C-x @key{SPC}}. In other words, GDS assumes that you want a +@code{break-at} breakpoint if there is an active region, and a +@code{break-in} breakpoint otherwise. + +There are three supported breakpoint behaviours, known as @code{debug}, +@code{trace} and @code{trace-subtree}. @code{debug} means that GDS will +display the stack and wait for instruction when the breakpoint is hit. +@code{trace} means that a line will be written to the trace output +buffer (@code{*GDS Trace*}) when the breakpoint is hit, and when the +relevant expression or procedure call returns. @code{trace-subtree} +means that a line is written to the trace output buffer for every +evaluation step between when the breakpoint is hit and when the +expression or procedure returns. + +@kbd{C-x @key{SPC}} creates a breakpoint with behaviour according to the +@code{gds-default-breakpoint-type} variable, which by default is +@code{debug}; you can customize this if you prefer a different default. +You can also create a breakpoint with behaviour other than the current +default by using the alternative key sequences @kbd{C-c C-b d} (for +@code{debug}), @kbd{C-c C-b t} (for @code{trace}) and @kbd{C-c C-b T} +(for @code{trace-subtree}). + +GDS keeps all the breakpoints that you create in a single list, and +tries to set them in every Guile program that connects to GDS and calls +@code{set-gds-breakpoints}. That may sound surprising, because you are +probably thinking of one particular program when you create a +breakpoint; but GDS assumes that you would want the breakpoint to continue +taking effect if you stop and restart that program, and this is +currently achieved by giving all breakpoints to every program that asks +for them. In practice it doesn't matter if a program gets a breakpoint +definition --- such as ``break in procedure @code{foo}'' --- that it +can't actually map to any of its code. + +If there are already Guile programs connected to GDS when you create a +new breakpoint, GDS also tries to set the new breakpoint in each of +those programs at the earliest opportunity, which is usually when they +decide to stop and talk to GDS for some other reason. + + +@node Listing and Deleting Breakpoints +@subsubsection Listing and Deleting Breakpoints + +To see a list of all breakpoints, type @kbd{C-c C-b ?} (or @kbd{M-x +gds-describe-breakpoints}). GDS will then pop up a buffer that +describes each breakpoint and reports whether it is actually set in each +of the Guile programs connected to GDS. + +To delete a breakpoint, type @kbd{C-c C-b @key{backspace}}. If the +region is active when you do this, GDS will delete all of the +breakpoints in the region. If the region is not active, GDS tries to +delete a ``break-in'' breakpoint for the procedure whose definition +contains point (the Emacs cursor). In either case, deletion means that +the breakpoint is removed both from GDS's global list and from all of +the connected Guile programs that had previously managed to set it. + + +@node Moving and Losing Breakpoints +@subsubsection Moving and Losing Breakpoints + +Imagine that you set a breakpoint at line 80 of a Scheme code file, and +execute some code that hits this breakpoint; then you add some new code +at line 40, or delete some code that is no longer needed, and save the +file. Now the breakpoint will have moved up or down from line 80, and +any attached Guile program needs to be told about the new line number. +Otherwise, when a program loads this file again, it will try incorrectly +to set a breakpoint on whatever code is now at line 80, and will +@emph{not} set a breakpoint on the code where you want it. + +For this reason, GDS checks all breakpoint positions whenever you save a +Scheme file, and sends the new position to connected Guile programs for +any breakpoints that have moved. @dots{} [to be continued] + + +@node Evaluating Scheme Code +@subsubsection Evaluating Scheme Code + +The following keystrokes and commands provide various ways of sending +code to a Guile client process for evaluation. + +@table @kbd +@item M-C-x +@findex gds-eval-defun +Evaluate the ``top level defun'' that the cursor is in, in other words +the smallest balanced expression which includes the cursor and whose +opening parenthesis is in column 0 (@code{gds-eval-defun}). + +@item C-x C-e +@findex gds-eval-last-sexp +Evaluate the expression that ends just before the cursor +(@code{gds-eval-last-sexp}). This is designed so that it is easy to +evaluate an expression that you have just finished typing. + +@item C-c C-e +@findex gds-eval-expression +Read a Scheme expression using the minibuffer, and evaluate that +expression (@code{gds-eval-expression}). + +@item C-c C-r +@findex gds-eval-region +Evaluate the Scheme code in the marked region of the current buffer +(@code{gds-eval-region}). Note that GDS does not check whether the +region contains a balanced expression, or try to expand the region so +that it does; it uses the region exactly as it is. +@end table + + @node Displaying the Scheme Stack @subsection Displaying the Scheme Stack @@ -902,117 +1110,6 @@ remains in place and so will still fire at the appropriate point. @end table -@node Evaluating Scheme Code -@subsection Evaluating Scheme Code - -The following keystrokes and commands provide various ways of sending -code to a Guile client process for evaluation. - -@table @kbd -@item M-C-x -@findex gds-eval-defun -Evaluate the ``top level defun'' that the cursor is in, in other words -the smallest balanced expression which includes the cursor and whose -opening parenthesis is in column 0 (@code{gds-eval-defun}). - -@item C-x C-e -@findex gds-eval-last-sexp -Evaluate the expression that ends just before the cursor -(@code{gds-eval-last-sexp}). This is designed so that it is easy to -evaluate an expression that you have just finished typing. - -@item C-c C-e -@findex gds-eval-expression -Read a Scheme expression using the minibuffer, and evaluate that -expression (@code{gds-eval-expression}). - -@item C-c C-r -@findex gds-eval-region -Evaluate the Scheme code in the marked region of the current buffer -(@code{gds-eval-region}). Note that GDS does not check whether the -region contains a balanced expression, or try to expand the region so -that it does; it uses the region exactly as it is. -@end table - - -@node Setting and Managing Breakpoints -@subsection Setting and Managing Breakpoints - -You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a -Scheme mode buffer. To create a breakpoint on calls to a procedure ---- i.e. the equivalent of calling @code{break-in} --- place the -cursor on the procedure's name and type @kbd{C-x @key{SPC}}. To -create breakpoints on a particular expression, or on the series of -expressions in a particular region --- i.e. as with @code{break-at} ---- select the expression or region in the usual way and type @kbd{C-x -@key{SPC}}. In general, GDS assumes that you want a @code{break-at} -breakpoint if there is an active region, and a @code{break-in} -breakpoint otherwise. - -When you create a breakpoint like this, two things happen. Firstly, -if the current buffer is associated with a Guile client program, the -new breakpoint definition is immediately sent to that client (or, if -the client cannot accept input immediately, it is held in readiness to -pass to the client at the next possible opportunity). This allows the -new breakpoint to take effect as soon as possible in the relevant -client program. - -Secondly, it is added to GDS's @emph{global} list of all breakpoints. -This list holds the breakpoint information that will be given to any -client program that asks for it by calling @code{set-gds-breakpoints}. -The fact that this list is global, rather than client-specific, means -that the breakpoints you have set will automatically be recreated if -the program you are debugging has to be stopped and restarted --- -which in my experience happens often.@footnote{An important point here -is that there is nothing that unambiguously relates two subsequent -runs of the same client program, which might allow GDS to pass on -breakpoint settings more precisely.} - -(The only possible downside of this last point is that if you are -debugging two programs in parallel, which have some code in common, -you might not want a common code breakpoint in one program to be set -in the other program as well. But this feels like a small concern in -comparison to the benefit of breakpoints persisting as just described.) - - -@node Access to Guile Help and Completion -@subsection Access to Guile Help and Completion - -The following keystrokes provide fast and convenient access to Guile's -built in help, and to completion with respect to the set of defined and -accessible symbols. - -@table @kbd -@item C-h g -@findex gds-help-symbol -Get Guile help for a particular symbol, with the same results as if -you had typed @code{(help SYMBOL)} into the Guile REPL -(@code{gds-help-symbol}). The symbol to query defaults to the word at -or before the cursor but can also be entered or edited in the -minibuffer. The available help is popped up in a temporary Emacs -window. - -@item C-h C-g -@findex gds-apropos -List all accessible Guile symbols matching a given regular expression, -with the same results as if you had typed @code{(apropos REGEXP)} into -the Guile REPL (@code{gds-apropos}). The regexp to query defaults to -the word at or before the cursor but can also be entered or edited in -the minibuffer. The list of matching symbols is popped up in a -temporary Emacs window. - -@item M-@key{TAB} -@findex gds-complete-symbol -Try to complete the symbol at the cursor by matching it against the -set of all defined and accessible bindings in the associated Guile -process (@code{gds-complete-symbol}). If there are any extra -characters that can be definitively added to the symbol at point, they -are inserted. Otherwise, if there are any completions available, they -are popped up in a temporary Emacs window, where one of them can be -selected using either @kbd{@key{RET}} or the mouse. -@end table - - @node Associating Buffers with Clients @subsection Associating Buffers with Clients diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 6786c2844..21c354c7b 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,24 @@ +2006-11-02 Neil Jerram <neil@ossau.uklinux.net> + + * gds-scheme.el (gds-choose-client): Change assq to memq, so that + the mapcar really constructs a list of available clients. + +2006-10-14 Neil Jerram <neil@ossau.uklinux.net> + + * gds.el (gds-socket-type-alist): New. + (gds-run-debug-server): Use gds-server-socket-type and + gds-socket-type-alist instead of gds-server-port-or-path. + (gds-server-socket-type): New, replacing gds-server-port-or-path. + +2006-10-13 Neil Jerram <neil@ossau.uklinux.net> + + * gds.el (gds-run-debug-server): Use variable + gds-server-port-or-path instead of hardcoded 8333. + (gds-server-port-or-path): New. + + * gds-server.el (gds-start-server): Change port arg to + port-or-path, to support Unix domain sockets. + 2006-08-18 Neil Jerram <neil@ossau.uklinux.net> * gds-server.el (gds-start-server): Change "ossau" to "ice-9". diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index 8fb4ca2af..134e80592 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -158,7 +158,7 @@ Emacs to display an error or trap so that the user can debug it." (default nil)) ;; Prepare a table containing all current clients. (mapcar (lambda (client-info) - (setq table (cons (cons (cadr (assq 'name client-info)) + (setq table (cons (cons (cadr (memq 'name client-info)) (car client-info)) table))) gds-client-info) diff --git a/emacs/gds-server.el b/emacs/gds-server.el index 722e613db..86defc07b 100644 --- a/emacs/gds-server.el +++ b/emacs/gds-server.el @@ -44,24 +44,25 @@ :group 'gds :type '(choice (const :tag "nil" nil) directory)) -(defun gds-start-server (procname port protocol-handler &optional bufname) - "Start a GDS server process called PROCNAME, listening on TCP port PORT. -PROTOCOL-HANDLER should be a function that accepts and processes one -protocol form. Optional arg BUFNAME specifies the name of the buffer -that is used for process output\; if not specified the buffer name is -the same as the process name." +(defun gds-start-server (procname port-or-path protocol-handler &optional bufname) + "Start a GDS server process called PROCNAME, listening on TCP port +or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a +function that accepts and processes one protocol form. Optional arg +BUFNAME specifies the name of the buffer that is used for process +output; if not specified the buffer name is the same as the process +name." (with-current-buffer (get-buffer-create (or bufname procname)) (erase-buffer) (let* ((code (format "(begin %s (use-modules (ice-9 gds-server)) - (run-server %d))" + (run-server %S))" (if gds-scheme-directory (concat "(set! %load-path (cons " (format "%S" gds-scheme-directory) " %load-path))") "") - port)) + port-or-path)) (process-connection-type nil) ; use a pipe (proc (start-process procname (current-buffer) diff --git a/emacs/gds.el b/emacs/gds.el index 3ce4696b6..71d9a99d4 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -37,12 +37,20 @@ ;; The subprocess object for the debug server. (defvar gds-debug-server nil) +(defvar gds-socket-type-alist '((tcp . 8333) + (unix . "/tmp/.gds_socket")) + "Maps each of the possible socket types that the GDS server can +listen on to the path that it should bind to for each one.") + (defun gds-run-debug-server () "Start (or restart, if already running) the GDS debug server process." (interactive) (if gds-debug-server (gds-kill-debug-server)) (setq gds-debug-server - (gds-start-server "gds-debug" 8333 'gds-debug-protocol)) + (gds-start-server "gds-debug" + (cdr (assq gds-server-socket-type + gds-socket-type-alist)) + 'gds-debug-protocol)) (process-kill-without-query gds-debug-server)) (defun gds-kill-debug-server () @@ -602,6 +610,11 @@ you would add an element to this alist to transform :type 'boolean :group 'gds) +(defcustom gds-server-socket-type 'tcp + "What kind of socket the GDS server should listen on." + :group 'gds + :type '(choice (const :tag "TCP" tcp) + (const :tag "Unix" unix))) ;;;; If requested, autostart the server after loading. diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 383541575..b7bddd59f 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,18 @@ +2006-10-06 Neil Jerram <neil@ossau.uklinux.net> + + * ice-9/readline.scm (new-input-prompt): Renamed from "prompt". + (continuation-prompt): Renamed from "prompt2". + (make-readline-port, readline, set-readline-prompt!): Reflect + above renamings. + (activate-readline): Rename locals "read-hook" and "prompt" to + "repl-read-hook" and "repl-prompt", to disambiguate them from + globals. Save and restore the new-input- and continuation- + prompts around the REPL read call. + +2006-10-05 Kevin Ryde <user42@zip.com.au> + + * ice-9/readline.scm (filename-completion-function): Export this. + 2006-04-17 Kevin Ryde <user42@zip.com.au> * ice-9/readline.scm: Bump lib file version to libguilereadline-v-18, diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 59224524b..e74bc0243 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -27,7 +27,8 @@ :use-module (ice-9 session) :use-module (ice-9 regex) :use-module (ice-9 buffered-input) - :no-backtrace) + :no-backtrace + :export (filename-completion-function)) @@ -68,8 +69,8 @@ ;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed, ;;; guile will enter an endless loop or crash. -(define prompt "") -(define prompt2 "") +(define new-input-prompt "") +(define continuation-prompt "") (define input-port (current-input-port)) (define output-port (current-output-port)) (define read-hook #f) @@ -77,8 +78,8 @@ (define (make-readline-port) (make-line-buffered-input-port (lambda (continuation?) (let* ((prompt (if continuation? - prompt2 - prompt)) + continuation-prompt + new-input-prompt)) (str (%readline (if (string? prompt) prompt (prompt)) @@ -125,7 +126,7 @@ ;;; %readline is the low-level readline procedure. (define-public (readline . args) - (let ((prompt prompt) + (let ((prompt new-input-prompt) (inp input-port)) (cond ((not (null? args)) (set! prompt (car args)) @@ -141,9 +142,9 @@ args))) (define-public (set-readline-prompt! p . rest) - (set! prompt p) + (set! new-input-prompt p) (if (not (null? rest)) - (set! prompt2 (car rest)))) + (set! continuation-prompt (car rest)))) (define-public (set-readline-input-port! p) (cond ((or (not (file-port? p)) (not (input-port? p))) @@ -202,19 +203,22 @@ (not (let ((guile-user-module (resolve-module '(guile-user)))) (and (module-defined? guile-user-module 'use-emacs-interface) (module-ref guile-user-module 'use-emacs-interface))))) - (let ((read-hook (lambda () (run-hook before-read-hook)))) + (let ((repl-read-hook (lambda () (run-hook before-read-hook)))) (set-current-input-port (readline-port)) (set! repl-reader - (lambda (prompt) - (dynamic-wind - (lambda () - (set-buffered-input-continuation?! (readline-port) #f) - (set-readline-prompt! prompt "... ") - (set-readline-read-hook! read-hook)) - (lambda () (read)) - (lambda () - (set-readline-prompt! "" "") - (set-readline-read-hook! #f))))) + (lambda (repl-prompt) + (let ((outer-new-input-prompt new-input-prompt) + (outer-continuation-prompt continuation-prompt) + (outer-read-hook read-hook)) + (dynamic-wind + (lambda () + (set-buffered-input-continuation?! (readline-port) #f) + (set-readline-prompt! repl-prompt "... ") + (set-readline-read-hook! repl-read-hook)) + (lambda () (read)) + (lambda () + (set-readline-prompt! outer-new-input-prompt outer-continuation-prompt) + (set-readline-read-hook! outer-read-hook)))))) (set! (using-readline?) #t)))) (define-public (make-completion-function strings) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 9786388b5..f50827ef8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,41 @@ +2006-11-13 Neil Jerram <neil@ossau.uklinux.net> + + * boot-9.scm (environment-module): Change eval-closure-module call + back to procedure-property lookup. (This completes the reversion + of the change made on 2005-06-10, which was only partially undone + by the change on 2005-08-01.) + +2006-10-13 Neil Jerram <neil@ossau.uklinux.net> + + Integration of Unix domain socket patch from William Xu: + + * gds-client.scm (connect-to-gds): Try to connect by Unix domain + socket if TCP connection fails. + + * gds-server.scm (run-server): Update to support listening on a + Unix domain socket. + +2006-10-05 Kevin Ryde <user42@zip.com.au> + + * ftw.scm (visited?-proc): Use hashv since we know we're getting + numbers. Incorporate stat:dev, since stat:ino is only unique within a + single device. This fixes a bug where if two files with the same + inode on different devices where seen only the first would be returned + by ftw (and nftw). + +2006-10-03 Neil Jerram <neil@ossau.uklinux.net> + + * gds-client.scm (run-utility): Remove unnecessary + `connect-to-gds' call. + +2006-09-30 Neil Jerram <neil@ossau.uklinux.net> + + * debugging/ice-9-debugger-extensions.scm (debug-trap): Use + `debugger-command-loop' instead of `read-and-dispatch-commands', + which isn't actually available. Thanks to Carlos Pita for + reporting this. + (debugger-command-loop): Define here for 1.6.x. + 2006-09-25 Neil Jerram <neil@ossau.uklinux.net> * debugging/ice-9-debugger-extensions.scm (debugger:step): @@ -9,6 +47,18 @@ (info-args, info-frame, position, evaluate): Docstring improvements. +2006-09-23 Kevin Ryde <user42@zip.com.au> + + * boot-9.scm (log, log10, exp, sqrt): Remove, now in + libguile/numbers.c. + +2006-09-07 Kevin Ryde <user42@zip.com.au> + + * format.scm: Module "(ice-9 threads)" no longer used, now no mutex. + (format:parse-float): Fix normalization of leading zeros like "02.5" + to "2.5". left-zeros was zeroed before adjusting format:fn-dot, + resulting in the latter being unchanged. + 2006-08-18 Neil Jerram <neil@ossau.uklinux.net> * debugging/trc.scm: New file. @@ -31,6 +81,13 @@ * Makefile.am (SUBDIRS): Add debugging. +2006-08-02 Kevin Ryde <user42@zip.com.au> + + * boot-9.scm (%record-type-check): New function. + (record-accessor, record-modifier): Use it for a strict type check of + the given record. Previously an accessor returned #f on a wrong + record type, and modifier silently did nothing. + 2006-06-19 Neil Jerram <neil@ossau.uklinux.net> * Makefile.am (ice9_sources): Add new files. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 0f56f9855..b50ae2911 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -339,7 +339,7 @@ (define (environment-module env) (let ((closure (and (pair? env) (car (last-pair env))))) - (and closure (eval-closure-module closure)))) + (and closure (procedure-property closure 'module)))) @@ -429,13 +429,20 @@ (define (record-predicate rtd) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) +(define (%record-type-check rtd obj) ;; private helper + (or (eq? rtd (record-type-descriptor obj)) + (scm-error 'wrong-type-arg "%record-type-check" + "Wrong type record (want `~S'): ~S" + (list (record-type-name rtd) obj) + #f))) + (define (record-accessor rtd field-name) (let* ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) (local-eval `(lambda (obj) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-ref obj ,pos))) + (%record-type-check ',rtd obj) + (struct-ref obj ,pos)) the-root-environment))) (define (record-modifier rtd field-name) @@ -443,8 +450,8 @@ (if (not pos) (error 'no-such-field field-name)) (local-eval `(lambda (obj val) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-set! obj ,pos val))) + (%record-type-check ',rtd obj) + (struct-set! obj ,pos val)) the-root-environment))) @@ -779,21 +786,6 @@ ;;; See the file `COPYING' for terms applying to this program. ;;; -(define (exp z) - (if (real? z) ($exp z) - (make-polar ($exp (real-part z)) (imag-part z)))) - -(define (log z) - (if (and (real? z) (>= z 0)) - ($log z) - (make-rectangular ($log (magnitude z)) (angle z)))) - -(define (sqrt z) - (if (real? z) - (if (negative? z) (make-rectangular 0 ($sqrt (- z))) - ($sqrt z)) - (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) - (define expt (let ((integer-expt integer-expt)) (lambda (z1 z2) @@ -868,9 +860,6 @@ (/ (log (/ (- +i z) (+ +i z))) +2i)) ($atan2 z (car y)))) -(define (log10 arg) - (/ (log arg) (log 10))) - ;;; {Reader Extensions} diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm index 217d935b9..2770c1f73 100644 --- a/ice-9/debugging/ice-9-debugger-extensions.scm +++ b/ice-9/debugging/ice-9-debugger-extensions.scm @@ -121,6 +121,11 @@ print the result obtained." (define *not-yet-introduced* #t) +(cond ((string>=? (version) "1.7")) + (else + (define (debugger-command-loop state) + (read-and-dispatch-commands state (current-input-port))))) + (define-public (debug-trap trap-context) "Invoke the Guile debugger to explore the stack at the specified @var{trap}." (start-stack 'debugger @@ -144,7 +149,7 @@ print the result obtained." (display "There is 1 frame on the stack.\n\n") (format #t "There are ~A frames on the stack.\n\n" ssize)))) (write-state-short-with-source-location state) - (read-and-dispatch-commands state (current-input-port))))) + (debugger-command-loop state)))) (define write-state-short-with-source-location (cond ((string>=? (version) "1.7") diff --git a/ice-9/format.scm b/ice-9/format.scm index 3d17d44df..4bf623757 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -13,7 +13,6 @@ (define-module (ice-9 format) :use-module (ice-9 and-let-star) - :use-module (ice-9 threads) :autoload (ice-9 pretty-print) (pretty-print) :replace (format) :export (format:symbol-case-conv @@ -1461,8 +1460,8 @@ (if (> format:fn-dot left-zeros) (begin ; norm 0{0}nn.mm to nn.mm (format:fn-shiftleft left-zeros) - (set! left-zeros 0) - (set! format:fn-dot (- format:fn-dot left-zeros))) + (set! format:fn-dot (- format:fn-dot left-zeros)) + (set! left-zeros 0)) (begin ; normalize 0{0}.nnn to .nnn (format:fn-shiftleft format:fn-dot) (set! left-zeros (- left-zeros format:fn-dot)) diff --git a/ice-9/ftw.scm b/ice-9/ftw.scm index 09b580c05..23f341521 100644 --- a/ice-9/ftw.scm +++ b/ice-9/ftw.scm @@ -217,14 +217,33 @@ (define (abs? filename) (char=? #\/ (string-ref filename 0))) +;; `visited?-proc' returns a test procedure VISITED? which when called as +;; (VISITED? stat-obj) returns #f the first time a distinct file is seen, +;; then #t on any subsequent sighting of it. +;; +;; stat:dev and stat:ino together uniquely identify a file (see "Attribute +;; Meanings" in the glibc manual). Often there'll be just one dev, and +;; usually there's just a handful mounted, so the strategy here is a small +;; hash table indexed by dev, containing hash tables indexed by ino. +;; +;; It'd be possible to make a pair (dev . ino) and use that as the key to a +;; single hash table. It'd use an extra pair for every file visited, but +;; might be a little faster if it meant less scheme code. +;; (define (visited?-proc size) - (let ((visited (make-hash-table size))) + (let ((dev-hash (make-hash-table 7))) (lambda (s) - (and s (let ((ino (stat:ino s))) - (or (hash-ref visited ino) - (begin - (hash-set! visited ino #t) - #f))))))) + (and s + (let ((ino-hash (hashv-ref dev-hash (stat:dev s))) + (ino (stat:ino s))) + (or ino-hash + (begin + (set! ino-hash (make-hash-table size)) + (hashv-set! dev-hash (stat:dev s) ino-hash))) + (or (hashv-ref ino-hash ino) + (begin + (hashv-set! ino-hash ino #t) + #f))))))) (define (stat-dir-readable?-proc uid gid) (let ((uid (getuid)) diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index e101c4e4d..8c7bdc742 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -174,12 +174,22 @@ (or gds-port (begin (set! gds-port - (let ((s (socket PF_INET SOCK_STREAM 0)) - (SOL_TCP 6) - (TCP_NODELAY 1)) - (setsockopt s SOL_TCP TCP_NODELAY 1) - (connect s AF_INET (inet-aton "127.0.0.1") 8333) - s)) + (or (let ((s (socket PF_INET SOCK_STREAM 0)) + (SOL_TCP 6) + (TCP_NODELAY 1)) + (setsockopt s SOL_TCP TCP_NODELAY 1) + (catch #t + (lambda () + (connect s AF_INET (inet-aton "127.0.0.1") 8333) + s) + (lambda _ #f))) + (let ((s (socket PF_UNIX SOCK_STREAM 0))) + (catch #t + (lambda () + (connect s AF_UNIX "/tmp/.gds_socket") + s) + (lambda _ #f))) + (error "Couldn't connect to GDS by TCP or Unix domain socket"))) (write-form (list 'name (getpid) (format #f "PID ~A" (getpid))))))) (if (not (defined? 'make-mutex)) @@ -562,7 +572,6 @@ Thanks!\n\n" (apply throw key args)) (define (run-utility) - (connect-to-gds) (set-gds-breakpoints) (write (getpid)) (newline) diff --git a/ice-9/gds-server.scm b/ice-9/gds-server.scm index a8e9c99c8..f59758729 100644 --- a/ice-9/gds-server.scm +++ b/ice-9/gds-server.scm @@ -36,13 +36,29 @@ (define connection->id (make-object-property)) -(define (run-server port) +(define (run-server port-or-path) - (let ((server (socket PF_INET SOCK_STREAM 0))) + (or (integer? port-or-path) + (string? port-or-path) + (error "port-or-path should be an integer (port number) or a string (file name)" + port-or-path)) + + (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX) + SOCK_STREAM + 0))) ;; Initialize server socket. - (setsockopt server SOL_SOCKET SO_REUSEADDR 1) - (bind server AF_INET INADDR_ANY port) + (if (integer? port-or-path) + (begin + (setsockopt server SOL_SOCKET SO_REUSEADDR 1) + (bind server AF_INET INADDR_ANY port-or-path)) + (begin + (catch #t + (lambda () (delete-file port-or-path)) + (lambda _ #f)) + (bind server AF_UNIX port-or-path))) + + ;; Start listening. (listen server 5) (let loop ((clients '()) (readable-sockets '())) diff --git a/ice-9/i18n.scm b/ice-9/i18n.scm new file mode 100644 index 000000000..e782ee21a --- /dev/null +++ b/ice-9/i18n.scm @@ -0,0 +1,67 @@ +;;;; i18n.scm --- internationalization support + +;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès <ludovic.courtes@laas.fr> + +;;; Commentary: +;;; +;;; This module provides a number of routines that support +;;; internationalization (e.g., locale-dependent text collation, character +;;; mapping, etc.). It also defines `locale' objects, representing locale +;;; settings, that may be passed around to most of these procedures. +;;; + +;;; Code: + +(define-module (ice-9 i18n) + :export (;; `locale' type + make-locale locale? + + ;; locale category masks (standard) + LC_ALL_MASK + LC_COLLATE_MASK LC_CTYPE_MASK LC_MESSAGES_MASK + LC_MONETARY_MASK LC_NUMERIC_MASK LC_TIME_MASK + + ;; locale category masks (non-standard) + LC_PAPER_MASK LC_NAME_MASK LC_ADDRESS_MASK + LC_TELEPHONE_MASK LC_MEASUREMENT_MASK + LC_IDENTIFICATION_MASK + + ;; text collation + string-locale<? string-locale>? + string-locale-ci<? string-locale-ci>? string-locale-ci=? + + char-locale<? char-locale>? + char-locale-ci<? char-locale-ci>? char-locale-ci=? + + ;; character mapping + char-locale-downcase char-locale-upcase + string-locale-downcase string-locale-upcase + + ;; reading numbers + locale-string->integer locale-string->inexact)) + + +(load-extension "libguile-i18n-v-0" "scm_init_i18n") + + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; i18n.scm ends here diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4b7b805f8..8ba446c6c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,4 +1,195 @@ -2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr> + + * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES + instead of RES (reported by Gyula Szavai). This allows the use of + negative lower bounds. + (scm_i_read_array): Make sure LEN is non-negative (reported by + Gyula Szavai). + + (scm_array_in_bounds_p): Iterate over S instead of always + comparing indices with the bounds of S[0]. This fixes + `array-in-bounds?' for arrays with a rank greater than one and + with different lower bounds for each dimension. + +2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr> + + * libguile/vectors.c (scm_vector_to_list): Fixed list + construction: elements were not copied when INC is zero (see + "shared array" example in `vectors.test'). Reported by + Szavai Gyula. + +2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr> + + * Makefile.am (lib_LTLIBRARIES): Added `libguile-i18n-v-XX.la'. + (libguile_la_SOURCES): Added `gettext.c', removed `i18n.c'. + (libguile_i18n_v_XX_la_SOURCES, libguile_i18n_v_XX_la_CFLAGS, + libguile_i18n_v_XX_la_LIBADD, libguile_i18n_v_XX_la_LDFLAGS): New. + (DOT_X_FILES): Added `gettext.x'. + (DOT_DOC_FILES): Likewise. + (EXTRA_libguile_la_SOURCES): Added `locale-categories.h'. + (modinclude_HEADERS): Added `gettext.h'. + (EXTRA_DIST): Added `libgettext.h'. + + * gettext.h: Renamed to... + * libgettext.h: New file. + + * i18n.c: Renamed to... + * gettext.c: New file. + + * i18n.h: Renamed to... + * gettext.h: New file. + + * i18n.c, i18n.h, locale-categories.h: New files. + + * init.c: Include "libguile/gettext.h" instead of + "libguile/i18n.h". + (scm_i_init_guile): Invoke `scm_init_gettext ()' instead of + `scm_init_i18n ()'. + + * posix.c: Include "libguile/gettext.h" instead of + "libguile/i18n.h" Test `HAVE_NEWLOCALE' and `HAVE_STRCOLL_L'. + (USE_GNU_LOCALE_API): New macro. + (scm_i_locale_mutex): New variable. + (scm_setlocale): Lock and unlock it around `setlocale ()' calls. + + * posix.h: Include "libguile/threads.h". + (scm_i_locale_mutex): New declaration. + +2006-11-17 Neil Jerram <neil@ossau.uklinux.net> + + * script.c (scm_shell_usage): Note need for subscription to bug-guile@gnu.org. + +2006-11-08 Ludovic Courtès <ludovic.courtes@laas.fr> + + * libguile/gc-freelist.c (scm_i_adjust_min_yield): Take two + "sweep_stats" arguments; use them instead of accessing the global + variables `scm_gc_cells_collected' and `scm_gc_cells_collected_1'. + + * libguile/gc-segment.c (scm_i_sweep_some_cards): Reset SWEEP + before each iteration of the loop. + (scm_i_sweep_some_segments): Reset SWEEP at each iteration. + (scm_i_get_new_heap_segment): Take an additional argument + SWEEP_STATS. Compute MIN_CELLS as a function of it. + + * libguile/gc.c (scm_gc_cells_collected, + scm_gc_cells_collected_1): Removed. + (scm_i_gc_sweep_stats, scm_i_gc_sweep_stats_1): New. + (scm_gc_cells_marked_acc, scm_gc_cells_swept_acc, + scm_gc_time_taken, scm_gc_mark_time_taken, scm_gc_times, + scm_gc_cell_yield_percentage, protected_obj_count): Made `static'. + (scm_gc_stats): Use `scm_i_gc_sweep_stats' instead of + `scm_gc_cells_(collected|swept)'. + (gc_update_stats): New. + (gc_end_stats): Use `scm_i_gc_sweep_stats' and + `scm_i_gc_sweep_stats_1' instead of the former globals. + (scm_gc_for_newcell): Invoke `gc_update_stats ()' after each + `scm_i_sweep_some_segments' call. This fixes a bug where the GC + would keep allocating new segments instead of re-using collected + cells (because `scm_gc_cells_collected' would remain zero). + + * libguile/gc.h (scm_gc_cells_swept, scm_gc_cells_collected, + scm_gc_cell_yield_percentage): Removed. + + * libguile/private-gc.h (scm_gc_cells_collected_1): Removed. + (scm_i_adjust_min_yield): Updated. + (scm_i_get_new_heap_segment): Updated. + +2006-11-02 Neil Jerram <neil@ossau.uklinux.net> + + * modules.c: Correct comment saying that low-level environments + will be used "in the next release". + + * init.c: Comment out #include of environments.h. + (scm_i_init_guile): Comment out scm_environments_prehistory() and + scm_init_environments() calls. + + * Makefile.am (libguile_la_SOURCES): Remove environments.c. + (DOT_X_FILES): Remove environments.x. + (DOT_DOC_FILES): Remove environments.doc. + (modinclude_HEADERS): Remove environments.h. + +2006-10-25 Neil Jerram <neil@ossau.uklinux.net> + + IA64 HP-UX GC patch from Hrvoje NikÅ¡ić. (Thanks!) + + * threads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() and + scm_ia64_register_backing_store_base() instead of Linux-specific + implementations. + + * gc.h (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): + New declarations. + + * gc.c (__libc_ia64_register_backing_store_base): Declaration + removed. + (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): New, with + implementations for Linux and HP-UX. + + * coop-pthreads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() + and scm_ia64_register_backing_store_base() instead of + Linux-specific implementations. + + * continuations.h (__libc_ia64_register_backing_store_base): + Declaration removed. + (scm_t_contregs): New "fresh" field. + + * continuations.c (ia64_getcontext): Removed. + (scm_make_continuation): Use continuation fresh field instead of + interpreting getcontext return values (which isn't portable). Use + scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base() + instead of Linux-specific implementations. + (copy_stack_and_call): Use scm_ia64_register_backing_store_base() + instead of Linux-specific implementation. + + * _scm.h (__ia64__): Also detect __ia64. + +2006-10-03 Kevin Ryde <user42@zip.com.au> + + * eval.c (SCM_APPLY): For scm_tc7_subr_2o, throw wrong-num-args on 0 + arguments or 3 or more arguments. Previously 0 called proc with + SCM_UNDEFINED, and 3 or more silently used just the first 2. + +2006-09-28 Kevin Ryde <user42@zip.com.au> + + * fports.c, ports.c (ftruncate): Use "HAVE_CHSIZE && ! HAVE_FTRUNCATE" + for chsize fallback, instead of hard-coding mingw. Mingw in fact + supplies ftruncate itself these days. + + * ports.c (fcntl.h): Can include this unconditionally, no need for + __MINGW32__. + + * ports.c (truncate): Conditionalize on "HAVE_FTRUNCATE && ! + HAVE_TRUNCATE" so as not to hard-code mingw. Use "const char *" and + "off_t" for parameters, per usual definition of this function, rather + than "char *" and "int". Use ftruncate instead of chsize. Check for + error on final close. + +2006-09-27 Kevin Ryde <user42@zip.com.au> + + * numbers.c (scm_log10): Check HAVE_CLOG10, clog10() is not available + in mingw. + + * posix.c (scm_execl, scm_execlp, scm_execle): Cast "const char * + const *" for mingw to suppress warnings from gcc (which are errors + under the configure default -Werror). Reported by Nils Durner. + +2006-09-26 Kevin Ryde <user42@zip.com.au> + + * _scm.h (scm_to_off64_t, scm_from_off64_t): New macros. + * fports.c (scm_open_file): Use open_or_open64. + (fport_seek_or_seek64): New function, adapting fport_seek. + * fports.c, fports.h (scm_i_fport_seek, scm_i_fport_truncate): New + functions. + * ports.c (scm_seek, scm_truncate_file): Use scm_i_fport_seek and + scm_i_fport_truncate to allow 64-bit seeks and truncates on fports. + + * ports.c (scm_truncate_file): Update docstring per manual. + +2006-09-23 Kevin Ryde <user42@zip.com.au> + + * numbers.c, numbers.h (scm_log, scm_log10, scm_exp, scm_sqrt): New + functions. + +2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> * srfi-14.c: Include <config.h>. Define `_GNU_SOURCE'. (make_predset, define_predset, make_strset, define_strset, false, @@ -20,6 +211,11 @@ (scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a successful `setlocale ()' call. +2006-09-08 Kevin Ryde <user42@zip.com.au> + + * socket.c (scm_init_socket): Add MSG_DONTWAIT. + (scm_recvfrom): Update docstring from manual. + 2006-08-31 Rob Browning <rlb@defaultvalue.org> * ports.c (scm_c_port_for_each): Add a @@ -32,11 +228,47 @@ improvements to docstring. (scm_backtrace_with_highlights): Analogous improvements. +2006-08-12 Kevin Ryde <user42@zip.com.au> + + * gen-scmconfig.h.in (SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT): + New, set from configure. + * gen-scmconfig.c (SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT): New output + to scmconfig.h. + * pthread-threads.h (SCM_I_PTHREAD_ONCE_INIT): Use + SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT to cope with Solaris. + Reported by Claes Wallin. + 2006-08-11 Neil Jerram <neil@ossau.uklinux.net> * stacks.c (scm_last_stack_frame): Correct docstring (returns a frame, not a stack). +2006-07-25 Kevin Ryde <user42@zip.com.au> + + * threads.c (get_thread_stack_base): Restrict HAVE_PTHREAD_GETATTR_NP + on pthreads version, since pthread_getattr_np not available on solaris + and macos. Reported by Claes Wallin. + +2006-07-24 Kevin Ryde <user42@zip.com.au> + + * filesys.c (dirfd): Test with #ifndef rather than HAVE_DIRFD, since + it's a macro on MacOS X. Reported by Claes Wallin. + + * posix.c (sethostname): Give prototype if not HAVE_DECL_SETHOSTNAME, + for the benefit of Solaris 10. Reported by Claes Wallin. + + * socket.c (scm_htonl, scm_ntohl): Use scm_to_uint32 rather than + NUM2ULONG, to enforce 32-bit range check on systems with 64-bit long. + +2006-07-21 Kevin Ryde <user42@zip.com.au> + + * eval.c, filesys.c (alloca): Update <alloca.h> etc blob, per current + autoconf recommendation. Should fix Solaris 10 reported by Claes + Wallin. + + * threads.c: Include <string.h>, needed for memset() which is used by + FD_ZERO() on Solaris 10. Reported by Claes Wallin. + 2006-07-18 Rob Browning <rlb@defaultvalue.org> * continuations.c: Add __attribute__ ((returns_twice)) to the @@ -44,12 +276,31 @@ arrangements and avoid an illegal instruction during call-with-current-continuation. -2006-07-12 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-07-12 Ludovic Courtès <ludovic.courtes@laas.fr> * numbers.c (guile_ieee_init): Use regular ANSI C casts rather than C++-style `X_CAST ()'. Patch posted by by Mike Gran. -2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-07-08 Kevin Ryde <user42@zip.com.au> + + * environments.c (core_environments_unobserve): Use if/else rather + than ?: for "SET" bits, avoiding complaints from AIX xlc compiler + about them not being rvalues. Reported by Mike Gran. + + * Makefile.am (version.h): Don't use $< in an explicit rule, it's not + portable and in particular fails on OpenBSD and AIX (see autoconf + manual too). Reported by Mike Gran. + +2006-06-25 Kevin Ryde <user42@zip.com.au> + + * stime.c (bdtime2c): tm_gmtoff is seconds East, so take negative of + tm:gmtoff which is seconds West. Reported by Aaron VanDevender. + (bdtime2c): Test HAVE_STRUCT_TM_TM_GMTOFF for tm_gmtoff, rather than + HAVE_TM_ZONE. + (scm_strptime): Use tm_gmtoff from the strptime result when that field + exists, it's set by glibc strptime "%s". + +2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> * eq.c: Include "struct.h", "goops.h" and "objects.h". (scm_equal_p): Invoke `scm_i_struct_equalp ()' on structures that @@ -187,7 +438,7 @@ 2006-04-06 Kevin Ryde <user42@zip.com.au> * fports.c (scm_setvbuf): Fix for not _IOLBF, clear SCM_BUFLINE - instead of toggling it. Reported by Ludovic Courtès. + instead of toggling it. Reported by Ludovic Courtès. 2006-03-26 Marius Vollmer <mvo@zagadka.de> @@ -199,7 +450,7 @@ * gc_os_dep.c (scm_get_stack_base): Abort when the machine type is unknown instead of returning NULL. -2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr> * numbers.c (scm_i_mem2number): Renamed to scm_c_locale_stringn_to_number. @@ -291,7 +542,7 @@ (scm_i_sweep_statistics_init): New macro. (scm_i_sweep_statistics_sum): New macro -2006-02-14 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-02-14 Ludovic Courtès <ludovic.courtes@laas.fr> * strings.c (scm_i_take_stringbufn): Register LEN+1 bytes instead of LEN. Without this, too much collectable memory gets unregistered, @@ -409,7 +660,7 @@ * inline.h, pairs.c (scm_is_pair): Moved scm_is_pair from pairs.c to inline.h to make it inline. -2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr> * strings.c (scm_i_take_stringbufn): New. (scm_i_c_take_symbol): New. @@ -442,7 +693,7 @@ 2005-12-29 Neil Jerram <neil@ossau.uklinux.net> - * fluids.c (next_fluid_num): [From Ludovic Courtès:] Don't trigger + * fluids.c (next_fluid_num): [From Ludovic Courtès:] Don't trigger the GC when allocated_fluids_len is zero. 2005-12-14 Neil Jerram <neil@ossau.uklinux.net> @@ -474,7 +725,7 @@ * srfi-4.h, srfi-4.c, srfi-4.i.c (take_uvec): Make BASE pointer non-const. - (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courtès! + (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courtès! * threads.h, threads.c (scm_t_guile_ticket, scm_leave_guile, scm_enter_guile): Removed from public API. See comment at @@ -489,7 +740,7 @@ * eval.c (scm_m_cond): Recognize SRFI 61 cond syntax. (CEVAL): Evaluate SRFI 61 cond clauses. -2005-12-06 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-12-06 Ludovic Courtès <ludovic.courtes@laas.fr> * gc-card.c (scm_i_card_statistics): Return if BITVEC is NULL. This was typically hit when running `gc-live-object-stats' right @@ -503,7 +754,7 @@ 2005-11-26 Kevin Ryde <user42@zip.com.au> * gc-mark.c (scm_mark_all): Change C++ comment to C comment. Reported - by Ludovic Courtès. + by Ludovic Courtès. * list.c (list): Should be "primitive" in SCM_SNARF_DOCS, not "register". @@ -515,7 +766,7 @@ * socket.c (scm_fill_sockaddr): Remove SCM_C_INLINE_KEYWORD, this is much too big to want to inline. -2005-11-17 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-11-17 Ludovic Courtès <ludovic.courtes@laas.fr> * print.c (EXIT_NESTED_DATA): Before popping from the stack, reset the value at its top. This fixes a reference leak. @@ -523,14 +774,14 @@ `PSTATE_STACK_SET ()' in order to avoid undesired potential side effects. -2005-11-12 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-11-12 Ludovic Courtès <ludovic.courtes@laas.fr> * gc.c (scm_weak_vectors): Removed. 2005-11-12 Kevin Ryde <user42@zip.com.au> * socket.c (scm_setsockopt): Missing @defvar in docstring. Reported - by Ludovic Courtès. + by Ludovic Courtès. 2005-11-07 Marius Vollmer <mvo@zagadka.de> @@ -552,7 +803,7 @@ * debug.h (SCM_CHEAPTRAPS_P): Removed. -2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr> * socket.c (scm_fill_sockaddr): No need to check NULL from scm_malloc. (scm_connect, scm_bind, scm_sendto): Accept sockaddr object. @@ -860,7 +1111,7 @@ 2005-05-11 Neil Jerram <neil@ossau.uklinux.net> - Fix C99isms reported by Ludovic Courtès: + Fix C99isms reported by Ludovic Courtès: * threads.c (s_scm_lock_mutex): Don't declare msg in middle of code. @@ -975,7 +1226,7 @@ 2005-03-18 Kevin Ryde <user42@zip.com.au> * arbiters.c (FETCH_STORE) [generic C]: Should be - scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courtès. + scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courtès. 2005-03-13 Kevin Ryde <user42@zip.com.au> @@ -2121,7 +2372,7 @@ 2004-11-02 Marius Vollmer <mvo@zagadka.de> - Mac OS X and OpenBSD compatibility patches from Andreas Vögele. + Mac OS X and OpenBSD compatibility patches from Andreas Vögele. Thanks! * backtrace.c (scm_display_backtrace_with_highlights): Join the @@ -2565,7 +2816,7 @@ * numbers.h, numbers.c: Include <gmp.h> in numbers.h, not in numbers.c. (scm_to_mpz, scm_from_mpz): New. - Thanks to Andreas Vögele! + Thanks to Andreas Vögele! * read.c (skip_scsh_block_comment): Recognize "!#" everywhere, not just on a line of its own. @@ -2574,7 +2825,7 @@ scm_string_tabulate, string_upcase_x, string_down_case_x, string_titlecase_x, string_reverse_x, scm_string_tokenize): Use size_t instead of int for indices into strings. Make sure that no - over- or underflow occurs. Thanks to Andreas Vögele! + over- or underflow occurs. Thanks to Andreas Vögele! (scm_xsubstring, scm_string_xcopy_x): Use ints for 'extended' indices, which can also be negative. @@ -2596,7 +2847,7 @@ * filesys.c, stime.c (_POSIX_C_SOURCE): Use this only on hpux, it causes too many problems elsewhere (glibc, freebsd, mingw). Reported - by Andreas Vögele. + by Andreas Vögele. 2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de> @@ -3431,7 +3682,7 @@ * gc_os_dep.c: update ifdefery for macosx. (scm_get_stack_base): separate result initialization from declaration to slience warnings with macosx and hp-ux using gcc - 3.3. Thanks to Andreas Vögele. + 3.3. Thanks to Andreas Vögele. 2004-06-13 Han-Wen Nienhuys <hanwen@xs4all.nl> @@ -3641,10 +3892,10 @@ 2004-05-02 Kevin Ryde <user42@zip.com.au> * eval.c (scm_macroexp): Add prototype, since it's not in eval.h under - --disable-deprecated. Reported by Andreas Vögele. + --disable-deprecated. Reported by Andreas Vögele. * filesys.c (_POSIX_C_SOURCE): Define to 199506L to get readdir_r (in - particular on HP-UX). Reported by Andreas Vögele. + particular on HP-UX). Reported by Andreas Vögele. * list.c (varargs.h): Remove, leave just stdarg.h which is all the code has support for. Fixes building with AIX cc, which is ansi but @@ -3655,14 +3906,14 @@ 2004-05-01 Kevin Ryde <user42@zip.com.au> * continuations.c (scm_dynthrow): Use >= instead of SCM_PTR_GE which - is now gone. Reported by Andreas Vögele. + is now gone. Reported by Andreas Vögele. 2004-04-28 Kevin Ryde <user42@zip.com.au> * backtrace.c (display_frame_expr), numbers.c (XDIGIT2UINT, mem2uinteger, mem2decimal_from_point, mem2ureal): Cast char to int for ctype.h tests, to avoid warnings from gcc on HP-UX about char as array - subscript. Reported by Andreas Vögele. + subscript. Reported by Andreas Vögele. Also cast through unsigned char to avoid passing negatives to those macros if input contains 8-bit values. @@ -3676,17 +3927,17 @@ * numbers.c (scm_bit_extract): Use min instead of MIN. (MIN): Remove, this conflicts with similar macro defined by limits.h - on HP-UX. Reported by Andreas Vögele. + on HP-UX. Reported by Andreas Vögele. * stime.c (_POSIX_C_SOURCE): Define to 199506L to get gmtime_r (in - particular on HP-UX). Reported by Andreas Vögele. + particular on HP-UX). Reported by Andreas Vögele. * threads.c (scm_threads_mark_stacks): Correction sizet -> size_t. - Reported by Andreas Vögele. + Reported by Andreas Vögele. * threads-plugin.h (SCM_MUTEX_MAXSIZE): Increase to 25*sizeof(long), for the benefit of hpux11 where pthread_mutex_t is 88 bytes. Reported - by Andreas Vögele. + by Andreas Vögele. 2004-04-22 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> @@ -7539,7 +7790,7 @@ 2002-08-26 Marius Vollmer <mvo@zagadka.ping.de> * script.c (scm_compile_shell_switches): Added "2002" to Copyright - years. Thanks to Martin Grabmüller! + years. Thanks to Martin Grabmüller! 2002-08-25 Han-Wen Nienhuys <hanwen@cs.uu.nl> @@ -9455,7 +9706,7 @@ * deprecation.c (scm_include_deprecated_features): Simplified. * eval.c (EVALCAR, unmemocopy), eval.h (SCM_XEVALCAR): Use - `SCM_IMP' instead of `!SCM_CELLP´. + `SCM_IMP' instead of `!SCM_CELLP´. * eval.c (unmemocopy): Eliminate redundant SCM_CELLP tests. Extract side-effecting operations from macros. @@ -10496,7 +10747,7 @@ 2001-06-09 Marius Vollmer <mvo@zagadka.ping.de> * ports.c (scm_lfwrite): Maintain columnd and row count in port. - Thanks to Matthias Köppe! + Thanks to Matthias Köppe! 2001-06-08 Michael Livshin <mlivshin@bigfoot.com> @@ -10504,7 +10755,7 @@ space-happy C preprocessors. * filter-doc-snarfage.c, guile-snarf.in: try to cope with spaces - inside cookies. thanks to Matthias Köppe! + inside cookies. thanks to Matthias Köppe! 2001-06-08 Dirk Herrmann <D.Herrmann@tu-bs.de> @@ -11079,7 +11330,7 @@ SCM_VARIABLE_INIT since that it what it used to be. * deprecation.c (scm_include_deprecated_features): Make docstring - ANSIsh. Thanks to Matthias Köppe! + ANSIsh. Thanks to Matthias Köppe! 2001-05-21 Marius Vollmer <mvo@zagadka.ping.de> @@ -11433,7 +11684,7 @@ 2001-05-15 Marius Vollmer <mvo@zagadka.ping.de> * values.c (print_values): Print as a unreadable object, not as - multiple lines. Thanks to Matthias Köppe! + multiple lines. Thanks to Matthias Köppe! 2001-05-14 Dirk Herrmann <D.Herrmann@tu-bs.de> @@ -11465,7 +11716,7 @@ 2001-05-09 Michael Livshin <mlivshin@bigfoot.com> - from Matthias Köppe (thanks!): + from Matthias Köppe (thanks!): * ports.c (scm_c_read): pointer arithmetic on void pointers isn't portable. @@ -13322,7 +13573,7 @@ 2001-01-11 Michael Livshin <mlivshin@bigfoot.com> - from Matthias Köppe: + from Matthias Köppe: * objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER casts its result, so doesn't yield an lvalue per ANSI C. @@ -13391,3 +13642,7 @@ (write_all): new helper procedure. The ChangeLog continues in the file: "ChangeLog-2000" + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 34b747324..6e1fa8634 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -31,7 +31,8 @@ INCLUDES = -I.. -I$(top_srcdir) ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \ --regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/' -lib_LTLIBRARIES = libguile.la +lib_LTLIBRARIES = libguile.la \ + libguile-i18n-v-@LIBGUILE_I18N_MAJOR@.la bin_PROGRAMS = guile noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig @@ -94,12 +95,12 @@ libguile_la_CFLAGS = $(GUILE_CFLAGS) libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ chars.c continuations.c convert.c debug.c deprecation.c \ - deprecated.c discouraged.c dynwind.c environments.c eq.c error.c \ + deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-malloc.c \ - gdbint.c gh_data.c gh_eval.c gh_funcs.c \ + gdbint.c gettext.c gh_data.c gh_eval.c gh_funcs.c \ gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \ - guardians.c hash.c hashtab.c hooks.c i18n.c init.c inline.c \ + guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ print.c procprop.c procs.c properties.c random.c rdelim.c read.c \ @@ -109,11 +110,20 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ ramap.c unif.c +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \ + $(libguile_la_CFLAGS) +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \ + libguile.la +libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \ + -module -L$(builddir) -lguile \ + -version-info @LIBGUILE_I18N_INTERFACE@ + DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x \ - goops.x gsubr.x guardians.x \ + gettext.c goops.x gsubr.x guardians.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ @@ -128,10 +138,10 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \ deprecated.doc discouraged.doc dynl.doc dynwind.doc \ - environments.doc eq.doc error.doc eval.doc evalext.doc \ + eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ gc.doc goops.doc gsubr.doc \ - gc-malloc.doc guardians.doc hash.doc hashtab.doc \ + gc-malloc.doc gettext.doc guardians.doc hash.doc hashtab.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ @@ -154,7 +164,8 @@ EXTRA_libguile_la_SOURCES = _scm.h \ dynl.c regex-posix.c \ filesys.c posix.c net_db.c socket.c \ debug-malloc.c mkstemp.c \ - win32-uname.c win32-dirent.c win32-socket.c + win32-uname.c win32-dirent.c win32-socket.c \ + locale-categories.h ## delete guile-snarf.awk from the installation bindir, in case it's ## lingering there due to an earlier guile version not having been @@ -186,9 +197,10 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ boehm-gc.h \ boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ - environments.h eq.h error.h eval.h evalext.h extensions.h \ + eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ - gdb_interface.h gdbint.h goops.h gsubr.h guardians.h hash.h \ + gdb_interface.h gdbint.h gettext.h goops.h \ + gsubr.h guardians.h hash.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \ @@ -213,7 +225,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex version.h.in \ - scmconfig.h.top gettext.h + scmconfig.h.top libgettext.h # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi @@ -221,7 +233,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ ## usual @...@, so autoconf doesn't go and substitute the values ## directly into the left-hand sides of the sed substitutions. *sigh* version.h: version.h.in - sed < $< > $@.tmp \ + sed < $(srcdir)/version.h.in > $@.tmp \ -e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \ -e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \ -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}: diff --git a/libguile/_scm.h b/libguile/_scm.h index ea654ad39..fd05770c2 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -54,6 +54,9 @@ and differences between _scm.h and __scm.h. **********************************************************************/ +#if defined(__ia64) && !defined(__ia64__) +# define __ia64__ +#endif #if HAVE_CONFIG_H # include <config.h> @@ -167,6 +170,8 @@ #else # error sizeof(off_t) is not 4 or 8. #endif +#define scm_to_off64_t scm_to_int64 +#define scm_from_off64_t scm_from_int64 #endif /* SCM__SCM_H */ diff --git a/libguile/continuations.c b/libguile/continuations.c index f9e52df2a..a06ae79ab 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -57,22 +57,6 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) return 1; } -#ifdef __ia64__ -/* Extern declaration of getcontext()/setcontext() in order to redefine - getcontext() since on ia64-linux the second return value indicates whether - it returned from getcontext() itself or by running setcontext(). */ -struct rv -{ - long retval; - long first_return; -}; - -#ifdef __GNUC__ -__attribute__ ((returns_twice)) -#endif /* __GNUC__ */ -extern struct rv ia64_getcontext (ucontext_t *) __asm__ ("getcontext"); -#endif /* __ia64__ */ - /* this may return more than once: the first time with the escape procedure, then subsequently with the value to be passed to the continuation. */ @@ -85,9 +69,6 @@ scm_make_continuation (int *first) scm_t_contregs *continuation; long stack_size; SCM_STACKITEM * src; -#ifdef __ia64__ - struct rv rv; -#endif /* __ia64__ */ SCM_FLUSH_REGISTER_WINDOWS; stack_size = scm_stack_size (thread->continuation_base); @@ -109,20 +90,23 @@ scm_make_continuation (int *first) memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); #ifdef __ia64__ - rv = ia64_getcontext (&continuation->ctx); - if (rv.first_return) + continuation->fresh = 1; + getcontext (&continuation->ctx); + if (continuation->fresh) { - continuation->backing_store_size = - continuation->ctx.uc_mcontext.sc_ar_bsp - - (unsigned long) __libc_ia64_register_backing_store_base; + continuation->backing_store_size = + (char *) scm_ia64_ar_bsp(&continuation->ctx) + - + (char *) scm_ia64_register_backing_store_base (); continuation->backing_store = NULL; continuation->backing_store = scm_gc_malloc (continuation->backing_store_size, "continuation backing store"); memcpy (continuation->backing_store, - (void *) __libc_ia64_register_backing_store_base, + (void *) scm_ia64_register_backing_store_base (), continuation->backing_store_size); *first = 1; + continuation->fresh = 0; return cont; } else @@ -217,7 +201,7 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, continuation->throw_value = val; #ifdef __ia64__ - memcpy ((void *) __libc_ia64_register_backing_store_base, + memcpy (scm_ia64_register_backing_store_base (), continuation->backing_store, continuation->backing_store_size); setcontext (&continuation->ctx); diff --git a/libguile/continuations.h b/libguile/continuations.h index d10297956..0274c1b2d 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -27,7 +27,6 @@ #ifdef __ia64__ #include <signal.h> #include <ucontext.h> -extern unsigned long * __libc_ia64_register_backing_store_base; #endif /* __ia64__ */ @@ -48,6 +47,7 @@ typedef struct SCM dynenv; #ifdef __ia64__ ucontext_t ctx; + int fresh; void *backing_store; unsigned long backing_store_size; #endif /* __ia64__ */ diff --git a/libguile/coop-pthreads.c b/libguile/coop-pthreads.c index 2ca8b4f6f..641583037 100644 --- a/libguile/coop-pthreads.c +++ b/libguile/coop-pthreads.c @@ -827,8 +827,8 @@ scm_threads_init (SCM_STACKITEM *base) scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ / sizeof (SCM_STACKITEM))); \ - bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \ - top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \ + bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \ + top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ scm_mark_locations (bot, top - bot); } while (0) #else # define SCM_MARK_BACKING_STORE() diff --git a/libguile/environments.c b/libguile/environments.c index 34788cc74..ed23d3011 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -667,9 +667,10 @@ core_environments_unobserve (SCM env, SCM observer) if (scm_is_eq (first, observer)) { /* Remove the first observer */ - handling_weaks - ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest) - : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest); + if (handling_weaks) + SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest); + else + SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest); return; } diff --git a/libguile/eval.c b/libguile/eval.c index ae4ee4fd8..dcbd1ac7d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -37,24 +37,22 @@ #ifndef DEVAL -/* AIX requires this to be the first thing in the file. The #pragma - directive is indented so pre-ANSI compilers will ignore it, rather - than choke on it. */ -#ifndef __GNUC__ -# if HAVE_ALLOCA_H -# include <alloca.h> -# else -# ifdef _AIX -# pragma alloca -# else -# ifndef alloca /* predefined by HP cc +Olibcalls */ -char *alloca (); -# endif -# endif +/* This blob per the Autoconf manual (under "Particular Functions"). */ +#if HAVE_ALLOCA_H +# include <alloca.h> +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include <malloc.h> +# define alloca _alloca +#else +# include <stddef.h> +# ifdef __cplusplus +extern "C" # endif -#endif -#if HAVE_MALLOC_H -#include <malloc.h> /* alloca on mingw */ +void *alloca (size_t); #endif #include <assert.h> @@ -4851,7 +4849,16 @@ tail: switch (SCM_TYP7 (proc)) { case scm_tc7_subr_2o: - args = scm_is_null (args) ? SCM_UNDEFINED : SCM_CAR (args); + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + if (scm_is_null (args)) + args = SCM_UNDEFINED; + else + { + if (! scm_is_null (SCM_CDR (args))) + scm_wrong_num_args (proc); + args = SCM_CAR (args); + } RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_2: if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) diff --git a/libguile/filesys.c b/libguile/filesys.c index 8ac6bd246..72b45e92a 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -29,24 +29,22 @@ # include <config.h> #endif -/* AIX requires this to be the first thing in the file. The #pragma - directive is indented so pre-ANSI compilers will ignore it, rather - than choke on it. */ -#ifndef __GNUC__ -# if HAVE_ALLOCA_H -# include <alloca.h> -# else -# ifdef _AIX -# pragma alloca -# else -# ifndef alloca /* predefined by HP cc +Olibcalls */ -char *alloca (); -# endif -# endif +/* This blob per the Autoconf manual (under "Particular Functions"). */ +#if HAVE_ALLOCA_H +# include <alloca.h> +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include <malloc.h> +# define alloca _alloca +#else +# include <stddef.h> +# ifdef __cplusplus +extern "C" # endif -#endif -#if HAVE_MALLOC_H -#include <malloc.h> /* alloca on mingw, though its not used on that system */ +void *alloca (size_t); #endif #include <stdio.h> @@ -202,10 +200,14 @@ char *alloca (); # define fchmod(fd, mode) (-1) #endif /* __MINGW32__ */ -/* This definition is for Solaris 10, it's probably not right elsewhere, but - that's ok, it shouldn't be used elsewhere. */ -#if ! HAVE_DIRFD -#define dirfd(dirstream) (dirstream->dd_fd) +/* dirfd() returns the file descriptor underlying a "DIR*" directory stream. + Found on MacOS X for instance. The following definition is for Solaris + 10, it's probably not right elsewhere, but that's ok, it shouldn't be + used elsewhere. Crib note: If we need more then gnulib has a dirfd.m4 + figuring out how to get the fd (dirfd function, dirfd macro, dd_fd field, + or d_fd field). */ +#ifndef dirfd +#define dirfd(dirstream) ((dirstream)->dd_fd) #endif diff --git a/libguile/fports.c b/libguile/fports.c index 742877eaf..f4c07af0d 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -17,6 +17,8 @@ +#define _LARGEFILE64_SOURCE /* ask for stat64 etc */ + #if HAVE_CONFIG_H # include <config.h> #endif @@ -46,6 +48,7 @@ #endif #include <errno.h> +#include <sys/types.h> #include "libguile/iselect.h" @@ -53,9 +56,33 @@ #ifdef __MINGW32__ # include <sys/stat.h> # include <winsock2.h> -# define ftruncate(fd, size) chsize (fd, size) #endif /* __MINGW32__ */ +/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize + already, but have this code here in case that wasn't so in past versions, + or perhaps to help other minimal DOS environments. + + gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which + might be possibilities if we've got other systems without ftruncate. */ + +#if HAVE_CHSIZE && ! HAVE_FTRUNCATE +# define ftruncate(fd, size) chsize (fd, size) +#undef HAVE_FTRUNCATE +#define HAVE_FTRUNCATE 1 +#endif + +#if SIZEOF_OFF_T == SIZEOF_INT +#define OFF_T_MAX INT_MAX +#define OFF_T_MIN INT_MIN +#elif SIZEOF_OFF_T == SIZEOF_LONG +#define OFF_T_MAX LONG_MAX +#define OFF_T_MIN LONG_MIN +#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG +#define OFF_T_MAX LONG_LONG_MAX +#define OFF_T_MIN LONG_LONG_MIN +#else +#error Oops, unknown OFF_T size +#endif scm_t_bits scm_tc16_fport; @@ -334,7 +361,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, } ptr++; } - SCM_SYSCALL (fdes = open (file, flags, 0666)); + SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666)); if (fdes == -1) { int en = errno; @@ -584,25 +611,25 @@ fport_fill_input (SCM port) } } -static off_t -fport_seek (SCM port, off_t offset, int whence) +static off_t_or_off64_t +fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence) { scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_fport *fp = SCM_FSTREAM (port); - off_t rv; - off_t result; + off_t_or_off64_t rv; + off_t_or_off64_t result; if (pt->rw_active == SCM_PORT_WRITE) { if (offset != 0 || whence != SEEK_CUR) { fport_flush (port); - result = rv = lseek (fp->fdes, offset, whence); + result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); } else { /* read current position without disturbing the buffer. */ - rv = lseek (fp->fdes, offset, whence); + rv = lseek_or_lseek64 (fp->fdes, offset, whence); result = rv + (pt->write_pos - pt->write_buf); } } @@ -612,13 +639,13 @@ fport_seek (SCM port, off_t offset, int whence) { /* could expand to avoid a second seek. */ scm_end_input (port); - result = rv = lseek (fp->fdes, offset, whence); + result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); } else { /* read current position without disturbing the buffer (particularly the unread-char buffer). */ - rv = lseek (fp->fdes, offset, whence); + rv = lseek_or_lseek64 (fp->fdes, offset, whence); result = rv - (pt->read_end - pt->read_pos); if (pt->read_buf == pt->putback_buf) @@ -627,7 +654,7 @@ fport_seek (SCM port, off_t offset, int whence) } else /* SCM_PORT_NEITHER */ { - result = rv = lseek (fp->fdes, offset, whence); + result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); } if (rv == -1) @@ -636,6 +663,39 @@ fport_seek (SCM port, off_t offset, int whence) return result; } +/* If we've got largefile and off_t isn't already off64_t then + fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in + the port descriptor. + + Otherwise if no largefile, or off_t is the same as off64_t (which is the + case on NetBSD apparently), then fport_seek_or_seek64 is right to be + fport_seek already. */ + +#if HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T +static off_t +fport_seek (SCM port, off_t offset, int whence) +{ + off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence); + if (rv > OFF_T_MAX || rv < OFF_T_MIN) + { + errno = EOVERFLOW; + scm_syserror ("fport_seek"); + } + return (off_t) rv; + +} +#else +#define fport_seek fport_seek_or_seek64 +#endif + +/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */ +SCM +scm_i_fport_seek (SCM port, SCM offset, int how) +{ + return scm_from_off_t_or_off64_t + (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how)); +} + static void fport_truncate (SCM port, off_t length) { @@ -645,6 +705,13 @@ fport_truncate (SCM port, off_t length) scm_syserror ("ftruncate"); } +int +scm_i_fport_truncate (SCM port, SCM length) +{ + scm_t_fport *fp = SCM_FSTREAM (port); + return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length)); +} + /* helper for fport_write: try to write data, using multiple system calls if required. */ #define FUNC_NAME "write_all" diff --git a/libguile/fports.h b/libguile/fports.h index efc315792..634106760 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -58,6 +58,9 @@ SCM_API void scm_init_fports (void); /* internal functions */ SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name); +SCM_API int scm_i_fport_truncate (SCM, SCM); +SCM_API SCM scm_i_fport_seek (SCM, SCM, int); + #endif /* SCM_FPORTS_H */ diff --git a/libguile/gc.c b/libguile/gc.c index d8b27d2f5..04e4e0a45 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -30,11 +30,6 @@ #include <string.h> #include <assert.h> -#ifdef __ia64__ -#include <ucontext.h> -extern unsigned long * __libc_ia64_register_backing_store_base; -#endif - #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stime.h" @@ -224,18 +219,25 @@ unsigned long scm_mtrigger; */ unsigned long scm_cells_allocated = 0; unsigned long scm_mallocated = 0; -unsigned long scm_gc_cells_collected; -unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */ -unsigned long scm_gc_malloc_collected; -unsigned long scm_gc_ports_collected; -unsigned long scm_gc_time_taken = 0; + +/* Global GC sweep statistics since the last full GC. */ +static scm_t_sweep_statistics scm_i_gc_sweep_stats = { 0, 0 }; +static scm_t_sweep_statistics scm_i_gc_sweep_stats_1 = { 0, 0 }; + +/* Total count of cells marked/swept. */ +static double scm_gc_cells_marked_acc = 0.; +static double scm_gc_cells_swept_acc = 0.; + +static unsigned long scm_gc_time_taken = 0; static unsigned long t_before_gc; -unsigned long scm_gc_mark_time_taken = 0; -unsigned long scm_gc_times = 0; -unsigned long scm_gc_cells_swept = 0; -double scm_gc_cells_marked_acc = 0.; -double scm_gc_cells_swept_acc = 0.; -int scm_gc_cell_yield_percentage =0; +static unsigned long scm_gc_mark_time_taken = 0; + +static unsigned long scm_gc_times = 0; + +static int scm_gc_cell_yield_percentage = 0; +static unsigned long protected_obj_count = 0; + +/* The following are accessed from `gc-malloc.c' and `gc-card.c'. */ int scm_gc_malloc_yield_percentage = 0; static unsigned long protected_obj_count = 0; @@ -862,6 +864,44 @@ scm_init_gc () #include "libguile/gc.x" } +#ifdef __ia64__ +# ifdef __hpux +# include <sys/param.h> +# include <sys/pstat.h> +void * +scm_ia64_register_backing_store_base (void) +{ + struct pst_vm_status vm_status; + int i = 0; + while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1) + if (vm_status.pst_type == PS_RSESTACK) + return (void *) vm_status.pst_vaddr; + abort (); +} +void * +scm_ia64_ar_bsp (const void *ctx) +{ + uint64_t bsp; + __uc_get_ar_bsp(ctx, &bsp); + return (void *) bsp; +} +# endif /* hpux */ +# ifdef linux +# include <ucontext.h> +void * +scm_ia64_register_backing_store_base (void) +{ + extern void *__libc_ia64_register_backing_store_base; + return __libc_ia64_register_backing_store_base; +} +void * +scm_ia64_ar_bsp (const void *opaque) +{ + ucontext_t *ctx = opaque; + return (void *) ctx->uc_mcontext.sc_ar_bsp; +} +# endif /* linux */ +#endif /* __ia64__ */ void scm_gc_sweep (void) diff --git a/libguile/gc.h b/libguile/gc.h index 4ad21b462..f745b76a2 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -139,6 +139,11 @@ SCM_API scm_i_pthread_mutex_t scm_i_gc_admin_mutex; #define scm_gc_running_p (SCM_I_CURRENT_THREAD->gc_running_p) SCM_API scm_i_pthread_mutex_t scm_i_sweep_mutex; +#ifdef __ia64__ +void *scm_ia64_register_backing_store_base (void); +void *scm_ia64_ar_bsp (const void *); +#endif + #if (SCM_ENABLE_DEPRECATED == 1) @@ -165,13 +170,9 @@ SCM_API scm_i_pthread_key_t scm_i_freelist2; SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist; SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2; - -SCM_API unsigned long scm_gc_cells_swept; -SCM_API unsigned long scm_gc_cells_collected; SCM_API unsigned long scm_gc_malloc_collected; SCM_API unsigned long scm_gc_ports_collected; SCM_API unsigned long scm_cells_allocated; -SCM_API int scm_gc_cell_yield_percentage; SCM_API int scm_gc_malloc_yield_percentage; SCM_API unsigned long scm_mallocated; SCM_API unsigned long scm_mtrigger; diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index d162e395a..43a2a989d 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -378,6 +378,10 @@ main (int argc, char *argv[]) pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n", SCM_I_GSC_USE_NULL_THREADS); + pf ("/* Define to 1 if need braces around PTHREAD_ONCE_INIT (for Solaris). */\n"); + pf ("#define SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT %d /* 0 or 1 */\n", + SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT); + #if USE_DLL_IMPORT pf ("\n"); pf ("/* Define some additional CPP macros on Win32 platforms. */\n"); diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in index 8ceed8463..b4e0561f1 100644 --- a/libguile/gen-scmconfig.h.in +++ b/libguile/gen-scmconfig.h.in @@ -28,6 +28,7 @@ #define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@ #define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@ #define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@ +#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@ /* Local Variables: diff --git a/libguile/gettext.c b/libguile/gettext.c new file mode 100644 index 000000000..91a51439c --- /dev/null +++ b/libguile/gettext.c @@ -0,0 +1,331 @@ +/* Copyright (C) 2004, 2006 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 + */ + + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/dynwind.h" + +#include "libguile/gettext.h" +#include "libgettext.h" +#include <locale.h> + + +int +scm_i_to_lc_category (SCM category, int allow_lc_all) +{ + int c_category = scm_to_int (category); + switch (c_category) + { +#ifdef LC_CTYPE + case LC_CTYPE: +#endif +#ifdef LC_NUMERIC + case LC_NUMERIC: +#endif +#ifdef LC_COLLATE + case LC_COLLATE: +#endif +#ifdef LC_TIME + case LC_TIME: +#endif +#ifdef LC_MONETARY + case LC_MONETARY: +#endif +#ifdef LC_MESSAGES + case LC_MESSAGES: +#endif +#ifdef LC_PAPER + case LC_PAPER: +#endif +#ifdef LC_NAME + case LC_NAME: +#endif +#ifdef LC_ADDRESS + case LC_ADDRESS: +#endif +#ifdef LC_TELEPHONE + case LC_TELEPHONE: +#endif +#ifdef LC_MEASUREMENT + case LC_MEASUREMENT: +#endif +#ifdef LC_IDENTIFICATION + case LC_IDENTIFICATION: +#endif + return c_category; +#ifdef LC_ALL + case LC_ALL: + if (allow_lc_all) + return c_category; +#endif + } + scm_wrong_type_arg (0, 0, category); +} + +SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0, + (SCM msgid, SCM domain, SCM category), + "Return the translation of @var{msgid} in the message domain " + "@var{domain}. @var{domain} is optional and defaults to the " + "domain set through (textdomain). @var{category} is optional " + "and defaults to LC_MESSAGES.") +#define FUNC_NAME s_scm_gettext +{ + char *c_msgid; + char const *c_result; + SCM result; + + scm_dynwind_begin (0); + + c_msgid = scm_to_locale_string (msgid); + scm_dynwind_free (c_msgid); + + if (SCM_UNBNDP (domain)) + { + /* 1 argument case. */ + c_result = gettext (c_msgid); + } + else + { + char *c_domain; + + c_domain = scm_to_locale_string (domain); + scm_dynwind_free (c_domain); + + if (SCM_UNBNDP (category)) + { + /* 2 argument case. */ + c_result = dgettext (c_domain, c_msgid); + } + else + { + /* 3 argument case. */ + int c_category; + + c_category = scm_i_to_lc_category (category, 0); + c_result = dcgettext (c_domain, c_msgid, c_category); + } + } + + if (c_result == c_msgid) + result = msgid; + else + result = scm_from_locale_string (c_result); + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0, + (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category), + "Return the translation of @var{msgid}/@var{msgid_plural} in the " + "message domain @var{domain}, with the plural form being chosen " + "appropriately for the number @var{n}. @var{domain} is optional " + "and defaults to the domain set through (textdomain). " + "@var{category} is optional and defaults to LC_MESSAGES.") +#define FUNC_NAME s_scm_ngettext +{ + char *c_msgid; + char *c_msgid_plural; + unsigned long c_n; + const char *c_result; + SCM result; + + scm_dynwind_begin (0); + + c_msgid = scm_to_locale_string (msgid); + scm_dynwind_free (c_msgid); + + c_msgid_plural = scm_to_locale_string (msgid_plural); + scm_dynwind_free (c_msgid_plural); + + c_n = scm_to_ulong (n); + + if (SCM_UNBNDP (domain)) + { + /* 3 argument case. */ + c_result = ngettext (c_msgid, c_msgid_plural, c_n); + } + else + { + char *c_domain; + + c_domain = scm_to_locale_string (domain); + scm_dynwind_free (c_domain); + + if (SCM_UNBNDP (category)) + { + /* 4 argument case. */ + c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n); + } + else + { + /* 5 argument case. */ + int c_category; + + c_category = scm_i_to_lc_category (category, 0); + c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n, + c_category); + } + } + + if (c_result == c_msgid) + result = msgid; + else if (c_result == c_msgid_plural) + result = msgid_plural; + else + result = scm_from_locale_string (c_result); + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0, + (SCM domainname), + "If optional parameter @var{domainname} is supplied, " + "set the textdomain. " + "Return the textdomain.") +#define FUNC_NAME s_scm_textdomain +{ + char const *c_result; + char *c_domain; + SCM result = SCM_BOOL_F; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (domainname)) + c_domain = NULL; + else + { + c_domain = scm_to_locale_string (domainname); + scm_dynwind_free (c_domain); + } + + c_result = textdomain (c_domain); + if (c_result != NULL) + result = scm_from_locale_string (c_result); + else if (!SCM_UNBNDP (domainname)) + SCM_SYSERROR; + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0, + (SCM domainname, SCM directory), + "If optional parameter @var{directory} is supplied, " + "set message catalogs to directory @var{directory}. " + "Return the directory bound to @var{domainname}.") +#define FUNC_NAME s_scm_bindtextdomain +{ + char *c_domain; + char *c_directory; + char const *c_result; + SCM result; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (directory)) + c_directory = NULL; + else + { + c_directory = scm_to_locale_string (directory); + scm_dynwind_free (c_directory); + } + + c_domain = scm_to_locale_string (domainname); + scm_dynwind_free (c_domain); + + c_result = bindtextdomain (c_domain, c_directory); + + if (c_result != NULL) + result = scm_from_locale_string (c_result); + else if (!SCM_UNBNDP (directory)) + SCM_SYSERROR; + else + result = SCM_BOOL_F; + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0, + (SCM domainname, SCM encoding), + "If optional parameter @var{encoding} is supplied, " + "set encoding for message catalogs of @var{domainname}. " + "Return the encoding of @var{domainname}.") +#define FUNC_NAME s_scm_bind_textdomain_codeset +{ + char *c_domain; + char *c_encoding; + char const *c_result; + SCM result; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (encoding)) + c_encoding = NULL; + else + { + c_encoding = scm_to_locale_string (encoding); + scm_dynwind_free (c_encoding); + } + + c_domain = scm_to_locale_string (domainname); + scm_dynwind_free (c_domain); + + c_result = bind_textdomain_codeset (c_domain, c_encoding); + + if (c_result != NULL) + result = scm_from_locale_string (c_result); + else if (!SCM_UNBNDP (encoding)) + SCM_SYSERROR; + else + result = SCM_BOOL_F; + + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + +void +scm_init_gettext () +{ + /* When gettext support was first added (in 1.8.0), it provided feature + `i18n'. We keep this as is although the name is a bit misleading + now. */ + scm_add_feature ("i18n"); + +#include "libguile/gettext.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/gettext.h b/libguile/gettext.h index f54b6bff7..4d91358e5 100644 --- a/libguile/gettext.h +++ b/libguile/gettext.h @@ -1,69 +1,41 @@ -/* Convenience header for conditional use of GNU <libintl.h>. - Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc. - - This program is free software; you can redistribute it and/or modify it - under the terms of the GNU Library 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 - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, - USA. */ - -#ifndef _LIBGETTEXT_H -#define _LIBGETTEXT_H 1 - -/* NLS can be disabled through the configure --disable-nls option. */ -#if ENABLE_NLS - -/* Get declarations of GNU message catalog functions. */ -# include <libintl.h> - -#else - -/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which - chokes if dcgettext is defined as a macro. So include it now, to make - later inclusions of <locale.h> a NOP. We don't include <libintl.h> - as well because people using "gettext.h" will not include <libintl.h>, - and also including <libintl.h> would fail on SunOS 4, whereas <locale.h> - is OK. */ -#if defined(__sun) -# include <locale.h> -#endif - -/* Disabled NLS. - The casts to 'const char *' serve the purpose of producing warnings - for invalid uses of the value returned from these functions. - On pre-ANSI systems without 'const', the config.h file is supposed to - contain "#define const". */ -# define gettext(Msgid) ((const char *) (Msgid)) -# define dgettext(Domainname, Msgid) ((const char *) (Msgid)) -# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid)) -# define ngettext(Msgid1, Msgid2, N) \ - ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) -# define dngettext(Domainname, Msgid1, Msgid2, N) \ - ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) -# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \ - ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) -# define textdomain(Domainname) ((const char *) (Domainname)) -# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname)) -# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset)) - -#endif - -/* A pseudo function call that serves as a marker for the automated - extraction of messages, but does not call gettext(). The run-time - translation is done at a different place in the code. - The argument, String, should be a literal string. Concatenated strings - and other string expressions won't work. - The macro's expansion is not parenthesized, so that it is suitable as - initializer for static 'char[]' or 'const char[]' variables. */ -#define gettext_noop(String) String - -#endif /* _LIBGETTEXT_H */ +/* classes: h_files */ + +#ifndef SCM_GETTEXT_H +#define SCM_GETTEXT_H + +/* Copyright (C) 2004, 2006 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 + */ + +#include "libguile/__scm.h" + +SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category); +SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category); +SCM_API SCM scm_textdomain (SCM domainname); +SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory); +SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding); + +SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all); + +SCM_API void scm_init_gettext (void); + +#endif /* SCM_GETTEXT_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/i18n.c b/libguile/i18n.c index 16e45e495..76dd9a514 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2006 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 @@ -15,308 +15,1142 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */ #if HAVE_CONFIG_H # include <config.h> #endif +#if HAVE_ALLOCA_H +# include <alloca.h> +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include <malloc.h> +# define alloca _alloca +#else +# include <stddef.h> +# ifdef __cplusplus +extern "C" +# endif +void *alloca (size_t); +#endif + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/i18n.h" #include "libguile/strings.h" +#include "libguile/chars.h" #include "libguile/dynwind.h" +#include "libguile/validate.h" +#include "libguile/values.h" -#include "gettext.h" #include <locale.h> +#include <string.h> /* `strcoll ()' */ +#include <ctype.h> /* `toupper ()' et al. */ +#include <errno.h> - -int -scm_i_to_lc_category (SCM category, int allow_lc_all) -{ - int c_category = scm_to_int (category); - switch (c_category) - { -#ifdef LC_CTYPE - case LC_CTYPE: -#endif -#ifdef LC_NUMERIC - case LC_NUMERIC: -#endif -#ifdef LC_COLLATE - case LC_COLLATE: -#endif -#ifdef LC_TIME - case LC_TIME: -#endif -#ifdef LC_MONETARY - case LC_MONETARY: -#endif -#ifdef LC_MESSAGES - case LC_MESSAGES: +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API #endif -#ifdef LC_PAPER - case LC_PAPER: + +#ifndef USE_GNU_LOCALE_API +# include "libguile/posix.h" /* for `scm_i_locale_mutex' */ #endif -#ifdef LC_NAME - case LC_NAME: + +#ifndef HAVE_SETLOCALE +static inline char * +setlocale (int category, const char *name) +{ + errno = ENOSYS; + return NULL; +} #endif -#ifdef LC_ADDRESS - case LC_ADDRESS: + + + +/* Locale objects, string and character collation, and other locale-dependent + string operations. + + A large part of the code here deals with emulating glibc's reentrant + locale API on non-GNU systems. The emulation is a bit "brute-force": + Whenever a `-locale<?' procedure is passed a locale object, then: + + 1. The `scm_t_locale_mutex' is locked. + 2. A series of `setlocale ()' call is performed to store the current + locale for each category in an `scm_t_locale_settings' object. + 3. A series of `setlocale ()' call is made to install each of the locale + categories of each of the base locales of each locale object, + recursively, starting from the last locale object of the chain. + 4. The settings captured in step (2) are restored. + 5. The `scm_t_locale_mutex' is released. + + Hopefully, some smart standard will make that hack useless someday... + A similar API can be found in MzScheme starting from version 200: + http://download.plt-scheme.org/chronology/mzmr200alpha14.html . + + Note: We don't wrap glibc's `uselocale ()' call because it sets the locale + of the current _thread_ (unlike `setlocale ()') and doing so would require + maintaining per-thread locale information on non-GNU systems and always + re-installing this locale upon locale-dependent calls. */ + + +#ifndef USE_GNU_LOCALE_API + +/* Provide the locale category masks as found in glibc (copied from + <locale.h> as found in glibc 2.3.6). This must be kept in sync with + `locale-categories.h'. */ + +# define LC_CTYPE_MASK (1 << LC_CTYPE) +# define LC_COLLATE_MASK (1 << LC_COLLATE) +# define LC_MESSAGES_MASK (1 << LC_MESSAGES) +# define LC_MONETARY_MASK (1 << LC_MONETARY) +# define LC_NUMERIC_MASK (1 << LC_NUMERIC) +# define LC_TIME_MASK (1 << LC_TIME) + +# ifdef LC_PAPER +# define LC_PAPER_MASK (1 << LC_PAPER) +# else +# define LC_PAPER_MASK 0 +# endif +# ifdef LC_NAME +# define LC_NAME_MASK (1 << LC_NAME) +# else +# define LC_NAME_MASK 0 +# endif +# ifdef LC_ADDRESS +# define LC_ADDRESS_MASK (1 << LC_ADDRESS) +# else +# define LC_ADDRESS_MASK 0 +# endif +# ifdef LC_TELEPHONE +# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE) +# else +# define LC_TELEPHONE_MASK 0 +# endif +# ifdef LC_MEASUREMENT +# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT) +# else +# define LC_MEASUREMENT_MASK 0 +# endif +# ifdef LC_IDENTIFICATION +# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION) +# else +# define LC_IDENTIFICATION_MASK 0 +# endif + +# define LC_ALL_MASK (LC_CTYPE_MASK \ + | LC_NUMERIC_MASK \ + | LC_TIME_MASK \ + | LC_COLLATE_MASK \ + | LC_MONETARY_MASK \ + | LC_MESSAGES_MASK \ + | LC_PAPER_MASK \ + | LC_NAME_MASK \ + | LC_ADDRESS_MASK \ + | LC_TELEPHONE_MASK \ + | LC_MEASUREMENT_MASK \ + | LC_IDENTIFICATION_MASK \ + ) + +/* Locale objects as returned by `make-locale' on non-GNU systems. */ +typedef struct scm_locale +{ + SCM base_locale; /* a `locale' object */ + char *locale_name; + int category_mask; +} *scm_t_locale; + +#else + +/* Alias for glibc's locale type. */ +typedef locale_t scm_t_locale; + #endif -#ifdef LC_TELEPHONE - case LC_TELEPHONE: + +/* Validate parameter ARG as a locale object and set C_LOCALE to the + corresponding C locale object. */ +#define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \ + do \ + { \ + SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \ + (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \ + } \ + while (0) + +/* Validate optional parameter ARG as either undefined or bound to a locale + object. Set C_LOCALE to the corresponding C locale object or NULL. */ +#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \ + do \ + { \ + if ((_arg) != SCM_UNDEFINED) \ + SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \ + else \ + (_c_locale) = NULL; \ + } \ + while (0) + + +SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0); + +SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) +{ + scm_t_locale c_locale; + + c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); + +#ifdef USE_GNU_LOCALE_API + freelocale ((locale_t)c_locale); +#else + c_locale->base_locale = SCM_UNDEFINED; + free (c_locale->locale_name); + + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); #endif -#ifdef LC_MEASUREMENT - case LC_MEASUREMENT: + + return 0; +} + +#ifndef USE_GNU_LOCALE_API +static SCM +smob_locale_mark (SCM locale) +{ + scm_t_locale c_locale; + + c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); + return (c_locale->base_locale); +} #endif -#ifdef LC_IDENTIFICATION - case LC_IDENTIFICATION: + + +SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, + (SCM category_mask, SCM locale_name, SCM base_locale), + "Return a reference to a data structure representing a set of " + "locale datasets. Unlike for the @var{category} parameter for " + "@code{setlocale}, the @var{category_mask} parameter here uses " + "a single bit for each category, made by OR'ing together " + "@code{LC_*_MASK} bits.") +#define FUNC_NAME s_scm_make_locale +{ + SCM locale = SCM_BOOL_F; + int c_category_mask; + char *c_locale_name; + scm_t_locale c_base_locale, c_locale; + + SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask); + SCM_VALIDATE_STRING (2, locale_name); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); + + c_locale_name = scm_to_locale_string (locale_name); + +#ifdef USE_GNU_LOCALE_API + + c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); + + if (!c_locale) + locale = SCM_BOOL_F; + else + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + + free (c_locale_name); + +#else + + c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); + c_locale->base_locale = base_locale; + + c_locale->category_mask = c_category_mask; + c_locale->locale_name = c_locale_name; + + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + #endif - return c_category; -#ifdef LC_ALL - case LC_ALL: - if (allow_lc_all) - return c_category; -#endif - } - scm_wrong_type_arg (0, 0, category); + + return locale; } +#undef FUNC_NAME -SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0, - (SCM msgid, SCM domain, SCM category), - "Return the translation of @var{msgid} in the message domain " - "@var{domain}. @var{domain} is optional and defaults to the " - "domain set through (textdomain). @var{category} is optional " - "and defaults to LC_MESSAGES.") -#define FUNC_NAME s_scm_gettext +SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a locale object.") +#define FUNC_NAME s_scm_locale_p { - char *c_msgid; - char const *c_result; - SCM result; + if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj)) + return SCM_BOOL_T; + + return SCM_BOOL_F; +} +#undef FUNC_NAME + + + +#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */ + + +/* Maximum number of chained locales (via `base_locale'). */ +#define LOCALE_STACK_SIZE_MAX 256 + +typedef struct +{ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name; +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY +} scm_t_locale_settings; + +/* Fill out SETTINGS according to the current locale settings. On success + zero is returned and SETTINGS is properly initialized. */ +static int +get_current_locale_settings (scm_t_locale_settings *settings) +{ + const char *locale_name; + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + { \ + SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \ + if (!locale_name) \ + goto handle_error; \ + \ + settings-> _name = strdup (locale_name); \ + if (settings-> _name == NULL) \ + goto handle_oom; \ + } + +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + + return 0; + + handle_error: + return errno; - scm_dynwind_begin (0); + handle_oom: + return ENOMEM; +} + +/* Restore locale settings SETTINGS. On success, return zero. */ +static int +restore_locale_settings (const scm_t_locale_settings *settings) +{ + const char *result; + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \ + if (result == NULL) \ + goto handle_error; + +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + + return 0; + + handle_error: + return errno; +} + +/* Free memory associated with SETTINGS. */ +static void +free_locale_settings (scm_t_locale_settings *settings) +{ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + free (settings-> _name); \ + settings->_name = NULL; +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY +} - c_msgid = scm_to_locale_string (msgid); - scm_dynwind_free (c_msgid); +/* Install the locale named LOCALE_NAME for all the categories listed in + CATEGORY_MASK. */ +static int +install_locale_categories (const char *locale_name, int category_mask) +{ + const char *result; - if (SCM_UNBNDP (domain)) + if (category_mask == LC_ALL_MASK) { - /* 1 argument case. */ - c_result = gettext (c_msgid); + SCM_SYSCALL (result = setlocale (LC_ALL, locale_name)); + if (result == NULL) + goto handle_error; } else { - char *c_domain; +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + if (category_mask & LC_ ## _name ## _MASK) \ + { \ + SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \ + if (result == NULL) \ + goto handle_error; \ + } +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + } - c_domain = scm_to_locale_string (domain); - scm_dynwind_free (c_domain); + return 0; - if (SCM_UNBNDP (category)) - { - /* 2 argument case. */ - c_result = dgettext (c_domain, c_msgid); - } + handle_error: + return errno; +} + +/* Install LOCALE, recursively installing its base locales first. On + success, zero is returned. */ +static int +install_locale (scm_t_locale locale) +{ + scm_t_locale stack[LOCALE_STACK_SIZE_MAX]; + size_t stack_size = 0; + int stack_offset = 0; + const char *result = NULL; + + /* Build up a locale stack by traversing the `base_locale' link. */ + do + { + if (stack_size >= LOCALE_STACK_SIZE_MAX) + /* We cannot use `scm_error ()' here because otherwise the locale + mutex may remain locked. */ + return EINVAL; + + stack[stack_size++] = locale; + + if (locale->base_locale != SCM_UNDEFINED) + locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale); else - { - /* 3 argument case. */ - int c_category; + locale = NULL; + } + while (locale != NULL); - c_category = scm_i_to_lc_category (category, 0); - c_result = dcgettext (c_domain, c_msgid, c_category); - } + /* Install the C locale to start from a pristine state. */ + SCM_SYSCALL (result = setlocale (LC_ALL, "C")); + if (result == NULL) + goto handle_error; + + /* Install the locales in reverse order. */ + for (stack_offset = stack_size - 1; + stack_offset >= 0; + stack_offset--) + { + int err; + scm_t_locale locale; + + locale = stack[stack_offset]; + err = install_locale_categories (locale->locale_name, + locale->category_mask); + if (err) + goto handle_error; } - if (c_result == c_msgid) - result = msgid; - else - result = scm_from_locale_string (c_result); + return 0; - scm_dynwind_end (); - return result; + handle_error: + return errno; } -#undef FUNC_NAME +/* Leave the locked locale section. */ +static inline void +leave_locale_section (const scm_t_locale_settings *settings) +{ + /* Restore the previous locale settings. */ + (void)restore_locale_settings (settings); + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); +} -SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0, - (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category), - "Return the translation of @var{msgid}/@var{msgid_plural} in the " - "message domain @var{domain}, with the plural form being chosen " - "appropriately for the number @var{n}. @var{domain} is optional " - "and defaults to the domain set through (textdomain). " - "@var{category} is optional and defaults to LC_MESSAGES.") -#define FUNC_NAME s_scm_ngettext +/* Enter a locked locale section. */ +static inline int +enter_locale_section (scm_t_locale locale, + scm_t_locale_settings *prev_locale) { - char *c_msgid; - char *c_msgid_plural; - unsigned long c_n; - const char *c_result; - SCM result; + int err; + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + err = get_current_locale_settings (prev_locale); + if (err) + { + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + return err; + } - scm_dynwind_begin (0); + err = install_locale (locale); + if (err) + { + leave_locale_section (prev_locale); + free_locale_settings (prev_locale); + } + + return err; +} + +/* Throw an exception corresponding to error ERR. */ +static void inline +scm_locale_error (const char *func_name, int err) +{ + SCM s_err; + + s_err = scm_from_int (err); + scm_error (scm_system_error_key, func_name, + "Failed to install locale", + scm_cons (scm_strerror (s_err), SCM_EOL), + scm_cons (s_err, SCM_EOL)); +} + +/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */ +#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \ + do \ + { \ + int lsec_err; \ + scm_t_locale_settings lsec_prev_locale; \ + \ + lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \ + if (lsec_err) \ + scm_locale_error (FUNC_NAME, lsec_err); \ + else \ + { \ + _statement ; \ + \ + leave_locale_section (&lsec_prev_locale); \ + free_locale_settings (&lsec_prev_locale); \ + } \ + } \ + while (0) + +#endif /* !USE_GNU_LOCALE_API */ - c_msgid = scm_to_locale_string (msgid); - scm_dynwind_free (c_msgid); + +/* Locale-dependent string comparison. */ - c_msgid_plural = scm_to_locale_string (msgid_plural); - scm_dynwind_free (c_msgid_plural); +/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return + an integer whose sign is the same as the difference between C_S1 and + C_S2. */ +static inline int +compare_strings (const char *c_s1, const char *c_s2, SCM locale, + const char *func_name) +#define FUNC_NAME func_name +{ + int result; + scm_t_locale c_locale; - c_n = scm_to_ulong (n); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); - if (SCM_UNBNDP (domain)) + if (c_locale) { - /* 3 argument case. */ - c_result = ngettext (c_msgid, c_msgid_plural, c_n); +#ifdef USE_GNU_LOCALE_API + result = strcoll_l (c_s1, c_s2, c_locale); +#else +#ifdef HAVE_STRCOLL + RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2)); +#else + result = strcmp (c_s1, c_s2); +#endif +#endif /* !USE_GNU_LOCALE_API */ } else + +#ifdef HAVE_STRCOLL + result = strcoll (c_s1, c_s2); +#else + result = strcmp (c_s1, c_s2); +#endif + + return result; +} +#undef FUNC_NAME + +/* Store into DST an upper-case version of SRC. */ +static inline void +str_upcase (register char *dst, register const char *src) +{ + for (; *src != '\0'; src++, dst++) + *dst = toupper (*src); + *dst = '\0'; +} + +static inline void +str_downcase (register char *dst, register const char *src) +{ + for (; *src != '\0'; src++, dst++) + *dst = tolower (*src); + *dst = '\0'; +} + +#ifdef USE_GNU_LOCALE_API +static inline void +str_upcase_l (register char *dst, register const char *src, + scm_t_locale locale) +{ + for (; *src != '\0'; src++, dst++) + *dst = toupper_l (*src, locale); + *dst = '\0'; +} + +static inline void +str_downcase_l (register char *dst, register const char *src, + scm_t_locale locale) +{ + for (; *src != '\0'; src++, dst++) + *dst = tolower_l (*src, locale); + *dst = '\0'; +} +#endif + + +/* Compare null-terminated strings C_S1 and C_S2 in a case-independent way + according to LOCALE. Return an integer whose sign is the same as the + difference between C_S1 and C_S2. */ +static inline int +compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale, + const char *func_name) +#define FUNC_NAME func_name +{ + int result; + scm_t_locale c_locale; + char *c_us1, *c_us2; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + c_us1 = (char *) alloca (strlen (c_s1) + 1); + c_us2 = (char *) alloca (strlen (c_s2) + 1); + + if (c_locale) { - char *c_domain; +#ifdef USE_GNU_LOCALE_API + str_upcase_l (c_us1, c_s1, c_locale); + str_upcase_l (c_us2, c_s2, c_locale); - c_domain = scm_to_locale_string (domain); - scm_dynwind_free (c_domain); + result = strcoll_l (c_us1, c_us2, c_locale); +#else + int err; + scm_t_locale_settings prev_locale; - if (SCM_UNBNDP (category)) + err = enter_locale_section (c_locale, &prev_locale); + if (err) { - /* 4 argument case. */ - c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n); + scm_locale_error (func_name, err); + return 0; } - else - { - /* 5 argument case. */ - int c_category; - c_category = scm_i_to_lc_category (category, 0); - c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n, - c_category); - } - } + str_upcase (c_us1, c_s1); + str_upcase (c_us2, c_s2); + +#ifdef HAVE_STRCOLL + result = strcoll (c_us1, c_us2); +#else + result = strcmp (c_us1, c_us2); +#endif /* !HAVE_STRCOLL */ - if (c_result == c_msgid) - result = msgid; - else if (c_result == c_msgid_plural) - result = msgid_plural; + leave_locale_section (&prev_locale); + free_locale_settings (&prev_locale); +#endif /* !USE_GNU_LOCALE_API */ + } else - result = scm_from_locale_string (c_result); - - scm_dynwind_end (); + { + str_upcase (c_us1, c_s1); + str_upcase (c_us2, c_s2); + +#ifdef HAVE_STRCOLL + result = strcoll (c_us1, c_us2); +#else + result = strcmp (c_us1, c_us2); +#endif + } + return result; } #undef FUNC_NAME -SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0, - (SCM domainname), - "If optional parameter @var{domainname} is supplied, " - "set the textdomain. " - "Return the textdomain.") -#define FUNC_NAME s_scm_textdomain + +SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a locale-dependent way." + "If @var{locale} is provided, it should be locale object (as " + "returned by @code{make-locale}) and will be used to perform the " + "comparison; otherwise, the current system locale is used.") +#define FUNC_NAME s_scm_string_locale_lt { - char const *c_result; - char *c_domain; - SCM result = SCM_BOOL_F; + int result; + const char *c_s1, *c_s2; - scm_dynwind_begin (0); + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); - if (SCM_UNBNDP (domainname)) - c_domain = NULL; - else + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result < 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a locale-dependent way." + "If @var{locale} is provided, it should be locale object (as " + "returned by @code{make-locale}) and will be used to perform the " + "comparison; otherwise, the current system locale is used.") +#define FUNC_NAME s_scm_string_locale_gt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a case-insensitive, " + "and locale-dependent way. If @var{locale} is provided, it " + "should be locale object (as returned by @code{make-locale}) " + "and will be used to perform the comparison; otherwise, the " + "current system locale is used.") +#define FUNC_NAME s_scm_string_locale_ci_lt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result < 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a case-insensitive, " + "and locale-dependent way. If @var{locale} is provided, it " + "should be locale object (as returned by @code{make-locale}) " + "and will be used to perform the comparison; otherwise, the " + "current system locale is used.") +#define FUNC_NAME s_scm_string_locale_ci_gt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0, + (SCM s1, SCM s2, SCM locale), + "Compare strings @var{s1} and @var{s2} in a case-insensitive, " + "and locale-dependent way. If @var{locale} is provided, it " + "should be locale object (as returned by @code{make-locale}) " + "and will be used to perform the comparison; otherwise, the " + "current system locale is used.") +#define FUNC_NAME s_scm_string_locale_ci_eq +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result == 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is lower than @var{c2} " + "according to @var{locale} or to the current locale.") +#define FUNC_NAME s_scm_char_locale_lt +{ + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) < 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is greater than @var{c2} " + "according to @var{locale} or to the current locale.") +#define FUNC_NAME s_scm_char_locale_gt +{ + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is lower than @var{c2}, " + "in a case insensitive way according to @var{locale} or to " + "the current locale.") +#define FUNC_NAME s_scm_char_locale_ci_lt +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result < 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is greater than @var{c2}, " + "in a case insensitive way according to @var{locale} or to " + "the current locale.") +#define FUNC_NAME s_scm_char_locale_ci_gt +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is equal to @var{c2}, " + "in a case insensitive way according to @var{locale} or to " + "the current locale.") +#define FUNC_NAME s_scm_char_locale_ci_eq +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result == 0); +} +#undef FUNC_NAME + + + +/* Locale-dependent alphabetic character mapping. */ + +SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0, + (SCM chr, SCM locale), + "Return the lowercase character that corresponds to @var{chr} " + "according to either @var{locale} or the current locale.") +#define FUNC_NAME s_scm_char_locale_downcase +{ + char c_chr; + int c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_CHAR (1, chr); + c_chr = SCM_CHAR (chr); + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) { - c_domain = scm_to_locale_string (domainname); - scm_dynwind_free (c_domain); +#ifdef USE_GNU_LOCALE_API + c_result = tolower_l (c_chr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower (c_chr)); +#endif } + else + c_result = tolower (c_chr); - c_result = textdomain (c_domain); - if (c_result != NULL) - result = scm_from_locale_string (c_result); - else if (!SCM_UNBNDP (domainname)) - SCM_SYSERROR; - - scm_dynwind_end (); - return result; + return (SCM_MAKE_CHAR (c_result)); } #undef FUNC_NAME -SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0, - (SCM domainname, SCM directory), - "If optional parameter @var{directory} is supplied, " - "set message catalogs to directory @var{directory}. " - "Return the directory bound to @var{domainname}.") -#define FUNC_NAME s_scm_bindtextdomain +SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0, + (SCM chr, SCM locale), + "Return the uppercase character that corresponds to @var{chr} " + "according to either @var{locale} or the current locale.") +#define FUNC_NAME s_scm_char_locale_upcase { - char *c_domain; - char *c_directory; - char const *c_result; - SCM result; + char c_chr; + int c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_CHAR (1, chr); + c_chr = SCM_CHAR (chr); - scm_dynwind_begin (0); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); - if (SCM_UNBNDP (directory)) - c_directory = NULL; + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = toupper_l (c_chr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper (c_chr)); +#endif + } else + c_result = toupper (c_chr); + + return (SCM_MAKE_CHAR (c_result)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0, + (SCM str, SCM locale), + "Return a new string that is the uppercase version of " + "@var{str} according to either @var{locale} or the current " + "locale.") +#define FUNC_NAME s_scm_string_locale_upcase +{ + const char *c_str; + char *c_ustr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + c_str = scm_i_string_chars (str); + c_ustr = (char *) alloca (strlen (c_str) + 1); + + if (c_locale) { - c_directory = scm_to_locale_string (directory); - scm_dynwind_free (c_directory); +#ifdef USE_GNU_LOCALE_API + str_upcase_l (c_ustr, c_str, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str)); +#endif } + else + str_upcase (c_ustr, c_str); + + scm_remember_upto_here (str); + + return (scm_from_locale_string (c_ustr)); +} +#undef FUNC_NAME - c_domain = scm_to_locale_string (domainname); - scm_dynwind_free (c_domain); +SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0, + (SCM str, SCM locale), + "Return a new string that is the down-case version of " + "@var{str} according to either @var{locale} or the current " + "locale.") +#define FUNC_NAME s_scm_string_locale_downcase +{ + const char *c_str; + char *c_lstr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); - c_result = bindtextdomain (c_domain, c_directory); + c_str = scm_i_string_chars (str); + c_lstr = (char *) alloca (strlen (c_str) + 1); - if (c_result != NULL) - result = scm_from_locale_string (c_result); - else if (!SCM_UNBNDP (directory)) - SCM_SYSERROR; + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_downcase_l (c_lstr, c_str, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str)); +#endif + } else - result = SCM_BOOL_F; + str_downcase (c_lstr, c_str); - scm_dynwind_end (); - return result; + scm_remember_upto_here (str); + + return (scm_from_locale_string (c_lstr)); } #undef FUNC_NAME -SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0, - (SCM domainname, SCM encoding), - "If optional parameter @var{encoding} is supplied, " - "set encoding for message catalogs of @var{domainname}. " - "Return the encoding of @var{domainname}.") -#define FUNC_NAME s_scm_bind_textdomain_codeset +/* Note: We don't provide mutative versions of `string-locale-(up|down)case' + because, in some languages, a single downcase character maps to a couple + of uppercase characters. Read the SRFI-13 document for a detailed + discussion about this. */ + + + +/* Locale-dependent number parsing. */ + +SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer", + 1, 2, 0, (SCM str, SCM base, SCM locale), + "Convert string @var{str} into an integer according to either " + "@var{locale} (a locale object as returned by @code{make-locale}) " + "or the current process locale. Return two values: an integer " + "(on success) or @code{#f}, and the number of characters read " + "from @var{str} (@code{0} on failure).") +#define FUNC_NAME s_scm_locale_string_to_integer { - char *c_domain; - char *c_encoding; - char const *c_result; SCM result; + long c_result; + int c_base; + const char *c_str; + char *c_endptr; + scm_t_locale c_locale; - scm_dynwind_begin (0); + SCM_VALIDATE_STRING (1, str); + c_str = scm_i_string_chars (str); - if (SCM_UNBNDP (encoding)) - c_encoding = NULL; + if (base != SCM_UNDEFINED) + SCM_VALIDATE_INT_COPY (2, base, c_base); else + c_base = 10; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + if (c_locale != NULL) { - c_encoding = scm_to_locale_string (encoding); - scm_dynwind_free (c_encoding); +#ifdef USE_GNU_LOCALE_API + c_result = strtol_l (c_str, &c_endptr, c_base, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, + c_result = strtol (c_str, &c_endptr, c_base)); +#endif } + else + c_result = strtol (c_str, &c_endptr, c_base); + + scm_remember_upto_here (str); + + if (c_endptr == c_str) + result = SCM_BOOL_F; + else + result = scm_from_long (c_result); + + return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", + 1, 1, 0, (SCM str, SCM locale), + "Convert string @var{str} into an inexact number according to " + "either @var{locale} (a locale object as returned by " + "@code{make-locale}) or the current process locale. Return " + "two values: an inexact number (on success) or @code{#f}, and " + "the number of characters read from @var{str} (@code{0} on " + "failure).") +#define FUNC_NAME s_scm_locale_string_to_inexact +{ + SCM result; + double c_result; + const char *c_str; + char *c_endptr; + scm_t_locale c_locale; - c_domain = scm_to_locale_string (domainname); - scm_dynwind_free (c_domain); + SCM_VALIDATE_STRING (1, str); + c_str = scm_i_string_chars (str); - c_result = bind_textdomain_codeset (c_domain, c_encoding); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); - if (c_result != NULL) - result = scm_from_locale_string (c_result); - else if (!SCM_UNBNDP (encoding)) - SCM_SYSERROR; + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = strtod_l (c_str, &c_endptr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, + c_result = strtod (c_str, &c_endptr)); +#endif + } else + c_result = strtod (c_str, &c_endptr); + + scm_remember_upto_here (str); + + if (c_endptr == c_str) result = SCM_BOOL_F; + else + result = scm_from_double (c_result); - scm_dynwind_end (); - return result; + return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); } #undef FUNC_NAME -void + + +void scm_init_i18n () { - scm_add_feature ("i18n"); + scm_add_feature ("ice-9-i18n"); + +#define _SCM_STRINGIFY_LC(_name) # _name +#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name) + + /* Define all the relevant `_MASK' variables. */ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \ + SCM_I_MAKINUM (LC_ ## _name ## _MASK)); +#include "locale-categories.h" + +#undef SCM_DEFINE_LOCALE_CATEGORY +#undef SCM_STRINGIFY_LC +#undef _SCM_STRINGIFY_LC + + scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK)); + #include "libguile/i18n.x" + +#ifndef USE_GNU_LOCALE_API + scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark); +#endif } diff --git a/libguile/i18n.h b/libguile/i18n.h index 1f0cb0852..7d5d9baa9 100644 --- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -3,7 +3,7 @@ #ifndef SCM_I18N_H #define SCM_I18N_H -/* Copyright (C) 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -22,13 +22,24 @@ #include "libguile/__scm.h" -SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category); -SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category); -SCM_API SCM scm_textdomain (SCM domainname); -SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory); -SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding); - -SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all); +SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale); +SCM_API SCM scm_locale_p (SCM obj); +SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_gt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_lt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_gt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_eq (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_char_locale_lt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_gt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_lt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_gt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_eq (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_upcase (SCM chr, SCM locale); +SCM_API SCM scm_char_locale_downcase (SCM chr, SCM locale); +SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale); +SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale); +SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale); +SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale); SCM_API void scm_init_i18n (void); diff --git a/libguile/init.c b/libguile/init.c index 46919f0fe..664aee63a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -46,7 +46,9 @@ #include "libguile/deprecation.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" +#if 0 #include "libguile/environments.h" +#endif #include "libguile/eq.h" #include "libguile/error.h" #include "libguile/eval.h" @@ -63,7 +65,7 @@ #include "libguile/hash.h" #include "libguile/hashtab.h" #include "libguile/hooks.h" -#include "libguile/i18n.h" +#include "libguile/gettext.h" #include "libguile/iselect.h" #include "libguile/ioext.h" #include "libguile/keywords.h" @@ -436,7 +438,9 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_struct_prehistory (); /* requires storage */ scm_symbols_prehistory (); /* requires storage */ scm_init_subr_table (); +#if 0 scm_environments_prehistory (); /* requires storage */ +#endif scm_modules_prehistory (); /* requires storage and hash tables */ scm_init_variable (); /* all bindings need variables */ scm_init_continuations (); @@ -445,7 +449,9 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_gsubr (); scm_init_thread_procs (); /* requires gsubrs */ scm_init_procprop (); +#if 0 scm_init_environments (); +#endif scm_init_alist (); scm_init_arbiters (); scm_init_async (); @@ -475,7 +481,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_properties (); scm_init_hooks (); /* Requires smob_prehistory */ scm_init_gc (); /* Requires hooks, async */ - scm_init_i18n (); + scm_init_gettext (); scm_init_ioext (); scm_init_keywords (); scm_init_list (); diff --git a/libguile/libgettext.h b/libguile/libgettext.h new file mode 100644 index 000000000..f54b6bff7 --- /dev/null +++ b/libguile/libgettext.h @@ -0,0 +1,69 @@ +/* Convenience header for conditional use of GNU <libintl.h>. + Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU Library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, + USA. */ + +#ifndef _LIBGETTEXT_H +#define _LIBGETTEXT_H 1 + +/* NLS can be disabled through the configure --disable-nls option. */ +#if ENABLE_NLS + +/* Get declarations of GNU message catalog functions. */ +# include <libintl.h> + +#else + +/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which + chokes if dcgettext is defined as a macro. So include it now, to make + later inclusions of <locale.h> a NOP. We don't include <libintl.h> + as well because people using "gettext.h" will not include <libintl.h>, + and also including <libintl.h> would fail on SunOS 4, whereas <locale.h> + is OK. */ +#if defined(__sun) +# include <locale.h> +#endif + +/* Disabled NLS. + The casts to 'const char *' serve the purpose of producing warnings + for invalid uses of the value returned from these functions. + On pre-ANSI systems without 'const', the config.h file is supposed to + contain "#define const". */ +# define gettext(Msgid) ((const char *) (Msgid)) +# define dgettext(Domainname, Msgid) ((const char *) (Msgid)) +# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid)) +# define ngettext(Msgid1, Msgid2, N) \ + ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) +# define dngettext(Domainname, Msgid1, Msgid2, N) \ + ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) +# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \ + ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2)) +# define textdomain(Domainname) ((const char *) (Domainname)) +# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname)) +# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset)) + +#endif + +/* A pseudo function call that serves as a marker for the automated + extraction of messages, but does not call gettext(). The run-time + translation is done at a different place in the code. + The argument, String, should be a literal string. Concatenated strings + and other string expressions won't work. + The macro's expansion is not parenthesized, so that it is suitable as + initializer for static 'char[]' or 'const char[]' variables. */ +#define gettext_noop(String) String + +#endif /* _LIBGETTEXT_H */ diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h new file mode 100644 index 000000000..cec91fb91 --- /dev/null +++ b/libguile/locale-categories.h @@ -0,0 +1,47 @@ +/* Copyright (C) 2006 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 + */ + +/* A list of all available locale categories, not including `ALL'. */ + + +/* The six standard categories, as defined in IEEE Std 1003.1-2001. */ +SCM_DEFINE_LOCALE_CATEGORY (COLLATE) +SCM_DEFINE_LOCALE_CATEGORY (CTYPE) +SCM_DEFINE_LOCALE_CATEGORY (MESSAGES) +SCM_DEFINE_LOCALE_CATEGORY (MONETARY) +SCM_DEFINE_LOCALE_CATEGORY (NUMERIC) +SCM_DEFINE_LOCALE_CATEGORY (TIME) + +/* Additional non-standard categories. */ +#ifdef LC_PAPER +SCM_DEFINE_LOCALE_CATEGORY (PAPER) +#endif +#ifdef LC_NAME +SCM_DEFINE_LOCALE_CATEGORY (NAME) +#endif +#ifdef LC_ADDRESS +SCM_DEFINE_LOCALE_CATEGORY (ADDRESS) +#endif +#ifdef LC_TELEPHONE +SCM_DEFINE_LOCALE_CATEGORY (TELEPHONE) +#endif +#ifdef LC_MEASUREMENT +SCM_DEFINE_LOCALE_CATEGORY (MEASUREMENT) +#endif +#ifdef LC_IDENTIFICATION +SCM_DEFINE_LOCALE_CATEGORY (IDENTIFICATION) +#endif diff --git a/libguile/modules.c b/libguile/modules.c index 40936cb44..b1f312a92 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -273,8 +273,9 @@ SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0, /* * C level implementation of the standard eval closure * - * This increases loading speed substantially. - * The code will be replaced by the low-level environments in next release. + * This increases loading speed substantially. The code may be + * replaced by something based on environments.[ch], in a future + * release. */ static SCM module_make_local_var_x_var; diff --git a/libguile/numbers.c b/libguile/numbers.c index 1a662b015..3be5314e0 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -40,7 +40,7 @@ */ -/* tell glibc (2.3) to give prototype for C99 trunc() */ +/* tell glibc (2.3) to give prototype for C99 trunc(), csqrt(), etc */ #define _GNU_SOURCE #if HAVE_CONFIG_H @@ -51,6 +51,10 @@ #include <ctype.h> #include <string.h> +#if HAVE_COMPLEX_H +#include <complex.h> +#endif + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -66,6 +70,14 @@ #include "libguile/discouraged.h" +/* values per glibc, if not already defined */ +#ifndef M_LOG10E +#define M_LOG10E 0.43429448190325182765 +#endif +#ifndef M_PI +#define M_PI 3.14159265358979323846 +#endif + /* @@ -150,6 +162,21 @@ xisnan (double x) #endif } + +/* For an SCM object Z which is a complex number (ie. satisfies + SCM_COMPLEXP), return its value as a C level "complex double". */ +#define SCM_COMPLEX_VALUE(z) \ + (SCM_COMPLEX_REAL (z) + _Complex_I * SCM_COMPLEX_IMAG (z)) + +/* Convert a C "complex double" to an SCM value. */ +#if HAVE_COMPLEX_DOUBLE +static SCM +scm_from_complex_double (complex double z) +{ + return scm_c_make_rectangular (creal (z), cimag (z)); +} +#endif /* HAVE_COMPLEX_DOUBLE */ + static mpz_t z_negative_one; @@ -5978,6 +6005,142 @@ scm_is_number (SCM z) return scm_is_true (scm_number_p (z)); } + +/* 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 + clog() for instance. This is in case clog() doesn't optimize for a + real-only case, and because we have to test SCM_COMPLEXP anyway so may as + well use it to go straight to the applicable C func. */ + +SCM_DEFINE (scm_log, "log", 1, 0, 0, + (SCM z), + "Return the natural logarithm of @var{z}.") +#define FUNC_NAME s_scm_log +{ + if (SCM_COMPLEXP (z)) + { +#if HAVE_COMPLEX_DOUBLE + return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z))); +#else + double re = SCM_COMPLEX_REAL (z); + double im = SCM_COMPLEX_IMAG (z); + return scm_c_make_rectangular (log (hypot (re, im)), + atan2 (im, re)); +#endif + } + else + { + /* ENHANCE-ME: When z is a bignum the logarithm will fit a double + although the value itself overflows. */ + double re = scm_to_double (z); + double l = log (fabs (re)); + if (re >= 0.0) + return scm_from_double (l); + else + return scm_c_make_rectangular (l, M_PI); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_log10, "log10", 1, 0, 0, + (SCM z), + "Return the base 10 logarithm of @var{z}.") +#define FUNC_NAME s_scm_log10 +{ + if (SCM_COMPLEXP (z)) + { + /* Mingw has clog() but not clog10(). (Maybe it'd be worth using + clog() and a multiply by M_LOG10E, rather than the fallback + log10+hypot+atan2.) */ +#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG10 + return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z))); +#else + double re = SCM_COMPLEX_REAL (z); + double im = SCM_COMPLEX_IMAG (z); + return scm_c_make_rectangular (log10 (hypot (re, im)), + M_LOG10E * atan2 (im, re)); +#endif + } + else + { + /* ENHANCE-ME: When z is a bignum the logarithm will fit a double + although the value itself overflows. */ + double re = scm_to_double (z); + double l = log10 (fabs (re)); + if (re >= 0.0) + return scm_from_double (l); + else + return scm_c_make_rectangular (l, M_LOG10E * M_PI); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_exp, "exp", 1, 0, 0, + (SCM z), + "Return @math{e} to the power of @var{z}, where @math{e} is the\n" + "base of natural logarithms (2.71828@dots{}).") +#define FUNC_NAME s_scm_exp +{ + if (SCM_COMPLEXP (z)) + { +#if HAVE_COMPLEX_DOUBLE + return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z))); +#else + return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)), + SCM_COMPLEX_IMAG (z)); +#endif + } + else + { + /* When z is a negative bignum the conversion to double overflows, + giving -infinity, but that's ok, the exp is still 0.0. */ + return scm_from_double (exp (scm_to_double (z))); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_sqrt, "sqrt", 1, 0, 0, + (SCM x), + "Return the square root of @var{z}. Of the two possible roots\n" + "(positive and negative), the one with the a positive real part\n" + "is returned, or if that's zero then a positive imaginary part.\n" + "Thus,\n" + "\n" + "@example\n" + "(sqrt 9.0) @result{} 3.0\n" + "(sqrt -9.0) @result{} 0.0+3.0i\n" + "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n" + "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n" + "@end example") +#define FUNC_NAME s_scm_sqrt +{ + if (SCM_COMPLEXP (x)) + { +#if HAVE_COMPLEX_DOUBLE && HAVE_USABLE_CSQRT + return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (x))); +#else + double re = SCM_COMPLEX_REAL (x); + double im = SCM_COMPLEX_IMAG (x); + return scm_c_make_polar (sqrt (hypot (re, im)), + 0.5 * atan2 (im, re)); +#endif + } + else + { + double xx = scm_to_double (x); + if (xx < 0) + return scm_c_make_rectangular (0.0, sqrt (-xx)); + else + return scm_from_double (sqrt (xx)); + } +} +#undef FUNC_NAME + + + void scm_init_numbers () { diff --git a/libguile/numbers.h b/libguile/numbers.h index 40b836959..8448b7fd2 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -263,6 +263,10 @@ SCM_API SCM scm_angle (SCM z); SCM_API SCM scm_exact_to_inexact (SCM z); SCM_API SCM scm_inexact_to_exact (SCM z); SCM_API SCM scm_trunc (SCM x); +SCM_API SCM scm_log (SCM z); +SCM_API SCM scm_log10 (SCM z); +SCM_API SCM scm_exp (SCM z); +SCM_API SCM scm_sqrt (SCM z); /* bignum internal functions */ SCM_API SCM scm_i_mkbig (void); diff --git a/libguile/ports.c b/libguile/ports.c index bcf4a89f1..3fcc0efaa 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -27,12 +27,14 @@ #include <stdio.h> #include <errno.h> +#include <fcntl.h> /* for chsize on mingw */ #include <assert.h> #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/eval.h" +#include "libguile/fports.h" /* direct access for seek and truncate */ #include "libguile/objects.h" #include "libguile/goops.h" #include "libguile/smob.h" @@ -64,9 +66,17 @@ #include <sys/ioctl.h> #endif -#ifdef __MINGW32__ -#include <fcntl.h> +/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize + already, but have this code here in case that wasn't so in past versions, + or perhaps to help other minimal DOS environments. + + gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which + might be possibilities if we've got other systems without ftruncate. */ + +#if HAVE_CHSIZE && ! HAVE_FTRUNCATE #define ftruncate(fd, size) chsize (fd, size) +#undef HAVE_FTRUNCATE +#define HAVE_FTRUNCATE 1 #endif @@ -1456,7 +1466,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); - if (SCM_OPPORTP (fd_port)) + if (SCM_OPFPORTP (fd_port)) + { + /* go direct to fport code to allow 64-bit offsets */ + return scm_i_fport_seek (fd_port, offset, how); + } + else if (SCM_OPPORTP (fd_port)) { scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); off_t off = scm_to_off_t (offset); @@ -1481,28 +1496,48 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, } #undef FUNC_NAME -#ifdef __MINGW32__ -/* Define this function since it is not supported under Windows. */ -static int truncate (char *file, int length) +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +/* Mingw has ftruncate(), perhaps implemented above using chsize, but + doesn't have the filename version truncate(), hence this code. */ +#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE +static int +truncate (const char *file, off_t length) { - int ret = -1, fdes; - if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1) + int ret, fdes; + + fdes = open (file, O_BINARY | O_WRONLY); + if (fdes == -1) + return -1; + + ret = ftruncate (fdes, length); + if (ret == -1) { - ret = chsize (fdes, length); + int save_errno = errno; close (fdes); + errno = save_errno; + return -1; } - return ret; + + return close (fdes); } -#endif /* __MINGW32__ */ +#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, (SCM object, SCM length), - "Truncates the object referred to by @var{object} to at most\n" - "@var{length} bytes. @var{object} can be a string containing a\n" - "file name or an integer file descriptor or a port.\n" - "@var{length} may be omitted if @var{object} is not a file name,\n" - "in which case the truncation occurs at the current port\n" - "position. The return value is unspecified.") + "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n" + "filename string, a port object, or an integer file descriptor.\n" + "The return value is unspecified.\n" + "\n" + "For a port or file descriptor @var{length} can be omitted, in\n" + "which case the file is truncated at the current position (per\n" + "@code{ftell} above).\n" + "\n" + "On most systems a file can be extended by giving a length\n" + "greater than the current size, but this is not mandatory in the\n" + "POSIX standard.") #define FUNC_NAME s_scm_truncate_file { int rv; @@ -1529,6 +1564,11 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object), c_length)); } + else if (SCM_OPOUTFPORTP (object)) + { + /* go direct to fport code to allow 64-bit offsets */ + rv = scm_i_fport_truncate (object, length); + } else if (SCM_OPOUTPORTP (object)) { off_t c_length = scm_to_off_t (length); diff --git a/libguile/posix.c b/libguile/posix.c index 136d77084..8129c6413 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -40,7 +40,7 @@ #include "libguile/validate.h" #include "libguile/posix.h" -#include "libguile/i18n.h" +#include "libguile/gettext.h" #include "libguile/threads.h" @@ -115,6 +115,10 @@ extern char ** environ; #include <locale.h> #endif +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API +#endif + #if HAVE_CRYPT_H # include <crypt.h> #endif @@ -157,6 +161,12 @@ extern char ** environ; #define F_OK 0 #endif +/* No prototype for this on Solaris 10. The man page says it's in + <unistd.h> ... but it lies. */ +#if ! HAVE_DECL_SETHOSTNAME +int sethostname (char *name, size_t namelen); +#endif + /* On NextStep, <utime.h> doesn't define struct utime, unless we #define _POSIX_SOURCE before #including it. I think this is less of a kludge than defining struct utimbuf ourselves. */ @@ -943,7 +953,12 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1, scm_dynwind_unwind_handler (free_string_pointers, exec_argv, SCM_F_WIND_EXPLICITLY); - execv (exec_file, exec_argv); + execv (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); SCM_SYSERROR; /* not reached. */ @@ -974,7 +989,12 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, scm_dynwind_unwind_handler (free_string_pointers, exec_argv, SCM_F_WIND_EXPLICITLY); - execvp (exec_file, exec_argv); + execvp (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); SCM_SYSERROR; /* not reached. */ @@ -1013,7 +1033,17 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, scm_dynwind_unwind_handler (free_string_pointers, exec_env, SCM_F_WIND_EXPLICITLY); - execve (exec_file, exec_argv, exec_env); + execve (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_env); SCM_SYSERROR; /* not reached. */ @@ -1354,7 +1384,15 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, } #undef FUNC_NAME +#ifndef USE_GNU_LOCALE_API +/* This mutex is used to serialize invocations of `setlocale ()' on non-GNU + systems (i.e., systems where a reentrant locale API is not available). + See `i18n.c' for details. */ +scm_i_pthread_mutex_t scm_i_locale_mutex; +#endif + #ifdef HAVE_SETLOCALE + SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, (SCM category, SCM locale), "If @var{locale} is omitted, return the current value of the\n" @@ -1383,7 +1421,14 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, scm_dynwind_free (clocale); } +#ifndef USE_GNU_LOCALE_API + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); +#endif rv = setlocale (scm_i_to_lc_category (category, 1), clocale); +#ifndef USE_GNU_LOCALE_API + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); +#endif + if (rv == NULL) { /* POSIX and C99 don't say anything about setlocale setting errno, so @@ -1917,9 +1962,13 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, #endif /* HAVE_GETHOSTNAME */ -void +void scm_init_posix () { +#ifndef USE_GNU_LOCALE_API + scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL); +#endif + scm_add_feature ("posix"); #ifdef HAVE_GETEUID scm_add_feature ("EIDs"); diff --git a/libguile/posix.h b/libguile/posix.h index 3bef9f96d..871bba850 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -23,8 +23,7 @@ #include "libguile/__scm.h" - - +#include "libguile/threads.h" @@ -87,6 +86,8 @@ SCM_API SCM scm_sethostname (SCM name); SCM_API SCM scm_gethostname (void); SCM_API void scm_init_posix (void); +SCM_API scm_i_pthread_mutex_t scm_i_locale_mutex; + #endif /* SCM_POSIX_H */ /* diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 64b56e197..5f652252a 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -69,8 +69,12 @@ extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1]; /* Onces */ #define scm_i_pthread_once_t pthread_once_t -#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT #define scm_i_pthread_once pthread_once +#if SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT +#define SCM_I_PTHREAD_ONCE_INIT { PTHREAD_ONCE_INIT } +#else +#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT +#endif /* Thread specific storage */ diff --git a/libguile/script.c b/libguile/script.c index 33fcbc130..e3425e108 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -381,7 +381,9 @@ scm_shell_usage (int fatal, char *message) " -v, --version display version information and exit\n" " \\ read arguments from following script lines\n" "\n" - "Please report bugs to bug-guile@gnu.org\n", + "Please report bugs to bug-guile@gnu.org. (Note that you must\n" + "be subscribed to this list first, in order to successfully send\n" + "a report to it).\n", scm_usage_name); if (fatal) diff --git a/libguile/socket.c b/libguile/socket.c index a9b7ed8ca..5d09c615b 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -98,9 +98,7 @@ SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0, "and returned as a new integer.") #define FUNC_NAME s_scm_htonl { - scm_t_uint32 c_in = SCM_NUM2ULONG (1, value); - - return scm_from_ulong (htonl (c_in)); + return scm_from_ulong (htonl (scm_to_uint32 (value))); } #undef FUNC_NAME @@ -111,9 +109,7 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0, "and returned as a new integer.") #define FUNC_NAME s_scm_ntohl { - scm_t_uint32 c_in = SCM_NUM2ULONG (1, value); - - return scm_from_ulong (ntohl (c_in)); + return scm_from_ulong (ntohl (scm_to_uint32 (value))); } #undef FUNC_NAME @@ -1459,25 +1455,34 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, (SCM sock, SCM str, SCM flags, SCM start, SCM end), - "Return data from the socket port @var{sock} and also\n" - "information about where the data was received from.\n" - "@var{sock} must already be bound to the address from which\n" - "data is to be received. @code{str}, is a string into which the\n" - "data will be written. The size of @var{str} limits the amount\n" - "of data which can be received: in the case of packet protocols,\n" - "if a packet larger than this limit is encountered then some\n" - "data will be irrevocably lost.\n\n" - "The optional @var{flags} argument is a value or bitwise OR of\n" - "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n" - "The value returned is a pair: the @emph{car} is the number of\n" - "bytes read from the socket and the @emph{cdr} an address object\n" - "in the same form as returned by @code{accept}. The address\n" - "will given as @code{#f} if not available, as is usually the\n" - "case for stream sockets.\n\n" - "The @var{start} and @var{end} arguments specify a substring of\n" - "@var{str} to which the data should be written.\n\n" - "Note that the data is read directly from the socket file\n" - "descriptor: any unread buffered port data is ignored.") + "Receive data from socket port @var{sock} (which must be already\n" + "bound), returning the originating address as well as the data.\n" + "This is usually for use on datagram sockets, but can be used on\n" + "stream-oriented sockets too.\n" + "\n" + "The data received is stored in the given @var{str}, using\n" + "either the whole string or just the region between the optional\n" + "@var{start} and @var{end} positions. The size of @var{str}\n" + "limits the amount of data which can be received. For datagram\n" + "protocols, if a packet larger than this is received then excess\n" + "bytes are irrevocably lost.\n" + "\n" + "The return value is a pair. The @code{car} is the number of\n" + "bytes read. The @code{cdr} is a socket address object which is\n" + "where the data come from, or @code{#f} if the origin is\n" + "unknown.\n" + "\n" + "The optional @var{flags} argument is a or bitwise OR\n" + "(@code{logior}) of @code{MSG_OOB}, @code{MSG_PEEK},\n" + "@code{MSG_DONTROUTE} etc.\n" + "\n" + "Data is read directly from the socket file descriptor, any\n" + "buffered port data is ignored.\n" + "\n" + "On a GNU/Linux system @code{recvfrom!} is not multi-threading,\n" + "all threads stop while a @code{recvfrom!} call is in progress.\n" + "An application may need to use @code{select}, @code{O_NONBLOCK}\n" + "or @code{MSG_DONTWAIT} to avoid this.") #define FUNC_NAME s_scm_recvfrom { int rv; @@ -1728,6 +1733,9 @@ scm_init_socket () #endif /* recv/send options. */ +#ifdef MSG_DONTWAIT + scm_c_define ("MSG_DONTWAIT", scm_from_int (MSG_DONTWAIT)); +#endif #ifdef MSG_OOB scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB)); #endif diff --git a/libguile/stime.c b/libguile/stime.c index 37d2290cf..418e80f21 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -497,8 +497,10 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6)); lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7)); lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8)); +#if HAVE_STRUCT_TM_TM_GMTOFF + lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9)); +#endif #ifdef HAVE_TM_ZONE - lt->tm_gmtoff = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9)); if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10))) lt->tm_zone = NULL; else @@ -731,6 +733,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, { struct tm t; const char *fmt, *str, *rest; + long zoff; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); @@ -748,6 +751,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, tm_init (tm_year); tm_init (tm_wday); tm_init (tm_yday); +#if HAVE_STRUCT_TM_TM_GMTOFF + tm_init (tm_gmtoff); +#endif #undef tm_init /* GNU glibc strptime() "%s" is affected by the current timezone, since it @@ -766,7 +772,15 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, SCM_SYSERROR; } - return scm_cons (filltime (&t, 0, NULL), + /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when + available */ +#if HAVE_STRUCT_TM_TM_GMTOFF + zoff = - t.tm_gmtoff; /* seconds west, not east */ +#else + zoff = 0; +#endif + + return scm_cons (filltime (&t, zoff, NULL), scm_from_signed_integer (rest - str)); } #undef FUNC_NAME diff --git a/libguile/threads.c b/libguile/threads.c index 5f5218019..d15046bd2 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -28,6 +28,11 @@ #endif #include <stdio.h> #include <assert.h> + +#ifdef HAVE_STRING_H +#include <string.h> /* for memset used by FD_ZERO on Solaris 10 */ +#endif + #if HAVE_SYS_TIME_H #include <sys/time.h> #endif @@ -558,7 +563,8 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) } #if SCM_USE_PTHREAD_THREADS -#ifdef HAVE_PTHREAD_ATTR_GETSTACK +/* pthread_getattr_np not available on MacOS X and Solaris 10. */ +#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP #define HAVE_GET_THREAD_STACK_BASE @@ -592,7 +598,7 @@ get_thread_stack_base () } } -#endif /* HAVE_PTHREAD_ATTR_GETSTACK */ +#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */ #else /* !SCM_USE_PTHREAD_THREADS */ @@ -1276,8 +1282,8 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ / sizeof (SCM_STACKITEM))); \ - bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \ - top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \ + bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \ + top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ scm_mark_locations (bot, top - bot); } while (0) #else # define SCM_MARK_BACKING_STORE() diff --git a/libguile/unif.c b/libguile/unif.c index 8594ba3da..d3bf82314 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1150,10 +1150,10 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) { - size_t k = SCM_I_ARRAY_NDIM (v); + size_t k, ndim = SCM_I_ARRAY_NDIM (v); scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); - while (k > 0) + for (k = 0; k < ndim; k++) { long ind; @@ -1161,9 +1161,8 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, SCM_WRONG_NUM_ARGS (); ind = scm_to_long (SCM_CAR (args)); args = SCM_CDR (args); - k -= 1; - if (ind < s->lbnd || ind > s->ubnd) + if (ind < s[k].lbnd || ind > s[k].ubnd) { res = SCM_BOOL_F; /* We do not stop the checking after finding a violation @@ -2661,7 +2660,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) } if (got_it) - *resp = res; + *resp = sign * res; return c; } @@ -2745,6 +2744,11 @@ scm_i_read_array (SCM port, int c) { c = scm_getc (port); c = read_decimal_integer (port, c, &len); + if (len < 0) + scm_i_input_error (NULL, port, + "array length must be non-negative", + SCM_EOL); + s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); } diff --git a/libguile/vectors.c b/libguile/vectors.c index 4bc5ce611..c3107ecf1 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -476,15 +476,15 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, SCM res = SCM_EOL; const SCM *data; scm_t_array_handle handle; - size_t i, len; + size_t i, count, len; ssize_t inc; data = scm_vector_elements (v, &handle, &len, &inc); - for (i = len*inc; i > 0;) - { - i -= inc; - res = scm_cons (data[i], res); - } + for (i = (len - 1) * inc, count = 0; + count < len; + i -= inc, count++) + res = scm_cons (data[i], res); + scm_array_handle_release (&handle); return res; } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1a5c26a56..cd2141c0d 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,4 +1,61 @@ -2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr> + + * tests/unif.test (syntax): New test prefix. Check syntax for + negative lower bounds and negative lengths (reported by Gyula + Szavai) as well as `array-in-bounds?'. + +2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr> + + * test-suite/tests/vectors.test: Use `define-module'. + (vector->list): New test prefix. "Shared array" test contributed + by Szavai Gyula. + +2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr> + + * Makefile.am (SCM_TESTS): Added `tests/i18n.test'. + + * tests/i18n.test: New file. + +2006-11-17 Neil Jerram <neil@ossau.uklinux.net> + + * README: Note need for subscription to bug-guile@gnu.org. + +2006-11-02 Neil Jerram <neil@ossau.uklinux.net> + + * tests/environments.test: Comment out all tests in this file. + +2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr> + + * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a + typo: `thrown' instead of `throw'. + +2006-10-05 Kevin Ryde <user42@zip.com.au> + + * tests/ftw.test: New file. + * Makefile.am (SCM_TESTS): Add it. + +2006-10-03 Kevin Ryde <user42@zip.com.au> + + * tests/eval.test (apply): New tests, exercising scm_tc7_subr_2o which + had lacked some arg count checking. + +2006-09-26 Kevin Ryde <user42@zip.com.au> + + * tests/ports.test (seek): New tests. + (truncate-file): More tests. + +2006-09-23 Kevin Ryde <user42@zip.com.au> + + * tests/numbers.test (exp, log, log10, sqrt): New tests. + + * tests/format.test, tests/srfi-1.test: Use define-module to prevent + redefined funcs in those modules extending on to subsequent tests. + + * tests/time.test (gmtime, strptime): Remove the "unresolved" throws, + the error+thread tests seem ok now (previously were upset by something + leaking out of syntax.test). + +2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr> * tests/srfi-14.test: Use `define-module'. Use modules `(srfi srfi-1)' and `(test-suite lib)'. @@ -7,7 +64,43 @@ (every?, find-latin1-locale): New procedures. (%latin1): New variable. -2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-09-08 Kevin Ryde <user42@zip.com.au> + + * tests/format.test (~f): Test leading zeros bugfix. + +2006-08-25 Kevin Ryde <user42@zip.com.au> + + * tests/popen.test (open-input-pipe, open-output-pipe): In the "no + duplicate" tests, close parent side of signalling pipe, to hopefully + generate an error instead of a hang if something bad in the child + means it doesn't write anything. + +2006-08-22 Kevin Ryde <user42@zip.com.au> + + * tests/srfi-9.test: More tests, in particular check for exceptions on + wrong record types passed to accessor and modifier funcs. + +2006-07-25 Kevin Ryde <user42@zip.com.au> + + * standalone/test-conversion.c, standalone/test-gh.c, + standalone/test-list.c, standalone/test-num2integral.c, + standalone/test-round.c: Use scm_boot_guile rather than + scm_init_guile, for the benefit of those systems where we can't + implement the latter. Reported by Claes Wallin. + + * standalone/test-require-extension: Use "&& exit 1" instead of "!" to + invert the sense of exit statuses, as the latter doesn't work on + Solaris 10. Reported by Claes Wallin. + +2006-07-24 Kevin Ryde <user42@zip.com.au> + + * tests/socket.test (htonl, ntohl): New tests. + +2006-07-06 Kevin Ryde <user42@zip.com.au> + + * tests/time.test (localtime, mktime, strptime): More tests. + +2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr> * Makefile.am (SCM_TESTS): Added `tests/structs.test'. * tests/structs.test: New file. @@ -70,7 +163,7 @@ * tests/unif.test (make-shared-array): Add example usages from the manual, two of which currently fail. -2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr> +2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr> * test-suite/tests/modules.test: New file. * test-suite/Makefile.am (SCM_TESTS): Added it. @@ -118,7 +211,7 @@ * tests/srfi-1.test (lset-difference!): More tests. -2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr> * tests/socket.test (make-socket-address): New tests. (connect, bind, sendto): Exercise sockaddr object. @@ -649,7 +742,7 @@ * lib.scm (exception:numerical-overflow): New define. * tests/numbers.test (modulo-expt): Use it and exception:wrong-type-arg, avoiding empty "" regexp which is invalid on - BSD. Reported by Andreas Vögele. + BSD. Reported by Andreas Vögele. 2004-05-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> @@ -674,12 +767,12 @@ * tests/srfi-19.test (test-dst, string->date local DST): Test with "EST5EDT" instead of "CET", since HP-UX doesn't know CET. Reported by - Andreas Vögele. + Andreas Vögele. 2004-05-03 Kevin Ryde <user42@zip.com.au> * tests/time.test (strftime): Force tm:isdst to 0 for the test, for - the benefit of HP-UX. Reported by Andreas Vögele. + the benefit of HP-UX. Reported by Andreas Vögele. Use set-tm:zone rather than a hard coded vector offset. 2004-04-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> @@ -1620,7 +1713,7 @@ 2001-06-16 Marius Vollmer <mvo@zagadka.ping.de> - Thanks to Matthias Köppe! + Thanks to Matthias Köppe! * tests/ports.test: New test for output port line counts. * tests/format.test, tests/optargs.test, tests/srfi-19.test: New @@ -2214,3 +2307,7 @@ Fri Dec 17 12:14:10 1999 Greg J. Badros <gjb@cs.washington.edu> * lib.scm, guile-test, paths.scm: Log begins. + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 4bacf6142..be5e0a9af 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -35,12 +35,14 @@ SCM_TESTS = tests/alist.test \ tests/filesys.test \ tests/format.test \ tests/fractions.test \ + tests/ftw.test \ tests/gc.test \ tests/getopt-long.test \ tests/goops.test \ tests/guardians.test \ tests/hash.test \ tests/hooks.test \ + tests/i18n.test \ tests/import.test \ tests/interp.test \ tests/list.test \ diff --git a/test-suite/README b/test-suite/README index 116869e17..35c0fc3c8 100644 --- a/test-suite/README +++ b/test-suite/README @@ -13,9 +13,11 @@ You can reference the file `lib.scm' from your own code as the module function explaining what's going on. Please write more Guile tests, and send them to bug-guile@gnu.org. -We'll merge them into the distribution. All test suites must be -licensed for our use under the GPL, but I don't think I'm going to -collect assignment papers for them. +(Note that you must be subscribed to this list first, in order to +successfully send a report to it.) We'll merge them into the +distribution. All test suites must be licensed for our use under the +GPL, but I don't think I'm going to collect assignment papers for +them. diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 9f1a7b60f..2ddbf75a6 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -1010,10 +1010,9 @@ test_locale_strings () test_11 ("(string #\\f #\\nul)", NULL, 1, 0); } -int -main (int argc, char *argv[]) +static void +tests (void *data, int argc, char **argv) { - scm_init_guile(); test_is_signed_integer (); test_is_unsigned_integer (); test_to_signed_integer (); @@ -1024,5 +1023,11 @@ main (int argc, char *argv[]) test_from_double (); test_to_double (); test_locale_strings (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-gh.c b/test-suite/standalone/test-gh.c index 7e030f4d3..78cf87fa5 100644 --- a/test-suite/standalone/test-gh.c +++ b/test-suite/standalone/test-gh.c @@ -67,11 +67,16 @@ test_gh_set_substr () assert (string_equal (string, "Frdarnitrnit!")); } -int -main (int argc, char *argv[]) +static void +tests (void *data, int argc, char **argv) { - scm_init_guile (); test_gh_set_substr (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-list.c b/test-suite/standalone/test-list.c index de2645fb9..7a9514ae9 100644 --- a/test-suite/standalone/test-list.c +++ b/test-suite/standalone/test-list.c @@ -46,10 +46,15 @@ test_scm_list (void) } } -int -main (int argc, char **argv) +static void +tests (void *data, int argc, char **argv) { - scm_init_guile(); test_scm_list (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index 947890a48..86c3e5db7 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -141,12 +141,17 @@ test_ulong_long () #endif /* SCM_SIZEOF_LONG_LONG != 0 */ } -int -main (int argc, char *argv[]) +static void +tests (void *data, int argc, char **argv) { - scm_init_guile(); test_long_long (); test_ulong_long (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/standalone/test-require-extension b/test-suite/standalone/test-require-extension index c953a30af..730137b55 100755 --- a/test-suite/standalone/test-require-extension +++ b/test-suite/standalone/test-require-extension @@ -2,10 +2,16 @@ set -e -! guile -c '(require-extension 7)' 2> /dev/null -! guile -c '(require-extension (blarg))' 2> /dev/null -! guile -c '(require-extension (srfi "foo"))' 2> /dev/null +# expect these to throw errors, if they succeed it's wrong +# +# (Note the syntax "! guile -c ..." isn't used here, because that doesn't +# work on Solaris 10.) +# +guile -c '(require-extension 7)' 2>/dev/null && exit 1 +guile -c '(require-extension (blarg))' 2>/dev/null && exit 1 +guile -c '(require-extension (srfi "foo"))' 2>/dev/null && exit 1 +# expect these to succeed guile -c '(require-extension (srfi 1)) (exit (procedure? take-right))' guile -c '(require-extension (srfi))' diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index c594d5812..a3928d26b 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -113,10 +113,15 @@ test_scm_c_round () } } +static void +tests (void *data, int argc, char **argv) +{ + test_scm_c_round (); +} + int main (int argc, char *argv[]) { - scm_init_guile(); - test_scm_c_round (); + scm_boot_guile (argc, argv, tests, NULL); return 0; } diff --git a/test-suite/tests/environments.nottest b/test-suite/tests/environments.nottest index a426eecd3..46883849a 100644 --- a/test-suite/tests/environments.nottest +++ b/test-suite/tests/environments.nottest @@ -18,9 +18,9 @@ (use-modules (ice-9 documentation) (test-suite lib)) -;;; FIXME: Test disabled! -;;; The `environments' code (which is currently unused) relies on weak alist -;;; vectors. However, these are currently implemented as weak hash tables. +;;; environments are currently commented out of libguile, so these +;;; tests must be commented out also. - NJ 2006-11-02. +(if #f (let () ;;; ;;; miscellaneous @@ -1047,3 +1047,5 @@ (pass-if "documented?" (documented? make-import-environment)))) +;;; End of commenting out. - NJ 2006-11-02. +)) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 6bca6235c..4adf0312f 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -99,10 +99,10 @@ )) ;;; -;;; apply +;;; call ;;; -(with-test-prefix "application" +(with-test-prefix "call" (with-test-prefix "wrong number of arguments" @@ -143,6 +143,30 @@ ((lambda (x y . rest) #f) 1)))) ;;; +;;; apply +;;; + +(with-test-prefix "apply" + + (with-test-prefix "scm_tc7_subr_2o" + + ;; prior to guile 1.6.9 and 1.8.1 this called the function with + ;; SCM_UNDEFIEND, which in the case of make-vector resulted in + ;; wrong-type-arg, instead of the intended wrong-num-args + (pass-if-exception "0 args" exception:wrong-num-args + (apply make-vector '())) + + (pass-if "1 arg" + (vector? (apply make-vector '(1)))) + + (pass-if "2 args" + (vector? (apply make-vector '(1 2)))) + + ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected + (pass-if-exception "3 args" exception:wrong-num-args + (apply make-vector '(1 2 3))))) + +;;; ;;; map ;;; diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index 3cdc8dc75..cc3b6684b 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -18,8 +18,10 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (test-suite lib) - (ice-9 format)) +(define-module (test-format) + #:use-module (test-suite lib) + #:use-module (ice-9 format)) + ;;; FORMAT Basic Output @@ -73,6 +75,20 @@ (string=? (format #f "~@d" 1) "+1")))) ;;; +;;; ~f +;;; + +(with-test-prefix "~f fixed-point" + + (pass-if "1.5" + (string=? "1.5" (format #f "~f" 1.5))) + + ;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly + ;; stripped, moving the decimal point and giving "25.0" here + (pass-if "string 02.5" + (string=? "2.5" (format #f "~f" "02.5")))) + +;;; ;;; ~{ ;;; diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test new file mode 100644 index 000000000..a61850af2 --- /dev/null +++ b/test-suite/tests/ftw.test @@ -0,0 +1,73 @@ +;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- +;;;; +;;;; Copyright 2006 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 + +(define-module (test-suite test-ice-9-ftw) + #:use-module (test-suite lib) + #:use-module (ice-9 ftw)) + + +;; the procedure-source checks here ensure the vector indexes we write match +;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match +;; libguile/filesys.c of course) + +(or (equal? (procedure-source stat:dev) + '(lambda (f) (vector-ref f 0))) + (error "oops, unexpected stat:dev definition")) +(define (stat:dev! st dev) + (vector-set! st 0 dev)) + +(or (equal? (procedure-source stat:ino) + '(lambda (f) (vector-ref f 1))) + (error "oops, unexpected stat:ino definition")) +(define (stat:ino! st ino) + (vector-set! st 1 ino)) + + +;; +;; visited?-proc +;; + +(with-test-prefix "visited?-proc" + + ;; normally internal-only + (let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc)) + (visited? (visited?-proc 97)) + (s (stat "/"))) + + (define (try-visited? dev ino) + (stat:dev! s dev) + (stat:ino! s ino) + (visited? s)) + + (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0))) + (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0))) + (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0))) + + (pass-if "0 1" (eq? #f (try-visited? 0 1))) + (pass-if "0 2" (eq? #f (try-visited? 0 2))) + (pass-if "0 3" (eq? #f (try-visited? 0 3))) + + (pass-if "5 5" (eq? #f (try-visited? 5 5))) + (pass-if "5 7" (eq? #f (try-visited? 5 7))) + (pass-if "7 5" (eq? #f (try-visited? 7 5))) + (pass-if "7 7" (eq? #f (try-visited? 7 7))) + + (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5))) + (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7))) + (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5))) + (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7))))) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test new file mode 100644 index 000000000..fca99c768 --- /dev/null +++ b/test-suite/tests/i18n.test @@ -0,0 +1,143 @@ +;;;; i18n.test --- Exercise the i18n API. +;;;; +;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; 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 i18n) + :use-module (ice-9 i18n) + :use-module (test-suite lib)) + +;; Start from a pristine locale state. +(setlocale LC_ALL "C") + + +(with-test-prefix "locale objects" + + (pass-if "make-locale (2 args)" + (not (not (make-locale LC_ALL_MASK "C")))) + + (pass-if "make-locale (3 args)" + (not (not (make-locale LC_COLLATE_MASK "C" + (make-locale LC_MESSAGES_MASK "C"))))) + + (pass-if "locale?" + (and (locale? (make-locale LC_ALL_MASK "C")) + (locale? (make-locale (logior LC_MESSAGES_MASK LC_NUMERIC_MASK) "C" + (make-locale LC_CTYPE_MASK "C")))))) + + + +(with-test-prefix "text collation (English)" + + (pass-if "string-locale<?" + (and (string-locale<? "hello" "world") + (string-locale<? "hello" "world" + (make-locale LC_COLLATE_MASK "C")))) + + (pass-if "char-locale<?" + (and (char-locale<? #\a #\b) + (char-locale<? #\a #\b (make-locale LC_COLLATE_MASK "C")))) + + (pass-if "string-locale-ci=?" + (and (string-locale-ci=? "Hello" "HELLO") + (string-locale-ci=? "Hello" "HELLO" + (make-locale LC_COLLATE_MASK "C")))) + + (pass-if "string-locale-ci<?" + (and (string-locale-ci<? "hello" "WORLD") + (string-locale-ci<? "hello" "WORLD" + (make-locale LC_COLLATE_MASK "C"))))) + + +(define %french-locale + (false-if-exception + (make-locale (logior LC_CTYPE_MASK LC_COLLATE_MASK) + "fr_FR.ISO-8859-1"))) + +(define (under-french-locale-or-unresolved thunk) + ;; On non-GNU systems, an exception may be raised only when the locale is + ;; actually used rather than at `make-locale'-time. Thus, we must guard + ;; against both. + (if %french-locale + (catch 'system-error thunk + (lambda (key . args) + (throw 'unresolved))) + (throw 'unresolved))) + +(with-test-prefix "text collation (French)" + + (pass-if "string-locale<?" + (under-french-locale-or-unresolved + (lambda () + (string-locale<? "été" "hiver" %french-locale)))) + + (pass-if "char-locale<?" + (under-french-locale-or-unresolved + (lambda () + (char-locale<? #\é #\h %french-locale)))) + + (pass-if "string-locale-ci=?" + (under-french-locale-or-unresolved + (lambda () + (string-locale-ci=? "ÉTÉ" "été" %french-locale)))) + + (pass-if "string-locale-ci<>?" + (under-french-locale-or-unresolved + (lambda () + (and (string-locale-ci<? "été" "Hiver" %french-locale) + (string-locale-ci>? "HiVeR" "été" %french-locale))))) + + (pass-if "char-locale-ci<>?" + (under-french-locale-or-unresolved + (lambda () + (and (char-locale-ci<? #\é #\H %french-locale) + (char-locale-ci>? #\h #\É %french-locale)))))) + + +(with-test-prefix "character mapping" + + (pass-if "char-locale-downcase" + (and (eq? #\a (char-locale-downcase #\A)) + (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL_MASK "C"))))) + + (pass-if "char-locale-upcase" + (and (eq? #\Z (char-locale-upcase #\z)) + (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL_MASK "C")))))) + + +(with-test-prefix "number parsing" + + (pass-if "locale-string->integer" + (call-with-values (lambda () (locale-string->integer "123")) + (lambda (result char-count) + (and (equal? result 123) + (equal? char-count 3))))) + + (pass-if "locale-string->inexact" + (call-with-values + (lambda () + (locale-string->inexact "123.456" + (make-locale LC_NUMERIC_MASK "C"))) + (lambda (result char-count) + (and (equal? result 123.456) + (equal? char-count 7)))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index af67d6816..78d130a2b 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -71,6 +71,32 @@ (quotient (- n d -1) d) ;; neg/pos (quotient n d))) ;; pos/pos +;; return true of X is in the range LO to HI, inclusive +(define (within-range? lo hi x) + (and (>= x (min lo hi)) + (<= x (max lo hi)))) + +;; return true if GOT is within +/- 0.01 of GOT +;; for a complex number both real and imaginary parts must be in that range +(define (eqv-loosely? want got) + (and (within-range? (- (real-part want) 0.01) + (+ (real-part want) 0.01) + (real-part got)) + (within-range? (- (imag-part want) 0.01) + (+ (imag-part want) 0.01) + (imag-part got)))) + +;; return true if OBJ is negative infinity +(define (negative-infinity? obj) + (and (real? obj) + (negative? obj) + (inf? obj))) + +(define const-e 2.7182818284590452354) +(define const-e^2 7.3890560989306502274) +(define const-1/e 0.3678794411714423215) + + ;;; ;;; 1+ ;;; @@ -201,6 +227,36 @@ (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))))) ;;; +;;; exp +;;; + +(with-test-prefix "exp" + (pass-if "documented?" + (documented? exp)) + + (pass-if-exception "no args" exception:wrong-num-args + (exp)) + (pass-if-exception "two args" exception:wrong-num-args + (exp 123 456)) + + (pass-if (eqv? 0.0 (exp -inf.0))) + (pass-if (eqv-loosely? 1.0 (exp 0))) + (pass-if (eqv-loosely? 1.0 (exp 0.0))) + (pass-if (eqv-loosely? const-e (exp 1.0))) + (pass-if (eqv-loosely? const-e^2 (exp 2.0))) + (pass-if (eqv-loosely? const-1/e (exp -1))) + + (pass-if "exp(pi*i) = -1" + (eqv-loosely? -1.0 (exp 0+3.14159i))) + (pass-if "exp(-pi*i) = -1" + (eqv-loosely? -1.0 (exp 0-3.14159i))) + (pass-if "exp(2*pi*i) = +1" + (eqv-loosely? 1.0 (exp 0+6.28318i))) + + (pass-if "exp(2-pi*i) = -e^2" + (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i)))) + +;;; ;;; odd? ;;; @@ -2931,6 +2987,62 @@ (= i (integer-length n)))))) ;;; +;;; log +;;; + +(with-test-prefix "log" + (pass-if "documented?" + (documented? log)) + + (pass-if-exception "no args" exception:wrong-num-args + (log)) + (pass-if-exception "two args" exception:wrong-num-args + (log 123 456)) + + (pass-if (negative-infinity? (log 0))) + (pass-if (negative-infinity? (log 0.0))) + (pass-if (eqv? 0.0 (log 1))) + (pass-if (eqv? 0.0 (log 1.0))) + (pass-if (eqv-loosely? 1.0 (log const-e))) + (pass-if (eqv-loosely? 2.0 (log const-e^2))) + (pass-if (eqv-loosely? -1.0 (log const-1/e))) + + (pass-if (eqv-loosely? 1.0+1.57079i (log 0+2.71828i))) + (pass-if (eqv-loosely? 1.0-1.57079i (log 0-2.71828i))) + + (pass-if (eqv-loosely? 0.0+3.14159i (log -1.0))) + (pass-if (eqv-loosely? 1.0+3.14159i (log -2.71828))) + (pass-if (eqv-loosely? 2.0+3.14159i (log (* -2.71828 2.71828))))) + +;;; +;;; log10 +;;; + +(with-test-prefix "log10" + (pass-if "documented?" + (documented? log10)) + + (pass-if-exception "no args" exception:wrong-num-args + (log10)) + (pass-if-exception "two args" exception:wrong-num-args + (log10 123 456)) + + (pass-if (negative-infinity? (log10 0))) + (pass-if (negative-infinity? (log10 0.0))) + (pass-if (eqv? 0.0 (log10 1))) + (pass-if (eqv? 0.0 (log10 1.0))) + (pass-if (eqv-loosely? 1.0 (log10 10.0))) + (pass-if (eqv-loosely? 2.0 (log10 100.0))) + (pass-if (eqv-loosely? -1.0 (log10 0.1))) + + (pass-if (eqv-loosely? 1.0+0.68218i (log10 0+10.0i))) + (pass-if (eqv-loosely? 1.0-0.68218i (log10 0-10.0i))) + + (pass-if (eqv-loosely? 0.0+1.36437i (log10 -1))) + (pass-if (eqv-loosely? 1.0+1.36437i (log10 -10))) + (pass-if (eqv-loosely? 2.0+1.36437i (log10 -100)))) + +;;; ;;; logbit? ;;; @@ -3035,3 +3147,36 @@ (lognot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))) (pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF (lognot #x-100000000000000000000000000000000)))) + +;;; +;;; sqrt +;;; + +(with-test-prefix "sqrt" + (pass-if "documented?" + (documented? sqrt)) + + (pass-if-exception "no args" exception:wrong-num-args + (sqrt)) + (pass-if-exception "two args" exception:wrong-num-args + (sqrt 123 456)) + + (pass-if (eqv? 0.0 (sqrt 0))) + (pass-if (eqv? 0.0 (sqrt 0.0))) + (pass-if (eqv? 1.0 (sqrt 1.0))) + (pass-if (eqv-loosely? 2.0 (sqrt 4.0))) + (pass-if (eqv-loosely? 31.62 (sqrt 1000.0))) + + (pass-if (eqv? +1.0i (sqrt -1.0))) + (pass-if (eqv-loosely? +2.0i (sqrt -4.0))) + (pass-if (eqv-loosely? +31.62i (sqrt -1000.0))) + + (pass-if "+i swings back to 45deg angle" + (eqv-loosely? +0.7071+0.7071i (sqrt +1.0i))) + + ;; Note: glibc 2.3 csqrt() had a bug affecting this test case, so if it + ;; fails check whether that's the cause (there's a configure test to + ;; reject it, but when cross-compiling we assume the C library is ok). + (pass-if "-100i swings back to 45deg down" + (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) + diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 19d3edc49..1dd2bc78e 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -82,9 +82,10 @@ (port (with-error-to-port (cdr pair) (lambda () (open-input-pipe - "exec 1>/dev/null; echo closed 1>&2; sleep 999"))))) - (read-char (car pair)) ;; wait for child to do its thing - (and (char-ready? port) + "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999"))))) + (close-port (cdr pair)) ;; write side + (and (char? (read-char (car pair))) ;; wait for child to do its thing + (char-ready? port) (eof-object? (read-char port)))))) ;; @@ -131,15 +132,16 @@ (port (with-error-to-port (cdr pair) (lambda () (open-output-pipe - "exec 0</dev/null; echo closed 1>&2; sleep 999"))))) - (read-char (car pair)) ;; wait for child to do its thing - (catch 'system-error + "exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999"))))) + (close-port (cdr pair)) ;; write side + (and (char? (read-char (car pair))) ;; wait for child to do its thing + (catch 'system-error (lambda () (write-char #\x port) (force-output port) #f) (lambda (key name fmt args errno-list) - (= (car errno-list) EPIPE)))))))) + (= (car errno-list) EPIPE))))))))) ;; ;; close-pipe diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index b738dc9f2..9690122b5 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -539,19 +539,72 @@ (= 8 (port-column port)))))) ;;; +;;; seek +;;; + +(with-test-prefix "seek" + + (with-test-prefix "file port" + + (pass-if "SEEK_CUR" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port 2 SEEK_CUR) + (eqv? #\d (read-char port)))) + + (pass-if "SEEK_SET" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port 3 SEEK_SET) + (eqv? #\d (read-char port)))) + + (pass-if "SEEK_END" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port -2 SEEK_END) + (eqv? #\d (read-char port)))))) + +;;; ;;; truncate-file ;;; (with-test-prefix "truncate-file" + (pass-if-exception "flonum file" exception:wrong-type-arg + (truncate-file 1.0 123)) + + (pass-if-exception "frac file" exception:wrong-type-arg + (truncate-file 7/3 123)) + (with-test-prefix "filename" + (pass-if-exception "flonum length" exception:wrong-type-arg + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file) 1.0)) + (pass-if "shorten" (call-with-output-file (test-file) (lambda (port) (display "hello" port))) (truncate-file (test-file) 1) - (eqv? 1 (stat:size (stat (test-file)))))) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if-exception "shorten to current pos" exception:miscellaneous-error + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file)))) (with-test-prefix "file descriptor" @@ -562,6 +615,16 @@ (let ((fd (open-fdes (test-file) O_RDWR))) (truncate-file fd 1) (close-fdes fd)) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if "shorten to current pos" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((fd (open-fdes (test-file) O_RDWR))) + (seek fd 1 SEEK_SET) + (truncate-file fd) + (close-fdes fd)) (eqv? 1 (stat:size (stat (test-file)))))) (with-test-prefix "file port" @@ -572,6 +635,15 @@ (display "hello" port))) (let ((port (open-file (test-file) "r+"))) (truncate-file port 1)) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if "shorten to current pos" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((port (open-file (test-file) "r+"))) + (read-char port) + (truncate-file port)) (eqv? 1 (stat:size (stat (test-file))))))) diff --git a/test-suite/tests/slib.test b/test-suite/tests/slib.test deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/slib.test +++ /dev/null diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index dd91f35b6..7663b56b7 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -20,6 +20,27 @@ #:use-module (test-suite lib)) + +;;; +;;; htonl +;;; + +(with-test-prefix "htonl" + + (pass-if "0" (eqv? 0 (htonl 0))) + + (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))) + + (pass-if-exception "2^1024" exception:out-of-range + (htonl (ash 1 1024)))) + + ;;; ;;; inet-ntop ;;; @@ -110,6 +131,25 @@ (and (= (sockaddr:fam sa) AF_UNIX) (string=? (sockaddr:path sa) "/tmp/unix-socket")))))) +;;; +;;; ntohl +;;; + +(with-test-prefix "ntohl" + + (pass-if "0" (eqv? 0 (ntohl 0))) + + (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))) + + (pass-if-exception "2^1024" exception:out-of-range + (ntohl (ash 1 1024)))) + ;;; diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index dd55c1335..22c4a9a68 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -17,8 +17,10 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (srfi srfi-1) - (test-suite lib)) +(define-module (test-srfi-1) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + (define (ref-delete x lst . proc) "Reference implemenation of srfi-1 `delete'." diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index 5c3a3f509..fc6307149 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -290,7 +290,7 @@ (pass-if "char-set:punctuation (membership)" (if (not %latin1) - (thrown 'unresolved) + (throw 'unresolved) (let ((punctuation (char-set->list char-set:punctuation))) (every? (lambda (8-bit-char) (memq 8-bit-char punctuation)) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index 9a6f8e31a..18fa19328 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -18,25 +18,69 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (srfi srfi-9)) +(define-module (test-suite test-numbers) + #:use-module (test-suite lib) + #:use-module (srfi srfi-9)) + + +(define exception:not-a-record + (cons 'misc-error "^not-a-record")) + (define-record-type :foo (make-foo x) foo? (x get-x) (y get-y set-y!)) +(define-record-type :bar (make-bar i j) bar? + (i get-i) (i get-j set-j!)) + (define f (make-foo 1)) (set-y! f 2) -(with-test-prefix "record procedures" +(define b (make-bar 123 456)) + +(with-test-prefix "constructor" + + (pass-if-exception "foo 0 args" exception:wrong-num-args + (make-foo)) + (pass-if-exception "foo 2 args" exception:wrong-num-args + (make-foo 1 2))) + +(with-test-prefix "predicate" - (pass-if "predicate" + (pass-if "pass" (foo? f)) + (pass-if "fail wrong record type" + (eq? #f (foo? b))) + (pass-if "fail number" + (eq? #f (foo? 123)))) - (pass-if "accessor 1" - (= 1 (get-x f))) +(with-test-prefix "accessor" - (pass-if "accessor 2" + (pass-if "get-x" + (= 1 (get-x f))) + (pass-if "get-y" (= 2 (get-y f))) - (pass-if "modifier" + (pass-if-exception "get-x on number" exception:not-a-record + (get-x 999)) + (pass-if-exception "get-y on number" exception:not-a-record + (get-y 999)) + + ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced + (pass-if-exception "get-x on bar" exception:wrong-type-arg + (get-x b)) + (pass-if-exception "get-y on bar" exception:wrong-type-arg + (get-y b))) + +(with-test-prefix "modifier" + + (pass-if "set-y!" (set-y! f #t) - (eq? #t (get-y f)))) + (eq? #t (get-y f))) + + (pass-if-exception "set-y! on number" exception:not-a-record + (set-y! 999 #t)) + + ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced + (pass-if-exception "set-y! on bar" exception:wrong-type-arg + (set-y! b 99))) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index 3cbbb15f8..e228dfb09 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -32,15 +32,9 @@ (pass-if (list "in another thread after error" t) (or (provided? 'threads) (throw 'unsupported)) - ;; actually this test is perfectly good, but the "internal - ;; define - missing body expression" in syntax.test somehow - ;; ends up leaving SCM_DEFER_INTS, making the test here hang - ;; - (throw 'unresolved) - (alarm 5) (false-if-exception (gmtime t)) - (thread-join (begin-thread (catch 'out-of-range + (join-thread (begin-thread (catch 'out-of-range (lambda () (gmtime t)) (lambda args #f)))) (alarm 0) @@ -74,30 +68,186 @@ (* 2 internal-time-units-per-second)))))) ;;; +;;; localtime +;;; + +(with-test-prefix "localtime" + + ;; gmtoff is calculated with some explicit code, try to exercise that + ;; here, looking at cases where the localtime and gmtime are within the same + ;; day, or crossing midnight, or crossing new year + + (pass-if "gmtoff of EST+5 at GMT 10:00am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 10) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "EST+5"))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing forward over day boundary + (pass-if "gmtoff of EST+5 at GMT 3am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "EST+5"))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at GMT 10pm on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "AST-10"))) + (eqv? (* -10 3600) (tm:gmtoff tm))))) + + ;; crossing forward over year boundary + (pass-if "gmtoff of EST+5 at GMT 3am on 1 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 1) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "EST+5"))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at GMT 10pm on 31 Dec 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 31) + (set-tm:mon tm 11) + (set-tm:year tm 100) + (let* ((t (car (mktime tm "GMT"))) + (tm (localtime t "AST-10"))) + (eqv? (* -10 3600) (tm:gmtoff tm)))))) + +;;; +;;; mktime +;;; + +(with-test-prefix "mktime" + + ;; gmtoff is calculated with some explicit code, try to exercise that + ;; here, looking at cases where the mktime and gmtime are within the same + ;; day, or crossing midnight, or crossing new year + + (pass-if "gmtoff of EST+5 at 10:00am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 10) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "EST+5")))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing forward over day boundary + (pass-if "gmtoff of EST+5 at 10:00pm on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "EST+5")))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at 3:00am on 10 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 10) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "AST-10")))) + (eqv? (* -10 3600) (tm:gmtoff tm))))) + + ;; crossing forward over year boundary + (pass-if "gmtoff of EST+5 at 10:00pm on 31 Dec 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 22) + (set-tm:mday tm 31) + (set-tm:mon tm 11) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "EST+5")))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + ;; crossing backward over day boundary + (pass-if "gmtoff of AST-10 at 3:00am on 1 Jan 2000" + (let ((tm (gmtime 0))) + (set-tm:hour tm 3) + (set-tm:mday tm 1) + (set-tm:mon tm 0) + (set-tm:year tm 100) + (let ((tm (cdr (mktime tm "AST-10")))) + (eqv? (* -10 3600) (tm:gmtoff tm)))))) + +;;; ;;; strftime ;;; -;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX. -;; If localtime is in daylight savings then it will decide there's no -;; daylight savings zone name for the fake ZOW, and come back empty. -;; -;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone -;; field in struct tm passed by guile. That behaviour is reasonable enough -;; since that field is not in C99 so a C99 program won't know it has to be -;; set. For the details on that see -;; -;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722 -;; -;; Not sure what to do about this in guile, it'd be nice for %Z to look at -;; tm:zone everywhere. -;; -;; -;; (pass-if "strftime %Z doesn't return garbage" -;; (let ((t (localtime (current-time)))) -;; (set-tm:zone t "ZOW") -;; (set-tm:isdst t 0) -;; (string=? (strftime "%Z" t) -;; "ZOW"))) +(with-test-prefix "strftime" + + ;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX. + ;; If localtime is in daylight savings then it will decide there's no + ;; daylight savings zone name for the fake ZOW, and come back empty. + ;; + ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone + ;; field in struct tm passed by guile. That behaviour is reasonable + ;; enough since that field is not in C99 so a C99 program won't know it + ;; has to be set. For the details on that see + ;; + ;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722 + ;; + ;; Not sure what to do about this in guile, it'd be nice for %Z to look at + ;; tm:zone everywhere. + ;; + ;; + ;; (pass-if "strftime %Z doesn't return garbage" + ;; (let ((t (localtime (current-time)))) + ;; (set-tm:zone t "ZOW") + ;; (set-tm:isdst t 0) + ;; (string=? (strftime "%Z" t) + ;; "ZOW"))) + + (with-test-prefix "C99 %z format" + + ;; C99 spec is empty string if no zone determinable + ;; + ;; on pre-C99 systems not sure what to expect if %z unsupported, probably + ;; "%z" unchanged in C99 if timezone + ;; + (define have-strftime-%z + (not (member (strftime "%z" (gmtime 0)) + '("" "%z")))) + + ;; %z here is quite possibly affected by the same tm:gmtoff vs current + ;; zone as %Z above is, so in the following tests we make them the same. + + (pass-if "GMT" + (or have-strftime-%z (throw 'unsupported)) + (putenv "TZ=GMT+0") + (tzset) + (let ((tm (localtime 86400))) + (string=? "+0000" (strftime "%z" tm)))) + + ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500", + ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus + ;; tm_gmtoff being east of Greenwich + (pass-if "EST+5" + (or have-strftime-%z (throw 'unsupported)) + (putenv "TZ=EST+5") + (tzset) + (let ((tm (localtime 86400))) + (string=? "-0500" (strftime "%z" tm)))))) ;;; ;;; strptime @@ -109,15 +259,31 @@ (or (defined? 'strptime) (throw 'unsupported)) (or (provided? 'threads) (throw 'unsupported)) - ;; actually this test is perfectly good, but the "internal define - - ;; missing body expression" in syntax.test somehow ends up leaving - ;; SCM_DEFER_INTS, making the test here hang - ;; - (throw 'unresolved) - (alarm 5) (false-if-exception (strptime "%a" "nosuchday")) - (thread-join (begin-thread (strptime "%d" "1"))) + (join-thread (begin-thread (strptime "%d" "1"))) (alarm 0) - #t)) + #t) + + (with-test-prefix "GNU %s format" + + ;; "%s" to parse a count of seconds since 1970 is a GNU extension + (define have-strptime-%s + (false-if-exception (strptime "%s" "0"))) + + (pass-if "gmtoff on GMT" + (or have-strptime-%s (throw 'unsupported)) + (putenv "TZ=GMT+0") + (tzset) + (let ((tm (car (strptime "%s" "86400")))) + (eqv? 0 (tm:gmtoff tm)))) + + ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from + ;; strptime + (pass-if "gmtoff on EST+5" + (or have-strptime-%s (throw 'unsupported)) + (putenv "TZ=EST+5") + (tzset) + (let ((tm (car (strptime "%s" "86400")))) + (eqv? (* 5 3600) (tm:gmtoff tm)))))) diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 2a0048483..576a9286c 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -26,6 +26,10 @@ (define exception:wrong-num-indices (cons 'misc-error "^wrong number of indices.*")) +(define exception:length-non-negative + (cons 'read-error ".*array length must be non-negative.*")) + + (with-test-prefix "array?" (let ((bool (make-typed-array 'b #t '(5 6))) @@ -513,7 +517,41 @@ (array-set! a -128 0) (= -128 (uniform-vector-ref a 0))))))) +;;; +;;; syntax +;;; + +(with-test-prefix "syntax" + + (pass-if "rank and lower bounds" + ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8. + (let ((a '#2u32@2@7((1 2) (3 4)))) + (and (array? a) + (typed-array? a 'u32) + (= (array-rank a) 2) + (let loop ((bounds '((2 7) (2 8) (3 7) (3 8))) + (result #t)) + (if (null? bounds) + result + (and result + (loop (cdr bounds) + (apply array-in-bounds? a (car bounds))))))))) + + (pass-if "negative lower bound" + (let ((a '#1@-3(a b))) + (and (array? a) + (= (array-rank a) 1) + (array-in-bounds? a -3) (array-in-bounds? a -2) + (eq? 'a (array-ref a -3)) + (eq? 'b (array-ref a -2))))) + + (pass-if-exception "negative length" exception:length-non-negative + (with-input-from-string "'#1:-3(#t #t)" read))) + + +;;; ;;; equal? with vector and one-dimensional array +;;; (pass-if "vector equal? one-dimensional array" (equal? (make-shared-array #2((a b c) (d e f) (g h i)) diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test index 1fb16bcb0..738a0828a 100644 --- a/test-suite/tests/vectors.test +++ b/test-suite/tests/vectors.test @@ -17,6 +17,8 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA +(define-module (test-suite vectors) + :use-module (test-suite lib)) ;; FIXME: As soon as guile supports immutable vectors, this has to be ;; replaced with the appropriate error type and message. @@ -29,3 +31,13 @@ (expect-fail-exception "vector constant" exception:immutable-vector (vector-set! '#(1 2 3) 0 4))) + +(with-test-prefix "vector->list" + + (pass-if "simple vector" + (equal? '(1 2 3) (vector->list #(1 2 3)))) + + (pass-if "shared array" + (let ((b (make-shared-array #(1) (lambda (x) '(0)) 2))) + (equal? b (list->vector (vector->list b)))))) + |