mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

merge from 1.8 branch

Browse source
This commit is contained in:
Kevin Ryde 2006-10-09 23:40:48 +00:00
parent 121a80826c
commit 8ab3d8a068
41 changed files with 1513 additions and 203 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.cvsignore
View file

@ -27,6 +27,7 @@ install-sh
libtool libtool
ltconfig ltconfig
ltmain.sh ltmain.sh
mdate-sh
missing missing
mkinstalldirs mkinstalldirs
pre-inst-guile pre-inst-guile

44
ChangeLog
View file

@ -1,3 +1,28 @@
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> 2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
* configure.in: Check for `isblank ()'. * configure.in: Check for `isblank ()'.
@ -5,6 +30,11 @@
* NEWS: Mentioned the interaction between `setlocale' and SRFI-14 * NEWS: Mentioned the interaction between `setlocale' and SRFI-14
standard char sets. 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> 2006-08-18 Neil Jerram <neil@ossau.uklinux.net>
* configure.in: Generate Makefile for emacs subdir. * configure.in: Generate Makefile for emacs subdir.
@ -13,6 +43,20 @@
* configure.in: Generate Makefile for ice-9/debugging subdir. * configure.in: Generate Makefile for ice-9/debugging subdir.
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> 2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
* NEWS: Mentioned the new behavior of `equal?' for structures. * NEWS: Mentioned the new behavior of `equal?' for structures.

2
Makefile.am
View file

@ -30,7 +30,7 @@ include_HEADERS = libguile.h
# automake sometimes forgets to distribute acconfig.h, # automake sometimes forgets to distribute acconfig.h,
# apparently depending on the phase of the moon. # apparently depending on the phase of the moon.
EXTRA_DIST = HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS
TESTS = check-guile TESTS = check-guile

73
NEWS
View file

