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