summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.cvsignore1
-rw-r--r--ChangeLog44
-rw-r--r--Makefile.am2
-rw-r--r--NEWS73
-rw-r--r--configure.in99
-rw-r--r--libguile/ChangeLog107
-rw-r--r--libguile/Makefile.am2
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/environments.c7
-rw-r--r--libguile/eval.c43
-rw-r--r--libguile/filesys.c44
-rw-r--r--libguile/fports.c89
-rw-r--r--libguile/fports.h3
-rw-r--r--libguile/gen-scmconfig.c4
-rw-r--r--libguile/gen-scmconfig.h.in1
-rw-r--r--libguile/numbers.c165
-rw-r--r--libguile/numbers.h4
-rw-r--r--libguile/ports.c74
-rw-r--r--libguile/posix.c32
-rw-r--r--libguile/pthread-threads.h6
-rw-r--r--libguile/socket.c58
-rw-r--r--libguile/stime.c18
-rw-r--r--libguile/threads.c10
-rw-r--r--test-suite/ChangeLog62
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/standalone/test-conversion.c11
-rw-r--r--test-suite/standalone/test-gh.c11
-rw-r--r--test-suite/standalone/test-list.c11
-rw-r--r--test-suite/standalone/test-num2integral.c11
-rwxr-xr-xtest-suite/standalone/test-require-extension12
-rw-r--r--test-suite/standalone/test-round.c9
-rw-r--r--test-suite/tests/eval.test28
-rw-r--r--test-suite/tests/format.test20
-rw-r--r--test-suite/tests/ftw.test73
-rw-r--r--test-suite/tests/numbers.test145
-rw-r--r--test-suite/tests/popen.test16
-rw-r--r--test-suite/tests/ports.test74
-rw-r--r--test-suite/tests/socket.test40
-rw-r--r--test-suite/tests/srfi-1.test6
-rw-r--r--test-suite/tests/srfi-9.test60
-rw-r--r--test-suite/tests/time.test238
41 files changed, 1513 insertions, 203 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
diff --git a/ChangeLog b/ChangeLog
index 0df690615..0aef5db3f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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>
* configure.in: Check for `isblank ()'.
@@ -5,6 +30,11 @@
* 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,6 +43,20 @@
* 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>
* NEWS: Mentioned the new behavior of `equal?' for structures.
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
diff --git a/NEWS b/NEWS
index 0cfba4ac8..d5e136af6 100644
--- a/NEWS
+++ b/NEWS
@@ -22,34 +22,73 @@ 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]
+
+* 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
diff --git a/configure.in b/configure.in
index e06a4981a..9578cdfc8 100644
--- a/configure.in
+++ b/configure.in
@@ -523,14 +523,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 +600,31 @@ 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
#
-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:
# 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 +643,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 +926,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 +971,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 +979,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?
@@ -997,6 +1059,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"
@@ -1007,7 +1071,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.
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 4b7b805f8..01a17aa77 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -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>
* srfi-14.c: Include <config.h>. Define `_GNU_SOURCE'.
@@ -20,6 +67,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 +84,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
@@ -49,6 +137,25 @@
* numbers.c (guile_ieee_init): Use regular ANSI C casts rather
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>
* eq.c: Include "struct.h", "goops.h" and "objects.h".
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 68b5dfdc7..bf121161f 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -220,7 +220,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..906de3780 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -167,6 +167,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/environments.c b/libguile/environments.c
index a94f119cd..5d15f36bc 100644
--- a/libguile/environments.c
+++ b/libguile/environments.c
@@ -687,9 +687,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 9fe419137..db5c00529 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 563557e82..010e5dda6 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;
@@ -583,25 +610,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);
}
}
@@ -611,13 +638,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)
@@ -626,7 +653,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)
@@ -635,6 +662,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)
{
@@ -644,6 +704,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/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/numbers.c b/libguile/numbers.c
index caaa6e2fc..2aa2de81b 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;
@@ -5977,6 +6004,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 2628cfc06..a1ebb57d5 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -27,10 +27,12 @@
#include <stdio.h>
#include <errno.h>
+#include <fcntl.h> /* for chsize on mingw */
#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"
@@ -66,9 +68,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
@@ -1382,7 +1392,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);
@@ -1407,28 +1422,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;
@@ -1455,6 +1490,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..8a83a1e7e 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -157,6 +157,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 +949,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 +985,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 +1029,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. */
diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h
index 06e735f75..015a70767 100644
--- a/libguile/pthread-threads.h
+++ b/libguile/pthread-threads.h
@@ -66,8 +66,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/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 20b8e38c9..428133d8a 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -27,6 +27,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
@@ -566,7 +571,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
@@ -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 */
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 1a5c26a56..a35e29704 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -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>
* tests/srfi-14.test: Use `define-module'. Use modules `(srfi
@@ -7,6 +33,42 @@
(every?, find-latin1-locale): New procedures.
(%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>
* Makefile.am (SCM_TESTS): Added `tests/structs.test'.
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index c0efc78a9..2714eeb1e 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -36,6 +36,7 @@ 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 \
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/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/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/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-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))))))