@ -22,34 +22,73 @@ Changes in 1.9.XXXXXXXX:
Changes in 1.8.1 (since 1.8.0): 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]
* Bugs fixed
** Build problems have been fixed on MacOS, SunOS, and QNX.
** A one-dimensional array can now be 'equal?' to a vector. ** A one-dimensional array can now be 'equal?' to a vector.
** Structures, records, and SRFI-9 records can now be compared with `equal?'. ** Structures, records, and SRFI-9 records can now be compared with `equal?'.
** 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'.
** New function scm_c_locale_stringn_to_number. ** `record-accessor' and `record-modifier' now have strict type checks.
* Bug fixes. 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).
** array-set! with bit vector. ** It is now OK to use both autoload and use-modules on a given module.
** make-shared-array fixes, including examples in the manual which failed.
** string<? and friends follow char<? etc order on 8-bit chars. ** `apply' checks the number of arguments more carefully on "0 or 1" funcs.
** n-par-for-each, n-for-each-par-map for "futures" variable.
** module autoload and explicit use-modules cooperate. Previously there was no checking on primatives like make-vector that
** ice-9 format ~f with infs and nans. accept "one or two" arguments. Now there is.
** exact->inexact overflows on fractions with big num/den but small result.
** srfi-1 assoc "=" procedure argument order. ** The srfi-1 assoc function now calls its equality predicate properly.
** Build problems on MacOS, SunOS, QNX.
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.
This matches the srfi-9 specification.
** (ice-9 ftw) procedures won't ignore different files with same inode number.
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 * Changes to the distribution

99
configure.in
View file

@ -523,14 +523,22 @@ AC_HEADER_TIME
AC_HEADER_SYS_WAIT AC_HEADER_SYS_WAIT
# Reasons for testing: # Reasons for testing:
# complex.h - new in C99
# fenv.h - available in C99, but not older systems # 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 \ regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \ sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \ sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
direct.h]) 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 # On MacOS X <sys/socklen.h> contains socklen_t, so must include that
# when testing. # when testing.
AC_CHECK_TYPE(socklen_t, , AC_CHECK_TYPE(socklen_t, ,
@ -592,23 +600,31 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# DINFINITY - OSF specific # DINFINITY - OSF specific
# DQNAN - OSF specific # DQNAN - OSF specific
# (DINFINITY and DQNAN are actually global variables, not functions) # (DINFINITY and DQNAN are actually global variables, not functions)
# chsize - an MS-DOS-ism, found in mingw
# clog10 - not in mingw (though others like clog and csqrt are)
# fesetround - available in C99, but not older systems # fesetround - available in C99, but not older systems
# ftruncate - posix, but probably not older systems (current mingw
# has it as an inline for chsize)
# ioctl - not in mingw. # ioctl - not in mingw.
# gmtime_r - recent posix, not on old systems # gmtime_r - recent posix, not on old systems
# readdir_r - recent posix, not on old systems # readdir_r - recent posix, not on old systems
# stat64 - SuS largefile stuff, not on old systems # stat64 - SuS largefile stuff, not on old systems
# sysconf - not on old systems # sysconf - not on old systems
# truncate - not in mingw
# isblank - available as a GNU extension or in C99 # isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific # _NSGetEnviron - Darwin specific
# #
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])
# Reasons for testing: # Reasons for testing:
# netdb.h - not in mingw # netdb.h - not in mingw
# sys/param.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_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_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 # crypt() may or may not be available, for instance in some countries there
# are restrictions on cryptography. # are restrictions on cryptography.
@ -627,6 +643,38 @@ AC_SEARCH_LIBS(crypt, crypt,
[AC_DEFINE(HAVE_CRYPT,1, [AC_DEFINE(HAVE_CRYPT,1,
[Define to 1 if you have the `crypt' function.])]) [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 dnl GMP tests
AC_CHECK_LIB([gmp], [__gmpz_init], , AC_CHECK_LIB([gmp], [__gmpz_init], ,
[AC_MSG_ERROR([GNU MP not found, see README])]) [AC_MSG_ERROR([GNU MP not found, see README])])
@ -878,10 +926,9 @@ AC_CHECK_HEADERS(floatingpoint.h ieeefp.h nan.h)
# Reasons for testing: # Reasons for testing:
# asinh, acosh, atanh, trunc - C99 standard, generally not available on # asinh, acosh, atanh, trunc - C99 standard, generally not available on
# older systems # older systems
# dirfd - mainly BSD derived, not in older systems
# sincos - GLIBC extension # 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. # C99 specifies isinf and isnan as macros.
# HP-UX provides only macros, no functions. # HP-UX provides only macros, no functions.
@ -924,6 +971,7 @@ fi
# st_rdev # st_rdev
# st_blksize # st_blksize
# st_blocks not in mingw # 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 # Note AC_STRUCT_ST_BLOCKS is not used here because we don't want the
# AC_LIBOBJ(fileblocks) replacement which that macro gives. # AC_LIBOBJ(fileblocks) replacement which that macro gives.
@ -931,8 +979,22 @@ fi
AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct stat.st_blocks]) AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct stat.st_blocks])
AC_STRUCT_TIMEZONE 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 GUILE_STRUCT_UTIMBUF
#-------------------------------------------------------------------- #--------------------------------------------------------------------
# #
# Which way does the stack grow? # Which way does the stack grow?
@ -997,6 +1059,8 @@ AC_SUBST([SCM_I_GSC_USE_NULL_THREADS])
AC_ARG_WITH(threads, [ --with-threads thread interface], AC_ARG_WITH(threads, [ --with-threads thread interface],
, with_threads=yes) , with_threads=yes)
AC_SUBST(SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT, 0)
case "$with_threads" in case "$with_threads" in
"yes" | "pthread" | "pthreads" | "pthread-threads" | "") "yes" | "pthread" | "pthreads" | "pthread-threads" | "")
ACX_PTHREAD(CC="$PTHREAD_CC" ACX_PTHREAD(CC="$PTHREAD_CC"
@ -1007,7 +1071,32 @@ case "$with_threads" in
old_CFLAGS="$CFLAGS" old_CFLAGS="$CFLAGS"
CFLAGS="$PTHREAD_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" CFLAGS="$old_CFLAGS"
# On Solaris, sched_yield lives in -lrt. # On Solaris, sched_yield lives in -lrt.

107
libguile/ChangeLog
View file

@ -1,3 +1,50 @@
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> 2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
* srfi-14.c: Include <config.h>. Define `_GNU_SOURCE'. * srfi-14.c: Include <config.h>. Define `_GNU_SOURCE'.
@ -20,6 +67,11 @@
(scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a (scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a
successful `setlocale ()' call. 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> 2006-08-31 Rob Browning <rlb@defaultvalue.org>
* ports.c (scm_c_port_for_each): Add a * ports.c (scm_c_port_for_each): Add a
@ -32,11 +84,47 @@
improvements to docstring. improvements to docstring.
(scm_backtrace_with_highlights): Analogous improvements. (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> 2006-08-11 Neil Jerram <neil@ossau.uklinux.net>
* stacks.c (scm_last_stack_frame): Correct docstring (returns a * stacks.c (scm_last_stack_frame): Correct docstring (returns a
frame, not a stack). 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> 2006-07-18 Rob Browning <rlb@defaultvalue.org>
* continuations.c: Add __attribute__ ((returns_twice)) to the * continuations.c: Add __attribute__ ((returns_twice)) to the
@ -49,6 +137,25 @@
* numbers.c (guile_ieee_init): Use regular ANSI C casts rather * numbers.c (guile_ieee_init): Use regular ANSI C casts rather
than C++-style `X_CAST ()'. Patch posted by by Mike Gran. than C++-style `X_CAST ()'. Patch posted by by Mike Gran.
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> 2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
* eq.c: Include "struct.h", "goops.h" and "objects.h". * eq.c: Include "struct.h", "goops.h" and "objects.h".

2
libguile/Makefile.am
View file

@ -220,7 +220,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \
## usual @...@, so autoconf doesn't go and substitute the values ## usual @...@, so autoconf doesn't go and substitute the values
## directly into the left-hand sides of the sed substitutions. *sigh* ## directly into the left-hand sides of the sed substitutions. *sigh*
version.h: version.h.in version.h: version.h.in
sed < $< > $@.tmp \ sed < $(srcdir)/version.h.in > $@.tmp \
-e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \ -e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \
-e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \ -e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \
-e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}: -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}:

2
libguile/_scm.h
View file

@ -167,6 +167,8 @@
#else #else
# error sizeof(off_t) is not 4 or 8. # error sizeof(off_t) is not 4 or 8.
#endif #endif
#define scm_to_off64_t scm_to_int64
#define scm_from_off64_t scm_from_int64
#endif /* SCM__SCM_H */ #endif /* SCM__SCM_H */

7
libguile/environments.c
View file

@ -687,9 +687,10 @@ core_environments_unobserve (SCM env, SCM observer)
if (scm_is_eq (first, observer)) if (scm_is_eq (first, observer))
{ {
/* Remove the first observer */ /* Remove the first observer */
handling_weaks if (handling_weaks)
? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest) SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
: SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest); else
SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
return; return;
} }

