* threads.scm (letpar): New macro.

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

diff --git a/libguile/numbers.c b/libguile/numbers.c
index 9a90885..5e86a54 100644 (file)
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
  *
  * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
  * and Bellcore.  See scm_divide.
@@ -47,6 +47,7 @@
 
 #include <math.h>
 #include <ctype.h>
+#include <string.h>
 #include "libguile/_scm.h"
 #include "libguile/feature.h"
 #include "libguile/ports.h"
@@ -64,7 +65,7 @@ static SCM scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, in
 static SCM scm_divbigint (SCM x, long z, int sgn, int mode);
 
 
-#define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
+#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
 
 
 /* FLOBUFLEN is the maximum number of characters neccessary for the
@@ -897,15 +898,10 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
       return SCM_MAKINUM (-1);
     } else if (!SCM_NUMBERP (n1)) {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
-#ifndef SCM_RECKLESS
     } else if (SCM_NUMBERP (n1)) {
       return n1;
     } else {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
-#else
-    } else {
-      return n1;
-#endif
     }
   }
 
@@ -981,15 +977,10 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
   if (SCM_UNBNDP (n2)) {
     if (SCM_UNBNDP (n1)) {
       return SCM_INUM0;
-#ifndef SCM_RECKLESS
     } else if (SCM_NUMBERP (n1)) {
       return n1;
     } else {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
-#else
-    } else {
-      return n1;
-#endif
     }
   }
 
@@ -1068,15 +1059,10 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
   if (SCM_UNBNDP (n2)) {
     if (SCM_UNBNDP (n1)) {
       return SCM_INUM0;
-#ifndef SCM_RECKLESS
     } else if (SCM_NUMBERP (n1)) {
       return n1;
     } else {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
-#else
-    } else {
-      return n1;
-#endif
     }
   }
 
@@ -1258,8 +1244,9 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
   SCM acc = SCM_MAKINUM (1L);
   int i2;
 #ifdef SCM_BIGDIG
+  /* 0^0 == 1 according to R5RS */
   if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc))
-    return n;
+    return SCM_FALSEP (scm_zero_p(k)) ? n : acc;
   else if (SCM_EQ_P (n, SCM_MAKINUM (-1L)))
     return SCM_FALSEP (scm_even_p (k)) ? n : acc;
 #endif
@@ -1271,7 +1258,7 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
        SCM_WRONG_TYPE_ARG (2, k);
     }
   else
-    SCM_VALIDATE_ULONG_COPY (2,k,i2);
+    SCM_VALIDATE_ULONG_COPY (2, k, i2);
   if (i2 < 0)
     {
       i2 = -i2;
@@ -1364,7 +1351,7 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
 #define FUNC_NAME s_scm_bit_extract
 {
   unsigned long int istart, iend;
-  SCM_VALIDATE_INUM_MIN_COPY (2,start,0,istart);
+  SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart);
   SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
   SCM_ASSERT_RANGE (3, end, (iend >= istart));
 
@@ -2075,7 +2062,16 @@ idbl2str (double f, char *a)
   int exp = 0;
 
   if (f == 0.0)
-    goto zero;                 /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
+    {
+#ifdef HAVE_COPYSIGN
+      double sgn = copysign (1.0, f);
+
+      if (sgn < 0.0)
+       a[ch++] = '-';
+#endif
+
+      goto zero;       /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
+    }
 
   if (xisinf (f))
     {
@@ -2293,6 +2289,12 @@ big2str (SCM b, unsigned int radix)
   SCM_BIGDIG radpow = 1, radmod = 0;
   SCM ss = scm_allocate_string (j);
   char *s = SCM_STRING_CHARS (ss), c;
+
+  if (i == 0)
+    {
+      return scm_makfrom0str ("0");
+    }
+  
   while ((long) radpow * radix < SCM_BIGRAD)
     {
       radpow *= radix;
@@ -2668,6 +2670,7 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
           unsigned int radix, enum t_exactness *p_exactness)
 {
   unsigned int idx = *p_idx;
+  SCM result;
 
   if (idx == len)
     return SCM_BOOL_F;
@@ -2699,14 +2702,13 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
       else if (!isdigit (mem[idx + 1]))
        return SCM_BOOL_F;
       else
-       return mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
-                                      p_idx, p_exactness);
+       result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
+                                        p_idx, p_exactness);
     }
   else
     {
       enum t_exactness x = EXACT;
       SCM uinteger;
-      SCM result;
 
       uinteger = mem2uinteger (mem, len, &idx, radix, &x);
       if (SCM_FALSEP (uinteger))
@@ -2738,9 +2740,15 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
       *p_idx = idx;
       if (x == INEXACT)
        *p_exactness = x;
-
-      return result;
     }
+
+  /* When returning an inexact zero, make sure it is represented as a
+     floating point value so that we can change its sign. 
+  */
+  if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT)
+    result = scm_make_real (0.0);
+
+  return result;
 }
 
 
@@ -2793,7 +2801,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
     }
   else
     {
-      if (sign == -1)
+      if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
        ureal = scm_difference (ureal, SCM_UNDEFINED);
 
       if (idx == len)
@@ -2844,7 +2852,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
              if (idx != len)
                return SCM_BOOL_F;
 
-             if (sign == -1)
+             if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
                angle = scm_difference (angle, SCM_UNDEFINED);
 
              result = scm_make_polar (ureal, angle);
@@ -2864,7 +2872,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
 
              if (SCM_FALSEP (imag))
                imag = SCM_MAKINUM (sign);
-             else if (sign == -1)
+             else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
                imag = scm_difference (imag, SCM_UNDEFINED);
 
              if (idx == len)
@@ -2991,7 +2999,7 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
   SCM answer;
   int base;
   SCM_VALIDATE_STRING (1, string);
-  SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base);
+  SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base);
   answer = scm_i_mem2number (SCM_STRING_CHARS (string),
                           SCM_STRING_LENGTH (string),
                           base);
@@ -3006,8 +3014,8 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
 SCM
 scm_make_real (double x)
 {
-  SCM z;
-  z = scm_double_cell (scm_tc16_real, 0, 0, 0);
+  SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
+
   SCM_REAL_VALUE (z) = x;
   return z;
 }
@@ -3284,6 +3292,8 @@ scm_leq_p (SCM x, SCM y)
     SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
   else if (!SCM_NUMBERP (y))
     SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+  else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
+    return SCM_BOOL_F;
   else
     return SCM_BOOL_NOT (scm_less_p (y, x));
 }
@@ -3302,8 +3312,10 @@ scm_geq_p (SCM x, SCM y)
     SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
   else if (!SCM_NUMBERP (y))
     SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+  else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
+    return SCM_BOOL_F;
   else
-  return SCM_BOOL_NOT (scm_less_p (x, y));
+    return SCM_BOOL_NOT (scm_less_p (x, y));
 }
 #undef FUNC_NAME
 
@@ -4479,7 +4491,7 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
     if (SCM_FIXABLE (lu)) {
       return SCM_MAKINUM (lu);
 #ifdef SCM_BIGDIG
-    } else if (isfinite (u)) {
+    } else if (isfinite (u) && !xisnan (u)) {
       return scm_i_dbl2big (u);
 #endif
     } else {
@@ -4517,10 +4529,8 @@ scm_i_dbl2big (double d)
       u -= c;
       digits[i] = c;
     }
-#ifndef SCM_RECKLESS
   if (u != 0)
     scm_num_overflow ("dbl2big");
-#endif
   return ans;
 }