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