HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* num2integral.i.c (NUM2INTEGRAL): use SCM_CHAR_BIT.
[bpt/guile.git] / libguile / numbers.c
CommitLineData
a48d60b1 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc.
ba74ef4e
MV		 2 *
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
5 *
f81e080b 6 *
73be1d9e
MV		 7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public
9 * License as published by the Free Software Foundation; either
10 * version 2.1 of the License, or (at your option) any later version.
0f2d19dd 11 *
73be1d9e
MV		 12 * This library is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
0f2d19dd 16 *
73be1d9e
MV		 17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 */
1bbd0b84 21
0f2d19dd 22\f
ca46fb90
RB		 23/* General assumptions:
24 * All objects satisfying SCM_COMPLEXP() have a non-zero complex component.
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 */
29
30/* TODO:
31
32 - see if special casing bignums and reals in integer-exponent when
33 possible (to use mpz_pow and mpf_pow_ui) is faster.
34
35 - look in to better short-circuiting of common cases in
36 integer-expt and elsewhere.
37
38 - see if direct mpz operations can help in ash and elsewhere.
39
40 */
0f2d19dd 41
ee33d62a
RB		 42#if HAVE_CONFIG_H
43# include <config.h>
44#endif
45
0f2d19dd 46#include <math.h>
3c9a524f 47#include <ctype.h>
fc194577 48#include <string.h>
ca46fb90 49#include <gmp.h>
a0599745 50#include "libguile/_scm.h"
a0599745
MD		 51#include "libguile/feature.h"
52#include "libguile/ports.h"
53#include "libguile/root.h"
54#include "libguile/smob.h"
55#include "libguile/strings.h"
a0599745
MD		 56
57#include "libguile/validate.h"
58#include "libguile/numbers.h"
1be6b49c 59#include "libguile/deprecation.h"
f4c627b3 60
0f2d19dd 61\f
f4c627b3 62
ca46fb90
RB		 63/*
64 Wonder if this might be faster for some of our code? A switch on
65 the numtag would jump directly to the right case, and the
66 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
67
68 #define SCM_I_NUMTAG_NOTNUM 0
69 #define SCM_I_NUMTAG_INUM 1
70 #define SCM_I_NUMTAG_BIG scm_tc16_big
71 #define SCM_I_NUMTAG_REAL scm_tc16_real
72 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
73 #define SCM_I_NUMTAG(x) \
74 (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \
75 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
76 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_smob) ? SCM_TYP16(x) \
77 : SCM_I_NUMTAG_NOTNUM)))
78*/
f4c627b3
DH		 79
80
34d19ef6 81#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
09fb7599 82
56e55ac7 83/* FLOBUFLEN is the maximum number of characters neccessary for the
3a9809df
DH		 84 * printed or scm_string representation of an inexact number.
85 */
56e55ac7 86#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
3a9809df 87
7351e207
MV		 88#if defined (SCO)
89#if ! defined (HAVE_ISNAN)
90#define HAVE_ISNAN
91static int
92isnan (double x)
93{
94 return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0;
95}
0f2d19dd 96#endif
7351e207
MV		 97#if ! defined (HAVE_ISINF)
98#define HAVE_ISINF
99static int
100isinf (double x)
101{
102 return (IsNANorINF (x) && IsINF (x)) ? 1 : 0;
103}
0f2d19dd 104
7351e207 105#endif
e6f3ef58
MD		 106#endif
107
0f2d19dd
JB		 108\f
109
ac0c002c
DH		 110static SCM abs_most_negative_fixnum;
111
112\f
113
ca46fb90
RB		 114static const char s_bignum[] = "bignum";
115
116SCM_C_INLINE SCM
117scm_i_mkbig ()
118{
119 /* Return a newly created bignum. */
120 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
121 mpz_init (SCM_I_BIG_MPZ (z));
122 return z;
123}
124
125SCM_C_INLINE static SCM
126scm_i_clonebig (SCM src_big, int same_sign_p)
127{
128 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
129 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
130 mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
131 if (!same_sign_p) mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
132 return z;
133}
134
135SCM_C_INLINE int
136scm_i_bigcmp (SCM x, SCM y)
137{
138 /* Return neg if x < y, pos if x > y, and 0 if x == y */
139 /* presume we already know x and y are bignums */
140 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
141 scm_remember_upto_here_2 (x, y);
142 return result;
143}
144
145SCM_C_INLINE SCM
146scm_i_dbl2big (double d)
147{
148 /* results are only defined if d is an integer */
149 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
150 mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
151 return z;
152}
153
154SCM_C_INLINE double
155scm_i_big2dbl (SCM b)
156{
157 double result = mpz_get_d (SCM_I_BIG_MPZ (b));
158 scm_remember_upto_here_1 (b);
159 return result;
160}
161
162SCM_C_INLINE SCM
163scm_i_normbig (SCM b)
164{
165 /* convert a big back to a fixnum if it'll fit */
166 /* presume b is a bignum */
167 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
168 {
169 long val = mpz_get_si (SCM_I_BIG_MPZ (b));
170 if (SCM_FIXABLE (val))
171 b = SCM_MAKINUM (val);
172 }
173 return b;
174}
f872b822 175
a1ec6916 176SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
1bbd0b84 177 (SCM x),
942e5b91
MG		 178 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
179 "otherwise.")
1bbd0b84 180#define FUNC_NAME s_scm_exact_p
0f2d19dd 181{
ca46fb90
RB		 182 if (SCM_INUMP (x)) return SCM_BOOL_T;
183 if (SCM_BIGP (x)) return SCM_BOOL_T;
184 return SCM_BOOL_F;
0f2d19dd 185}
1bbd0b84 186#undef FUNC_NAME
0f2d19dd 187
4219f20d 188
a1ec6916 189SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
1bbd0b84 190 (SCM n),
942e5b91
MG		 191 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
192 "otherwise.")
1bbd0b84 193#define FUNC_NAME s_scm_odd_p
0f2d19dd 194{
4219f20d 195 if (SCM_INUMP (n)) {
ca46fb90
RB		 196 long val = SCM_INUM (n);
197 return SCM_BOOL ((val & 1L) != 0);
4219f20d 198 } else if (SCM_BIGP (n)) {
ca46fb90
RB		 199 int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
200 scm_remember_upto_here_1 (n);
201 return SCM_BOOL (odd_p);
7351e207
MV		 202 } else if (scm_inf_p (n)) {
203 return SCM_BOOL_T;
4219f20d 204 } else {
a1a33b0f 205 SCM_WRONG_TYPE_ARG (1, n);
4219f20d 206 }
0f2d19dd 207}
1bbd0b84 208#undef FUNC_NAME
0f2d19dd 209
4219f20d 210
a1ec6916 211SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
1bbd0b84 212 (SCM n),
942e5b91
MG		 213 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
214 "otherwise.")
1bbd0b84 215#define FUNC_NAME s_scm_even_p
0f2d19dd 216{
4219f20d 217 if (SCM_INUMP (n)) {
ca46fb90
RB		 218 long val = SCM_INUM (n);
219 return SCM_BOOL ((val & 1L) == 0);
4219f20d 220 } else if (SCM_BIGP (n)) {
ca46fb90
RB		 221 int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
222 scm_remember_upto_here_1 (n);
223 return SCM_BOOL (even_p);
7351e207
MV		 224 } else if (scm_inf_p (n)) {
225 return SCM_BOOL_T;
4219f20d 226 } else {
a1a33b0f 227 SCM_WRONG_TYPE_ARG (1, n);
4219f20d 228 }
0f2d19dd 229}
1bbd0b84 230#undef FUNC_NAME
0f2d19dd 231
7351e207
MV		 232static int
233xisinf (double x)
234{
235#if defined (HAVE_ISINF)
236 return isinf (x);
237#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
238 return (! (finite (x) || isnan (x)));
239#else
240 return 0;
241#endif
242}
243
244static int
245xisnan (double x)
246{
247#if defined (HAVE_ISNAN)
248 return isnan (x);
249#else
250 return 0;
251#endif
252}
253
254#define isfinite(x) (! xisinf (x))
255
256SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
257 (SCM n),
258 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
259 "otherwise.")
260#define FUNC_NAME s_scm_inf_p
261{
262 if (SCM_REALP (n)) {
263 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n)));
264 } else if (SCM_COMPLEXP (n)) {
265 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n))
266 || xisinf (SCM_COMPLEX_IMAG (n)));
267 } else {
268 return SCM_BOOL_F;
269 }
270}
271#undef FUNC_NAME
272
273SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
274 (SCM n),
275 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
276 "otherwise.")
277#define FUNC_NAME s_scm_nan_p
278{
279 if (SCM_REALP (n)) {
280 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n)));
281 } else if (SCM_COMPLEXP (n)) {
282 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n))
283 || xisnan (SCM_COMPLEX_IMAG (n)));
284 } else {
285 return SCM_BOOL_F;
286 }
287}
288#undef FUNC_NAME
289
290/* Guile's idea of infinity. */
291static double guile_Inf;
292
293/* Guile's idea of not a number. */
294static double guile_NaN;
295
296static void
297guile_ieee_init (void)
298{
299#if defined (HAVE_ISINF) || defined (HAVE_FINITE)
300
301/* Some version of gcc on some old version of Linux used to crash when
302 trying to make Inf and NaN. */
303
304#if defined (SCO)
305 double tmp = 1.0;
306 guile_Inf = 1.0 / (tmp - tmp);
307#elif defined (__alpha__) && ! defined (linux)
308 extern unsigned int DINFINITY[2];
309 guile_Inf = (*(X_CAST(double *, DINFINITY)));
310#else
311 double tmp = 1e+10;
312 guile_Inf = tmp;
313 for (;;)
314 {
315 guile_Inf *= 1e+10;
316 if (guile_Inf == tmp)
317 break;
318 tmp = guile_Inf;
319 }
320#endif
321
322#endif
323
324#if defined (HAVE_ISNAN)
325
326#if defined (__alpha__) && ! defined (linux)
327 extern unsigned int DQNAN[2];
328 guile_NaN = (*(X_CAST(double *, DQNAN)));
329#else
330 guile_NaN = guile_Inf / guile_Inf;
331#endif
332
333#endif
334}
335
336SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
337 (void),
338 "Return Inf.")
339#define FUNC_NAME s_scm_inf
340{
341 static int initialized = 0;
342 if (! initialized)
343 {
344 guile_ieee_init ();
345 initialized = 1;
346 }
347 return scm_make_real (guile_Inf);
348}
349#undef FUNC_NAME
350
351SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
352 (void),
353 "Return NaN.")
354#define FUNC_NAME s_scm_nan
355{
356 static int initialized = 0;
357 if (! initialized)
358 {
359 guile_ieee_init ();
360 initialized = 1;
361 }
362 return scm_make_real (guile_NaN);
363}
364#undef FUNC_NAME
365
4219f20d 366
a48d60b1
MD		 367SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
368 (SCM x),
369 "Return the absolute value of @var{x}.")
370#define FUNC_NAME
0f2d19dd 371{
4219f20d
DH		 372 if (SCM_INUMP (x)) {
373 long int xx = SCM_INUM (x);
374 if (xx >= 0) {
375 return x;
376 } else if (SCM_POSFIXABLE (-xx)) {
377 return SCM_MAKINUM (-xx);
378 } else {
1be6b49c 379 return scm_i_long2big (-xx);
4219f20d 380 }
4219f20d 381 } else if (SCM_BIGP (x)) {
ca46fb90
RB		 382 const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
383 if (sgn < 0) {
384 return scm_i_clonebig (x, 0);
4219f20d 385 } else {
ca46fb90 386 return x;
4219f20d 387 }
5986c47d
DH		 388 } else if (SCM_REALP (x)) {
389 return scm_make_real (fabs (SCM_REAL_VALUE (x)));
4219f20d 390 } else {
a48d60b1 391 SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
4219f20d 392 }
0f2d19dd 393}
a48d60b1 394#undef FUNC_NAME
0f2d19dd 395
4219f20d 396
9de33deb 397SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
942e5b91
MG		 398/* "Return the quotient of the numbers @var{x} and @var{y}."
399 */
0f2d19dd 400SCM
6e8d25a6 401scm_quotient (SCM x, SCM y)
0f2d19dd 402{
828865c3
DH		 403 if (SCM_INUMP (x)) {
404 long xx = SCM_INUM (x);
405 if (SCM_INUMP (y)) {
406 long yy = SCM_INUM (y);
407 if (yy == 0) {
408 scm_num_overflow (s_quotient);
409 } else {
410 long z = xx / yy;
4219f20d
DH		 411 if (SCM_FIXABLE (z)) {
412 return SCM_MAKINUM (z);
413 } else {
1be6b49c 414 return scm_i_long2big (z);
828865c3
DH		 415 }
416 }
4219f20d 417 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 418 if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
419 && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
ac0c002c
DH		 420 {
421 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
422 return SCM_MAKINUM (-1);
423 }
424 else
425 return SCM_MAKINUM (0);
4219f20d
DH		 426 } else {
427 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
828865c3 428 }
4219f20d
DH		 429 } else if (SCM_BIGP (x)) {
430 if (SCM_INUMP (y)) {
828865c3
DH		 431 long yy = SCM_INUM (y);
432 if (yy == 0) {
433 scm_num_overflow (s_quotient);
434 } else if (yy == 1) {
f872b822 435 return x;
828865c3 436 } else {
ca46fb90
RB		 437 SCM result = scm_i_mkbig ();
438 if (yy < 0) {
439 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - yy);
440 mpz_neg(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
441 } else {
442 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
443 }
444 scm_remember_upto_here_1 (x);
445 return scm_i_normbig (result);
828865c3 446 }
4219f20d 447 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 448 SCM result = scm_i_mkbig ();
449 mpz_tdiv_q(SCM_I_BIG_MPZ (result),
450 SCM_I_BIG_MPZ (x),
451 SCM_I_BIG_MPZ (y));
452 scm_remember_upto_here_2 (x, y);
453 return scm_i_normbig (result);
4219f20d
DH		 454 } else {
455 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
f872b822 456 }
4219f20d 457 } else {
89a7e495 458 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient);
0f2d19dd 459 }
0f2d19dd
JB		 460}
461
9de33deb 462SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
942e5b91
MG		 463/* "Return the remainder of the numbers @var{x} and @var{y}.\n"
464 * "@lisp\n"
465 * "(remainder 13 4) @result{} 1\n"
466 * "(remainder -13 4) @result{} -1\n"
467 * "@end lisp"
468 */
0f2d19dd 469SCM
6e8d25a6 470scm_remainder (SCM x, SCM y)
0f2d19dd 471{
89a7e495
DH		 472 if (SCM_INUMP (x)) {
473 if (SCM_INUMP (y)) {
474 long yy = SCM_INUM (y);
475 if (yy == 0) {
476 scm_num_overflow (s_remainder);
477 } else {
89a7e495 478 long z = SCM_INUM (x) % yy;
89a7e495
DH		 479 return SCM_MAKINUM (z);
480 }
89a7e495 481 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 482 if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
483 && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
ac0c002c
DH		 484 {
485 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
486 return SCM_MAKINUM (0);
487 }
488 else
489 return x;
89a7e495
DH		 490 } else {
491 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
492 }
89a7e495
DH		 493 } else if (SCM_BIGP (x)) {
494 if (SCM_INUMP (y)) {
495 long yy = SCM_INUM (y);
496 if (yy == 0) {
497 scm_num_overflow (s_remainder);
498 } else {
ca46fb90
RB		 499 SCM result = scm_i_mkbig ();
500 if (yy < 0) yy = - yy;
501 mpz_tdiv_r_ui(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
502 scm_remember_upto_here_1(x);
503 return scm_i_normbig (result);
89a7e495
DH		 504 }
505 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 506 SCM result = scm_i_mkbig ();
507 mpz_tdiv_r (SCM_I_BIG_MPZ (result),
508 SCM_I_BIG_MPZ (x),
509 SCM_I_BIG_MPZ (y));
510 scm_remember_upto_here_2(x, y);
511 return scm_i_normbig (result);
89a7e495
DH		 512 } else {
513 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
f872b822 514 }
89a7e495
DH		 515 } else {
516 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder);
517 }
0f2d19dd
JB		 518}
519
89a7e495 520
9de33deb 521SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
942e5b91
MG		 522/* "Return the modulo of the numbers @var{x} and @var{y}.\n"
523 * "@lisp\n"
524 * "(modulo 13 4) @result{} 1\n"
525 * "(modulo -13 4) @result{} 3\n"
526 * "@end lisp"
527 */
0f2d19dd 528SCM
6e8d25a6 529scm_modulo (SCM x, SCM y)
0f2d19dd 530{
828865c3
DH		 531 if (SCM_INUMP (x)) {
532 long xx = SCM_INUM (x);
533 if (SCM_INUMP (y)) {
534 long yy = SCM_INUM (y);
535 if (yy == 0) {
536 scm_num_overflow (s_modulo);
537 } else {
ca46fb90
RB		 538 /* FIXME: I think this may be a bug on some arches -- results
539 of % with negative second arg are undefined... */
828865c3 540 long z = xx % yy;
ca46fb90
RB		 541 long result;
542
543 if (yy < 0) {
544 if (z > 0) result = z + yy;
545 else result = z;
546 } else {
547 if (z < 0) result = z + yy;
548 else result = z;
549 }
550 return SCM_MAKINUM (result);
828865c3 551 }
09fb7599 552 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 553 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
554
555 if (sgn_y == 0) {
556 scm_num_overflow (s_modulo);
557 } else {
558 mpz_t z_x;
559 SCM result;
560
561 if (sgn_y < 0) {
562 SCM pos_y = scm_i_clonebig (y, 0);
563 /* do this after the last scm_op */
564 mpz_init_set_si (z_x, xx);
565 result = pos_y; /* re-use this bignum */
566 mpz_mod (SCM_I_BIG_MPZ (result), z_x, SCM_I_BIG_MPZ (pos_y));
567 scm_remember_upto_here_1 (pos_y);
568 } else {
569 result = scm_i_mkbig ();
570 /* do this after the last scm_op */
571 mpz_init_set_si (z_x, xx);
572 mpz_mod (SCM_I_BIG_MPZ (result), z_x, SCM_I_BIG_MPZ (y));
573 scm_remember_upto_here_1 (y);
574 }
575
576 if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0) {
577 mpz_add (SCM_I_BIG_MPZ (result),
578 SCM_I_BIG_MPZ (y),
579 SCM_I_BIG_MPZ (result));
580 }
581 scm_remember_upto_here_1 (y);
582 /* and do this before the next one */
583 mpz_clear (z_x);
584 return scm_i_normbig (result);
585 }
09fb7599
DH		 586 } else {
587 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
f872b822 588 }
09fb7599
DH		 589 } else if (SCM_BIGP (x)) {
590 if (SCM_INUMP (y)) {
828865c3
DH		 591 long yy = SCM_INUM (y);
592 if (yy == 0) {
593 scm_num_overflow (s_modulo);
594 } else {
ca46fb90
RB		 595 SCM result = scm_i_mkbig ();
596 mpz_mod_ui (SCM_I_BIG_MPZ (result),
597 SCM_I_BIG_MPZ (x),
598 (yy < 0) ? - yy : yy);
599 scm_remember_upto_here_1 (x);
600 if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) {
601 mpz_sub_ui (SCM_I_BIG_MPZ (result),
602 SCM_I_BIG_MPZ (result),
603 - yy);
604 }
605 return scm_i_normbig (result);
828865c3 606 }
09fb7599 607 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 608 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
609 if (sgn_y == 0) {
610 scm_num_overflow (s_modulo);
611 } else {
612 SCM result = scm_i_mkbig ();
613 int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
614 SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
615 mpz_mod (SCM_I_BIG_MPZ (result),
616 SCM_I_BIG_MPZ (x),
617 SCM_I_BIG_MPZ (pos_y));
618
619 scm_remember_upto_here_1 (x);
620 if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) {
621 mpz_add (SCM_I_BIG_MPZ (result),
622 SCM_I_BIG_MPZ (y),
623 SCM_I_BIG_MPZ (result));
624 }
625 scm_remember_upto_here_2 (y, pos_y);
626 return scm_i_normbig (result);
627 }
09fb7599
DH		 628 } else {
629 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
828865c3 630 }
09fb7599
DH		 631 } else {
632 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
828865c3 633 }
0f2d19dd
JB		 634}
635
9de33deb 636SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
942e5b91
MG		 637/* "Return the greatest common divisor of all arguments.\n"
638 * "If called without arguments, 0 is returned."
639 */
0f2d19dd 640SCM
6e8d25a6 641scm_gcd (SCM x, SCM y)
0f2d19dd 642{
ca46fb90
RB		 643 if (SCM_UNBNDP (y))
644 return (SCM_UNBNDP (x)) ? SCM_INUM0 : x;
645
646 if (SCM_INUMP (x))
647 {
648 if (SCM_INUMP (y))
649 {
650 long xx = SCM_INUM (x);
651 long yy = SCM_INUM (y);
652 long u = xx < 0 ? -xx : xx;
653 long v = yy < 0 ? -yy : yy;
654 long result;
655 if (xx == 0) {
656 result = v;
657 } else if (yy == 0) {
658 result = u;
659 } else {
660 long k = 1;
661 long t;
662 /* Determine a common factor 2^k */
663 while (!(1 & (u | v)))
664 {
665 k <<= 1;
666 u >>= 1;
667 v >>= 1;
668 }
669 /* Now, any factor 2^n can be eliminated */
670 if (u & 1)
671 t = -v;
672 else
673 {
674 t = u;
675 b3:
676 t = SCM_SRS (t, 1);
677 }
678 if (!(1 & t))
679 goto b3;
680 if (t > 0)
681 u = t;
682 else
683 v = -t;
684 t = u - v;
685 if (t != 0)
686 goto b3;
687 result = u * k;
688 }
689 return SCM_POSFIXABLE (result) \
690 ? SCM_MAKINUM (result) : scm_i_long2big (result);
691 }
692 else if (SCM_BIGP (y))
693 {
694 SCM result = scm_i_mkbig ();
695 SCM mx = scm_i_mkbig ();
696 mpz_set_si(SCM_I_BIG_MPZ (mx), SCM_INUM (x));
697 scm_remember_upto_here_1 (x);
698 mpz_gcd(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (mx), SCM_I_BIG_MPZ (y));
699 scm_remember_upto_here_2(mx, y);
700 return scm_i_normbig (result);
701 }
702 else
703 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
f872b822 704 }
ca46fb90
RB		 705 else if (SCM_BIGP (x))
706 {
707 if (SCM_INUMP (y))
708 {
709 unsigned long result;
710 long yy = SCM_INUM (y);
711 if (yy < 0) yy = -yy;
712 result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
713 scm_remember_upto_here_1 (x);
714 return SCM_POSFIXABLE (result) \
715 ? SCM_MAKINUM (result) : scm_ulong2num (result);
716 }
717 else if (SCM_BIGP (y))
718 {
719 SCM result = scm_i_mkbig ();
720 mpz_gcd(SCM_I_BIG_MPZ (result),
721 SCM_I_BIG_MPZ (x),
722 SCM_I_BIG_MPZ (y));
723 scm_remember_upto_here_2(x, y);
724 return scm_i_normbig (result);
725 }
726 else
727 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
09fb7599 728 }
ca46fb90 729 else
09fb7599 730 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
0f2d19dd
JB		 731}
732
9de33deb 733SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
942e5b91
MG		 734/* "Return the least common multiple of the arguments.\n"
735 * "If called without arguments, 1 is returned."
736 */
0f2d19dd 737SCM
6e8d25a6 738scm_lcm (SCM n1, SCM n2)
0f2d19dd 739{
ca46fb90
RB		 740 if (SCM_UNBNDP (n2))
741 {
742 if (SCM_UNBNDP (n1))
743 return SCM_MAKINUM (1L);
09fb7599
DH		 744 n2 = SCM_MAKINUM (1L);
745 }
09fb7599 746
09fb7599 747 SCM_GASSERT2 (SCM_INUMP (n1) || SCM_BIGP (n1),
ca46fb90 748 g_lcm, n1, n2, SCM_ARG1, s_lcm);
09fb7599 749 SCM_GASSERT2 (SCM_INUMP (n2) || SCM_BIGP (n2),
ca46fb90 750 g_lcm, n1, n2, SCM_ARGn, s_lcm);
09fb7599 751
ca46fb90
RB		 752 if (SCM_INUMP (n1))
753 {
754 if (SCM_INUMP (n2))
755 {
756 SCM d = scm_gcd (n1, n2);
757 if (SCM_EQ_P (d, SCM_INUM0))
758 return d;
759 else
760 return scm_abs (scm_product (n1, scm_quotient (n2, d)));
761 }
762 else
763 {
764 /* inum n1, big n2 */
765 inumbig:
766 {
767 SCM result = scm_i_mkbig ();
768 long nn1 = SCM_INUM (n1);
769 if (nn1 == 0) return SCM_INUM0;
770 if (nn1 < 0) nn1 = - nn1;
771 mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
772 scm_remember_upto_here_1 (n2);
773 return result;
774 }
775 }
776 }
777 else
778 {
779 /* big n1 */
780 if (SCM_INUMP (n2))
781 {
782 SCM_SWAP (n1, n2);
783 goto inumbig;
784 }
785 else
786 {
787 SCM result = scm_i_mkbig ();
788 mpz_lcm(SCM_I_BIG_MPZ (result),
789 SCM_I_BIG_MPZ (n1),
790 SCM_I_BIG_MPZ (n2));
791 scm_remember_upto_here_2(n1, n2);
792 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
793 return result;
794 }
f872b822 795 }
0f2d19dd
JB		 796}
797
0f2d19dd 798#ifndef scm_long2num
c1bfcf60
GB		 799#define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
800#else
801#define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
802#endif
803
8a525303
GB		 804/* Emulating 2's complement bignums with sign magnitude arithmetic:
805
806 Logand:
807 X Y Result Method:
808 (len)
809 + + + x (map digit:logand X Y)
810 + - + x (map digit:logand X (lognot (+ -1 Y)))
811 - + + y (map digit:logand (lognot (+ -1 X)) Y)
812 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
813
814 Logior:
815 X Y Result Method:
816
817 + + + (map digit:logior X Y)
818 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
819 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
820 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
821
822 Logxor:
823 X Y Result Method:
824
825 + + + (map digit:logxor X Y)
826 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
827 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
828 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
829
830 Logtest:
831 X Y Result
832
833 + + (any digit:logand X Y)
834 + - (any digit:logand X (lognot (+ -1 Y)))
835 - + (any digit:logand (lognot (+ -1 X)) Y)
836 - - #t
837
838*/
839
c3ee7520 840SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
1bbd0b84 841 (SCM n1, SCM n2),
3c3db128
GH		 842 "Return the bitwise AND of the integer arguments.\n\n"
843 "@lisp\n"
844 "(logand) @result{} -1\n"
845 "(logand 7) @result{} 7\n"
846 "(logand #b111 #b011 #\b001) @result{} 1\n"
847 "@end lisp")
1bbd0b84 848#define FUNC_NAME s_scm_logand
0f2d19dd 849{
9a00c9fc
DH		 850 long int nn1;
851
09fb7599
DH		 852 if (SCM_UNBNDP (n2)) {
853 if (SCM_UNBNDP (n1)) {
854 return SCM_MAKINUM (-1);
855 } else if (!SCM_NUMBERP (n1)) {
856 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
09fb7599 857 } else if (SCM_NUMBERP (n1)) {
d28da049 858 return n1;
09fb7599
DH		 859 } else {
860 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 861 }
8a525303 862 }
09fb7599
DH		 863
864 if (SCM_INUMP (n1)) {
9a00c9fc 865 nn1 = SCM_INUM (n1);
09fb7599
DH		 866 if (SCM_INUMP (n2)) {
867 long nn2 = SCM_INUM (n2);
868 return SCM_MAKINUM (nn1 & nn2);
09fb7599
DH		 869 } else if SCM_BIGP (n2) {
870 intbig:
ca46fb90 871 if (n1 == 0) return SCM_INUM0;
09fb7599 872 {
ca46fb90
RB		 873 SCM result_z = scm_i_mkbig ();
874 mpz_t nn1_z;
875 mpz_init_set_si (nn1_z, nn1);
876 mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
877 scm_remember_upto_here_1 (n2);
878 mpz_clear (nn1_z);
879 return scm_i_normbig (result_z);
09fb7599 880 }
09fb7599
DH		 881 } else {
882 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
883 }
09fb7599
DH		 884 } else if (SCM_BIGP (n1)) {
885 if (SCM_INUMP (n2)) {
886 SCM_SWAP (n1, n2);
9a00c9fc 887 nn1 = SCM_INUM (n1);
09fb7599
DH		 888 goto intbig;
889 } else if (SCM_BIGP (n2)) {
ca46fb90
RB		 890 SCM result_z = scm_i_mkbig ();
891 mpz_and (SCM_I_BIG_MPZ (result_z),
892 SCM_I_BIG_MPZ (n1),
893 SCM_I_BIG_MPZ (n2));
894 scm_remember_upto_here_2 (n1, n2);
895 return scm_i_normbig (result_z);
09fb7599
DH		 896 } else {
897 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
898 }
09fb7599
DH		 899 } else {
900 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
901 }
0f2d19dd 902}
1bbd0b84 903#undef FUNC_NAME
0f2d19dd 904
09fb7599 905
c3ee7520 906SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
1bbd0b84 907 (SCM n1, SCM n2),
3c3db128
GH		 908 "Return the bitwise OR of the integer arguments.\n\n"
909 "@lisp\n"
910 "(logior) @result{} 0\n"
911 "(logior 7) @result{} 7\n"
912 "(logior #b000 #b001 #b011) @result{} 3\n"
1e6808ea 913 "@end lisp")
1bbd0b84 914#define FUNC_NAME s_scm_logior
0f2d19dd 915{
9a00c9fc
DH		 916 long int nn1;
917
09fb7599
DH		 918 if (SCM_UNBNDP (n2)) {
919 if (SCM_UNBNDP (n1)) {
920 return SCM_INUM0;
09fb7599 921 } else if (SCM_NUMBERP (n1)) {
d28da049 922 return n1;
09fb7599
DH		 923 } else {
924 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 925 }
8a525303 926 }
09fb7599
DH		 927
928 if (SCM_INUMP (n1)) {
9a00c9fc 929 nn1 = SCM_INUM (n1);
09fb7599
DH		 930 if (SCM_INUMP (n2)) {
931 long nn2 = SCM_INUM (n2);
932 return SCM_MAKINUM (nn1 | nn2);
09fb7599
DH		 933 } else if (SCM_BIGP (n2)) {
934 intbig:
ca46fb90 935 if (nn1 == 0) return n2;
09fb7599 936 {
ca46fb90
RB		 937 SCM result_z = scm_i_mkbig ();
938 mpz_t nn1_z;
939 mpz_init_set_si (nn1_z, nn1);
940 mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
941 scm_remember_upto_here_1 (n2);
942 mpz_clear (nn1_z);
943 return result_z;
09fb7599 944 }
09fb7599
DH		 945 } else {
946 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
947 }
09fb7599
DH		 948 } else if (SCM_BIGP (n1)) {
949 if (SCM_INUMP (n2)) {
950 SCM_SWAP (n1, n2);
9a00c9fc 951 nn1 = SCM_INUM (n1);
09fb7599
DH		 952 goto intbig;
953 } else if (SCM_BIGP (n2)) {
ca46fb90
RB		 954 SCM result_z = scm_i_mkbig ();
955 mpz_ior (SCM_I_BIG_MPZ (result_z),
956 SCM_I_BIG_MPZ (n1),
957 SCM_I_BIG_MPZ (n2));
958 scm_remember_upto_here_2 (n1, n2);
959 return result_z;
09fb7599
DH		 960 } else {
961 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
962 }
09fb7599
DH		 963 } else {
964 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
965 }
0f2d19dd 966}
1bbd0b84 967#undef FUNC_NAME
0f2d19dd 968
09fb7599 969
c3ee7520 970SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
1bbd0b84 971 (SCM n1, SCM n2),
3c3db128
GH		 972 "Return the bitwise XOR of the integer arguments. A bit is\n"
973 "set in the result if it is set in an odd number of arguments.\n"
974 "@lisp\n"
975 "(logxor) @result{} 0\n"
976 "(logxor 7) @result{} 7\n"
977 "(logxor #b000 #b001 #b011) @result{} 2\n"
978 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1e6808ea 979 "@end lisp")
1bbd0b84 980#define FUNC_NAME s_scm_logxor
0f2d19dd 981{
9a00c9fc
DH		 982 long int nn1;
983
09fb7599
DH		 984 if (SCM_UNBNDP (n2)) {
985 if (SCM_UNBNDP (n1)) {
986 return SCM_INUM0;
09fb7599
DH		 987 } else if (SCM_NUMBERP (n1)) {
988 return n1;
989 } else {
990 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 991 }
8a525303 992 }
09fb7599
DH		 993
994 if (SCM_INUMP (n1)) {
9a00c9fc 995 nn1 = SCM_INUM (n1);
09fb7599
DH		 996 if (SCM_INUMP (n2)) {
997 long nn2 = SCM_INUM (n2);
998 return SCM_MAKINUM (nn1 ^ nn2);
09fb7599 999 } else if (SCM_BIGP (n2)) {
ca46fb90 1000 intbig:
8a525303 1001 {
ca46fb90
RB		 1002 SCM result_z = scm_i_mkbig ();
1003 mpz_t nn1_z;
1004 mpz_init_set_si (nn1_z, nn1);
1005 mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1006 scm_remember_upto_here_1 (n2);
1007 mpz_clear (nn1_z);
1008 return scm_i_normbig (result_z);
8a525303 1009 }
09fb7599
DH		 1010 } else {
1011 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1012 }
09fb7599
DH		 1013 } else if (SCM_BIGP (n1)) {
1014 if (SCM_INUMP (n2)) {
1015 SCM_SWAP (n1, n2);
9a00c9fc 1016 nn1 = SCM_INUM (n1);
09fb7599
DH		 1017 goto intbig;
1018 } else if (SCM_BIGP (n2)) {
ca46fb90
RB		 1019 SCM result_z = scm_i_mkbig ();
1020 mpz_xor (SCM_I_BIG_MPZ (result_z),
1021 SCM_I_BIG_MPZ (n1),
1022 SCM_I_BIG_MPZ (n2));
1023 scm_remember_upto_here_2 (n1, n2);
1024 return scm_i_normbig (result_z);
09fb7599
DH		 1025 } else {
1026 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1027 }
09fb7599
DH		 1028 } else {
1029 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
1030 }
0f2d19dd 1031}
1bbd0b84 1032#undef FUNC_NAME
0f2d19dd 1033
09fb7599 1034
a1ec6916 1035SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
1e6808ea
MG		 1036 (SCM j, SCM k),
1037 "@lisp\n"
b380b885
MD		 1038 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1039 "(logtest #b0100 #b1011) @result{} #f\n"
1040 "(logtest #b0100 #b0111) @result{} #t\n"
1e6808ea 1041 "@end lisp")
1bbd0b84 1042#define FUNC_NAME s_scm_logtest
0f2d19dd 1043{
1e6808ea 1044 long int nj;
9a00c9fc 1045
1e6808ea
MG		 1046 if (SCM_INUMP (j)) {
1047 nj = SCM_INUM (j);
1048 if (SCM_INUMP (k)) {
1049 long nk = SCM_INUM (k);
1050 return SCM_BOOL (nj & nk);
1051 } else if (SCM_BIGP (k)) {
f8de44c1 1052 intbig:
ca46fb90 1053 if (nj == 0) return SCM_BOOL_F;
f8de44c1 1054 {
ca46fb90
RB		 1055 SCM result;
1056 mpz_t nj_z;
1057 mpz_init_set_si (nj_z, nj);
1058 mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
1059 scm_remember_upto_here_1 (k);
1060 result = SCM_BOOL (mpz_sgn (nj_z) != 0);
1061 mpz_clear (nj_z);
1062 return result;
f8de44c1 1063 }
f8de44c1 1064 } else {
1e6808ea 1065 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
f8de44c1 1066 }
1e6808ea
MG		 1067 } else if (SCM_BIGP (j)) {
1068 if (SCM_INUMP (k)) {
1069 SCM_SWAP (j, k);
1070 nj = SCM_INUM (j);
f8de44c1 1071 goto intbig;
1e6808ea 1072 } else if (SCM_BIGP (k)) {
ca46fb90
RB		 1073 SCM result;
1074 mpz_t result_z;
1075 mpz_init (result_z);
1076 mpz_and (SCM_I_BIG_MPZ (result_z),
1077 SCM_I_BIG_MPZ (j),
1078 SCM_I_BIG_MPZ (k));
1079 scm_remember_upto_here_2 (j, k);
1080 result = SCM_BOOL (mpz_sgn (result_z) != 0);
1081 mpz_clear (result_z);
1082 return result;
f8de44c1 1083 } else {
1e6808ea 1084 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
f8de44c1 1085 }
f8de44c1 1086 } else {
1e6808ea 1087 SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
f8de44c1 1088 }
0f2d19dd 1089}
1bbd0b84 1090#undef FUNC_NAME
0f2d19dd 1091
c1bfcf60 1092
a1ec6916 1093SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
2cd04b42 1094 (SCM index, SCM j),
1e6808ea 1095 "@lisp\n"
b380b885
MD		 1096 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1097 "(logbit? 0 #b1101) @result{} #t\n"
1098 "(logbit? 1 #b1101) @result{} #f\n"
1099 "(logbit? 2 #b1101) @result{} #t\n"
1100 "(logbit? 3 #b1101) @result{} #t\n"
1101 "(logbit? 4 #b1101) @result{} #f\n"
1e6808ea 1102 "@end lisp")
1bbd0b84 1103#define FUNC_NAME s_scm_logbit_p
0f2d19dd 1104{
78166ad5
DH		 1105 unsigned long int iindex;
1106
1107 SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0);
1108 iindex = (unsigned long int) SCM_INUM (index);
1109
1110 if (SCM_INUMP (j)) {
1111 return SCM_BOOL ((1L << iindex) & SCM_INUM (j));
1112 } else if (SCM_BIGP (j)) {
ca46fb90
RB		 1113 int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
1114 scm_remember_upto_here_1 (j);
1115 return SCM_BOOL (val);
78166ad5
DH		 1116 } else {
1117 SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
8a525303 1118 }
0f2d19dd 1119}
1bbd0b84 1120#undef FUNC_NAME
0f2d19dd 1121
78166ad5 1122
a1ec6916 1123SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
1bbd0b84 1124 (SCM n),
1e6808ea
MG		 1125 "Return the integer which is the 2s-complement of the integer\n"
1126 "argument.\n"
1127 "\n"
b380b885
MD		 1128 "@lisp\n"
1129 "(number->string (lognot #b10000000) 2)\n"
1130 " @result{} \"-10000001\"\n"
1131 "(number->string (lognot #b0) 2)\n"
1132 " @result{} \"-1\"\n"
1e6808ea 1133 "@end lisp")
1bbd0b84 1134#define FUNC_NAME s_scm_lognot
0f2d19dd 1135{
f872b822 1136 return scm_difference (SCM_MAKINUM (-1L), n);
0f2d19dd 1137}
1bbd0b84 1138#undef FUNC_NAME
0f2d19dd 1139
a1ec6916 1140SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
2cd04b42 1141 (SCM n, SCM k),
1e6808ea
MG		 1142 "Return @var{n} raised to the non-negative integer exponent\n"
1143 "@var{k}.\n"
1144 "\n"
b380b885
MD		 1145 "@lisp\n"
1146 "(integer-expt 2 5)\n"
1147 " @result{} 32\n"
1148 "(integer-expt -3 3)\n"
1149 " @result{} -27\n"
1150 "@end lisp")
1bbd0b84 1151#define FUNC_NAME s_scm_integer_expt
0f2d19dd 1152{
f872b822 1153 SCM acc = SCM_MAKINUM (1L);
ca46fb90 1154
d57ed702 1155 /* 0^0 == 1 according to R5RS */
4260a7fc 1156 if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc))
7b3381f4 1157 return SCM_FALSEP (scm_zero_p(k)) ? n : acc;
4260a7fc
DH		 1158 else if (SCM_EQ_P (n, SCM_MAKINUM (-1L)))
1159 return SCM_FALSEP (scm_even_p (k)) ? n : acc;
ca46fb90
RB		 1160
1161 long i2 = 0;
1162 SCM z_i2 = SCM_BOOL_F;
1163 int i2_is_big = 0;
1164
1165 if (SCM_INUMP (k))
1166 i2 = SCM_INUM (k);
1167 else if (SCM_BIGP (k))
1168 {
1169 z_i2 = scm_i_clonebig (k, 1);
1170 mpz_init_set (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (k));
1171 scm_remember_upto_here_1 (k);
1172 i2_is_big = 1;
1173 }
1174 else if (SCM_REALP (k))
2830fd91
MD		 1175 {
1176 double r = SCM_REAL_VALUE (k);
ca46fb90
RB		 1177 if (floor (r) != r)
1178 SCM_WRONG_TYPE_ARG (2, k);
1179 if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM))
1180 {
1181 z_i2 = scm_i_mkbig ();
1182 mpz_init_set_d (SCM_I_BIG_MPZ (z_i2), r);
1183 i2_is_big = 1;
1184 }
1185 else
1186 {
1187 i2 = r;
1188 }
2830fd91
MD		 1189 }
1190 else
ca46fb90
RB		 1191 SCM_WRONG_TYPE_ARG (2, k);
1192
1193 if (i2_is_big)
f872b822 1194 {
ca46fb90
RB		 1195 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
1196 {
1197 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
1198 n = scm_divide (n, SCM_UNDEFINED);
1199 }
1200 while (1)
1201 {
1202 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
1203 {
1204 mpz_clear (SCM_I_BIG_MPZ (z_i2));
1205 return acc;
1206 }
1207 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
1208 {
1209 mpz_clear (SCM_I_BIG_MPZ (z_i2));
1210 return scm_product (acc, n);
1211 }
1212 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
1213 acc = scm_product (acc, n);
1214 n = scm_product (n, n);
1215 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
1216 }
f872b822 1217 }
ca46fb90 1218 else
f872b822 1219 {
ca46fb90
RB		 1220 if (i2 < 0)
1221 {
1222 i2 = -i2;
1223 n = scm_divide (n, SCM_UNDEFINED);
1224 }
1225 while (1)
1226 {
1227 if (0 == i2)
1228 return acc;
1229 if (1 == i2)
1230 return scm_product (acc, n);
1231 if (i2 & 1)
1232 acc = scm_product (acc, n);
1233 n = scm_product (n, n);
1234 i2 >>= 1;
1235 }
f872b822 1236 }
0f2d19dd 1237}
1bbd0b84 1238#undef FUNC_NAME
0f2d19dd 1239
a1ec6916 1240SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
1bbd0b84 1241 (SCM n, SCM cnt),
1e6808ea
MG		 1242 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1243 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1244 "means, that the function does not guarantee to keep the bit\n"
1245 "structure of @var{n}, but rather guarantees that the result\n"
1246 "will always be rounded towards minus infinity. Therefore, the\n"
1247 "results of ash and a corresponding bitwise shift will differ if\n"
1248 "@var{n} is negative.\n"
1249 "\n"
3ab9f56e 1250 "Formally, the function returns an integer equivalent to\n"
1e6808ea
MG		 1251 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1252 "\n"
b380b885 1253 "@lisp\n"
1e6808ea
MG		 1254 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1255 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
a3c8b9fc 1256 "@end lisp")
1bbd0b84 1257#define FUNC_NAME s_scm_ash
0f2d19dd 1258{
3ab9f56e
DH		 1259 long bits_to_shift;
1260
3ab9f56e
DH		 1261 SCM_VALIDATE_INUM (2, cnt);
1262
1263 bits_to_shift = SCM_INUM (cnt);
ca46fb90
RB		 1264
1265 if (bits_to_shift < 0)
1266 {
1267 /* Shift right by abs(cnt) bits. This is realized as a division
1268 by div:=2^abs(cnt). However, to guarantee the floor
1269 rounding, negative values require some special treatment.
1270 */
1271 SCM div = scm_integer_expt (SCM_MAKINUM (2),
1272 SCM_MAKINUM (-bits_to_shift));
1273 if (SCM_FALSEP (scm_negative_p (n)))
1274 return scm_quotient (n, div);
1275 else
1276 return scm_sum (SCM_MAKINUM (-1L),
1277 scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div));
1278 }
1279 else
3ab9f56e 1280 /* Shift left is done by multiplication with 2^CNT */
f872b822 1281 return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
0f2d19dd 1282}
1bbd0b84 1283#undef FUNC_NAME
0f2d19dd 1284
3c9f20f8 1285
a1ec6916 1286SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
1bbd0b84 1287 (SCM n, SCM start, SCM end),
1e6808ea
MG		 1288 "Return the integer composed of the @var{start} (inclusive)\n"
1289 "through @var{end} (exclusive) bits of @var{n}. The\n"
1290 "@var{start}th bit becomes the 0-th bit in the result.\n"
1291 "\n"
b380b885
MD		 1292 "@lisp\n"
1293 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1294 " @result{} \"1010\"\n"
1295 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1296 " @result{} \"10110\"\n"
1297 "@end lisp")
1bbd0b84 1298#define FUNC_NAME s_scm_bit_extract
0f2d19dd 1299{
ac0c002c 1300 unsigned long int istart, iend;
34d19ef6 1301 SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart);
c1bfcf60
GB		 1302 SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
1303 SCM_ASSERT_RANGE (3, end, (iend >= istart));
78166ad5
DH		 1304
1305 if (SCM_INUMP (n)) {
ac0c002c
DH		 1306 long int in = SCM_INUM (n);
1307 unsigned long int bits = iend - istart;
1308
1be6b49c 1309 if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
ac0c002c
DH		 1310 {
1311 /* Since we emulate two's complement encoded numbers, this special
1312 * case requires us to produce a result that has more bits than can be
1313 * stored in a fixnum. Thus, we fall back to the more general
1314 * algorithm that is used for bignums.
1315 */
1316 goto generalcase;
1317 }
1318
1be6b49c 1319 if (istart < SCM_I_FIXNUM_BIT)
ac0c002c
DH		 1320 {
1321 in = in >> istart;
1be6b49c 1322 if (bits < SCM_I_FIXNUM_BIT)
ac0c002c
DH		 1323 return SCM_MAKINUM (in & ((1L << bits) - 1));
1324 else /* we know: in >= 0 */
1325 return SCM_MAKINUM (in);
1326 }
1327 else if (in < 0)
1328 {
1329 return SCM_MAKINUM (-1L & ((1L << bits) - 1));
1330 }
1331 else
1332 {
1333 return SCM_MAKINUM (0);
1334 }
78166ad5 1335 } else if (SCM_BIGP (n)) {
ac0c002c
DH		 1336 generalcase:
1337 {
1338 SCM num1 = SCM_MAKINUM (1L);
1339 SCM num2 = SCM_MAKINUM (2L);
1340 SCM bits = SCM_MAKINUM (iend - istart);
1341 SCM mask = scm_difference (scm_integer_expt (num2, bits), num1);
1342 return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
1343 }
78166ad5
DH		 1344 } else {
1345 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
1346 }
0f2d19dd 1347}
1bbd0b84 1348#undef FUNC_NAME
0f2d19dd 1349
e4755e5c
JB		 1350static const char scm_logtab[] = {
1351 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1352};
1cc91f1b 1353
a1ec6916 1354SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
1bbd0b84 1355 (SCM n),
1e6808ea
MG		 1356 "Return the number of bits in integer @var{n}. If integer is\n"
1357 "positive, the 1-bits in its binary representation are counted.\n"
1358 "If negative, the 0-bits in its two's-complement binary\n"
1359 "representation are counted. If 0, 0 is returned.\n"
1360 "\n"
b380b885
MD		 1361 "@lisp\n"
1362 "(logcount #b10101010)\n"
ca46fb90
RB		 1363 " @result{} 4\n"
1364 "(logcount 0)\n"
1365 " @result{} 0\n"
1366 "(logcount -2)\n"
1367 " @result{} 1\n"
1368 "@end lisp")
1369#define FUNC_NAME s_scm_logcount
1370{
1371 if (SCM_INUMP (n))
f872b822 1372 {
ca46fb90
RB		 1373 unsigned long int c = 0;
1374 long int nn = SCM_INUM (n);
1375 if (nn < 0)
1376 nn = -1 - nn;
1377 while (nn)
1378 {
1379 c += scm_logtab[15 & nn];
1380 nn >>= 4;
1381 }
1382 return SCM_MAKINUM (c);
f872b822 1383 }
ca46fb90 1384 else if (SCM_BIGP (n))
f872b822 1385 {
ca46fb90
RB		 1386 unsigned long count;
1387 if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0)
1388 {
1389 mpz_t z_n;
1390 mpz_init (z_n);
1391 mpz_neg (z_n, SCM_I_BIG_MPZ (n));
1392 scm_remember_upto_here_1 (n);
1393 count = mpz_popcount (z_n);
1394 mpz_clear (z_n);
1395 }
1396 else
1397 {
1398 count = mpz_popcount (SCM_I_BIG_MPZ (n));
1399 scm_remember_upto_here_1 (n);
1400 }
1401 return SCM_MAKINUM (count);
f872b822 1402 }
ca46fb90
RB		 1403 else
1404 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1405}
ca46fb90 1406#undef FUNC_NAME
0f2d19dd
JB		 1407
1408
ca46fb90
RB		 1409static const char scm_ilentab[] = {
1410 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1411};
1412
0f2d19dd 1413
ca46fb90
RB		 1414SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
1415 (SCM n),
1416 "Return the number of bits necessary to represent @var{n}.\n"
1417 "\n"
1418 "@lisp\n"
1419 "(integer-length #b10101010)\n"
1420 " @result{} 8\n"
1421 "(integer-length 0)\n"
1422 " @result{} 0\n"
1423 "(integer-length #b1111)\n"
1424 " @result{} 4\n"
1425 "@end lisp")
1426#define FUNC_NAME s_scm_integer_length
1427{
1428 if (SCM_INUMP (n)) {
1429 unsigned long int c = 0;
1430 unsigned int l = 4;
1431 long int nn = SCM_INUM (n);
1432 if (nn < 0) {
1433 nn = -1 - nn;
1434 };
1435 while (nn) {
1436 c += 4;
1437 l = scm_ilentab [15 & nn];
1438 nn >>= 4;
1439 };
1440 return SCM_MAKINUM (c - 4 + l);
1441 } else if (SCM_BIGP (n)) {
1442 size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
1443 scm_remember_upto_here_1 (n);
1444 return SCM_MAKINUM (size);
1445 } else {
1446 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
1447 }
1448}
1449#undef FUNC_NAME
0f2d19dd
JB		 1450
1451/*** NUMBERS -> STRINGS ***/
0f2d19dd 1452int scm_dblprec;
e4755e5c 1453static const double fx[] =
f872b822
MD		 1454{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1455 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1456 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1457 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
0f2d19dd 1458
1be6b49c 1459static size_t
1bbd0b84 1460idbl2str (double f, char *a)
0f2d19dd
JB		 1461{
1462 int efmt, dpt, d, i, wp = scm_dblprec;
1be6b49c 1463 size_t ch = 0;
0f2d19dd
JB		 1464 int exp = 0;
1465
f872b822 1466 if (f == 0.0)
abb7e44d
MV		 1467 {
1468#ifdef HAVE_COPYSIGN
1469 double sgn = copysign (1.0, f);
1470
1471 if (sgn < 0.0)
1472 a[ch++] = '-';
1473#endif
1474
1475 goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1476 }
7351e207
MV		 1477
1478 if (xisinf (f))
1479 {
1480 if (f < 0)
1481 strcpy (a, "-inf.0");
1482 else
1483 strcpy (a, "+inf.0");
1484 return ch+6;
1485 }
1486 else if (xisnan (f))
1487 {
1488 strcpy (a, "+nan.0");
1489 return ch+6;
1490 }
1491
f872b822
MD		 1492 if (f < 0.0)
1493 {
1494 f = -f;
1495 a[ch++] = '-';
1496 }
7351e207 1497
f872b822
MD		 1498#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1499 make-uniform-vector, from causing infinite loops. */
1500 while (f < 1.0)
1501 {
1502 f *= 10.0;
1503 if (exp-- < DBL_MIN_10_EXP)
7351e207
MV		 1504 {
1505 a[ch++] = '#';
1506 a[ch++] = '.';
1507 a[ch++] = '#';
1508 return ch;
1509 }
f872b822
MD		 1510 }
1511 while (f > 10.0)
1512 {
1513 f *= 0.10;
1514 if (exp++ > DBL_MAX_10_EXP)
7351e207
MV		 1515 {
1516 a[ch++] = '#';
1517 a[ch++] = '.';
1518 a[ch++] = '#';
1519 return ch;
1520 }
f872b822
MD		 1521 }
1522#else
1523 while (f < 1.0)
1524 {
1525 f *= 10.0;
1526 exp--;
1527 }
1528 while (f > 10.0)
1529 {
1530 f /= 10.0;
1531 exp++;
1532 }
1533#endif
1534 if (f + fx[wp] >= 10.0)
1535 {
1536 f = 1.0;
1537 exp++;
1538 }
0f2d19dd 1539 zero:
f872b822
MD		 1540#ifdef ENGNOT
1541 dpt = (exp + 9999) % 3;
0f2d19dd
JB		 1542 exp -= dpt++;
1543 efmt = 1;
f872b822
MD		 1544#else
1545 efmt = (exp < -3) || (exp > wp + 2);
0f2d19dd 1546 if (!efmt)
cda139a7
MD		 1547 {
1548 if (exp < 0)
1549 {
1550 a[ch++] = '0';
1551 a[ch++] = '.';
1552 dpt = exp;
f872b822
MD		 1553 while (++dpt)
1554 a[ch++] = '0';
cda139a7
MD		 1555 }
1556 else
f872b822 1557 dpt = exp + 1;
cda139a7 1558 }
0f2d19dd
JB		 1559 else
1560 dpt = 1;
f872b822
MD		 1561#endif
1562
1563 do
1564 {
1565 d = f;
1566 f -= d;
1567 a[ch++] = d + '0';
1568 if (f < fx[wp])
1569 break;
1570 if (f + fx[wp] >= 1.0)
1571 {
1572 a[ch - 1]++;
1573 break;
1574 }
1575 f *= 10.0;
1576 if (!(--dpt))
1577 a[ch++] = '.';
0f2d19dd 1578 }
f872b822 1579 while (wp--);
0f2d19dd
JB		 1580
1581 if (dpt > 0)
cda139a7 1582 {
f872b822 1583#ifndef ENGNOT
cda139a7
MD		 1584 if ((dpt > 4) && (exp > 6))
1585 {
f872b822 1586 d = (a[0] == '-' ? 2 : 1);
cda139a7 1587 for (i = ch++; i > d; i--)
f872b822 1588 a[i] = a[i - 1];
cda139a7
MD		 1589 a[d] = '.';
1590 efmt = 1;
1591 }
1592 else
f872b822 1593#endif
cda139a7 1594 {
f872b822
MD		 1595 while (--dpt)
1596 a[ch++] = '0';
cda139a7
MD		 1597 a[ch++] = '.';
1598 }
1599 }
f872b822
MD		 1600 if (a[ch - 1] == '.')
1601 a[ch++] = '0'; /* trailing zero */
1602 if (efmt && exp)
1603 {
1604 a[ch++] = 'e';
1605 if (exp < 0)
1606 {
1607 exp = -exp;
1608 a[ch++] = '-';
1609 }
1610 for (i = 10; i <= exp; i *= 10);
1611 for (i /= 10; i; i /= 10)
1612 {
1613 a[ch++] = exp / i + '0';
1614 exp %= i;
1615 }
0f2d19dd 1616 }
0f2d19dd
JB		 1617 return ch;
1618}
1619
1cc91f1b 1620
1be6b49c 1621static size_t
1bbd0b84 1622iflo2str (SCM flt, char *str)
0f2d19dd 1623{
1be6b49c 1624 size_t i;
3c9a524f 1625 if (SCM_REALP (flt))
f3ae5d60 1626 i = idbl2str (SCM_REAL_VALUE (flt), str);
0f2d19dd 1627 else
f872b822 1628 {
f3ae5d60
MD		 1629 i = idbl2str (SCM_COMPLEX_REAL (flt), str);
1630 if (SCM_COMPLEX_IMAG (flt) != 0.0)
1631 {
7351e207
MV		 1632 double imag = SCM_COMPLEX_IMAG (flt);
1633 /* Don't output a '+' for negative numbers or for Inf and
1634 NaN. They will provide their own sign. */
1635 if (0 <= imag && !xisinf (imag) && !xisnan (imag))
f3ae5d60 1636 str[i++] = '+';
7351e207 1637 i += idbl2str (imag, &str[i]);
f3ae5d60
MD		 1638 str[i++] = 'i';
1639 }
f872b822 1640 }
0f2d19dd
JB		 1641 return i;
1642}
0f2d19dd 1643
5c11cc9d 1644/* convert a long to a string (unterminated). returns the number of
1bbd0b84
GB		 1645 characters in the result.
1646 rad is output base
1647 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1be6b49c 1648size_t
1bbd0b84 1649scm_iint2str (long num, int rad, char *p)
0f2d19dd 1650{
1be6b49c
ML		 1651 size_t j = 1;
1652 size_t i;
5c11cc9d
GH		 1653 unsigned long n = (num < 0) ? -num : num;
1654
f872b822 1655 for (n /= rad; n > 0; n /= rad)
5c11cc9d
GH		 1656 j++;
1657
1658 i = j;
1659 if (num < 0)
f872b822 1660 {
f872b822 1661 *p++ = '-';
5c11cc9d
GH		 1662 j++;
1663 n = -num;
f872b822 1664 }
5c11cc9d
GH		 1665 else
1666 n = num;
f872b822
MD		 1667 while (i--)
1668 {
5c11cc9d
GH		 1669 int d = n % rad;
1670
f872b822
MD		 1671 n /= rad;
1672 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
1673 }
0f2d19dd
JB		 1674 return j;
1675}
1676
1677
a1ec6916 1678SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
bb628794
DH		 1679 (SCM n, SCM radix),
1680 "Return a string holding the external representation of the\n"
942e5b91
MG		 1681 "number @var{n} in the given @var{radix}. If @var{n} is\n"
1682 "inexact, a radix of 10 will be used.")
1bbd0b84 1683#define FUNC_NAME s_scm_number_to_string
0f2d19dd 1684{
1bbd0b84 1685 int base;
98cb6e75
DH		 1686
1687 if (SCM_UNBNDP (radix)) {
1688 base = 10;
1689 } else {
1690 SCM_VALIDATE_INUM (2, radix);
1691 base = SCM_INUM (radix);
ca46fb90
RB		 1692 /* FIXME: ask if range limit was OK, and if so, document */
1693 SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36));
98cb6e75
DH		 1694 }
1695
bb628794 1696 if (SCM_INUMP (n)) {
98cb6e75 1697 char num_buf [SCM_INTBUFLEN];
1be6b49c 1698 size_t length = scm_iint2str (SCM_INUM (n), base, num_buf);
36284627 1699 return scm_mem2string (num_buf, length);
bb628794 1700 } else if (SCM_BIGP (n)) {
ca46fb90
RB		 1701 char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
1702 scm_remember_upto_here_1 (n);
1703 return scm_take0str (str);
bb628794 1704 } else if (SCM_INEXACTP (n)) {
56e55ac7 1705 char num_buf [FLOBUFLEN];
36284627 1706 return scm_mem2string (num_buf, iflo2str (n, num_buf));
98cb6e75 1707 } else {
bb628794 1708 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd
JB		 1709 }
1710}
1bbd0b84 1711#undef FUNC_NAME
0f2d19dd
JB		 1712
1713
ca46fb90
RB		 1714/* These print routines used to be stubbed here so that scm_repl.c
1715 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1cc91f1b 1716
0f2d19dd 1717int
e81d98ec 1718scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 1719{
56e55ac7 1720 char num_buf[FLOBUFLEN];
f872b822 1721 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
0f2d19dd
JB		 1722 return !0;
1723}
1724
f3ae5d60 1725int
e81d98ec 1726scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
f3ae5d60 1727{
56e55ac7 1728 char num_buf[FLOBUFLEN];
f3ae5d60
MD		 1729 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
1730 return !0;
1731}
1cc91f1b 1732
0f2d19dd 1733int
e81d98ec 1734scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 1735{
ca46fb90
RB		 1736 char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
1737 scm_remember_upto_here_1 (exp);
1738 scm_lfwrite (str, (size_t) strlen (str), port);
1739 free (str);
0f2d19dd
JB		 1740 return !0;
1741}
1742/*** END nums->strs ***/
1743
3c9a524f 1744
0f2d19dd 1745/*** STRINGS -> NUMBERS ***/
2a8fecee 1746
3c9a524f
DH		 1747/* The following functions implement the conversion from strings to numbers.
1748 * The implementation somehow follows the grammar for numbers as it is given
1749 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
1750 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
1751 * points should be noted about the implementation:
1752 * * Each function keeps a local index variable 'idx' that points at the
1753 * current position within the parsed string. The global index is only
1754 * updated if the function could parse the corresponding syntactic unit
1755 * successfully.
1756 * * Similarly, the functions keep track of indicators of inexactness ('#',
1757 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
1758 * global exactness information is only updated after each part has been
1759 * successfully parsed.
1760 * * Sequences of digits are parsed into temporary variables holding fixnums.
1761 * Only if these fixnums would overflow, the result variables are updated
1762 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
1763 * the temporary variables holding the fixnums are cleared, and the process
1764 * starts over again. If for example fixnums were able to store five decimal
1765 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
1766 * and the result was computed as 12345 * 100000 + 67890. In other words,
1767 * only every five digits two bignum operations were performed.
1768 */
1769
1770enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
1771
1772/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
1773
1774/* In non ASCII-style encodings the following macro might not work. */
1775#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
1776
2a8fecee 1777static SCM
3c9a524f
DH		 1778mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
1779 unsigned int radix, enum t_exactness *p_exactness)
2a8fecee 1780{
3c9a524f
DH		 1781 unsigned int idx = *p_idx;
1782 unsigned int hash_seen = 0;
1783 scm_t_bits shift = 1;
1784 scm_t_bits add = 0;
1785 unsigned int digit_value;
1786 SCM result;
1787 char c;
1788
1789 if (idx == len)
1790 return SCM_BOOL_F;
2a8fecee 1791
3c9a524f
DH		 1792 c = mem[idx];
1793 if (!isxdigit (c))
1794 return SCM_BOOL_F;
1795 digit_value = XDIGIT2UINT (c);
1796 if (digit_value >= radix)
1797 return SCM_BOOL_F;
1798
1799 idx++;
1800 result = SCM_MAKINUM (digit_value);
1801 while (idx != len)
f872b822 1802 {
3c9a524f
DH		 1803 char c = mem[idx];
1804 if (isxdigit (c))
f872b822 1805 {
3c9a524f 1806 if (hash_seen)
1fe5e088 1807 break;
3c9a524f
DH		 1808 digit_value = XDIGIT2UINT (c);
1809 if (digit_value >= radix)
1fe5e088 1810 break;
f872b822 1811 }
3c9a524f
DH		 1812 else if (c == '#')
1813 {
1814 hash_seen = 1;
1815 digit_value = 0;
1816 }
1817 else
1818 break;
1819
1820 idx++;
1821 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
1822 {
1823 result = scm_product (result, SCM_MAKINUM (shift));
1824 if (add > 0)
1825 result = scm_sum (result, SCM_MAKINUM (add));
1826
1827 shift = radix;
1828 add = digit_value;
1829 }
1830 else
1831 {
1832 shift = shift * radix;
1833 add = add * radix + digit_value;
1834 }
1835 };
1836
1837 if (shift > 1)
1838 result = scm_product (result, SCM_MAKINUM (shift));
1839 if (add > 0)
1840 result = scm_sum (result, SCM_MAKINUM (add));
1841
1842 *p_idx = idx;
1843 if (hash_seen)
1844 *p_exactness = INEXACT;
1845
1846 return result;
2a8fecee
JB		 1847}
1848
1849
3c9a524f
DH		 1850/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
1851 * covers the parts of the rules that start at a potential point. The value
1852 * of the digits up to the point have been parsed by the caller and are given
79d34f68
DH		 1853 * in variable result. The content of *p_exactness indicates, whether a hash
1854 * has already been seen in the digits before the point.
3c9a524f 1855 */
1cc91f1b 1856
3c9a524f
DH		 1857/* In non ASCII-style encodings the following macro might not work. */
1858#define DIGIT2UINT(d) ((d) - '0')
1859
1860static SCM
79d34f68 1861mem2decimal_from_point (SCM result, const char* mem, size_t len,
3c9a524f 1862 unsigned int *p_idx, enum t_exactness *p_exactness)
0f2d19dd 1863{
3c9a524f
DH		 1864 unsigned int idx = *p_idx;
1865 enum t_exactness x = *p_exactness;
3c9a524f
DH		 1866
1867 if (idx == len)
79d34f68 1868 return result;
3c9a524f
DH		 1869
1870 if (mem[idx] == '.')
1871 {
1872 scm_t_bits shift = 1;
1873 scm_t_bits add = 0;
1874 unsigned int digit_value;
79d34f68 1875 SCM big_shift = SCM_MAKINUM (1);
3c9a524f
DH		 1876
1877 idx++;
1878 while (idx != len)
1879 {
1880 char c = mem[idx];
1881 if (isdigit (c))
1882 {
1883 if (x == INEXACT)
1884 return SCM_BOOL_F;
1885 else
1886 digit_value = DIGIT2UINT (c);
1887 }
1888 else if (c == '#')
1889 {
1890 x = INEXACT;
1891 digit_value = 0;
1892 }
1893 else
1894 break;
1895
1896 idx++;
1897 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
1898 {
1899 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68 1900 result = scm_product (result, SCM_MAKINUM (shift));
3c9a524f 1901 if (add > 0)
79d34f68 1902 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 1903
1904 shift = 10;
1905 add = digit_value;
1906 }
1907 else
1908 {
1909 shift = shift * 10;
1910 add = add * 10 + digit_value;
1911 }
1912 };
1913
1914 if (add > 0)
1915 {
1916 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68
DH		 1917 result = scm_product (result, SCM_MAKINUM (shift));
1918 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 1919 }
1920
79d34f68
DH		 1921 result = scm_divide (result, big_shift);
1922
3c9a524f
DH		 1923 /* We've seen a decimal point, thus the value is implicitly inexact. */
1924 x = INEXACT;
f872b822 1925 }
3c9a524f 1926
3c9a524f 1927 if (idx != len)
f872b822 1928 {
3c9a524f
DH		 1929 int sign = 1;
1930 unsigned int start;
1931 char c;
1932 int exponent;
1933 SCM e;
1934
1935 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
1936
1937 switch (mem[idx])
f872b822 1938 {
3c9a524f
DH		 1939 case 'd': case 'D':
1940 case 'e': case 'E':
1941 case 'f': case 'F':
1942 case 'l': case 'L':
1943 case 's': case 'S':
1944 idx++;
1945 start = idx;
1946 c = mem[idx];
1947 if (c == '-')
1948 {
1949 idx++;
1950 sign = -1;
1951 c = mem[idx];
1952 }
1953 else if (c == '+')
1954 {
1955 idx++;
1956 sign = 1;
1957 c = mem[idx];
1958 }
1959 else
1960 sign = 1;
1961
1962 if (!isdigit (c))
1963 return SCM_BOOL_F;
1964
1965 idx++;
1966 exponent = DIGIT2UINT (c);
1967 while (idx != len)
f872b822 1968 {
3c9a524f
DH		 1969 char c = mem[idx];
1970 if (isdigit (c))
1971 {
1972 idx++;
1973 if (exponent <= SCM_MAXEXP)
1974 exponent = exponent * 10 + DIGIT2UINT (c);
1975 }
1976 else
1977 break;
f872b822 1978 }
3c9a524f
DH		 1979
1980 if (exponent > SCM_MAXEXP)
f872b822 1981 {
3c9a524f
DH		 1982 size_t exp_len = idx - start;
1983 SCM exp_string = scm_mem2string (&mem[start], exp_len);
1984 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
1985 scm_out_of_range ("string->number", exp_num);
f872b822 1986 }
3c9a524f
DH		 1987
1988 e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent));
1989 if (sign == 1)
1990 result = scm_product (result, e);
1991 else
1992 result = scm_divide (result, e);
1993
1994 /* We've seen an exponent, thus the value is implicitly inexact. */
1995 x = INEXACT;
1996
f872b822 1997 break;
3c9a524f 1998
f872b822 1999 default:
3c9a524f 2000 break;
f872b822 2001 }
0f2d19dd 2002 }
3c9a524f
DH		 2003
2004 *p_idx = idx;
2005 if (x == INEXACT)
2006 *p_exactness = x;
2007
2008 return result;
0f2d19dd 2009}
0f2d19dd 2010
3c9a524f
DH		 2011
2012/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2013
2014static SCM
2015mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
2016 unsigned int radix, enum t_exactness *p_exactness)
0f2d19dd 2017{
3c9a524f 2018 unsigned int idx = *p_idx;
164d2481 2019 SCM result;
3c9a524f
DH		 2020
2021 if (idx == len)
2022 return SCM_BOOL_F;
2023
7351e207
MV		 2024 if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
2025 {
2026 *p_idx = idx+5;
2027 return scm_inf ();
2028 }
2029
2030 if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
2031 {
2032 enum t_exactness x = EXACT;
2033
2034 /* Cobble up the fraction. We might want to set the NaN's
2035 mantissa from it. */
2036 idx += 4;
2037 mem2uinteger (mem, len, &idx, 10, &x);
2038 *p_idx = idx;
2039 return scm_nan ();
2040 }
2041
3c9a524f
DH		 2042 if (mem[idx] == '.')
2043 {
2044 if (radix != 10)
2045 return SCM_BOOL_F;
2046 else if (idx + 1 == len)
2047 return SCM_BOOL_F;
2048 else if (!isdigit (mem[idx + 1]))
2049 return SCM_BOOL_F;
2050 else
164d2481
MV		 2051 result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
2052 p_idx, p_exactness);
f872b822 2053 }
3c9a524f
DH		 2054 else
2055 {
2056 enum t_exactness x = EXACT;
2057 SCM uinteger;
3c9a524f
DH		 2058
2059 uinteger = mem2uinteger (mem, len, &idx, radix, &x);
2060 if (SCM_FALSEP (uinteger))
2061 return SCM_BOOL_F;
2062
2063 if (idx == len)
2064 result = uinteger;
2065 else if (mem[idx] == '/')
f872b822 2066 {
3c9a524f
DH		 2067 SCM divisor;
2068
2069 idx++;
2070
2071 divisor = mem2uinteger (mem, len, &idx, radix, &x);
2072 if (SCM_FALSEP (divisor))
2073 return SCM_BOOL_F;
2074
2075 result = scm_divide (uinteger, divisor);
f872b822 2076 }
3c9a524f
DH		 2077 else if (radix == 10)
2078 {
2079 result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
2080 if (SCM_FALSEP (result))
2081 return SCM_BOOL_F;
2082 }
2083 else
2084 result = uinteger;
2085
2086 *p_idx = idx;
2087 if (x == INEXACT)
2088 *p_exactness = x;
f872b822 2089 }
164d2481
MV		 2090
2091 /* When returning an inexact zero, make sure it is represented as a
2092 floating point value so that we can change its sign.
2093 */
2094 if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT)
2095 result = scm_make_real (0.0);
2096
2097 return result;
3c9a524f 2098}
0f2d19dd 2099
0f2d19dd 2100
3c9a524f 2101/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
0f2d19dd 2102
3c9a524f
DH		 2103static SCM
2104mem2complex (const char* mem, size_t len, unsigned int idx,
2105 unsigned int radix, enum t_exactness *p_exactness)
2106{
2107 char c;
2108 int sign = 0;
2109 SCM ureal;
2110
2111 if (idx == len)
2112 return SCM_BOOL_F;
2113
2114 c = mem[idx];
2115 if (c == '+')
2116 {
2117 idx++;
2118 sign = 1;
2119 }
2120 else if (c == '-')
2121 {
2122 idx++;
2123 sign = -1;
0f2d19dd 2124 }
0f2d19dd 2125
3c9a524f
DH		 2126 if (idx == len)
2127 return SCM_BOOL_F;
2128
2129 ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
2130 if (SCM_FALSEP (ureal))
f872b822 2131 {
3c9a524f
DH		 2132 /* input must be either +i or -i */
2133
2134 if (sign == 0)
2135 return SCM_BOOL_F;
2136
2137 if (mem[idx] == 'i' || mem[idx] == 'I')
f872b822 2138 {
3c9a524f
DH		 2139 idx++;
2140 if (idx != len)
2141 return SCM_BOOL_F;
2142
2143 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign));
f872b822 2144 }
3c9a524f
DH		 2145 else
2146 return SCM_BOOL_F;
0f2d19dd 2147 }
3c9a524f
DH		 2148 else
2149 {
fc194577 2150 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f 2151 ureal = scm_difference (ureal, SCM_UNDEFINED);
f872b822 2152
3c9a524f
DH		 2153 if (idx == len)
2154 return ureal;
2155
2156 c = mem[idx];
2157 switch (c)
f872b822 2158 {
3c9a524f
DH		 2159 case 'i': case 'I':
2160 /* either +<ureal>i or -<ureal>i */
2161
2162 idx++;
2163 if (sign == 0)
2164 return SCM_BOOL_F;
2165 if (idx != len)
2166 return SCM_BOOL_F;
2167 return scm_make_rectangular (SCM_MAKINUM (0), ureal);
2168
2169 case '@':
2170 /* polar input: <real>@<real>. */
2171
2172 idx++;
2173 if (idx == len)
2174 return SCM_BOOL_F;
2175 else
f872b822 2176 {
3c9a524f
DH		 2177 int sign;
2178 SCM angle;
2179 SCM result;
2180
2181 c = mem[idx];
2182 if (c == '+')
2183 {
2184 idx++;
2185 sign = 1;
2186 }
2187 else if (c == '-')
2188 {
2189 idx++;
2190 sign = -1;
2191 }
2192 else
2193 sign = 1;
2194
2195 angle = mem2ureal (mem, len, &idx, radix, p_exactness);
2196 if (SCM_FALSEP (angle))
2197 return SCM_BOOL_F;
2198 if (idx != len)
2199 return SCM_BOOL_F;
2200
fc194577 2201 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f
DH		 2202 angle = scm_difference (angle, SCM_UNDEFINED);
2203
2204 result = scm_make_polar (ureal, angle);
2205 return result;
f872b822 2206 }
3c9a524f
DH		 2207 case '+':
2208 case '-':
2209 /* expecting input matching <real>[+-]<ureal>?i */
0f2d19dd 2210
3c9a524f
DH		 2211 idx++;
2212 if (idx == len)
2213 return SCM_BOOL_F;
2214 else
2215 {
2216 int sign = (c == '+') ? 1 : -1;
2217 SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
0f2d19dd 2218
3c9a524f
DH		 2219 if (SCM_FALSEP (imag))
2220 imag = SCM_MAKINUM (sign);
fc194577 2221 else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
1fe5e088 2222 imag = scm_difference (imag, SCM_UNDEFINED);
0f2d19dd 2223
3c9a524f
DH		 2224 if (idx == len)
2225 return SCM_BOOL_F;
2226 if (mem[idx] != 'i' && mem[idx] != 'I')
2227 return SCM_BOOL_F;
0f2d19dd 2228
3c9a524f
DH		 2229 idx++;
2230 if (idx != len)
2231 return SCM_BOOL_F;
0f2d19dd 2232
1fe5e088 2233 return scm_make_rectangular (ureal, imag);
3c9a524f
DH		 2234 }
2235 default:
2236 return SCM_BOOL_F;
2237 }
2238 }
0f2d19dd 2239}
0f2d19dd
JB		 2240
2241
3c9a524f
DH		 2242/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2243
2244enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
1cc91f1b 2245
0f2d19dd 2246SCM
3c9a524f 2247scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix)
0f2d19dd 2248{
3c9a524f
DH		 2249 unsigned int idx = 0;
2250 unsigned int radix = NO_RADIX;
2251 enum t_exactness forced_x = NO_EXACTNESS;
2252 enum t_exactness implicit_x = EXACT;
2253 SCM result;
2254
2255 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2256 while (idx + 2 < len && mem[idx] == '#')
2257 {
2258 switch (mem[idx + 1])
2259 {
2260 case 'b': case 'B':
2261 if (radix != NO_RADIX)
2262 return SCM_BOOL_F;
2263 radix = DUAL;
2264 break;
2265 case 'd': case 'D':
2266 if (radix != NO_RADIX)
2267 return SCM_BOOL_F;
2268 radix = DEC;
2269 break;
2270 case 'i': case 'I':
2271 if (forced_x != NO_EXACTNESS)
2272 return SCM_BOOL_F;
2273 forced_x = INEXACT;
2274 break;
2275 case 'e': case 'E':
2276 if (forced_x != NO_EXACTNESS)
2277 return SCM_BOOL_F;
2278 forced_x = EXACT;
2279 break;
2280 case 'o': case 'O':
2281 if (radix != NO_RADIX)
2282 return SCM_BOOL_F;
2283 radix = OCT;
2284 break;
2285 case 'x': case 'X':
2286 if (radix != NO_RADIX)
2287 return SCM_BOOL_F;
2288 radix = HEX;
2289 break;
2290 default:
f872b822 2291 return SCM_BOOL_F;
3c9a524f
DH		 2292 }
2293 idx += 2;
2294 }
2295
2296 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2297 if (radix == NO_RADIX)
2298 result = mem2complex (mem, len, idx, default_radix, &implicit_x);
2299 else
2300 result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
2301
2302 if (SCM_FALSEP (result))
2303 return SCM_BOOL_F;
f872b822 2304
3c9a524f 2305 switch (forced_x)
f872b822 2306 {
3c9a524f
DH		 2307 case EXACT:
2308 if (SCM_INEXACTP (result))
2309 /* FIXME: This may change the value. */
2310 return scm_inexact_to_exact (result);
2311 else
2312 return result;
2313 case INEXACT:
2314 if (SCM_INEXACTP (result))
2315 return result;
2316 else
2317 return scm_exact_to_inexact (result);
2318 case NO_EXACTNESS:
2319 default:
2320 if (implicit_x == INEXACT)
2321 {
2322 if (SCM_INEXACTP (result))
2323 return result;
2324 else
2325 return scm_exact_to_inexact (result);
2326 }
2327 else
2328 return result;
f872b822 2329 }
0f2d19dd
JB		 2330}
2331
2332
a1ec6916 2333SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
bb628794 2334 (SCM string, SCM radix),
1e6808ea 2335 "Return a number of the maximally precise representation\n"
942e5b91 2336 "expressed by the given @var{string}. @var{radix} must be an\n"
5352393c
MG		 2337 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2338 "is a default radix that may be overridden by an explicit radix\n"
2339 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2340 "supplied, then the default radix is 10. If string is not a\n"
2341 "syntactically valid notation for a number, then\n"
2342 "@code{string->number} returns @code{#f}.")
1bbd0b84 2343#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 2344{
2345 SCM answer;
1bbd0b84 2346 int base;
a6d9e5ab 2347 SCM_VALIDATE_STRING (1, string);
34d19ef6 2348 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base);
3c9a524f
DH		 2349 answer = scm_i_mem2number (SCM_STRING_CHARS (string),
2350 SCM_STRING_LENGTH (string),
2351 base);
bb628794 2352 return scm_return_first (answer, string);
0f2d19dd 2353}
1bbd0b84 2354#undef FUNC_NAME
3c9a524f
DH		 2355
2356
0f2d19dd
JB		 2357/*** END strs->nums ***/
2358
5986c47d 2359
0f2d19dd 2360SCM
f3ae5d60 2361scm_make_real (double x)
0f2d19dd 2362{
3553e1d1
GH		 2363 SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
2364
3a9809df 2365 SCM_REAL_VALUE (z) = x;
0f2d19dd
JB		 2366 return z;
2367}
0f2d19dd 2368
5986c47d 2369
f3ae5d60
MD		 2370SCM
2371scm_make_complex (double x, double y)
2372{
3a9809df
DH		 2373 if (y == 0.0) {
2374 return scm_make_real (x);
2375 } else {
2376 SCM z;
4c9419ac
MV		 2377 SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double),
2378 "complex"));
3a9809df
DH		 2379 SCM_COMPLEX_REAL (z) = x;
2380 SCM_COMPLEX_IMAG (z) = y;
2381 return z;
2382 }
f3ae5d60 2383}
1cc91f1b 2384
5986c47d 2385
0f2d19dd 2386SCM
1bbd0b84 2387scm_bigequal (SCM x, SCM y)
0f2d19dd 2388{
ca46fb90
RB		 2389 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (x));
2390 scm_remember_upto_here_2 (x, y);
2391 return SCM_BOOL (0 == result);
0f2d19dd
JB		 2392}
2393
0f2d19dd 2394SCM
f3ae5d60 2395scm_real_equalp (SCM x, SCM y)
0f2d19dd 2396{
f3ae5d60 2397 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
0f2d19dd
JB		 2398}
2399
f3ae5d60
MD		 2400SCM
2401scm_complex_equalp (SCM x, SCM y)
2402{
2403 return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
2404 && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
2405}
0f2d19dd
JB		 2406
2407
2408
1bbd0b84 2409SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
942e5b91
MG		 2410/* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2411 * "else. Note that the sets of complex, real, rational and\n"
2412 * "integer values form subsets of the set of numbers, i. e. the\n"
2413 * "predicate will be fulfilled for any number."
2414 */
a1ec6916 2415SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0,
1bbd0b84 2416 (SCM x),
942e5b91 2417 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
bb2c02f2 2418 "otherwise. Note that the sets of real, rational and integer\n"
942e5b91
MG		 2419 "values form subsets of the set of complex numbers, i. e. the\n"
2420 "predicate will also be fulfilled if @var{x} is a real,\n"
2421 "rational or integer number.")
1bbd0b84 2422#define FUNC_NAME s_scm_number_p
0f2d19dd 2423{
bb628794 2424 return SCM_BOOL (SCM_NUMBERP (x));
0f2d19dd 2425}
1bbd0b84 2426#undef FUNC_NAME
0f2d19dd
JB		 2427
2428
1bbd0b84 2429SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p);
942e5b91
MG		 2430/* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2431 * "Note that the sets of integer and rational values form a subset\n"
2432 * "of the set of real numbers, i. e. the predicate will also\n"
2433 * "be fulfilled if @var{x} is an integer or a rational number."
2434 */
a1ec6916 2435SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0,
1bbd0b84 2436 (SCM x),
942e5b91 2437 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
bb2c02f2 2438 "otherwise. Note that the set of integer values forms a subset of\n"
942e5b91
MG		 2439 "the set of rational numbers, i. e. the predicate will also be\n"
2440 "fulfilled if @var{x} is an integer number. Real numbers\n"
2441 "will also satisfy this predicate, because of their limited\n"
2442 "precision.")
1bbd0b84 2443#define FUNC_NAME s_scm_real_p
0f2d19dd 2444{
bb628794 2445 if (SCM_INUMP (x)) {
0f2d19dd 2446 return SCM_BOOL_T;
bb628794 2447 } else if (SCM_IMP (x)) {
0f2d19dd 2448 return SCM_BOOL_F;
3c9a524f 2449 } else if (SCM_REALP (x)) {
0f2d19dd 2450 return SCM_BOOL_T;
bb628794 2451 } else if (SCM_BIGP (x)) {
0f2d19dd 2452 return SCM_BOOL_T;
bb628794
DH		 2453 } else {
2454 return SCM_BOOL_F;
2455 }
0f2d19dd 2456}
1bbd0b84 2457#undef FUNC_NAME
0f2d19dd
JB		 2458
2459
a1ec6916 2460SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
1bbd0b84 2461 (SCM x),
942e5b91
MG		 2462 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2463 "else.")
1bbd0b84 2464#define FUNC_NAME s_scm_integer_p
0f2d19dd
JB		 2465{
2466 double r;
f872b822
MD		 2467 if (SCM_INUMP (x))
2468 return SCM_BOOL_T;
2469 if (SCM_IMP (x))
2470 return SCM_BOOL_F;
f872b822
MD		 2471 if (SCM_BIGP (x))
2472 return SCM_BOOL_T;
3c9a524f 2473 if (!SCM_INEXACTP (x))
f872b822 2474 return SCM_BOOL_F;
3c9a524f 2475 if (SCM_COMPLEXP (x))
f872b822 2476 return SCM_BOOL_F;
5986c47d 2477 r = SCM_REAL_VALUE (x);
f872b822
MD		 2478 if (r == floor (r))
2479 return SCM_BOOL_T;
0f2d19dd
JB		 2480 return SCM_BOOL_F;
2481}
1bbd0b84 2482#undef FUNC_NAME
0f2d19dd
JB		 2483
2484
a1ec6916 2485SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
1bbd0b84 2486 (SCM x),
942e5b91
MG		 2487 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2488 "else.")
1bbd0b84 2489#define FUNC_NAME s_scm_inexact_p
0f2d19dd 2490{
f4c627b3 2491 return SCM_BOOL (SCM_INEXACTP (x));
0f2d19dd 2492}
1bbd0b84 2493#undef FUNC_NAME
0f2d19dd
JB		 2494
2495
152f82bf 2496SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
942e5b91 2497/* "Return @code{#t} if all parameters are numerically equal." */
0f2d19dd 2498SCM
6e8d25a6 2499scm_num_eq_p (SCM x, SCM y)
0f2d19dd 2500{
f4c627b3
DH		 2501 if (SCM_INUMP (x)) {
2502 long xx = SCM_INUM (x);
2503 if (SCM_INUMP (y)) {
2504 long yy = SCM_INUM (y);
2505 return SCM_BOOL (xx == yy);
2506 } else if (SCM_BIGP (y)) {
2507 return SCM_BOOL_F;
2508 } else if (SCM_REALP (y)) {
2509 return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));
2510 } else if (SCM_COMPLEXP (y)) {
2511 return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))
2512 && (0.0 == SCM_COMPLEX_IMAG (y)));
2513 } else {
2514 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2515 }
f4c627b3
DH		 2516 } else if (SCM_BIGP (x)) {
2517 if (SCM_INUMP (y)) {
2518 return SCM_BOOL_F;
2519 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2520 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2521 scm_remember_upto_here_2 (x, y);
2522 return SCM_BOOL (0 == cmp);
f4c627b3 2523 } else if (SCM_REALP (y)) {
ca46fb90
RB		 2524 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2525 scm_remember_upto_here_1 (x);
2526 return SCM_BOOL (0 == cmp);
f4c627b3 2527 } else if (SCM_COMPLEXP (y)) {
ca46fb90
RB		 2528 int cmp;
2529 if (0.0 != SCM_COMPLEX_IMAG (y)) return SCM_BOOL_F;
2530 cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
2531 scm_remember_upto_here_1 (x);
2532 return SCM_BOOL (0 == cmp);
f4c627b3
DH		 2533 } else {
2534 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2535 }
2536 } else if (SCM_REALP (x)) {
2537 if (SCM_INUMP (y)) {
2538 return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));
2539 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2540 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2541 scm_remember_upto_here_1 (y);
2542 return SCM_BOOL (0 == cmp);
f4c627b3
DH		 2543 } else if (SCM_REALP (y)) {
2544 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
2545 } else if (SCM_COMPLEXP (y)) {
2546 return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
2547 && (0.0 == SCM_COMPLEX_IMAG (y)));
2548 } else {
2549 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2550 }
f4c627b3
DH		 2551 } else if (SCM_COMPLEXP (x)) {
2552 if (SCM_INUMP (y)) {
2553 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))
2554 && (SCM_COMPLEX_IMAG (x) == 0.0));
2555 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2556 int cmp;
2557 if (0.0 != SCM_COMPLEX_IMAG (x)) return SCM_BOOL_F;
2558 cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
2559 scm_remember_upto_here_1 (y);
2560 return SCM_BOOL (0 == cmp);
f4c627b3
DH		 2561 } else if (SCM_REALP (y)) {
2562 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
2563 && (SCM_COMPLEX_IMAG (x) == 0.0));
2564 } else if (SCM_COMPLEXP (y)) {
2565 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
2566 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
2567 } else {
2568 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
2569 }
2570 } else {
2571 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
2572 }
0f2d19dd
JB		 2573}
2574
2575
152f82bf 2576SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
942e5b91
MG		 2577/* "Return @code{#t} if the list of parameters is monotonically\n"
2578 * "increasing."
2579 */
0f2d19dd 2580SCM
6e8d25a6 2581scm_less_p (SCM x, SCM y)
0f2d19dd 2582{
f4c627b3
DH		 2583 if (SCM_INUMP (x)) {
2584 long xx = SCM_INUM (x);
2585 if (SCM_INUMP (y)) {
2586 long yy = SCM_INUM (y);
2587 return SCM_BOOL (xx < yy);
2588 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2589 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2590 scm_remember_upto_here_1 (y);
2591 return SCM_BOOL (sgn > 0);
f4c627b3
DH		 2592 } else if (SCM_REALP (y)) {
2593 return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
2594 } else {
2595 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2596 }
f4c627b3
DH		 2597 } else if (SCM_BIGP (x)) {
2598 if (SCM_INUMP (y)) {
ca46fb90
RB		 2599 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2600 scm_remember_upto_here_1 (x);
2601 return SCM_BOOL (sgn < 0);
f4c627b3 2602 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2603 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2604 scm_remember_upto_here_2 (x, y);
2605 return SCM_BOOL (cmp < 0);
f4c627b3 2606 } else if (SCM_REALP (y)) {
ca46fb90
RB		 2607 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2608 scm_remember_upto_here_1 (x);
2609 return SCM_BOOL (cmp < 0);
f4c627b3
DH		 2610 } else {
2611 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
2612 }
2613 } else if (SCM_REALP (x)) {
2614 if (SCM_INUMP (y)) {
2615 return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));
2616 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2617 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2618 scm_remember_upto_here_1 (y);
2619 return SCM_BOOL (cmp > 0);
f4c627b3
DH		 2620 } else if (SCM_REALP (y)) {
2621 return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
2622 } else {
2623 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2624 }
f4c627b3
DH		 2625 } else {
2626 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
2627 }
0f2d19dd
JB		 2628}
2629
2630
c76b1eaf 2631SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
942e5b91
MG		 2632/* "Return @code{#t} if the list of parameters is monotonically\n"
2633 * "decreasing."
c76b1eaf 2634 */
1bbd0b84 2635#define FUNC_NAME s_scm_gr_p
c76b1eaf
MD		 2636SCM
2637scm_gr_p (SCM x, SCM y)
0f2d19dd 2638{
c76b1eaf
MD		 2639 if (!SCM_NUMBERP (x))
2640 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
2641 else if (!SCM_NUMBERP (y))
2642 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
2643 else
2644 return scm_less_p (y, x);
0f2d19dd 2645}
1bbd0b84 2646#undef FUNC_NAME
0f2d19dd
JB		 2647
2648
c76b1eaf 2649SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
942e5b91 2650/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 2651 * "non-decreasing."
2652 */
1bbd0b84 2653#define FUNC_NAME s_scm_leq_p
c76b1eaf
MD		 2654SCM
2655scm_leq_p (SCM x, SCM y)
0f2d19dd 2656{
c76b1eaf
MD		 2657 if (!SCM_NUMBERP (x))
2658 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
2659 else if (!SCM_NUMBERP (y))
2660 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 2661 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
2662 return SCM_BOOL_F;
c76b1eaf
MD		 2663 else
2664 return SCM_BOOL_NOT (scm_less_p (y, x));
0f2d19dd 2665}
1bbd0b84 2666#undef FUNC_NAME
0f2d19dd
JB		 2667
2668
c76b1eaf 2669SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
942e5b91 2670/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 2671 * "non-increasing."
2672 */
1bbd0b84 2673#define FUNC_NAME s_scm_geq_p
c76b1eaf
MD		 2674SCM
2675scm_geq_p (SCM x, SCM y)
0f2d19dd 2676{
c76b1eaf
MD		 2677 if (!SCM_NUMBERP (x))
2678 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
2679 else if (!SCM_NUMBERP (y))
2680 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 2681 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
2682 return SCM_BOOL_F;
c76b1eaf 2683 else
fc194577 2684 return SCM_BOOL_NOT (scm_less_p (x, y));
0f2d19dd 2685}
1bbd0b84 2686#undef FUNC_NAME
0f2d19dd
JB		 2687
2688
152f82bf 2689SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
942e5b91
MG		 2690/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
2691 * "zero."
2692 */
0f2d19dd 2693SCM
6e8d25a6 2694scm_zero_p (SCM z)
0f2d19dd 2695{
c2ff8ab0
DH		 2696 if (SCM_INUMP (z)) {
2697 return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));
2698 } else if (SCM_BIGP (z)) {
2699 return SCM_BOOL_F;
2700 } else if (SCM_REALP (z)) {
2701 return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);
2702 } else if (SCM_COMPLEXP (z)) {
2703 return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0
2704 && SCM_COMPLEX_IMAG (z) == 0.0);
2705 } else {
2706 SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
2707 }
0f2d19dd
JB		 2708}
2709
2710
152f82bf 2711SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
942e5b91
MG		 2712/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
2713 * "zero."
2714 */
0f2d19dd 2715SCM
6e8d25a6 2716scm_positive_p (SCM x)
0f2d19dd 2717{
c2ff8ab0
DH		 2718 if (SCM_INUMP (x)) {
2719 return SCM_BOOL (SCM_INUM (x) > 0);
2720 } else if (SCM_BIGP (x)) {
ca46fb90
RB		 2721 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2722 scm_remember_upto_here_1 (x);
2723 return SCM_BOOL (sgn > 0);
c2ff8ab0
DH		 2724 } else if (SCM_REALP (x)) {
2725 return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);
2726 } else {
2727 SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
2728 }
0f2d19dd
JB		 2729}
2730
2731
152f82bf 2732SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
942e5b91
MG		 2733/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
2734 * "zero."
2735 */
0f2d19dd 2736SCM
6e8d25a6 2737scm_negative_p (SCM x)
0f2d19dd 2738{
c2ff8ab0
DH		 2739 if (SCM_INUMP (x)) {
2740 return SCM_BOOL (SCM_INUM (x) < 0);
2741 } else if (SCM_BIGP (x)) {
ca46fb90
RB		 2742 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2743 scm_remember_upto_here_1 (x);
2744 return SCM_BOOL (sgn < 0);
c2ff8ab0
DH		 2745 } else if (SCM_REALP (x)) {
2746 return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);
2747 } else {
2748 SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
2749 }
0f2d19dd
JB		 2750}
2751
2752
9de33deb 2753SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
942e5b91
MG		 2754/* "Return the maximum of all parameter values."
2755 */
0f2d19dd 2756SCM
6e8d25a6 2757scm_max (SCM x, SCM y)
0f2d19dd 2758{
f4c627b3
DH		 2759 if (SCM_UNBNDP (y)) {
2760 if (SCM_UNBNDP (x)) {
c05e97b7 2761 SCM_WTA_DISPATCH_0 (g_max, s_max);
f4c627b3 2762 } else if (SCM_NUMBERP (x)) {
f872b822 2763 return x;
f4c627b3
DH		 2764 } else {
2765 SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
f872b822 2766 }
f4c627b3
DH		 2767 }
2768
2769 if (SCM_INUMP (x)) {
2770 long xx = SCM_INUM (x);
2771 if (SCM_INUMP (y)) {
2772 long yy = SCM_INUM (y);
2773 return (xx < yy) ? y : x;
2774 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2775 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2776 scm_remember_upto_here_1 (y);
2777 return (sgn < 0) ? x : y;
f4c627b3
DH		 2778 } else if (SCM_REALP (y)) {
2779 double z = xx;
2780 return (z <= SCM_REAL_VALUE (y)) ? y : scm_make_real (z);
2781 } else {
2782 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 2783 }
f4c627b3
DH		 2784 } else if (SCM_BIGP (x)) {
2785 if (SCM_INUMP (y)) {
ca46fb90
RB		 2786 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2787 scm_remember_upto_here_1 (x);
2788 return (sgn < 0) ? y : x;
f4c627b3 2789 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2790 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2791 scm_remember_upto_here_2 (x, y);
2792 return (cmp > 0) ? x : y;
f4c627b3 2793 } else if (SCM_REALP (y)) {
ca46fb90
RB		 2794 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2795 scm_remember_upto_here_1 (x);
2796 return (cmp > 0) ? x : y;
f4c627b3
DH		 2797 } else {
2798 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
2799 }
2800 } else if (SCM_REALP (x)) {
2801 if (SCM_INUMP (y)) {
2802 double z = SCM_INUM (y);
2803 return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;
2804 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2805 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2806 scm_remember_upto_here_1 (y);
2807 return (cmp < 0) ? x : y;
f4c627b3
DH		 2808 } else if (SCM_REALP (y)) {
2809 return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? y : x;
2810 } else {
2811 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 2812 }
f4c627b3
DH		 2813 } else {
2814 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
2815 }
0f2d19dd
JB		 2816}
2817
2818
9de33deb 2819SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
942e5b91
MG		 2820/* "Return the minium of all parameter values."
2821 */
0f2d19dd 2822SCM
6e8d25a6 2823scm_min (SCM x, SCM y)
0f2d19dd 2824{
f4c627b3
DH		 2825 if (SCM_UNBNDP (y)) {
2826 if (SCM_UNBNDP (x)) {
c05e97b7 2827 SCM_WTA_DISPATCH_0 (g_min, s_min);
f4c627b3 2828 } else if (SCM_NUMBERP (x)) {
f872b822 2829 return x;
f4c627b3
DH		 2830 } else {
2831 SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
f872b822 2832 }
f4c627b3
DH		 2833 }
2834
2835 if (SCM_INUMP (x)) {
2836 long xx = SCM_INUM (x);
2837 if (SCM_INUMP (y)) {
2838 long yy = SCM_INUM (y);
2839 return (xx < yy) ? x : y;
2840 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2841 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2842 scm_remember_upto_here_1 (y);
2843 return (sgn < 0) ? y : x;
f4c627b3
DH		 2844 } else if (SCM_REALP (y)) {
2845 double z = xx;
2846 return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
2847 } else {
2848 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 2849 }
f4c627b3
DH		 2850 } else if (SCM_BIGP (x)) {
2851 if (SCM_INUMP (y)) {
ca46fb90
RB		 2852 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2853 scm_remember_upto_here_1 (x);
2854 return (sgn < 0) ? x : y;
f4c627b3 2855 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2856 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2857 scm_remember_upto_here_2 (x, y);
2858 return (cmp > 0) ? y : x;
f4c627b3 2859 } else if (SCM_REALP (y)) {
ca46fb90
RB		 2860 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2861 scm_remember_upto_here_1 (x);
2862 return (cmp > 0) ? y : x;
f4c627b3
DH		 2863 } else {
2864 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
2865 }
2866 } else if (SCM_REALP (x)) {
2867 if (SCM_INUMP (y)) {
2868 double z = SCM_INUM (y);
2869 return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z);
2870 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2871 int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2872 scm_remember_upto_here_1 (y);
2873 return (cmp < 0) ? y : x;
f4c627b3
DH		 2874 } else if (SCM_REALP (y)) {
2875 return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? x : y;
2876 } else {
2877 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 2878 }
f4c627b3
DH		 2879 } else {
2880 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
2881 }
0f2d19dd
JB		 2882}
2883
2884
9de33deb 2885SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
942e5b91
MG		 2886/* "Return the sum of all parameter values. Return 0 if called without\n"
2887 * "any parameters."
2888 */
0f2d19dd 2889SCM
6e8d25a6 2890scm_sum (SCM x, SCM y)
0f2d19dd 2891{
ca46fb90
RB		 2892 if (SCM_UNBNDP (y))
2893 {
2894 if (SCM_NUMBERP (x)) return x;
2895 if (SCM_UNBNDP (x)) return SCM_INUM0;
98cb6e75 2896 SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
f872b822 2897 }
c209c88e 2898
ca46fb90
RB		 2899 if (SCM_INUMP (x))
2900 {
2901 if (SCM_INUMP (y))
2902 {
2903 long xx = SCM_INUM (x);
2904 long yy = SCM_INUM (y);
2905 long int z = xx + yy;
2906 return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z);
2907 }
2908 else if (SCM_BIGP (y))
2909 {
2910 SCM_SWAP (x, y);
2911 goto add_big_inum;
2912 }
2913 else if (SCM_REALP (y))
2914 {
2915 long int xx = SCM_INUM (x);
2916 return scm_make_real (xx + SCM_REAL_VALUE (y));
2917 }
2918 else if (SCM_COMPLEXP (y))
2919 {
2920 long int xx = SCM_INUM (x);
2921 return scm_make_complex (xx + SCM_COMPLEX_REAL (y),
2922 SCM_COMPLEX_IMAG (y));
2923 }
2924 else
2925 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
2926 } else if (SCM_BIGP (x)) {
98cb6e75 2927 if (SCM_INUMP (y)) {
ca46fb90
RB		 2928 long int inum;
2929 int bigsgn;
2930 add_big_inum:
2931 inum = SCM_INUM (y);
2932 if (inum == 0) return x;
2933 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2934 if (inum < 0) {
2935 SCM result = scm_i_mkbig ();
2936 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
2937 scm_remember_upto_here_1 (x);
2938 /* we know the result will have to be a bignum */
2939 if (bigsgn == -1) return result;
2940 return scm_i_normbig (result);
98cb6e75 2941 } else {
ca46fb90
RB		 2942 SCM result = scm_i_mkbig ();
2943 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
2944 scm_remember_upto_here_1 (x);
2945 /* we know the result will have to be a bignum */
2946 if (bigsgn == 1) return result;
2947 return result;
2948 return scm_i_normbig (result);
0f2d19dd 2949 }
f872b822 2950 }
ca46fb90
RB		 2951 else if (SCM_BIGP (y)) {
2952 SCM result = scm_i_mkbig ();
2953 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
2954 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
2955 mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2956 scm_remember_upto_here_2 (x, y);
2957 /* we know the result will have to be a bignum */
2958 if (sgn_x == sgn_y) return result;
2959 return scm_i_normbig (result);
2960 }
2961 else if (SCM_REALP (y)) {
2962 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
2963 scm_remember_upto_here_1 (x);
2964 return scm_make_real (result);
2965 }
2966 else if (SCM_COMPLEXP (y)) {
2967 double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_COMPLEX_REAL (y);
2968 scm_remember_upto_here_1 (x);
2969 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
f872b822 2970 }
ca46fb90 2971 else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
98cb6e75
DH		 2972 } else if (SCM_REALP (x)) {
2973 if (SCM_INUMP (y)) {
2974 return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));
2975 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2976 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
2977 scm_remember_upto_here_1 (y);
2978 return scm_make_real (result);
98cb6e75
DH		 2979 } else if (SCM_REALP (y)) {
2980 return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
2981 } else if (SCM_COMPLEXP (y)) {
2982 return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
2983 SCM_COMPLEX_IMAG (y));
2984 } else {
2985 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
2986 }
2987 } else if (SCM_COMPLEXP (x)) {
2988 if (SCM_INUMP (y)) {
2989 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),
2990 SCM_COMPLEX_IMAG (x));
2991 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 2992 double real_part = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_COMPLEX_REAL (x);
2993 scm_remember_upto_here_1 (y);
2994 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));
98cb6e75
DH		 2995 } else if (SCM_REALP (y)) {
2996 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
2997 SCM_COMPLEX_IMAG (x));
2998 } else if (SCM_COMPLEXP (y)) {
2999 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
3000 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
3001 } else {
3002 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3003 }
3004 } else {
3005 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
3006 }
0f2d19dd
JB		 3007}
3008
3009
9de33deb 3010SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
609c3d30
MG		 3011/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3012 * the sum of all but the first argument are subtracted from the first
3013 * argument. */
c05e97b7 3014#define FUNC_NAME s_difference
0f2d19dd 3015SCM
6e8d25a6 3016scm_difference (SCM x, SCM y)
0f2d19dd 3017{
ca46fb90
RB		 3018 if (SCM_UNBNDP (y))
3019 {
3020 if (SCM_UNBNDP (x))
3021 SCM_WTA_DISPATCH_0 (g_difference, s_difference);
3022 else
3023 if (SCM_INUMP (x))
3024 {
3025 long xx = -SCM_INUM (x);
3026 if (SCM_FIXABLE (xx))
3027 return SCM_MAKINUM (xx);
3028 else
3029 return scm_i_long2big (xx);
3030 }
3031 else if (SCM_BIGP (x))
3032 /* FIXME: do we really need to normalize here? */
3033 return scm_i_normbig (scm_i_clonebig (x, 0));
3034 else if (SCM_REALP (x))
3035 return scm_make_real (-SCM_REAL_VALUE (x));
3036 else if (SCM_COMPLEXP (x))
3037 return scm_make_complex (-SCM_COMPLEX_REAL (x),
3038 -SCM_COMPLEX_IMAG (x));
3039 else
3040 SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
f872b822 3041 }
ca46fb90 3042
98cb6e75 3043 if (SCM_INUMP (x)) {
98cb6e75 3044 if (SCM_INUMP (y)) {
ca46fb90 3045 long int xx = SCM_INUM (x);
98cb6e75
DH		 3046 long int yy = SCM_INUM (y);
3047 long int z = xx - yy;
3048 if (SCM_FIXABLE (z)) {
3049 return SCM_MAKINUM (z);
3050 } else {
1be6b49c 3051 return scm_i_long2big (z);
98cb6e75 3052 }
ca46fb90
RB		 3053 } else if (SCM_BIGP (y)) {
3054 /* inum-x - big-y */
3055 long xx = SCM_INUM (x);
3056
3057 if (xx == 0)
3058 return scm_i_clonebig (y, 0);
3059 else
3060 {
3061 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3062 SCM result = scm_i_mkbig ();
3063
3064 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
3065 scm_remember_upto_here_1 (y);
3066
3067 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
3068 /* we know the result will have to be a bignum */
3069 return result;
3070 else
3071 return scm_i_normbig (result);
3072 }
98cb6e75 3073 } else if (SCM_REALP (y)) {
ca46fb90 3074 long int xx = SCM_INUM (x);
98cb6e75
DH		 3075 return scm_make_real (xx - SCM_REAL_VALUE (y));
3076 } else if (SCM_COMPLEXP (y)) {
ca46fb90 3077 long int xx = SCM_INUM (x);
98cb6e75
DH		 3078 return scm_make_complex (xx - SCM_COMPLEX_REAL (y),
3079 -SCM_COMPLEX_IMAG (y));
3080 } else {
3081 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3082 }
98cb6e75
DH		 3083 } else if (SCM_BIGP (x)) {
3084 if (SCM_INUMP (y)) {
ca46fb90
RB		 3085 /* big-x - inum-y */
3086 long yy = SCM_INUM (y);
3087 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3088
3089 scm_remember_upto_here_1 (x);
3090 if (sgn_x == 0)
3091 return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);
3092 else
3093 {
3094 SCM result = scm_i_mkbig ();
3095
3096 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
3097 scm_remember_upto_here_1 (x);
3098
3099 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
3100 /* we know the result will have to be a bignum */
3101 return result;
3102 else
3103 return scm_i_normbig (result);
3104 }
98cb6e75 3105 }
ca46fb90
RB		 3106 else if (SCM_BIGP (y))
3107 {
3108 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3109 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3110 SCM result = scm_i_mkbig ();
3111 mpz_sub (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3112 scm_remember_upto_here_2 (x, y);
3113 /* we know the result will have to be a bignum */
3114 if ((sgn_x == 1) && (sgn_y == -1)) return result;
3115 if ((sgn_x == -1) && (sgn_y == 1)) return result;
3116 return scm_i_normbig (result);
3117 }
3118 else if (SCM_REALP (y)) {
3119 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
3120 scm_remember_upto_here_1 (x);
3121 return scm_make_real (result);
3122 }
3123 else if (SCM_COMPLEXP (y)) {
3124 double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_COMPLEX_REAL (y);
3125 scm_remember_upto_here_1 (x);
3126 return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));
3127 }
3128 else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75
DH		 3129 } else if (SCM_REALP (x)) {
3130 if (SCM_INUMP (y)) {
3131 return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));
3132 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3133 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
3134 scm_remember_upto_here_1 (x);
3135 return scm_make_real (result);
98cb6e75
DH		 3136 } else if (SCM_REALP (y)) {
3137 return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
3138 } else if (SCM_COMPLEXP (y)) {
3139 return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
3140 -SCM_COMPLEX_IMAG (y));
3141 } else {
3142 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3143 }
3144 } else if (SCM_COMPLEXP (x)) {
3145 if (SCM_INUMP (y)) {
3146 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),
3147 SCM_COMPLEX_IMAG (x));
3148 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3149 double real_part = SCM_COMPLEX_REAL (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
3150 scm_remember_upto_here_1 (x);
3151 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
98cb6e75
DH		 3152 } else if (SCM_REALP (y)) {
3153 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
3154 SCM_COMPLEX_IMAG (x));
3155 } else if (SCM_COMPLEXP (y)) {
3156 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
3157 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
3158 } else {
3159 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3160 }
3161 } else {
3162 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
3163 }
0f2d19dd 3164}
c05e97b7 3165#undef FUNC_NAME
0f2d19dd 3166
ca46fb90 3167
9de33deb 3168SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
942e5b91
MG		 3169/* "Return the product of all arguments. If called without arguments,\n"
3170 * "1 is returned."
3171 */
0f2d19dd 3172SCM
6e8d25a6 3173scm_product (SCM x, SCM y)
0f2d19dd 3174{
f4c627b3
DH		 3175 if (SCM_UNBNDP (y)) {
3176 if (SCM_UNBNDP (x)) {
3177 return SCM_MAKINUM (1L);
3178 } else if (SCM_NUMBERP (x)) {
f872b822 3179 return x;
f4c627b3
DH		 3180 } else {
3181 SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
f872b822 3182 }
f4c627b3 3183 }
ca46fb90 3184
f4c627b3
DH		 3185 if (SCM_INUMP (x)) {
3186 long xx;
3187
3188 intbig:
3189 xx = SCM_INUM (x);
3190
ca46fb90
RB		 3191 switch (xx)
3192 {
3193 case 0: return x; break;
3194 case 1: return y; break;
3195 }
f4c627b3
DH		 3196
3197 if (SCM_INUMP (y)) {
3198 long yy = SCM_INUM (y);
3199 long kk = xx * yy;
3200 SCM k = SCM_MAKINUM (kk);
ca46fb90
RB		 3201 if ((kk == SCM_INUM (k)) && (kk / xx == yy)) {
3202 return k;
f4c627b3 3203 } else {
ca46fb90
RB		 3204 SCM result = scm_i_long2big (xx);
3205 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
3206 return scm_i_normbig (result);
0f2d19dd 3207 }
f4c627b3 3208 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3209 SCM result = scm_i_mkbig ();
3210 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
3211 scm_remember_upto_here_1 (y);
3212 return result;
f4c627b3
DH		 3213 } else if (SCM_REALP (y)) {
3214 return scm_make_real (xx * SCM_REAL_VALUE (y));
3215 } else if (SCM_COMPLEXP (y)) {
3216 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
3217 xx * SCM_COMPLEX_IMAG (y));
3218 } else {
3219 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3220 }
3221 } else if (SCM_BIGP (x)) {
3222 if (SCM_INUMP (y)) {
3223 SCM_SWAP (x, y);
3224 goto intbig;
3225 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3226 SCM result = scm_i_mkbig ();
3227 mpz_mul (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3228 scm_remember_upto_here_2 (x, y);
3229 return result;
f4c627b3 3230 } else if (SCM_REALP (y)) {
ca46fb90
RB		 3231 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
3232 scm_remember_upto_here_1 (x);
3233 return scm_make_real (result);
f4c627b3 3234 } else if (SCM_COMPLEXP (y)) {
ca46fb90
RB		 3235 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
3236 scm_remember_upto_here_1 (x);
f4c627b3
DH		 3237 return scm_make_complex (z * SCM_COMPLEX_REAL (y),
3238 z * SCM_COMPLEX_IMAG (y));
3239 } else {
3240 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3241 }
3242 } else if (SCM_REALP (x)) {
3243 if (SCM_INUMP (y)) {
3244 return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));
3245 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3246 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
3247 scm_remember_upto_here_1 (y);
3248 return scm_make_real (result);
f4c627b3
DH		 3249 } else if (SCM_REALP (y)) {
3250 return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
3251 } else if (SCM_COMPLEXP (y)) {
3252 return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
3253 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
3254 } else {
3255 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3256 }
3257 } else if (SCM_COMPLEXP (x)) {
3258 if (SCM_INUMP (y)) {
3259 return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),
3260 SCM_INUM (y) * SCM_COMPLEX_IMAG (x));
3261 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3262 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
3263 scm_remember_upto_here_1 (y);
3264 return scm_make_complex (z * SCM_COMPLEX_REAL (y),
3265 z * SCM_COMPLEX_IMAG (y));
f4c627b3
DH		 3266 } else if (SCM_REALP (y)) {
3267 return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
3268 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
3269 } else if (SCM_COMPLEXP (y)) {
3270 return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
3271 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
3272 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
3273 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
3274 } else {
3275 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
3276 }
3277 } else {
3278 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
0f2d19dd
JB		 3279 }
3280}
3281
0f2d19dd 3282double
6e8d25a6 3283scm_num2dbl (SCM a, const char *why)
f4c627b3 3284#define FUNC_NAME why
0f2d19dd 3285{
f4c627b3 3286 if (SCM_INUMP (a)) {
0f2d19dd 3287 return (double) SCM_INUM (a);
f4c627b3 3288 } else if (SCM_BIGP (a)) {
ca46fb90
RB		 3289 double result = mpz_get_d (SCM_I_BIG_MPZ (a));
3290 scm_remember_upto_here_1 (a);
3291 return result;
f4c627b3
DH		 3292 } else if (SCM_REALP (a)) {
3293 return (SCM_REAL_VALUE (a));
3294 } else {
3295 SCM_WRONG_TYPE_ARG (SCM_ARGn, a);
3296 }
0f2d19dd 3297}
f4c627b3 3298#undef FUNC_NAME
0f2d19dd 3299
7351e207
MV		 3300#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3301 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3302#define ALLOW_DIVIDE_BY_ZERO
3303/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3304#endif
0f2d19dd 3305
ba74ef4e
MV		 3306/* The code below for complex division is adapted from the GNU
3307 libstdc++, which adapted it from f2c's libF77, and is subject to
3308 this copyright: */
3309
3310/****************************************************************
3311Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3312
3313Permission to use, copy, modify, and distribute this software
3314and its documentation for any purpose and without fee is hereby
3315granted, provided that the above copyright notice appear in all
3316copies and that both that the copyright notice and this
3317permission notice and warranty disclaimer appear in supporting
3318documentation, and that the names of AT&T Bell Laboratories or
3319Bellcore or any of their entities not be used in advertising or
3320publicity pertaining to distribution of the software without
3321specific, written prior permission.
3322
3323AT&T and Bellcore disclaim all warranties with regard to this
3324software, including all implied warranties of merchantability
3325and fitness. In no event shall AT&T or Bellcore be liable for
3326any special, indirect or consequential damages or any damages
3327whatsoever resulting from loss of use, data or profits, whether
3328in an action of contract, negligence or other tortious action,
3329arising out of or in connection with the use or performance of
3330this software.
3331****************************************************************/
3332
9de33deb 3333SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
609c3d30
MG		 3334/* Divide the first argument by the product of the remaining
3335 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3336 returned. */
c05e97b7 3337#define FUNC_NAME s_divide
0f2d19dd 3338SCM
6e8d25a6 3339scm_divide (SCM x, SCM y)
0f2d19dd 3340{
f8de44c1
DH		 3341 double a;
3342
3343 if (SCM_UNBNDP (y)) {
3344 if (SCM_UNBNDP (x)) {
c05e97b7 3345 SCM_WTA_DISPATCH_0 (g_divide, s_divide);
f8de44c1 3346 } else if (SCM_INUMP (x)) {
164826d3
DH		 3347 long xx = SCM_INUM (x);
3348 if (xx == 1 || xx == -1) {
f8de44c1 3349 return x;
7351e207 3350#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
164826d3
DH		 3351 } else if (xx == 0) {
3352 scm_num_overflow (s_divide);
7351e207 3353#endif
f8de44c1 3354 } else {
164826d3 3355 return scm_make_real (1.0 / (double) xx);
f8de44c1 3356 }
f8de44c1 3357 } else if (SCM_BIGP (x)) {
1be6b49c 3358 return scm_make_real (1.0 / scm_i_big2dbl (x));
f8de44c1 3359 } else if (SCM_REALP (x)) {
5eec27e9 3360 double xx = SCM_REAL_VALUE (x);
7351e207 3361#ifndef ALLOW_DIVIDE_BY_ZERO
5eec27e9
DH		 3362 if (xx == 0.0)
3363 scm_num_overflow (s_divide);
3364 else
7351e207 3365#endif
5eec27e9 3366 return scm_make_real (1.0 / xx);
f8de44c1
DH		 3367 } else if (SCM_COMPLEXP (x)) {
3368 double r = SCM_COMPLEX_REAL (x);
3369 double i = SCM_COMPLEX_IMAG (x);
ba74ef4e
MV		 3370 if (r <= i) {
3371 double t = r / i;
3372 double d = i * (1.0 + t * t);
3373 return scm_make_complex (t / d, -1.0 / d);
3374 } else {
3375 double t = i / r;
3376 double d = r * (1.0 + t * t);
3377 return scm_make_complex (1.0 / d, -t / d);
3378 }
f8de44c1
DH		 3379 } else {
3380 SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
3381 }
3382 }
3383
3384 if (SCM_INUMP (x)) {
3385 long xx = SCM_INUM (x);
3386 if (SCM_INUMP (y)) {
3387 long yy = SCM_INUM (y);
3388 if (yy == 0) {
7351e207 3389#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
f4c627b3 3390 scm_num_overflow (s_divide);
7351e207
MV		 3391#else
3392 return scm_make_real ((double) xx / (double) yy);
3393#endif
f8de44c1
DH		 3394 } else if (xx % yy != 0) {
3395 return scm_make_real ((double) xx / (double) yy);
3396 } else {
3397 long z = xx / yy;
3398 if (SCM_FIXABLE (z)) {
3399 return SCM_MAKINUM (z);
3400 } else {
1be6b49c 3401 return scm_i_long2big (z);
f872b822 3402 }
f8de44c1 3403 }
f8de44c1 3404 } else if (SCM_BIGP (y)) {
1be6b49c 3405 return scm_make_real ((double) xx / scm_i_big2dbl (y));
f8de44c1 3406 } else if (SCM_REALP (y)) {
5eec27e9 3407 double yy = SCM_REAL_VALUE (y);
7351e207 3408#ifndef ALLOW_DIVIDE_BY_ZERO
5eec27e9
DH		 3409 if (yy == 0.0)
3410 scm_num_overflow (s_divide);
3411 else
7351e207 3412#endif
5eec27e9 3413 return scm_make_real ((double) xx / yy);
f8de44c1
DH		 3414 } else if (SCM_COMPLEXP (y)) {
3415 a = xx;
3416 complex_div: /* y _must_ be a complex number */
3417 {
3418 double r = SCM_COMPLEX_REAL (y);
3419 double i = SCM_COMPLEX_IMAG (y);
ba74ef4e
MV		 3420 if (r <= i) {
3421 double t = r / i;
3422 double d = i * (1.0 + t * t);
3423 return scm_make_complex ((a * t) / d, -a / d);
3424 } else {
3425 double t = i / r;
3426 double d = r * (1.0 + t * t);
3427 return scm_make_complex (a / d, -(a * t) / d);
3428 }
f8de44c1
DH		 3429 }
3430 } else {
3431 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3432 }
f8de44c1
DH		 3433 } else if (SCM_BIGP (x)) {
3434 if (SCM_INUMP (y)) {
3435 long int yy = SCM_INUM (y);
3436 if (yy == 0) {
7351e207 3437#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
f8de44c1 3438 scm_num_overflow (s_divide);
7351e207 3439#else
ca46fb90
RB		 3440 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3441 scm_remember_upto_here_1 (x);
3442 return (sgn == 0) ? scm_nan () : scm_inf ();
7351e207 3443#endif
f8de44c1
DH		 3444 } else if (yy == 1) {
3445 return x;
3446 } else {
ca46fb90
RB		 3447 /* FIXME: HMM, what are the relative performance issues here?
3448 We need to test. Is it faster on average to test
3449 divisible_p, then perform whichever operation, or is it
3450 faster to perform the integer div opportunistically and
3451 switch to real if there's a remainder? For now we take the
3452 middle ground: test, then if divisible, use the faster div
3453 func. */
3454
3455 long abs_yy = yy < 0 ? -yy : yy;
3456 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
3457
3458 if (divisible_p) {
3459 SCM result = scm_i_mkbig ();
3460 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
3461 scm_remember_upto_here_1 (x);
3462 if (yy < 0)
3463 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3464 return scm_i_normbig (result);
3465 }
3466 else {
3467 return scm_make_real (scm_i_big2dbl (x) / (double) yy);
3468 }
3469 }
3470 } else if (SCM_BIGP (y)) {
3471 int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
3472 if (y_is_zero) {
3473#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3474 scm_num_overflow (s_divide);
f872b822 3475#else
ca46fb90
RB		 3476 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3477 scm_remember_upto_here_1 (x);
3478 return (sgn == 0) ? scm_nan () : scm_inf ();
f872b822 3479#endif
ca46fb90
RB		 3480 } else {
3481 /* big_x / big_y */
3482 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
3483 SCM_I_BIG_MPZ (y));
3484 if (divisible_p) {
3485 SCM result = scm_i_mkbig ();
3486 mpz_divexact (SCM_I_BIG_MPZ (result),
3487 SCM_I_BIG_MPZ (x),
3488 SCM_I_BIG_MPZ (y));
3489 scm_remember_upto_here_2 (x, y);
3490 return scm_i_normbig (result);
3491 }
3492 else {
3493 double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));
3494 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3495 scm_remember_upto_here_2 (x, y);
3496 return scm_make_real (dbx / dby);
3497 }
f8de44c1 3498 }
f8de44c1 3499 } else if (SCM_REALP (y)) {
5eec27e9 3500 double yy = SCM_REAL_VALUE (y);
7351e207 3501#ifndef ALLOW_DIVIDE_BY_ZERO
5eec27e9
DH		 3502 if (yy == 0.0)
3503 scm_num_overflow (s_divide);
3504 else
7351e207 3505#endif
5eec27e9 3506 return scm_make_real (scm_i_big2dbl (x) / yy);
f8de44c1 3507 } else if (SCM_COMPLEXP (y)) {
1be6b49c 3508 a = scm_i_big2dbl (x);
f8de44c1
DH		 3509 goto complex_div;
3510 } else {
3511 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3512 }
f8de44c1
DH		 3513 } else if (SCM_REALP (x)) {
3514 double rx = SCM_REAL_VALUE (x);
3515 if (SCM_INUMP (y)) {
5eec27e9 3516 long int yy = SCM_INUM (y);
7351e207
MV		 3517#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3518 if (yy == 0)
5eec27e9 3519 scm_num_overflow (s_divide);
7351e207
MV		 3520 else
3521#endif
5eec27e9 3522 return scm_make_real (rx / (double) yy);
f8de44c1 3523 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3524 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3525 scm_remember_upto_here_1 (y);
3526 return scm_make_real (rx / dby);
f8de44c1 3527 } else if (SCM_REALP (y)) {
5eec27e9 3528 double yy = SCM_REAL_VALUE (y);
7351e207 3529#ifndef ALLOW_DIVIDE_BY_ZERO
5eec27e9
DH		 3530 if (yy == 0.0)
3531 scm_num_overflow (s_divide);
3532 else
7351e207 3533#endif
5eec27e9 3534 return scm_make_real (rx / yy);
f8de44c1
DH		 3535 } else if (SCM_COMPLEXP (y)) {
3536 a = rx;
3537 goto complex_div;
3538 } else {
3539 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3540 }
f8de44c1
DH		 3541 } else if (SCM_COMPLEXP (x)) {
3542 double rx = SCM_COMPLEX_REAL (x);
3543 double ix = SCM_COMPLEX_IMAG (x);
3544 if (SCM_INUMP (y)) {
5eec27e9 3545 long int yy = SCM_INUM (y);
7351e207
MV		 3546#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3547 if (yy == 0)
5eec27e9 3548 scm_num_overflow (s_divide);
7351e207
MV		 3549 else
3550#endif
3551 {
5eec27e9
DH		 3552 double d = yy;
3553 return scm_make_complex (rx / d, ix / d);
3554 }
f8de44c1 3555 } else if (SCM_BIGP (y)) {
ca46fb90
RB		 3556 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3557 scm_remember_upto_here_1 (y);
3558 return scm_make_complex (rx / dby, ix / dby);
f8de44c1 3559 } else if (SCM_REALP (y)) {
5eec27e9 3560 double yy = SCM_REAL_VALUE (y);
7351e207 3561#ifndef ALLOW_DIVIDE_BY_ZERO
5eec27e9
DH		 3562 if (yy == 0.0)
3563 scm_num_overflow (s_divide);
3564 else
7351e207 3565#endif
5eec27e9 3566 return scm_make_complex (rx / yy, ix / yy);
f8de44c1
DH		 3567 } else if (SCM_COMPLEXP (y)) {
3568 double ry = SCM_COMPLEX_REAL (y);
3569 double iy = SCM_COMPLEX_IMAG (y);
ba74ef4e
MV		 3570 if (ry <= iy) {
3571 double t = ry / iy;
3572 double d = iy * (1.0 + t * t);
3573 return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);
3574 } else {
3575 double t = iy / ry;
3576 double d = ry * (1.0 + t * t);
3577 return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);
3578 }
f8de44c1
DH		 3579 } else {
3580 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
3581 }
3582 } else {
3583 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
0f2d19dd
JB		 3584 }
3585}
c05e97b7 3586#undef FUNC_NAME
0f2d19dd 3587
9de33deb 3588SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh);
942e5b91
MG		 3589/* "Return the inverse hyperbolic sine of @var{x}."
3590 */
0f2d19dd 3591double
6e8d25a6 3592scm_asinh (double x)
0f2d19dd 3593{
f872b822 3594 return log (x + sqrt (x * x + 1));
0f2d19dd
JB		 3595}
3596
3597
9de33deb 3598SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh);
942e5b91
MG		 3599/* "Return the inverse hyperbolic cosine of @var{x}."
3600 */
0f2d19dd 3601double
6e8d25a6 3602scm_acosh (double x)
0f2d19dd 3603{
f872b822 3604 return log (x + sqrt (x * x - 1));
0f2d19dd
JB		 3605}
3606
3607
9de33deb 3608SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh);
942e5b91
MG		 3609/* "Return the inverse hyperbolic tangent of @var{x}."
3610 */
0f2d19dd 3611double
6e8d25a6 3612scm_atanh (double x)
0f2d19dd 3613{
f872b822 3614 return 0.5 * log ((1 + x) / (1 - x));
0f2d19dd
JB		 3615}
3616
3617
9de33deb 3618SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
942e5b91
MG		 3619/* "Round the inexact number @var{x} towards zero."
3620 */
0f2d19dd 3621double
6e8d25a6 3622scm_truncate (double x)
0f2d19dd 3623{
f872b822
MD		 3624 if (x < 0.0)
3625 return -floor (-x);
3626 return floor (x);
0f2d19dd
JB		 3627}
3628
3629
9de33deb 3630SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
942e5b91
MG		 3631/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3632 * "numbers, round towards even."
3633 */
0f2d19dd 3634double
6e8d25a6 3635scm_round (double x)
0f2d19dd
JB		 3636{
3637 double plus_half = x + 0.5;
f872b822 3638 double result = floor (plus_half);
0f2d19dd 3639 /* Adjust so that the scm_round is towards even. */
f872b822 3640 return (plus_half == result && plus_half / 2 != floor (plus_half / 2))
0f2d19dd
JB		 3641 ? result - 1 : result;
3642}
3643
3644
9de33deb 3645SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
942e5b91
MG		 3646/* "Round the number @var{x} towards minus infinity."
3647 */
9de33deb 3648SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
942e5b91
MG		 3649/* "Round the number @var{x} towards infinity."
3650 */
9de33deb 3651SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
942e5b91
MG		 3652/* "Return the square root of the real number @var{x}."
3653 */
9de33deb 3654SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
942e5b91
MG		 3655/* "Return the absolute value of the real number @var{x}."
3656 */
9de33deb 3657SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
942e5b91
MG		 3658/* "Return the @var{x}th power of e."
3659 */
9de33deb 3660SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log);
b3fcac34 3661/* "Return the natural logarithm of the real number @var{x}."
942e5b91 3662 */
9de33deb 3663SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin);
942e5b91
MG		 3664/* "Return the sine of the real number @var{x}."
3665 */
9de33deb 3666SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos);
942e5b91
MG		 3667/* "Return the cosine of the real number @var{x}."
3668 */
9de33deb 3669SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan);
942e5b91
MG		 3670/* "Return the tangent of the real number @var{x}."
3671 */
9de33deb 3672SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin);
942e5b91
MG		 3673/* "Return the arc sine of the real number @var{x}."
3674 */
9de33deb 3675SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos);
942e5b91
MG		 3676/* "Return the arc cosine of the real number @var{x}."
3677 */
9de33deb 3678SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan);
942e5b91
MG		 3679/* "Return the arc tangent of the real number @var{x}."
3680 */
9de33deb 3681SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh);
942e5b91
MG		 3682/* "Return the hyperbolic sine of the real number @var{x}."
3683 */
9de33deb 3684SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh);
942e5b91
MG		 3685/* "Return the hyperbolic cosine of the real number @var{x}."
3686 */
9de33deb 3687SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh);
942e5b91
MG		 3688/* "Return the hyperbolic tangent of the real number @var{x}."
3689 */
f872b822
MD		 3690
3691struct dpair
3692{
3693 double x, y;
3694};
3695
27c37006
NJ		 3696static void scm_two_doubles (SCM x,
3697 SCM y,
3eeba8d4
JB		 3698 const char *sstring,
3699 struct dpair * xy);
f872b822
MD		 3700
3701static void
27c37006
NJ		 3702scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
3703{
3704 if (SCM_INUMP (x)) {
3705 xy->x = SCM_INUM (x);
3706 } else if (SCM_BIGP (x)) {
1be6b49c 3707 xy->x = scm_i_big2dbl (x);
27c37006
NJ		 3708 } else if (SCM_REALP (x)) {
3709 xy->x = SCM_REAL_VALUE (x);
98cb6e75 3710 } else {
27c37006 3711 scm_wrong_type_arg (sstring, SCM_ARG1, x);
98cb6e75
DH		 3712 }
3713
27c37006
NJ		 3714 if (SCM_INUMP (y)) {
3715 xy->y = SCM_INUM (y);
3716 } else if (SCM_BIGP (y)) {
1be6b49c 3717 xy->y = scm_i_big2dbl (y);
27c37006
NJ		 3718 } else if (SCM_REALP (y)) {
3719 xy->y = SCM_REAL_VALUE (y);
98cb6e75 3720 } else {
27c37006 3721 scm_wrong_type_arg (sstring, SCM_ARG2, y);
98cb6e75 3722 }
0f2d19dd
JB		 3723}
3724
3725
a1ec6916 3726SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
27c37006
NJ		 3727 (SCM x, SCM y),
3728 "Return @var{x} raised to the power of @var{y}. This\n"
0137a31b 3729 "procedure does not accept complex arguments.")
1bbd0b84 3730#define FUNC_NAME s_scm_sys_expt
0f2d19dd
JB		 3731{
3732 struct dpair xy;
27c37006 3733 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 3734 return scm_make_real (pow (xy.x, xy.y));
0f2d19dd 3735}
1bbd0b84 3736#undef FUNC_NAME
0f2d19dd
JB		 3737
3738
a1ec6916 3739SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
27c37006
NJ		 3740 (SCM x, SCM y),
3741 "Return the arc tangent of the two arguments @var{x} and\n"
3742 "@var{y}. This is similar to calculating the arc tangent of\n"
3743 "@var{x} / @var{y}, except that the signs of both arguments\n"
0137a31b
MG		 3744 "are used to determine the quadrant of the result. This\n"
3745 "procedure does not accept complex arguments.")
1bbd0b84 3746#define FUNC_NAME s_scm_sys_atan2
0f2d19dd
JB		 3747{
3748 struct dpair xy;
27c37006 3749 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 3750 return scm_make_real (atan2 (xy.x, xy.y));
0f2d19dd 3751}
1bbd0b84 3752#undef FUNC_NAME
0f2d19dd
JB		 3753
3754
a1ec6916 3755SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
bb628794 3756 (SCM real, SCM imaginary),
942e5b91
MG		 3757 "Return a complex number constructed of the given @var{real} and\n"
3758 "@var{imaginary} parts.")
1bbd0b84 3759#define FUNC_NAME s_scm_make_rectangular
0f2d19dd
JB		 3760{
3761 struct dpair xy;
bb628794 3762 scm_two_doubles (real, imaginary, FUNC_NAME, &xy);
f8de44c1 3763 return scm_make_complex (xy.x, xy.y);
0f2d19dd 3764}
1bbd0b84 3765#undef FUNC_NAME
0f2d19dd
JB		 3766
3767
3768
a1ec6916 3769SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
27c37006 3770 (SCM x, SCM y),
942e5b91 3771 "Return the complex number @var{x} * e^(i * @var{y}).")
1bbd0b84 3772#define FUNC_NAME s_scm_make_polar
0f2d19dd
JB		 3773{
3774 struct dpair xy;
27c37006 3775 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 3776 return scm_make_complex (xy.x * cos (xy.y), xy.x * sin (xy.y));
0f2d19dd 3777}
1bbd0b84 3778#undef FUNC_NAME
0f2d19dd
JB		 3779
3780
152f82bf 3781SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
942e5b91
MG		 3782/* "Return the real part of the number @var{z}."
3783 */
0f2d19dd 3784SCM
6e8d25a6 3785scm_real_part (SCM z)
0f2d19dd 3786{
c2ff8ab0
DH		 3787 if (SCM_INUMP (z)) {
3788 return z;
3789 } else if (SCM_BIGP (z)) {
3790 return z;
3791 } else if (SCM_REALP (z)) {
3792 return z;
3793 } else if (SCM_COMPLEXP (z)) {
3794 return scm_make_real (SCM_COMPLEX_REAL (z));
3795 } else {
3796 SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
3797 }
0f2d19dd
JB		 3798}
3799
3800
152f82bf 3801SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
942e5b91
MG		 3802/* "Return the imaginary part of the number @var{z}."
3803 */
0f2d19dd 3804SCM
6e8d25a6 3805scm_imag_part (SCM z)
0f2d19dd 3806{
c2ff8ab0 3807 if (SCM_INUMP (z)) {
f872b822 3808 return SCM_INUM0;
c2ff8ab0 3809 } else if (SCM_BIGP (z)) {
f872b822 3810 return SCM_INUM0;
c2ff8ab0
DH		 3811 } else if (SCM_REALP (z)) {
3812 return scm_flo0;
3813 } else if (SCM_COMPLEXP (z)) {
3814 return scm_make_real (SCM_COMPLEX_IMAG (z));
3815 } else {
3816 SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
3817 }
0f2d19dd
JB		 3818}
3819
3820
9de33deb 3821SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
942e5b91
MG		 3822/* "Return the magnitude of the number @var{z}. This is the same as\n"
3823 * "@code{abs} for real arguments, but also allows complex numbers."
3824 */
0f2d19dd 3825SCM
6e8d25a6 3826scm_magnitude (SCM z)
0f2d19dd 3827{
c2ff8ab0 3828 if (SCM_INUMP (z)) {
5986c47d
DH		 3829 long int zz = SCM_INUM (z);
3830 if (zz >= 0) {
3831 return z;
3832 } else if (SCM_POSFIXABLE (-zz)) {
3833 return SCM_MAKINUM (-zz);
3834 } else {
1be6b49c 3835 return scm_i_long2big (-zz);
5986c47d 3836 }
c2ff8ab0 3837 } else if (SCM_BIGP (z)) {
ca46fb90
RB		 3838 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
3839 scm_remember_upto_here_1 (z);
3840 if (sgn < 0) {
3841 return scm_i_clonebig (z, 0);
5986c47d 3842 } else {
ca46fb90 3843 return z;
5986c47d 3844 }
c2ff8ab0
DH		 3845 } else if (SCM_REALP (z)) {
3846 return scm_make_real (fabs (SCM_REAL_VALUE (z)));
3847 } else if (SCM_COMPLEXP (z)) {
3848 double r = SCM_COMPLEX_REAL (z);
3849 double i = SCM_COMPLEX_IMAG (z);
3850 return scm_make_real (sqrt (i * i + r * r));
3851 } else {
3852 SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
3853 }
0f2d19dd
JB		 3854}
3855
3856
9de33deb 3857SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
942e5b91
MG		 3858/* "Return the angle of the complex number @var{z}."
3859 */
0f2d19dd 3860SCM
6e8d25a6 3861scm_angle (SCM z)
0f2d19dd 3862{
f4c627b3
DH		 3863 if (SCM_INUMP (z)) {
3864 if (SCM_INUM (z) >= 0) {
3865 return scm_make_real (atan2 (0.0, 1.0));
3866 } else {
3867 return scm_make_real (atan2 (0.0, -1.0));
f872b822 3868 }
f4c627b3 3869 } else if (SCM_BIGP (z)) {
ca46fb90
RB		 3870 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
3871 scm_remember_upto_here_1 (z);
3872 if (sgn < 0) {
f4c627b3
DH		 3873 return scm_make_real (atan2 (0.0, -1.0));
3874 } else {
3875 return scm_make_real (atan2 (0.0, 1.0));
0f2d19dd 3876 }
f4c627b3
DH		 3877 } else if (SCM_REALP (z)) {
3878 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z)));
3879 } else if (SCM_COMPLEXP (z)) {
3880 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
3881 } else {
3882 SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
3883 }
0f2d19dd
JB		 3884}
3885
3886
3c9a524f
DH		 3887SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact);
3888/* Convert the number @var{x} to its inexact representation.\n"
3889 */
3890SCM
3891scm_exact_to_inexact (SCM z)
3892{
3893 if (SCM_INUMP (z))
3894 return scm_make_real ((double) SCM_INUM (z));
3895 else if (SCM_BIGP (z))
3896 return scm_make_real (scm_i_big2dbl (z));
3897 else if (SCM_INEXACTP (z))
3898 return z;
3899 else
3900 SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact);
3901}
3902
3903
a1ec6916 3904SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
1bbd0b84 3905 (SCM z),
1e6808ea 3906 "Return an exact number that is numerically closest to @var{z}.")
1bbd0b84 3907#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 3908{
c2ff8ab0 3909 if (SCM_INUMP (z)) {
f872b822 3910 return z;
c2ff8ab0 3911 } else if (SCM_BIGP (z)) {
f872b822 3912 return z;
c2ff8ab0
DH		 3913 } else if (SCM_REALP (z)) {
3914 double u = floor (SCM_REAL_VALUE (z) + 0.5);
3915 long lu = (long) u;
3916 if (SCM_FIXABLE (lu)) {
3917 return SCM_MAKINUM (lu);
fc194577 3918 } else if (isfinite (u) && !xisnan (u)) {
1be6b49c 3919 return scm_i_dbl2big (u);
c2ff8ab0
DH		 3920 } else {
3921 scm_num_overflow (s_scm_inexact_to_exact);
3922 }
3923 } else {
3924 SCM_WRONG_TYPE_ARG (1, z);
3925 }
0f2d19dd 3926}
1bbd0b84 3927#undef FUNC_NAME
0f2d19dd 3928
87617347 3929/* if you need to change this, change test-num2integral.c as well */
ee33d62a 3930#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 3931# ifndef LLONG_MAX
3932# define ULLONG_MAX ((unsigned long long) (-1))
3933# define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
3934# define LLONG_MIN (~LLONG_MAX)
3935# endif
f872b822 3936#endif
0f2d19dd 3937
3d2e8ceb
MV		 3938/* Parameters for creating integer conversion routines.
3939
3940 Define the following preprocessor macros before including
3941 "libguile/num2integral.i.c":
3942
3943 NUM2INTEGRAL - the name of the function for converting from a
ca46fb90
RB		 3944 Scheme object to the integral type. This function will be
3945 defined when including "num2integral.i.c".
3d2e8ceb
MV		 3946
3947 INTEGRAL2NUM - the name of the function for converting from the
ca46fb90 3948 integral type to a Scheme object. This function will be defined.
3d2e8ceb
MV		 3949
3950 INTEGRAL2BIG - the name of an internal function that createas a
ca46fb90
RB		 3951 bignum from the integral type. This function will be defined.
3952 The name should start with "scm_i_".
3953
3954 ITYPE - the name of the integral type.
3955
3956 UNSIGNED - Define this when ITYPE is an unsigned type. Do not
3957 define it otherwise.
3958
3959 UNSIGNED_ITYPE - the name of the the unsigned variant of the
3960 integral type. If you don't define this, it defaults to
3961 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
3962 ones.
3963
3964 SIZEOF_ITYPE - an expression giving the size of the integral type
3965 in bytes. This expression must be computable by the
3966 preprocessor. (SIZEOF_FOO values are calculated by configure.in
3967 for common types).
3968
3d2e8ceb
MV		 3969*/
3970
1be6b49c
ML		 3971#define NUM2INTEGRAL scm_num2short
3972#define INTEGRAL2NUM scm_short2num
3973#define INTEGRAL2BIG scm_i_short2big
ca46fb90 3974#define UNSIGNED 0
1be6b49c 3975#define ITYPE short
3d2e8ceb 3976#define SIZEOF_ITYPE SIZEOF_SHORT
1be6b49c
ML		 3977#include "libguile/num2integral.i.c"
3978
3979#define NUM2INTEGRAL scm_num2ushort
3980#define INTEGRAL2NUM scm_ushort2num
3981#define INTEGRAL2BIG scm_i_ushort2big
ca46fb90 3982#define UNSIGNED 1
1be6b49c 3983#define ITYPE unsigned short
ca46fb90 3984#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
1be6b49c
ML		 3985#include "libguile/num2integral.i.c"
3986
3987#define NUM2INTEGRAL scm_num2int
3988#define INTEGRAL2NUM scm_int2num
3989#define INTEGRAL2BIG scm_i_int2big
ca46fb90 3990#define UNSIGNED 0
1be6b49c 3991#define ITYPE int
3d2e8ceb 3992#define SIZEOF_ITYPE SIZEOF_INT
1be6b49c
ML		 3993#include "libguile/num2integral.i.c"
3994
3995#define NUM2INTEGRAL scm_num2uint
3996#define INTEGRAL2NUM scm_uint2num
3997#define INTEGRAL2BIG scm_i_uint2big
ca46fb90 3998#define UNSIGNED 1
1be6b49c 3999#define ITYPE unsigned int
ca46fb90 4000#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
1be6b49c
ML		 4001#include "libguile/num2integral.i.c"
4002
4003#define NUM2INTEGRAL scm_num2long
4004#define INTEGRAL2NUM scm_long2num
4005#define INTEGRAL2BIG scm_i_long2big
ca46fb90 4006#define UNSIGNED 0
1be6b49c 4007#define ITYPE long
3d2e8ceb 4008#define SIZEOF_ITYPE SIZEOF_LONG
1be6b49c
ML		 4009#include "libguile/num2integral.i.c"
4010
4011#define NUM2INTEGRAL scm_num2ulong
4012#define INTEGRAL2NUM scm_ulong2num
4013#define INTEGRAL2BIG scm_i_ulong2big
ca46fb90 4014#define UNSIGNED 1
1be6b49c 4015#define ITYPE unsigned long
ca46fb90 4016#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
1be6b49c
ML		 4017#include "libguile/num2integral.i.c"
4018
1be6b49c
ML		 4019#define NUM2INTEGRAL scm_num2ptrdiff
4020#define INTEGRAL2NUM scm_ptrdiff2num
4021#define INTEGRAL2BIG scm_i_ptrdiff2big
ca46fb90 4022#define UNSIGNED 0
ee33d62a 4023#define ITYPE scm_t_ptrdiff
3d2e8ceb 4024#define UNSIGNED_ITYPE size_t
ee33d62a 4025#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
1be6b49c
ML		 4026#include "libguile/num2integral.i.c"
4027
4028#define NUM2INTEGRAL scm_num2size
4029#define INTEGRAL2NUM scm_size2num
4030#define INTEGRAL2BIG scm_i_size2big
ca46fb90 4031#define UNSIGNED 1
1be6b49c 4032#define ITYPE size_t
3d2e8ceb 4033#define SIZEOF_ITYPE SIZEOF_SIZE_T
1be6b49c 4034#include "libguile/num2integral.i.c"
0f2d19dd 4035
ee33d62a 4036#if SCM_SIZEOF_LONG_LONG != 0
1cc91f1b 4037
caf08e65
MV		 4038#ifndef ULONG_LONG_MAX
4039#define ULONG_LONG_MAX (~0ULL)
4040#endif
4041
1be6b49c
ML		 4042#define NUM2INTEGRAL scm_num2long_long
4043#define INTEGRAL2NUM scm_long_long2num
4044#define INTEGRAL2BIG scm_i_long_long2big
ca46fb90 4045#define UNSIGNED 0
1be6b49c 4046#define ITYPE long long
3d2e8ceb 4047#define SIZEOF_ITYPE SIZEOF_LONG_LONG
1be6b49c
ML		 4048#include "libguile/num2integral.i.c"
4049
4050#define NUM2INTEGRAL scm_num2ulong_long
4051#define INTEGRAL2NUM scm_ulong_long2num
4052#define INTEGRAL2BIG scm_i_ulong_long2big
ca46fb90 4053#define UNSIGNED 1
1be6b49c 4054#define ITYPE unsigned long long
ca46fb90 4055#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
1be6b49c 4056#include "libguile/num2integral.i.c"
0f2d19dd 4057
ee33d62a 4058#endif /* SCM_SIZEOF_LONG_LONG != 0 */
caf08e65 4059
5437598b
MD		 4060#define NUM2FLOAT scm_num2float
4061#define FLOAT2NUM scm_float2num
4062#define FTYPE float
4063#include "libguile/num2float.i.c"
4064
4065#define NUM2FLOAT scm_num2double
4066#define FLOAT2NUM scm_double2num
4067#define FTYPE double
4068#include "libguile/num2float.i.c"
4069
1be6b49c 4070#ifdef GUILE_DEBUG
caf08e65 4071
6063dc1d
SJ		 4072#ifndef SIZE_MAX
4073#define SIZE_MAX ((size_t) (-1))
4074#endif
4075#ifndef PTRDIFF_MIN
4076#define PTRDIFF_MIN \
ee33d62a 4077 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 << (sizeof (scm_t_ptrdiff) * 8 - 1)))
6063dc1d
SJ		 4078#endif
4079#ifndef PTRDIFF_MAX
4080#define PTRDIFF_MAX (~ PTRDIFF_MIN)
4081#endif
4082
1be6b49c
ML		 4083#define CHECK(type, v) \
4084 do { \
4085 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4086 abort (); \
4087 } while (0);
caf08e65 4088
1be6b49c
ML		 4089static void
4090check_sanity ()
4091{
4092 CHECK (short, 0);
4093 CHECK (ushort, 0U);
4094 CHECK (int, 0);
4095 CHECK (uint, 0U);
4096 CHECK (long, 0L);
4097 CHECK (ulong, 0UL);
4098 CHECK (size, 0);
4099 CHECK (ptrdiff, 0);
4100
4101 CHECK (short, -1);
4102 CHECK (int, -1);
4103 CHECK (long, -1L);
4104 CHECK (ptrdiff, -1);
4105
4106 CHECK (short, SHRT_MAX);
4107 CHECK (short, SHRT_MIN);
4108 CHECK (ushort, USHRT_MAX);
4109 CHECK (int, INT_MAX);
4110 CHECK (int, INT_MIN);
4111 CHECK (uint, UINT_MAX);
4112 CHECK (long, LONG_MAX);
4113 CHECK (long, LONG_MIN);
4114 CHECK (ulong, ULONG_MAX);
4115 CHECK (size, SIZE_MAX);
4116 CHECK (ptrdiff, PTRDIFF_MAX);
4117 CHECK (ptrdiff, PTRDIFF_MIN);
0f2d19dd 4118
ee33d62a 4119#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 4120 CHECK (long_long, 0LL);
4121 CHECK (ulong_long, 0ULL);
1be6b49c 4122 CHECK (long_long, -1LL);
1be6b49c
ML		 4123 CHECK (long_long, LLONG_MAX);
4124 CHECK (long_long, LLONG_MIN);
4125 CHECK (ulong_long, ULLONG_MAX);
4126#endif
0f2d19dd
JB		 4127}
4128
b10586f0
ML		 4129#undef CHECK
4130
4131#define CHECK \
4132 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4133 if (!SCM_FALSEP (data)) abort();
4134
4135static SCM
4136check_body (void *data)
4137{
4138 SCM num = *(SCM *) data;
4139 scm_num2ulong (num, 1, NULL);
4140
4141 return SCM_UNSPECIFIED;
4142}
4143
4144static SCM
4145check_handler (void *data, SCM tag, SCM throw_args)
4146{
4147 SCM *num = (SCM *) data;
4148 *num = SCM_BOOL_F;
4149
4150 return SCM_UNSPECIFIED;
4151}
4152
4153SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0,
b4e15479 4154 (void),
b10586f0
ML		 4155 "Number conversion sanity checking.")
4156#define FUNC_NAME s_scm_sys_check_number_conversions
4157{
4158 SCM data = SCM_MAKINUM (-1);
4159 CHECK;
4160 data = scm_int2num (INT_MIN);
4161 CHECK;
4162 data = scm_ulong2num (ULONG_MAX);
4163 data = scm_difference (SCM_INUM0, data);
4164 CHECK;
4165 data = scm_ulong2num (ULONG_MAX);
4166 data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data);
4167 CHECK;
4168 data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data);
4169 CHECK;
4170
4171 return SCM_UNSPECIFIED;
4172}
4173#undef FUNC_NAME
4174
1be6b49c 4175#endif
0f2d19dd 4176
0f2d19dd
JB		 4177void
4178scm_init_numbers ()
0f2d19dd 4179{
1be6b49c 4180 abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM);
ac0c002c
DH		 4181 scm_permanent_object (abs_most_negative_fixnum);
4182
a261c0e9
DH		 4183 /* It may be possible to tune the performance of some algorithms by using
4184 * the following constants to avoid the creation of bignums. Please, before
4185 * using these values, remember the two rules of program optimization:
4186 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
86d31dfe
MV		 4187 scm_c_define ("most-positive-fixnum",
4188 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
4189 scm_c_define ("most-negative-fixnum",
4190 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
a261c0e9 4191
f3ae5d60
MD		 4192 scm_add_feature ("complex");
4193 scm_add_feature ("inexact");
5986c47d 4194 scm_flo0 = scm_make_real (0.0);
f872b822 4195#ifdef DBL_DIG
0f2d19dd 4196 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
f872b822 4197#else
0f2d19dd
JB		 4198 { /* determine floating point precision */
4199 double f = 0.1;
f872b822 4200 double fsum = 1.0 + f;
bb628794
DH		 4201 while (fsum != 1.0) {
4202 if (++scm_dblprec > 20) {
4203 fsum = 1.0;
4204 } else {
f872b822 4205 f /= 10.0;
bb628794 4206 fsum = f + 1.0;
f872b822 4207 }
bb628794 4208 }
f872b822 4209 scm_dblprec = scm_dblprec - 1;
0f2d19dd 4210 }
f872b822 4211#endif /* DBL_DIG */
1be6b49c
ML		 4212
4213#ifdef GUILE_DEBUG
4214 check_sanity ();
4215#endif
4216
a0599745 4217#include "libguile/numbers.x"
0f2d19dd 4218}
89e00824
ML		 4219
4220/*
4221 Local Variables:
4222 c-file-style: "gnu"
4223 End:
4224*/
Unnamed repository; edit this file 'description' to name the repository.