From 23d72566286b3b2b6fec9548cbfdb5d79685e973 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Jan 2007 23:42:45 +0000 Subject: [PATCH] merge from 1.8 --- libguile/ChangeLog | 106 +++++++++++++++++++++++++++++- libguile/Makefile.am | 2 +- libguile/deprecated.h | 4 +- libguile/eval.c | 2 +- libguile/feature.c | 18 ++++- libguile/feature.h | 1 + libguile/filesys.c | 40 +++++------ libguile/numbers.c | 16 ++++- libguile/posix.c | 75 +++++++++++++-------- libguile/print.c | 6 ++ libguile/regex-posix.c | 27 +++++--- libguile/scmsigs.c | 24 +++++-- libguile/threads.c | 56 ++++++++++++++-- libguile/version.h.in | 12 ++-- srfi/ChangeLog | 6 ++ srfi/srfi-60.c | 2 +- test-suite/ChangeLog | 39 ++++++++++- test-suite/standalone/Makefile.am | 8 ++- test-suite/tests/eval.test | 27 ++++++++ test-suite/tests/numbers.test | 80 ++++++++++++++++------ 20 files changed, 445 insertions(+), 106 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b2244a975..fed459b90 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,33 @@ +<<<<<<< ChangeLog +2007-01-16 Kevin Ryde + + * feature.c, feature.h (scm_set_program_arguments_scm): New function, + implementing `set-program-arguments'. + + * filesys.c (scm_init_filesys): Use scm_from_int rather than + scm_from_long for O_RDONLY, O_WRONLY, O_RDWR, O_CREAT, O_EXCL, + O_NOCTTY, O_TRUNC, O_APPEND, O_NONBLOCK, O_NDELAY, O_SYNC and + O_LARGEFILE. These are all int not long, per arg to open(). + (scm_init_filesys): Use scm_from_int rather than scm_from_long for + F_DUPFD, F_GETFD, F_SETFD, F_GETFL, F_SETFL, F_GETOWN, F_SETOWN, these + are all ints (per command arg to fcntl). Likewise FD_CLOEXEC which is + an int arg to fcntl. + + * posix.c (scm_putenv): Correction to "len" variable, was defined only + for __MINGW32__ but used under any !HAVE_UNSETENV (such as solaris). + Move it to where it's used. Reported by Hugh Sasse. + + * regex-posix.c (scm_regexp_exec): Remove SCM_CRITICAL_SECTION_START + and SCM_CRITICAL_SECTION_END, believe not needed. Their placement + meant #\nul in the input (detected by scm_to_locale_string) and a bad + flags arg (detected by scm_to_int) would throw from a critical + section, causing an abort(). + + * regex-posix.c (scm_init_regex_posix): Use scm_from_int for + REG_BASIC, REG_EXTENDED, REG_ICASE, REG_NEWLINE, REG_NOTBOL, + REG_NOTEOL; they're all ints not longs (per args to regcomp and + regexec). + 2007-01-10 Han-Wen Nienhuys * throw.c (scm_ithrow): print out key symbol and string arguments @@ -8,12 +38,44 @@ * read.c (s_scm_read_hash_extend): document #f argument to read-hash-extend. +2007-01-04 Kevin Ryde + + * deprecated.h (scm_create_hook), version.h.in (scm_major_version, + scm_minor_version, scm_micro_version, scm_effective_version, + scm_version, scm_init_version): Use SCM_API instead of just extern, + for the benefit of mingw. Reported by Cesar Strauss. + 2007-01-03 Han-Wen Nienhuys * gc.c (s_scm_gc_stats): return an entry for total-cells-allocated too. (gc_update_stats): update scm_gc_cells_allocated_acc too. +2006-12-27 Kevin Ryde + + * threads.c (get_thread_stack_base): In mingw with pthreads we can use + the basic scm_get_stack_base. As advised by Nils Durner. + + * threads.c (get_thread_stack_base): Add a version using + pthread_get_stackaddr_np (when available), for the benefit of MacOS. + As advised by Heikki Lindholm. + + * scmsigs.c (signal_delivery_thread): Restrict scm_i_pthread_sigmask + to HAVE_PTHREAD_SIGMASK, it doesn't exist on mingw. Reported by Nils + Durner. + +2006-12-24 Kevin Ryde + + * posix.c (scm_kill): When only raise() is available, throw an ENOSYS + error if pid is not our own process, instead of silently doing nothing. + + * print.c (scm_write, scm_display, scm_write_char): Disable port close + on EPIPE. This was previously disabled but introduction of HAVE_PIPE + check in configure.in unintentionally enabled it. Believe that + testing errno after scm_prin1 or scm_putc is bogus, a long ago error + can leave errno in that state. popen.test "no duplicates" output test + provoked that. + 2006-12-23 Han-Wen Nienhuys * numbers.c (scm_i_fraction_reduce): move logic into @@ -30,7 +92,35 @@ SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR, SCM_FRACTION_REDUCED. - +2006-12-16 Kevin Ryde + + * scmsigs.c (scm_raise): Use raise() rather than kill(), as this is + more direct for a procedure called raise. + (kill): Remove mingw fake fallback. + +2006-12-15 Kevin Ryde + + * scmsigs.c: Conditionalize process.h, add io.h believe needed for + _pipe on mingw. + +2006-12-14 Kevin Ryde + + * threads.c (thread_print): Cope with the case where pthread_t is a + struct, as found on mingw. Can't just cast to size_t for printing. + Reported by Nils Durner. + + * scmsigs.c: Add and needed by mingw. Copy the + fallback pipe() using _pipe() from posix.c. Reported by Nils Durner. + +2006-12-13 Kevin Ryde + + * eval.c (scm_m_define): Set 'name procedure property on any + scm_procedure_p, not just SCM_CLOSUREP. In particular this picks up + procedures with setters as used in srfi-17. + + * posix.c (scm_crypt): Check for NULL return from crypt(), which the + linux man page says is a possibility. + 2006-12-12 Ludovic Courtès * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES @@ -44,6 +134,20 @@ `array-in-bounds?' for arrays with a rank greater than one and with different lower bounds for each dimension. +2006-12-05 Kevin Ryde + + * numbers.c (scm_product): For flonum*inum and complex*inum, return + exact 0 if inum==0. Already done for inum*flonum and inum*complex, + and as per R5RS section "Exactness". + +2006-12-03 Kevin Ryde + + * Makefile.am (.c.doc): Remove the "test -n" apparently attempting to + allow $AWK from the environment to override. It had syntax gremlins, + and the presence of a $(AWK) variable set by AC_PROG_AWK in the + Makefile stopped it having any effect. Use just $(AWK), which can be + overridden with "make AWK=xxx" in the usual way if desired. + 2006-11-29 Ludovic Courtès * libguile/vectors.c (scm_vector_to_list): Fixed list diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 47220ddb6..273f5aa02 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -285,7 +285,7 @@ SUFFIXES = .x .doc .c.x: ./guile-snarf -o $@ $< $(snarfcppopts) .c.doc: - -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) + -$(AWK) -f ./guile-func-name-check $< (./guile-snarf-docs $(snarfcppopts) $< | \ ./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index bbd8bc07a..9a0862c3e 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -5,7 +5,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright (C) 2003,2004, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -164,7 +164,7 @@ SCM_API SCM scm_make_gsubr_with_generic (const char *name, SCM (*fcn)(), SCM *gf); -extern SCM scm_create_hook (const char* name, int n_args); +SCM_API SCM scm_create_hook (const char* name, int n_args); #define SCM_LIST0 SCM_EOL #define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) diff --git a/libguile/eval.c b/libguile/eval.c index db5c00529..26d90f1f6 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1235,7 +1235,7 @@ scm_m_define (SCM expr, SCM env) SCM tmp = value; while (SCM_MACROP (tmp)) tmp = SCM_MACRO_CODE (tmp); - if (SCM_CLOSUREP (tmp) + if (scm_is_true (scm_procedure_p (tmp)) /* Only the first definition determines the name. */ && scm_is_false (scm_procedure_property (tmp, scm_sym_name))) scm_set_procedure_property_x (tmp, scm_sym_name, variable); diff --git a/libguile/feature.c b/libguile/feature.c index 1d44a7790..6cd0e54ab 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -76,6 +76,22 @@ scm_set_program_arguments (int argc, char **argv, char *first) scm_fluid_set_x (progargs_fluid, args); } +SCM_DEFINE (scm_set_program_arguments_scm, "set-program-arguments", 1, 0, 0, + (SCM lst), + "Set the command line arguments to be returned by\n" + "@code{program-arguments} (and @code{command-line}). @var{lst}\n" + "should be a list of strings, the first of which is the program\n" + "name (either a script name, or just @code{\"guile\"}).\n" + "\n" + "Program arguments are held in a fluid and therefore have a\n" + "separate value in each Guile thread. Neither the list nor the\n" + "strings within it are copied, so should not be modified later.") +#define FUNC_NAME s_scm_set_program_arguments_scm +{ + return scm_fluid_set_x (progargs_fluid, lst); +} +#undef FUNC_NAME + diff --git a/libguile/feature.h b/libguile/feature.h index 58db46422..f12f292ce 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -27,6 +27,7 @@ SCM_API void scm_add_feature (const char* str); SCM_API SCM scm_program_arguments (void); SCM_API void scm_set_program_arguments (int argc, char **argv, char *first); +SCM_API SCM scm_set_program_arguments_scm (SCM lst); SCM_API void scm_init_feature (void); #endif /* SCM_FEATURE_H */ diff --git a/libguile/filesys.c b/libguile/filesys.c index 72b45e92a..1798bb698 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1681,65 +1681,65 @@ scm_init_filesys () scm_dot_string = scm_permanent_object (scm_from_locale_string (".")); #ifdef O_RDONLY - scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY)); + scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY)); #endif #ifdef O_WRONLY - scm_c_define ("O_WRONLY", scm_from_long (O_WRONLY)); + scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY)); #endif #ifdef O_RDWR - scm_c_define ("O_RDWR", scm_from_long (O_RDWR)); + scm_c_define ("O_RDWR", scm_from_int (O_RDWR)); #endif #ifdef O_CREAT - scm_c_define ("O_CREAT", scm_from_long (O_CREAT)); + scm_c_define ("O_CREAT", scm_from_int (O_CREAT)); #endif #ifdef O_EXCL - scm_c_define ("O_EXCL", scm_from_long (O_EXCL)); + scm_c_define ("O_EXCL", scm_from_int (O_EXCL)); #endif #ifdef O_NOCTTY - scm_c_define ("O_NOCTTY", scm_from_long (O_NOCTTY)); + scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY)); #endif #ifdef O_TRUNC - scm_c_define ("O_TRUNC", scm_from_long (O_TRUNC)); + scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC)); #endif #ifdef O_APPEND - scm_c_define ("O_APPEND", scm_from_long (O_APPEND)); + scm_c_define ("O_APPEND", scm_from_int (O_APPEND)); #endif #ifdef O_NONBLOCK - scm_c_define ("O_NONBLOCK", scm_from_long (O_NONBLOCK)); + scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK)); #endif #ifdef O_NDELAY - scm_c_define ("O_NDELAY", scm_from_long (O_NDELAY)); + scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY)); #endif #ifdef O_SYNC - scm_c_define ("O_SYNC", scm_from_long (O_SYNC)); + scm_c_define ("O_SYNC", scm_from_int (O_SYNC)); #endif #ifdef O_LARGEFILE - scm_c_define ("O_LARGEFILE", scm_from_long (O_LARGEFILE)); + scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE)); #endif #ifdef F_DUPFD - scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD)); + scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD)); #endif #ifdef F_GETFD - scm_c_define ("F_GETFD", scm_from_long (F_GETFD)); + scm_c_define ("F_GETFD", scm_from_int (F_GETFD)); #endif #ifdef F_SETFD - scm_c_define ("F_SETFD", scm_from_long (F_SETFD)); + scm_c_define ("F_SETFD", scm_from_int (F_SETFD)); #endif #ifdef F_GETFL - scm_c_define ("F_GETFL", scm_from_long (F_GETFL)); + scm_c_define ("F_GETFL", scm_from_int (F_GETFL)); #endif #ifdef F_SETFL - scm_c_define ("F_SETFL", scm_from_long (F_SETFL)); + scm_c_define ("F_SETFL", scm_from_int (F_SETFL)); #endif #ifdef F_GETOWN - scm_c_define ("F_GETOWN", scm_from_long (F_GETOWN)); + scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN)); #endif #ifdef F_SETOWN - scm_c_define ("F_SETOWN", scm_from_long (F_SETOWN)); + scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN)); #endif #ifdef FD_CLOEXEC - scm_c_define ("FD_CLOEXEC", scm_from_long (FD_CLOEXEC)); + scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC)); #endif #include "libguile/filesys.x" diff --git a/libguile/numbers.c b/libguile/numbers.c index 2a833c83c..a0ef29cdd 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4481,7 +4481,12 @@ scm_product (SCM x, SCM y) else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) - return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); + { + /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ + if (scm_is_eq (y, SCM_INUM0)) + return y; + return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); + } else if (SCM_BIGP (y)) { double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); @@ -4501,8 +4506,13 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (x)) { if (SCM_I_INUMP (y)) - return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); + { + /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ + if (scm_is_eq (y, SCM_INUM0)) + return y; + return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), + SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); + } else if (SCM_BIGP (y)) { double z = mpz_get_d (SCM_I_BIG_MPZ (y)); diff --git a/libguile/posix.c b/libguile/posix.c index 8129c6413..dda20e8e1 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -491,11 +491,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, /* Signal values are interned in scm_init_posix(). */ #ifdef HAVE_KILL if (kill (scm_to_int (pid), scm_to_int (sig)) != 0) + SCM_SYSERROR; #else + /* Mingw has raise(), but not kill(). (Other raw DOS environments might + be similar.) Use raise() when the requested pid is our own process, + otherwise bomb. */ if (scm_to_int (pid) == getpid ()) - if (raise (scm_to_int (sig)) != 0) + { + if (raise (scm_to_int (sig)) != 0) + { + err: + SCM_SYSERROR; + } + else + { + errno = ENOSYS; + goto err; + } + } #endif - SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1316,9 +1330,6 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, { int rv; char *c_str = scm_to_locale_string (str); -#ifdef __MINGW32__ - size_t len = strlen (c_str); -#endif if (strchr (c_str, '=') == NULL) { @@ -1333,6 +1344,7 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, /* On e.g. Win32 hosts putenv() called with 'name=' removes the environment variable 'name'. */ int e; + size_t len = strlen (c_str); char *ptr = scm_malloc (len + 2); strcpy (ptr, c_str); strcpy (ptr+len, "="); @@ -1352,26 +1364,29 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, by getenv. It's not enough just to modify the string we set, because MINGW putenv copies it. */ - if (c_str[len-1] == '=') - { - char *ptr = scm_malloc (len+2); - strcpy (ptr, c_str); - strcpy (ptr+len, " "); - rv = putenv (ptr); - if (rv < 0) - { - int eno = errno; - free (c_str); - errno = eno; - SCM_SYSERROR; - } - /* truncate to just the name */ - c_str[len-1] = '\0'; - ptr = getenv (c_str); - if (ptr) - ptr[0] = '\0'; - return SCM_UNSPECIFIED; - } + { + size_t len = strlen (c_str); + if (c_str[len-1] == '=') + { + char *ptr = scm_malloc (len+2); + strcpy (ptr, c_str); + strcpy (ptr+len, " "); + rv = putenv (ptr); + if (rv < 0) + { + int eno = errno; + free (c_str); + errno = eno; + SCM_SYSERROR; + } + /* truncate to just the name */ + c_str[len-1] = '\0'; + ptr = getenv (c_str); + if (ptr) + ptr[0] = '\0'; + return SCM_UNSPECIFIED; + } + } #endif /* __MINGW32__ */ /* Leave c_str in the environment. */ @@ -1565,7 +1580,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, #define FUNC_NAME s_scm_crypt { SCM ret; - char *c_key, *c_salt; + char *c_key, *c_salt, *c_ret; scm_dynwind_begin (0); scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); @@ -1575,8 +1590,14 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, c_salt = scm_to_locale_string (salt); scm_dynwind_free (c_salt); - ret = scm_from_locale_string (crypt (c_key, c_salt)); + /* The Linux crypt(3) man page says crypt will return NULL and set errno + on error. (Eg. ENOSYS if legal restrictions mean it cannot be + implemented). */ + c_ret = crypt (c_key, c_salt); + if (c_ret == NULL) + SCM_SYSERROR; + ret = scm_from_locale_string (c_ret); scm_dynwind_end (); return ret; } diff --git a/libguile/print.c b/libguile/print.c index efd51ce06..8bed72297 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -926,11 +926,13 @@ scm_write (SCM obj, SCM port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write); scm_prin1 (obj, port, 1); +#if 0 #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) scm_close_port (port); # endif +#endif #endif return SCM_UNSPECIFIED; } @@ -947,11 +949,13 @@ scm_display (SCM obj, SCM port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display); scm_prin1 (obj, port, 0); +#if 0 #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) scm_close_port (port); # endif +#endif #endif return SCM_UNSPECIFIED; } @@ -1084,11 +1088,13 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, SCM_VALIDATE_OPORT_VALUE (2, port); scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port)); +#if 0 #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) scm_close_port (port); # endif +#endif #endif return SCM_UNSPECIFIED; } diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index fcef50006..d280c82b6 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -218,6 +218,17 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, "@end table") #define FUNC_NAME s_scm_regexp_exec { + /* We used to have an SCM_DEFER_INTS, and then later an + SCM_CRITICAL_SECTION_START, around the regexec() call. Can't quite + remember what defer ints was for, but a critical section would only be + wanted now if we think regexec() is not thread-safe. The posix spec + + http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html + + reads like regexec is meant to be both thread safe and reentrant + (mentioning simultaneous use in threads, and in signal handlers). So + for now believe no protection needed. */ + int status, nmatches, offset; regmatch_t *matches; char *c_str; @@ -245,7 +256,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, whole regexp, so add 1 to nmatches. */ nmatches = SCM_RGX(rx)->re_nsub + 1; - SCM_CRITICAL_SECTION_START; matches = scm_malloc (sizeof (regmatch_t) * nmatches); c_str = scm_to_locale_string (substr); status = regexec (SCM_RGX (rx), c_str, nmatches, matches, @@ -269,7 +279,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, scm_from_long (matches[i].rm_eo + offset))); } free (matches); - SCM_CRITICAL_SECTION_END; if (status != 0 && status != REG_NOMATCH) scm_error_scm (scm_regexp_error_key, @@ -287,14 +296,14 @@ scm_init_regex_posix () scm_set_smob_free (scm_tc16_regex, regex_free); /* Compilation flags. */ - scm_c_define ("regexp/basic", scm_from_long (REG_BASIC)); - scm_c_define ("regexp/extended", scm_from_long (REG_EXTENDED)); - scm_c_define ("regexp/icase", scm_from_long (REG_ICASE)); - scm_c_define ("regexp/newline", scm_from_long (REG_NEWLINE)); + scm_c_define ("regexp/basic", scm_from_int (REG_BASIC)); + scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED)); + scm_c_define ("regexp/icase", scm_from_int (REG_ICASE)); + scm_c_define ("regexp/newline", scm_from_int (REG_NEWLINE)); /* Execution flags. */ - scm_c_define ("regexp/notbol", scm_from_long (REG_NOTBOL)); - scm_c_define ("regexp/noteol", scm_from_long (REG_NOTEOL)); + scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL)); + scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL)); #include "libguile/regex-posix.x" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 3452f911c..9b1c96d42 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -22,6 +22,7 @@ # include #endif +#include /* for mingw */ #include #include #include @@ -36,6 +37,14 @@ #include "libguile/validate.h" #include "libguile/scmsigs.h" +#ifdef HAVE_IO_H +#include /* for mingw _pipe() */ +#endif + +#ifdef HAVE_PROCESS_H +#include /* for mingw */ +#endif + #ifdef HAVE_UNISTD_H #include #endif @@ -50,7 +59,7 @@ /* This weird comma expression is because Sleep is void under Windows. */ #define sleep(sec) (Sleep ((sec) * 1000), 0) #define usleep(usec) (Sleep ((usec) / 1000), 0) -#define kill(pid, sig) raise (sig) +#define pipe(fd) _pipe (fd, 256, O_BINARY) #endif @@ -106,6 +115,12 @@ close_1 (SCM proc, SCM arg) } #if SCM_USE_PTHREAD_THREADS +/* On mingw there's no notion of inter-process signals, only a raise() + within the process itself which apparently invokes the registered handler + immediately. Not sure how well the following code will cope in this + case. It builds but it may not offer quite the same scheme-level + semantics as on a proper system. If you're relying on much in the way of + signal handling on mingw you probably lose anyway. */ static int signal_pipe[2]; @@ -149,12 +164,13 @@ read_without_guile (int fd, char *buf, size_t n) static SCM signal_delivery_thread (void *data) { - sigset_t all_sigs; int n, sig; char sigbyte; - +#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */ + sigset_t all_sigs; sigfillset (&all_sigs); scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL); +#endif while (1) { @@ -616,7 +632,7 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0, "@var{sig} is as described for the kill procedure.") #define FUNC_NAME s_scm_raise { - if (kill (getpid (), scm_to_int (sig)) != 0) + if (raise (scm_to_int (sig)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } diff --git a/libguile/threads.c b/libguile/threads.c index 6e2bce9c7..7e1bfde7f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -141,9 +141,32 @@ thread_mark (SCM obj) static int thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { + /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a + struct. A cast like "(unsigned long) t->pthread" is a syntax error in + the struct case, hence we go via a union, and extract according to the + size of pthread_t. */ + union { + scm_i_pthread_t p; + unsigned short us; + unsigned int ui; + unsigned long ul; + scm_t_uintmax um; + } u; scm_i_thread *t = SCM_I_THREAD_DATA (exp); + scm_i_pthread_t p = t->pthread; + scm_t_uintmax id; + u.p = p; + if (sizeof (p) == sizeof (unsigned short)) + id = u.us; + else if (sizeof (p) == sizeof (unsigned int)) + id = u.ui; + else if (sizeof (p) == sizeof (unsigned long)) + id = u.ul; + else + id = u.um; + scm_puts ("#pthread, 10, port); + scm_uintprint (id, 10, port); scm_puts (" (", port); scm_uintprint ((scm_t_bits)t, 16, port); scm_puts (")>", port); @@ -571,9 +594,11 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) } #if SCM_USE_PTHREAD_THREADS -/* pthread_getattr_np not available on MacOS X and Solaris 10. */ -#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP +#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP +/* This method for GNU/Linux and perhaps some other systems. + It's not for MacOS X or Solaris 10, since pthread_getattr_np is not + available on them. */ #define HAVE_GET_THREAD_STACK_BASE static SCM_STACKITEM * @@ -606,7 +631,30 @@ get_thread_stack_base () } } -#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */ +#elif HAVE_PTHREAD_GET_STACKADDR_NP +/* This method for MacOS X. + It'd be nice if there was some documentation on pthread_get_stackaddr_np, + but as of 2006 there's nothing obvious at apple.com. */ +#define HAVE_GET_THREAD_STACK_BASE +static SCM_STACKITEM * +get_thread_stack_base () +{ + return pthread_get_stackaddr_np (pthread_self ()); +} + +#elif defined (__MINGW32__) +/* This method for mingw. In mingw the basic scm_get_stack_base can be used + in any thread. We don't like hard-coding the name of a system, but there + doesn't seem to be a cleaner way of knowing scm_get_stack_base can + work. */ +#define HAVE_GET_THREAD_STACK_BASE +static SCM_STACKITEM * +get_thread_stack_base () +{ + return scm_get_stack_base (); +} + +#endif /* pthread methods of get_thread_stack_base */ #else /* !SCM_USE_PTHREAD_THREADS */ diff --git a/libguile/version.h.in b/libguile/version.h.in index 691898cd5..1d8f27750 100644 --- a/libguile/version.h.in +++ b/libguile/version.h.in @@ -30,12 +30,12 @@ #define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@ #define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@ -extern SCM scm_major_version (void); -extern SCM scm_minor_version (void); -extern SCM scm_micro_version (void); -extern SCM scm_effective_version (void); -extern SCM scm_version (void); -extern void scm_init_version (void); +SCM_API SCM scm_major_version (void); +SCM_API SCM scm_minor_version (void); +SCM_API SCM scm_micro_version (void); +SCM_API SCM scm_effective_version (void); +SCM_API SCM scm_version (void); +SCM_API void scm_init_version (void); #endif /* SCM_VERSION_H */ diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 1d77d7747..e662163fb 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2006-12-02 Kevin Ryde + + * srfi-60.c (scm_srfi60_copy_bit): Should be long not int for fixnum + bitshift, fixes 64-bit systems setting a bit between 32 and 63. + Reported by Aaron M. Ucko, Debian bug 396119. + 2006-05-28 Kevin Ryde * srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!): diff --git a/srfi/srfi-60.c b/srfi/srfi-60.c index 257b1387f..f631c6447 100644 --- a/srfi/srfi-60.c +++ b/srfi/srfi-60.c @@ -86,7 +86,7 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, if (ii < SCM_LONG_BIT-1) { nn &= ~(1L << ii); /* zap bit at index */ - nn |= (bb << ii); /* insert desired bit */ + nn |= ((long) bb << ii); /* insert desired bit */ return scm_from_long (nn); } else diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 11018c308..c49acb15f 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,15 +1,48 @@ +2007-01-16 Kevin Ryde + + * tests/regexp.test (regexp-exec): Further tests, in particular #\nul + in input and bad flags args which had been provoking abort()s. + 2006-12-24 Han-Wen Nienhuys * tests/numbers.test ("equal?"): add case for reduction of rational numbers. -2006-12-12 Ludovic Courtès +2006-12-13 Kevin Ryde + + * tests/eval.test: Exercise top-level define setting procedure-name. + * tests/srfi-17.test (car): Check procedure-name property. + + * tests/numbers.test (*): Exercise multiply by exact 0 giving exact 0. + +2006-12-12 Ludovic Courtès * tests/unif.test (syntax): New test prefix. Check syntax for negative lower bounds and negative lengths (reported by Gyula Szavai) as well as `array-in-bounds?'. -2006-11-29 Ludovic Courtès +2006-12-09 Kevin Ryde + + * standalone/test-use-srfi: New test. + * standalone/Makefile.am (TESTS): Add it. + +2006-12-03 Kevin Ryde + + * standalone/Makefile.am (.x): Change from %.c %.x style to .c.x style + since the former is a GNU make extension. (Rule now as per + libguile/Makefile.am.) + + * standalone/Makefile.am (test_cflags): Change from := to plain =, as + the former is not portable (according to automake). + +2006-12-02 Kevin Ryde + + * tests/numbers.test (min, max): Correction to big/real and real/big + tests, `big*5' will round on a 64-bit system. And use `eqv?' to + ensure intended exact vs inexact is checked. Reported by Aaron + M. Ucko, Debian bug 396119. + +2006-11-29 Ludovic Courtès * test-suite/tests/vectors.test: Use `define-module'. (vector->list): New test prefix. "Shared array" test contributed @@ -29,7 +62,7 @@ * tests/environments.test: Comment out all tests in this file. -2006-10-26 Ludovic Courtès +2006-10-26 Ludovic Courtès * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a typo: `thrown' instead of `throw'. diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index ec6481029..b95fdd0f9 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -29,7 +29,7 @@ BUILT_SOURCES = TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env" -test_cflags := \ +test_cflags = \ -I$(top_srcdir)/test-suite/standalone \ -I$(top_srcdir) \ -I$(top_srcdir)/libguile-ltdl $(EXTRA_DEFS) $(GUILE_CFLAGS) @@ -38,7 +38,8 @@ AM_LDFLAGS = $(GUILE_CFLAGS) snarfcppopts = \ $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir) -%.x: %.c +SUFFIXES = .x +.c.x: ${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts) CLEANFILES = *.x @@ -102,6 +103,9 @@ test_conversion_LDADD = ${top_builddir}/libguile/libguile.la check_PROGRAMS += test-conversion TESTS += test-conversion +# test-use-srfi +TESTS += test-use-srfi + all-local: cd ${srcdir} && chmod u+x ${check_SCRIPTS} diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 4adf0312f..99beca418 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -201,6 +201,33 @@ (map + '(1 2) '(3))) ))) +;;; +;;; define with procedure-name +;;; + +(define old-procnames-flag (memq 'procnames (debug-options))) +(debug-enable 'procnames) + +;; names are only set on top-level procedures (currently), so these can't be +;; hidden in a let +;; +(define foo-closure (lambda () "hello")) +(define bar-closure foo-closure) +(define foo-pws (make-procedure-with-setter car set-car!)) +(define bar-pws foo-pws) + +(with-test-prefix "define set procedure-name" + + (pass-if "closure" + (eq? 'foo-closure (procedure-name bar-closure))) + + (pass-if "procedure-with-setter" + (eq? 'foo-pws (pk (procedure-name bar-pws))))) + +(if old-procnames-flag + (debug-enable 'procnames) + (debug-disable 'procnames)) + ;;; ;;; promises ;;; diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index fd1ced2d2..b28b4ef97 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2243,19 +2243,17 @@ (with-test-prefix "big / real" (pass-if (nan? (max big*5 +nan.0))) - (pass-if (= big*5 (max big*5 -inf.0))) - (pass-if (= +inf.0 (max big*5 +inf.0))) - (pass-if (= 1.0 (max (- big*5) 1.0))) - (pass-if (inexact? (max big*5 1.0))) - (pass-if (= (exact->inexact big*5) (max big*5 1.0)))) + (pass-if (eqv? (exact->inexact big*5) (max big*5 -inf.0))) + (pass-if (eqv? (exact->inexact big*5) (max big*5 1.0))) + (pass-if (eqv? +inf.0 (max big*5 +inf.0))) + (pass-if (eqv? 1.0 (max (- big*5) 1.0)))) (with-test-prefix "real / big" (pass-if (nan? (max +nan.0 big*5))) - (pass-if (= +inf.0 (max +inf.0 big*5))) - (pass-if (= big*5 (max -inf.0 big*5))) - (pass-if (= 1.0 (max 1.0 (- big*5)))) - (pass-if (inexact? (max 1.0 big*5))) - (pass-if (= (exact->inexact big*5) (max 1.0 big*5)))) + (pass-if (eqv? (exact->inexact big*5) (max -inf.0 big*5))) + (pass-if (eqv? (exact->inexact big*5) (max 1.0 big*5))) + (pass-if (eqv? +inf.0 (max +inf.0 big*5))) + (pass-if (eqv? 1.0 (max 1.0 (- big*5))))) (with-test-prefix "frac / frac" (pass-if (= 2/3 (max 1/2 2/3))) @@ -2370,19 +2368,17 @@ (with-test-prefix "big / real" (pass-if (nan? (min big*5 +nan.0))) - (pass-if (= big*5 (min big*5 +inf.0))) - (pass-if (= -inf.0 (min big*5 -inf.0))) - (pass-if (= 1.0 (min big*5 1.0))) - (pass-if (inexact? (min (- big*5) 1.0))) - (pass-if (= (exact->inexact (- big*5)) (min (- big*5) 1.0)))) + (pass-if (eqv? (exact->inexact big*5) (min big*5 +inf.0))) + (pass-if (eqv? -inf.0 (min big*5 -inf.0))) + (pass-if (eqv? 1.0 (min big*5 1.0))) + (pass-if (eqv? (exact->inexact (- big*5)) (min (- big*5) 1.0)))) (with-test-prefix "real / big" (pass-if (nan? (min +nan.0 big*5))) - (pass-if (= big*5 (min +inf.0 big*5))) - (pass-if (= -inf.0 (min -inf.0 big*5))) - (pass-if (= 1.0 (min 1.0 big*5))) - (pass-if (inexact? (min 1.0 (- big*5)))) - (pass-if (= (exact->inexact (- big*5)) (min 1.0 (- big*5))))) + (pass-if (eqv? (exact->inexact big*5) (min +inf.0 big*5))) + (pass-if (eqv? -inf.0 (min -inf.0 big*5))) + (pass-if (eqv? 1.0 (min 1.0 big*5))) + (pass-if (eqv? (exact->inexact (- big*5)) (min 1.0 (- big*5))))) (with-test-prefix "frac / frac" (pass-if (= 1/2 (min 1/2 2/3))) @@ -2463,10 +2459,52 @@ (with-test-prefix "*" + (with-test-prefix "inum * bignum" + + (pass-if "0 * 2^256 = 0" + (eqv? 0 (* 0 (ash 1 256))))) + + (with-test-prefix "inum * flonum" + + (pass-if "0 * 1.0 = 0" + (eqv? 0 (* 0 1.0)))) + + (with-test-prefix "inum * complex" + + (pass-if "0 * 1+1i = 0" + (eqv? 0 (* 0 1+1i)))) + + (with-test-prefix "inum * frac" + + (pass-if "0 * 2/3 = 0" + (eqv? 0 (* 0 2/3)))) + + (with-test-prefix "bignum * inum" + + (pass-if "2^256 * 0 = 0" + (eqv? 0 (* (ash 1 256) 0)))) + + (with-test-prefix "flonum * inum" + + ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0 + (pass-if "1.0 * 0 = 0" + (eqv? 0 (* 1.0 0)))) + + (with-test-prefix "complex * inum" + + ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0 + (pass-if "1+1i * 0 = 0" + (eqv? 0 (* 1+1i 0)))) + (pass-if "complex * bignum" (let ((big (ash 1 90))) (= (make-rectangular big big) - (* 1+1i big))))) + (* 1+1i big)))) + + (with-test-prefix "frac * inum" + + (pass-if "2/3 * 0 = 0" + (eqv? 0 (* 2/3 0))))) ;;; ;;; / -- 2.20.1