prefer compilers earlier in list

[bpt/guile.git] / libguile / numbers.c

diff --git a/libguile/numbers.c b/libguile/numbers.c
index 7ccbeec..14d98ff 100644 (file)
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1,6 +1,6 @@
 /* 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.
@@ -4679,9 +4679,15 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
 
   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))
     {
@@ -4977,24 +4983,27 @@ left_shift_exact_integer (SCM n, long count)
     {
       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))
@@ -6516,8 +6525,8 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 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))
@@ -6532,6 +6541,19 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
 }
 #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,
@@ -9620,6 +9642,12 @@ scm_is_integer (SCM val)
   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)
 {