summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el4
-rw-r--r--THANKS1
-rw-r--r--doc/ref/api-control.texi3
-rw-r--r--doc/ref/api-macros.texi8
-rw-r--r--doc/ref/api-scheduling.texi6
-rw-r--r--libguile/error.c3
-rw-r--r--libguile/eval.c12
-rw-r--r--libguile/keywords.c20
-rw-r--r--libguile/numbers.c115
-rw-r--r--libguile/posix.c4
-rw-r--r--libguile/socket.c2
-rw-r--r--libguile/threads.c4
-rw-r--r--libguile/vm-engine.c6
-rw-r--r--libguile/vm-i-scheme.c8
-rw-r--r--libguile/vm-i-system.c4
-rw-r--r--libguile/vm.c12
-rw-r--r--module/ice-9/boot-9.scm7
-rw-r--r--module/ice-9/eval.scm4
-rw-r--r--module/rnrs/arithmetic/bitwise.scm6
-rw-r--r--module/web/uri.scm11
-rwxr-xr-xtest-suite/standalone/test-language4
-rw-r--r--test-suite/standalone/test-scm-c-bind-keyword-arguments.c65
-rwxr-xr-xtest-suite/standalone/test-system-cmds8
-rw-r--r--test-suite/standalone/test-unwind.c13
-rw-r--r--test-suite/tests/coverage.test31
-rw-r--r--test-suite/tests/filesys.test3
-rw-r--r--test-suite/tests/foreign.test16
-rw-r--r--test-suite/tests/numbers.test83
-rw-r--r--test-suite/tests/optargs.test54
-rw-r--r--test-suite/tests/r6rs-arithmetic-bitwise.test4
-rw-r--r--test-suite/tests/web-uri.test4
31 files changed, 371 insertions, 154 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index ce2af7a77..a24e860ca 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 a01dcfb17..c517cf724 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 f34074ec6..026308cac 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
-@var{key} is @code{out-of-range} or @code{wrong-type-arg},
+@var{key} 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 09ffee6a7..82a2c071e 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 b23082192..0d036be9e 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 0df4c737e..26cf5b6d6 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 b245026f0..f5e1524c7 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 96c0b0144..f630259d9 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 d941133df..9857e182d 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 822599d9e..0443f95ea 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 7e735f43c..34bc21a73 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 ef771dcae..99582cca0 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 8b11e7f24..9b12d3e77 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 ef3d02b7c..2f1d5fe02 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 248db9af0..0973792bd 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 f43191299..dd016b7fe 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 48aec4904..39d313f63 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 bb1ce1e81..fdf16c8ae 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 bb3a20797..ac870ff79 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 7fe010096..3ab820d14 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 59ed82b62..d67d36129 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 6fcf82180..ad0722ce8 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 f5007297e..8c590835d 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 cf56a9658..3aa3e159d 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 b29de0f20..336c87a33 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 049c9a2b0..253c32ac5 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 9d615ce16..74cdc1b4f 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 eca4536a9..5e95ab9b6 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 16a45336a..047417b4c 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 a61fef8c4..c864f3b68 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 3f6e7e3ab..3d14d9d46 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 "<>\\^"))))