43
libguile/eval.c
View file

@ -37,24 +37,22 @@
#ifndef DEVAL #ifndef DEVAL
/* AIX requires this to be the first thing in the file. The #pragma /* This blob per the Autoconf manual (under "Particular Functions"). */
directive is indented so pre-ANSI compilers will ignore it, rather #if HAVE_ALLOCA_H
than choke on it. */ # include <alloca.h>
#ifndef __GNUC__ #elif defined __GNUC__
# if HAVE_ALLOCA_H # define alloca __builtin_alloca
# include <alloca.h> #elif defined _AIX
# else # define alloca __alloca
# ifdef _AIX #elif defined _MSC_VER
# pragma alloca # include <malloc.h>
# else # define alloca _alloca
# ifndef alloca /* predefined by HP cc +Olibcalls */ #else
char *alloca (); # include <stddef.h>
# endif # ifdef __cplusplus
# endif extern "C"
# endif # endif
#endif void *alloca (size_t);
#if HAVE_MALLOC_H
#include <malloc.h> /* alloca on mingw */
#endif #endif
#include <assert.h> #include <assert.h>
@ -4851,7 +4849,16 @@ tail:
switch (SCM_TYP7 (proc)) switch (SCM_TYP7 (proc))
{ {
case scm_tc7_subr_2o: 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)); RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_2: case scm_tc7_subr_2:
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))

44
libguile/filesys.c
View file

@ -29,24 +29,22 @@
# include <config.h> # include <config.h>
#endif #endif
/* AIX requires this to be the first thing in the file. The #pragma /* This blob per the Autoconf manual (under "Particular Functions"). */
directive is indented so pre-ANSI compilers will ignore it, rather #if HAVE_ALLOCA_H
than choke on it. */ # include <alloca.h>
#ifndef __GNUC__ #elif defined __GNUC__
# if HAVE_ALLOCA_H # define alloca __builtin_alloca
# include <alloca.h> #elif defined _AIX
# else # define alloca __alloca
# ifdef _AIX #elif defined _MSC_VER
# pragma alloca # include <malloc.h>
# else # define alloca _alloca
# ifndef alloca /* predefined by HP cc +Olibcalls */ #else
char *alloca (); # include <stddef.h>
# endif # ifdef __cplusplus
# endif extern "C"
# endif # endif
#endif void *alloca (size_t);
#if HAVE_MALLOC_H
#include <malloc.h> /* alloca on mingw, though its not used on that system */
#endif #endif
#include <stdio.h> #include <stdio.h>
@ -202,10 +200,14 @@ char *alloca ();
# define fchmod(fd, mode) (-1) # define fchmod(fd, mode) (-1)
#endif /* __MINGW32__ */ #endif /* __MINGW32__ */
/* This definition is for Solaris 10, it's probably not right elsewhere, but /* dirfd() returns the file descriptor underlying a "DIR*" directory stream.
that's ok, it shouldn't be used elsewhere. */ Found on MacOS X for instance. The following definition is for Solaris
#if ! HAVE_DIRFD 10, it's probably not right elsewhere, but that's ok, it shouldn't be
#define dirfd(dirstream) (dirstream->dd_fd) 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 #endif

89
libguile/fports.c
View file

