/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
* 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
- * 2013 Free Software Foundation, Inc.
+ * 2013, 2014 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
#endif
#include <verify.h>
+#include <assert.h>
#include <math.h>
#include <string.h>
if (SCM_I_INUMP (j))
{
- /* bits above what's in an inum follow the sign bit */
- iindex = min (iindex, SCM_LONG_BIT - 1);
- return scm_from_bool ((1L << iindex) & SCM_I_INUM (j));
+ if (iindex < SCM_LONG_BIT - 1)
+ /* Arrange for the number to be converted to unsigned before
+ checking the bit, to ensure that we're testing the bit in a
+ two's complement representation (regardless of the native
+ representation. */
+ return scm_from_bool ((1UL << iindex) & SCM_I_INUM (j));
+ else
+ /* Portably check the sign. */
+ return scm_from_bool (SCM_I_INUM (j) < 0);
}
else if (SCM_BIGP (j))
{
{
scm_t_inum nn = SCM_I_INUM (n);
- /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
+ /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
overflow a non-zero fixnum. For smaller shifts we check the
bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
- Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
+ Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
+
+ [*] There's one exception:
+ (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
if (nn == 0)
return n;
else if (count < SCM_I_FIXNUM_BIT-1 &&
((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1)
<= 1))
- return SCM_I_MAKINUM (nn << count);
+ return SCM_I_MAKINUM (nn < 0 ? -(-nn << count) : (nn << count));
else
{
SCM result = scm_i_inum2big (nn);
mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
count);
- return result;
+ return scm_i_normbig (result);
}
}
else if (SCM_BIGP (n))
return result;
}
else
- scm_syserror ("left_shift_exact_integer");
+ assert (0);
}
/* Efficiently compute floor (N / 2^COUNT),
return scm_i_normbig (result);
}
else
- scm_syserror ("floor_right_shift_exact_integer");
+ assert (0);
}
/* Efficiently compute round (N / 2^COUNT),
return scm_i_normbig (q);
}
else
- scm_syserror ("round_right_shift_exact_integer");
+ assert (0);
}
SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
static unsigned int
char_decimal_value (scm_t_uint32 c)
{
- /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
- that's certainly above any valid decimal, so we take advantage of
- that to elide some tests. */
- unsigned int d = (unsigned int) uc_decimal_value (c);
-
- /* If that failed, try extended hexadecimals, then. Only accept ascii
- hexadecimals. */
- if (d >= 10U)
+ if (c >= (scm_t_uint32) '0' && c <= (scm_t_uint32) '9')
+ return c - (scm_t_uint32) '0';
+ else
{
- c = uc_tolower (c);
- if (c >= (scm_t_uint32) 'a')
- d = c - (scm_t_uint32)'a' + 10U;
+ /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
+ that's certainly above any valid decimal, so we take advantage of
+ that to elide some tests. */
+ unsigned int d = (unsigned int) uc_decimal_value (c);
+
+ /* If that failed, try extended hexadecimals, then. Only accept ascii
+ hexadecimals. */
+ if (d >= 10U)
+ {
+ c = uc_tolower (c);
+ if (c >= (scm_t_uint32) 'a')
+ d = c - (scm_t_uint32)'a' + 10U;
+ }
+ return d;
}
- return d;
}
/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
}
/* We should never get here */
- scm_syserror ("mem2ureal");
+ assert (0);
}
SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
(SCM x),
- "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
- "else.")
+ "Return @code{#t} if @var{x} is an integer number,\n"
+ "else return @code{#f}.")
#define FUNC_NAME s_scm_integer_p
{
if (SCM_I_INUMP (x) || SCM_BIGP (x))
}
#undef FUNC_NAME
+SCM_DEFINE (scm_exact_integer_p, "exact-integer?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an exact integer number,\n"
+ "else return @code{#f}.")
+#define FUNC_NAME s_scm_exact_integer_p
+{
+ if (SCM_I_INUMP (x) || SCM_BIGP (x))
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM scm_i_num_eq_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_NUMERATOR (z);
else if (SCM_REALP (z))
- return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ {
+ double zz = SCM_REAL_VALUE (z);
+ if (zz == floor (zz))
+ /* Handle -0.0 and infinities in accordance with R6RS
+ flnumerator, and optimize handling of integers. */
+ return z;
+ else
+ return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ }
else
return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
}
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_DENOMINATOR (z);
else if (SCM_REALP (z))
- return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ {
+ double zz = SCM_REAL_VALUE (z);
+ if (zz == floor (zz))
+ /* Handle infinities in accordance with R6RS fldenominator, and
+ optimize handling of integers. */
+ return scm_i_from_double (1.0);
+ else
+ return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ }
else
return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
s_scm_denominator);
return scm_is_true (scm_integer_p (val));
}
+int
+scm_is_exact_integer (SCM val)
+{
+ return scm_is_true (scm_exact_integer_p (val));
+}
+
int
scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
{
HCoop / bpt / guile.git / blobdiff