/[guile]/guile/guile-core/libguile/numbers.c
ViewVC logotype

Diff of /guile/guile-core/libguile/numbers.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.160 by ossau, Fri Mar 15 10:37:40 2002 UTC revision 1.161 by mvo, Mon May 6 22:33:10 2002 UTC
# Line 72  static SCM scm_divbigint (SCM x, long z, Line 72  static SCM scm_divbigint (SCM x, long z,
72   */   */
73  #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)  #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
74    
75    #if defined (SCO)
76  /* IS_INF tests its floating point number for infiniteness  #if ! defined (HAVE_ISNAN)
77     Dirk:FIXME:: This test does not work if x == 0  #define HAVE_ISNAN
78   */  static int
79  #ifndef IS_INF  isnan (double x)
80  #define IS_INF(x) ((x) == (x) / 2)  {
81      return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0;
82    }
83  #endif  #endif
84    #if ! defined (HAVE_ISINF)
85    #define HAVE_ISINF
86    static int
87    isinf (double x)
88    {
89      return (IsNANorINF (x) && IsINF (x)) ? 1 : 0;
90    }
91    
92    #endif
 /* Return true if X is not infinite and is not a NaN  
    Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0  
  */  
 #ifndef isfinite  
 #define isfinite(x) (!IS_INF (x) && (x) == (x))  