@ -17,6 +17,8 @@
#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
#if HAVE_CONFIG_H #if HAVE_CONFIG_H
# include <config.h> # include <config.h>
#endif #endif
@ -46,6 +48,7 @@
#endif #endif
#include <errno.h> #include <errno.h>
#include <sys/types.h>
#include "libguile/iselect.h" #include "libguile/iselect.h"
@ -53,9 +56,33 @@
#ifdef __MINGW32__ #ifdef __MINGW32__
# include <sys/stat.h> # include <sys/stat.h>
# include <winsock2.h> # include <winsock2.h>
# define ftruncate(fd, size) chsize (fd, size)
#endif /* __MINGW32__ */ #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; scm_t_bits scm_tc16_fport;
@ -334,7 +361,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
} }
ptr++; ptr++;
} }
SCM_SYSCALL (fdes = open (file, flags, 0666)); SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
if (fdes == -1) if (fdes == -1)
{ {
int en = errno; int en = errno;
@ -583,25 +610,25 @@ fport_fill_input (SCM port)
} }
} }
static off_t static off_t_or_off64_t
fport_seek (SCM port, off_t offset, int whence) fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
{ {
scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port *pt = SCM_PTAB_ENTRY (port);
scm_t_fport *fp = SCM_FSTREAM (port); scm_t_fport *fp = SCM_FSTREAM (port);
off_t rv; off_t_or_off64_t rv;
off_t result; off_t_or_off64_t result;
if (pt->rw_active == SCM_PORT_WRITE) if (pt->rw_active == SCM_PORT_WRITE)
{ {
if (offset != 0 || whence != SEEK_CUR) if (offset != 0 || whence != SEEK_CUR)
{ {
fport_flush (port); fport_flush (port);
result = rv = lseek (fp->fdes, offset, whence); result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
} }
else else
{ {
/* read current position without disturbing the buffer. */ /* 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); result = rv + (pt->write_pos - pt->write_buf);
} }
} }
@ -611,13 +638,13 @@ fport_seek (SCM port, off_t offset, int whence)
{ {
/* could expand to avoid a second seek. */ /* could expand to avoid a second seek. */
scm_end_input (port); scm_end_input (port);
result = rv = lseek (fp->fdes, offset, whence); result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
} }
else else
{ {
/* read current position without disturbing the buffer /* read current position without disturbing the buffer
(particularly the unread-char 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); result = rv - (pt->read_end - pt->read_pos);
if (pt->read_buf == pt->putback_buf) if (pt->read_buf == pt->putback_buf)
@ -626,7 +653,7 @@ fport_seek (SCM port, off_t offset, int whence)
} }
else /* SCM_PORT_NEITHER */ else /* SCM_PORT_NEITHER */
{ {
result = rv = lseek (fp->fdes, offset, whence); result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
} }
if (rv == -1) if (rv == -1)
@ -635,6 +662,39 @@ fport_seek (SCM port, off_t offset, int whence)
return result; 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 static void
fport_truncate (SCM port, off_t length) fport_truncate (SCM port, off_t length)
{ {
@ -644,6 +704,13 @@ fport_truncate (SCM port, off_t length)
scm_syserror ("ftruncate"); 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 /* helper for fport_write: try to write data, using multiple system
calls if required. */ calls if required. */
#define FUNC_NAME "write_all" #define FUNC_NAME "write_all"

3
libguile/fports.h
View file

@ -58,6 +58,9 @@ SCM_API void scm_init_fports (void);
/* internal functions */ /* internal functions */
SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name); 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 */ #endif /* SCM_FPORTS_H */

4
libguile/gen-scmconfig.c
View file

@ -378,6 +378,10 @@ main (int argc, char *argv[])
pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n", pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n",
SCM_I_GSC_USE_NULL_THREADS); 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 #if USE_DLL_IMPORT
pf ("\n"); pf ("\n");
pf ("/* Define some additional CPP macros on Win32 platforms. */\n"); pf ("/* Define some additional CPP macros on Win32 platforms. */\n");

1
libguile/gen-scmconfig.h.in
View file

@ -28,6 +28,7 @@
#define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@ #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_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_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: Local Variables:

165
libguile/numbers.c
View file

@ -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 #define _GNU_SOURCE
#if HAVE_CONFIG_H #if HAVE_CONFIG_H
@ -51,6 +51,10 @@
#include <ctype.h> #include <ctype.h>
#include <string.h> #include <string.h>
#if HAVE_COMPLEX_H
#include <complex.h>
#endif
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/feature.h" #include "libguile/feature.h"
#include "libguile/ports.h" #include "libguile/ports.h"
@ -66,6 +70,14 @@
#include "libguile/discouraged.h" #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 #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; static mpz_t z_negative_one;
@ -5977,6 +6004,142 @@ scm_is_number (SCM z)
return scm_is_true (scm_number_p (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 void
scm_init_numbers () scm_init_numbers ()
{ {

4
libguile/numbers.h
View file

@ -263,6 +263,10 @@ SCM_API SCM scm_angle (SCM z);
SCM_API SCM scm_exact_to_inexact (SCM z); SCM_API SCM scm_exact_to_inexact (SCM z);
SCM_API SCM scm_inexact_to_exact (SCM z); SCM_API SCM scm_inexact_to_exact (SCM z);
SCM_API SCM scm_trunc (SCM x); 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 */ /* bignum internal functions */
SCM_API SCM scm_i_mkbig (void); SCM_API SCM scm_i_mkbig (void);

74
libguile/ports.c
View file

@ -27,10 +27,12 @@
#include <stdio.h> #include <stdio.h>
#include <errno.h> #include <errno.h>
#include <fcntl.h> /* for chsize on mingw */
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/async.h" #include "libguile/async.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/fports.h" /* direct access for seek and truncate */
#include "libguile/objects.h" #include "libguile/objects.h"
#include "libguile/goops.h" #include "libguile/goops.h"
#include "libguile/smob.h" #include "libguile/smob.h"
@ -66,9 +68,17 @@
#include <sys/ioctl.h> #include <sys/ioctl.h>
#endif #endif
#ifdef __MINGW32__ /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
#include <fcntl.h> 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) #define ftruncate(fd, size) chsize (fd, size)
#undef HAVE_FTRUNCATE
#define HAVE_FTRUNCATE 1
#endif #endif
@ -1382,7 +1392,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence); 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); scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
off_t off = scm_to_off_t (offset); off_t off = scm_to_off_t (offset);
@ -1407,28 +1422,48 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
#ifdef __MINGW32__ #ifndef O_BINARY
/* Define this function since it is not supported under Windows. */ #define O_BINARY 0
static int truncate (char *file, int length) #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; int ret, fdes;
if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1)
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); 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_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length), (SCM object, SCM length),
"Truncates the object referred to by @var{object} to at most\n" "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
"@var{length} bytes. @var{object} can be a string containing a\n" "filename string, a port object, or an integer file descriptor.\n"
"file name or an integer file descriptor or a port.\n" "The return value is unspecified.\n"
"@var{length} may be omitted if @var{object} is not a file name,\n" "\n"
"in which case the truncation occurs at the current port\n" "For a port or file descriptor @var{length} can be omitted, in\n"
"position. The return value is unspecified.") "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 #define FUNC_NAME s_scm_truncate_file
{ {
int rv; int rv;
@ -1455,6 +1490,11 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object), SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
c_length)); 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)) else if (SCM_OPOUTPORTP (object))
{ {
off_t c_length = scm_to_off_t (length); off_t c_length = scm_to_off_t (length);

32
libguile/posix.c
View file

@ -157,6 +157,12 @@ extern char ** environ;
#define F_OK 0 #define F_OK 0
#endif #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 /* On NextStep, <utime.h> doesn't define struct utime, unless we
#define _POSIX_SOURCE before #including it. I think this is less #define _POSIX_SOURCE before #including it. I think this is less
of a kludge than defining struct utimbuf ourselves. */ of a kludge than defining struct utimbuf ourselves. */
@ -943,7 +949,12 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
scm_dynwind_unwind_handler (free_string_pointers, exec_argv, scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY); 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; SCM_SYSERROR;
/* not reached. */ /* not reached. */
@ -974,7 +985,12 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
scm_dynwind_unwind_handler (free_string_pointers, exec_argv, scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY); 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; SCM_SYSERROR;
/* not reached. */ /* not reached. */
@ -1013,7 +1029,17 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
scm_dynwind_unwind_handler (free_string_pointers, exec_env, scm_dynwind_unwind_handler (free_string_pointers, exec_env,
SCM_F_WIND_EXPLICITLY); 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; SCM_SYSERROR;
/* not reached. */ /* not reached. */

6
libguile/pthread-threads.h
View file

@ -66,8 +66,12 @@ extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
/* Onces /* Onces
*/ */
#define scm_i_pthread_once_t pthread_once_t #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 #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 /* Thread specific storage
*/ */

58
libguile/socket.c
View file

@ -98,9 +98,7 @@ SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
"and returned as a new integer.") "and returned as a new integer.")
#define FUNC_NAME s_scm_htonl #define FUNC_NAME s_scm_htonl
{ {
scm_t_uint32 c_in = SCM_NUM2ULONG (1, value); return scm_from_ulong (htonl (scm_to_uint32 (value)));
return scm_from_ulong (htonl (c_in));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -111,9 +109,7 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
"and returned as a new integer.") "and returned as a new integer.")
#define FUNC_NAME s_scm_ntohl #define FUNC_NAME s_scm_ntohl
{ {
scm_t_uint32 c_in = SCM_NUM2ULONG (1, value); return scm_from_ulong (ntohl (scm_to_uint32 (value)));
return scm_from_ulong (ntohl (c_in));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1459,25 +1455,34 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
(SCM sock, SCM str, SCM flags, SCM start, SCM end), (SCM sock, SCM str, SCM flags, SCM start, SCM end),
"Return data from the socket port @var{sock} and also\n" "Receive data from socket port @var{sock} (which must be already\n"
"information about where the data was received from.\n" "bound), returning the originating address as well as the data.\n"
"@var{sock} must already be bound to the address from which\n" "This is usually for use on datagram sockets, but can be used on\n"
"data is to be received. @code{str}, is a string into which the\n" "stream-oriented sockets too.\n"
"data will be written. The size of @var{str} limits the amount\n" "\n"
"of data which can be received: in the case of packet protocols,\n" "The data received is stored in the given @var{str}, using\n"
"if a packet larger than this limit is encountered then some\n" "either the whole string or just the region between the optional\n"
"data will be irrevocably lost.\n\n" "@var{start} and @var{end} positions. The size of @var{str}\n"
"The optional @var{flags} argument is a value or bitwise OR of\n" "limits the amount of data which can be received. For datagram\n"
"@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n" "protocols, if a packet larger than this is received then excess\n"
"The value returned is a pair: the @emph{car} is the number of\n" "bytes are irrevocably lost.\n"
"bytes read from the socket and the @emph{cdr} an address object\n" "\n"
"in the same form as returned by @code{accept}. The address\n" "The return value is a pair. The @code{car} is the number of\n"
"will given as @code{#f} if not available, as is usually the\n" "bytes read. The @code{cdr} is a socket address object which is\n"
"case for stream sockets.\n\n" "where the data come from, or @code{#f} if the origin is\n"
"The @var{start} and @var{end} arguments specify a substring of\n" "unknown.\n"
"@var{str} to which the data should be written.\n\n" "\n"
"Note that the data is read directly from the socket file\n" "The optional @var{flags} argument is a or bitwise OR\n"
"descriptor: any unread buffered port data is ignored.") "(@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 #define FUNC_NAME s_scm_recvfrom
{ {
int rv; int rv;
@ -1728,6 +1733,9 @@ scm_init_socket ()
#endif #endif
/* recv/send options. */ /* recv/send options. */
#ifdef MSG_DONTWAIT
scm_c_define ("MSG_DONTWAIT", scm_from_int (MSG_DONTWAIT));
#endif
#ifdef MSG_OOB #ifdef MSG_OOB
scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB)); scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB));
#endif #endif

18
libguile/stime.c
View file

@ -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_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_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7));
lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8)); 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 #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))) if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)))
lt->tm_zone = NULL; lt->tm_zone = NULL;
else else
@ -731,6 +733,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
{ {
struct tm t; struct tm t;
const char *fmt, *str, *rest; const char *fmt, *str, *rest;
long zoff;
SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (1, format);
SCM_VALIDATE_STRING (2, string); SCM_VALIDATE_STRING (2, string);
@ -748,6 +751,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
tm_init (tm_year); tm_init (tm_year);
tm_init (tm_wday); tm_init (tm_wday);
tm_init (tm_yday); tm_init (tm_yday);
#if HAVE_STRUCT_TM_TM_GMTOFF
tm_init (tm_gmtoff);
#endif
#undef tm_init #undef tm_init
/* GNU glibc strptime() "%s" is affected by the current timezone, since it /* 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; 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)); scm_from_signed_integer (rest - str));
} }
#undef FUNC_NAME #undef FUNC_NAME

10
libguile/threads.c
View file

@ -27,6 +27,11 @@
#endif #endif
#include <stdio.h> #include <stdio.h>
#include <assert.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 #if HAVE_SYS_TIME_H
#include <sys/time.h> #include <sys/time.h>
#endif #endif
@ -566,7 +571,8 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
} }
#if SCM_USE_PTHREAD_THREADS #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 #define HAVE_GET_THREAD_STACK_BASE
@ -600,7 +606,7 @@ get_thread_stack_base ()
} }
} }
#endif /* HAVE_PTHREAD_ATTR_GETSTACK */ #endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */
#else /* !SCM_USE_PTHREAD_THREADS */ #else /* !SCM_USE_PTHREAD_THREADS */

62
test-suite/ChangeLog
View file

@ -1,3 +1,29 @@
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> 2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/srfi-14.test: Use `define-module'. Use modules `(srfi * tests/srfi-14.test: Use `define-module'. Use modules `(srfi
@ -7,6 +33,42 @@
(every?, find-latin1-locale): New procedures. (every?, find-latin1-locale): New procedures.
(%latin1): New variable. (%latin1): New variable.
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> 2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
* Makefile.am (SCM_TESTS): Added `tests/structs.test'. * Makefile.am (SCM_TESTS): Added `tests/structs.test'.

1
test-suite/Makefile.am
View file

@ -36,6 +36,7 @@ SCM_TESTS = tests/alist.test \
tests/filesys.test \ tests/filesys.test \
tests/format.test \ tests/format.test \
tests/fractions.test \ tests/fractions.test \
tests/ftw.test \
tests/gc.test \ tests/gc.test \
tests/getopt-long.test \ tests/getopt-long.test \
tests/goops.test \ tests/goops.test \

11
test-suite/standalone/test-conversion.c
View file

@ -1010,10 +1010,9 @@ test_locale_strings ()
test_11 ("(string #\\f #\\nul)", NULL, 1, 0); test_11 ("(string #\\f #\\nul)", NULL, 1, 0);
} }
int static void
main (int argc, char *argv[]) tests (void *data, int argc, char **argv)
{ {
scm_init_guile();
test_is_signed_integer (); test_is_signed_integer ();
test_is_unsigned_integer (); test_is_unsigned_integer ();
test_to_signed_integer (); test_to_signed_integer ();
@ -1024,5 +1023,11 @@ main (int argc, char *argv[])
test_from_double (); test_from_double ();
test_to_double (); test_to_double ();
test_locale_strings (); test_locale_strings ();
}
int
main (int argc, char *argv[])
{
scm_boot_guile (argc, argv, tests, NULL);
return 0; return 0;
} }

9
test-suite/standalone/test-gh.c
View file

@ -67,11 +67,16 @@ test_gh_set_substr ()
assert (string_equal (string, "Frdarnitrnit!")); assert (string_equal (string, "Frdarnitrnit!"));
} }
static void
tests (void *data, int argc, char **argv)
{
test_gh_set_substr ();
}
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
scm_init_guile (); scm_boot_guile (argc, argv, tests, NULL);
test_gh_set_substr ();
return 0; return 0;
} }

