mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 17:50:29 +02:00
merge from 1.8
This commit is contained in:
Kevin Ryde
parent
cea95a2fa1
commit
23d7256628
20 changed files with 445 additions and 106 deletions
|
|
@ -1,3 +1,33 @@
|
|||
<<<<<<< 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
|
||||
|
|
@ -8,12 +38,44 @@
|
|||
* 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
|
||||
|
|
@ -30,7 +92,35 @@
|
|||
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
|
||||
|
|
@ -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 <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
|
||||
|
|
|
|||
|
|
@ -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; }
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@
|
|||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <fcntl.h> /* for mingw */
|
||||
#include <signal.h>
|
||||
#include <stdio.h>
|
||||
#include <errno.h>
|
||||
|
|
@ -36,6 +37,14 @@
|
|||
#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
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 ("#<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);
|
||||
|
|
@ -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 */
|
||||
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
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!):
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,15 +1,48 @@
|
|||
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
|
||||
|
|
@ -29,7 +62,7 @@
|
|||
|
||||
* 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'.
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
;;;
|
||||
;;; /
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue