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 |
|
|
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 |
} |
} |
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}." |
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) |
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 |
} |
} |
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) |
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 |
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 |
} |
} |
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); |
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 { |
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; |
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 { |
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); |
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; |
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 |
} |
} |
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); |