11
test-suite/standalone/test-list.c
View file

@ -46,10 +46,15 @@ test_scm_list (void)
} }
} }
int static void
main (int argc, char **argv) tests (void *data, int argc, char **argv)
{ {
scm_init_guile();
test_scm_list (); test_scm_list ();
}
int
main (int argc, char *argv[])
{
scm_boot_guile (argc, argv, tests, NULL);
return 0; return 0;
} }

11
test-suite/standalone/test-num2integral.c
View file

@ -141,12 +141,17 @@ test_ulong_long ()
#endif /* SCM_SIZEOF_LONG_LONG != 0 */ #endif /* SCM_SIZEOF_LONG_LONG != 0 */
} }
static void
tests (void *data, int argc, char **argv)
{
test_long_long ();
test_ulong_long ();
}
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
scm_init_guile(); scm_boot_guile (argc, argv, tests, NULL);
test_long_long ();
test_ulong_long ();
return 0; return 0;
} }

12
test-suite/standalone/test-require-extension
View file

@ -2,10 +2,16 @@
set -e set -e
! guile -c '(require-extension 7)' 2> /dev/null # expect these to throw errors, if they succeed it's wrong
! guile -c '(require-extension (blarg))' 2> /dev/null #
! guile -c '(require-extension (srfi "foo"))' 2> /dev/null # (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 1)) (exit (procedure? take-right))'
guile -c '(require-extension (srfi))' guile -c '(require-extension (srfi))'

