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