From 8ab3d8a0681777eb329ac533be51d557267ccf32 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Oct 2006 23:40:48 +0000 Subject: [PATCH] merge from 1.8 branch --- .cvsignore | 1 + ChangeLog | 44 ++++ Makefile.am | 2 +- NEWS | 73 ++++-- configure.in | 99 +++++++- libguile/ChangeLog | 107 +++++++++ libguile/Makefile.am | 2 +- libguile/_scm.h | 2 + libguile/environments.c | 7 +- libguile/eval.c | 43 ++-- libguile/filesys.c | 44 ++-- libguile/fports.c | 89 ++++++- libguile/fports.h | 3 + libguile/gen-scmconfig.c | 4 + libguile/gen-scmconfig.h.in | 1 + libguile/numbers.c | 165 ++++++++++++- libguile/numbers.h | 4 + libguile/ports.c | 74 ++++-- libguile/posix.c | 32 ++- libguile/pthread-threads.h | 6 +- libguile/socket.c | 58 +++-- libguile/stime.c | 18 +- libguile/threads.c | 10 +- test-suite/ChangeLog | 62 +++++ test-suite/Makefile.am | 1 + test-suite/standalone/test-conversion.c | 11 +- test-suite/standalone/test-gh.c | 11 +- test-suite/standalone/test-list.c | 11 +- test-suite/standalone/test-num2integral.c | 11 +- test-suite/standalone/test-require-extension | 12 +- test-suite/standalone/test-round.c | 9 +- test-suite/tests/eval.test | 28 ++- test-suite/tests/format.test | 20 +- test-suite/tests/ftw.test | 73 ++++++ test-suite/tests/numbers.test | 145 +++++++++++ test-suite/tests/popen.test | 16 +- test-suite/tests/ports.test | 74 +++++- test-suite/tests/socket.test | 40 ++++ test-suite/tests/srfi-1.test | 6 +- test-suite/tests/srfi-9.test | 60 ++++- test-suite/tests/time.test | 238 ++++++++++++++++--- 41 files changed, 1513 insertions(+), 203 deletions(-) create mode 100644 test-suite/tests/ftw.test 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 + + 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 + + * configure.in (chsize, ftruncate, truncate): New tests, for mingw. + +2006-09-27 Kevin Ryde + + * configure.in (clog10): New test, not in mingw. + +2006-09-23 Kevin Ryde + + * configure.in (complex.h, complex double, csqrt): New tests. + 2006-09-20 Ludovic Courtès * 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 + + * 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 * 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 + + * configure.in (AC_CHECK_FUNCS): Add pthread_getattr_np. + +2006-07-24 Kevin Ryde + + * 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 + + * configure.in (AC_CHECK_MEMBERS): Test struct tm.tm_gmtoff. + 2006-06-13 Ludovic Courtès * 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. + +** stringinexact 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. -** stringinexact 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 +# is included +AC_CHECK_TYPES(complex double,,, +[#if HAVE_COMPLEX_H +#include +#endif]) + # On MacOS X 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 +/* "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 +#ifdef TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# 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_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 + + * 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 + + * 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 + + * 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 + + * _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 + + * numbers.c, numbers.h (scm_log, scm_log10, scm_exp, scm_sqrt): New + functions. + 2006-09-20 Ludovic Courtès * srfi-14.c: Include . 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 + + * socket.c (scm_init_socket): Add MSG_DONTWAIT. + (scm_recvfrom): Update docstring from manual. + 2006-08-31 Rob Browning * 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 + + * 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 * stacks.c (scm_last_stack_frame): Correct docstring (returns a frame, not a stack). +2006-07-25 Kevin Ryde + + * 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 + + * 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 + + * eval.c, filesys.c (alloca): Update etc blob, per current + autoconf recommendation. Should fix Solaris 10 reported by Claes + Wallin. + + * threads.c: Include , needed for memset() which is used by + FD_ZERO() on Solaris 10. Reported by Claes Wallin. + 2006-07-18 Rob Browning * 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 + + * 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 + + * 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 * 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 -# 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 +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include +# define alloca _alloca +#else +# include +# ifdef __cplusplus +extern "C" # endif -#endif -#if HAVE_MALLOC_H -#include /* alloca on mingw */ +void *alloca (size_t); #endif #include @@ -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 #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 -# 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 +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include +# define alloca _alloca +#else +# include +# ifdef __cplusplus +extern "C" # endif -#endif -#if HAVE_MALLOC_H -#include /* alloca on mingw, though its not used on that system */ +void *alloca (size_t); #endif #include @@ -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 #endif @@ -46,6 +48,7 @@ #endif #include +#include #include "libguile/iselect.h" @@ -53,9 +56,33 @@ #ifdef __MINGW32__ # include # include -# 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 #include +#if HAVE_COMPLEX_H +#include +#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 #include +#include /* 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 #endif -#ifdef __MINGW32__ -#include +/* 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 + ... but it lies. */ +#if ! HAVE_DECL_SETHOSTNAME +int sethostname (char *name, size_t namelen); +#endif + /* On NextStep, 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 #include + +#ifdef HAVE_STRING_H +#include /* for memset used by FD_ZERO on Solaris 10 */ +#endif + #if HAVE_SYS_TIME_H #include #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 + + * tests/ftw.test: New file. + * Makefile.am (SCM_TESTS): Add it. + +2006-10-03 Kevin Ryde + + * tests/eval.test (apply): New tests, exercising scm_tc7_subr_2o which + had lacked some arg count checking. + +2006-09-26 Kevin Ryde + + * tests/ports.test (seek): New tests. + (truncate-file): More tests. + +2006-09-23 Kevin Ryde + + * 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 * 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 + + * tests/format.test (~f): Test leading zeros bugfix. + +2006-08-25 Kevin Ryde + + * 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 + + * 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 + + * 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 + + * tests/socket.test (htonl, ntohl): New tests. + +2006-07-06 Kevin Ryde + + * tests/time.test (localtime, mktime, strptime): More tests. + 2006-06-13 Ludovic Courtès * 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" @@ -142,6 +142,30 @@ exception:wrong-num-args ((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 @@ -72,6 +74,20 @@ (pass-if "+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")))) + ;;; ;;; ~{ ;;; 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+ ;;; @@ -200,6 +226,36 @@ (pass-if "sqrt ((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? ;;; @@ -2930,6 +2986,62 @@ (pass-if 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? ;;; @@ -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&2; sleep 999"))))) - (read-char (car pair)) ;; wait for child to do its thing - (catch 'system-error + "exec 0&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 @@ -538,20 +538,73 @@ (while (not (eof-object? (read-char 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 ;;; (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) @@ -73,31 +67,187 @@ elapsed (* 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)))))) -- 2.20.1