9
test-suite/standalone/test-round.c
View file

@ -113,10 +113,15 @@ test_scm_c_round ()
} }
} }
static void
tests (void *data, int argc, char **argv)
{
test_scm_c_round ();
}
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
scm_init_guile(); scm_boot_guile (argc, argv, tests, NULL);
test_scm_c_round ();
return 0; return 0;
} }

28
test-suite/tests/eval.test
View file

@ -99,10 +99,10 @@
)) ))
;;; ;;;
;;; apply ;;; call
;;; ;;;
(with-test-prefix "application" (with-test-prefix "call"
(with-test-prefix "wrong number of arguments" (with-test-prefix "wrong number of arguments"
@ -142,6 +142,30 @@
exception:wrong-num-args exception:wrong-num-args
((lambda (x y . rest) #f) 1)))) ((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 ;;; map
;;; ;;;

20
test-suite/tests/format.test
View file

@ -18,8 +18,10 @@
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA ;;;; Boston, MA 02110-1301 USA
(use-modules (test-suite lib) (define-module (test-format)
(ice-9 format)) #:use-module (test-suite lib)
#:use-module (ice-9 format))
;;; FORMAT Basic Output ;;; FORMAT Basic Output
@ -72,6 +74,20 @@
(pass-if "+1" (pass-if "+1"
(string=? (format #f "~@d" 1) "+1")))) (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"))))
;;; ;;;
;;; ~{ ;;; ~{
;;; ;;;

73
test-suite/tests/ftw.test Normal file
View file

@ -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)))))

145
test-suite/tests/numbers.test
View file

@ -71,6 +71,32 @@
(quotient (- n d -1) d) ;; neg/pos (quotient (- n d -1) d) ;; neg/pos
(quotient n d))) ;; pos/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+ ;;; 1+
;;; ;;;
@ -200,6 +226,36 @@
(pass-if "sqrt ((fixnum-max+1)^2 - 1)" (pass-if "sqrt ((fixnum-max+1)^2 - 1)"
(eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))))) (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? ;;; odd?
;;; ;;;
@ -2930,6 +2986,62 @@
(pass-if n (pass-if n
(= i (integer-length n)))))) (= 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? ;;; logbit?
;;; ;;;
@ -3035,3 +3147,36 @@
(lognot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))) (lognot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
(pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF (pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
(lognot #x-100000000000000000000000000000000)))) (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))))

16
test-suite/tests/popen.test
View file

@ -82,9 +82,10 @@
(port (with-error-to-port (cdr pair) (port (with-error-to-port (cdr pair)
(lambda () (lambda ()
(open-input-pipe (open-input-pipe
"exec 1>/dev/null; echo closed 1>&2; sleep 999"))))) "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
(read-char (car pair)) ;; wait for child to do its thing (close-port (cdr pair)) ;; write side
(and (char-ready? port) (and (char? (read-char (car pair))) ;; wait for child to do its thing
(char-ready? port)
(eof-object? (read-char port)))))) (eof-object? (read-char port))))))
;; ;;
@ -131,15 +132,16 @@
(port (with-error-to-port (cdr pair) (port (with-error-to-port (cdr pair)
(lambda () (lambda ()
(open-output-pipe (open-output-pipe
"exec 0</dev/null; echo closed 1>&2; sleep 999"))))) "exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
(read-char (car pair)) ;; wait for child to do its thing (close-port (cdr pair)) ;; write side
(catch 'system-error (and (char? (read-char (car pair))) ;; wait for child to do its thing
(catch 'system-error
(lambda () (lambda ()
(write-char #\x port) (write-char #\x port)
(force-output port) (force-output port)
#f) #f)
(lambda (key name fmt args errno-list) (lambda (key name fmt args errno-list)
(= (car errno-list) EPIPE)))))))) (= (car errno-list) EPIPE)))))))))
;; ;;
;; close-pipe ;; close-pipe

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

