summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-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
11 files changed, 125 insertions, 65 deletions
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