[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-81-g28d5d25
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-81-g28d5d25 |
|
Date: |
Tue, 16 Jul 2013 05:33:39 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=28d5d2537c0321643c3b511a2195cd491204e7f2
The branch, master has been updated
via 28d5d2537c0321643c3b511a2195cd491204e7f2 (commit)
via 95ed221785f5b1203e998823455f682c1830498b (commit)
via ba0e46ea1b56ff6164daa9d5fe0778029ca3beee (commit)
via 01329288918de3ab4b7d85d4c0c5b83b0edfc179 (commit)
via 4cc2e41cf78bccf13d7dfc44f74b7c11d13dbf33 (commit)
via 7e8166f5bdb526c021c826943aaf050134cccc83 (commit)
via e8f329972666db6c9d4644619473e14d54db3a80 (commit)
via 10454601e03a20cc121d06d8004f96bb2a3b6fb5 (commit)
via b16bf64639d457f9cfe8dc7bf80464cd2b86a622 (commit)
via 41f2f14bd97f3889075419a11e7a555463bd9a0d (commit)
via ee49b1684b94627c364e2362e54a596183906021 (commit)
via 9f7914d39a5047c8d6b2cff554b8f575dcc32302 (commit)
via 09fb52b6c908606a0f4a5d5d118128c02de606c4 (commit)
via 556d35af88f01ba8cb6019de3a54e30e3f7f59d8 (commit)
via b518c6a0b3b429615d889aebe73862f76bbbf59c (commit)
via dba6f4e2e377a036df666cf101129f80ab3e6864 (commit)
via 2a1d8403c07704a40279e58373e6605e0c1f6dd7 (commit)
via 8b12a34c8f13d9b2917ffbecc5d59151e5d38a5b (commit)
via 79a9a2c271f18d1cd2031b23c682dadd0cf31bae (commit)
via 4af0d97ee65f298be33d5959cd36a5bea8797be9 (commit)
via 6fe2803b45fbbd676625c9d665151e5a8a57aca5 (commit)
via e006d87ba5942b6e49b39b951413dfe63785a398 (commit)
via 72d4abda1d2766096d246a2c0fe75c1522782934 (commit)
from 178a40928ab5221f6ce57c5af1067abe30a342b3 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 28d5d2537c0321643c3b511a2195cd491204e7f2
Merge: 178a409 95ed221
Author: Mark H Weaver <address@hidden>
Date: Tue Jul 16 01:33:27 2013 -0400
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/keywords.c
libguile/vm.c
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 4 +-
THANKS | 1 +
doc/ref/api-control.texi | 3 +-
doc/ref/api-macros.texi | 8 +-
doc/ref/api-scheduling.texi | 6 +-
libguile/error.c | 3 +-
libguile/eval.c | 12 +-
libguile/keywords.c | 20 ++--
libguile/numbers.c | 115 ++++++++++++++------
libguile/posix.c | 4 +-
libguile/socket.c | 2 +-
libguile/threads.c | 4 +-
libguile/vm-engine.c | 6 +-
libguile/vm-i-scheme.c | 8 +-
libguile/vm-i-system.c | 4 +-
libguile/vm.c | 12 +-
module/ice-9/boot-9.scm | 7 +-
module/ice-9/eval.scm | 4 +-
module/rnrs/arithmetic/bitwise.scm | 6 +-
module/web/uri.scm | 11 +-
test-suite/standalone/test-language | 4 +-
.../standalone/test-scm-c-bind-keyword-arguments.c | 65 ++++++++---
test-suite/standalone/test-system-cmds | 8 +-
test-suite/standalone/test-unwind.c | 13 ++-
test-suite/tests/coverage.test | 31 +++---
test-suite/tests/filesys.test | 3 +-
test-suite/tests/foreign.test | 16 ++-
test-suite/tests/numbers.test | 83 ++++++++++++++-
test-suite/tests/optargs.test | 54 ++++++----
test-suite/tests/r6rs-arithmetic-bitwise.test | 4 +-
test-suite/tests/web-uri.test | 4 +-
31 files changed, 371 insertions(+), 154 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index ce2af7a..a24e860 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -8,7 +8,9 @@
(eval . (put 'pass-if 'scheme-indent-function 1))
(eval . (put 'pass-if-exception 'scheme-indent-function 2))
(eval . (put 'pass-if-equal 'scheme-indent-function 2))
- (eval . (put 'with-test-prefix 'scheme-indent-function 1))))
+ (eval . (put 'with-test-prefix 'scheme-indent-function 1))
+ (eval . (put 'with-code-coverage 'scheme-indent-function 1))
+ (eval . (put 'with-statprof 'scheme-indent-function 1))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
diff --git a/THANKS b/THANKS
index a01dcfb..c517cf7 100644
--- a/THANKS
+++ b/THANKS
@@ -77,6 +77,7 @@ For fixes or providing information which led to a fix:
Fu-gangqiang
Aidan Gauland
Peter Gavin
+ Andrew Gaylard
Nils Gey
Eric Gillespie, Jr
Didier Godefroy
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index f34074e..026308c 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1424,7 +1424,8 @@ Guile) formats using @code{display} and @code{~S} (was
@code{system-error} then it should be a list containing the
Unix @code{errno} value; If @var{key} is @code{signal} then it
should be a list containing the Unix signal number; If
address@hidden is @code{out-of-range} or @code{wrong-type-arg},
address@hidden is @code{out-of-range}, @code{wrong-type-arg},
+or @code{keyword-argument-error},
it is a list containing the bad value; otherwise
it will usually be @code{#f}.
@end deffn
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 09ffee6..82a2c07 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -122,8 +122,8 @@ same @var{letrec-syntax}.
exp)
((my-or exp rest ...)
(let ((t exp))
- (if exp
- exp
+ (if t
+ t
(my-or rest ...)))))))
(my-or #f "rockaway beach"))
@result{} "rockaway beach"
@@ -323,8 +323,8 @@ Consider the definition of @code{my-or} from the previous
section:
exp)
((my-or exp rest ...)
(let ((t exp))
- (if exp
- exp
+ (if t
+ t
(my-or rest ...))))))
@end example
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index b230821..0d036be 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -446,9 +446,9 @@ which the calling thread will wait to be signalled before
returning.
@code{wait-condition-variable}, except that the mutex is left in an
unlocked state when the function returns.)
-When @var{timeout} is also given, it specifies a point in time where
-the waiting should be aborted. It can be either an integer as
-returned by @code{current-time} or a pair as returned by
+When @var{timeout} is also given and not false, it specifies a point in
+time where the waiting should be aborted. It can be either an integer
+as returned by @code{current-time} or a pair as returned by
@code{gettimeofday}. When the waiting is aborted, @code{#f} is
returned. Otherwise the function returns @code{#t}.
@end deffn
diff --git a/libguile/error.c b/libguile/error.c
index 0df4c73..26cf5b6 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -80,7 +80,8 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
"@code{system-error} then it should be a list containing the\n"
"Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
"should be a list containing the Unix signal number; If\n"
- "@var{key} is @code{out-of-range} or @code{wrong-type-arg},\n"
+ "@var{key} is @code{out-of-range}, @code{wrong-type-arg},\n"
+ "or @code{keyword-argument-error}, "
"it is a list containing the bad value; otherwise\n"
"it will usually be @code{#f}.")
#define FUNC_NAME s_scm_error_scm
diff --git a/libguile/eval.c b/libguile/eval.c
index b245026..f5e1524 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -162,18 +162,18 @@ static void error_used_before_defined (void)
"Variable used before given a value", SCM_EOL, SCM_BOOL_F);
}
-static void error_invalid_keyword (SCM proc)
+static void error_invalid_keyword (SCM proc, SCM obj)
{
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Invalid keyword"), SCM_EOL,
- SCM_BOOL_F);
+ scm_list_1 (obj));
}
-static void error_unrecognized_keyword (SCM proc)
+static void error_unrecognized_keyword (SCM proc, SCM kw)
{
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Unrecognized keyword"), SCM_EOL,
- SCM_BOOL_F);
+ scm_list_1 (kw));
}
@@ -818,10 +818,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
break;
}
if (scm_is_null (walk) && scm_is_false (aok))
- error_unrecognized_keyword (proc);
+ error_unrecognized_keyword (proc, k);
}
if (scm_is_pair (args) && scm_is_false (rest))
- error_invalid_keyword (proc);
+ error_invalid_keyword (proc, CAR (args));
/* Now fill in unbound values, evaluating init expressions in their
appropriate environment. */
diff --git a/libguile/keywords.c b/libguile/keywords.c
index 96c0b01..f630259 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008,
2009, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
+ * 2006, 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -157,9 +158,11 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest,
{
/* KW_OR_ARG is not in the list of expected keywords. */
if (!(flags & SCM_ALLOW_OTHER_KEYS))
- scm_error (scm_keyword_argument_error,
- subr, "Unrecognized keyword",
- SCM_EOL, SCM_BOOL_F);
+ scm_error_scm (scm_keyword_argument_error,
+ scm_from_locale_string (subr),
+ scm_from_latin1_string
+ ("Unrecognized keyword"),
+ SCM_EOL, scm_list_1 (kw_or_arg));
break;
}
arg_p = va_arg (va, SCM *);
@@ -181,9 +184,10 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest,
/* The next argument is not a keyword, or is a singleton
keyword at the end of REST. */
if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS))
- scm_error (scm_keyword_argument_error,
- subr, "Invalid keyword",
- SCM_EOL, SCM_BOOL_F);
+ scm_error_scm (scm_keyword_argument_error,
+ scm_from_locale_string (subr),
+ scm_from_latin1_string ("Invalid keyword"),
+ SCM_EOL, scm_list_1 (kw_or_arg));
/* Advance REST. */
rest = tail;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index d941133..9857e18 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -100,6 +100,13 @@ typedef scm_t_signed_bits scm_t_inum;
#define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
#define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
+/* Test an inum to see if it can be converted to a double without loss
+ of precision. Note that this will sometimes return 0 even when 1
+ could have been returned, e.g. for large powers of 2. It is designed
+ to be a fast check to optimize common cases. */
+#define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
+ (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
+ || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
#if ! HAVE_DECL_MPZ_INITS
@@ -506,10 +513,10 @@ scm_i_divide2double (SCM n, SCM d)
if (SCM_LIKELY (SCM_I_INUMP (d)))
{
- if (SCM_LIKELY (SCM_I_INUMP (n)
- && (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG
- || (SCM_I_INUM (n) < (1L << DBL_MANT_DIG)
- && SCM_I_INUM (d) < (1L << DBL_MANT_DIG)))))
+ if (SCM_LIKELY
+ (SCM_I_INUMP (n)
+ && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n))
+ && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d))))
/* If both N and D can be losslessly converted to doubles, then
we can rely on IEEE floating point to do proper rounding much
faster than we can. */
@@ -6535,9 +6542,11 @@ scm_num_eq_p (SCM x, SCM y)
to a double and compare.
But on a 64-bit system an inum is bigger than a double and
- casting it to a double (call that dxx) will round. dxx is at
- worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
- an integer and fits a long. So we cast yy to a long and
+ casting it to a double (call that dxx) will round.
+ Although dxx will not in general be equal to xx, dxx will
+ always be an integer and within a factor of 2 of xx, so if
+ dxx==yy, we know that yy is an integer and fits in
+ scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
compare with plain xx.
An alternative (for any size system actually) would be to check
@@ -6552,8 +6561,14 @@ scm_num_eq_p (SCM x, SCM y)
|| xx == (scm_t_signed_bits) yy));
}
else if (SCM_COMPLEXP (y))
- return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
- && (0.0 == SCM_COMPLEX_IMAG (y)));
+ {
+ /* see comments with inum/real above */
+ double ry = SCM_COMPLEX_REAL (y);
+ return scm_from_bool ((double) xx == ry
+ && 0.0 == SCM_COMPLEX_IMAG (y)
+ && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
+ || xx == (scm_t_signed_bits) ry));
+ }
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
@@ -6610,24 +6625,21 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_BIGP (y))
{
int cmp;
- if (isnan (SCM_REAL_VALUE (x)))
+ if (isnan (xx))
return SCM_BOOL_F;
- cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
scm_remember_upto_here_1 (y);
return scm_from_bool (0 == cmp);
}
else if (SCM_REALP (y))
- return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
+ return scm_from_bool (xx == SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
- return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
- && (0.0 == SCM_COMPLEX_IMAG (y)));
+ return scm_from_bool ((xx == SCM_COMPLEX_REAL (y))
+ && (0.0 == SCM_COMPLEX_IMAG (y)));
else if (SCM_FRACTIONP (y))
{
- double xx = SCM_REAL_VALUE (x);
- if (isnan (xx))
+ if (isnan (xx) || isinf (xx))
return SCM_BOOL_F;
- if (isinf (xx))
- return scm_from_bool (xx < 0.0);
x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again;
}
@@ -6638,8 +6650,15 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_COMPLEXP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y))
- && (SCM_COMPLEX_IMAG (x) == 0.0));
+ {
+ /* see comments with inum/real above */
+ double rx = SCM_COMPLEX_REAL (x);
+ scm_t_signed_bits yy = SCM_I_INUM (y);
+ return scm_from_bool (rx == (double) yy
+ && 0.0 == SCM_COMPLEX_IMAG (x)
+ && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
+ || (scm_t_signed_bits) rx == yy));
+ }
else if (SCM_BIGP (y))
{
int cmp;
@@ -6653,20 +6672,18 @@ scm_num_eq_p (SCM x, SCM y)
}
else if (SCM_REALP (y))
return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
- && (SCM_COMPLEX_IMAG (x) == 0.0));
+ && (SCM_COMPLEX_IMAG (x) == 0.0));
else if (SCM_COMPLEXP (y))
return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
- && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
+ && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG
(y)));
else if (SCM_FRACTIONP (y))
{
double xx;
if (SCM_COMPLEX_IMAG (x) != 0.0)
return SCM_BOOL_F;
xx = SCM_COMPLEX_REAL (x);
- if (isnan (xx))
+ if (isnan (xx) || isinf (xx))
return SCM_BOOL_F;
- if (isinf (xx))
- return scm_from_bool (xx < 0.0);
x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again;
}
@@ -6683,10 +6700,8 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_REALP (y))
{
double yy = SCM_REAL_VALUE (y);
- if (isnan (yy))
+ if (isnan (yy) || isinf (yy))
return SCM_BOOL_F;
- if (isinf (yy))
- return scm_from_bool (0.0 < yy);
y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again;
}
@@ -6696,10 +6711,8 @@ scm_num_eq_p (SCM x, SCM y)
if (SCM_COMPLEX_IMAG (y) != 0.0)
return SCM_BOOL_F;
yy = SCM_COMPLEX_REAL (y);
- if (isnan (yy))
+ if (isnan (yy) || isinf(yy))
return SCM_BOOL_F;
- if (isinf (yy))
- return scm_from_bool (0.0 < yy);
y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again;
}
@@ -6760,7 +6773,25 @@ scm_less_p (SCM x, SCM y)
return scm_from_bool (sgn > 0);
}
else if (SCM_REALP (y))
- return scm_from_bool ((double) xx < SCM_REAL_VALUE (y));
+ {
+ /* We can safely take the ceiling of y without changing the
+ result of x<y, given that x is an integer. */
+ double yy = ceil (SCM_REAL_VALUE (y));
+
+ /* In the following comparisons, it's important that the right
+ hand side always be a power of 2, so that it can be
+ losslessly converted to a double even on 64-bit
+ machines. */
+ if (yy >= (double) (SCM_MOST_POSITIVE_FIXNUM+1))
+ return SCM_BOOL_T;
+ else if (!(yy > (double) SCM_MOST_NEGATIVE_FIXNUM))
+ /* The condition above is carefully written to include the
+ case where yy==NaN. */
+ return SCM_BOOL_F;
+ else
+ /* yy is a finite integer that fits in an inum. */
+ return scm_from_bool (xx < (scm_t_inum) yy);
+ }
else if (SCM_FRACTIONP (y))
{
/* "x < a/b" becomes "x*b < a" */
@@ -6805,7 +6836,25 @@ scm_less_p (SCM x, SCM y)
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y));
+ {
+ /* We can safely take the floor of x without changing the
+ result of x<y, given that y is an integer. */
+ double xx = floor (SCM_REAL_VALUE (x));
+
+ /* In the following comparisons, it's important that the right
+ hand side always be a power of 2, so that it can be
+ losslessly converted to a double even on 64-bit
+ machines. */
+ if (xx < (double) SCM_MOST_NEGATIVE_FIXNUM)
+ return SCM_BOOL_T;
+ else if (!(xx < (double) (SCM_MOST_POSITIVE_FIXNUM+1)))
+ /* The condition above is carefully written to include the
+ case where xx==NaN. */
+ return SCM_BOOL_F;
+ else
+ /* xx is a finite integer that fits in an inum. */
+ return scm_from_bool ((scm_t_inum) xx < SCM_I_INUM (y));
+ }
else if (SCM_BIGP (y))
{
int cmp;
diff --git a/libguile/posix.c b/libguile/posix.c
index 822599d..0443f95 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -910,7 +910,7 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
#ifdef HAVE_SETEGID
-SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
+SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
(SCM id),
"Sets the effective group ID to the integer @var{id}, provided the
process\n"
"has appropriate privileges. If effective IDs are not supported,
the\n"
@@ -921,7 +921,7 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
{
int rv;
-#ifdef HAVE_SETEUID
+#ifdef HAVE_SETEGID
rv = setegid (scm_to_int (id));
#else
rv = setgid (scm_to_int (id));
diff --git a/libguile/socket.c b/libguile/socket.c
index 7e735f4..34bc21a 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1645,7 +1645,7 @@ scm_init_socket ()
#ifdef AF_UNSPEC
scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC));
#endif
-#ifdef AF_UNIX
+#if defined HAVE_UNIX_DOMAIN_SOCKETS && defined AF_UNIX
scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX));
#endif
#ifdef AF_INET
diff --git a/libguile/threads.c b/libguile/threads.c
index ef771dc..99582cc 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -326,7 +326,7 @@ remqueue (SCM q, SCM c)
if (scm_is_eq (p, c))
{
if (scm_is_eq (c, SCM_CAR (q)))
- SCM_SETCAR (q, SCM_CDR (c));
+ SCM_SETCAR (q, scm_is_eq (prev, q) ? SCM_EOL : prev);
SCM_SETCDR (prev, SCM_CDR (c));
/* GC-robust */
@@ -1712,7 +1712,7 @@ SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2,
0,
{
SCM_VALIDATE_CONDVAR (2, cond);
- if (! (SCM_UNBNDP (timeout)))
+ if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout))
{
to_timespec (timeout, &cwaittime);
waittime = &cwaittime;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 8b11e7f..9b12d3e 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1555,11 +1555,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
break;
}
VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
- vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM
(fp)));
+ vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM
(fp),
+ LOCAL_REF (ntotal
+ n)));
n++;
}
else
- VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword
(SCM_FRAME_PROGRAM (fp)));
+ VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword
(SCM_FRAME_PROGRAM (fp),
+ LOCAL_REF
(ntotal + n)));
if (has_rest)
{
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index ef3d02b..2f1d5fe 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -402,8 +402,12 @@ VM_DEFINE_FUNCTION (161, ash, "ash", 2)
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
{
if (SCM_I_INUM (y) < 0)
- /* Right shift, will be a fixnum. */
- RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
+ {
+ /* Right shift, will be a fixnum. */
+ if (SCM_I_INUM (y) > -SCM_I_FIXNUM_BIT)
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
+ /* fall through */
+ }
else
/* Left shift. See comments in scm_ash. */
{
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 248db9a..0973792 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -697,12 +697,12 @@ VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5,
0, 0)
}
VM_ASSERT (scm_is_pair (walk)
|| (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
- vm_error_kwargs_unrecognized_keyword (program));
+ vm_error_kwargs_unrecognized_keyword (program, sp[nkw]));
nkw++;
}
else
VM_ASSERT (kw_and_rest_flags & F_REST,
- vm_error_kwargs_invalid_keyword (program));
+ vm_error_kwargs_invalid_keyword (program, sp[nkw]));
}
NEXT;
diff --git a/libguile/vm.c b/libguile/vm.c
index f431912..dd016b7 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -416,8 +416,8 @@ static void vm_error_unbound_fluid (SCM proc, SCM fluid)
SCM_NORETURN SCM_NOINLI
static void vm_error_not_a_variable (const char *func_name, SCM x)
SCM_NORETURN SCM_NOINLINE;
static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN
SCM_NOINLINE;
-static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN
SCM_NOINLINE;
-static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN
SCM_NOINLINE;
+static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN
SCM_NOINLINE;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
SCM_NORETURN SCM_NOINLINE;
static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
@@ -486,19 +486,19 @@ vm_error_kwargs_length_not_even (SCM proc)
}
static void
-vm_error_kwargs_invalid_keyword (SCM proc)
+vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
{
scm_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Invalid keyword"),
- SCM_EOL, SCM_BOOL_F);
+ SCM_EOL, scm_list_1 (obj));
}
static void
-vm_error_kwargs_unrecognized_keyword (SCM proc)
+vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
{
scm_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Unrecognized keyword"),
- SCM_EOL, SCM_BOOL_F);
+ SCM_EOL, scm_list_1 (kw));
}
static void
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 48aec49..39d313f 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -977,12 +977,17 @@ information is unavailable."
(_ (default-printer)))
args))
+ (define (keyword-error-printer port key args default-printer)
+ (let ((message (cadr args))
+ (faulty (car (cadddr args)))) ; I won't do it again, I promise.
+ (format port "~a: ~s" message faulty)))
+
(define (getaddrinfo-error-printer port key args default-printer)
(format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
(set-exception-printer! 'goops-error scm-error-printer)
(set-exception-printer! 'host-not-found scm-error-printer)
- (set-exception-printer! 'keyword-argument-error scm-error-printer)
+ (set-exception-printer! 'keyword-argument-error keyword-error-printer)
(set-exception-printer! 'misc-error scm-error-printer)
(set-exception-printer! 'no-data scm-error-printer)
(set-exception-printer! 'no-recovery scm-error-printer)
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index bb1ce1e..fdf16c8 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -349,7 +349,7 @@
(scm-error
'keyword-argument-error
"eval" "Unrecognized keyword"
- '() #f)))
+ '() (list (car args)))))
(lp (cddr args)))
(if (pair? args)
(if rest?
@@ -357,7 +357,7 @@
(lp (cdr args))
(scm-error 'keyword-argument-error
"eval" "Invalid keyword"
- '() #f))
+ '() (list (car args))))
;; Finished parsing keywords. Fill in
;; uninitialized kwargs by evalling init
;; expressions in their appropriate
diff --git a/module/rnrs/arithmetic/bitwise.scm
b/module/rnrs/arithmetic/bitwise.scm
index bb3a207..ac870ff 100644
--- a/module/rnrs/arithmetic/bitwise.scm
+++ b/module/rnrs/arithmetic/bitwise.scm
@@ -53,9 +53,13 @@
(logand bitwise-and)
(logior bitwise-ior)
(logxor bitwise-xor)
- (logcount bitwise-bit-count)
(ash bitwise-arithmetic-shift)))
+ (define (bitwise-bit-count ei)
+ (if (negative? ei)
+ (bitwise-not (logcount ei))
+ (logcount ei)))
+
(define (bitwise-if ei1 ei2 ei3)
(bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3)))
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 7fe0100..3ab820d 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
@@ -20,7 +20,7 @@
;;; Commentary:
;; A data type for Universal Resource Identifiers, as defined in RFC
-;; 3986.
+;; 3986.
;;; Code:
@@ -382,7 +382,7 @@ The default character set includes alphanumerics from
ASCII, as well as
the special characters â-â, â.â, â_â, and â~â. Any other
character will
be percent-encoded, by writing out the character to a bytevector within
the given ENCODING, then encoding each byte as â%HHâ, where HH is the
-hexadecimal representation of the byte."
+uppercase hexadecimal representation of the byte."
(define (needs-escaped? ch)
(not (char-set-contains? unescaped-chars ch)))
(if (string-index str needs-escaped?)
@@ -400,7 +400,8 @@ hexadecimal representation of the byte."
(display #\% port)
(when (< byte 16)
(display #\0 port))
- (display (number->string byte 16) port)
+ (display (string-upcase (number->string byte 16))
+ port)
(lp (1+ i))))))))
str)))
str))
diff --git a/test-suite/standalone/test-language
b/test-suite/standalone/test-language
index 59ed82b..d67d361 100755
--- a/test-suite/standalone/test-language
+++ b/test-suite/standalone/test-language
@@ -8,7 +8,9 @@ set -e
# The default language in effect until `--language' is encountered is
# Scheme.
guile -c "(exit (= 3 (apply + '(1 2))))" --language=elisp
-! guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null
+
+if guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null
+then false; else true; fi
guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)"
guile --language=ecmascript -c '(function (x) { return x * x; })(2);'
diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
index 6fcf821..ad0722c 100644
--- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
+++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
@@ -25,20 +25,6 @@
#include <assert.h>
static SCM
-error_handler (void *data, SCM key, SCM args)
-{
- SCM expected_args = scm_list_n (scm_from_utf8_string ("test"),
- scm_from_utf8_string ((char *) data),
- SCM_EOL, SCM_BOOL_F,
- SCM_UNDEFINED);
-
- assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error")));
- assert (scm_is_true (scm_equal_p (args, expected_args)));
-
- return SCM_BOOL_T;
-}
-
-static SCM
test_unrecognized_keyword (void *data)
{
SCM k_foo = scm_from_utf8_keyword ("foo");
@@ -58,6 +44,21 @@ test_unrecognized_keyword (void *data)
}
static SCM
+unrecognized_keyword_error_handler (void *data, SCM key, SCM args)
+{
+ SCM expected_args = scm_list_n
+ (scm_from_utf8_string ("test"),
+ scm_from_utf8_string ("Unrecognized keyword"),
+ SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("baz")),
+ SCM_UNDEFINED);
+
+ assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error")));
+ assert (scm_is_true (scm_equal_p (args, expected_args)));
+
+ return SCM_BOOL_T;
+}
+
+static SCM
test_invalid_keyword (void *data)
{
SCM k_foo = scm_from_utf8_keyword ("foo");
@@ -76,6 +77,21 @@ test_invalid_keyword (void *data)
}
static SCM
+invalid_keyword_error_handler (void *data, SCM key, SCM args)
+{
+ SCM expected_args = scm_list_n
+ (scm_from_utf8_string ("test"),
+ scm_from_utf8_string ("Invalid keyword"),
+ SCM_EOL, scm_list_1 (SCM_INUM0),
+ SCM_UNDEFINED);
+
+ assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error")));
+ assert (scm_is_true (scm_equal_p (args, expected_args)));
+
+ return SCM_BOOL_T;
+}
+
+static SCM
test_odd_length (void *data)
{
SCM k_foo = scm_from_utf8_keyword ("foo");
@@ -93,6 +109,21 @@ test_odd_length (void *data)
assert (0);
}
+static SCM
+odd_length_error_handler (void *data, SCM key, SCM args)
+{
+ SCM expected_args = scm_list_n
+ (scm_from_utf8_string ("test"),
+ scm_from_utf8_string ("Odd length of keyword argument list"),
+ SCM_EOL, SCM_BOOL_F,
+ SCM_UNDEFINED);
+
+ assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error")));
+ assert (scm_is_true (scm_equal_p (args, expected_args)));
+
+ return SCM_BOOL_T;
+}
+
static void
test_scm_c_bind_keyword_arguments ()
{
@@ -174,17 +205,17 @@ test_scm_c_bind_keyword_arguments ()
/* Test unrecognized keyword error. */
scm_internal_catch (SCM_BOOL_T,
test_unrecognized_keyword, NULL,
- error_handler, "Unrecognized keyword");
+ unrecognized_keyword_error_handler, NULL);
/* Test invalid keyword error. */
scm_internal_catch (SCM_BOOL_T,
test_invalid_keyword, NULL,
- error_handler, "Invalid keyword");
+ invalid_keyword_error_handler, NULL);
/* Test odd length error. */
scm_internal_catch (SCM_BOOL_T,
test_odd_length, NULL,
- error_handler, "Odd length of keyword argument list");
+ odd_length_error_handler, NULL);
}
static void
diff --git a/test-suite/standalone/test-system-cmds
b/test-suite/standalone/test-system-cmds
index f500729..8c59083 100755
--- a/test-suite/standalone/test-system-cmds
+++ b/test-suite/standalone/test-system-cmds
@@ -9,8 +9,10 @@ exec guile -q -s "$0" "$@"
#t
"test-system-cmds: (system) did not return a boolean\n")
(exit 1)))
-
- (let ((rs (status:exit-val (system "guile -c '(exit 42)'"))))
+
+ ;; Note: Use double quotes since simple quotes are not supported by
+ ;; `cmd.exe' on Windows.
+ (let ((rs (status:exit-val (system "guile -c \"(exit 42)\""))))
(if (not (= 42 rs))
(begin
(simple-format
@@ -39,4 +41,4 @@ exec guile -q -s "$0" "$@"
;; Local Variables:
;; mode: scheme
-;; End:
\ No newline at end of file
+;; End:
diff --git a/test-suite/standalone/test-unwind.c
b/test-suite/standalone/test-unwind.c
index cf56a96..3aa3e15 100644
--- a/test-suite/standalone/test-unwind.c
+++ b/test-suite/standalone/test-unwind.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2004, 2005, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2004, 2005, 2008, 2009, 2010, 2013 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -200,9 +200,20 @@ check_ports ()
#define FILENAME_TEMPLATE "/check-ports.XXXXXX"
char *filename;
const char *tmpdir = getenv ("TMPDIR");
+#ifdef __MINGW32__
+ extern int mkstemp (char *);
+ /* On Windows neither $TMPDIR nor /tmp can be relied on. */
+ if (tmpdir == NULL)
+ tmpdir = getenv ("TEMP");
+ if (tmpdir == NULL)
+ tmpdir = getenv ("TMP");
+ if (tmpdir == NULL)
+ tmpdir = "/";
+#else
if (tmpdir == NULL)
tmpdir = "/tmp";
+#endif
filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1);
strcpy (filename, tmpdir);
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index b29de0f..336c87a 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -230,19 +230,22 @@
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
;; test makes sure that they get to use %TEST-VM.
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
- (call (pointer->procedure '*
- (dynamic-func "scm_call_2"
- (dynamic-link))
- '(* * *))))
- (let-values (((data result)
- (with-code-coverage %test-vm
- (lambda ()
- (call (make-pointer (object-address proc))
- (make-pointer (object-address 1))
- (make-pointer (object-address 2)))))))
- (and (coverage-data? data)
- (= (object-address 3) (pointer-address result))
- (= (procedure-execution-count data proc) 1)))))
+ (call (false-if-exception ; can we resolve `scm_call_2'?
+ (pointer->procedure '*
+ (dynamic-func "scm_call_2"
+ (dynamic-link))
+ '(* * *)))))
+ (if call
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda ()
+ (call (make-pointer (object-address proc))
+ (make-pointer (object-address 1))
+ (make-pointer (object-address 2)))))))
+ (and (coverage-data? data)
+ (= (object-address 3) (pointer-address result))
+ (= (procedure-execution-count data proc) 1)))
+ (throw 'unresolved))))
(pass-if "called from eval"
(let-values (((data result)
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 049c9a2..253c32a 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -222,4 +222,5 @@
(throw 'unresolved)))))
(delete-file (test-file))
-(delete-file (test-symlink))
+(when (file-exists? (test-symlink))
+ (delete-file (test-symlink)))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 9d615ce..74cdc1b 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -224,9 +224,13 @@
(define qsort
;; Bindings for libc's `qsort' function.
- (pointer->procedure void
- (dynamic-func "qsort" (dynamic-link))
- (list '* size_t size_t '*)))
+ ;; On some platforms, such as MinGW, `qsort' is visible only if
+ ;; linking with `-export-dynamic'. Just skip these tests when it's
+ ;; not visible.
+ (false-if-exception
+ (pointer->procedure void
+ (dynamic-func "qsort" (dynamic-link))
+ (list '* size_t size_t '*))))
(define (dereference-pointer-to-byte ptr)
(let ((b (pointer->bytevector ptr 1)))
@@ -236,7 +240,7 @@
'(7 1 127 3 5 4 77 2 9 0))
(pass-if "qsort"
- (if (defined? 'procedure->pointer)
+ (if (and qsort (defined? 'procedure->pointer))
(let* ((called? #f)
(cmp (lambda (x y)
(set! called? #t)
@@ -254,7 +258,7 @@
(pass-if-exception "qsort, wrong return type"
exception:wrong-type-arg
- (if (defined? 'procedure->pointer)
+ (if (and qsort (defined? 'procedure->pointer))
(let* ((cmp (lambda (x y) #f)) ; wrong return type
(ptr (procedure->pointer int cmp (list '* '*)))
(bv (u8-list->bytevector input)))
@@ -266,7 +270,7 @@
(pass-if-exception "qsort, wrong arity"
exception:wrong-num-args
- (if (defined? 'procedure->pointer)
+ (if (and qsort (defined? 'procedure->pointer))
(let* ((cmp (lambda (x y z) #f)) ; wrong arity
(ptr (procedure->pointer int cmp (list '* '*)))
(bv (u8-list->bytevector input)))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index eca4536..5e95ab9 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -33,7 +33,10 @@
(not (not (object-documentation object))))
(define fixnum-bit
- (inexact->exact (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1)))
+ (do ((i 0 (+ 1 i))
+ (n 1 (* 2 n)))
+ ((> n most-positive-fixnum)
+ (+ 1 i))))
(define fixnum-min most-negative-fixnum)
(define fixnum-max most-positive-fixnum)
@@ -2034,7 +2037,28 @@
(pass-if (not (= (ash-flo 1.0 58) (1- (ash 1 58)))))
(pass-if (= (ash 1 58) (ash-flo 1.0 58)))
(pass-if (not (= (1+ (ash 1 58)) (ash-flo 1.0 58))))
- (pass-if (not (= (1- (ash 1 58)) (ash-flo 1.0 58)))))
+ (pass-if (not (= (1- (ash 1 58)) (ash-flo 1.0 58))))
+
+ ;; prior to guile 2.0.10, inum/complex comparisons were done just by
+ ;; converting the inum to a double, which on a 64-bit would round making
+ ;; say inexact 2^58 appear equal to exact 2^58+1
+ (pass-if (= (+ +0.0i (ash-flo 1.0 58)) (ash 1 58)))
+ (pass-if (not (= (+ +0.0i (ash-flo 1.0 58)) (1+ (ash 1 58)))))
+ (pass-if (not (= (+ +0.0i (ash-flo 1.0 58)) (1- (ash 1 58)))))
+ (pass-if (= (ash 1 58) (+ +0.0i (ash-flo 1.0 58))))
+ (pass-if (not (= (1+ (ash 1 58)) (+ +0.0i (ash-flo 1.0 58)))))
+ (pass-if (not (= (1- (ash 1 58)) (+ +0.0i (ash-flo 1.0 58)))))
+
+ ;; prior to guile 2.0.10, fraction/flonum and fraction/complex
+ ;; comparisons mishandled infinities.
+ (pass-if (not (= 1/2 +inf.0)))
+ (pass-if (not (= 1/2 -inf.0)))
+ (pass-if (not (= +inf.0 1/2)))
+ (pass-if (not (= -inf.0 1/2)))
+ (pass-if (not (= 1/2 +inf.0+0.0i)))
+ (pass-if (not (= 1/2 -inf.0+0.0i)))
+ (pass-if (not (= +inf.0+0.0i 1/2)))
+ (pass-if (not (= -inf.0+0.0i 1/2))))
;;;
;;; <
@@ -2085,6 +2109,9 @@
(pass-if "n = 0.0"
(not (< 0.0 0.0)))
+ (pass-if "n = -0.0"
+ (not (< 0.0 -0.0)))
+
(pass-if "n = 1"
(< 0.0 1))
@@ -2108,6 +2135,9 @@
(pass-if "n = fixnum-min - 1"
(not (< 0.0 (- fixnum-min 1)))))
+
+ (pass-if (not (< -0.0 0.0)))
+ (pass-if (not (< -0.0 -0.0)))
(with-test-prefix "(< 1 n)"
@@ -2433,6 +2463,42 @@
(pass-if (eq? #f (< x (* -4/3 x))))
(pass-if (eq? #f (< (- x) (* -4/3 x))))))
+ (with-test-prefix "inum/flonum"
+ (pass-if (< 4 4.5))
+ (pass-if (< 4.5 5))
+ (pass-if (< -5 -4.5))
+ (pass-if (< -4.5 4))
+ (pass-if (not (< 4.5 4)))
+ (pass-if (not (< 5 4.5)))
+ (pass-if (not (< -4.5 -5)))
+ (pass-if (not (< 4 -4.5)))
+
+ (pass-if (< 4 +inf.0))
+ (pass-if (< -4 +inf.0))
+ (pass-if (< -inf.0 4))
+ (pass-if (< -inf.0 -4))
+ (pass-if (not (< +inf.0 4)))
+ (pass-if (not (< +inf.0 -4)))
+ (pass-if (not (< 4 -inf.0)))
+ (pass-if (not (< -4 -inf.0)))
+
+ (pass-if (not (< +nan.0 4)))
+ (pass-if (not (< +nan.0 -4)))
+ (pass-if (not (< 4 +nan.0)))
+ (pass-if (not (< -4 +nan.0)))
+
+ (pass-if (< most-positive-fixnum (expt 2.0 fixnum-bit)))
+ (pass-if (not (< (expt 2.0 fixnum-bit) most-positive-fixnum)))
+
+ (pass-if (< (- (expt 2.0 fixnum-bit)) most-negative-fixnum))
+ (pass-if (not (< most-negative-fixnum (- (expt 2.0 fixnum-bit)))))
+
+ ;; Prior to guile 2.0.10, we would unconditionally convert the inum
+ ;; to a double, which on a 64-bit system could result in a
+ ;; significant change in its value, thus corrupting the comparison.
+ (pass-if (< most-positive-fixnum (exact->inexact most-positive-fixnum)))
+ (pass-if (< (exact->inexact (- most-positive-fixnum)) (-
most-positive-fixnum))))
+
(with-test-prefix "flonum/frac"
(pass-if (< 0.75 4/3))
(pass-if (< -0.75 4/3))
@@ -4021,6 +4087,19 @@
(let ((big (ash 1 4096)))
(= 1.0 (exact->inexact (/ (1+ big) big)))))
+ ;; In guile 2.0.9, 'exact->inexact' guaranteed proper rounding when
+ ;; applied to non-negative fractions, but on 64-bit systems would
+ ;; sometimes double-round when applied to negative fractions,
+ ;; specifically when the numerator was a fixnum not exactly
+ ;; representable as a double.
+ (with-test-prefix "frac inum/inum, numerator not exactly representable as a
double"
+ (let ((n (+ 1 (expt 2 dbl-mant-dig))))
+ (for-each (lambda (d)
+ (test (/ n d)
+ (/ n d)
+ (exact->inexact (/ n d))))
+ '(3 5 6 7 9 11 13 17 19 23 0.0 -0.0 +nan.0 +inf.0 -inf.0))))
+
(test "round up to odd"
;; =====================================================
;; 11111111111111111111111111111111111111111111111111000101 ->
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 16a4533..047417b 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -34,25 +34,6 @@
;'(keyword-argument-error . ".*")
'(#t . ".*"))
-(define-syntax c&e
- (syntax-rules (pass-if pass-if-exception)
- ((_ (pass-if test-name exp))
- (begin (pass-if (string-append test-name " (eval)")
- (primitive-eval 'exp))
- (pass-if (string-append test-name " (compile)")
- (compile 'exp #:to 'value #:env (current-module)))))
- ((_ (pass-if-exception test-name exc exp))
- (begin (pass-if-exception (string-append test-name " (eval)")
- exc (primitive-eval 'exp))
- (pass-if-exception (string-append test-name " (compile)")
- exc (compile 'exp #:to 'value
- #:env (current-module)))))))
-
-(define-syntax with-test-prefix/c&e
- (syntax-rules ()
- ((_ section-name exp ...)
- (with-test-prefix section-name (c&e exp) ...))))
-
(with-test-prefix/c&e "optional argument processing"
(pass-if "local defines work with optional arguments"
(eval '(begin
@@ -165,10 +146,21 @@
(let ((f (lambda* (#:key x) x)))
(f 1 2 #:x 'x)))
- (pass-if-exception "unrecognized keyword"
- exception:unrecognized-keyword
- (let ((f (lambda* (#:key x) x)))
- (f #:y 'not-recognized)))
+ (pass-if-equal "unrecognized keyword" '(#:y)
+ (catch 'keyword-argument-error
+ (lambda ()
+ (let ((f (lambda* (#:key x) x)))
+ (f #:y 'not-recognized)))
+ (lambda (key proc fmt args data)
+ data)))
+
+ (pass-if-equal "invalid keyword" '(not-a-keyword)
+ (catch 'keyword-argument-error
+ (lambda ()
+ (let ((f (lambda* (#:key x) x)))
+ (f 'not-a-keyword 'something)))
+ (lambda (key proc fmt args data)
+ data)))
(pass-if "rest given before keywords"
;; Passing the rest argument before the keyword arguments should not
@@ -177,6 +169,22 @@
(equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (1 2 3 #:x x #:z z))))))
+(with-test-prefix "scm_c_bind_keyword_arguments"
+
+ (pass-if-equal "unrecognized keyword" '(#:y)
+ (catch 'keyword-argument-error
+ (lambda ()
+ (open-file "/dev/null" "r" #:y 'not-recognized))
+ (lambda (key proc fmt args data)
+ data)))
+
+ (pass-if-equal "invalid keyword" '(not-a-keyword)
+ (catch 'keyword-argument-error
+ (lambda ()
+ (open-file "/dev/null" "r" 'not-a-keyword 'something))
+ (lambda (key proc fmt args data)
+ data))))
+
(with-test-prefix/c&e "lambda* inits"
(pass-if "can bind lexicals within inits"
(begin
diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test
b/test-suite/tests/r6rs-arithmetic-bitwise.test
index a61fef8..c864f3b 100644
--- a/test-suite/tests/r6rs-arithmetic-bitwise.test
+++ b/test-suite/tests/r6rs-arithmetic-bitwise.test
@@ -43,7 +43,9 @@
(with-test-prefix "bitwise-bit-count"
(pass-if "bitwise-bit-count simple"
- (eqv? (bitwise-bit-count #b101) 2)))
+ (eqv? (bitwise-bit-count #b101) 2))
+ (pass-if "bitwise-bit-count negative"
+ (eqv? (bitwise-bit-count #b-101) -2)))
(with-test-prefix "bitwise-length"
(pass-if "bitwise-length simple"
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 3f6e7e3..3d14d9d 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -259,5 +259,5 @@
(with-test-prefix "encode"
(pass-if (equal? "foo%20bar" (uri-encode "foo bar")))
- (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar")))
- (pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^"))))
+ (pass-if (equal? "foo%0A%00bar" (uri-encode "foo\n\x00bar")))
+ (pass-if (equal? "%3C%3E%5C%5E" (uri-encode "<>\\^"))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-81-g28d5d25,
Mark H Weaver <=