@ -538,20 +538,73 @@
(while (not (eof-object? (read-char port)))) (while (not (eof-object? (read-char port))))
(= 8 (port-column port)))))) (= 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 ;;; truncate-file
;;; ;;;
(with-test-prefix "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" (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" (pass-if "shorten"
(call-with-output-file (test-file) (call-with-output-file (test-file)
(lambda (port) (lambda (port)
(display "hello" port))) (display "hello" port)))
(truncate-file (test-file) 1) (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" (with-test-prefix "file descriptor"
@ -562,6 +615,16 @@
(let ((fd (open-fdes (test-file) O_RDWR))) (let ((fd (open-fdes (test-file) O_RDWR)))
(truncate-file fd 1) (truncate-file fd 1)
(close-fdes fd)) (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)))))) (eqv? 1 (stat:size (stat (test-file))))))
(with-test-prefix "file port" (with-test-prefix "file port"
@ -572,6 +635,15 @@
(display "hello" port))) (display "hello" port)))
(let ((port (open-file (test-file) "r+"))) (let ((port (open-file (test-file) "r+")))
(truncate-file port 1)) (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))))))) (eqv? 1 (stat:size (stat (test-file)))))))

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

@ -20,6 +20,27 @@
#:use-module (test-suite lib)) #: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 ;;; inet-ntop
;;; ;;;
@ -110,6 +131,25 @@
(and (= (sockaddr:fam sa) AF_UNIX) (and (= (sockaddr:fam sa) AF_UNIX)
(string=? (sockaddr:path sa) "/tmp/unix-socket")))))) (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))))
;;; ;;;