93  #endif  #endif
94    
95    
# Line 122  SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, Line 126  SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
126      return SCM_BOOL ((4 & SCM_UNPACK (n)) != 0);      return SCM_BOOL ((4 & SCM_UNPACK (n)) != 0);
127    } else if (SCM_BIGP (n)) {    } else if (SCM_BIGP (n)) {
128      return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) != 0);      return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) != 0);
129      } else if (scm_inf_p (n)) {
130        return SCM_BOOL_T;
131    } else {    } else {
132      SCM_WRONG_TYPE_ARG (1, n);      SCM_WRONG_TYPE_ARG (1, n);
133    }    }
# Line 139  SCM_DEFINE (scm_even_p, "even?", 1, 0, 0 Line 145  SCM_DEFINE (scm_even_p, "even?", 1, 0, 0
145      return SCM_BOOL ((4 & SCM_UNPACK (n)) == 0);      return SCM_BOOL ((4 & SCM_UNPACK (n)) == 0);
146    } else if (SCM_BIGP (n)) {    } else if (SCM_BIGP (n)) {
147      return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) == 0);      return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) == 0);
148      } else if (scm_inf_p (n)) {
149        return SCM_BOOL_T;
150    } else {    } else {
151      SCM_WRONG_TYPE_ARG (1, n);      SCM_WRONG_TYPE_ARG (1, n);
152    }    }
153  }  }
154  #undef FUNC_NAME  #undef FUNC_NAME
155    
156    static int
157    xisinf (double x)
158    {
159    #if defined (HAVE_ISINF)
160      return isinf (x);
161    #elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
162      return (! (finite (x) || isnan (x)));
163    #else
164      return 0;
165    #endif
166    }
167    
168    static int
169    xisnan (double x)
170    {
171    #if defined (HAVE_ISNAN)
172      return isnan (x);
173    #else
174      return 0;
175    #endif
176    }
177    
178    #define isfinite(x) (! xisinf (x))
179    
180    SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
181                (SCM n),
182                "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
183                "otherwise.")
184    #define FUNC_NAME s_scm_inf_p
185    {
186      if (SCM_REALP (n)) {
187        return SCM_BOOL (xisinf (SCM_REAL_VALUE (n)));
188      } else if (SCM_COMPLEXP (n)) {
189        return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n))
190                         || xisinf (SCM_COMPLEX_IMAG (n)));
191      } else {
192        return SCM_BOOL_F;
193      }
194    }
195    #undef FUNC_NAME
196    
197    SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
198                (SCM n),
199                "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
200                "otherwise.")
201    #define FUNC_NAME s_scm_nan_p
202    {
203      if (SCM_REALP (n)) {
204        return SCM_BOOL (xisnan (SCM_REAL_VALUE (n)));
205      } else if (SCM_COMPLEXP (n)) {
206        return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n))
207                         || xisnan (SCM_COMPLEX_IMAG (n)));
208      } else {
209        return SCM_BOOL_F;
210      }
211    }
212    #undef FUNC_NAME
213    
214    /* Guile's idea of infinity.  */
215    static double guile_Inf;
216    
217    /* Guile's idea of not a number.  */
218    static double guile_NaN;
219    
220    static void
221    guile_ieee_init (void)
222    {
223    #if defined (HAVE_ISINF) || defined (HAVE_FINITE)
224    
225    /* Some version of gcc on some old version of Linux used to crash when
226       trying to make Inf and NaN.  */
227    
228    #if defined (SCO)
229      double tmp = 1.0;
230      guile_Inf = 1.0 / (tmp - tmp);
231    #elif defined (__alpha__) && ! defined (linux)
232      extern unsigned int DINFINITY[2];
233      guile_Inf = (*(X_CAST(double *, DINFINITY)));
234    #else
235      double tmp = 1e+10;
236      guile_Inf = tmp;
237      for (;;)
238        {
239          guile_Inf *= 1e+10;
240          if (guile_Inf == tmp)
241            break;
242          tmp = guile_Inf;
243        }
244    #endif
245    
246    #endif
247    
248    #if defined (HAVE_ISNAN)
249    
250    #if defined (__alpha__) && ! defined (linux)
251      extern unsigned int DQNAN[2];
252      guile_NaN =  (*(X_CAST(double *, DQNAN)));
253    #else
254      guile_NaN = guile_Inf / guile_Inf;
255    #endif
256    
257    #endif
258    }
259    
260    SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
261                (void),
262                "Return Inf.")
263    #define FUNC_NAME s_scm_inf
264    {
265      static int initialized = 0;
266      if (! initialized)
267        {
268          guile_ieee_init ();
269          initialized = 1;
270        }
271      return scm_make_real (guile_Inf);
272    }
273    #undef FUNC_NAME
274    
275    SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
276                (void),
277                "Return NaN.")
278    #define FUNC_NAME s_scm_nan
279    {
280      static int initialized = 0;
281      if (! initialized)
282        {
283          guile_ieee_init ();
284          initialized = 1;
285        }
286      return scm_make_real (guile_NaN);
287    }
288    #undef FUNC_NAME
289    
290    
291  SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);  SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);
292  /* "Return the absolute value of @var{x}."  /* "Return the absolute value of @var{x}."
# Line 1934  idbl2str (double f, char *a) Line 2076  idbl2str (double f, char *a)
2076    
2077    if (f == 0.0)    if (f == 0.0)
2078      goto zero;                  /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */      goto zero;                  /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2079    
2080      if (xisinf (f))
2081        {
2082          if (f < 0)
2083            strcpy (a, "-inf.0");
2084          else
2085            strcpy (a, "+inf.0");
2086          return ch+6;
2087        }
2088      else if (xisnan (f))
2089        {
2090          strcpy (a, "+nan.0");
2091          return ch+6;
2092        }
2093    
2094    if (f < 0.0)    if (f < 0.0)
2095      {      {
2096        f = -f;        f = -f;
2097        a[ch++] = '-';        a[ch++] = '-';
2098      }      }
2099    else if (f > 0.0);  
   else  
     goto funny;  
   if (IS_INF (f))  
     {  
       if (ch == 0)  
         a[ch++] = '+';  
     funny:  
       a[ch++] = '#';  
       a[ch++] = '.';  
       a[ch++] = '#';  
       return ch;  
     }  
