+<<<<<<< ChangeLog
+2007-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <hanwen@lilypond.org>
* throw.c (scm_ithrow): print out key symbol and string arguments
* read.c (s_scm_read_hash_extend): document #f argument to
read-hash-extend.
+2007-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <hanwen@lilypond.org>
* 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 <user42@zip.com.au>
+
+ * 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 <user42@zip.com.au>
+
+ * 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 <hanwen@lilypond.org>
* numbers.c (scm_i_fraction_reduce): move logic into
SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR,
SCM_FRACTION_REDUCED.
-
+2006-12-16 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <user42@zip.com.au>
+
+ * scmsigs.c: Conditionalize process.h, add io.h believe needed for
+ _pipe on mingw.
+
+2006-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <fcntl.h> and <process.h> needed by mingw. Copy the
+ fallback pipe() using _pipe() from posix.c. Reported by Nils Durner.
+
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <ludovic.courtes@laas.fr>
* libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES
`array-in-bounds?' for arrays with a rank greater than one and
with different lower bounds for each dimension.
+2006-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <user42@zip.com.au>
+
+ * 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 <ludovic.courtes@laas.fr>
* libguile/vectors.c (scm_vector_to_list): Fixed list
.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; }
#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
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)
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);
-/* 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
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
+
\f
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 */
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"
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);
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));
/* 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
{
int rv;
char *c_str = scm_to_locale_string (str);
-#ifdef __MINGW32__
- size_t len = strlen (c_str);
-#endif
if (strchr (c_str, '=') == NULL)
{
/* 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, "=");
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. */
#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);
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;
}
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;
}
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;
}
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;
}
-/* 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
"@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;
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,
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,
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"
# include <config.h>
#endif
+#include <fcntl.h> /* for mingw */
#include <signal.h>
#include <stdio.h>
#include <errno.h>
#include "libguile/validate.h"
#include "libguile/scmsigs.h"
+#ifdef HAVE_IO_H
+#include <io.h> /* for mingw _pipe() */
+#endif
+
+#ifdef HAVE_PROCESS_H
+#include <process.h> /* for mingw */
+#endif
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
/* 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
\f
}
#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];
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)
{
"@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;
}
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 ("#<thread ", port);
- scm_uintprint ((size_t)t->pthread, 10, port);
+ scm_uintprint (id, 10, port);
scm_puts (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
scm_puts (")>", port);
}
#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 *
}
}
-#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 */
#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 */
+2006-12-02 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <user42@zip.com.au>
* srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!):
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
+2007-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <hanwen@lilypond.org>
* tests/numbers.test ("equal?"): add case for reduction of
rational numbers.
-2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <ludovic.courtes@laas.fr>
* tests/unif.test (syntax): New test prefix. Check syntax for
negative lower bounds and negative lengths (reported by Gyula
Szavai) as well as `array-in-bounds?'.
-2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-12-09 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-use-srfi: New test.
+ * standalone/Makefile.am (TESTS): Add it.
+
+2006-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * 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 <user42@zip.com.au>
+
+ * 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 <ludovic.courtes@laas.fr>
* test-suite/tests/vectors.test: Use `define-module'.
(vector->list): New test prefix. "Shared array" test contributed
* tests/environments.test: Comment out all tests in this file.
-2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a
typo: `thrown' instead of `throw'.
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)
snarfcppopts = \
$(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir)
-%.x: %.c
+SUFFIXES = .x
+.c.x:
${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts)
CLEANFILES = *.x
check_PROGRAMS += test-conversion
TESTS += test-conversion
+# test-use-srfi
+TESTS += test-use-srfi
+
all-local:
cd ${srcdir} && chmod u+x ${check_SCRIPTS}
(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
;;;
(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)))
(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)))
(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)))))
;;;
;;; /
HCoop / bpt / guile.git / commitdiff