6
test-suite/tests/srfi-1.test
View file

@ -17,8 +17,10 @@
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA ;;;; Boston, MA 02110-1301 USA
(use-modules (srfi srfi-1) (define-module (test-srfi-1)
(test-suite lib)) #:use-module (test-suite lib)
#:use-module (srfi srfi-1))
(define (ref-delete x lst . proc) (define (ref-delete x lst . proc)
"Reference implemenation of srfi-1 `delete'." "Reference implemenation of srfi-1 `delete'."

60
test-suite/tests/srfi-9.test
View file

@ -18,25 +18,69 @@
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA ;;;; Boston, MA 02110-1301 USA
(use-modules (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? (define-record-type :foo (make-foo x) foo?
(x get-x) (y get-y set-y!)) (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)) (define f (make-foo 1))
(set-y! f 2) (set-y! f 2)
(with-test-prefix "record procedures" (define b (make-bar 123 456))
(pass-if "predicate" (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 "pass"
(foo? f)) (foo? f))
(pass-if "fail wrong record type"
(eq? #f (foo? b)))
(pass-if "fail number"
(eq? #f (foo? 123))))
(pass-if "accessor 1" (with-test-prefix "accessor"
(pass-if "get-x"
(= 1 (get-x f))) (= 1 (get-x f)))
(pass-if "get-y"
(pass-if "accessor 2"
(= 2 (get-y f))) (= 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) (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)))

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

@ -32,15 +32,9 @@
(pass-if (list "in another thread after error" t) (pass-if (list "in another thread after error" t)
(or (provided? 'threads) (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) (alarm 5)
(false-if-exception (gmtime t)) (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 () (gmtime t))
(lambda args #f)))) (lambda args #f))))
(alarm 0) (alarm 0)
@ -73,31 +67,187 @@
elapsed elapsed
(* 2 internal-time-units-per-second)))))) (* 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 ;;; strftime
;;; ;;;
;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX. (with-test-prefix "strftime"
;; 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. ;; 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
;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone ;; daylight savings zone name for the fake ZOW, and come back empty.
;; 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 ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone
;; set. For the details on that see ;; 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
;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722 ;; has to be set. For the details on that see
;; ;;
;; Not sure what to do about this in guile, it'd be nice for %Z to look at ;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722
;; tm:zone everywhere. ;;
;; ;; 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") ;; (pass-if "strftime %Z doesn't return garbage"
;; (set-tm:isdst t 0) ;; (let ((t (localtime (current-time))))
;; (string=? (strftime "%Z" t) ;; (set-tm:zone t "ZOW")
;; "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 ;;; strptime
@ -109,15 +259,31 @@
(or (defined? 'strptime) (throw 'unsupported)) (or (defined? 'strptime) (throw 'unsupported))
(or (provided? 'threads) (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) (alarm 5)
(false-if-exception (false-if-exception
(strptime "%a" "nosuchday")) (strptime "%a" "nosuchday"))
(thread-join (begin-thread (strptime "%d" "1"))) (join-thread (begin-thread (strptime "%d" "1")))
(alarm 0) (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))))))