mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 09:40:25 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	libguile/keywords.c
	libguile/vm.c
This commit is contained in:
Mark H Weaver 2013-07-16 01:33:27 -04:00
commit 28d5d2537c
31 changed files with 371 additions and 154 deletions
Download patch file Download diff file Expand all files Collapse all files

4
.dir-locals.el
View file

@ -8,7 +8,9 @@
(eval . (put 'pass-if 'scheme-indent-function 1)) (eval . (put 'pass-if 'scheme-indent-function 1))
(eval . (put 'pass-if-exception 'scheme-indent-function 2)) (eval . (put 'pass-if-exception 'scheme-indent-function 2))
(eval . (put 'pass-if-equal '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))) (emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil) (texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72)))) (fill-column . 72))))

1
THANKS
View file

@ -77,6 +77,7 @@ For fixes or providing information which led to a fix:
Fu-gangqiang Fu-gangqiang
Aidan Gauland Aidan Gauland
Peter Gavin Peter Gavin
Andrew Gaylard
Nils Gey Nils Gey
Eric Gillespie, Jr Eric Gillespie, Jr
Didier Godefroy Didier Godefroy

3
doc/ref/api-control.texi
View file

@ -1424,7 +1424,8 @@ Guile) formats using @code{display} and @code{~S} (was
@code{system-error} then it should be a list containing the @code{system-error} then it should be a list containing the
Unix @code{errno} value; If @var{key} is @code{signal} then it Unix @code{errno} value; If @var{key} is @code{signal} then it
should be a list containing the Unix signal number; If 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 is a list containing the bad value; otherwise
it will usually be @code{#f}. it will usually be @code{#f}.
@end deffn @end deffn

8
doc/ref/api-macros.texi
View file

@ -122,8 +122,8 @@ same @var{letrec-syntax}.
exp) exp)
((my-or exp rest ...) ((my-or exp rest ...)
(let ((t exp)) (let ((t exp))
(if exp (if t
exp t
(my-or rest ...))))))) (my-or rest ...)))))))
(my-or #f "rockaway beach")) (my-or #f "rockaway beach"))
@result{} "rockaway beach" @result{} "rockaway beach"
@ -323,8 +323,8 @@ Consider the definition of @code{my-or} from the previous section:
exp) exp)
((my-or exp rest ...) ((my-or exp rest ...)
(let ((t exp)) (let ((t exp))
(if exp (if t
exp t
(my-or rest ...)))))) (my-or rest ...))))))
@end example @end example

6
doc/ref/api-scheduling.texi
View file

@ -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 @code{wait-condition-variable}, except that the mutex is left in an
unlocked state when the function returns.) unlocked state when the function returns.)
When @var{timeout} is also given, it specifies a point in time where When @var{timeout} is also given and not false, it specifies a point in
the waiting should be aborted. It can be either an integer as time where the waiting should be aborted. It can be either an integer
returned by @code{current-time} or a pair as returned by as returned by @code{current-time} or a pair as returned by
@code{gettimeofday}. When the waiting is aborted, @code{#f} is @code{gettimeofday}. When the waiting is aborted, @code{#f} is
returned. Otherwise the function returns @code{#t}. returned. Otherwise the function returns @code{#t}.
@end deffn @end deffn

3
libguile/error.c
View file

@ -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" "@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" "Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
"should be a list containing the Unix signal number; If\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 is a list containing the bad value; otherwise\n"
"it will usually be @code{#f}.") "it will usually be @code{#f}.")
#define FUNC_NAME s_scm_error_scm #define FUNC_NAME s_scm_error_scm

12
libguile/eval.c
View file

@ -162,18 +162,18 @@ static void error_used_before_defined (void)
"Variable used before given a value", SCM_EOL, SCM_BOOL_F); "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_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Invalid keyword"), SCM_EOL, 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_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Unrecognized keyword"), SCM_EOL, 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; break;
} }
if (scm_is_null (walk) && scm_is_false (aok)) 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)) 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 /* Now fill in unbound values, evaluating init expressions in their
appropriate environment. */ appropriate environment. */