2100  #ifdef DBL_MIN_10_EXP  /* Prevent unnormalized values, as from  #ifdef DBL_MIN_10_EXP  /* Prevent unnormalized values, as from
2101                            make-uniform-vector, from causing infinite loops. */                            make-uniform-vector, from causing infinite loops. */
2102    while (f < 1.0)    while (f < 1.0)
2103      {      {
2104        f *= 10.0;        f *= 10.0;
2105        if (exp-- < DBL_MIN_10_EXP)        if (exp-- < DBL_MIN_10_EXP)
2106          goto funny;          {
2107              a[ch++] = '#';
2108              a[ch++] = '.';
2109              a[ch++] = '#';
2110              return ch;
2111            }
2112      }      }
2113    while (f > 10.0)    while (f > 10.0)
2114      {      {
2115        f *= 0.10;        f *= 0.10;
2116        if (exp++ > DBL_MAX_10_EXP)        if (exp++ > DBL_MAX_10_EXP)
2117          goto funny;          {
2118              a[ch++] = '#';
2119              a[ch++] = '.';
2120              a[ch++] = '#';
2121              return ch;
2122            }
2123      }      }
2124  #else  #else
2125    while (f < 1.0)    while (f < 1.0)
# Line 2076  iflo2str (SCM flt, char *str) Line 2231  iflo2str (SCM flt, char *str)
2231        i = idbl2str (SCM_COMPLEX_REAL (flt), str);        i = idbl2str (SCM_COMPLEX_REAL (flt), str);
2232        if (SCM_COMPLEX_IMAG (flt) != 0.0)        if (SCM_COMPLEX_IMAG (flt) != 0.0)
2233          {          {
2234            if (0 <= SCM_COMPLEX_IMAG (flt))            double imag = SCM_COMPLEX_IMAG (flt);
2235              /* Don't output a '+' for negative numbers or for Inf and
2236                 NaN.  They will provide their own sign. */
2237              if (0 <= imag && !xisinf (imag) && !xisnan (imag))
2238              str[i++] = '+';              str[i++] = '+';
2239            i += idbl2str (SCM_COMPLEX_IMAG (flt), &str[i]);            i += idbl2str (imag, &str[i]);
2240            str[i++] = 'i';            str[i++] = 'i';
2241          }          }
2242      }      }
# Line 2514  mem2ureal (const char* mem, size_t len, Line 2672  mem2ureal (const char* mem, size_t len,
2672    if (idx == len)    if (idx == len)
2673      return SCM_BOOL_F;      return SCM_BOOL_F;
2674    
2675      if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
2676        {
2677          *p_idx = idx+5;
2678          return scm_inf ();
2679        }
2680    
2681      if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
2682        {
2683          enum t_exactness x = EXACT;
2684    
2685          /* Cobble up the fraction.  We might want to set the NaN's
2686             mantissa from it. */
2687          idx += 4;
2688          mem2uinteger (mem, len, &idx, 10, &x);
2689          *p_idx = idx;
2690          return scm_nan ();
2691        }
2692    
2693    if (mem[idx] == '.')    if (mem[idx] == '.')
2694      {      {
2695        if (radix != 10)        if (radix != 10)
# Line 3694  scm_num2dbl (SCM a, const char *why) Line 3870  scm_num2dbl (SCM a, const char *why)
3870  }  }
3871  #undef FUNC_NAME  #undef FUNC_NAME
3872    
3873    #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3874         || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3875    #define ALLOW_DIVIDE_BY_ZERO
3876    /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3877    #endif
3878    
3879  /* The code below for complex division is adapted from the GNU  /* The code below for complex division is adapted from the GNU
3880     libstdc++, which adapted it from f2c's libF77, and is subject to     libstdc++, which adapted it from f2c's libF77, and is subject to
# Line 3739  scm_divide (SCM x, SCM y) Line 3920  scm_divide (SCM x, SCM y)
3920        long xx = SCM_INUM (x);        long xx = SCM_INUM (x);
3921        if (xx == 1 || xx == -1) {        if (xx == 1 || xx == -1) {
3922          return x;          return x;
3923    #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3924        } else if (xx == 0) {        } else if (xx == 0) {
3925          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
3926    #endif
3927        } else {        } else {
3928          return scm_make_real (1.0 / (double) xx);          return scm_make_real (1.0 / (double) xx);
3929        }        }
# Line 3748  scm_divide (SCM x, SCM y) Line 3931  scm_divide (SCM x, SCM y)
3931        return scm_make_real (1.0 / scm_i_big2dbl (x));        return scm_make_real (1.0 / scm_i_big2dbl (x));
3932      } else if (SCM_REALP (x)) {      } else if (SCM_REALP (x)) {
3933        double xx = SCM_REAL_VALUE (x);        double xx = SCM_REAL_VALUE (x);
3934    #ifndef ALLOW_DIVIDE_BY_ZERO
3935        if (xx == 0.0)        if (xx == 0.0)
3936          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
3937        else        else
3938    #endif
3939          return scm_make_real (1.0 / xx);          return scm_make_real (1.0 / xx);
3940      } else if (SCM_COMPLEXP (x)) {      } else if (SCM_COMPLEXP (x)) {
3941        double r = SCM_COMPLEX_REAL (x);        double r = SCM_COMPLEX_REAL (x);
# Line 3774  scm_divide (SCM x, SCM y) Line 3959  scm_divide (SCM x, SCM y)
3959      if (SCM_INUMP (y)) {      if (SCM_INUMP (y)) {
3960        long yy = SCM_INUM (y);        long yy = SCM_INUM (y);
3961        if (yy == 0) {        if (yy == 0) {
3962    #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3963          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
3964    #else
3965            return scm_make_real ((double) xx / (double) yy);
3966    #endif
3967        } else if (xx % yy != 0) {        } else if (xx % yy != 0) {
3968          return scm_make_real ((double) xx / (double) yy);          return scm_make_real ((double) xx / (double) yy);
3969        } else {        } else {
# Line 3793  scm_divide (SCM x, SCM y) Line 3982  scm_divide (SCM x, SCM y)
3982        return scm_make_real ((double) xx / scm_i_big2dbl (y));        return scm_make_real ((double) xx / scm_i_big2dbl (y));
3983      } else if (SCM_REALP (y)) {      } else if (SCM_REALP (y)) {
3984        double yy = SCM_REAL_VALUE (y);        double yy = SCM_REAL_VALUE (y);
3985    #ifndef ALLOW_DIVIDE_BY_ZERO
3986        if (yy == 0.0)        if (yy == 0.0)
3987          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
3988        else        else
3989    #endif
3990          return scm_make_real ((double) xx / yy);          return scm_make_real ((double) xx / yy);
3991      } else if (SCM_COMPLEXP (y)) {      } else if (SCM_COMPLEXP (y)) {
3992        a = xx;        a = xx;
# Line 3820  scm_divide (SCM x, SCM y) Line 4011  scm_divide (SCM x, SCM y)
4011      if (SCM_INUMP (y)) {      if (SCM_INUMP (y)) {
4012        long int yy = SCM_INUM (y);        long int yy = SCM_INUM (y);
4013        if (yy == 0) {        if (yy == 0) {
4014    #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4015          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
4016    #else
4017            if (scm_bigcomp (x, scm_i_int2big (0)) == 0)
4018              return scm_nan ();
4019            else
4020              return scm_inf ();
4021    #endif
4022        } else if (yy == 1) {        } else if (yy == 1) {
4023          return x;          return x;
4024        } else {        } else {
# Line 3859  scm_divide (SCM x, SCM y) Line 4057  scm_divide (SCM x, SCM y)
4057          : scm_make_real (scm_i_big2dbl (x) / scm_i_big2dbl (y));          : scm_make_real (scm_i_big2dbl (x) / scm_i_big2dbl (y));
4058      } else if (SCM_REALP (y)) {      } else if (SCM_REALP (y)) {
4059        double yy = SCM_REAL_VALUE (y);        double yy = SCM_REAL_VALUE (y);
4060    #ifndef ALLOW_DIVIDE_BY_ZERO
4061        if (yy == 0.0)        if (yy == 0.0)
4062          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
4063        else        else
4064    #endif
4065          return scm_make_real (scm_i_big2dbl (x) / yy);          return scm_make_real (scm_i_big2dbl (x) / yy);
4066      } else if (SCM_COMPLEXP (y)) {      } else if (SCM_COMPLEXP (y)) {
4067        a = scm_i_big2dbl (x);        a = scm_i_big2dbl (x);
# Line 3873  scm_divide (SCM x, SCM y) Line 4073  scm_divide (SCM x, SCM y)
4073      double rx = SCM_REAL_VALUE (x);      double rx = SCM_REAL_VALUE (x);
4074      if (SCM_INUMP (y)) {      if (SCM_INUMP (y)) {
4075        long int yy = SCM_INUM (y);        long int yy = SCM_INUM (y);
4076        if (yy == 0) {  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4077          if (yy == 0)
4078          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
4079        } else {        else
4080    #endif
4081          return scm_make_real (rx / (double) yy);          return scm_make_real (rx / (double) yy);
       }  
4082      } else if (SCM_BIGP (y)) {      } else if (SCM_BIGP (y)) {
4083        return scm_make_real (rx / scm_i_big2dbl (y));        return scm_make_real (rx / scm_i_big2dbl (y));
4084      } else if (SCM_REALP (y)) {      } else if (SCM_REALP (y)) {
4085        double yy = SCM_REAL_VALUE (y);        double yy = SCM_REAL_VALUE (y);
4086    #ifndef ALLOW_DIVIDE_BY_ZERO
4087        if (yy == 0.0)        if (yy == 0.0)
4088          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
4089        else        else
4090    #endif
4091          return scm_make_real (rx / yy);          return scm_make_real (rx / yy);
4092      } else if (SCM_COMPLEXP (y)) {      } else if (SCM_COMPLEXP (y)) {
4093        a = rx;        a = rx;
# Line 3897  scm_divide (SCM x, SCM y) Line 4100  scm_divide (SCM x, SCM y)
4100      double ix = SCM_COMPLEX_IMAG (x);      double ix = SCM_COMPLEX_IMAG (x);
4101      if (SCM_INUMP (y)) {      if (SCM_INUMP (y)) {
4102        long int yy = SCM_INUM (y);        long int yy = SCM_INUM (y);
4103        if (yy == 0) {  #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4104          if (yy == 0)
4105          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
4106        } else {        else
4107    #endif
4108          {
4109          double d = yy;          double d = yy;
4110          return scm_make_complex (rx / d, ix / d);          return scm_make_complex (rx / d, ix / d);
4111        }        }
# Line 3908  scm_divide (SCM x, SCM y) Line 4114  scm_divide (SCM x, SCM y)
4114        return scm_make_complex (rx / d, ix / d);        return scm_make_complex (rx / d, ix / d);
4115      } else if (SCM_REALP (y)) {      } else if (SCM_REALP (y)) {
4116        double yy = SCM_REAL_VALUE (y);        double yy = SCM_REAL_VALUE (y);
4117    #ifndef ALLOW_DIVIDE_BY_ZERO
4118        if (yy == 0.0)        if (yy == 0.0)
4119          scm_num_overflow (s_divide);          scm_num_overflow (s_divide);
4120        else        else
4121    #endif
4122          return scm_make_complex (rx / yy, ix / yy);          return scm_make_complex (rx / yy, ix / yy);
4123      } else if (SCM_COMPLEXP (y)) {      } else if (SCM_COMPLEXP (y)) {
4124        double ry = SCM_COMPLEX_REAL (y);        double ry = SCM_COMPLEX_REAL (y);

Legend:
Removed from v.1.160  
changed lines
  Added in v.1.161

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26