mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 17:50:29 +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-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))))

1
THANKS
View file

@ -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

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
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

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

@ -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

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
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

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"
"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

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);
}
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. */

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
* 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;

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_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;

4
libguile/posix.c
View file

@ -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));

2
libguile/socket.c
View file

@ -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

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 (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;

6
libguile/vm-engine.c
View file

@ -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)
{

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_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. */
{

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)
|| (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;

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_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

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

@ -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)

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

@ -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

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

@ -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)))

11
module/web/uri.scm
View file

@ -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))

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

@ -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);'

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

@ -24,20 +24,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)
{
@ -57,6 +43,21 @@ test_unrecognized_keyword (void *data)
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
test_invalid_keyword (void *data)
{
@ -75,6 +76,21 @@ test_invalid_keyword (void *data)
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
test_odd_length (void *data)
{
@ -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

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

@ -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:
;; 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
* 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);

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

@ -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)

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

@ -222,4 +222,5 @@
(throw 'unresolved)))))
(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
;; 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)))

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

@ -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 ->

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

@ -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

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

@ -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"

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

@ -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 "<>\\^"))))