diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/error.c | 3 | ||||
-rw-r--r-- | libguile/eval.c | 12 | ||||
-rw-r--r-- | libguile/keywords.c | 20 | ||||
-rw-r--r-- | libguile/numbers.c | 115 | ||||
-rw-r--r-- | libguile/posix.c | 4 | ||||
-rw-r--r-- | libguile/socket.c | 2 | ||||
-rw-r--r-- | libguile/threads.c | 4 | ||||
-rw-r--r-- | libguile/vm-engine.c | 6 | ||||
-rw-r--r-- | libguile/vm-i-scheme.c | 8 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 4 | ||||
-rw-r--r-- | libguile/vm.c | 12 |
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 |