20
libguile/keywords.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of * 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. */ /* KW_OR_ARG is not in the list of expected keywords. */
if (!(flags & SCM_ALLOW_OTHER_KEYS)) if (!(flags & SCM_ALLOW_OTHER_KEYS))
scm_error (scm_keyword_argument_error, scm_error_scm (scm_keyword_argument_error,
subr, "Unrecognized keyword", scm_from_locale_string (subr),
SCM_EOL, SCM_BOOL_F); scm_from_latin1_string
("Unrecognized keyword"),
SCM_EOL, scm_list_1 (kw_or_arg));
break; break;
} }
arg_p = va_arg (va, SCM *); 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 /* The next argument is not a keyword, or is a singleton
keyword at the end of REST. */ keyword at the end of REST. */
if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS)) if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS))
scm_error (scm_keyword_argument_error, scm_error_scm (scm_keyword_argument_error,
subr, "Invalid keyword", scm_from_locale_string (subr),
SCM_EOL, SCM_BOOL_F); scm_from_latin1_string ("Invalid keyword"),
SCM_EOL, scm_list_1 (kw_or_arg));
/* Advance REST. */ /* Advance REST. */
rest = tail; rest = tail;

115
libguile/numbers.c
View file

@ -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_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
#define DOUBLE_IS_NEGATIVE_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 #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 (d)))
{ {
if (SCM_LIKELY (SCM_I_INUMP (n) if (SCM_LIKELY
&& (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG (SCM_I_INUMP (n)
|| (SCM_I_INUM (n) < (1L << DBL_MANT_DIG) && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n))
&& SCM_I_INUM (d) < (1L << DBL_MANT_DIG))))) && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d))))
/* If both N and D can be losslessly converted to doubles, then /* If both N and D can be losslessly converted to doubles, then
we can rely on IEEE floating point to do proper rounding much we can rely on IEEE floating point to do proper rounding much
faster than we can. */ faster than we can. */
@ -6535,9 +6542,11 @@ scm_num_eq_p (SCM x, SCM y)
to a double and compare. to a double and compare.
But on a 64-bit system an inum is bigger than a double and 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 casting it to a double (call that dxx) will round.
worst 1 bigger or smaller than xx, so if dxx==yy we know yy is Although dxx will not in general be equal to xx, dxx will
an integer and fits a long. So we cast yy to a long and 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. compare with plain xx.
An alternative (for any size system actually) would be to check 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)); || xx == (scm_t_signed_bits) yy));
} }
else if (SCM_COMPLEXP (y)) 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)) else if (SCM_FRACTIONP (y))
return SCM_BOOL_F; return SCM_BOOL_F;
else else
@ -6610,24 +6625,21 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
{ {
int cmp; int cmp;
if (isnan (SCM_REAL_VALUE (x))) if (isnan (xx))
return SCM_BOOL_F; 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); scm_remember_upto_here_1 (y);
return scm_from_bool (0 == cmp); return scm_from_bool (0 == cmp);
} }
else if (SCM_REALP (y)) 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)) else if (SCM_COMPLEXP (y))
return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) return scm_from_bool ((xx == SCM_COMPLEX_REAL (y))
&& (0.0 == SCM_COMPLEX_IMAG (y))); && (0.0 == SCM_COMPLEX_IMAG (y)));
else if (SCM_FRACTIONP (y)) else if (SCM_FRACTIONP (y))
{ {
double xx = SCM_REAL_VALUE (x); if (isnan (xx) || isinf (xx))
if (isnan (xx))
return SCM_BOOL_F; 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 */ x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again; goto again;
} }
@ -6638,8 +6650,15 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_COMPLEXP (x)) else if (SCM_COMPLEXP (x))
{ {
if (SCM_I_INUMP (y)) 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)) else if (SCM_BIGP (y))
{ {
int cmp; int cmp;
@ -6653,20 +6672,18 @@ scm_num_eq_p (SCM x, SCM y)
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (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)) else if (SCM_COMPLEXP (y))
return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (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)) else if (SCM_FRACTIONP (y))
{ {
double xx; double xx;
if (SCM_COMPLEX_IMAG (x) != 0.0) if (SCM_COMPLEX_IMAG (x) != 0.0)
return SCM_BOOL_F; return SCM_BOOL_F;
xx = SCM_COMPLEX_REAL (x); xx = SCM_COMPLEX_REAL (x);
if (isnan (xx)) if (isnan (xx) || isinf (xx))
return SCM_BOOL_F; 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 */ x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again; goto again;
} }
@ -6683,10 +6700,8 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_REALP (y)) else if (SCM_REALP (y))
{ {
double yy = SCM_REAL_VALUE (y); double yy = SCM_REAL_VALUE (y);
if (isnan (yy)) if (isnan (yy) || isinf (yy))
return SCM_BOOL_F; 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 */ y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again; goto again;
} }
@ -6696,10 +6711,8 @@ scm_num_eq_p (SCM x, SCM y)
if (SCM_COMPLEX_IMAG (y) != 0.0) if (SCM_COMPLEX_IMAG (y) != 0.0)
return SCM_BOOL_F; return SCM_BOOL_F;
yy = SCM_COMPLEX_REAL (y); yy = SCM_COMPLEX_REAL (y);
if (isnan (yy)) if (isnan (yy) || isinf(yy))
return SCM_BOOL_F; 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 */ y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again; goto again;
} }
@ -6760,7 +6773,25 @@ scm_less_p (SCM x, SCM y)
return scm_from_bool (sgn > 0); return scm_from_bool (sgn > 0);
} }
else if (SCM_REALP (y)) 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)) else if (SCM_FRACTIONP (y))
{ {
/* "x < a/b" becomes "x*b < a" */ /* "x < a/b" becomes "x*b < a" */
@ -6805,7 +6836,25 @@ scm_less_p (SCM x, SCM y)
else if (SCM_REALP (x)) else if (SCM_REALP (x))
{ {
if (SCM_I_INUMP (y)) 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)) else if (SCM_BIGP (y))
{ {
int cmp; int cmp;

4
libguile/posix.c
View file

@ -910,7 +910,7 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
#ifdef HAVE_SETEGID #ifdef HAVE_SETEGID
SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
(SCM id), (SCM id),
"Sets the effective group ID to the integer @var{id}, provided the process\n" "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" "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; int rv;
#ifdef HAVE_SETEUID #ifdef HAVE_SETEGID
rv = setegid (scm_to_int (id)); rv = setegid (scm_to_int (id));
#else #else
rv = setgid (scm_to_int (id)); rv = setgid (scm_to_int (id));

2
libguile/socket.c
View file

@ -1645,7 +1645,7 @@ scm_init_socket ()
#ifdef AF_UNSPEC #ifdef AF_UNSPEC
scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC)); scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC));
#endif #endif
#ifdef AF_UNIX #if defined HAVE_UNIX_DOMAIN_SOCKETS && defined AF_UNIX
scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX)); scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX));
#endif #endif
#ifdef AF_INET #ifdef AF_INET

4
libguile/threads.c
View file

@ -326,7 +326,7 @@ remqueue (SCM q, SCM c)
if (scm_is_eq (p, c)) if (scm_is_eq (p, c))
{ {
if (scm_is_eq (c, SCM_CAR (q))) 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)); SCM_SETCDR (prev, SCM_CDR (c));
/* GC-robust */ /* GC-robust */
@ -1712,7 +1712,7 @@ SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0,
{ {
SCM_VALIDATE_CONDVAR (2, cond); SCM_VALIDATE_CONDVAR (2, cond);
if (! (SCM_UNBNDP (timeout))) if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout))
{ {
to_timespec (timeout, &cwaittime); to_timespec (timeout, &cwaittime);
waittime = &cwaittime; waittime = &cwaittime;

6
libguile/vm-engine.c
View file

@ -1555,11 +1555,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
break; break;
} }
VM_ASSERT (scm_is_pair (walk) || allow_other_keys, 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++; n++;
} }
else 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) if (has_rest)
{ {

8
libguile/vm-i-scheme.c
View file

@ -402,8 +402,12 @@ VM_DEFINE_FUNCTION (161, ash, "ash", 2)
if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
{ {
if (SCM_I_INUM (y) < 0) 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 else
/* Left shift. See comments in scm_ash. */ /* Left shift. See comments in scm_ash. */
{ {

4
libguile/vm-i-system.c
View file

@ -697,12 +697,12 @@ VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0)
} }
VM_ASSERT (scm_is_pair (walk) VM_ASSERT (scm_is_pair (walk)
|| (kw_and_rest_flags & F_ALLOW_OTHER_KEYS), || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
vm_error_kwargs_unrecognized_keyword (program)); vm_error_kwargs_unrecognized_keyword (program, sp[nkw]));
nkw++; nkw++;
} }
else else
VM_ASSERT (kw_and_rest_flags & F_REST, VM_ASSERT (kw_and_rest_flags & F_REST,
vm_error_kwargs_invalid_keyword (program)); vm_error_kwargs_invalid_keyword (program, sp[nkw]));
} }
NEXT; NEXT;

12
libguile/vm.c
View file

@ -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_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_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_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_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE;
static void vm_error_kwargs_unrecognized_keyword (SCM proc) 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_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_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_type_apply (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 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_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Invalid keyword"), scm_from_latin1_string ("Invalid keyword"),
SCM_EOL, SCM_BOOL_F); SCM_EOL, scm_list_1 (obj));
} }
static void 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_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Unrecognized keyword"), scm_from_latin1_string ("Unrecognized keyword"),
SCM_EOL, SCM_BOOL_F); SCM_EOL, scm_list_1 (kw));
} }
static void static void

7
module/ice-9/boot-9.scm
View file

@ -977,12 +977,17 @@ information is unavailable."
(_ (default-printer))) (_ (default-printer)))
args)) 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) (define (getaddrinfo-error-printer port key args default-printer)
(format port "In procedure getaddrinfo: ~a" (gai-strerror (car args)))) (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
(set-exception-printer! 'goops-error scm-error-printer) (set-exception-printer! 'goops-error scm-error-printer)
(set-exception-printer! 'host-not-found 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! 'misc-error scm-error-printer)
(set-exception-printer! 'no-data scm-error-printer) (set-exception-printer! 'no-data scm-error-printer)
(set-exception-printer! 'no-recovery scm-error-printer) (set-exception-printer! 'no-recovery scm-error-printer)

4
module/ice-9/eval.scm
View file

@ -349,7 +349,7 @@
(scm-error (scm-error
'keyword-argument-error 'keyword-argument-error
"eval" "Unrecognized keyword" "eval" "Unrecognized keyword"
'() #f))) '() (list (car args)))))
(lp (cddr args))) (lp (cddr args)))
(if (pair? args) (if (pair? args)
(if rest? (if rest?
@ -357,7 +357,7 @@
(lp (cdr args)) (lp (cdr args))
(scm-error 'keyword-argument-error (scm-error 'keyword-argument-error
"eval" "Invalid keyword" "eval" "Invalid keyword"
'() #f)) '() (list (car args))))
;; Finished parsing keywords. Fill in ;; Finished parsing keywords. Fill in
;; uninitialized kwargs by evalling init ;; uninitialized kwargs by evalling init
;; expressions in their appropriate ;; expressions in their appropriate

6
module/rnrs/arithmetic/bitwise.scm
View file

@ -53,9 +53,13 @@
(logand bitwise-and) (logand bitwise-and)
(logior bitwise-ior) (logior bitwise-ior)
(logxor bitwise-xor) (logxor bitwise-xor)
(logcount bitwise-bit-count)
(ash bitwise-arithmetic-shift))) (ash bitwise-arithmetic-shift)))
(define (bitwise-bit-count ei)
(if (negative? ei)
(bitwise-not (logcount ei))
(logcount ei)))
(define (bitwise-if ei1 ei2 ei3) (define (bitwise-if ei1 ei2 ei3)
(bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3))) (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3)))

11
module/web/uri.scm
View file

@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either ;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version. ;;;; version 3 of the License, or (at your option) any later version.
;;;; ;;;;
;;;; This library is distributed in the hope that it will be useful, ;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details. ;;;; Lesser General Public License for more details.
;;;; ;;;;
;;;; You should have received a copy of the GNU Lesser General Public ;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software ;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@ -20,7 +20,7 @@
;;; Commentary: ;;; Commentary:
;; A data type for Universal Resource Identifiers, as defined in RFC ;; A data type for Universal Resource Identifiers, as defined in RFC
;; 3986. ;; 3986.
;;; Code: ;;; Code:
@ -382,7 +382,7 @@ The default character set includes alphanumerics from ASCII, as well as
the special characters ‘-’, ‘.’, ‘_’, and ‘~’. Any other character will the special characters ‘-’, ‘.’, ‘_’, and ‘~’. Any other character will
be percent-encoded, by writing out the character to a bytevector within 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 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) (define (needs-escaped? ch)
(not (char-set-contains? unescaped-chars ch))) (not (char-set-contains? unescaped-chars ch)))
(if (string-index str needs-escaped?) (if (string-index str needs-escaped?)
@ -400,7 +400,8 @@ hexadecimal representation of the byte."
(display #\% port) (display #\% port)
(when (< byte 16) (when (< byte 16)
(display #\0 port)) (display #\0 port))
(display (number->string byte 16) port) (display (string-upcase (number->string byte 16))
port)
(lp (1+ i)))))))) (lp (1+ i))))))))
str))) str)))
str)) str))

4
test-suite/standalone/test-language
View file

@ -8,7 +8,9 @@ set -e
# The default language in effect until `--language' is encountered is # The default language in effect until `--language' is encountered is
# Scheme. # Scheme.
guile -c "(exit (= 3 (apply + '(1 2))))" --language=elisp 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=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)"
guile --language=ecmascript -c '(function (x) { return x * x; })(2);' guile --language=ecmascript -c '(function (x) { return x * x; })(2);'

65
test-suite/standalone/test-scm-c-bind-keyword-arguments.c
View file

@ -24,20 +24,6 @@
#include <assert.h> #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 static SCM
test_unrecognized_keyword (void *data) test_unrecognized_keyword (void *data)
{ {
@ -57,6 +43,21 @@ test_unrecognized_keyword (void *data)
assert (0); assert (0);
} }
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 static SCM
test_invalid_keyword (void *data) test_invalid_keyword (void *data)
{ {
@ -75,6 +76,21 @@ test_invalid_keyword (void *data)
assert (0); assert (0);
} }
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 static SCM
test_odd_length (void *data) test_odd_length (void *data)
{ {
@ -93,6 +109,21 @@ test_odd_length (void *data)
assert (0); 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 static void
test_scm_c_bind_keyword_arguments () test_scm_c_bind_keyword_arguments ()
{ {
@ -174,17 +205,17 @@ test_scm_c_bind_keyword_arguments ()
/* Test unrecognized keyword error. */ /* Test unrecognized keyword error. */
scm_internal_catch (SCM_BOOL_T, scm_internal_catch (SCM_BOOL_T,
test_unrecognized_keyword, NULL, test_unrecognized_keyword, NULL,
error_handler, "Unrecognized keyword"); unrecognized_keyword_error_handler, NULL);
/* Test invalid keyword error. */ /* Test invalid keyword error. */
scm_internal_catch (SCM_BOOL_T, scm_internal_catch (SCM_BOOL_T,
test_invalid_keyword, NULL, test_invalid_keyword, NULL,
error_handler, "Invalid keyword"); invalid_keyword_error_handler, NULL);
/* Test odd length error. */ /* Test odd length error. */
scm_internal_catch (SCM_BOOL_T, scm_internal_catch (SCM_BOOL_T,
test_odd_length, NULL, test_odd_length, NULL,
error_handler, "Odd length of keyword argument list"); odd_length_error_handler, NULL);
} }
static void static void

8
test-suite/standalone/test-system-cmds
View file

@ -9,8 +9,10 @@ exec guile -q -s "$0" "$@"
#t #t
"test-system-cmds: (system) did not return a boolean\n") "test-system-cmds: (system) did not return a boolean\n")
(exit 1))) (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)) (if (not (= 42 rs))
(begin (begin
(simple-format (simple-format
@ -39,4 +41,4 @@ exec guile -q -s "$0" "$@"
;; Local Variables: ;; Local Variables:
;; mode: scheme ;; mode: scheme
;; End: ;; End:

13
test-suite/standalone/test-unwind.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -200,9 +200,20 @@ check_ports ()
#define FILENAME_TEMPLATE "/check-ports.XXXXXX" #define FILENAME_TEMPLATE "/check-ports.XXXXXX"
char *filename; char *filename;
const char *tmpdir = getenv ("TMPDIR"); 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) if (tmpdir == NULL)
tmpdir = "/tmp"; tmpdir = "/tmp";
#endif
filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1); filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1);
strcpy (filename, tmpdir); strcpy (filename, tmpdir);

31
test-suite/tests/coverage.test
View file

@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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 ;; The `scm_call_N' functions use the VM returned by `the-vm'. This
;; test makes sure that they get to use %TEST-VM. ;; test makes sure that they get to use %TEST-VM.
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))")) (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
(call (pointer->procedure '* (call (false-if-exception ; can we resolve `scm_call_2'?
(dynamic-func "scm_call_2" (pointer->procedure '*
(dynamic-link)) (dynamic-func "scm_call_2"
'(* * *)))) (dynamic-link))
(let-values (((data result) '(* * *)))))
(with-code-coverage %test-vm (if call
(lambda () (let-values (((data result)
(call (make-pointer (object-address proc)) (with-code-coverage %test-vm
(make-pointer (object-address 1)) (lambda ()
(make-pointer (object-address 2))))))) (call (make-pointer (object-address proc))
(and (coverage-data? data) (make-pointer (object-address 1))
(= (object-address 3) (pointer-address result)) (make-pointer (object-address 2)))))))
(= (procedure-execution-count data proc) 1))))) (and (coverage-data? data)
(= (object-address 3) (pointer-address result))
(= (procedure-execution-count data proc) 1)))
(throw 'unresolved))))
(pass-if "called from eval" (pass-if "called from eval"
(let-values (((data result) (let-values (((data result)

3
test-suite/tests/filesys.test
View file

@ -222,4 +222,5 @@
(throw 'unresolved))))) (throw 'unresolved)))))
(delete-file (test-file)) (delete-file (test-file))
(delete-file (test-symlink)) (when (file-exists? (test-symlink))
(delete-file (test-symlink)))

16
test-suite/tests/foreign.test
View file

@ -224,9 +224,13 @@
(define qsort (define qsort
;; Bindings for libc's `qsort' function. ;; Bindings for libc's `qsort' function.
(pointer->procedure void ;; On some platforms, such as MinGW, `qsort' is visible only if
(dynamic-func "qsort" (dynamic-link)) ;; linking with `-export-dynamic'. Just skip these tests when it's
(list '* size_t size_t '*))) ;; not visible.
(false-if-exception
(pointer->procedure void
(dynamic-func "qsort" (dynamic-link))
(list '* size_t size_t '*))))
(define (dereference-pointer-to-byte ptr) (define (dereference-pointer-to-byte ptr)
(let ((b (pointer->bytevector ptr 1))) (let ((b (pointer->bytevector ptr 1)))
@ -236,7 +240,7 @@
'(7 1 127 3 5 4 77 2 9 0)) '(7 1 127 3 5 4 77 2 9 0))
(pass-if "qsort" (pass-if "qsort"
(if (defined? 'procedure->pointer) (if (and qsort (defined? 'procedure->pointer))
(let* ((called? #f) (let* ((called? #f)
(cmp (lambda (x y) (cmp (lambda (x y)
(set! called? #t) (set! called? #t)
@ -254,7 +258,7 @@
(pass-if-exception "qsort, wrong return type" (pass-if-exception "qsort, wrong return type"
exception:wrong-type-arg exception:wrong-type-arg
(if (defined? 'procedure->pointer) (if (and qsort (defined? 'procedure->pointer))
(let* ((cmp (lambda (x y) #f)) ; wrong return type (let* ((cmp (lambda (x y) #f)) ; wrong return type
(ptr (procedure->pointer int cmp (list '* '*))) (ptr (procedure->pointer int cmp (list '* '*)))
(bv (u8-list->bytevector input))) (bv (u8-list->bytevector input)))
@ -266,7 +270,7 @@
(pass-if-exception "qsort, wrong arity" (pass-if-exception "qsort, wrong arity"
exception:wrong-num-args exception:wrong-num-args
(if (defined? 'procedure->pointer) (if (and qsort (defined? 'procedure->pointer))
(let* ((cmp (lambda (x y z) #f)) ; wrong arity (let* ((cmp (lambda (x y z) #f)) ; wrong arity
(ptr (procedure->pointer int cmp (list '* '*))) (ptr (procedure->pointer int cmp (list '* '*)))
(bv (u8-list->bytevector input))) (bv (u8-list->bytevector input)))

83
test-suite/tests/numbers.test
View file

@ -33,7 +33,10 @@
(not (not (object-documentation object)))) (not (not (object-documentation object))))
(define fixnum-bit (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-min most-negative-fixnum)
(define fixnum-max most-positive-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 (not (= (ash-flo 1.0 58) (1- (ash 1 58)))))
(pass-if (= (ash 1 58) (ash-flo 1.0 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))))) (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" (pass-if "n = 0.0"
(not (< 0.0 0.0))) (not (< 0.0 0.0)))
(pass-if "n = -0.0"
(not (< 0.0 -0.0)))
(pass-if "n = 1" (pass-if "n = 1"
(< 0.0 1)) (< 0.0 1))
@ -2108,6 +2135,9 @@
(pass-if "n = fixnum-min - 1" (pass-if "n = fixnum-min - 1"
(not (< 0.0 (- 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)" (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))))
(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" (with-test-prefix "flonum/frac"
(pass-if (< 0.75 4/3)) (pass-if (< 0.75 4/3))
(pass-if (< -0.75 4/3)) (pass-if (< -0.75 4/3))
@ -4021,6 +4087,19 @@
(let ((big (ash 1 4096))) (let ((big (ash 1 4096)))
(= 1.0 (exact->inexact (/ (1+ big) big))))) (= 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" (test "round up to odd"
;; ===================================================== ;; =====================================================
;; 11111111111111111111111111111111111111111111111111000101 -> ;; 11111111111111111111111111111111111111111111111111000101 ->

54
test-suite/tests/optargs.test
View file

@ -34,25 +34,6 @@
;'(keyword-argument-error . ".*") ;'(keyword-argument-error . ".*")
'(#t . ".*")) '(#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" (with-test-prefix/c&e "optional argument processing"
(pass-if "local defines work with optional arguments" (pass-if "local defines work with optional arguments"
(eval '(begin (eval '(begin
@ -165,10 +146,21 @@
(let ((f (lambda* (#:key x) x))) (let ((f (lambda* (#:key x) x)))
(f 1 2 #:x 'x))) (f 1 2 #:x 'x)))
(pass-if-exception "unrecognized keyword" (pass-if-equal "unrecognized keyword" '(#:y)
exception:unrecognized-keyword (catch 'keyword-argument-error
(let ((f (lambda* (#:key x) x))) (lambda ()
(f #:y 'not-recognized))) (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" (pass-if "rest given before keywords"
;; Passing the rest argument before the keyword arguments should not ;; Passing the rest argument before the keyword arguments should not
@ -177,6 +169,22 @@
(equal? (f 1 2 3 #:x 'x #:z 'z) (equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (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" (with-test-prefix/c&e "lambda* inits"
(pass-if "can bind lexicals within inits" (pass-if "can bind lexicals within inits"
(begin (begin

4
test-suite/tests/r6rs-arithmetic-bitwise.test
View file

@ -43,7 +43,9 @@
(with-test-prefix "bitwise-bit-count" (with-test-prefix "bitwise-bit-count"
(pass-if "bitwise-bit-count simple" (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" (with-test-prefix "bitwise-length"
(pass-if "bitwise-length simple" (pass-if "bitwise-length simple"

4
test-suite/tests/web-uri.test
View file

@ -259,5 +259,5 @@
(with-test-prefix "encode" (with-test-prefix "encode"
(pass-if (equal? "foo%20bar" (uri-encode "foo bar"))) (pass-if (equal? "foo%20bar" (uri-encode "foo bar")))
(pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar"))) (pass-if (equal? "foo%0A%00bar" (uri-encode "foo\n\x00bar")))
(pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^")))) (pass-if (equal? "%3C%3E%5C%5E" (uri-encode "<>\\^"))))