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