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