HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* eval.c (s_bad_slot_number): New static identifier.
[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 \
534c55a9 79 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
ca46fb90
RB		 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
570b6821 131SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 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
570b6821 140SCM_C_INLINE_KEYWORD static SCM
ca46fb90
RB		 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
570b6821 151SCM_C_INLINE_KEYWORD int
ca46fb90
RB		 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
570b6821 161SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 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
570b6821 170SCM_C_INLINE_KEYWORD double
ca46fb90
RB		 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
570b6821 178SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 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),
4d814788 1239 "Return the integer which is the ones-complement of the integer\n"
1e6808ea
MG		 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{
f9811f9f
KR		 1250 if (SCM_INUMP (n)) {
1251 /* No overflow here, just need to toggle all the bits making up the inum.
1252 Enhancement: No need to strip the tag and add it back, could just xor
1253 a block of 1 bits, if that worked with the various debug versions of
1254 the SCM typedef. */
1255 return SCM_MAKINUM (~ SCM_INUM (n));
1256
1257 } else if (SCM_BIGP (n)) {
1258 SCM result = scm_i_mkbig ();
1259 mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
1260 scm_remember_upto_here_1 (n);
1261 return result;
1262
1263 } else {
1264 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
1265 }
0f2d19dd 1266}
1bbd0b84 1267#undef FUNC_NAME
0f2d19dd 1268
a1ec6916 1269SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
2cd04b42 1270 (SCM n, SCM k),
1e6808ea
MG		 1271 "Return @var{n} raised to the non-negative integer exponent\n"
1272 "@var{k}.\n"
1273 "\n"
b380b885
MD		 1274 "@lisp\n"
1275 "(integer-expt 2 5)\n"
1276 " @result{} 32\n"
1277 "(integer-expt -3 3)\n"
1278 " @result{} -27\n"
1279 "@end lisp")
1bbd0b84 1280#define FUNC_NAME s_scm_integer_expt
0f2d19dd 1281{
1c35cb19
RB		 1282 long i2 = 0;
1283 SCM z_i2 = SCM_BOOL_F;
1284 int i2_is_big = 0;
f872b822 1285 SCM acc = SCM_MAKINUM (1L);
ca46fb90 1286
d57ed702 1287 /* 0^0 == 1 according to R5RS */
4260a7fc 1288 if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc))
7b3381f4 1289 return SCM_FALSEP (scm_zero_p(k)) ? n : acc;
4260a7fc
DH		 1290 else if (SCM_EQ_P (n, SCM_MAKINUM (-1L)))
1291 return SCM_FALSEP (scm_even_p (k)) ? n : acc;
ca46fb90 1292
ca46fb90
RB		 1293 if (SCM_INUMP (k))
1294 i2 = SCM_INUM (k);
1295 else if (SCM_BIGP (k))
1296 {
1297 z_i2 = scm_i_clonebig (k, 1);
1298 mpz_init_set (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (k));
1299 scm_remember_upto_here_1 (k);
1300 i2_is_big = 1;
1301 }
1302 else if (SCM_REALP (k))
2830fd91
MD		 1303 {
1304 double r = SCM_REAL_VALUE (k);
ca46fb90
RB		 1305 if (floor (r) != r)
1306 SCM_WRONG_TYPE_ARG (2, k);
1307 if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM))
1308 {
1309 z_i2 = scm_i_mkbig ();
1310 mpz_init_set_d (SCM_I_BIG_MPZ (z_i2), r);
1311 i2_is_big = 1;
1312 }
1313 else
1314 {
1315 i2 = r;
1316 }
2830fd91
MD		 1317 }
1318 else
ca46fb90
RB		 1319 SCM_WRONG_TYPE_ARG (2, k);
1320
1321 if (i2_is_big)
f872b822 1322 {
ca46fb90
RB		 1323 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
1324 {
1325 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
1326 n = scm_divide (n, SCM_UNDEFINED);
1327 }
1328 while (1)
1329 {
1330 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
1331 {
1332 mpz_clear (SCM_I_BIG_MPZ (z_i2));
1333 return acc;
1334 }
1335 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
1336 {
1337 mpz_clear (SCM_I_BIG_MPZ (z_i2));
1338 return scm_product (acc, n);
1339 }
1340 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
1341 acc = scm_product (acc, n);
1342 n = scm_product (n, n);
1343 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
1344 }
f872b822 1345 }
ca46fb90 1346 else
f872b822 1347 {
ca46fb90
RB		 1348 if (i2 < 0)
1349 {
1350 i2 = -i2;
1351 n = scm_divide (n, SCM_UNDEFINED);
1352 }
1353 while (1)
1354 {
1355 if (0 == i2)
1356 return acc;
1357 if (1 == i2)
1358 return scm_product (acc, n);
1359 if (i2 & 1)
1360 acc = scm_product (acc, n);
1361 n = scm_product (n, n);
1362 i2 >>= 1;
1363 }
f872b822 1364 }
0f2d19dd 1365}
1bbd0b84 1366#undef FUNC_NAME
0f2d19dd 1367
a1ec6916 1368SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
1bbd0b84 1369 (SCM n, SCM cnt),
1e6808ea
MG		 1370 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1371 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1372 "means, that the function does not guarantee to keep the bit\n"
1373 "structure of @var{n}, but rather guarantees that the result\n"
1374 "will always be rounded towards minus infinity. Therefore, the\n"
1375 "results of ash and a corresponding bitwise shift will differ if\n"
1376 "@var{n} is negative.\n"
1377 "\n"
3ab9f56e 1378 "Formally, the function returns an integer equivalent to\n"
1e6808ea
MG		 1379 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1380 "\n"
b380b885 1381 "@lisp\n"
1e6808ea
MG		 1382 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1383 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
a3c8b9fc 1384 "@end lisp")
1bbd0b84 1385#define FUNC_NAME s_scm_ash
0f2d19dd 1386{
3ab9f56e
DH		 1387 long bits_to_shift;
1388
3ab9f56e
DH		 1389 SCM_VALIDATE_INUM (2, cnt);
1390
1391 bits_to_shift = SCM_INUM (cnt);
ca46fb90
RB		 1392
1393 if (bits_to_shift < 0)
1394 {
1395 /* Shift right by abs(cnt) bits. This is realized as a division
1396 by div:=2^abs(cnt). However, to guarantee the floor
1397 rounding, negative values require some special treatment.
1398 */
1399 SCM div = scm_integer_expt (SCM_MAKINUM (2),
1400 SCM_MAKINUM (-bits_to_shift));
1401 if (SCM_FALSEP (scm_negative_p (n)))
1402 return scm_quotient (n, div);
1403 else
1404 return scm_sum (SCM_MAKINUM (-1L),
1405 scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div));
1406 }
1407 else
3ab9f56e 1408 /* Shift left is done by multiplication with 2^CNT */
f872b822 1409 return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
0f2d19dd 1410}
1bbd0b84 1411#undef FUNC_NAME
0f2d19dd 1412
3c9f20f8 1413
a1ec6916 1414SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
1bbd0b84 1415 (SCM n, SCM start, SCM end),
1e6808ea
MG		 1416 "Return the integer composed of the @var{start} (inclusive)\n"
1417 "through @var{end} (exclusive) bits of @var{n}. The\n"
1418 "@var{start}th bit becomes the 0-th bit in the result.\n"
1419 "\n"
b380b885
MD		 1420 "@lisp\n"
1421 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1422 " @result{} \"1010\"\n"
1423 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1424 " @result{} \"10110\"\n"
1425 "@end lisp")
1bbd0b84 1426#define FUNC_NAME s_scm_bit_extract
0f2d19dd 1427{
ac0c002c 1428 unsigned long int istart, iend;
34d19ef6 1429 SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart);
c1bfcf60
GB		 1430 SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
1431 SCM_ASSERT_RANGE (3, end, (iend >= istart));
78166ad5 1432
0aacf84e
MD		 1433 if (SCM_INUMP (n))
1434 {
1435 long int in = SCM_INUM (n);
1436 unsigned long int bits = iend - istart;
ac0c002c 1437
0aacf84e
MD		 1438 if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
1439 {
1440 /* Since we emulate two's complement encoded numbers, this
1441 * special case requires us to produce a result that has
1442 * more bits than can be stored in a fixnum. Thus, we fall
1443 * back to the more general algorithm that is used for
1444 * bignums.
1445 */
1446 goto generalcase;
1447 }
ac0c002c 1448
0aacf84e
MD		 1449 if (istart < SCM_I_FIXNUM_BIT)
1450 {
1451 in = in >> istart;
1452 if (bits < SCM_I_FIXNUM_BIT)
1453 return SCM_MAKINUM (in & ((1L << bits) - 1));
1454 else /* we know: in >= 0 */
1455 return SCM_MAKINUM (in);
1456 }
1457 else if (in < 0)
ac0c002c 1458 return SCM_MAKINUM (-1L & ((1L << bits) - 1));
0aacf84e 1459 else
ac0c002c 1460 return SCM_MAKINUM (0);
0aacf84e
MD		 1461 }
1462 else if (SCM_BIGP (n))
ac0c002c 1463 {
0aacf84e
MD		 1464 generalcase:
1465 {
1466 SCM num1 = SCM_MAKINUM (1L);
1467 SCM num2 = SCM_MAKINUM (2L);
1468 SCM bits = SCM_MAKINUM (iend - istart);
1469 SCM mask = scm_difference (scm_integer_expt (num2, bits), num1);
1470 return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
1471 }
ac0c002c 1472 }
0aacf84e 1473 else
78166ad5 1474 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1475}
1bbd0b84 1476#undef FUNC_NAME
0f2d19dd 1477
e4755e5c
JB		 1478static const char scm_logtab[] = {
1479 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1480};
1cc91f1b 1481
a1ec6916 1482SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
1bbd0b84 1483 (SCM n),
1e6808ea
MG		 1484 "Return the number of bits in integer @var{n}. If integer is\n"
1485 "positive, the 1-bits in its binary representation are counted.\n"
1486 "If negative, the 0-bits in its two's-complement binary\n"
1487 "representation are counted. If 0, 0 is returned.\n"
1488 "\n"
b380b885
MD		 1489 "@lisp\n"
1490 "(logcount #b10101010)\n"
ca46fb90
RB		 1491 " @result{} 4\n"
1492 "(logcount 0)\n"
1493 " @result{} 0\n"
1494 "(logcount -2)\n"
1495 " @result{} 1\n"
1496 "@end lisp")
1497#define FUNC_NAME s_scm_logcount
1498{
1499 if (SCM_INUMP (n))
f872b822 1500 {
ca46fb90
RB		 1501 unsigned long int c = 0;
1502 long int nn = SCM_INUM (n);
1503 if (nn < 0)
1504 nn = -1 - nn;
1505 while (nn)
1506 {
1507 c += scm_logtab[15 & nn];
1508 nn >>= 4;
1509 }
1510 return SCM_MAKINUM (c);
f872b822 1511 }
ca46fb90 1512 else if (SCM_BIGP (n))
f872b822 1513 {
ca46fb90 1514 unsigned long count;
713a4259
KR		 1515 if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
1516 count = mpz_popcount (SCM_I_BIG_MPZ (n));
ca46fb90 1517 else
713a4259
KR		 1518 count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
1519 scm_remember_upto_here_1 (n);
ca46fb90 1520 return SCM_MAKINUM (count);
f872b822 1521 }
ca46fb90
RB		 1522 else
1523 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1524}
ca46fb90 1525#undef FUNC_NAME
0f2d19dd
JB		 1526
1527
ca46fb90
RB		 1528static const char scm_ilentab[] = {
1529 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1530};
1531
0f2d19dd 1532
ca46fb90
RB		 1533SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
1534 (SCM n),
1535 "Return the number of bits necessary to represent @var{n}.\n"
1536 "\n"
1537 "@lisp\n"
1538 "(integer-length #b10101010)\n"
1539 " @result{} 8\n"
1540 "(integer-length 0)\n"
1541 " @result{} 0\n"
1542 "(integer-length #b1111)\n"
1543 " @result{} 4\n"
1544 "@end lisp")
1545#define FUNC_NAME s_scm_integer_length
1546{
0aacf84e
MD		 1547 if (SCM_INUMP (n))
1548 {
1549 unsigned long int c = 0;
1550 unsigned int l = 4;
1551 long int nn = SCM_INUM (n);
1552 if (nn < 0)
1553 nn = -1 - nn;
1554 while (nn)
1555 {
1556 c += 4;
1557 l = scm_ilentab [15 & nn];
1558 nn >>= 4;
1559 }
1560 return SCM_MAKINUM (c - 4 + l);
1561 }
1562 else if (SCM_BIGP (n))
1563 {
1564 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1565 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1566 1 too big, so check for that and adjust. */
1567 size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
1568 if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
1569 && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
1570 mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
1571 size--;
1572 scm_remember_upto_here_1 (n);
1573 return SCM_MAKINUM (size);
1574 }
1575 else
ca46fb90 1576 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
ca46fb90
RB		 1577}
1578#undef FUNC_NAME
0f2d19dd
JB		 1579
1580/*** NUMBERS -> STRINGS ***/
0f2d19dd 1581int scm_dblprec;
e4755e5c 1582static const double fx[] =
f872b822
MD		 1583{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1584 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1585 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1586 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
0f2d19dd 1587
1be6b49c 1588static size_t
1bbd0b84 1589idbl2str (double f, char *a)
0f2d19dd
JB		 1590{
1591 int efmt, dpt, d, i, wp = scm_dblprec;
1be6b49c 1592 size_t ch = 0;
0f2d19dd
JB		 1593 int exp = 0;
1594
f872b822 1595 if (f == 0.0)
abb7e44d
MV		 1596 {
1597#ifdef HAVE_COPYSIGN
1598 double sgn = copysign (1.0, f);
1599
1600 if (sgn < 0.0)
1601 a[ch++] = '-';
1602#endif
1603
1604 goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1605 }
7351e207
MV		 1606
1607 if (xisinf (f))
1608 {
1609 if (f < 0)
1610 strcpy (a, "-inf.0");
1611 else
1612 strcpy (a, "+inf.0");
1613 return ch+6;
1614 }
1615 else if (xisnan (f))
1616 {
1617 strcpy (a, "+nan.0");
1618 return ch+6;
1619 }
1620
f872b822
MD		 1621 if (f < 0.0)
1622 {
1623 f = -f;
1624 a[ch++] = '-';
1625 }
7351e207 1626
f872b822
MD		 1627#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1628 make-uniform-vector, from causing infinite loops. */
1629 while (f < 1.0)
1630 {
1631 f *= 10.0;
1632 if (exp-- < DBL_MIN_10_EXP)
7351e207
MV		 1633 {
1634 a[ch++] = '#';
1635 a[ch++] = '.';
1636 a[ch++] = '#';
1637 return ch;
1638 }
f872b822
MD		 1639 }
1640 while (f > 10.0)
1641 {
1642 f *= 0.10;
1643 if (exp++ > DBL_MAX_10_EXP)
7351e207
MV		 1644 {
1645 a[ch++] = '#';
1646 a[ch++] = '.';
1647 a[ch++] = '#';
1648 return ch;
1649 }
f872b822
MD		 1650 }
1651#else
1652 while (f < 1.0)
1653 {
1654 f *= 10.0;
1655 exp--;
1656 }
1657 while (f > 10.0)
1658 {
1659 f /= 10.0;
1660 exp++;
1661 }
1662#endif
1663 if (f + fx[wp] >= 10.0)
1664 {
1665 f = 1.0;
1666 exp++;
1667 }
0f2d19dd 1668 zero:
f872b822
MD		 1669#ifdef ENGNOT
1670 dpt = (exp + 9999) % 3;
0f2d19dd
JB		 1671 exp -= dpt++;
1672 efmt = 1;
f872b822
MD		 1673#else
1674 efmt = (exp < -3) || (exp > wp + 2);
0f2d19dd 1675 if (!efmt)
cda139a7
MD		 1676 {
1677 if (exp < 0)
1678 {
1679 a[ch++] = '0';
1680 a[ch++] = '.';
1681 dpt = exp;
f872b822
MD		 1682 while (++dpt)
1683 a[ch++] = '0';
cda139a7
MD		 1684 }
1685 else
f872b822 1686 dpt = exp + 1;
cda139a7 1687 }
0f2d19dd
JB		 1688 else
1689 dpt = 1;
f872b822
MD		 1690#endif
1691
1692 do
1693 {
1694 d = f;
1695 f -= d;
1696 a[ch++] = d + '0';
1697 if (f < fx[wp])
1698 break;
1699 if (f + fx[wp] >= 1.0)
1700 {
1701 a[ch - 1]++;
1702 break;
1703 }
1704 f *= 10.0;
1705 if (!(--dpt))
1706 a[ch++] = '.';
0f2d19dd 1707 }
f872b822 1708 while (wp--);
0f2d19dd
JB		 1709
1710 if (dpt > 0)
cda139a7 1711 {
f872b822 1712#ifndef ENGNOT
cda139a7
MD		 1713 if ((dpt > 4) && (exp > 6))
1714 {
f872b822 1715 d = (a[0] == '-' ? 2 : 1);
cda139a7 1716 for (i = ch++; i > d; i--)
f872b822 1717 a[i] = a[i - 1];
cda139a7
MD		 1718 a[d] = '.';
1719 efmt = 1;
1720 }
1721 else
f872b822 1722#endif
cda139a7 1723 {
f872b822
MD		 1724 while (--dpt)
1725 a[ch++] = '0';
cda139a7
MD		 1726 a[ch++] = '.';
1727 }
1728 }
f872b822
MD		 1729 if (a[ch - 1] == '.')
1730 a[ch++] = '0'; /* trailing zero */
1731 if (efmt && exp)
1732 {
1733 a[ch++] = 'e';
1734 if (exp < 0)
1735 {
1736 exp = -exp;
1737 a[ch++] = '-';
1738 }
1739 for (i = 10; i <= exp; i *= 10);
1740 for (i /= 10; i; i /= 10)
1741 {
1742 a[ch++] = exp / i + '0';
1743 exp %= i;
1744 }
0f2d19dd 1745 }
0f2d19dd
JB		 1746 return ch;
1747}
1748
1cc91f1b 1749
1be6b49c 1750static size_t
1bbd0b84 1751iflo2str (SCM flt, char *str)
0f2d19dd 1752{
1be6b49c 1753 size_t i;
3c9a524f 1754 if (SCM_REALP (flt))
f3ae5d60 1755 i = idbl2str (SCM_REAL_VALUE (flt), str);
0f2d19dd 1756 else
f872b822 1757 {
f3ae5d60
MD		 1758 i = idbl2str (SCM_COMPLEX_REAL (flt), str);
1759 if (SCM_COMPLEX_IMAG (flt) != 0.0)
1760 {
7351e207
MV		 1761 double imag = SCM_COMPLEX_IMAG (flt);
1762 /* Don't output a '+' for negative numbers or for Inf and
1763 NaN. They will provide their own sign. */
1764 if (0 <= imag && !xisinf (imag) && !xisnan (imag))
f3ae5d60 1765 str[i++] = '+';
7351e207 1766 i += idbl2str (imag, &str[i]);
f3ae5d60
MD		 1767 str[i++] = 'i';
1768 }
f872b822 1769 }
0f2d19dd
JB		 1770 return i;
1771}
0f2d19dd 1772
5c11cc9d 1773/* convert a long to a string (unterminated). returns the number of
1bbd0b84
GB		 1774 characters in the result.
1775 rad is output base
1776 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1be6b49c 1777size_t
1bbd0b84 1778scm_iint2str (long num, int rad, char *p)
0f2d19dd 1779{
1be6b49c
ML		 1780 size_t j = 1;
1781 size_t i;
5c11cc9d
GH		 1782 unsigned long n = (num < 0) ? -num : num;
1783
f872b822 1784 for (n /= rad; n > 0; n /= rad)
5c11cc9d
GH		 1785 j++;
1786
1787 i = j;
1788 if (num < 0)
f872b822 1789 {
f872b822 1790 *p++ = '-';
5c11cc9d
GH		 1791 j++;
1792 n = -num;
f872b822 1793 }
5c11cc9d
GH		 1794 else
1795 n = num;
f872b822
MD		 1796 while (i--)
1797 {
5c11cc9d
GH		 1798 int d = n % rad;
1799
f872b822
MD		 1800 n /= rad;
1801 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
1802 }
0f2d19dd
JB		 1803 return j;
1804}
1805
1806
a1ec6916 1807SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
bb628794
DH		 1808 (SCM n, SCM radix),
1809 "Return a string holding the external representation of the\n"
942e5b91
MG		 1810 "number @var{n} in the given @var{radix}. If @var{n} is\n"
1811 "inexact, a radix of 10 will be used.")
1bbd0b84 1812#define FUNC_NAME s_scm_number_to_string
0f2d19dd 1813{
1bbd0b84 1814 int base;
98cb6e75 1815
0aacf84e 1816 if (SCM_UNBNDP (radix))
98cb6e75 1817 base = 10;
0aacf84e
MD		 1818 else
1819 {
1820 SCM_VALIDATE_INUM (2, radix);
1821 base = SCM_INUM (radix);
1822 /* FIXME: ask if range limit was OK, and if so, document */
1823 SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36));
1824 }
98cb6e75 1825
0aacf84e
MD		 1826 if (SCM_INUMP (n))
1827 {
1828 char num_buf [SCM_INTBUFLEN];
1829 size_t length = scm_iint2str (SCM_INUM (n), base, num_buf);
1830 return scm_mem2string (num_buf, length);
1831 }
1832 else if (SCM_BIGP (n))
1833 {
1834 char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
1835 scm_remember_upto_here_1 (n);
1836 return scm_take0str (str);
1837 }
1838 else if (SCM_INEXACTP (n))
1839 {
1840 char num_buf [FLOBUFLEN];
1841 return scm_mem2string (num_buf, iflo2str (n, num_buf));
1842 }
1843 else
bb628794 1844 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 1845}
1bbd0b84 1846#undef FUNC_NAME
0f2d19dd
JB		 1847
1848
ca46fb90
RB		 1849/* These print routines used to be stubbed here so that scm_repl.c
1850 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1cc91f1b 1851
0f2d19dd 1852int
e81d98ec 1853scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 1854{
56e55ac7 1855 char num_buf[FLOBUFLEN];
f872b822 1856 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
0f2d19dd
JB		 1857 return !0;
1858}
1859
f3ae5d60 1860int
e81d98ec 1861scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
f3ae5d60 1862{
56e55ac7 1863 char num_buf[FLOBUFLEN];
f3ae5d60
MD		 1864 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
1865 return !0;
1866}
1cc91f1b 1867
0f2d19dd 1868int
e81d98ec 1869scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 1870{
ca46fb90
RB		 1871 char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
1872 scm_remember_upto_here_1 (exp);
1873 scm_lfwrite (str, (size_t) strlen (str), port);
1874 free (str);
0f2d19dd
JB		 1875 return !0;
1876}
1877/*** END nums->strs ***/
1878
3c9a524f 1879
0f2d19dd 1880/*** STRINGS -> NUMBERS ***/
2a8fecee 1881
3c9a524f
DH		 1882/* The following functions implement the conversion from strings to numbers.
1883 * The implementation somehow follows the grammar for numbers as it is given
1884 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
1885 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
1886 * points should be noted about the implementation:
1887 * * Each function keeps a local index variable 'idx' that points at the
1888 * current position within the parsed string. The global index is only
1889 * updated if the function could parse the corresponding syntactic unit
1890 * successfully.
1891 * * Similarly, the functions keep track of indicators of inexactness ('#',
1892 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
1893 * global exactness information is only updated after each part has been
1894 * successfully parsed.
1895 * * Sequences of digits are parsed into temporary variables holding fixnums.
1896 * Only if these fixnums would overflow, the result variables are updated
1897 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
1898 * the temporary variables holding the fixnums are cleared, and the process
1899 * starts over again. If for example fixnums were able to store five decimal
1900 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
1901 * and the result was computed as 12345 * 100000 + 67890. In other words,
1902 * only every five digits two bignum operations were performed.
1903 */
1904
1905enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
1906
1907/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
1908
1909/* In non ASCII-style encodings the following macro might not work. */
1910#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
1911
2a8fecee 1912static SCM
3c9a524f
DH		 1913mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
1914 unsigned int radix, enum t_exactness *p_exactness)
2a8fecee 1915{
3c9a524f
DH		 1916 unsigned int idx = *p_idx;
1917 unsigned int hash_seen = 0;
1918 scm_t_bits shift = 1;
1919 scm_t_bits add = 0;
1920 unsigned int digit_value;
1921 SCM result;
1922 char c;
1923
1924 if (idx == len)
1925 return SCM_BOOL_F;
2a8fecee 1926
3c9a524f
DH		 1927 c = mem[idx];
1928 if (!isxdigit (c))
1929 return SCM_BOOL_F;
1930 digit_value = XDIGIT2UINT (c);
1931 if (digit_value >= radix)
1932 return SCM_BOOL_F;
1933
1934 idx++;
1935 result = SCM_MAKINUM (digit_value);
1936 while (idx != len)
f872b822 1937 {
3c9a524f
DH		 1938 char c = mem[idx];
1939 if (isxdigit (c))
f872b822 1940 {
3c9a524f 1941 if (hash_seen)
1fe5e088 1942 break;
3c9a524f
DH		 1943 digit_value = XDIGIT2UINT (c);
1944 if (digit_value >= radix)
1fe5e088 1945 break;
f872b822 1946 }
3c9a524f
DH		 1947 else if (c == '#')
1948 {
1949 hash_seen = 1;
1950 digit_value = 0;
1951 }
1952 else
1953 break;
1954
1955 idx++;
1956 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
1957 {
1958 result = scm_product (result, SCM_MAKINUM (shift));
1959 if (add > 0)
1960 result = scm_sum (result, SCM_MAKINUM (add));
1961
1962 shift = radix;
1963 add = digit_value;
1964 }
1965 else
1966 {
1967 shift = shift * radix;
1968 add = add * radix + digit_value;
1969 }
1970 };
1971
1972 if (shift > 1)
1973 result = scm_product (result, SCM_MAKINUM (shift));
1974 if (add > 0)
1975 result = scm_sum (result, SCM_MAKINUM (add));
1976
1977 *p_idx = idx;
1978 if (hash_seen)
1979 *p_exactness = INEXACT;
1980
1981 return result;
2a8fecee
JB		 1982}
1983
1984
3c9a524f
DH		 1985/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
1986 * covers the parts of the rules that start at a potential point. The value
1987 * of the digits up to the point have been parsed by the caller and are given
79d34f68
DH		 1988 * in variable result. The content of *p_exactness indicates, whether a hash
1989 * has already been seen in the digits before the point.
3c9a524f 1990 */
1cc91f1b 1991
3c9a524f
DH		 1992/* In non ASCII-style encodings the following macro might not work. */
1993#define DIGIT2UINT(d) ((d) - '0')
1994
1995static SCM
79d34f68 1996mem2decimal_from_point (SCM result, const char* mem, size_t len,
3c9a524f 1997 unsigned int *p_idx, enum t_exactness *p_exactness)
0f2d19dd 1998{
3c9a524f
DH		 1999 unsigned int idx = *p_idx;
2000 enum t_exactness x = *p_exactness;
3c9a524f
DH		 2001
2002 if (idx == len)
79d34f68 2003 return result;
3c9a524f
DH		 2004
2005 if (mem[idx] == '.')
2006 {
2007 scm_t_bits shift = 1;
2008 scm_t_bits add = 0;
2009 unsigned int digit_value;
79d34f68 2010 SCM big_shift = SCM_MAKINUM (1);
3c9a524f
DH		 2011
2012 idx++;
2013 while (idx != len)
2014 {
2015 char c = mem[idx];
2016 if (isdigit (c))
2017 {
2018 if (x == INEXACT)
2019 return SCM_BOOL_F;
2020 else
2021 digit_value = DIGIT2UINT (c);
2022 }
2023 else if (c == '#')
2024 {
2025 x = INEXACT;
2026 digit_value = 0;
2027 }
2028 else
2029 break;
2030
2031 idx++;
2032 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
2033 {
2034 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68 2035 result = scm_product (result, SCM_MAKINUM (shift));
3c9a524f 2036 if (add > 0)
79d34f68 2037 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2038
2039 shift = 10;
2040 add = digit_value;
2041 }
2042 else
2043 {
2044 shift = shift * 10;
2045 add = add * 10 + digit_value;
2046 }
2047 };
2048
2049 if (add > 0)
2050 {
2051 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68
DH		 2052 result = scm_product (result, SCM_MAKINUM (shift));
2053 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2054 }
2055
79d34f68
DH		 2056 result = scm_divide (result, big_shift);
2057
3c9a524f
DH		 2058 /* We've seen a decimal point, thus the value is implicitly inexact. */
2059 x = INEXACT;
f872b822 2060 }
3c9a524f 2061
3c9a524f 2062 if (idx != len)
f872b822 2063 {
3c9a524f
DH		 2064 int sign = 1;
2065 unsigned int start;
2066 char c;
2067 int exponent;
2068 SCM e;
2069
2070 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2071
2072 switch (mem[idx])
f872b822 2073 {
3c9a524f
DH		 2074 case 'd': case 'D':
2075 case 'e': case 'E':
2076 case 'f': case 'F':
2077 case 'l': case 'L':
2078 case 's': case 'S':
2079 idx++;
2080 start = idx;
2081 c = mem[idx];
2082 if (c == '-')
2083 {
2084 idx++;
2085 sign = -1;
2086 c = mem[idx];
2087 }
2088 else if (c == '+')
2089 {
2090 idx++;
2091 sign = 1;
2092 c = mem[idx];
2093 }
2094 else
2095 sign = 1;
2096
2097 if (!isdigit (c))
2098 return SCM_BOOL_F;
2099
2100 idx++;
2101 exponent = DIGIT2UINT (c);
2102 while (idx != len)
f872b822 2103 {
3c9a524f
DH		 2104 char c = mem[idx];
2105 if (isdigit (c))
2106 {
2107 idx++;
2108 if (exponent <= SCM_MAXEXP)
2109 exponent = exponent * 10 + DIGIT2UINT (c);
2110 }
2111 else
2112 break;
f872b822 2113 }
3c9a524f
DH		 2114
2115 if (exponent > SCM_MAXEXP)
f872b822 2116 {
3c9a524f
DH		 2117 size_t exp_len = idx - start;
2118 SCM exp_string = scm_mem2string (&mem[start], exp_len);
2119 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
2120 scm_out_of_range ("string->number", exp_num);
f872b822 2121 }
3c9a524f
DH		 2122
2123 e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent));
2124 if (sign == 1)
2125 result = scm_product (result, e);
2126 else
2127 result = scm_divide (result, e);
2128
2129 /* We've seen an exponent, thus the value is implicitly inexact. */
2130 x = INEXACT;
2131
f872b822 2132 break;
3c9a524f 2133
f872b822 2134 default:
3c9a524f 2135 break;
f872b822 2136 }
0f2d19dd 2137 }
3c9a524f
DH		 2138
2139 *p_idx = idx;
2140 if (x == INEXACT)
2141 *p_exactness = x;
2142
2143 return result;
0f2d19dd 2144}
0f2d19dd 2145
3c9a524f
DH		 2146
2147/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2148
2149static SCM
2150mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
2151 unsigned int radix, enum t_exactness *p_exactness)
0f2d19dd 2152{
3c9a524f 2153 unsigned int idx = *p_idx;
164d2481 2154 SCM result;
3c9a524f
DH		 2155
2156 if (idx == len)
2157 return SCM_BOOL_F;
2158
7351e207
MV		 2159 if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
2160 {
2161 *p_idx = idx+5;
2162 return scm_inf ();
2163 }
2164
2165 if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
2166 {
2167 enum t_exactness x = EXACT;
2168
2169 /* Cobble up the fraction. We might want to set the NaN's
2170 mantissa from it. */
2171 idx += 4;
2172 mem2uinteger (mem, len, &idx, 10, &x);
2173 *p_idx = idx;
2174 return scm_nan ();
2175 }
2176
3c9a524f
DH		 2177 if (mem[idx] == '.')
2178 {
2179 if (radix != 10)
2180 return SCM_BOOL_F;
2181 else if (idx + 1 == len)
2182 return SCM_BOOL_F;
2183 else if (!isdigit (mem[idx + 1]))
2184 return SCM_BOOL_F;
2185 else
164d2481
MV		 2186 result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
2187 p_idx, p_exactness);
f872b822 2188 }
3c9a524f
DH		 2189 else
2190 {
2191 enum t_exactness x = EXACT;
2192 SCM uinteger;
3c9a524f
DH		 2193
2194 uinteger = mem2uinteger (mem, len, &idx, radix, &x);
2195 if (SCM_FALSEP (uinteger))
2196 return SCM_BOOL_F;
2197
2198 if (idx == len)
2199 result = uinteger;
2200 else if (mem[idx] == '/')
f872b822 2201 {
3c9a524f
DH		 2202 SCM divisor;
2203
2204 idx++;
2205
2206 divisor = mem2uinteger (mem, len, &idx, radix, &x);
2207 if (SCM_FALSEP (divisor))
2208 return SCM_BOOL_F;
2209
2210 result = scm_divide (uinteger, divisor);
f872b822 2211 }
3c9a524f
DH		 2212 else if (radix == 10)
2213 {
2214 result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
2215 if (SCM_FALSEP (result))
2216 return SCM_BOOL_F;
2217 }
2218 else
2219 result = uinteger;
2220
2221 *p_idx = idx;
2222 if (x == INEXACT)
2223 *p_exactness = x;
f872b822 2224 }
164d2481
MV		 2225
2226 /* When returning an inexact zero, make sure it is represented as a
2227 floating point value so that we can change its sign.
2228 */
2229 if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT)
2230 result = scm_make_real (0.0);
2231
2232 return result;
3c9a524f 2233}
0f2d19dd 2234
0f2d19dd 2235
3c9a524f 2236/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
0f2d19dd 2237
3c9a524f
DH		 2238static SCM
2239mem2complex (const char* mem, size_t len, unsigned int idx,
2240 unsigned int radix, enum t_exactness *p_exactness)
2241{
2242 char c;
2243 int sign = 0;
2244 SCM ureal;
2245
2246 if (idx == len)
2247 return SCM_BOOL_F;
2248
2249 c = mem[idx];
2250 if (c == '+')
2251 {
2252 idx++;
2253 sign = 1;
2254 }
2255 else if (c == '-')
2256 {
2257 idx++;
2258 sign = -1;
0f2d19dd 2259 }
0f2d19dd 2260
3c9a524f
DH		 2261 if (idx == len)
2262 return SCM_BOOL_F;
2263
2264 ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
2265 if (SCM_FALSEP (ureal))
f872b822 2266 {
3c9a524f
DH		 2267 /* input must be either +i or -i */
2268
2269 if (sign == 0)
2270 return SCM_BOOL_F;
2271
2272 if (mem[idx] == 'i' || mem[idx] == 'I')
f872b822 2273 {
3c9a524f
DH		 2274 idx++;
2275 if (idx != len)
2276 return SCM_BOOL_F;
2277
2278 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign));
f872b822 2279 }
3c9a524f
DH		 2280 else
2281 return SCM_BOOL_F;
0f2d19dd 2282 }
3c9a524f
DH		 2283 else
2284 {
fc194577 2285 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f 2286 ureal = scm_difference (ureal, SCM_UNDEFINED);
f872b822 2287
3c9a524f
DH		 2288 if (idx == len)
2289 return ureal;
2290
2291 c = mem[idx];
2292 switch (c)
f872b822 2293 {
3c9a524f
DH		 2294 case 'i': case 'I':
2295 /* either +<ureal>i or -<ureal>i */
2296
2297 idx++;
2298 if (sign == 0)
2299 return SCM_BOOL_F;
2300 if (idx != len)
2301 return SCM_BOOL_F;
2302 return scm_make_rectangular (SCM_MAKINUM (0), ureal);
2303
2304 case '@':
2305 /* polar input: <real>@<real>. */
2306
2307 idx++;
2308 if (idx == len)
2309 return SCM_BOOL_F;
2310 else
f872b822 2311 {
3c9a524f
DH		 2312 int sign;
2313 SCM angle;
2314 SCM result;
2315
2316 c = mem[idx];
2317 if (c == '+')
2318 {
2319 idx++;
2320 sign = 1;
2321 }
2322 else if (c == '-')
2323 {
2324 idx++;
2325 sign = -1;
2326 }
2327 else
2328 sign = 1;
2329
2330 angle = mem2ureal (mem, len, &idx, radix, p_exactness);
2331 if (SCM_FALSEP (angle))
2332 return SCM_BOOL_F;
2333 if (idx != len)
2334 return SCM_BOOL_F;
2335
fc194577 2336 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f
DH		 2337 angle = scm_difference (angle, SCM_UNDEFINED);
2338
2339 result = scm_make_polar (ureal, angle);
2340 return result;
f872b822 2341 }
3c9a524f
DH		 2342 case '+':
2343 case '-':
2344 /* expecting input matching <real>[+-]<ureal>?i */
0f2d19dd 2345
3c9a524f
DH		 2346 idx++;
2347 if (idx == len)
2348 return SCM_BOOL_F;
2349 else
2350 {
2351 int sign = (c == '+') ? 1 : -1;
2352 SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
0f2d19dd 2353
3c9a524f
DH		 2354 if (SCM_FALSEP (imag))
2355 imag = SCM_MAKINUM (sign);
fc194577 2356 else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
1fe5e088 2357 imag = scm_difference (imag, SCM_UNDEFINED);
0f2d19dd 2358
3c9a524f
DH		 2359 if (idx == len)
2360 return SCM_BOOL_F;
2361 if (mem[idx] != 'i' && mem[idx] != 'I')
2362 return SCM_BOOL_F;
0f2d19dd 2363
3c9a524f
DH		 2364 idx++;
2365 if (idx != len)
2366 return SCM_BOOL_F;
0f2d19dd 2367
1fe5e088 2368 return scm_make_rectangular (ureal, imag);
3c9a524f
DH		 2369 }
2370 default:
2371 return SCM_BOOL_F;
2372 }
2373 }
0f2d19dd 2374}
0f2d19dd
JB		 2375
2376
3c9a524f
DH		 2377/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2378
2379enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
1cc91f1b 2380
0f2d19dd 2381SCM
3c9a524f 2382scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix)
0f2d19dd 2383{
3c9a524f
DH		 2384 unsigned int idx = 0;
2385 unsigned int radix = NO_RADIX;
2386 enum t_exactness forced_x = NO_EXACTNESS;
2387 enum t_exactness implicit_x = EXACT;
2388 SCM result;
2389
2390 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2391 while (idx + 2 < len && mem[idx] == '#')
2392 {
2393 switch (mem[idx + 1])
2394 {
2395 case 'b': case 'B':
2396 if (radix != NO_RADIX)
2397 return SCM_BOOL_F;
2398 radix = DUAL;
2399 break;
2400 case 'd': case 'D':
2401 if (radix != NO_RADIX)
2402 return SCM_BOOL_F;
2403 radix = DEC;
2404 break;
2405 case 'i': case 'I':
2406 if (forced_x != NO_EXACTNESS)
2407 return SCM_BOOL_F;
2408 forced_x = INEXACT;
2409 break;
2410 case 'e': case 'E':
2411 if (forced_x != NO_EXACTNESS)
2412 return SCM_BOOL_F;
2413 forced_x = EXACT;
2414 break;
2415 case 'o': case 'O':
2416 if (radix != NO_RADIX)
2417 return SCM_BOOL_F;
2418 radix = OCT;
2419 break;
2420 case 'x': case 'X':
2421 if (radix != NO_RADIX)
2422 return SCM_BOOL_F;
2423 radix = HEX;
2424 break;
2425 default:
f872b822 2426 return SCM_BOOL_F;
3c9a524f
DH		 2427 }
2428 idx += 2;
2429 }
2430
2431 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2432 if (radix == NO_RADIX)
2433 result = mem2complex (mem, len, idx, default_radix, &implicit_x);
2434 else
2435 result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
2436
2437 if (SCM_FALSEP (result))
2438 return SCM_BOOL_F;
f872b822 2439
3c9a524f 2440 switch (forced_x)
f872b822 2441 {
3c9a524f
DH		 2442 case EXACT:
2443 if (SCM_INEXACTP (result))
2444 /* FIXME: This may change the value. */
2445 return scm_inexact_to_exact (result);
2446 else
2447 return result;
2448 case INEXACT:
2449 if (SCM_INEXACTP (result))
2450 return result;
2451 else
2452 return scm_exact_to_inexact (result);
2453 case NO_EXACTNESS:
2454 default:
2455 if (implicit_x == INEXACT)
2456 {
2457 if (SCM_INEXACTP (result))
2458 return result;
2459 else
2460 return scm_exact_to_inexact (result);
2461 }
2462 else
2463 return result;
f872b822 2464 }
0f2d19dd
JB		 2465}
2466
2467
a1ec6916 2468SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
bb628794 2469 (SCM string, SCM radix),
1e6808ea 2470 "Return a number of the maximally precise representation\n"
942e5b91 2471 "expressed by the given @var{string}. @var{radix} must be an\n"
5352393c
MG		 2472 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2473 "is a default radix that may be overridden by an explicit radix\n"
2474 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2475 "supplied, then the default radix is 10. If string is not a\n"
2476 "syntactically valid notation for a number, then\n"
2477 "@code{string->number} returns @code{#f}.")
1bbd0b84 2478#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 2479{
2480 SCM answer;
1bbd0b84 2481 int base;
a6d9e5ab 2482 SCM_VALIDATE_STRING (1, string);
34d19ef6 2483 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base);
3c9a524f
DH		 2484 answer = scm_i_mem2number (SCM_STRING_CHARS (string),
2485 SCM_STRING_LENGTH (string),
2486 base);
bb628794 2487 return scm_return_first (answer, string);
0f2d19dd 2488}
1bbd0b84 2489#undef FUNC_NAME
3c9a524f
DH		 2490
2491
0f2d19dd
JB		 2492/*** END strs->nums ***/
2493
5986c47d 2494
0f2d19dd 2495SCM
f3ae5d60 2496scm_make_real (double x)
0f2d19dd 2497{
3553e1d1
GH		 2498 SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
2499
3a9809df 2500 SCM_REAL_VALUE (z) = x;
0f2d19dd
JB		 2501 return z;
2502}
0f2d19dd 2503
5986c47d 2504
f3ae5d60
MD		 2505SCM
2506scm_make_complex (double x, double y)
2507{
0aacf84e 2508 if (y == 0.0)
3a9809df 2509 return scm_make_real (x);
0aacf84e
MD		 2510 else
2511 {
2512 SCM z;
29c4382a 2513 SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
0aacf84e
MD		 2514 "complex"));
2515 SCM_COMPLEX_REAL (z) = x;
2516 SCM_COMPLEX_IMAG (z) = y;
2517 return z;
2518 }
f3ae5d60 2519}
1cc91f1b 2520
5986c47d 2521
0f2d19dd 2522SCM
1bbd0b84 2523scm_bigequal (SCM x, SCM y)
0f2d19dd 2524{
47ae1f0e 2525 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
ca46fb90
RB		 2526 scm_remember_upto_here_2 (x, y);
2527 return SCM_BOOL (0 == result);
0f2d19dd
JB		 2528}
2529
0f2d19dd 2530SCM
f3ae5d60 2531scm_real_equalp (SCM x, SCM y)
0f2d19dd 2532{
f3ae5d60 2533 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
0f2d19dd
JB		 2534}
2535
f3ae5d60
MD		 2536SCM
2537scm_complex_equalp (SCM x, SCM y)
2538{
2539 return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
2540 && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
2541}
0f2d19dd
JB		 2542
2543
2544
1bbd0b84 2545SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
942e5b91
MG		 2546/* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2547 * "else. Note that the sets of complex, real, rational and\n"
2548 * "integer values form subsets of the set of numbers, i. e. the\n"
2549 * "predicate will be fulfilled for any number."
2550 */
a1ec6916 2551SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0,
1bbd0b84 2552 (SCM x),
942e5b91 2553 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
bb2c02f2 2554 "otherwise. Note that the sets of real, rational and integer\n"
942e5b91
MG		 2555 "values form subsets of the set of complex numbers, i. e. the\n"
2556 "predicate will also be fulfilled if @var{x} is a real,\n"
2557 "rational or integer number.")
1bbd0b84 2558#define FUNC_NAME s_scm_number_p
0f2d19dd 2559{
bb628794 2560 return SCM_BOOL (SCM_NUMBERP (x));
0f2d19dd 2561}
1bbd0b84 2562#undef FUNC_NAME
0f2d19dd
JB		 2563
2564
1bbd0b84 2565SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p);
942e5b91
MG		 2566/* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2567 * "Note that the sets of integer and rational values form a subset\n"
2568 * "of the set of real numbers, i. e. the predicate will also\n"
2569 * "be fulfilled if @var{x} is an integer or a rational number."
2570 */
a1ec6916 2571SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0,
1bbd0b84 2572 (SCM x),
942e5b91 2573 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
bb2c02f2 2574 "otherwise. Note that the set of integer values forms a subset of\n"
942e5b91
MG		 2575 "the set of rational numbers, i. e. the predicate will also be\n"
2576 "fulfilled if @var{x} is an integer number. Real numbers\n"
2577 "will also satisfy this predicate, because of their limited\n"
2578 "precision.")
1bbd0b84 2579#define FUNC_NAME s_scm_real_p
0f2d19dd 2580{
0aacf84e 2581 if (SCM_INUMP (x))
0f2d19dd 2582 return SCM_BOOL_T;
0aacf84e 2583 else if (SCM_IMP (x))
0f2d19dd 2584 return SCM_BOOL_F;
0aacf84e 2585 else if (SCM_REALP (x))
0f2d19dd 2586 return SCM_BOOL_T;
0aacf84e 2587 else if (SCM_BIGP (x))
0f2d19dd 2588 return SCM_BOOL_T;
0aacf84e 2589 else
bb628794 2590 return SCM_BOOL_F;
0f2d19dd 2591}
1bbd0b84 2592#undef FUNC_NAME
0f2d19dd
JB		 2593
2594
a1ec6916 2595SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
1bbd0b84 2596 (SCM x),
942e5b91
MG		 2597 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2598 "else.")
1bbd0b84 2599#define FUNC_NAME s_scm_integer_p
0f2d19dd
JB		 2600{
2601 double r;
f872b822
MD		 2602 if (SCM_INUMP (x))
2603 return SCM_BOOL_T;
2604 if (SCM_IMP (x))
2605 return SCM_BOOL_F;
f872b822
MD		 2606 if (SCM_BIGP (x))
2607 return SCM_BOOL_T;
3c9a524f 2608 if (!SCM_INEXACTP (x))
f872b822 2609 return SCM_BOOL_F;
3c9a524f 2610 if (SCM_COMPLEXP (x))
f872b822 2611 return SCM_BOOL_F;
5986c47d 2612 r = SCM_REAL_VALUE (x);
f872b822
MD		 2613 if (r == floor (r))
2614 return SCM_BOOL_T;
0f2d19dd
JB		 2615 return SCM_BOOL_F;
2616}
1bbd0b84 2617#undef FUNC_NAME
0f2d19dd
JB		 2618
2619
a1ec6916 2620SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
1bbd0b84 2621 (SCM x),
942e5b91
MG		 2622 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2623 "else.")
1bbd0b84 2624#define FUNC_NAME s_scm_inexact_p
0f2d19dd 2625{
f4c627b3 2626 return SCM_BOOL (SCM_INEXACTP (x));
0f2d19dd 2627}
1bbd0b84 2628#undef FUNC_NAME
0f2d19dd
JB		 2629
2630
152f82bf 2631SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
942e5b91 2632/* "Return @code{#t} if all parameters are numerically equal." */
0f2d19dd 2633SCM
6e8d25a6 2634scm_num_eq_p (SCM x, SCM y)
0f2d19dd 2635{
0aacf84e
MD		 2636 if (SCM_INUMP (x))
2637 {
2638 long xx = SCM_INUM (x);
2639 if (SCM_INUMP (y))
2640 {
2641 long yy = SCM_INUM (y);
2642 return SCM_BOOL (xx == yy);
2643 }
2644 else if (SCM_BIGP (y))
2645 return SCM_BOOL_F;
2646 else if (SCM_REALP (y))
2647 return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));
2648 else if (SCM_COMPLEXP (y))
2649 return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))
2650 && (0.0 == SCM_COMPLEX_IMAG (y)));
2651 else
2652 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2653 }
0aacf84e
MD		 2654 else if (SCM_BIGP (x))
2655 {
2656 if (SCM_INUMP (y))
2657 return SCM_BOOL_F;
2658 else if (SCM_BIGP (y))
2659 {
2660 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2661 scm_remember_upto_here_2 (x, y);
2662 return SCM_BOOL (0 == cmp);
2663 }
2664 else if (SCM_REALP (y))
2665 {
2666 int cmp;
2667 if (xisnan (SCM_REAL_VALUE (y)))
2668 return SCM_BOOL_F;
2669 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2670 scm_remember_upto_here_1 (x);
2671 return SCM_BOOL (0 == cmp);
2672 }
2673 else if (SCM_COMPLEXP (y))
2674 {
2675 int cmp;
2676 if (0.0 != SCM_COMPLEX_IMAG (y))
2677 return SCM_BOOL_F;
2678 if (xisnan (SCM_COMPLEX_REAL (y)))
2679 return SCM_BOOL_F;
2680 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
2681 scm_remember_upto_here_1 (x);
2682 return SCM_BOOL (0 == cmp);
2683 }
2684 else
2685 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 2686 }
0aacf84e
MD		 2687 else if (SCM_REALP (x))
2688 {
2689 if (SCM_INUMP (y))
2690 return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));
2691 else if (SCM_BIGP (y))
2692 {
2693 int cmp;
2694 if (xisnan (SCM_REAL_VALUE (x)))
2695 return SCM_BOOL_F;
2696 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2697 scm_remember_upto_here_1 (y);
2698 return SCM_BOOL (0 == cmp);
2699 }
2700 else if (SCM_REALP (y))
2701 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
2702 else if (SCM_COMPLEXP (y))
2703 return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
2704 && (0.0 == SCM_COMPLEX_IMAG (y)));
2705 else
2706 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2707 }
0aacf84e
MD		 2708 else if (SCM_COMPLEXP (x))
2709 {
2710 if (SCM_INUMP (y))
2711 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))
2712 && (SCM_COMPLEX_IMAG (x) == 0.0));
2713 else if (SCM_BIGP (y))
2714 {
2715 int cmp;
2716 if (0.0 != SCM_COMPLEX_IMAG (x))
2717 return SCM_BOOL_F;
2718 if (xisnan (SCM_COMPLEX_REAL (x)))
2719 return SCM_BOOL_F;
2720 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
2721 scm_remember_upto_here_1 (y);
2722 return SCM_BOOL (0 == cmp);
2723 }
2724 else if (SCM_REALP (y))
2725 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
2726 && (SCM_COMPLEX_IMAG (x) == 0.0));
2727 else if (SCM_COMPLEXP (y))
2728 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
2729 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
2730 else
2731 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 2732 }
0aacf84e 2733 else
f4c627b3 2734 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
0f2d19dd
JB		 2735}
2736
2737
152f82bf 2738SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
942e5b91
MG		 2739/* "Return @code{#t} if the list of parameters is monotonically\n"
2740 * "increasing."
2741 */
0f2d19dd 2742SCM
6e8d25a6 2743scm_less_p (SCM x, SCM y)
0f2d19dd 2744{
0aacf84e
MD		 2745 if (SCM_INUMP (x))
2746 {
2747 long xx = SCM_INUM (x);
2748 if (SCM_INUMP (y))
2749 {
2750 long yy = SCM_INUM (y);
2751 return SCM_BOOL (xx < yy);
2752 }
2753 else if (SCM_BIGP (y))
2754 {
2755 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2756 scm_remember_upto_here_1 (y);
2757 return SCM_BOOL (sgn > 0);
2758 }
2759 else if (SCM_REALP (y))
2760 return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
2761 else
2762 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2763 }
0aacf84e
MD		 2764 else if (SCM_BIGP (x))
2765 {
2766 if (SCM_INUMP (y))
2767 {
2768 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2769 scm_remember_upto_here_1 (x);
2770 return SCM_BOOL (sgn < 0);
2771 }
2772 else if (SCM_BIGP (y))
2773 {
2774 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2775 scm_remember_upto_here_2 (x, y);
2776 return SCM_BOOL (cmp < 0);
2777 }
2778 else if (SCM_REALP (y))
2779 {
2780 int cmp;
2781 if (xisnan (SCM_REAL_VALUE (y)))
2782 return SCM_BOOL_F;
2783 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2784 scm_remember_upto_here_1 (x);
2785 return SCM_BOOL (cmp < 0);
2786 }
2787 else
2788 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f4c627b3 2789 }
0aacf84e
MD		 2790 else if (SCM_REALP (x))
2791 {
2792 if (SCM_INUMP (y))
2793 return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));
2794 else if (SCM_BIGP (y))
2795 {
2796 int cmp;
2797 if (xisnan (SCM_REAL_VALUE (x)))
2798 return SCM_BOOL_F;
2799 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2800 scm_remember_upto_here_1 (y);
2801 return SCM_BOOL (cmp > 0);
2802 }
2803 else if (SCM_REALP (y))
2804 return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
2805 else
2806 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2807 }
0aacf84e 2808 else
f4c627b3 2809 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
0f2d19dd
JB		 2810}
2811
2812
c76b1eaf 2813SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
942e5b91
MG		 2814/* "Return @code{#t} if the list of parameters is monotonically\n"
2815 * "decreasing."
c76b1eaf 2816 */
1bbd0b84 2817#define FUNC_NAME s_scm_gr_p
c76b1eaf
MD		 2818SCM
2819scm_gr_p (SCM x, SCM y)
0f2d19dd 2820{
c76b1eaf
MD		 2821 if (!SCM_NUMBERP (x))
2822 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
2823 else if (!SCM_NUMBERP (y))
2824 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
2825 else
2826 return scm_less_p (y, x);
0f2d19dd 2827}
1bbd0b84 2828#undef FUNC_NAME
0f2d19dd
JB		 2829
2830
c76b1eaf 2831SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
942e5b91 2832/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 2833 * "non-decreasing."
2834 */
1bbd0b84 2835#define FUNC_NAME s_scm_leq_p
c76b1eaf
MD		 2836SCM
2837scm_leq_p (SCM x, SCM y)
0f2d19dd 2838{
c76b1eaf
MD		 2839 if (!SCM_NUMBERP (x))
2840 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
2841 else if (!SCM_NUMBERP (y))
2842 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 2843 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
2844 return SCM_BOOL_F;
c76b1eaf
MD		 2845 else
2846 return SCM_BOOL_NOT (scm_less_p (y, x));
0f2d19dd 2847}
1bbd0b84 2848#undef FUNC_NAME
0f2d19dd
JB		 2849
2850
c76b1eaf 2851SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
942e5b91 2852/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 2853 * "non-increasing."
2854 */
1bbd0b84 2855#define FUNC_NAME s_scm_geq_p
c76b1eaf
MD		 2856SCM
2857scm_geq_p (SCM x, SCM y)
0f2d19dd 2858{
c76b1eaf
MD		 2859 if (!SCM_NUMBERP (x))
2860 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
2861 else if (!SCM_NUMBERP (y))
2862 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 2863 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
2864 return SCM_BOOL_F;
c76b1eaf 2865 else
fc194577 2866 return SCM_BOOL_NOT (scm_less_p (x, y));
0f2d19dd 2867}
1bbd0b84 2868#undef FUNC_NAME
0f2d19dd
JB		 2869
2870
152f82bf 2871SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
942e5b91
MG		 2872/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
2873 * "zero."
2874 */
0f2d19dd 2875SCM
6e8d25a6 2876scm_zero_p (SCM z)
0f2d19dd 2877{
0aacf84e 2878 if (SCM_INUMP (z))
c2ff8ab0 2879 return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));
0aacf84e 2880 else if (SCM_BIGP (z))
c2ff8ab0 2881 return SCM_BOOL_F;
0aacf84e 2882 else if (SCM_REALP (z))
c2ff8ab0 2883 return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);
0aacf84e 2884 else if (SCM_COMPLEXP (z))
c2ff8ab0
DH		 2885 return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0
2886 && SCM_COMPLEX_IMAG (z) == 0.0);
0aacf84e 2887 else
c2ff8ab0 2888 SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
0f2d19dd
JB		 2889}
2890
2891
152f82bf 2892SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
942e5b91
MG		 2893/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
2894 * "zero."
2895 */
0f2d19dd 2896SCM
6e8d25a6 2897scm_positive_p (SCM x)
0f2d19dd 2898{
0aacf84e 2899 if (SCM_INUMP (x))
c2ff8ab0 2900 return SCM_BOOL (SCM_INUM (x) > 0);
0aacf84e
MD		 2901 else if (SCM_BIGP (x))
2902 {
2903 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2904 scm_remember_upto_here_1 (x);
2905 return SCM_BOOL (sgn > 0);
2906 }
2907 else if (SCM_REALP (x))
c2ff8ab0 2908 return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);
0aacf84e 2909 else
c2ff8ab0 2910 SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
0f2d19dd
JB		 2911}
2912
2913
152f82bf 2914SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
942e5b91
MG		 2915/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
2916 * "zero."
2917 */
0f2d19dd 2918SCM
6e8d25a6 2919scm_negative_p (SCM x)
0f2d19dd 2920{
0aacf84e 2921 if (SCM_INUMP (x))
c2ff8ab0 2922 return SCM_BOOL (SCM_INUM (x) < 0);
0aacf84e
MD		 2923 else if (SCM_BIGP (x))
2924 {
2925 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2926 scm_remember_upto_here_1 (x);
2927 return SCM_BOOL (sgn < 0);
2928 }
2929 else if (SCM_REALP (x))
c2ff8ab0 2930 return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);
0aacf84e 2931 else
c2ff8ab0 2932 SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
0f2d19dd
JB		 2933}
2934
2935
9de33deb 2936SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
942e5b91
MG		 2937/* "Return the maximum of all parameter values."
2938 */
0f2d19dd 2939SCM
6e8d25a6 2940scm_max (SCM x, SCM y)
0f2d19dd 2941{
0aacf84e
MD		 2942 if (SCM_UNBNDP (y))
2943 {
2944 if (SCM_UNBNDP (x))
2945 SCM_WTA_DISPATCH_0 (g_max, s_max);
2946 else if (SCM_NUMBERP (x))
2947 return x;
2948 else
2949 SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
f872b822 2950 }
f4c627b3 2951
0aacf84e
MD		 2952 if (SCM_INUMP (x))
2953 {
2954 long xx = SCM_INUM (x);
2955 if (SCM_INUMP (y))
2956 {
2957 long yy = SCM_INUM (y);
2958 return (xx < yy) ? y : x;
2959 }
2960 else if (SCM_BIGP (y))
2961 {
2962 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
2963 scm_remember_upto_here_1 (y);
2964 return (sgn < 0) ? x : y;
2965 }
2966 else if (SCM_REALP (y))
2967 {
2968 double z = xx;
2969 /* if y==NaN then ">" is false and we return NaN */
2970 return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
2971 }
2972 else
2973 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 2974 }
0aacf84e
MD		 2975 else if (SCM_BIGP (x))
2976 {
2977 if (SCM_INUMP (y))
2978 {
2979 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
2980 scm_remember_upto_here_1 (x);
2981 return (sgn < 0) ? y : x;
2982 }
2983 else if (SCM_BIGP (y))
2984 {
2985 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2986 scm_remember_upto_here_2 (x, y);
2987 return (cmp > 0) ? x : y;
2988 }
2989 else if (SCM_REALP (y))
2990 {
2991 double yy = SCM_REAL_VALUE (y);
2992 int cmp;
2993 if (xisnan (yy))
2994 return y;
2995 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
2996 scm_remember_upto_here_1 (x);
2997 return (cmp > 0) ? x : y;
2998 }
2999 else
3000 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f4c627b3 3001 }
0aacf84e
MD		 3002 else if (SCM_REALP (x))
3003 {
3004 if (SCM_INUMP (y))
3005 {
3006 double z = SCM_INUM (y);
3007 /* if x==NaN then "<" is false and we return NaN */
3008 return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;
3009 }
3010 else if (SCM_BIGP (y))
3011 {
3012 double xx = SCM_REAL_VALUE (x);
3013 int cmp;
3014 if (xisnan (xx))
3015 return x;
3016 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3017 scm_remember_upto_here_1 (y);
3018 return (cmp < 0) ? x : y;
3019 }
3020 else if (SCM_REALP (y))
3021 {
3022 /* if x==NaN then our explicit check means we return NaN
3023 if y==NaN then ">" is false and we return NaN
3024 calling isnan is unavoidable, since it's the only way to know
3025 which of x or y causes any compares to be false */
3026 double xx = SCM_REAL_VALUE (x);
3027 return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
3028 }
3029 else
3030 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3031 }
0aacf84e 3032 else
f4c627b3 3033 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
0f2d19dd
JB		 3034}
3035
3036
9de33deb 3037SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
942e5b91
MG		 3038/* "Return the minium of all parameter values."
3039 */
0f2d19dd 3040SCM
6e8d25a6 3041scm_min (SCM x, SCM y)
0f2d19dd 3042{
0aacf84e
MD		 3043 if (SCM_UNBNDP (y))
3044 {
3045 if (SCM_UNBNDP (x))
3046 SCM_WTA_DISPATCH_0 (g_min, s_min);
3047 else if (SCM_NUMBERP (x))
3048 return x;
3049 else
3050 SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
f872b822 3051 }
f4c627b3 3052
0aacf84e
MD		 3053 if (SCM_INUMP (x))
3054 {
3055 long xx = SCM_INUM (x);
3056 if (SCM_INUMP (y))
3057 {
3058 long yy = SCM_INUM (y);
3059 return (xx < yy) ? x : y;
3060 }
3061 else if (SCM_BIGP (y))
3062 {
3063 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3064 scm_remember_upto_here_1 (y);
3065 return (sgn < 0) ? y : x;
3066 }
3067 else if (SCM_REALP (y))
3068 {
3069 double z = xx;
3070 /* if y==NaN then "<" is false and we return NaN */
3071 return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3072 }
3073 else
3074 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3075 }
0aacf84e
MD		 3076 else if (SCM_BIGP (x))
3077 {
3078 if (SCM_INUMP (y))
3079 {
3080 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3081 scm_remember_upto_here_1 (x);
3082 return (sgn < 0) ? x : y;
3083 }
3084 else if (SCM_BIGP (y))
3085 {
3086 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3087 scm_remember_upto_here_2 (x, y);
3088 return (cmp > 0) ? y : x;
3089 }
3090 else if (SCM_REALP (y))
3091 {
3092 double yy = SCM_REAL_VALUE (y);
3093 int cmp;
3094 if (xisnan (yy))
3095 return y;
3096 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3097 scm_remember_upto_here_1 (x);
3098 return (cmp > 0) ? y : x;
3099 }
3100 else
3101 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f4c627b3 3102 }
0aacf84e
MD		 3103 else if (SCM_REALP (x))
3104 {
3105 if (SCM_INUMP (y))
3106 {
3107 double z = SCM_INUM (y);
3108 /* if x==NaN then "<" is false and we return NaN */
3109 return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x;
3110 }
3111 else if (SCM_BIGP (y))
3112 {
3113 double xx = SCM_REAL_VALUE (x);
3114 int cmp;
3115 if (xisnan (xx))
3116 return x;
3117 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3118 scm_remember_upto_here_1 (y);
3119 return (cmp < 0) ? y : x;
3120 }
3121 else if (SCM_REALP (y))
3122 {
3123 /* if x==NaN then our explicit check means we return NaN
3124 if y==NaN then "<" is false and we return NaN
3125 calling isnan is unavoidable, since it's the only way to know
3126 which of x or y causes any compares to be false */
3127 double xx = SCM_REAL_VALUE (x);
3128 return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
3129 }
3130 else
3131 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3132 }
0aacf84e 3133 else
f4c627b3 3134 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
0f2d19dd
JB		 3135}
3136
3137
9de33deb 3138SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
942e5b91
MG		 3139/* "Return the sum of all parameter values. Return 0 if called without\n"
3140 * "any parameters."
3141 */
0f2d19dd 3142SCM
6e8d25a6 3143scm_sum (SCM x, SCM y)
0f2d19dd 3144{
ca46fb90
RB		 3145 if (SCM_UNBNDP (y))
3146 {
3147 if (SCM_NUMBERP (x)) return x;
3148 if (SCM_UNBNDP (x)) return SCM_INUM0;
98cb6e75 3149 SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
f872b822 3150 }
c209c88e 3151
ca46fb90
RB		 3152 if (SCM_INUMP (x))
3153 {
3154 if (SCM_INUMP (y))
3155 {
3156 long xx = SCM_INUM (x);
3157 long yy = SCM_INUM (y);
3158 long int z = xx + yy;
3159 return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z);
3160 }
3161 else if (SCM_BIGP (y))
3162 {
3163 SCM_SWAP (x, y);
3164 goto add_big_inum;
3165 }
3166 else if (SCM_REALP (y))
3167 {
3168 long int xx = SCM_INUM (x);
3169 return scm_make_real (xx + SCM_REAL_VALUE (y));
3170 }
3171 else if (SCM_COMPLEXP (y))
3172 {
3173 long int xx = SCM_INUM (x);
3174 return scm_make_complex (xx + SCM_COMPLEX_REAL (y),
3175 SCM_COMPLEX_IMAG (y));
3176 }
3177 else
3178 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0aacf84e
MD		 3179 } else if (SCM_BIGP (x))
3180 {
3181 if (SCM_INUMP (y))
3182 {
3183 long int inum;
3184 int bigsgn;
3185 add_big_inum:
3186 inum = SCM_INUM (y);
3187 if (inum == 0)
3188 return x;
3189 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3190 if (inum < 0)
3191 {
3192 SCM result = scm_i_mkbig ();
3193 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
3194 scm_remember_upto_here_1 (x);
3195 /* we know the result will have to be a bignum */
3196 if (bigsgn == -1)
3197 return result;
3198 return scm_i_normbig (result);
3199 }
3200 else
3201 {
3202 SCM result = scm_i_mkbig ();
3203 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
3204 scm_remember_upto_here_1 (x);
3205 /* we know the result will have to be a bignum */
3206 if (bigsgn == 1)
3207 return result;
3208 return scm_i_normbig (result);
3209 }
3210 }
3211 else if (SCM_BIGP (y))
3212 {
3213 SCM result = scm_i_mkbig ();
3214 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3215 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3216 mpz_add (SCM_I_BIG_MPZ (result),
3217 SCM_I_BIG_MPZ (x),
3218 SCM_I_BIG_MPZ (y));
3219 scm_remember_upto_here_2 (x, y);
3220 /* we know the result will have to be a bignum */
3221 if (sgn_x == sgn_y)
3222 return result;
3223 return scm_i_normbig (result);
3224 }
3225 else if (SCM_REALP (y))
3226 {
3227 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
3228 scm_remember_upto_here_1 (x);
3229 return scm_make_real (result);
3230 }
3231 else if (SCM_COMPLEXP (y))
3232 {
3233 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3234 + SCM_COMPLEX_REAL (y));
3235 scm_remember_upto_here_1 (x);
3236 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3237 }
3238 else
3239 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0f2d19dd 3240 }
0aacf84e
MD		 3241 else if (SCM_REALP (x))
3242 {
3243 if (SCM_INUMP (y))
3244 return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));
3245 else if (SCM_BIGP (y))
3246 {
3247 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
3248 scm_remember_upto_here_1 (y);
3249 return scm_make_real (result);
3250 }
3251 else if (SCM_REALP (y))
3252 return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
3253 else if (SCM_COMPLEXP (y))
3254 return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
3255 SCM_COMPLEX_IMAG (y));
3256 else
3257 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3258 }
0aacf84e
MD		 3259 else if (SCM_COMPLEXP (x))
3260 {
3261 if (SCM_INUMP (y))
3262 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),
3263 SCM_COMPLEX_IMAG (x));
3264 else if (SCM_BIGP (y))
3265 {
3266 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
3267 + SCM_COMPLEX_REAL (x));
3268 scm_remember_upto_here_1 (y);
3269 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));
3270 }
3271 else if (SCM_REALP (y))
3272 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
3273 SCM_COMPLEX_IMAG (x));
3274 else if (SCM_COMPLEXP (y))
3275 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
3276 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
3277 else
3278 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
98cb6e75 3279 }
0aacf84e 3280 else
98cb6e75 3281 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
0f2d19dd
JB		 3282}
3283
3284
9de33deb 3285SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
609c3d30
MG		 3286/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3287 * the sum of all but the first argument are subtracted from the first
3288 * argument. */
c05e97b7 3289#define FUNC_NAME s_difference
0f2d19dd 3290SCM
6e8d25a6 3291scm_difference (SCM x, SCM y)
0f2d19dd 3292{
ca46fb90
RB		 3293 if (SCM_UNBNDP (y))
3294 {
3295 if (SCM_UNBNDP (x))
3296 SCM_WTA_DISPATCH_0 (g_difference, s_difference);
3297 else
3298 if (SCM_INUMP (x))
3299 {
3300 long xx = -SCM_INUM (x);
3301 if (SCM_FIXABLE (xx))
3302 return SCM_MAKINUM (xx);
3303 else
3304 return scm_i_long2big (xx);
3305 }
3306 else if (SCM_BIGP (x))
3307 /* FIXME: do we really need to normalize here? */
3308 return scm_i_normbig (scm_i_clonebig (x, 0));
3309 else if (SCM_REALP (x))
3310 return scm_make_real (-SCM_REAL_VALUE (x));
3311 else if (SCM_COMPLEXP (x))
3312 return scm_make_complex (-SCM_COMPLEX_REAL (x),
3313 -SCM_COMPLEX_IMAG (x));
3314 else
3315 SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
f872b822 3316 }
ca46fb90 3317
0aacf84e
MD		 3318 if (SCM_INUMP (x))
3319 {
3320 if (SCM_INUMP (y))
3321 {
3322 long int xx = SCM_INUM (x);
3323 long int yy = SCM_INUM (y);
3324 long int z = xx - yy;
3325 if (SCM_FIXABLE (z))
3326 return SCM_MAKINUM (z);
3327 else
3328 return scm_i_long2big (z);
3329 }
3330 else if (SCM_BIGP (y))
3331 {
3332 /* inum-x - big-y */
3333 long xx = SCM_INUM (x);
ca46fb90 3334
0aacf84e
MD		 3335 if (xx == 0)
3336 return scm_i_clonebig (y, 0);
3337 else
3338 {
3339 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3340 SCM result = scm_i_mkbig ();
ca46fb90 3341
0aacf84e
MD		 3342 if (xx >= 0)
3343 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
3344 else
3345 {
3346 /* x - y == -(y + -x) */
3347 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
3348 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3349 }
3350 scm_remember_upto_here_1 (y);
ca46fb90 3351
0aacf84e
MD		 3352 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
3353 /* we know the result will have to be a bignum */
3354 return result;
3355 else
3356 return scm_i_normbig (result);
3357 }
3358 }
3359 else if (SCM_REALP (y))
3360 {
3361 long int xx = SCM_INUM (x);
3362 return scm_make_real (xx - SCM_REAL_VALUE (y));
3363 }
3364 else if (SCM_COMPLEXP (y))
3365 {
3366 long int xx = SCM_INUM (x);
3367 return scm_make_complex (xx - SCM_COMPLEX_REAL (y),
3368 - SCM_COMPLEX_IMAG (y));
3369 }
3370 else
3371 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3372 }
0aacf84e
MD		 3373 else if (SCM_BIGP (x))
3374 {
3375 if (SCM_INUMP (y))
3376 {
3377 /* big-x - inum-y */
3378 long yy = SCM_INUM (y);
3379 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
ca46fb90 3380
0aacf84e
MD		 3381 scm_remember_upto_here_1 (x);
3382 if (sgn_x == 0)
3383 return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);
3384 else
3385 {
3386 SCM result = scm_i_mkbig ();
ca46fb90 3387
708f22c6
KR		 3388 if (yy >= 0)
3389 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
3390 else
3391 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
0aacf84e 3392 scm_remember_upto_here_1 (x);
ca46fb90 3393
0aacf84e
MD		 3394 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
3395 /* we know the result will have to be a bignum */
3396 return result;
3397 else
3398 return scm_i_normbig (result);
3399 }
3400 }
3401 else if (SCM_BIGP (y))
3402 {
3403 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3404 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3405 SCM result = scm_i_mkbig ();
3406 mpz_sub (SCM_I_BIG_MPZ (result),
3407 SCM_I_BIG_MPZ (x),
3408 SCM_I_BIG_MPZ (y));
3409 scm_remember_upto_here_2 (x, y);
3410 /* we know the result will have to be a bignum */
3411 if ((sgn_x == 1) && (sgn_y == -1))
3412 return result;
3413 if ((sgn_x == -1) && (sgn_y == 1))
3414 return result;
3415 return scm_i_normbig (result);
3416 }
3417 else if (SCM_REALP (y))
3418 {
3419 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
3420 scm_remember_upto_here_1 (x);
3421 return scm_make_real (result);
3422 }
3423 else if (SCM_COMPLEXP (y))
3424 {
3425 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3426 - SCM_COMPLEX_REAL (y));
3427 scm_remember_upto_here_1 (x);
3428 return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));
3429 }
3430 else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
ca46fb90 3431 }
0aacf84e
MD		 3432 else if (SCM_REALP (x))
3433 {
3434 if (SCM_INUMP (y))
3435 return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));
3436 else if (SCM_BIGP (y))
3437 {
3438 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
3439 scm_remember_upto_here_1 (x);
3440 return scm_make_real (result);
3441 }
3442 else if (SCM_REALP (y))
3443 return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
3444 else if (SCM_COMPLEXP (y))
3445 return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
3446 -SCM_COMPLEX_IMAG (y));
3447 else
3448 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 3449 }
0aacf84e
MD		 3450 else if (SCM_COMPLEXP (x))
3451 {
3452 if (SCM_INUMP (y))
3453 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),
3454 SCM_COMPLEX_IMAG (x));
3455 else if (SCM_BIGP (y))
3456 {
3457 double real_part = (SCM_COMPLEX_REAL (x)
3458 - mpz_get_d (SCM_I_BIG_MPZ (y)));
3459 scm_remember_upto_here_1 (x);
3460 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3461 }
3462 else if (SCM_REALP (y))
3463 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
3464 SCM_COMPLEX_IMAG (x));
3465 else if (SCM_COMPLEXP (y))
3466 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
3467 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
3468 else
3469 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 3470 }
0aacf84e 3471 else
98cb6e75 3472 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
0f2d19dd 3473}
c05e97b7 3474#undef FUNC_NAME
0f2d19dd 3475
ca46fb90 3476
9de33deb 3477SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
942e5b91
MG		 3478/* "Return the product of all arguments. If called without arguments,\n"
3479 * "1 is returned."
3480 */
0f2d19dd 3481SCM
6e8d25a6 3482scm_product (SCM x, SCM y)
0f2d19dd 3483{
0aacf84e
MD		 3484 if (SCM_UNBNDP (y))
3485 {
3486 if (SCM_UNBNDP (x))
3487 return SCM_MAKINUM (1L);
3488 else if (SCM_NUMBERP (x))
3489 return x;
3490 else
3491 SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
f872b822 3492 }
ca46fb90 3493
0aacf84e
MD		 3494 if (SCM_INUMP (x))
3495 {
3496 long xx;
f4c627b3 3497
0aacf84e
MD		 3498 intbig:
3499 xx = SCM_INUM (x);
f4c627b3 3500
0aacf84e
MD		 3501 switch (xx)
3502 {
ca46fb90
RB		 3503 case 0: return x; break;
3504 case 1: return y; break;
0aacf84e 3505 }
f4c627b3 3506
0aacf84e
MD		 3507 if (SCM_INUMP (y))
3508 {
3509 long yy = SCM_INUM (y);
3510 long kk = xx * yy;
3511 SCM k = SCM_MAKINUM (kk);
3512 if ((kk == SCM_INUM (k)) && (kk / xx == yy))
3513 return k;
3514 else
3515 {
3516 SCM result = scm_i_long2big (xx);
3517 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
3518 return scm_i_normbig (result);
3519 }
3520 }
3521 else if (SCM_BIGP (y))
3522 {
3523 SCM result = scm_i_mkbig ();
3524 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
3525 scm_remember_upto_here_1 (y);
3526 return result;
3527 }
3528 else if (SCM_REALP (y))
3529 return scm_make_real (xx * SCM_REAL_VALUE (y));
3530 else if (SCM_COMPLEXP (y))
3531 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
3532 xx * SCM_COMPLEX_IMAG (y));
3533 else
3534 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 3535 }
0aacf84e
MD		 3536 else if (SCM_BIGP (x))
3537 {
3538 if (SCM_INUMP (y))
3539 {
3540 SCM_SWAP (x, y);
3541 goto intbig;
3542 }
3543 else if (SCM_BIGP (y))
3544 {
3545 SCM result = scm_i_mkbig ();
3546 mpz_mul (SCM_I_BIG_MPZ (result),
3547 SCM_I_BIG_MPZ (x),
3548 SCM_I_BIG_MPZ (y));
3549 scm_remember_upto_here_2 (x, y);
3550 return result;
3551 }
3552 else if (SCM_REALP (y))
3553 {
3554 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
3555 scm_remember_upto_here_1 (x);
3556 return scm_make_real (result);
3557 }
3558 else if (SCM_COMPLEXP (y))
3559 {
3560 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
3561 scm_remember_upto_here_1 (x);
3562 return scm_make_complex (z * SCM_COMPLEX_REAL (y),
3563 z * SCM_COMPLEX_IMAG (y));
3564 }
3565 else
3566 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 3567 }
0aacf84e
MD		 3568 else if (SCM_REALP (x))
3569 {
3570 if (SCM_INUMP (y))
3571 return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));
3572 else if (SCM_BIGP (y))
3573 {
3574 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
3575 scm_remember_upto_here_1 (y);
3576 return scm_make_real (result);
3577 }
3578 else if (SCM_REALP (y))
3579 return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
3580 else if (SCM_COMPLEXP (y))
3581 return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
3582 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
3583 else
3584 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 3585 }
0aacf84e
MD		 3586 else if (SCM_COMPLEXP (x))
3587 {
3588 if (SCM_INUMP (y))
3589 return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),
3590 SCM_INUM (y) * SCM_COMPLEX_IMAG (x));
3591 else if (SCM_BIGP (y))
3592 {
3593 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
3594 scm_remember_upto_here_1 (y);
76506335
KR		 3595 return scm_make_complex (z * SCM_COMPLEX_REAL (x),
3596 z * SCM_COMPLEX_IMAG (x));
0aacf84e
MD		 3597 }
3598 else if (SCM_REALP (y))
3599 return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
3600 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
3601 else if (SCM_COMPLEXP (y))
3602 {
3603 return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
3604 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
3605 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
3606 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
3607 }
3608 else
3609 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 3610 }
0aacf84e 3611 else
f4c627b3 3612 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
0f2d19dd
JB		 3613}
3614
0f2d19dd 3615double
6e8d25a6 3616scm_num2dbl (SCM a, const char *why)
f4c627b3 3617#define FUNC_NAME why
0f2d19dd 3618{
0aacf84e 3619 if (SCM_INUMP (a))
0f2d19dd 3620 return (double) SCM_INUM (a);
0aacf84e
MD		 3621 else if (SCM_BIGP (a))
3622 {
3623 double result = mpz_get_d (SCM_I_BIG_MPZ (a));
3624 scm_remember_upto_here_1 (a);
3625 return result;
3626 }
3627 else if (SCM_REALP (a))
f4c627b3 3628 return (SCM_REAL_VALUE (a));
0aacf84e 3629 else
f4c627b3 3630 SCM_WRONG_TYPE_ARG (SCM_ARGn, a);
0f2d19dd 3631}
f4c627b3 3632#undef FUNC_NAME
0f2d19dd 3633
7351e207
MV		 3634#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3635 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3636#define ALLOW_DIVIDE_BY_ZERO
3637/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3638#endif
0f2d19dd 3639
ba74ef4e
MV		 3640/* The code below for complex division is adapted from the GNU
3641 libstdc++, which adapted it from f2c's libF77, and is subject to
3642 this copyright: */
3643
3644/****************************************************************
3645Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3646
3647Permission to use, copy, modify, and distribute this software
3648and its documentation for any purpose and without fee is hereby
3649granted, provided that the above copyright notice appear in all
3650copies and that both that the copyright notice and this
3651permission notice and warranty disclaimer appear in supporting
3652documentation, and that the names of AT&T Bell Laboratories or
3653Bellcore or any of their entities not be used in advertising or
3654publicity pertaining to distribution of the software without
3655specific, written prior permission.
3656
3657AT&T and Bellcore disclaim all warranties with regard to this
3658software, including all implied warranties of merchantability
3659and fitness. In no event shall AT&T or Bellcore be liable for
3660any special, indirect or consequential damages or any damages
3661whatsoever resulting from loss of use, data or profits, whether
3662in an action of contract, negligence or other tortious action,
3663arising out of or in connection with the use or performance of
3664this software.
3665****************************************************************/
3666
9de33deb 3667SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
609c3d30
MG		 3668/* Divide the first argument by the product of the remaining
3669 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3670 returned. */
c05e97b7 3671#define FUNC_NAME s_divide
0f2d19dd 3672SCM
6e8d25a6 3673scm_divide (SCM x, SCM y)
0f2d19dd 3674{
f8de44c1
DH		 3675 double a;
3676
0aacf84e
MD		 3677 if (SCM_UNBNDP (y))
3678 {
3679 if (SCM_UNBNDP (x))
3680 SCM_WTA_DISPATCH_0 (g_divide, s_divide);
3681 else if (SCM_INUMP (x))
3682 {
3683 long xx = SCM_INUM (x);
3684 if (xx == 1 || xx == -1)
3685 return x;
7351e207 3686#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 3687 else if (xx == 0)
3688 scm_num_overflow (s_divide);
7351e207 3689#endif
0aacf84e
MD		 3690 else
3691 return scm_make_real (1.0 / (double) xx);
3692 }
3693 else if (SCM_BIGP (x))
3694 return scm_make_real (1.0 / scm_i_big2dbl (x));
3695 else if (SCM_REALP (x))
3696 {
3697 double xx = SCM_REAL_VALUE (x);
7351e207 3698#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 3699 if (xx == 0.0)
3700 scm_num_overflow (s_divide);
3701 else
7351e207 3702#endif
0aacf84e
MD		 3703 return scm_make_real (1.0 / xx);
3704 }
3705 else if (SCM_COMPLEXP (x))
3706 {
3707 double r = SCM_COMPLEX_REAL (x);
3708 double i = SCM_COMPLEX_IMAG (x);
3709 if (r <= i)
3710 {
3711 double t = r / i;
3712 double d = i * (1.0 + t * t);
3713 return scm_make_complex (t / d, -1.0 / d);
3714 }
3715 else
3716 {
3717 double t = i / r;
3718 double d = r * (1.0 + t * t);
3719 return scm_make_complex (1.0 / d, -t / d);
3720 }
3721 }
3722 else
3723 SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
f8de44c1 3724 }
f8de44c1 3725
0aacf84e
MD		 3726 if (SCM_INUMP (x))
3727 {
3728 long xx = SCM_INUM (x);
3729 if (SCM_INUMP (y))
3730 {
3731 long yy = SCM_INUM (y);
3732 if (yy == 0)
3733 {
7351e207 3734#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 3735 scm_num_overflow (s_divide);
7351e207 3736#else
0aacf84e 3737 return scm_make_real ((double) xx / (double) yy);
7351e207 3738#endif
0aacf84e
MD		 3739 }
3740 else if (xx % yy != 0)
3741 return scm_make_real ((double) xx / (double) yy);
3742 else
3743 {
3744 long z = xx / yy;
3745 if (SCM_FIXABLE (z))
3746 return SCM_MAKINUM (z);
3747 else
3748 return scm_i_long2big (z);
3749 }
f872b822 3750 }
0aacf84e
MD		 3751 else if (SCM_BIGP (y))
3752 return scm_make_real ((double) xx / scm_i_big2dbl (y));
3753 else if (SCM_REALP (y))
3754 {
3755 double yy = SCM_REAL_VALUE (y);
7351e207 3756#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 3757 if (yy == 0.0)
3758 scm_num_overflow (s_divide);
3759 else
7351e207 3760#endif
0aacf84e 3761 return scm_make_real ((double) xx / yy);
ba74ef4e 3762 }
0aacf84e
MD		 3763 else if (SCM_COMPLEXP (y))
3764 {
3765 a = xx;
3766 complex_div: /* y _must_ be a complex number */
3767 {
3768 double r = SCM_COMPLEX_REAL (y);
3769 double i = SCM_COMPLEX_IMAG (y);
3770 if (r <= i)
3771 {
3772 double t = r / i;
3773 double d = i * (1.0 + t * t);
3774 return scm_make_complex ((a * t) / d, -a / d);
3775 }
3776 else
3777 {
3778 double t = i / r;
3779 double d = r * (1.0 + t * t);
3780 return scm_make_complex (a / d, -(a * t) / d);
3781 }
3782 }
3783 }
3784 else
3785 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 3786 }
0aacf84e
MD		 3787 else if (SCM_BIGP (x))
3788 {
3789 if (SCM_INUMP (y))
3790 {
3791 long int yy = SCM_INUM (y);
3792 if (yy == 0)
3793 {
7351e207 3794#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 3795 scm_num_overflow (s_divide);
7351e207 3796#else
0aacf84e
MD		 3797 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3798 scm_remember_upto_here_1 (x);
3799 return (sgn == 0) ? scm_nan () : scm_inf ();
7351e207 3800#endif
0aacf84e
MD		 3801 }
3802 else if (yy == 1)
3803 return x;
3804 else
3805 {
3806 /* FIXME: HMM, what are the relative performance issues here?
3807 We need to test. Is it faster on average to test
3808 divisible_p, then perform whichever operation, or is it
3809 faster to perform the integer div opportunistically and
3810 switch to real if there's a remainder? For now we take the
3811 middle ground: test, then if divisible, use the faster div
3812 func. */
3813
3814 long abs_yy = yy < 0 ? -yy : yy;
3815 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
3816
3817 if (divisible_p)
3818 {
3819 SCM result = scm_i_mkbig ();
3820 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
3821 scm_remember_upto_here_1 (x);
3822 if (yy < 0)
3823 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3824 return scm_i_normbig (result);
3825 }
3826 else
3827 return scm_make_real (scm_i_big2dbl (x) / (double) yy);
3828 }
3829 }
3830 else if (SCM_BIGP (y))
3831 {
3832 int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
3833 if (y_is_zero)
3834 {
ca46fb90 3835#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 3836 scm_num_overflow (s_divide);
f872b822 3837#else
0aacf84e
MD		 3838 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3839 scm_remember_upto_here_1 (x);
3840 return (sgn == 0) ? scm_nan () : scm_inf ();
f872b822 3841#endif
0aacf84e
MD		 3842 }
3843 else
3844 {
3845 /* big_x / big_y */
3846 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
3847 SCM_I_BIG_MPZ (y));
3848 if (divisible_p)
3849 {
3850 SCM result = scm_i_mkbig ();
3851 mpz_divexact (SCM_I_BIG_MPZ (result),
3852 SCM_I_BIG_MPZ (x),
3853 SCM_I_BIG_MPZ (y));
3854 scm_remember_upto_here_2 (x, y);
3855 return scm_i_normbig (result);
3856 }
3857 else
3858 {
3859 double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));
3860 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3861 scm_remember_upto_here_2 (x, y);
3862 return scm_make_real (dbx / dby);
3863 }
3864 }
3865 }
3866 else if (SCM_REALP (y))
3867 {
3868 double yy = SCM_REAL_VALUE (y);
7351e207 3869#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 3870 if (yy == 0.0)
3871 scm_num_overflow (s_divide);
3872 else
7351e207 3873#endif
0aacf84e
MD		 3874 return scm_make_real (scm_i_big2dbl (x) / yy);
3875 }
3876 else if (SCM_COMPLEXP (y))
3877 {
3878 a = scm_i_big2dbl (x);
3879 goto complex_div;
3880 }
3881 else
3882 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3883 }
0aacf84e
MD		 3884 else if (SCM_REALP (x))
3885 {
3886 double rx = SCM_REAL_VALUE (x);
3887 if (SCM_INUMP (y))
3888 {
3889 long int yy = SCM_INUM (y);
7351e207 3890#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 3891 if (yy == 0)
3892 scm_num_overflow (s_divide);
3893 else
7351e207 3894#endif
0aacf84e
MD		 3895 return scm_make_real (rx / (double) yy);
3896 }
3897 else if (SCM_BIGP (y))
3898 {
3899 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3900 scm_remember_upto_here_1 (y);
3901 return scm_make_real (rx / dby);
3902 }
3903 else if (SCM_REALP (y))
3904 {
3905 double yy = SCM_REAL_VALUE (y);
7351e207 3906#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 3907 if (yy == 0.0)
3908 scm_num_overflow (s_divide);
3909 else
7351e207 3910#endif
0aacf84e
MD		 3911 return scm_make_real (rx / yy);
3912 }
3913 else if (SCM_COMPLEXP (y))
3914 {
3915 a = rx;
3916 goto complex_div;
3917 }
3918 else
3919 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3920 }
0aacf84e
MD		 3921 else if (SCM_COMPLEXP (x))
3922 {
3923 double rx = SCM_COMPLEX_REAL (x);
3924 double ix = SCM_COMPLEX_IMAG (x);
3925 if (SCM_INUMP (y))
3926 {
3927 long int yy = SCM_INUM (y);
7351e207 3928#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 3929 if (yy == 0)
3930 scm_num_overflow (s_divide);
3931 else
7351e207 3932#endif
0aacf84e
MD		 3933 {
3934 double d = yy;
3935 return scm_make_complex (rx / d, ix / d);
3936 }
3937 }
3938 else if (SCM_BIGP (y))
3939 {
3940 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
3941 scm_remember_upto_here_1 (y);
3942 return scm_make_complex (rx / dby, ix / dby);
3943 }
3944 else if (SCM_REALP (y))
3945 {
3946 double yy = SCM_REAL_VALUE (y);
7351e207 3947#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 3948 if (yy == 0.0)
3949 scm_num_overflow (s_divide);
3950 else
7351e207 3951#endif
0aacf84e
MD		 3952 return scm_make_complex (rx / yy, ix / yy);
3953 }
3954 else if (SCM_COMPLEXP (y))
3955 {
3956 double ry = SCM_COMPLEX_REAL (y);
3957 double iy = SCM_COMPLEX_IMAG (y);
3958 if (ry <= iy)
3959 {
3960 double t = ry / iy;
3961 double d = iy * (1.0 + t * t);
3962 return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);
3963 }
3964 else
3965 {
3966 double t = iy / ry;
3967 double d = ry * (1.0 + t * t);
3968 return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);
3969 }
3970 }
3971 else
3972 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 3973 }
0aacf84e 3974 else
f8de44c1 3975 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
0f2d19dd 3976}
c05e97b7 3977#undef FUNC_NAME
0f2d19dd 3978
fa605590 3979
0f2d19dd 3980double
6e8d25a6 3981scm_asinh (double x)
0f2d19dd 3982{
fa605590
KR		 3983#if HAVE_ASINH
3984 return asinh (x);
3985#else
3986#define asinh scm_asinh
f872b822 3987 return log (x + sqrt (x * x + 1));
fa605590 3988#endif
0f2d19dd 3989}
fa605590
KR		 3990SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
3991/* "Return the inverse hyperbolic sine of @var{x}."
3992 */
0f2d19dd
JB		 3993
3994
0f2d19dd 3995double
6e8d25a6 3996scm_acosh (double x)
0f2d19dd 3997{
fa605590
KR		 3998#if HAVE_ACOSH
3999 return acosh (x);
4000#else
4001#define acosh scm_acosh
f872b822 4002 return log (x + sqrt (x * x - 1));
fa605590 4003#endif
0f2d19dd 4004}
fa605590
KR		 4005SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
4006/* "Return the inverse hyperbolic cosine of @var{x}."
4007 */
0f2d19dd
JB		 4008
4009
0f2d19dd 4010double
6e8d25a6 4011scm_atanh (double x)
0f2d19dd 4012{
fa605590
KR		 4013#if HAVE_ATANH
4014 return atanh (x);
4015#else
4016#define atanh scm_atanh
f872b822 4017 return 0.5 * log ((1 + x) / (1 - x));
fa605590 4018#endif
0f2d19dd 4019}
fa605590
KR		 4020SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
4021/* "Return the inverse hyperbolic tangent of @var{x}."
4022 */
0f2d19dd
JB		 4023
4024
0f2d19dd 4025double
6e8d25a6 4026scm_truncate (double x)
0f2d19dd 4027{
fa605590
KR		 4028#if HAVE_TRUNC
4029 return trunc (x);
4030#else
4031#define trunc scm_truncate
f872b822
MD		 4032 if (x < 0.0)
4033 return -floor (-x);
4034 return floor (x);
fa605590 4035#endif
0f2d19dd 4036}
fa605590
KR		 4037SCM_GPROC1 (s_truncate, "truncate", scm_tc7_dsubr, (SCM (*)()) trunc, g_truncate);
4038/* "Round the inexact number @var{x} towards zero."
4039 */
0f2d19dd
JB		 4040
4041
14b18ed6 4042SCM_GPROC1 (s_round, "round", scm_tc7_dsubr, (SCM (*)()) scm_round, g_round);
942e5b91
MG		 4043/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
4044 * "numbers, round towards even."
4045 */
0f2d19dd 4046double
6e8d25a6 4047scm_round (double x)
0f2d19dd
JB		 4048{
4049 double plus_half = x + 0.5;
f872b822 4050 double result = floor (plus_half);
0f2d19dd 4051 /* Adjust so that the scm_round is towards even. */
0aacf84e
MD		 4052 return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
4053 ? result - 1
4054 : result);
0f2d19dd
JB		 4055}
4056
4057
14b18ed6 4058SCM_GPROC1 (s_i_floor, "floor", scm_tc7_dsubr, (SCM (*)()) floor, g_i_floor);
942e5b91
MG		 4059/* "Round the number @var{x} towards minus infinity."
4060 */
14b18ed6 4061SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_dsubr, (SCM (*)()) ceil, g_i_ceil);
942e5b91
MG		 4062/* "Round the number @var{x} towards infinity."
4063 */
14b18ed6 4064SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
942e5b91
MG		 4065/* "Return the square root of the real number @var{x}."
4066 */
14b18ed6 4067SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
942e5b91
MG		 4068/* "Return the absolute value of the real number @var{x}."
4069 */
14b18ed6 4070SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
942e5b91
MG		 4071/* "Return the @var{x}th power of e."
4072 */
14b18ed6 4073SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
b3fcac34 4074/* "Return the natural logarithm of the real number @var{x}."
942e5b91 4075 */
14b18ed6 4076SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
942e5b91
MG		 4077/* "Return the sine of the real number @var{x}."
4078 */
14b18ed6 4079SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
942e5b91
MG		 4080/* "Return the cosine of the real number @var{x}."
4081 */
14b18ed6 4082SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
942e5b91
MG		 4083/* "Return the tangent of the real number @var{x}."
4084 */
14b18ed6 4085SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
942e5b91
MG		 4086/* "Return the arc sine of the real number @var{x}."
4087 */
14b18ed6 4088SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
942e5b91
MG		 4089/* "Return the arc cosine of the real number @var{x}."
4090 */
14b18ed6 4091SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
942e5b91
MG		 4092/* "Return the arc tangent of the real number @var{x}."
4093 */
14b18ed6 4094SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
942e5b91
MG		 4095/* "Return the hyperbolic sine of the real number @var{x}."
4096 */
14b18ed6 4097SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
942e5b91
MG		 4098/* "Return the hyperbolic cosine of the real number @var{x}."
4099 */
14b18ed6 4100SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
942e5b91
MG		 4101/* "Return the hyperbolic tangent of the real number @var{x}."
4102 */
f872b822
MD		 4103
4104struct dpair
4105{
4106 double x, y;
4107};
4108
27c37006
NJ		 4109static void scm_two_doubles (SCM x,
4110 SCM y,
3eeba8d4
JB		 4111 const char *sstring,
4112 struct dpair * xy);
f872b822
MD		 4113
4114static void
27c37006
NJ		 4115scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
4116{
0aacf84e 4117 if (SCM_INUMP (x))
27c37006 4118 xy->x = SCM_INUM (x);
0aacf84e 4119 else if (SCM_BIGP (x))
1be6b49c 4120 xy->x = scm_i_big2dbl (x);
0aacf84e 4121 else if (SCM_REALP (x))
27c37006 4122 xy->x = SCM_REAL_VALUE (x);
0aacf84e 4123 else
27c37006 4124 scm_wrong_type_arg (sstring, SCM_ARG1, x);
98cb6e75 4125
0aacf84e 4126 if (SCM_INUMP (y))
27c37006 4127 xy->y = SCM_INUM (y);
0aacf84e 4128 else if (SCM_BIGP (y))
1be6b49c 4129 xy->y = scm_i_big2dbl (y);
0aacf84e 4130 else if (SCM_REALP (y))
27c37006 4131 xy->y = SCM_REAL_VALUE (y);
0aacf84e 4132 else
27c37006 4133 scm_wrong_type_arg (sstring, SCM_ARG2, y);
0f2d19dd
JB		 4134}
4135
4136
a1ec6916 4137SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
27c37006
NJ		 4138 (SCM x, SCM y),
4139 "Return @var{x} raised to the power of @var{y}. This\n"
0137a31b 4140 "procedure does not accept complex arguments.")
1bbd0b84 4141#define FUNC_NAME s_scm_sys_expt
0f2d19dd
JB		 4142{
4143 struct dpair xy;
27c37006 4144 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 4145 return scm_make_real (pow (xy.x, xy.y));
0f2d19dd 4146}
1bbd0b84 4147#undef FUNC_NAME
0f2d19dd
JB		 4148
4149
a1ec6916 4150SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
27c37006
NJ		 4151 (SCM x, SCM y),
4152 "Return the arc tangent of the two arguments @var{x} and\n"
4153 "@var{y}. This is similar to calculating the arc tangent of\n"
4154 "@var{x} / @var{y}, except that the signs of both arguments\n"
0137a31b
MG		 4155 "are used to determine the quadrant of the result. This\n"
4156 "procedure does not accept complex arguments.")
1bbd0b84 4157#define FUNC_NAME s_scm_sys_atan2
0f2d19dd
JB		 4158{
4159 struct dpair xy;
27c37006 4160 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 4161 return scm_make_real (atan2 (xy.x, xy.y));
0f2d19dd 4162}
1bbd0b84 4163#undef FUNC_NAME
0f2d19dd
JB		 4164
4165
a1ec6916 4166SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
bb628794 4167 (SCM real, SCM imaginary),
942e5b91
MG		 4168 "Return a complex number constructed of the given @var{real} and\n"
4169 "@var{imaginary} parts.")
1bbd0b84 4170#define FUNC_NAME s_scm_make_rectangular
0f2d19dd
JB		 4171{
4172 struct dpair xy;
bb628794 4173 scm_two_doubles (real, imaginary, FUNC_NAME, &xy);
f8de44c1 4174 return scm_make_complex (xy.x, xy.y);
0f2d19dd 4175}
1bbd0b84 4176#undef FUNC_NAME
0f2d19dd
JB		 4177
4178
4179
a1ec6916 4180SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
27c37006 4181 (SCM x, SCM y),
942e5b91 4182 "Return the complex number @var{x} * e^(i * @var{y}).")
1bbd0b84 4183#define FUNC_NAME s_scm_make_polar
0f2d19dd
JB		 4184{
4185 struct dpair xy;
6efadd7c 4186 double s, c;
27c37006 4187 scm_two_doubles (x, y, FUNC_NAME, &xy);
6efadd7c
KR		 4188#if HAVE_SINCOS
4189 sincos (xy.y, &s, &c);
4190#else
4191 s = sin (xy.y);
4192 c = cos (xy.y);
4193#endif
4194 return scm_make_complex (xy.x * c, xy.x * s);
0f2d19dd 4195}
1bbd0b84 4196#undef FUNC_NAME
0f2d19dd
JB		 4197
4198
152f82bf 4199SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
942e5b91
MG		 4200/* "Return the real part of the number @var{z}."
4201 */
0f2d19dd 4202SCM
6e8d25a6 4203scm_real_part (SCM z)
0f2d19dd 4204{
0aacf84e 4205 if (SCM_INUMP (z))
c2ff8ab0 4206 return z;
0aacf84e 4207 else if (SCM_BIGP (z))
c2ff8ab0 4208 return z;
0aacf84e 4209 else if (SCM_REALP (z))
c2ff8ab0 4210 return z;
0aacf84e 4211 else if (SCM_COMPLEXP (z))
c2ff8ab0 4212 return scm_make_real (SCM_COMPLEX_REAL (z));
0aacf84e 4213 else
c2ff8ab0 4214 SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
0f2d19dd
JB		 4215}
4216
4217
152f82bf 4218SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
942e5b91
MG		 4219/* "Return the imaginary part of the number @var{z}."
4220 */
0f2d19dd 4221SCM
6e8d25a6 4222scm_imag_part (SCM z)
0f2d19dd 4223{
0aacf84e 4224 if (SCM_INUMP (z))
f872b822 4225 return SCM_INUM0;
0aacf84e 4226 else if (SCM_BIGP (z))
f872b822 4227 return SCM_INUM0;
0aacf84e 4228 else if (SCM_REALP (z))
c2ff8ab0 4229 return scm_flo0;
0aacf84e 4230 else if (SCM_COMPLEXP (z))
c2ff8ab0 4231 return scm_make_real (SCM_COMPLEX_IMAG (z));
0aacf84e 4232 else
c2ff8ab0 4233 SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
0f2d19dd
JB		 4234}
4235
4236
9de33deb 4237SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
942e5b91
MG		 4238/* "Return the magnitude of the number @var{z}. This is the same as\n"
4239 * "@code{abs} for real arguments, but also allows complex numbers."
4240 */
0f2d19dd 4241SCM
6e8d25a6 4242scm_magnitude (SCM z)
0f2d19dd 4243{
0aacf84e
MD		 4244 if (SCM_INUMP (z))
4245 {
4246 long int zz = SCM_INUM (z);
4247 if (zz >= 0)
4248 return z;
4249 else if (SCM_POSFIXABLE (-zz))
4250 return SCM_MAKINUM (-zz);
4251 else
4252 return scm_i_long2big (-zz);
5986c47d 4253 }
0aacf84e
MD		 4254 else if (SCM_BIGP (z))
4255 {
4256 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
4257 scm_remember_upto_here_1 (z);
4258 if (sgn < 0)
4259 return scm_i_clonebig (z, 0);
4260 else
4261 return z;
5986c47d 4262 }
0aacf84e 4263 else if (SCM_REALP (z))
c2ff8ab0 4264 return scm_make_real (fabs (SCM_REAL_VALUE (z)));
0aacf84e 4265 else if (SCM_COMPLEXP (z))
6efadd7c 4266 return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
0aacf84e 4267 else
c2ff8ab0 4268 SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
0f2d19dd
JB		 4269}
4270
4271
9de33deb 4272SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
942e5b91
MG		 4273/* "Return the angle of the complex number @var{z}."
4274 */
0f2d19dd 4275SCM
6e8d25a6 4276scm_angle (SCM z)
0f2d19dd 4277{
c8ae173e
KR		 4278 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
4279 scm_flo0 to save allocating a new flonum with scm_make_real each time.
4280 But if atan2 follows the floating point rounding mode, then the value
4281 is not a constant. Maybe it'd be close enough though. */
0aacf84e
MD		 4282 if (SCM_INUMP (z))
4283 {
4284 if (SCM_INUM (z) >= 0)
c8ae173e 4285 return scm_flo0;
0aacf84e
MD		 4286 else
4287 return scm_make_real (atan2 (0.0, -1.0));
f872b822 4288 }
0aacf84e
MD		 4289 else if (SCM_BIGP (z))
4290 {
4291 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
4292 scm_remember_upto_here_1 (z);
4293 if (sgn < 0)
4294 return scm_make_real (atan2 (0.0, -1.0));
4295 else
c8ae173e 4296 return scm_flo0;
0f2d19dd 4297 }
0aacf84e 4298 else if (SCM_REALP (z))
c8ae173e
KR		 4299 {
4300 if (SCM_REAL_VALUE (z) >= 0)
4301 return scm_flo0;
4302 else
4303 return scm_make_real (atan2 (0.0, -1.0));
4304 }
0aacf84e 4305 else if (SCM_COMPLEXP (z))
f4c627b3 4306 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
0aacf84e 4307 else
f4c627b3 4308 SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
0f2d19dd
JB		 4309}
4310
4311
3c9a524f
DH		 4312SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact);
4313/* Convert the number @var{x} to its inexact representation.\n"
4314 */
4315SCM
4316scm_exact_to_inexact (SCM z)
4317{
4318 if (SCM_INUMP (z))
4319 return scm_make_real ((double) SCM_INUM (z));
4320 else if (SCM_BIGP (z))
4321 return scm_make_real (scm_i_big2dbl (z));
4322 else if (SCM_INEXACTP (z))
4323 return z;
4324 else
4325 SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact);
4326}
4327
4328
a1ec6916 4329SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
1bbd0b84 4330 (SCM z),
1e6808ea 4331 "Return an exact number that is numerically closest to @var{z}.")
1bbd0b84 4332#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 4333{
0aacf84e 4334 if (SCM_INUMP (z))
f872b822 4335 return z;
0aacf84e 4336 else if (SCM_BIGP (z))
f872b822 4337 return z;
0aacf84e
MD		 4338 else if (SCM_REALP (z))
4339 {
2be24db4
KR		 4340 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
4341 powers of 2, so there's no rounding when making "double" values
4342 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could get
4343 rounded on a 64-bit machine, hence the "+1".
4344
4345 The use of floor() to force to an integer value ensures we get a
4346 "numerically closest" value without depending on how a double->long
4347 cast or how mpz_set_d will round. For reference, double->long
4348 probably follows the hardware rounding mode, mpz_set_d truncates
4349 towards zero. */
4350
4351 double u = SCM_REAL_VALUE (z);
4352 if (xisinf (u) || xisnan (u))
0aacf84e 4353 scm_num_overflow (s_scm_inexact_to_exact);
2be24db4
KR		 4354 u = floor (u + 0.5);
4355 if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
4356 && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
4357 return SCM_MAKINUM ((long) u);
4358 else
4359 return scm_i_dbl2big (u);
c2ff8ab0 4360 }
0aacf84e 4361 else
c2ff8ab0 4362 SCM_WRONG_TYPE_ARG (1, z);
0f2d19dd 4363}
1bbd0b84 4364#undef FUNC_NAME
0f2d19dd 4365
87617347 4366/* if you need to change this, change test-num2integral.c as well */
ee33d62a 4367#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 4368# ifndef LLONG_MAX
4369# define ULLONG_MAX ((unsigned long long) (-1))
4370# define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4371# define LLONG_MIN (~LLONG_MAX)
4372# endif
f872b822 4373#endif
0f2d19dd 4374
3d2e8ceb
MV		 4375/* Parameters for creating integer conversion routines.
4376
4377 Define the following preprocessor macros before including
4378 "libguile/num2integral.i.c":
4379
4380 NUM2INTEGRAL - the name of the function for converting from a
ca46fb90
RB		 4381 Scheme object to the integral type. This function will be
4382 defined when including "num2integral.i.c".
3d2e8ceb
MV		 4383
4384 INTEGRAL2NUM - the name of the function for converting from the
ca46fb90 4385 integral type to a Scheme object. This function will be defined.
3d2e8ceb
MV		 4386
4387 INTEGRAL2BIG - the name of an internal function that createas a
ca46fb90
RB		 4388 bignum from the integral type. This function will be defined.
4389 The name should start with "scm_i_".
4390
4391 ITYPE - the name of the integral type.
4392
9dd023e1
MV		 4393 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
4394 it to 0 otherwise.
ca46fb90
RB		 4395
4396 UNSIGNED_ITYPE - the name of the the unsigned variant of the
4397 integral type. If you don't define this, it defaults to
4398 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
4399 ones.
4400
4401 SIZEOF_ITYPE - an expression giving the size of the integral type
4402 in bytes. This expression must be computable by the
4403 preprocessor. (SIZEOF_FOO values are calculated by configure.in
4404 for common types).
4405
3d2e8ceb
MV		 4406*/
4407
1be6b49c
ML		 4408#define NUM2INTEGRAL scm_num2short
4409#define INTEGRAL2NUM scm_short2num
4410#define INTEGRAL2BIG scm_i_short2big
ca46fb90 4411#define UNSIGNED 0
1be6b49c 4412#define ITYPE short
3d2e8ceb 4413#define SIZEOF_ITYPE SIZEOF_SHORT
1be6b49c
ML		 4414#include "libguile/num2integral.i.c"
4415
4416#define NUM2INTEGRAL scm_num2ushort
4417#define INTEGRAL2NUM scm_ushort2num
4418#define INTEGRAL2BIG scm_i_ushort2big
ca46fb90 4419#define UNSIGNED 1
1be6b49c 4420#define ITYPE unsigned short
ca46fb90 4421#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
1be6b49c
ML		 4422#include "libguile/num2integral.i.c"
4423
4424#define NUM2INTEGRAL scm_num2int
4425#define INTEGRAL2NUM scm_int2num
4426#define INTEGRAL2BIG scm_i_int2big
ca46fb90 4427#define UNSIGNED 0
1be6b49c 4428#define ITYPE int
3d2e8ceb 4429#define SIZEOF_ITYPE SIZEOF_INT
1be6b49c
ML		 4430#include "libguile/num2integral.i.c"
4431
4432#define NUM2INTEGRAL scm_num2uint
4433#define INTEGRAL2NUM scm_uint2num
4434#define INTEGRAL2BIG scm_i_uint2big
ca46fb90 4435#define UNSIGNED 1
1be6b49c 4436#define ITYPE unsigned int
ca46fb90 4437#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
1be6b49c
ML		 4438#include "libguile/num2integral.i.c"
4439
4440#define NUM2INTEGRAL scm_num2long
4441#define INTEGRAL2NUM scm_long2num
4442#define INTEGRAL2BIG scm_i_long2big
ca46fb90 4443#define UNSIGNED 0
1be6b49c 4444#define ITYPE long
3d2e8ceb 4445#define SIZEOF_ITYPE SIZEOF_LONG
1be6b49c
ML		 4446#include "libguile/num2integral.i.c"
4447
4448#define NUM2INTEGRAL scm_num2ulong
4449#define INTEGRAL2NUM scm_ulong2num
4450#define INTEGRAL2BIG scm_i_ulong2big
ca46fb90 4451#define UNSIGNED 1
1be6b49c 4452#define ITYPE unsigned long
ca46fb90 4453#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
1be6b49c
ML		 4454#include "libguile/num2integral.i.c"
4455
1be6b49c
ML		 4456#define NUM2INTEGRAL scm_num2ptrdiff
4457#define INTEGRAL2NUM scm_ptrdiff2num
4458#define INTEGRAL2BIG scm_i_ptrdiff2big
ca46fb90 4459#define UNSIGNED 0
ee33d62a 4460#define ITYPE scm_t_ptrdiff
3d2e8ceb 4461#define UNSIGNED_ITYPE size_t
ee33d62a 4462#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
1be6b49c
ML		 4463#include "libguile/num2integral.i.c"
4464
4465#define NUM2INTEGRAL scm_num2size
4466#define INTEGRAL2NUM scm_size2num
4467#define INTEGRAL2BIG scm_i_size2big
ca46fb90 4468#define UNSIGNED 1
1be6b49c 4469#define ITYPE size_t
3d2e8ceb 4470#define SIZEOF_ITYPE SIZEOF_SIZE_T
1be6b49c 4471#include "libguile/num2integral.i.c"
0f2d19dd 4472
ee33d62a 4473#if SCM_SIZEOF_LONG_LONG != 0
1cc91f1b 4474
caf08e65
MV		 4475#ifndef ULONG_LONG_MAX
4476#define ULONG_LONG_MAX (~0ULL)
4477#endif
4478
1be6b49c
ML		 4479#define NUM2INTEGRAL scm_num2long_long
4480#define INTEGRAL2NUM scm_long_long2num
4481#define INTEGRAL2BIG scm_i_long_long2big
ca46fb90 4482#define UNSIGNED 0
1be6b49c 4483#define ITYPE long long
3d2e8ceb 4484#define SIZEOF_ITYPE SIZEOF_LONG_LONG
1be6b49c
ML		 4485#include "libguile/num2integral.i.c"
4486
4487#define NUM2INTEGRAL scm_num2ulong_long
4488#define INTEGRAL2NUM scm_ulong_long2num
4489#define INTEGRAL2BIG scm_i_ulong_long2big
ca46fb90 4490#define UNSIGNED 1
1be6b49c 4491#define ITYPE unsigned long long
ca46fb90 4492#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
1be6b49c 4493#include "libguile/num2integral.i.c"
0f2d19dd 4494
ee33d62a 4495#endif /* SCM_SIZEOF_LONG_LONG != 0 */
caf08e65 4496
5437598b
MD		 4497#define NUM2FLOAT scm_num2float
4498#define FLOAT2NUM scm_float2num
4499#define FTYPE float
4500#include "libguile/num2float.i.c"
4501
4502#define NUM2FLOAT scm_num2double
4503#define FLOAT2NUM scm_double2num
4504#define FTYPE double
4505#include "libguile/num2float.i.c"
4506
1be6b49c 4507#ifdef GUILE_DEBUG
caf08e65 4508
6063dc1d
SJ		 4509#ifndef SIZE_MAX
4510#define SIZE_MAX ((size_t) (-1))
4511#endif
4512#ifndef PTRDIFF_MIN
4513#define PTRDIFF_MIN \
b4fb7de8
RB		 4514 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
4515 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
6063dc1d
SJ		 4516#endif
4517#ifndef PTRDIFF_MAX
4518#define PTRDIFF_MAX (~ PTRDIFF_MIN)
4519#endif
4520
0aacf84e
MD		 4521#define CHECK(type, v) \
4522 do \
4523 { \
4524 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4525 abort (); \
4526 } \
4527 while (0)
caf08e65 4528
1be6b49c
ML		 4529static void
4530check_sanity ()
4531{
4532 CHECK (short, 0);
4533 CHECK (ushort, 0U);
4534 CHECK (int, 0);
4535 CHECK (uint, 0U);
4536 CHECK (long, 0L);
4537 CHECK (ulong, 0UL);
4538 CHECK (size, 0);
4539 CHECK (ptrdiff, 0);
4540
4541 CHECK (short, -1);
4542 CHECK (int, -1);
4543 CHECK (long, -1L);
4544 CHECK (ptrdiff, -1);
4545
4546 CHECK (short, SHRT_MAX);
4547 CHECK (short, SHRT_MIN);
4548 CHECK (ushort, USHRT_MAX);
4549 CHECK (int, INT_MAX);
4550 CHECK (int, INT_MIN);
4551 CHECK (uint, UINT_MAX);
4552 CHECK (long, LONG_MAX);
4553 CHECK (long, LONG_MIN);
4554 CHECK (ulong, ULONG_MAX);
4555 CHECK (size, SIZE_MAX);
4556 CHECK (ptrdiff, PTRDIFF_MAX);
4557 CHECK (ptrdiff, PTRDIFF_MIN);
0f2d19dd 4558
ee33d62a 4559#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 4560 CHECK (long_long, 0LL);
4561 CHECK (ulong_long, 0ULL);
1be6b49c 4562 CHECK (long_long, -1LL);
1be6b49c
ML		 4563 CHECK (long_long, LLONG_MAX);
4564 CHECK (long_long, LLONG_MIN);
4565 CHECK (ulong_long, ULLONG_MAX);
4566#endif
0f2d19dd
JB		 4567}
4568
b10586f0
ML		 4569#undef CHECK
4570
4571#define CHECK \
4572 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4573 if (!SCM_FALSEP (data)) abort();
4574
4575static SCM
4576check_body (void *data)
4577{
4578 SCM num = *(SCM *) data;
4579 scm_num2ulong (num, 1, NULL);
4580
4581 return SCM_UNSPECIFIED;
4582}
4583
4584static SCM
4585check_handler (void *data, SCM tag, SCM throw_args)
4586{
4587 SCM *num = (SCM *) data;
4588 *num = SCM_BOOL_F;
4589
4590 return SCM_UNSPECIFIED;
4591}
4592
4593SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0,
b4e15479 4594 (void),
b10586f0
ML		 4595 "Number conversion sanity checking.")
4596#define FUNC_NAME s_scm_sys_check_number_conversions
4597{
4598 SCM data = SCM_MAKINUM (-1);
4599 CHECK;
4600 data = scm_int2num (INT_MIN);
4601 CHECK;
4602 data = scm_ulong2num (ULONG_MAX);
4603 data = scm_difference (SCM_INUM0, data);
4604 CHECK;
4605 data = scm_ulong2num (ULONG_MAX);
4606 data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data);
4607 CHECK;
4608 data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data);
4609 CHECK;
4610
4611 return SCM_UNSPECIFIED;
4612}
4613#undef FUNC_NAME
4614
1be6b49c 4615#endif
0f2d19dd 4616
0f2d19dd
JB		 4617void
4618scm_init_numbers ()
0f2d19dd 4619{
1be6b49c 4620 abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM);
ac0c002c
DH		 4621 scm_permanent_object (abs_most_negative_fixnum);
4622
713a4259
KR		 4623 mpz_init_set_si (z_negative_one, -1);
4624
a261c0e9
DH		 4625 /* It may be possible to tune the performance of some algorithms by using
4626 * the following constants to avoid the creation of bignums. Please, before
4627 * using these values, remember the two rules of program optimization:
4628 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
86d31dfe
MV		 4629 scm_c_define ("most-positive-fixnum",
4630 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
4631 scm_c_define ("most-negative-fixnum",
4632 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
a261c0e9 4633
f3ae5d60
MD		 4634 scm_add_feature ("complex");
4635 scm_add_feature ("inexact");
5986c47d 4636 scm_flo0 = scm_make_real (0.0);
f872b822 4637#ifdef DBL_DIG
0f2d19dd 4638 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
f872b822 4639#else
0f2d19dd
JB		 4640 { /* determine floating point precision */
4641 double f = 0.1;
f872b822 4642 double fsum = 1.0 + f;
0aacf84e
MD		 4643 while (fsum != 1.0)
4644 {
4645 if (++scm_dblprec > 20)
4646 fsum = 1.0;
4647 else
4648 {
4649 f /= 10.0;
4650 fsum = f + 1.0;
4651 }
f872b822
MD		 4652 }
4653 scm_dblprec = scm_dblprec - 1;
0f2d19dd 4654 }
f872b822 4655#endif /* DBL_DIG */
1be6b49c
ML		 4656
4657#ifdef GUILE_DEBUG
4658 check_sanity ();
4659#endif
4660
a0599745 4661#include "libguile/numbers.x"
0f2d19dd 4662}
89e00824
ML		 4663
4664/*
4665 Local Variables:
4666 c-file-style: "gnu"
4667 End:
4668*/
Unnamed repository; edit this file 'description' to name the repository.