HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* numbers.c (scm_make_ratio): Rewritten to have a simpler
[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.
f92e85f7 28 * All objects satisfying SCM_FRACTIONP are never an integer.
ca46fb90
RB		 29 */
30
31/* TODO:
32
33 - see if special casing bignums and reals in integer-exponent when
34 possible (to use mpz_pow and mpf_pow_ui) is faster.
35
36 - look in to better short-circuiting of common cases in
37 integer-expt and elsewhere.
38
39 - see if direct mpz operations can help in ash and elsewhere.
40
41 */
0f2d19dd 42
fa605590
KR		 43/* tell glibc (2.3) to give prototype for C99 trunc() */
44#define _GNU_SOURCE
45
ee33d62a
RB		 46#if HAVE_CONFIG_H
47# include <config.h>
48#endif
49
0f2d19dd 50#include <math.h>
3c9a524f 51#include <ctype.h>
fc194577 52#include <string.h>
ca46fb90 53#include <gmp.h>
f92e85f7 54
a0599745 55#include "libguile/_scm.h"
a0599745
MD		 56#include "libguile/feature.h"
57#include "libguile/ports.h"
58#include "libguile/root.h"
59#include "libguile/smob.h"
60#include "libguile/strings.h"
a0599745
MD		 61
62#include "libguile/validate.h"
63#include "libguile/numbers.h"
1be6b49c 64#include "libguile/deprecation.h"
f4c627b3 65
f92e85f7
MV		 66#include "libguile/eq.h"
67
0f2d19dd 68\f
f4c627b3 69
ca46fb90
RB		 70/*
71 Wonder if this might be faster for some of our code? A switch on
72 the numtag would jump directly to the right case, and the
73 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
74
75 #define SCM_I_NUMTAG_NOTNUM 0
76 #define SCM_I_NUMTAG_INUM 1
77 #define SCM_I_NUMTAG_BIG scm_tc16_big
78 #define SCM_I_NUMTAG_REAL scm_tc16_real
79 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
80 #define SCM_I_NUMTAG(x) \
81 (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \
82 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
534c55a9 83 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
ca46fb90
RB		 84 : SCM_I_NUMTAG_NOTNUM)))
85*/
f92e85f7 86/* the macro above will not work as is with fractions */
f4c627b3
DH		 87
88
34d19ef6 89#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
09fb7599 90
56e55ac7 91/* FLOBUFLEN is the maximum number of characters neccessary for the
3a9809df
DH		 92 * printed or scm_string representation of an inexact number.
93 */
56e55ac7 94#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
3a9809df 95
7351e207
MV		 96#if defined (SCO)
97#if ! defined (HAVE_ISNAN)
98#define HAVE_ISNAN
99static int
100isnan (double x)
101{
102 return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0;
103}
0f2d19dd 104#endif
7351e207
MV		 105#if ! defined (HAVE_ISINF)
106#define HAVE_ISINF
107static int
108isinf (double x)
109{
110 return (IsNANorINF (x) && IsINF (x)) ? 1 : 0;
111}
0f2d19dd 112
7351e207 113#endif
e6f3ef58
MD		 114#endif
115
b127c712
KR		 116
117/* mpz_cmp_d only recognises infinities in gmp 4.2 and up.
118 For prior versions use an explicit check here. */
119#if __GNU_MP_VERSION < 4 \
120 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
121#define xmpz_cmp_d(z, d) \
122 (xisinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
123#else
124#define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
125#endif
126
f92e85f7
MV		 127static int
128xisinf (double x)
129{
130#if defined (HAVE_ISINF)
131 return isinf (x);
132#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
133 return (! (finite (x) || isnan (x)));
134#else
135 return 0;
136#endif
137}
138
139static int
140xisnan (double x)
141{
142#if defined (HAVE_ISNAN)
143 return isnan (x);
144#else
145 return 0;
146#endif
147}
148
0f2d19dd
JB		 149\f
150
ac0c002c 151static SCM abs_most_negative_fixnum;
713a4259 152static mpz_t z_negative_one;
ac0c002c
DH		 153
154\f
155
ca46fb90
RB		 156static const char s_bignum[] = "bignum";
157
570b6821 158SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 159scm_i_mkbig ()
160{
161 /* Return a newly created bignum. */
162 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
163 mpz_init (SCM_I_BIG_MPZ (z));
164 return z;
165}
166
570b6821 167SCM_C_INLINE_KEYWORD static SCM
ca46fb90
RB		 168scm_i_clonebig (SCM src_big, int same_sign_p)
169{
170 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
171 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
172 mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
0aacf84e
MD		 173 if (!same_sign_p)
174 mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
ca46fb90
RB		 175 return z;
176}
177
570b6821 178SCM_C_INLINE_KEYWORD int
ca46fb90
RB		 179scm_i_bigcmp (SCM x, SCM y)
180{
181 /* Return neg if x < y, pos if x > y, and 0 if x == y */
182 /* presume we already know x and y are bignums */
183 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
184 scm_remember_upto_here_2 (x, y);
185 return result;
186}
187
570b6821 188SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 189scm_i_dbl2big (double d)
190{
191 /* results are only defined if d is an integer */
192 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
193 mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
194 return z;
195}
196
f92e85f7
MV		 197/* Convert a integer in double representation to a SCM number. */
198
199SCM_C_INLINE_KEYWORD SCM
200scm_i_dbl2num (double u)
201{
202 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
203 powers of 2, so there's no rounding when making "double" values
204 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
205 get rounded on a 64-bit machine, hence the "+1".
206
207 The use of floor() to force to an integer value ensures we get a
208 "numerically closest" value without depending on how a
209 double->long cast or how mpz_set_d will round. For reference,
210 double->long probably follows the hardware rounding mode,
211 mpz_set_d truncates towards zero. */
212
213 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
214 representable as a double? */
215
216 if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
217 && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
218 return SCM_MAKINUM ((long) u);
219 else
220 return scm_i_dbl2big (u);
221}
222
089c9a59
KR		 223/* scm_i_big2dbl() rounds to the closest representable double, in accordance
224 with R5RS exact->inexact.
225
226 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
227 (ie. it truncates towards zero), then adjust to get the closest double by
228 examining the next lower bit and adding 1 if necessary.
229
230 Note that bignums exactly half way between representable doubles are
231 rounded to the next higher absolute value (ie. away from zero). This
232 seems like an adequate interpretation of R5RS "numerically closest", and
233 it's easier and faster than a full "nearest-even" style.
234
235 The bit test is done on the absolute value of the mpz_t, which means we
236 must use mpz_getlimbn. mpz_tstbit is not right, it treats negatives as
237 twos complement.
238
239 Prior to GMP 4.2, the rounding done by mpz_get_d was unspecified. It
240 happened to follow the hardware rounding mode, but on the absolute value
241 of its operand. This is not what we want, so we put the high
242 DBL_MANT_DIG bits into a temporary. This extra init/clear is a slowdown,
243 but doesn't matter too much since it's only for older GMP. */
244
245double
ca46fb90
RB		 246scm_i_big2dbl (SCM b)
247{
089c9a59
KR		 248 double result;
249 size_t bits;
250
251 bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
252
253#if __GNU_MP_VERSION < 4 \
254 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
255 {
256 /* GMP prior to 4.2, force truncate towards zero */
257 mpz_t tmp;
258 if (bits > DBL_MANT_DIG)
259 {
260 size_t shift = bits - DBL_MANT_DIG;
261 mpz_init2 (tmp, DBL_MANT_DIG);
262 mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
263 result = ldexp (mpz_get_d (tmp), shift);
264 mpz_clear (tmp);
265 }
266 else
267 {
268 result = mpz_get_d (SCM_I_BIG_MPZ (b));
269 }
270 }
271#else
272 /* GMP 4.2 and up */
273 result = mpz_get_d (SCM_I_BIG_MPZ (b));
274#endif
275
276 if (bits > DBL_MANT_DIG)
277 {
278 unsigned long pos = bits - DBL_MANT_DIG - 1;
279 /* test bit number "pos" in absolute value */
280 if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
281 & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
282 {
283 result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
284 }
285 }
286
ca46fb90
RB		 287 scm_remember_upto_here_1 (b);
288 return result;
289}
290
570b6821 291SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 292scm_i_normbig (SCM b)
293{
294 /* convert a big back to a fixnum if it'll fit */
295 /* presume b is a bignum */
296 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
297 {
298 long val = mpz_get_si (SCM_I_BIG_MPZ (b));
299 if (SCM_FIXABLE (val))
300 b = SCM_MAKINUM (val);
301 }
302 return b;
303}
f872b822 304
f92e85f7
MV		 305static SCM_C_INLINE_KEYWORD SCM
306scm_i_mpz2num (mpz_t b)
307{
308 /* convert a mpz number to a SCM number. */
309 if (mpz_fits_slong_p (b))
310 {
311 long val = mpz_get_si (b);
312 if (SCM_FIXABLE (val))
313 return SCM_MAKINUM (val);
314 }
315
316 {
317 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
318 mpz_init_set (SCM_I_BIG_MPZ (z), b);
319 return z;
320 }
321}
322
323/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
324static SCM scm_divide2real (SCM x, SCM y);
325
326SCM
327scm_make_ratio (SCM numerator, SCM denominator)
c60e130c 328#define FUNC_NAME "make-ratio"
f92e85f7 329{
c60e130c
MV		 330 /* First make sure the arguments are proper.
331 */
f92e85f7
MV		 332 if (SCM_INUMP (denominator))
333 {
334 if (SCM_EQ_P (denominator, SCM_INUM0))
335 scm_num_overflow ("make-ratio");
336 if (SCM_EQ_P (denominator, SCM_MAKINUM(1)))
337 return numerator;
338 }
339 else
340 {
341 if (!(SCM_BIGP(denominator)))
342 SCM_WRONG_TYPE_ARG (2, denominator);
343 }
c60e130c
MV		 344 if (!SCM_INUMP (numerator) && !SCM_BIGP (numerator))
345 SCM_WRONG_TYPE_ARG (1, numerator);
346
347 /* Then flip signs so that the denominator is positive.
348 */
349 if (SCM_NFALSEP (scm_negative_p (denominator)))
350 {
351 numerator = scm_difference (numerator, SCM_UNDEFINED);
352 denominator = scm_difference (denominator, SCM_UNDEFINED);
353 }
354
355 /* Now consider for each of the four fixnum/bignum combinations
356 whether the rational number is really an integer.
357 */
f92e85f7
MV		 358 if (SCM_INUMP (numerator))
359 {
360 if (SCM_EQ_P (numerator, SCM_INUM0))
361 return SCM_INUM0;
362 if (SCM_INUMP (denominator))
363 {
364 long x, y;
365 x = SCM_INUM (numerator);
366 y = SCM_INUM (denominator);
367 if (x == y)
368 return SCM_MAKINUM(1);
369 if ((x % y) == 0)
370 return SCM_MAKINUM (x / y);
f92e85f7
MV		 371 }
372 }
c60e130c 373 else if (SCM_BIGP (numerator))
f92e85f7 374 {
c60e130c
MV		 375 if (SCM_INUMP (denominator))
376 {
377 long yy = SCM_INUM (denominator);
378 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
379 return scm_divide (numerator, denominator);
380 }
381 else
f92e85f7 382 {
c60e130c
MV		 383 if (SCM_EQ_P (numerator, denominator))
384 return SCM_MAKINUM(1);
385 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
386 SCM_I_BIG_MPZ (denominator)))
387 return scm_divide(numerator, denominator);
f92e85f7 388 }
f92e85f7 389 }
c60e130c
MV		 390
391 /* No, it's a proper fraction.
392 */
393 return scm_double_cell (scm_tc16_fraction,
394 SCM_UNPACK (numerator),
395 SCM_UNPACK (denominator), 0);
f92e85f7 396}
c60e130c 397#undef FUNC_NAME
f92e85f7
MV		 398
399static void scm_i_fraction_reduce (SCM z)
400{
401 if (!(SCM_FRACTION_REDUCED (z)))
402 {
403 SCM divisor;
404 divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z));
405 if (!(SCM_EQ_P (divisor, SCM_MAKINUM(1))))
406 {
407 /* is this safe? */
408 SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor));
409 SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor));
410 }
411 SCM_FRACTION_REDUCED_SET (z);
412 }
413}
414
415double
416scm_i_fraction2double (SCM z)
417{
418 return scm_num2dbl (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
419 SCM_FRACTION_DENOMINATOR (z)),
420 "fraction2real");
421}
422
a1ec6916 423SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
1bbd0b84 424 (SCM x),
942e5b91
MG		 425 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
426 "otherwise.")
1bbd0b84 427#define FUNC_NAME s_scm_exact_p
0f2d19dd 428{
0aacf84e
MD		 429 if (SCM_INUMP (x))
430 return SCM_BOOL_T;
431 if (SCM_BIGP (x))
432 return SCM_BOOL_T;
f92e85f7
MV		 433 if (SCM_FRACTIONP (x))
434 return SCM_BOOL_T;
eb927cb9
MV		 435 if (SCM_NUMBERP (x))
436 return SCM_BOOL_F;
437 SCM_WRONG_TYPE_ARG (1, x);
0f2d19dd 438}
1bbd0b84 439#undef FUNC_NAME
0f2d19dd 440
4219f20d 441
a1ec6916 442SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
1bbd0b84 443 (SCM n),
942e5b91
MG		 444 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
445 "otherwise.")
1bbd0b84 446#define FUNC_NAME s_scm_odd_p
0f2d19dd 447{
0aacf84e
MD		 448 if (SCM_INUMP (n))
449 {
450 long val = SCM_INUM (n);
451 return SCM_BOOL ((val & 1L) != 0);
452 }
453 else if (SCM_BIGP (n))
454 {
455 int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
456 scm_remember_upto_here_1 (n);
457 return SCM_BOOL (odd_p);
458 }
459 else if (!SCM_FALSEP (scm_inf_p (n)))
7351e207 460 return SCM_BOOL_T;
f92e85f7
MV		 461 else if (SCM_REALP (n))
462 {
463 double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
464 if (rem == 1.0)
465 return SCM_BOOL_T;
466 else if (rem == 0.0)
467 return SCM_BOOL_F;
468 else
469 SCM_WRONG_TYPE_ARG (1, n);
470 }
0aacf84e 471 else
a1a33b0f 472 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 473}
1bbd0b84 474#undef FUNC_NAME
0f2d19dd 475
4219f20d 476
a1ec6916 477SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
1bbd0b84 478 (SCM n),
942e5b91
MG		 479 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
480 "otherwise.")
1bbd0b84 481#define FUNC_NAME s_scm_even_p
0f2d19dd 482{
0aacf84e
MD		 483 if (SCM_INUMP (n))
484 {
485 long val = SCM_INUM (n);
486 return SCM_BOOL ((val & 1L) == 0);
487 }
488 else if (SCM_BIGP (n))
489 {
490 int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
491 scm_remember_upto_here_1 (n);
492 return SCM_BOOL (even_p);
493 }
494 else if (!SCM_FALSEP (scm_inf_p (n)))
7351e207 495 return SCM_BOOL_T;
f92e85f7
MV		 496 else if (SCM_REALP (n))
497 {
498 double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
499 if (rem == 1.0)
500 return SCM_BOOL_F;
501 else if (rem == 0.0)
502 return SCM_BOOL_T;
503 else
504 SCM_WRONG_TYPE_ARG (1, n);
505 }
0aacf84e 506 else
a1a33b0f 507 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 508}
1bbd0b84 509#undef FUNC_NAME
0f2d19dd 510
7351e207
MV		 511SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
512 (SCM n),
513 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
514 "otherwise.")
515#define FUNC_NAME s_scm_inf_p
516{
0aacf84e 517 if (SCM_REALP (n))
7351e207 518 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n)));
0aacf84e 519 else if (SCM_COMPLEXP (n))
7351e207
MV		 520 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n))
521 || xisinf (SCM_COMPLEX_IMAG (n)));
0aacf84e 522 else
7351e207 523 return SCM_BOOL_F;
7351e207
MV		 524}
525#undef FUNC_NAME
526
527SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
528 (SCM n),
529 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
530 "otherwise.")
531#define FUNC_NAME s_scm_nan_p
532{
0aacf84e 533 if (SCM_REALP (n))
7351e207 534 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n)));
0aacf84e 535 else if (SCM_COMPLEXP (n))
7351e207
MV		 536 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n))
537 || xisnan (SCM_COMPLEX_IMAG (n)));
0aacf84e 538 else
7351e207 539 return SCM_BOOL_F;
7351e207
MV		 540}
541#undef FUNC_NAME
542
543/* Guile's idea of infinity. */
544static double guile_Inf;
545
546/* Guile's idea of not a number. */
547static double guile_NaN;
548
549static void
550guile_ieee_init (void)
551{
552#if defined (HAVE_ISINF) || defined (HAVE_FINITE)
553
554/* Some version of gcc on some old version of Linux used to crash when
555 trying to make Inf and NaN. */
556
557#if defined (SCO)
558 double tmp = 1.0;
559 guile_Inf = 1.0 / (tmp - tmp);
560#elif defined (__alpha__) && ! defined (linux)
561 extern unsigned int DINFINITY[2];
562 guile_Inf = (*(X_CAST(double *, DINFINITY)));
563#else
564 double tmp = 1e+10;
565 guile_Inf = tmp;
566 for (;;)
567 {
568 guile_Inf *= 1e+10;
569 if (guile_Inf == tmp)
570 break;
571 tmp = guile_Inf;
572 }
573#endif
574
575#endif
576
577#if defined (HAVE_ISNAN)
578
579#if defined (__alpha__) && ! defined (linux)
580 extern unsigned int DQNAN[2];
581 guile_NaN = (*(X_CAST(double *, DQNAN)));
582#else
583 guile_NaN = guile_Inf / guile_Inf;
584#endif
585
586#endif
587}
588
589SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
590 (void),
591 "Return Inf.")
592#define FUNC_NAME s_scm_inf
593{
594 static int initialized = 0;
595 if (! initialized)
596 {
597 guile_ieee_init ();
598 initialized = 1;
599 }
600 return scm_make_real (guile_Inf);
601}
602#undef FUNC_NAME
603
604SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
605 (void),
606 "Return NaN.")
607#define FUNC_NAME s_scm_nan
608{
609 static int initialized = 0;
0aacf84e 610 if (!initialized)
7351e207
MV		 611 {
612 guile_ieee_init ();
613 initialized = 1;
614 }
615 return scm_make_real (guile_NaN);
616}
617#undef FUNC_NAME
618
4219f20d 619
a48d60b1
MD		 620SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
621 (SCM x),
622 "Return the absolute value of @var{x}.")
623#define FUNC_NAME
0f2d19dd 624{
0aacf84e
MD		 625 if (SCM_INUMP (x))
626 {
627 long int xx = SCM_INUM (x);
628 if (xx >= 0)
629 return x;
630 else if (SCM_POSFIXABLE (-xx))
631 return SCM_MAKINUM (-xx);
632 else
633 return scm_i_long2big (-xx);
4219f20d 634 }
0aacf84e
MD		 635 else if (SCM_BIGP (x))
636 {
637 const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
638 if (sgn < 0)
639 return scm_i_clonebig (x, 0);
640 else
641 return x;
4219f20d 642 }
0aacf84e 643 else if (SCM_REALP (x))
5986c47d 644 return scm_make_real (fabs (SCM_REAL_VALUE (x)));
f92e85f7
MV		 645 else if (SCM_FRACTIONP (x))
646 {
647 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
648 return x;
649 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
650 SCM_FRACTION_DENOMINATOR (x));
651 }
0aacf84e 652 else
a48d60b1 653 SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
0f2d19dd 654}
a48d60b1 655#undef FUNC_NAME
0f2d19dd 656
4219f20d 657
9de33deb 658SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
942e5b91
MG		 659/* "Return the quotient of the numbers @var{x} and @var{y}."
660 */
0f2d19dd 661SCM
6e8d25a6 662scm_quotient (SCM x, SCM y)
0f2d19dd 663{
0aacf84e
MD		 664 if (SCM_INUMP (x))
665 {
666 long xx = SCM_INUM (x);
667 if (SCM_INUMP (y))
668 {
669 long yy = SCM_INUM (y);
670 if (yy == 0)
671 scm_num_overflow (s_quotient);
672 else
673 {
674 long z = xx / yy;
675 if (SCM_FIXABLE (z))
676 return SCM_MAKINUM (z);
677 else
678 return scm_i_long2big (z);
679 }
828865c3 680 }
0aacf84e 681 else if (SCM_BIGP (y))
ac0c002c 682 {
0aacf84e
MD		 683 if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
684 && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
685 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
686 return SCM_MAKINUM (-1);
687 else
688 return SCM_MAKINUM (0);
ac0c002c
DH		 689 }
690 else
0aacf84e 691 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
828865c3 692 }
0aacf84e
MD		 693 else if (SCM_BIGP (x))
694 {
695 if (SCM_INUMP (y))
696 {
697 long yy = SCM_INUM (y);
698 if (yy == 0)
699 scm_num_overflow (s_quotient);
700 else if (yy == 1)
701 return x;
702 else
703 {
704 SCM result = scm_i_mkbig ();
705 if (yy < 0)
706 {
707 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result),
708 SCM_I_BIG_MPZ (x),
709 - yy);
710 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
711 }
712 else
713 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
714 scm_remember_upto_here_1 (x);
715 return scm_i_normbig (result);
716 }
717 }
718 else if (SCM_BIGP (y))
719 {
720 SCM result = scm_i_mkbig ();
721 mpz_tdiv_q (SCM_I_BIG_MPZ (result),
722 SCM_I_BIG_MPZ (x),
723 SCM_I_BIG_MPZ (y));
724 scm_remember_upto_here_2 (x, y);
725 return scm_i_normbig (result);
726 }
727 else
728 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
f872b822 729 }
0aacf84e 730 else
89a7e495 731 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient);
0f2d19dd
JB		 732}
733
9de33deb 734SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
942e5b91
MG		 735/* "Return the remainder of the numbers @var{x} and @var{y}.\n"
736 * "@lisp\n"
737 * "(remainder 13 4) @result{} 1\n"
738 * "(remainder -13 4) @result{} -1\n"
739 * "@end lisp"
740 */
0f2d19dd 741SCM
6e8d25a6 742scm_remainder (SCM x, SCM y)
0f2d19dd 743{
0aacf84e
MD		 744 if (SCM_INUMP (x))
745 {
746 if (SCM_INUMP (y))
747 {
748 long yy = SCM_INUM (y);
749 if (yy == 0)
750 scm_num_overflow (s_remainder);
751 else
752 {
753 long z = SCM_INUM (x) % yy;
754 return SCM_MAKINUM (z);
755 }
756 }
757 else if (SCM_BIGP (y))
ac0c002c 758 {
0aacf84e
MD		 759 if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
760 && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
761 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
762 return SCM_MAKINUM (0);
763 else
764 return x;
ac0c002c
DH		 765 }
766 else
0aacf84e 767 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
89a7e495 768 }
0aacf84e
MD		 769 else if (SCM_BIGP (x))
770 {
771 if (SCM_INUMP (y))
772 {
773 long yy = SCM_INUM (y);
774 if (yy == 0)
775 scm_num_overflow (s_remainder);
776 else
777 {
778 SCM result = scm_i_mkbig ();
779 if (yy < 0)
780 yy = - yy;
781 mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
782 scm_remember_upto_here_1 (x);
783 return scm_i_normbig (result);
784 }
785 }
786 else if (SCM_BIGP (y))
787 {
788 SCM result = scm_i_mkbig ();
789 mpz_tdiv_r (SCM_I_BIG_MPZ (result),
790 SCM_I_BIG_MPZ (x),
791 SCM_I_BIG_MPZ (y));
792 scm_remember_upto_here_2 (x, y);
793 return scm_i_normbig (result);
794 }
795 else
796 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
f872b822 797 }
0aacf84e 798 else
89a7e495 799 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder);
0f2d19dd
JB		 800}
801
89a7e495 802
9de33deb 803SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
942e5b91
MG		 804/* "Return the modulo of the numbers @var{x} and @var{y}.\n"
805 * "@lisp\n"
806 * "(modulo 13 4) @result{} 1\n"
807 * "(modulo -13 4) @result{} 3\n"
808 * "@end lisp"
809 */
0f2d19dd 810SCM
6e8d25a6 811scm_modulo (SCM x, SCM y)
0f2d19dd 812{
0aacf84e
MD		 813 if (SCM_INUMP (x))
814 {
815 long xx = SCM_INUM (x);
816 if (SCM_INUMP (y))
817 {
818 long yy = SCM_INUM (y);
819 if (yy == 0)
820 scm_num_overflow (s_modulo);
821 else
822 {
823 /* FIXME: I think this may be a bug on some arches -- results
824 of % with negative second arg are undefined... */
825 long z = xx % yy;
826 long result;
827
828 if (yy < 0)
829 {
830 if (z > 0)
831 result = z + yy;
832 else
833 result = z;
834 }
835 else
836 {
837 if (z < 0)
838 result = z + yy;
839 else
840 result = z;
841 }
842 return SCM_MAKINUM (result);
843 }
844 }
845 else if (SCM_BIGP (y))
846 {
847 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
848
849 if (sgn_y == 0)
850 scm_num_overflow (s_modulo);
851 else
852 {
853 mpz_t z_x;
854 SCM result;
855
856 if (sgn_y < 0)
857 {
858 SCM pos_y = scm_i_clonebig (y, 0);
859 /* do this after the last scm_op */
860 mpz_init_set_si (z_x, xx);
861 result = pos_y; /* re-use this bignum */
862 mpz_mod (SCM_I_BIG_MPZ (result),
863 z_x,
864 SCM_I_BIG_MPZ (pos_y));
865 scm_remember_upto_here_1 (pos_y);
866 }
867 else
868 {
869 result = scm_i_mkbig ();
870 /* do this after the last scm_op */
871 mpz_init_set_si (z_x, xx);
872 mpz_mod (SCM_I_BIG_MPZ (result),
873 z_x,
874 SCM_I_BIG_MPZ (y));
875 scm_remember_upto_here_1 (y);
876 }
ca46fb90 877
0aacf84e
MD		 878 if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
879 mpz_add (SCM_I_BIG_MPZ (result),
880 SCM_I_BIG_MPZ (y),
881 SCM_I_BIG_MPZ (result));
882 scm_remember_upto_here_1 (y);
883 /* and do this before the next one */
884 mpz_clear (z_x);
885 return scm_i_normbig (result);
886 }
887 }
888 else
889 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
f872b822 890 }
0aacf84e
MD		 891 else if (SCM_BIGP (x))
892 {
893 if (SCM_INUMP (y))
894 {
895 long yy = SCM_INUM (y);
896 if (yy == 0)
897 scm_num_overflow (s_modulo);
898 else
899 {
900 SCM result = scm_i_mkbig ();
901 mpz_mod_ui (SCM_I_BIG_MPZ (result),
902 SCM_I_BIG_MPZ (x),
903 (yy < 0) ? - yy : yy);
904 scm_remember_upto_here_1 (x);
905 if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
906 mpz_sub_ui (SCM_I_BIG_MPZ (result),
907 SCM_I_BIG_MPZ (result),
908 - yy);
909 return scm_i_normbig (result);
910 }
911 }
912 else if (SCM_BIGP (y))
913 {
914 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
915 if (sgn_y == 0)
916 scm_num_overflow (s_modulo);
917 else
918 {
919 SCM result = scm_i_mkbig ();
920 int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
921 SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
922 mpz_mod (SCM_I_BIG_MPZ (result),
923 SCM_I_BIG_MPZ (x),
924 SCM_I_BIG_MPZ (pos_y));
ca46fb90 925
0aacf84e
MD		 926 scm_remember_upto_here_1 (x);
927 if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
928 mpz_add (SCM_I_BIG_MPZ (result),
929 SCM_I_BIG_MPZ (y),
930 SCM_I_BIG_MPZ (result));
931 scm_remember_upto_here_2 (y, pos_y);
932 return scm_i_normbig (result);
933 }
934 }
935 else
936 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
828865c3 937 }
0aacf84e 938 else
09fb7599 939 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
0f2d19dd
JB		 940}
941
9de33deb 942SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
942e5b91
MG		 943/* "Return the greatest common divisor of all arguments.\n"
944 * "If called without arguments, 0 is returned."
945 */
0f2d19dd 946SCM
6e8d25a6 947scm_gcd (SCM x, SCM y)
0f2d19dd 948{
ca46fb90 949 if (SCM_UNBNDP (y))
0aacf84e 950 return SCM_UNBNDP (x) ? SCM_INUM0 : x;
ca46fb90
RB		 951
952 if (SCM_INUMP (x))
953 {
954 if (SCM_INUMP (y))
955 {
956 long xx = SCM_INUM (x);
957 long yy = SCM_INUM (y);
958 long u = xx < 0 ? -xx : xx;
959 long v = yy < 0 ? -yy : yy;
960 long result;
0aacf84e
MD		 961 if (xx == 0)
962 result = v;
963 else if (yy == 0)
964 result = u;
965 else
966 {
967 long k = 1;
968 long t;
969 /* Determine a common factor 2^k */
970 while (!(1 & (u | v)))
971 {
972 k <<= 1;
973 u >>= 1;
974 v >>= 1;
975 }
976 /* Now, any factor 2^n can be eliminated */
977 if (u & 1)
978 t = -v;
979 else
980 {
981 t = u;
982 b3:
983 t = SCM_SRS (t, 1);
984 }
985 if (!(1 & t))
986 goto b3;
987 if (t > 0)
988 u = t;
989 else
990 v = -t;
991 t = u - v;
992 if (t != 0)
993 goto b3;
994 result = u * k;
995 }
996 return (SCM_POSFIXABLE (result)
997 ? SCM_MAKINUM (result)
998 : scm_i_long2big (result));
ca46fb90
RB		 999 }
1000 else if (SCM_BIGP (y))
1001 {
1002 SCM result = scm_i_mkbig ();
1003 SCM mx = scm_i_mkbig ();
0aacf84e 1004 mpz_set_si (SCM_I_BIG_MPZ (mx), SCM_INUM (x));
ca46fb90 1005 scm_remember_upto_here_1 (x);
0aacf84e
MD		 1006 mpz_gcd (SCM_I_BIG_MPZ (result),
1007 SCM_I_BIG_MPZ (mx),
1008 SCM_I_BIG_MPZ (y));
1009 scm_remember_upto_here_2 (mx, y);
ca46fb90
RB		 1010 return scm_i_normbig (result);
1011 }
1012 else
1013 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
f872b822 1014 }
ca46fb90
RB		 1015 else if (SCM_BIGP (x))
1016 {
1017 if (SCM_INUMP (y))
1018 {
1019 unsigned long result;
1020 long yy = SCM_INUM (y);
8c5b0afc
KR		 1021 if (yy == 0)
1022 return scm_abs (x);
0aacf84e
MD		 1023 if (yy < 0)
1024 yy = -yy;
ca46fb90
RB		 1025 result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
1026 scm_remember_upto_here_1 (x);
0aacf84e
MD		 1027 return (SCM_POSFIXABLE (result)
1028 ? SCM_MAKINUM (result)
1029 : scm_ulong2num (result));
ca46fb90
RB		 1030 }
1031 else if (SCM_BIGP (y))
1032 {
1033 SCM result = scm_i_mkbig ();
0aacf84e
MD		 1034 mpz_gcd (SCM_I_BIG_MPZ (result),
1035 SCM_I_BIG_MPZ (x),
1036 SCM_I_BIG_MPZ (y));
1037 scm_remember_upto_here_2 (x, y);
ca46fb90
RB		 1038 return scm_i_normbig (result);
1039 }
1040 else
1041 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
09fb7599 1042 }
ca46fb90 1043 else
09fb7599 1044 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
0f2d19dd
JB		 1045}
1046
9de33deb 1047SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
942e5b91
MG		 1048/* "Return the least common multiple of the arguments.\n"
1049 * "If called without arguments, 1 is returned."
1050 */
0f2d19dd 1051SCM
6e8d25a6 1052scm_lcm (SCM n1, SCM n2)
0f2d19dd 1053{
ca46fb90
RB		 1054 if (SCM_UNBNDP (n2))
1055 {
1056 if (SCM_UNBNDP (n1))
1057 return SCM_MAKINUM (1L);
09fb7599
DH		 1058 n2 = SCM_MAKINUM (1L);
1059 }
09fb7599 1060
09fb7599 1061 SCM_GASSERT2 (SCM_INUMP (n1) || SCM_BIGP (n1),
ca46fb90 1062 g_lcm, n1, n2, SCM_ARG1, s_lcm);
09fb7599 1063 SCM_GASSERT2 (SCM_INUMP (n2) || SCM_BIGP (n2),
ca46fb90 1064 g_lcm, n1, n2, SCM_ARGn, s_lcm);
09fb7599 1065
ca46fb90
RB		 1066 if (SCM_INUMP (n1))
1067 {
1068 if (SCM_INUMP (n2))
1069 {
1070 SCM d = scm_gcd (n1, n2);
1071 if (SCM_EQ_P (d, SCM_INUM0))
1072 return d;
1073 else
1074 return scm_abs (scm_product (n1, scm_quotient (n2, d)));
1075 }
1076 else
1077 {
1078 /* inum n1, big n2 */
1079 inumbig:
1080 {
1081 SCM result = scm_i_mkbig ();
1082 long nn1 = SCM_INUM (n1);
1083 if (nn1 == 0) return SCM_INUM0;
1084 if (nn1 < 0) nn1 = - nn1;
1085 mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
1086 scm_remember_upto_here_1 (n2);
1087 return result;
1088 }
1089 }
1090 }
1091 else
1092 {
1093 /* big n1 */
1094 if (SCM_INUMP (n2))
1095 {
1096 SCM_SWAP (n1, n2);
1097 goto inumbig;
1098 }
1099 else
1100 {
1101 SCM result = scm_i_mkbig ();
1102 mpz_lcm(SCM_I_BIG_MPZ (result),
1103 SCM_I_BIG_MPZ (n1),
1104 SCM_I_BIG_MPZ (n2));
1105 scm_remember_upto_here_2(n1, n2);
1106 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
1107 return result;
1108 }
f872b822 1109 }
0f2d19dd
JB		 1110}
1111
0f2d19dd 1112#ifndef scm_long2num
c1bfcf60
GB		 1113#define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
1114#else
1115#define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
1116#endif
1117
8a525303
GB		 1118/* Emulating 2's complement bignums with sign magnitude arithmetic:
1119
1120 Logand:
1121 X Y Result Method:
1122 (len)
1123 + + + x (map digit:logand X Y)
1124 + - + x (map digit:logand X (lognot (+ -1 Y)))
1125 - + + y (map digit:logand (lognot (+ -1 X)) Y)
1126 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
1127
1128 Logior:
1129 X Y Result Method:
1130
1131 + + + (map digit:logior X Y)
1132 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
1133 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
1134 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
1135
1136 Logxor:
1137 X Y Result Method:
1138
1139 + + + (map digit:logxor X Y)
1140 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
1141 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
1142 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
1143
1144 Logtest:
1145 X Y Result
1146
1147 + + (any digit:logand X Y)
1148 + - (any digit:logand X (lognot (+ -1 Y)))
1149 - + (any digit:logand (lognot (+ -1 X)) Y)
1150 - - #t
1151
1152*/
1153
c3ee7520 1154SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
1bbd0b84 1155 (SCM n1, SCM n2),
3c3db128
GH		 1156 "Return the bitwise AND of the integer arguments.\n\n"
1157 "@lisp\n"
1158 "(logand) @result{} -1\n"
1159 "(logand 7) @result{} 7\n"
1160 "(logand #b111 #b011 #\b001) @result{} 1\n"
1161 "@end lisp")
1bbd0b84 1162#define FUNC_NAME s_scm_logand
0f2d19dd 1163{
9a00c9fc
DH		 1164 long int nn1;
1165
0aacf84e
MD		 1166 if (SCM_UNBNDP (n2))
1167 {
1168 if (SCM_UNBNDP (n1))
1169 return SCM_MAKINUM (-1);
1170 else if (!SCM_NUMBERP (n1))
1171 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
1172 else if (SCM_NUMBERP (n1))
1173 return n1;
1174 else
1175 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 1176 }
09fb7599 1177
0aacf84e
MD		 1178 if (SCM_INUMP (n1))
1179 {
9a00c9fc 1180 nn1 = SCM_INUM (n1);
0aacf84e
MD		 1181 if (SCM_INUMP (n2))
1182 {
1183 long nn2 = SCM_INUM (n2);
1184 return SCM_MAKINUM (nn1 & nn2);
1185 }
1186 else if SCM_BIGP (n2)
1187 {
1188 intbig:
1189 if (n1 == 0)
1190 return SCM_INUM0;
1191 {
1192 SCM result_z = scm_i_mkbig ();
1193 mpz_t nn1_z;
1194 mpz_init_set_si (nn1_z, nn1);
1195 mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1196 scm_remember_upto_here_1 (n2);
1197 mpz_clear (nn1_z);
1198 return scm_i_normbig (result_z);
1199 }
1200 }
1201 else
1202 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1203 }
1204 else if (SCM_BIGP (n1))
1205 {
1206 if (SCM_INUMP (n2))
1207 {
1208 SCM_SWAP (n1, n2);
1209 nn1 = SCM_INUM (n1);
1210 goto intbig;
1211 }
1212 else if (SCM_BIGP (n2))
1213 {
1214 SCM result_z = scm_i_mkbig ();
1215 mpz_and (SCM_I_BIG_MPZ (result_z),
1216 SCM_I_BIG_MPZ (n1),
1217 SCM_I_BIG_MPZ (n2));
1218 scm_remember_upto_here_2 (n1, n2);
1219 return scm_i_normbig (result_z);
1220 }
1221 else
1222 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 1223 }
0aacf84e 1224 else
09fb7599 1225 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 1226}
1bbd0b84 1227#undef FUNC_NAME
0f2d19dd 1228
09fb7599 1229
c3ee7520 1230SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
1bbd0b84 1231 (SCM n1, SCM n2),
3c3db128
GH		 1232 "Return the bitwise OR of the integer arguments.\n\n"
1233 "@lisp\n"
1234 "(logior) @result{} 0\n"
1235 "(logior 7) @result{} 7\n"
1236 "(logior #b000 #b001 #b011) @result{} 3\n"
1e6808ea 1237 "@end lisp")
1bbd0b84 1238#define FUNC_NAME s_scm_logior
0f2d19dd 1239{
9a00c9fc
DH		 1240 long int nn1;
1241
0aacf84e
MD		 1242 if (SCM_UNBNDP (n2))
1243 {
1244 if (SCM_UNBNDP (n1))
1245 return SCM_INUM0;
1246 else if (SCM_NUMBERP (n1))
1247 return n1;
1248 else
1249 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 1250 }
09fb7599 1251
0aacf84e
MD		 1252 if (SCM_INUMP (n1))
1253 {
9a00c9fc 1254 nn1 = SCM_INUM (n1);
0aacf84e
MD		 1255 if (SCM_INUMP (n2))
1256 {
1257 long nn2 = SCM_INUM (n2);
1258 return SCM_MAKINUM (nn1 | nn2);
1259 }
1260 else if (SCM_BIGP (n2))
1261 {
1262 intbig:
1263 if (nn1 == 0)
1264 return n2;
1265 {
1266 SCM result_z = scm_i_mkbig ();
1267 mpz_t nn1_z;
1268 mpz_init_set_si (nn1_z, nn1);
1269 mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1270 scm_remember_upto_here_1 (n2);
1271 mpz_clear (nn1_z);
1272 return result_z;
1273 }
1274 }
1275 else
1276 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1277 }
1278 else if (SCM_BIGP (n1))
1279 {
1280 if (SCM_INUMP (n2))
1281 {
1282 SCM_SWAP (n1, n2);
1283 nn1 = SCM_INUM (n1);
1284 goto intbig;
1285 }
1286 else if (SCM_BIGP (n2))
1287 {
1288 SCM result_z = scm_i_mkbig ();
1289 mpz_ior (SCM_I_BIG_MPZ (result_z),
1290 SCM_I_BIG_MPZ (n1),
1291 SCM_I_BIG_MPZ (n2));
1292 scm_remember_upto_here_2 (n1, n2);
1293 return result_z;
1294 }
1295 else
1296 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 1297 }
0aacf84e 1298 else
09fb7599 1299 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 1300}
1bbd0b84 1301#undef FUNC_NAME
0f2d19dd 1302
09fb7599 1303
c3ee7520 1304SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
1bbd0b84 1305 (SCM n1, SCM n2),
3c3db128
GH		 1306 "Return the bitwise XOR of the integer arguments. A bit is\n"
1307 "set in the result if it is set in an odd number of arguments.\n"
1308 "@lisp\n"
1309 "(logxor) @result{} 0\n"
1310 "(logxor 7) @result{} 7\n"
1311 "(logxor #b000 #b001 #b011) @result{} 2\n"
1312 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1e6808ea 1313 "@end lisp")
1bbd0b84 1314#define FUNC_NAME s_scm_logxor
0f2d19dd 1315{
9a00c9fc
DH		 1316 long int nn1;
1317
0aacf84e
MD		 1318 if (SCM_UNBNDP (n2))
1319 {
1320 if (SCM_UNBNDP (n1))
1321 return SCM_INUM0;
1322 else if (SCM_NUMBERP (n1))
1323 return n1;
1324 else
1325 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 1326 }
09fb7599 1327
0aacf84e
MD		 1328 if (SCM_INUMP (n1))
1329 {
9a00c9fc 1330 nn1 = SCM_INUM (n1);
0aacf84e
MD		 1331 if (SCM_INUMP (n2))
1332 {
1333 long nn2 = SCM_INUM (n2);
1334 return SCM_MAKINUM (nn1 ^ nn2);
1335 }
1336 else if (SCM_BIGP (n2))
1337 {
1338 intbig:
1339 {
1340 SCM result_z = scm_i_mkbig ();
1341 mpz_t nn1_z;
1342 mpz_init_set_si (nn1_z, nn1);
1343 mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1344 scm_remember_upto_here_1 (n2);
1345 mpz_clear (nn1_z);
1346 return scm_i_normbig (result_z);
1347 }
1348 }
1349 else
1350 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1351 }
1352 else if (SCM_BIGP (n1))
1353 {
1354 if (SCM_INUMP (n2))
1355 {
1356 SCM_SWAP (n1, n2);
1357 nn1 = SCM_INUM (n1);
1358 goto intbig;
1359 }
1360 else if (SCM_BIGP (n2))
1361 {
1362 SCM result_z = scm_i_mkbig ();
1363 mpz_xor (SCM_I_BIG_MPZ (result_z),
1364 SCM_I_BIG_MPZ (n1),
1365 SCM_I_BIG_MPZ (n2));
1366 scm_remember_upto_here_2 (n1, n2);
1367 return scm_i_normbig (result_z);
1368 }
1369 else
1370 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 1371 }
0aacf84e 1372 else
09fb7599 1373 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 1374}
1bbd0b84 1375#undef FUNC_NAME
0f2d19dd 1376
09fb7599 1377
a1ec6916 1378SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
1e6808ea
MG		 1379 (SCM j, SCM k),
1380 "@lisp\n"
b380b885
MD		 1381 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1382 "(logtest #b0100 #b1011) @result{} #f\n"
1383 "(logtest #b0100 #b0111) @result{} #t\n"
1e6808ea 1384 "@end lisp")
1bbd0b84 1385#define FUNC_NAME s_scm_logtest
0f2d19dd 1386{
1e6808ea 1387 long int nj;
9a00c9fc 1388
0aacf84e
MD		 1389 if (SCM_INUMP (j))
1390 {
1e6808ea 1391 nj = SCM_INUM (j);
0aacf84e
MD		 1392 if (SCM_INUMP (k))
1393 {
1394 long nk = SCM_INUM (k);
1395 return SCM_BOOL (nj & nk);
1396 }
1397 else if (SCM_BIGP (k))
1398 {
1399 intbig:
1400 if (nj == 0)
1401 return SCM_BOOL_F;
1402 {
1403 SCM result;
1404 mpz_t nj_z;
1405 mpz_init_set_si (nj_z, nj);
1406 mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
1407 scm_remember_upto_here_1 (k);
1408 result = SCM_BOOL (mpz_sgn (nj_z) != 0);
1409 mpz_clear (nj_z);
1410 return result;
1411 }
1412 }
1413 else
1414 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
1415 }
1416 else if (SCM_BIGP (j))
1417 {
1418 if (SCM_INUMP (k))
1419 {
1420 SCM_SWAP (j, k);
1421 nj = SCM_INUM (j);
1422 goto intbig;
1423 }
1424 else if (SCM_BIGP (k))
1425 {
1426 SCM result;
1427 mpz_t result_z;
1428 mpz_init (result_z);
1429 mpz_and (result_z,
1430 SCM_I_BIG_MPZ (j),
1431 SCM_I_BIG_MPZ (k));
1432 scm_remember_upto_here_2 (j, k);
1433 result = SCM_BOOL (mpz_sgn (result_z) != 0);
1434 mpz_clear (result_z);
1435 return result;
1436 }
1437 else
1438 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
1439 }
1440 else
1441 SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
0f2d19dd 1442}
1bbd0b84 1443#undef FUNC_NAME
0f2d19dd 1444
c1bfcf60 1445
a1ec6916 1446SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
2cd04b42 1447 (SCM index, SCM j),
1e6808ea 1448 "@lisp\n"
b380b885
MD		 1449 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1450 "(logbit? 0 #b1101) @result{} #t\n"
1451 "(logbit? 1 #b1101) @result{} #f\n"
1452 "(logbit? 2 #b1101) @result{} #t\n"
1453 "(logbit? 3 #b1101) @result{} #t\n"
1454 "(logbit? 4 #b1101) @result{} #f\n"
1e6808ea 1455 "@end lisp")
1bbd0b84 1456#define FUNC_NAME s_scm_logbit_p
0f2d19dd 1457{
78166ad5
DH		 1458 unsigned long int iindex;
1459
1460 SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0);
1461 iindex = (unsigned long int) SCM_INUM (index);
1462
0aacf84e 1463 if (SCM_INUMP (j))
78166ad5 1464 return SCM_BOOL ((1L << iindex) & SCM_INUM (j));
0aacf84e
MD		 1465 else if (SCM_BIGP (j))
1466 {
1467 int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
1468 scm_remember_upto_here_1 (j);
1469 return SCM_BOOL (val);
1470 }
1471 else
78166ad5 1472 SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
0f2d19dd 1473}
1bbd0b84 1474#undef FUNC_NAME
0f2d19dd 1475
78166ad5 1476
a1ec6916 1477SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
1bbd0b84 1478 (SCM n),
4d814788 1479 "Return the integer which is the ones-complement of the integer\n"
1e6808ea
MG		 1480 "argument.\n"
1481 "\n"
b380b885
MD		 1482 "@lisp\n"
1483 "(number->string (lognot #b10000000) 2)\n"
1484 " @result{} \"-10000001\"\n"
1485 "(number->string (lognot #b0) 2)\n"
1486 " @result{} \"-1\"\n"
1e6808ea 1487 "@end lisp")
1bbd0b84 1488#define FUNC_NAME s_scm_lognot
0f2d19dd 1489{
f9811f9f
KR		 1490 if (SCM_INUMP (n)) {
1491 /* No overflow here, just need to toggle all the bits making up the inum.
1492 Enhancement: No need to strip the tag and add it back, could just xor
1493 a block of 1 bits, if that worked with the various debug versions of
1494 the SCM typedef. */
1495 return SCM_MAKINUM (~ SCM_INUM (n));
1496
1497 } else if (SCM_BIGP (n)) {
1498 SCM result = scm_i_mkbig ();
1499 mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
1500 scm_remember_upto_here_1 (n);
1501 return result;
1502
1503 } else {
1504 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
1505 }
0f2d19dd 1506}
1bbd0b84 1507#undef FUNC_NAME
0f2d19dd 1508
a1ec6916 1509SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
2cd04b42 1510 (SCM n, SCM k),
1e6808ea
MG		 1511 "Return @var{n} raised to the non-negative integer exponent\n"
1512 "@var{k}.\n"
1513 "\n"
b380b885
MD		 1514 "@lisp\n"
1515 "(integer-expt 2 5)\n"
1516 " @result{} 32\n"
1517 "(integer-expt -3 3)\n"
1518 " @result{} -27\n"
1519 "@end lisp")
1bbd0b84 1520#define FUNC_NAME s_scm_integer_expt
0f2d19dd 1521{
1c35cb19
RB		 1522 long i2 = 0;
1523 SCM z_i2 = SCM_BOOL_F;
1524 int i2_is_big = 0;
f872b822 1525 SCM acc = SCM_MAKINUM (1L);
ca46fb90 1526
d57ed702 1527 /* 0^0 == 1 according to R5RS */
4260a7fc 1528 if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc))
7b3381f4 1529 return SCM_FALSEP (scm_zero_p(k)) ? n : acc;
4260a7fc
DH		 1530 else if (SCM_EQ_P (n, SCM_MAKINUM (-1L)))
1531 return SCM_FALSEP (scm_even_p (k)) ? n : acc;
ca46fb90 1532
ca46fb90
RB		 1533 if (SCM_INUMP (k))
1534 i2 = SCM_INUM (k);
1535 else if (SCM_BIGP (k))
1536 {
1537 z_i2 = scm_i_clonebig (k, 1);
1538 mpz_init_set (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (k));
1539 scm_remember_upto_here_1 (k);
1540 i2_is_big = 1;
1541 }
1542 else if (SCM_REALP (k))
2830fd91
MD		 1543 {
1544 double r = SCM_REAL_VALUE (k);
ca46fb90
RB		 1545 if (floor (r) != r)
1546 SCM_WRONG_TYPE_ARG (2, k);
1547 if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM))
1548 {
1549 z_i2 = scm_i_mkbig ();
1550 mpz_init_set_d (SCM_I_BIG_MPZ (z_i2), r);
1551 i2_is_big = 1;
1552 }
1553 else
1554 {
1555 i2 = r;
1556 }
2830fd91
MD		 1557 }
1558 else
ca46fb90
RB		 1559 SCM_WRONG_TYPE_ARG (2, k);
1560
1561 if (i2_is_big)
f872b822 1562 {
ca46fb90
RB		 1563 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
1564 {
1565 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
1566 n = scm_divide (n, SCM_UNDEFINED);
1567 }
1568 while (1)
1569 {
1570 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
1571 {
1572 mpz_clear (SCM_I_BIG_MPZ (z_i2));
1573 return acc;
1574 }
1575 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
1576 {
1577 mpz_clear (SCM_I_BIG_MPZ (z_i2));
1578 return scm_product (acc, n);
1579 }
1580 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
1581 acc = scm_product (acc, n);
1582 n = scm_product (n, n);
1583 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
1584 }
f872b822 1585 }
ca46fb90 1586 else
f872b822 1587 {
ca46fb90
RB		 1588 if (i2 < 0)
1589 {
1590 i2 = -i2;
1591 n = scm_divide (n, SCM_UNDEFINED);
1592 }
1593 while (1)
1594 {
1595 if (0 == i2)
1596 return acc;
1597 if (1 == i2)
1598 return scm_product (acc, n);
1599 if (i2 & 1)
1600 acc = scm_product (acc, n);
1601 n = scm_product (n, n);
1602 i2 >>= 1;
1603 }
f872b822 1604 }
0f2d19dd 1605}
1bbd0b84 1606#undef FUNC_NAME
0f2d19dd 1607
a1ec6916 1608SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
1bbd0b84 1609 (SCM n, SCM cnt),
32f19569
KR		 1610 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
1611 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1e6808ea 1612 "\n"
32f19569
KR		 1613 "This is effectively a multiplication by 2^@var{cnt}}, and when\n"
1614 "@var{cnt} is negative it's a division, rounded towards negative\n"
1615 "infinity. (Note that this is not the same rounding as\n"
1616 "@code{quotient} does.)\n"
1617 "\n"
1618 "With @var{n} viewed as an infinite precision twos complement,\n"
1619 "@code{ash} means a left shift introducing zero bits, or a right\n"
1620 "shift dropping bits.\n"
1e6808ea 1621 "\n"
b380b885 1622 "@lisp\n"
1e6808ea
MG		 1623 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1624 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
32f19569
KR		 1625 "\n"
1626 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
1627 "(ash -23 -2) @result{} -6\n"
a3c8b9fc 1628 "@end lisp")
1bbd0b84 1629#define FUNC_NAME s_scm_ash
0f2d19dd 1630{
3ab9f56e
DH		 1631 long bits_to_shift;
1632
3ab9f56e
DH		 1633 SCM_VALIDATE_INUM (2, cnt);
1634
1635 bits_to_shift = SCM_INUM (cnt);
ca46fb90
RB		 1636
1637 if (bits_to_shift < 0)
1638 {
1639 /* Shift right by abs(cnt) bits. This is realized as a division
1640 by div:=2^abs(cnt). However, to guarantee the floor
1641 rounding, negative values require some special treatment.
1642 */
1643 SCM div = scm_integer_expt (SCM_MAKINUM (2),
1644 SCM_MAKINUM (-bits_to_shift));
f92e85f7
MV		 1645
1646 /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */
ca46fb90
RB		 1647 if (SCM_FALSEP (scm_negative_p (n)))
1648 return scm_quotient (n, div);
1649 else
1650 return scm_sum (SCM_MAKINUM (-1L),
1651 scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div));
1652 }
1653 else
3ab9f56e 1654 /* Shift left is done by multiplication with 2^CNT */
f872b822 1655 return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
0f2d19dd 1656}
1bbd0b84 1657#undef FUNC_NAME
0f2d19dd 1658
3c9f20f8 1659
a1ec6916 1660SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
1bbd0b84 1661 (SCM n, SCM start, SCM end),
1e6808ea
MG		 1662 "Return the integer composed of the @var{start} (inclusive)\n"
1663 "through @var{end} (exclusive) bits of @var{n}. The\n"
1664 "@var{start}th bit becomes the 0-th bit in the result.\n"
1665 "\n"
b380b885
MD		 1666 "@lisp\n"
1667 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1668 " @result{} \"1010\"\n"
1669 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1670 " @result{} \"10110\"\n"
1671 "@end lisp")
1bbd0b84 1672#define FUNC_NAME s_scm_bit_extract
0f2d19dd 1673{
ac0c002c 1674 unsigned long int istart, iend;
34d19ef6 1675 SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart);
c1bfcf60
GB		 1676 SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
1677 SCM_ASSERT_RANGE (3, end, (iend >= istart));
78166ad5 1678
0aacf84e
MD		 1679 if (SCM_INUMP (n))
1680 {
1681 long int in = SCM_INUM (n);
1682 unsigned long int bits = iend - istart;
ac0c002c 1683
0aacf84e
MD		 1684 if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
1685 {
1686 /* Since we emulate two's complement encoded numbers, this
1687 * special case requires us to produce a result that has
1688 * more bits than can be stored in a fixnum. Thus, we fall
1689 * back to the more general algorithm that is used for
1690 * bignums.
1691 */
1692 goto generalcase;
1693 }
ac0c002c 1694
0aacf84e
MD		 1695 if (istart < SCM_I_FIXNUM_BIT)
1696 {
1697 in = in >> istart;
1698 if (bits < SCM_I_FIXNUM_BIT)
1699 return SCM_MAKINUM (in & ((1L << bits) - 1));
1700 else /* we know: in >= 0 */
1701 return SCM_MAKINUM (in);
1702 }
1703 else if (in < 0)
ac0c002c 1704 return SCM_MAKINUM (-1L & ((1L << bits) - 1));
0aacf84e 1705 else
ac0c002c 1706 return SCM_MAKINUM (0);
0aacf84e
MD		 1707 }
1708 else if (SCM_BIGP (n))
ac0c002c 1709 {
0aacf84e
MD		 1710 generalcase:
1711 {
1712 SCM num1 = SCM_MAKINUM (1L);
1713 SCM num2 = SCM_MAKINUM (2L);
1714 SCM bits = SCM_MAKINUM (iend - istart);
1715 SCM mask = scm_difference (scm_integer_expt (num2, bits), num1);
1716 return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
1717 }
ac0c002c 1718 }
0aacf84e 1719 else
78166ad5 1720 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1721}
1bbd0b84 1722#undef FUNC_NAME
0f2d19dd 1723
e4755e5c
JB		 1724static const char scm_logtab[] = {
1725 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1726};
1cc91f1b 1727
a1ec6916 1728SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
1bbd0b84 1729 (SCM n),
1e6808ea
MG		 1730 "Return the number of bits in integer @var{n}. If integer is\n"
1731 "positive, the 1-bits in its binary representation are counted.\n"
1732 "If negative, the 0-bits in its two's-complement binary\n"
1733 "representation are counted. If 0, 0 is returned.\n"
1734 "\n"
b380b885
MD		 1735 "@lisp\n"
1736 "(logcount #b10101010)\n"
ca46fb90
RB		 1737 " @result{} 4\n"
1738 "(logcount 0)\n"
1739 " @result{} 0\n"
1740 "(logcount -2)\n"
1741 " @result{} 1\n"
1742 "@end lisp")
1743#define FUNC_NAME s_scm_logcount
1744{
1745 if (SCM_INUMP (n))
f872b822 1746 {
ca46fb90
RB		 1747 unsigned long int c = 0;
1748 long int nn = SCM_INUM (n);
1749 if (nn < 0)
1750 nn = -1 - nn;
1751 while (nn)
1752 {
1753 c += scm_logtab[15 & nn];
1754 nn >>= 4;
1755 }
1756 return SCM_MAKINUM (c);
f872b822 1757 }
ca46fb90 1758 else if (SCM_BIGP (n))
f872b822 1759 {
ca46fb90 1760 unsigned long count;
713a4259
KR		 1761 if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
1762 count = mpz_popcount (SCM_I_BIG_MPZ (n));
ca46fb90 1763 else
713a4259
KR		 1764 count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
1765 scm_remember_upto_here_1 (n);
ca46fb90 1766 return SCM_MAKINUM (count);
f872b822 1767 }
ca46fb90
RB		 1768 else
1769 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1770}
ca46fb90 1771#undef FUNC_NAME
0f2d19dd
JB		 1772
1773
ca46fb90
RB		 1774static const char scm_ilentab[] = {
1775 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1776};
1777
0f2d19dd 1778
ca46fb90
RB		 1779SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
1780 (SCM n),
1781 "Return the number of bits necessary to represent @var{n}.\n"
1782 "\n"
1783 "@lisp\n"
1784 "(integer-length #b10101010)\n"
1785 " @result{} 8\n"
1786 "(integer-length 0)\n"
1787 " @result{} 0\n"
1788 "(integer-length #b1111)\n"
1789 " @result{} 4\n"
1790 "@end lisp")
1791#define FUNC_NAME s_scm_integer_length
1792{
0aacf84e
MD		 1793 if (SCM_INUMP (n))
1794 {
1795 unsigned long int c = 0;
1796 unsigned int l = 4;
1797 long int nn = SCM_INUM (n);
1798 if (nn < 0)
1799 nn = -1 - nn;
1800 while (nn)
1801 {
1802 c += 4;
1803 l = scm_ilentab [15 & nn];
1804 nn >>= 4;
1805 }
1806 return SCM_MAKINUM (c - 4 + l);
1807 }
1808 else if (SCM_BIGP (n))
1809 {
1810 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1811 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1812 1 too big, so check for that and adjust. */
1813 size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
1814 if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
1815 && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
1816 mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
1817 size--;
1818 scm_remember_upto_here_1 (n);
1819 return SCM_MAKINUM (size);
1820 }
1821 else
ca46fb90 1822 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
ca46fb90
RB		 1823}
1824#undef FUNC_NAME
0f2d19dd
JB		 1825
1826/*** NUMBERS -> STRINGS ***/
0f2d19dd 1827int scm_dblprec;
e4755e5c 1828static const double fx[] =
f872b822
MD		 1829{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1830 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1831 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1832 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
0f2d19dd 1833
1be6b49c 1834static size_t
1bbd0b84 1835idbl2str (double f, char *a)
0f2d19dd
JB		 1836{
1837 int efmt, dpt, d, i, wp = scm_dblprec;
1be6b49c 1838 size_t ch = 0;
0f2d19dd
JB		 1839 int exp = 0;
1840
f872b822 1841 if (f == 0.0)
abb7e44d
MV		 1842 {
1843#ifdef HAVE_COPYSIGN
1844 double sgn = copysign (1.0, f);
1845
1846 if (sgn < 0.0)
1847 a[ch++] = '-';
1848#endif
1849
1850 goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1851 }
7351e207
MV		 1852
1853 if (xisinf (f))
1854 {
1855 if (f < 0)
1856 strcpy (a, "-inf.0");
1857 else
1858 strcpy (a, "+inf.0");
1859 return ch+6;
1860 }
1861 else if (xisnan (f))
1862 {
1863 strcpy (a, "+nan.0");
1864 return ch+6;
1865 }
1866
f872b822
MD		 1867 if (f < 0.0)
1868 {
1869 f = -f;
1870 a[ch++] = '-';
1871 }
7351e207 1872
f872b822
MD		 1873#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1874 make-uniform-vector, from causing infinite loops. */
1875 while (f < 1.0)
1876 {
1877 f *= 10.0;
1878 if (exp-- < DBL_MIN_10_EXP)
7351e207
MV		 1879 {
1880 a[ch++] = '#';
1881 a[ch++] = '.';
1882 a[ch++] = '#';
1883 return ch;
1884 }
f872b822
MD		 1885 }
1886 while (f > 10.0)
1887 {
1888 f *= 0.10;
1889 if (exp++ > DBL_MAX_10_EXP)
7351e207
MV		 1890 {
1891 a[ch++] = '#';
1892 a[ch++] = '.';
1893 a[ch++] = '#';
1894 return ch;
1895 }
f872b822
MD		 1896 }
1897#else
1898 while (f < 1.0)
1899 {
1900 f *= 10.0;
1901 exp--;
1902 }
1903 while (f > 10.0)
1904 {
1905 f /= 10.0;
1906 exp++;
1907 }
1908#endif
1909 if (f + fx[wp] >= 10.0)
1910 {
1911 f = 1.0;
1912 exp++;
1913 }
0f2d19dd 1914 zero:
f872b822
MD		 1915#ifdef ENGNOT
1916 dpt = (exp + 9999) % 3;
0f2d19dd
JB		 1917 exp -= dpt++;
1918 efmt = 1;
f872b822
MD		 1919#else
1920 efmt = (exp < -3) || (exp > wp + 2);
0f2d19dd 1921 if (!efmt)
cda139a7
MD		 1922 {
1923 if (exp < 0)
1924 {
1925 a[ch++] = '0';
1926 a[ch++] = '.';
1927 dpt = exp;
f872b822
MD		 1928 while (++dpt)
1929 a[ch++] = '0';
cda139a7
MD		 1930 }
1931 else
f872b822 1932 dpt = exp + 1;
cda139a7 1933 }
0f2d19dd
JB		 1934 else
1935 dpt = 1;
f872b822
MD		 1936#endif
1937
1938 do
1939 {
1940 d = f;
1941 f -= d;
1942 a[ch++] = d + '0';
1943 if (f < fx[wp])
1944 break;
1945 if (f + fx[wp] >= 1.0)
1946 {
1947 a[ch - 1]++;
1948 break;
1949 }
1950 f *= 10.0;
1951 if (!(--dpt))
1952 a[ch++] = '.';
0f2d19dd 1953 }
f872b822 1954 while (wp--);
0f2d19dd
JB		 1955
1956 if (dpt > 0)
cda139a7 1957 {
f872b822 1958#ifndef ENGNOT
cda139a7
MD		 1959 if ((dpt > 4) && (exp > 6))
1960 {
f872b822 1961 d = (a[0] == '-' ? 2 : 1);
cda139a7 1962 for (i = ch++; i > d; i--)
f872b822 1963 a[i] = a[i - 1];
cda139a7
MD		 1964 a[d] = '.';
1965 efmt = 1;
1966 }
1967 else
f872b822 1968#endif
cda139a7 1969 {
f872b822
MD		 1970 while (--dpt)
1971 a[ch++] = '0';
cda139a7
MD		 1972 a[ch++] = '.';
1973 }
1974 }
f872b822
MD		 1975 if (a[ch - 1] == '.')
1976 a[ch++] = '0'; /* trailing zero */
1977 if (efmt && exp)
1978 {
1979 a[ch++] = 'e';
1980 if (exp < 0)
1981 {
1982 exp = -exp;
1983 a[ch++] = '-';
1984 }
1985 for (i = 10; i <= exp; i *= 10);
1986 for (i /= 10; i; i /= 10)
1987 {
1988 a[ch++] = exp / i + '0';
1989 exp %= i;
1990 }
0f2d19dd 1991 }
0f2d19dd
JB		 1992 return ch;
1993}
1994
1cc91f1b 1995
1be6b49c 1996static size_t
1bbd0b84 1997iflo2str (SCM flt, char *str)
0f2d19dd 1998{
1be6b49c 1999 size_t i;
3c9a524f 2000 if (SCM_REALP (flt))
f3ae5d60 2001 i = idbl2str (SCM_REAL_VALUE (flt), str);
0f2d19dd 2002 else
f872b822 2003 {
f3ae5d60
MD		 2004 i = idbl2str (SCM_COMPLEX_REAL (flt), str);
2005 if (SCM_COMPLEX_IMAG (flt) != 0.0)
2006 {
7351e207
MV		 2007 double imag = SCM_COMPLEX_IMAG (flt);
2008 /* Don't output a '+' for negative numbers or for Inf and
2009 NaN. They will provide their own sign. */
2010 if (0 <= imag && !xisinf (imag) && !xisnan (imag))
f3ae5d60 2011 str[i++] = '+';
7351e207 2012 i += idbl2str (imag, &str[i]);
f3ae5d60
MD		 2013 str[i++] = 'i';
2014 }
f872b822 2015 }
0f2d19dd
JB		 2016 return i;
2017}
0f2d19dd 2018
5c11cc9d 2019/* convert a long to a string (unterminated). returns the number of
1bbd0b84
GB		 2020 characters in the result.
2021 rad is output base
2022 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1be6b49c 2023size_t
1bbd0b84 2024scm_iint2str (long num, int rad, char *p)
0f2d19dd 2025{
1be6b49c
ML		 2026 size_t j = 1;
2027 size_t i;
5c11cc9d
GH		 2028 unsigned long n = (num < 0) ? -num : num;
2029
f872b822 2030 for (n /= rad; n > 0; n /= rad)
5c11cc9d
GH		 2031 j++;
2032
2033 i = j;
2034 if (num < 0)
f872b822 2035 {
f872b822 2036 *p++ = '-';
5c11cc9d
GH		 2037 j++;
2038 n = -num;
f872b822 2039 }
5c11cc9d
GH		 2040 else
2041 n = num;
f872b822
MD		 2042 while (i--)
2043 {
5c11cc9d
GH		 2044 int d = n % rad;
2045
f872b822
MD		 2046 n /= rad;
2047 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
2048 }
0f2d19dd
JB		 2049 return j;
2050}
2051
a1ec6916 2052SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
bb628794
DH		 2053 (SCM n, SCM radix),
2054 "Return a string holding the external representation of the\n"
942e5b91
MG		 2055 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2056 "inexact, a radix of 10 will be used.")
1bbd0b84 2057#define FUNC_NAME s_scm_number_to_string
0f2d19dd 2058{
1bbd0b84 2059 int base;
98cb6e75 2060
0aacf84e 2061 if (SCM_UNBNDP (radix))
98cb6e75 2062 base = 10;
0aacf84e
MD		 2063 else
2064 {
2065 SCM_VALIDATE_INUM (2, radix);
2066 base = SCM_INUM (radix);
2067 /* FIXME: ask if range limit was OK, and if so, document */
2068 SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36));
2069 }
98cb6e75 2070
0aacf84e
MD		 2071 if (SCM_INUMP (n))
2072 {
2073 char num_buf [SCM_INTBUFLEN];
2074 size_t length = scm_iint2str (SCM_INUM (n), base, num_buf);
2075 return scm_mem2string (num_buf, length);
2076 }
2077 else if (SCM_BIGP (n))
2078 {
2079 char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
2080 scm_remember_upto_here_1 (n);
2081 return scm_take0str (str);
2082 }
f92e85f7
MV		 2083 else if (SCM_FRACTIONP (n))
2084 {
2085 scm_i_fraction_reduce (n);
2086 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
2087 scm_mem2string ("/", 1),
2088 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
2089 }
0aacf84e
MD		 2090 else if (SCM_INEXACTP (n))
2091 {
2092 char num_buf [FLOBUFLEN];
2093 return scm_mem2string (num_buf, iflo2str (n, num_buf));
2094 }
2095 else
bb628794 2096 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 2097}
1bbd0b84 2098#undef FUNC_NAME
0f2d19dd
JB		 2099
2100
ca46fb90
RB		 2101/* These print routines used to be stubbed here so that scm_repl.c
2102 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1cc91f1b 2103
0f2d19dd 2104int
e81d98ec 2105scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 2106{
56e55ac7 2107 char num_buf[FLOBUFLEN];
f872b822 2108 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
0f2d19dd
JB		 2109 return !0;
2110}
2111
f3ae5d60 2112int
e81d98ec 2113scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
f92e85f7 2114
f3ae5d60 2115{
56e55ac7 2116 char num_buf[FLOBUFLEN];
f3ae5d60
MD		 2117 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
2118 return !0;
2119}
1cc91f1b 2120
f92e85f7
MV		 2121int
2122scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
2123{
2124 SCM str;
2125 scm_i_fraction_reduce (sexp);
2126 str = scm_number_to_string (sexp, SCM_UNDEFINED);
2127 scm_lfwrite (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port);
2128 scm_remember_upto_here_1 (str);
2129 return !0;
2130}
2131
0f2d19dd 2132int
e81d98ec 2133scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 2134{
ca46fb90
RB		 2135 char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
2136 scm_remember_upto_here_1 (exp);
2137 scm_lfwrite (str, (size_t) strlen (str), port);
2138 free (str);
0f2d19dd
JB		 2139 return !0;
2140}
2141/*** END nums->strs ***/
2142
3c9a524f 2143
0f2d19dd 2144/*** STRINGS -> NUMBERS ***/
2a8fecee 2145
3c9a524f
DH		 2146/* The following functions implement the conversion from strings to numbers.
2147 * The implementation somehow follows the grammar for numbers as it is given
2148 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2149 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2150 * points should be noted about the implementation:
2151 * * Each function keeps a local index variable 'idx' that points at the
2152 * current position within the parsed string. The global index is only
2153 * updated if the function could parse the corresponding syntactic unit
2154 * successfully.
2155 * * Similarly, the functions keep track of indicators of inexactness ('#',
2156 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2157 * global exactness information is only updated after each part has been
2158 * successfully parsed.
2159 * * Sequences of digits are parsed into temporary variables holding fixnums.
2160 * Only if these fixnums would overflow, the result variables are updated
2161 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2162 * the temporary variables holding the fixnums are cleared, and the process
2163 * starts over again. If for example fixnums were able to store five decimal
2164 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2165 * and the result was computed as 12345 * 100000 + 67890. In other words,
2166 * only every five digits two bignum operations were performed.
2167 */
2168
2169enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
2170
2171/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2172
2173/* In non ASCII-style encodings the following macro might not work. */
2174#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2175
2a8fecee 2176static SCM
3c9a524f
DH		 2177mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
2178 unsigned int radix, enum t_exactness *p_exactness)
2a8fecee 2179{
3c9a524f
DH		 2180 unsigned int idx = *p_idx;
2181 unsigned int hash_seen = 0;
2182 scm_t_bits shift = 1;
2183 scm_t_bits add = 0;
2184 unsigned int digit_value;
2185 SCM result;
2186 char c;
2187
2188 if (idx == len)
2189 return SCM_BOOL_F;
2a8fecee 2190
3c9a524f
DH		 2191 c = mem[idx];
2192 if (!isxdigit (c))
2193 return SCM_BOOL_F;
2194 digit_value = XDIGIT2UINT (c);
2195 if (digit_value >= radix)
2196 return SCM_BOOL_F;
2197
2198 idx++;
2199 result = SCM_MAKINUM (digit_value);
2200 while (idx != len)
f872b822 2201 {
3c9a524f
DH		 2202 char c = mem[idx];
2203 if (isxdigit (c))
f872b822 2204 {
3c9a524f 2205 if (hash_seen)
1fe5e088 2206 break;
3c9a524f
DH		 2207 digit_value = XDIGIT2UINT (c);
2208 if (digit_value >= radix)
1fe5e088 2209 break;
f872b822 2210 }
3c9a524f
DH		 2211 else if (c == '#')
2212 {
2213 hash_seen = 1;
2214 digit_value = 0;
2215 }
2216 else
2217 break;
2218
2219 idx++;
2220 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
2221 {
2222 result = scm_product (result, SCM_MAKINUM (shift));
2223 if (add > 0)
2224 result = scm_sum (result, SCM_MAKINUM (add));
2225
2226 shift = radix;
2227 add = digit_value;
2228 }
2229 else
2230 {
2231 shift = shift * radix;
2232 add = add * radix + digit_value;
2233 }
2234 };
2235
2236 if (shift > 1)
2237 result = scm_product (result, SCM_MAKINUM (shift));
2238 if (add > 0)
2239 result = scm_sum (result, SCM_MAKINUM (add));
2240
2241 *p_idx = idx;
2242 if (hash_seen)
2243 *p_exactness = INEXACT;
2244
2245 return result;
2a8fecee
JB		 2246}
2247
2248
3c9a524f
DH		 2249/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2250 * covers the parts of the rules that start at a potential point. The value
2251 * of the digits up to the point have been parsed by the caller and are given
79d34f68
DH		 2252 * in variable result. The content of *p_exactness indicates, whether a hash
2253 * has already been seen in the digits before the point.
3c9a524f 2254 */
1cc91f1b 2255
3c9a524f
DH		 2256/* In non ASCII-style encodings the following macro might not work. */
2257#define DIGIT2UINT(d) ((d) - '0')
2258
2259static SCM
79d34f68 2260mem2decimal_from_point (SCM result, const char* mem, size_t len,
3c9a524f 2261 unsigned int *p_idx, enum t_exactness *p_exactness)
0f2d19dd 2262{
3c9a524f
DH		 2263 unsigned int idx = *p_idx;
2264 enum t_exactness x = *p_exactness;
3c9a524f
DH		 2265
2266 if (idx == len)
79d34f68 2267 return result;
3c9a524f
DH		 2268
2269 if (mem[idx] == '.')
2270 {
2271 scm_t_bits shift = 1;
2272 scm_t_bits add = 0;
2273 unsigned int digit_value;
79d34f68 2274 SCM big_shift = SCM_MAKINUM (1);
3c9a524f
DH		 2275
2276 idx++;
2277 while (idx != len)
2278 {
2279 char c = mem[idx];
2280 if (isdigit (c))
2281 {
2282 if (x == INEXACT)
2283 return SCM_BOOL_F;
2284 else
2285 digit_value = DIGIT2UINT (c);
2286 }
2287 else if (c == '#')
2288 {
2289 x = INEXACT;
2290 digit_value = 0;
2291 }
2292 else
2293 break;
2294
2295 idx++;
2296 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
2297 {
2298 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68 2299 result = scm_product (result, SCM_MAKINUM (shift));
3c9a524f 2300 if (add > 0)
79d34f68 2301 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2302
2303 shift = 10;
2304 add = digit_value;
2305 }
2306 else
2307 {
2308 shift = shift * 10;
2309 add = add * 10 + digit_value;
2310 }
2311 };
2312
2313 if (add > 0)
2314 {
2315 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68
DH		 2316 result = scm_product (result, SCM_MAKINUM (shift));
2317 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2318 }
2319
d8592269 2320 result = scm_divide (result, big_shift);
79d34f68 2321
3c9a524f
DH		 2322 /* We've seen a decimal point, thus the value is implicitly inexact. */
2323 x = INEXACT;
f872b822 2324 }
3c9a524f 2325
3c9a524f 2326 if (idx != len)
f872b822 2327 {
3c9a524f
DH		 2328 int sign = 1;
2329 unsigned int start;
2330 char c;
2331 int exponent;
2332 SCM e;
2333
2334 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2335
2336 switch (mem[idx])
f872b822 2337 {
3c9a524f
DH		 2338 case 'd': case 'D':
2339 case 'e': case 'E':
2340 case 'f': case 'F':
2341 case 'l': case 'L':
2342 case 's': case 'S':
2343 idx++;
2344 start = idx;
2345 c = mem[idx];
2346 if (c == '-')
2347 {
2348 idx++;
2349 sign = -1;
2350 c = mem[idx];
2351 }
2352 else if (c == '+')
2353 {
2354 idx++;
2355 sign = 1;
2356 c = mem[idx];
2357 }
2358 else
2359 sign = 1;
2360
2361 if (!isdigit (c))
2362 return SCM_BOOL_F;
2363
2364 idx++;
2365 exponent = DIGIT2UINT (c);
2366 while (idx != len)
f872b822 2367 {
3c9a524f
DH		 2368 char c = mem[idx];
2369 if (isdigit (c))
2370 {
2371 idx++;
2372 if (exponent <= SCM_MAXEXP)
2373 exponent = exponent * 10 + DIGIT2UINT (c);
2374 }
2375 else
2376 break;
f872b822 2377 }
3c9a524f
DH		 2378
2379 if (exponent > SCM_MAXEXP)
f872b822 2380 {
3c9a524f
DH		 2381 size_t exp_len = idx - start;
2382 SCM exp_string = scm_mem2string (&mem[start], exp_len);
2383 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
2384 scm_out_of_range ("string->number", exp_num);
f872b822 2385 }
3c9a524f
DH		 2386
2387 e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent));
2388 if (sign == 1)
2389 result = scm_product (result, e);
2390 else
f92e85f7 2391 result = scm_divide2real (result, e);
3c9a524f
DH		 2392
2393 /* We've seen an exponent, thus the value is implicitly inexact. */
2394 x = INEXACT;
2395
f872b822 2396 break;
3c9a524f 2397
f872b822 2398 default:
3c9a524f 2399 break;
f872b822 2400 }
0f2d19dd 2401 }
3c9a524f
DH		 2402
2403 *p_idx = idx;
2404 if (x == INEXACT)
2405 *p_exactness = x;
2406
2407 return result;
0f2d19dd 2408}
0f2d19dd 2409
3c9a524f
DH		 2410
2411/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2412
2413static SCM
2414mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
2415 unsigned int radix, enum t_exactness *p_exactness)
0f2d19dd 2416{
3c9a524f 2417 unsigned int idx = *p_idx;
164d2481 2418 SCM result;
3c9a524f
DH		 2419
2420 if (idx == len)
2421 return SCM_BOOL_F;
2422
7351e207
MV		 2423 if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
2424 {
2425 *p_idx = idx+5;
2426 return scm_inf ();
2427 }
2428
2429 if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
2430 {
2431 enum t_exactness x = EXACT;
2432
d8592269
MV		 2433 /* Cobble up the fractional part. We might want to set the
2434 NaN's mantissa from it. */
7351e207
MV		 2435 idx += 4;
2436 mem2uinteger (mem, len, &idx, 10, &x);
2437 *p_idx = idx;
2438 return scm_nan ();
2439 }
2440
3c9a524f
DH		 2441 if (mem[idx] == '.')
2442 {
2443 if (radix != 10)
2444 return SCM_BOOL_F;
2445 else if (idx + 1 == len)
2446 return SCM_BOOL_F;
2447 else if (!isdigit (mem[idx + 1]))
2448 return SCM_BOOL_F;
2449 else
164d2481
MV		 2450 result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
2451 p_idx, p_exactness);
f872b822 2452 }
3c9a524f
DH		 2453 else
2454 {
2455 enum t_exactness x = EXACT;
2456 SCM uinteger;
3c9a524f
DH		 2457
2458 uinteger = mem2uinteger (mem, len, &idx, radix, &x);
2459 if (SCM_FALSEP (uinteger))
2460 return SCM_BOOL_F;
2461
2462 if (idx == len)
2463 result = uinteger;
2464 else if (mem[idx] == '/')
f872b822 2465 {
3c9a524f
DH		 2466 SCM divisor;
2467
2468 idx++;
2469
2470 divisor = mem2uinteger (mem, len, &idx, radix, &x);
2471 if (SCM_FALSEP (divisor))
2472 return SCM_BOOL_F;
2473
f92e85f7
MV		 2474 /* both are int/big here, I assume */
2475 result = scm_make_ratio (uinteger, divisor);
f872b822 2476 }
3c9a524f
DH		 2477 else if (radix == 10)
2478 {
2479 result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
2480 if (SCM_FALSEP (result))
2481 return SCM_BOOL_F;
2482 }
2483 else
2484 result = uinteger;
2485
2486 *p_idx = idx;
2487 if (x == INEXACT)
2488 *p_exactness = x;
f872b822 2489 }
164d2481
MV		 2490
2491 /* When returning an inexact zero, make sure it is represented as a
2492 floating point value so that we can change its sign.
2493 */
2494 if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT)
2495 result = scm_make_real (0.0);
2496
2497 return result;
3c9a524f 2498}
0f2d19dd 2499
0f2d19dd 2500
3c9a524f 2501/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
0f2d19dd 2502
3c9a524f
DH		 2503static SCM
2504mem2complex (const char* mem, size_t len, unsigned int idx,
2505 unsigned int radix, enum t_exactness *p_exactness)
2506{
2507 char c;
2508 int sign = 0;
2509 SCM ureal;
2510
2511 if (idx == len)
2512 return SCM_BOOL_F;
2513
2514 c = mem[idx];
2515 if (c == '+')
2516 {
2517 idx++;
2518 sign = 1;
2519 }
2520 else if (c == '-')
2521 {
2522 idx++;
2523 sign = -1;
0f2d19dd 2524 }
0f2d19dd 2525
3c9a524f
DH		 2526 if (idx == len)
2527 return SCM_BOOL_F;
2528
2529 ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
2530 if (SCM_FALSEP (ureal))
f872b822 2531 {
3c9a524f
DH		 2532 /* input must be either +i or -i */
2533
2534 if (sign == 0)
2535 return SCM_BOOL_F;
2536
2537 if (mem[idx] == 'i' || mem[idx] == 'I')
f872b822 2538 {
3c9a524f
DH		 2539 idx++;
2540 if (idx != len)
2541 return SCM_BOOL_F;
2542
2543 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign));
f872b822 2544 }
3c9a524f
DH		 2545 else
2546 return SCM_BOOL_F;
0f2d19dd 2547 }
3c9a524f
DH		 2548 else
2549 {
fc194577 2550 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f 2551 ureal = scm_difference (ureal, SCM_UNDEFINED);
f872b822 2552
3c9a524f
DH		 2553 if (idx == len)
2554 return ureal;
2555
2556 c = mem[idx];
2557 switch (c)
f872b822 2558 {
3c9a524f
DH		 2559 case 'i': case 'I':
2560 /* either +<ureal>i or -<ureal>i */
2561
2562 idx++;
2563 if (sign == 0)
2564 return SCM_BOOL_F;
2565 if (idx != len)
2566 return SCM_BOOL_F;
2567 return scm_make_rectangular (SCM_MAKINUM (0), ureal);
2568
2569 case '@':
2570 /* polar input: <real>@<real>. */
2571
2572 idx++;
2573 if (idx == len)
2574 return SCM_BOOL_F;
2575 else
f872b822 2576 {
3c9a524f
DH		 2577 int sign;
2578 SCM angle;
2579 SCM result;
2580
2581 c = mem[idx];
2582 if (c == '+')
2583 {
2584 idx++;
2585 sign = 1;
2586 }
2587 else if (c == '-')
2588 {
2589 idx++;
2590 sign = -1;
2591 }
2592 else
2593 sign = 1;
2594
2595 angle = mem2ureal (mem, len, &idx, radix, p_exactness);
2596 if (SCM_FALSEP (angle))
2597 return SCM_BOOL_F;
2598 if (idx != len)
2599 return SCM_BOOL_F;
2600
fc194577 2601 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f
DH		 2602 angle = scm_difference (angle, SCM_UNDEFINED);
2603
2604 result = scm_make_polar (ureal, angle);
2605 return result;
f872b822 2606 }
3c9a524f
DH		 2607 case '+':
2608 case '-':
2609 /* expecting input matching <real>[+-]<ureal>?i */
0f2d19dd 2610
3c9a524f
DH		 2611 idx++;
2612 if (idx == len)
2613 return SCM_BOOL_F;
2614 else
2615 {
2616 int sign = (c == '+') ? 1 : -1;
2617 SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
0f2d19dd 2618
3c9a524f
DH		 2619 if (SCM_FALSEP (imag))
2620 imag = SCM_MAKINUM (sign);
fc194577 2621 else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
1fe5e088 2622 imag = scm_difference (imag, SCM_UNDEFINED);
0f2d19dd 2623
3c9a524f
DH		 2624 if (idx == len)
2625 return SCM_BOOL_F;
2626 if (mem[idx] != 'i' && mem[idx] != 'I')
2627 return SCM_BOOL_F;
0f2d19dd 2628
3c9a524f
DH		 2629 idx++;
2630 if (idx != len)
2631 return SCM_BOOL_F;
0f2d19dd 2632
1fe5e088 2633 return scm_make_rectangular (ureal, imag);
3c9a524f
DH		 2634 }
2635 default:
2636 return SCM_BOOL_F;
2637 }
2638 }
0f2d19dd 2639}
0f2d19dd
JB		 2640
2641
3c9a524f
DH		 2642/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2643
2644enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
1cc91f1b 2645
0f2d19dd 2646SCM
3c9a524f 2647scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix)
0f2d19dd 2648{
3c9a524f
DH		 2649 unsigned int idx = 0;
2650 unsigned int radix = NO_RADIX;
2651 enum t_exactness forced_x = NO_EXACTNESS;
2652 enum t_exactness implicit_x = EXACT;
2653 SCM result;
2654
2655 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2656 while (idx + 2 < len && mem[idx] == '#')
2657 {
2658 switch (mem[idx + 1])
2659 {
2660 case 'b': case 'B':
2661 if (radix != NO_RADIX)
2662 return SCM_BOOL_F;
2663 radix = DUAL;
2664 break;
2665 case 'd': case 'D':
2666 if (radix != NO_RADIX)
2667 return SCM_BOOL_F;
2668 radix = DEC;
2669 break;
2670 case 'i': case 'I':
2671 if (forced_x != NO_EXACTNESS)
2672 return SCM_BOOL_F;
2673 forced_x = INEXACT;
2674 break;
2675 case 'e': case 'E':
2676 if (forced_x != NO_EXACTNESS)
2677 return SCM_BOOL_F;
2678 forced_x = EXACT;
2679 break;
2680 case 'o': case 'O':
2681 if (radix != NO_RADIX)
2682 return SCM_BOOL_F;
2683 radix = OCT;
2684 break;
2685 case 'x': case 'X':
2686 if (radix != NO_RADIX)
2687 return SCM_BOOL_F;
2688 radix = HEX;
2689 break;
2690 default:
f872b822 2691 return SCM_BOOL_F;
3c9a524f
DH		 2692 }
2693 idx += 2;
2694 }
2695
2696 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2697 if (radix == NO_RADIX)
2698 result = mem2complex (mem, len, idx, default_radix, &implicit_x);
2699 else
2700 result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
2701
2702 if (SCM_FALSEP (result))
2703 return SCM_BOOL_F;
f872b822 2704
3c9a524f 2705 switch (forced_x)
f872b822 2706 {
3c9a524f
DH		 2707 case EXACT:
2708 if (SCM_INEXACTP (result))
3c9a524f
DH		 2709 return scm_inexact_to_exact (result);
2710 else
2711 return result;
2712 case INEXACT:
2713 if (SCM_INEXACTP (result))
2714 return result;
2715 else
2716 return scm_exact_to_inexact (result);
2717 case NO_EXACTNESS:
2718 default:
2719 if (implicit_x == INEXACT)
2720 {
2721 if (SCM_INEXACTP (result))
2722 return result;
2723 else
2724 return scm_exact_to_inexact (result);
2725 }
2726 else
2727 return result;
f872b822 2728 }
0f2d19dd
JB		 2729}
2730
2731
a1ec6916 2732SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
bb628794 2733 (SCM string, SCM radix),
1e6808ea 2734 "Return a number of the maximally precise representation\n"
942e5b91 2735 "expressed by the given @var{string}. @var{radix} must be an\n"
5352393c
MG		 2736 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2737 "is a default radix that may be overridden by an explicit radix\n"
2738 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2739 "supplied, then the default radix is 10. If string is not a\n"
2740 "syntactically valid notation for a number, then\n"
2741 "@code{string->number} returns @code{#f}.")
1bbd0b84 2742#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 2743{
2744 SCM answer;
1bbd0b84 2745 int base;
a6d9e5ab 2746 SCM_VALIDATE_STRING (1, string);
34d19ef6 2747 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base);
3c9a524f 2748 answer = scm_i_mem2number (SCM_STRING_CHARS (string),
d8592269
MV		 2749 SCM_STRING_LENGTH (string),
2750 base);
bb628794 2751 return scm_return_first (answer, string);
0f2d19dd 2752}
1bbd0b84 2753#undef FUNC_NAME
3c9a524f
DH		 2754
2755
0f2d19dd
JB		 2756/*** END strs->nums ***/
2757
5986c47d 2758
0f2d19dd 2759SCM
f3ae5d60 2760scm_make_real (double x)
0f2d19dd 2761{
3553e1d1
GH		 2762 SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
2763
3a9809df 2764 SCM_REAL_VALUE (z) = x;
0f2d19dd
JB		 2765 return z;
2766}
0f2d19dd 2767
5986c47d 2768
f3ae5d60
MD		 2769SCM
2770scm_make_complex (double x, double y)
2771{
0aacf84e 2772 if (y == 0.0)
3a9809df 2773 return scm_make_real (x);
0aacf84e
MD		 2774 else
2775 {
2776 SCM z;
29c4382a 2777 SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
0aacf84e
MD		 2778 "complex"));
2779 SCM_COMPLEX_REAL (z) = x;
2780 SCM_COMPLEX_IMAG (z) = y;
2781 return z;
2782 }
f3ae5d60 2783}
1cc91f1b 2784
5986c47d 2785
0f2d19dd 2786SCM
1bbd0b84 2787scm_bigequal (SCM x, SCM y)
0f2d19dd 2788{
47ae1f0e 2789 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
ca46fb90
RB		 2790 scm_remember_upto_here_2 (x, y);
2791 return SCM_BOOL (0 == result);
0f2d19dd
JB		 2792}
2793
0f2d19dd 2794SCM
f3ae5d60 2795scm_real_equalp (SCM x, SCM y)
0f2d19dd 2796{
f3ae5d60 2797 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
0f2d19dd
JB		 2798}
2799
f3ae5d60
MD		 2800SCM
2801scm_complex_equalp (SCM x, SCM y)
2802{
2803 return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
2804 && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
2805}
0f2d19dd 2806
f92e85f7
MV		 2807SCM
2808scm_i_fraction_equalp (SCM x, SCM y)
2809{
2810 scm_i_fraction_reduce (x);
2811 scm_i_fraction_reduce (y);
02164269
MV		 2812 if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
2813 SCM_FRACTION_NUMERATOR (y)))
2814 || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
2815 SCM_FRACTION_DENOMINATOR (y))))
2816 return SCM_BOOL_F;
2817 else
2818 return SCM_BOOL_T;
f92e85f7 2819}
0f2d19dd
JB		 2820
2821
1bbd0b84 2822SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
942e5b91
MG		 2823/* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2824 * "else. Note that the sets of complex, real, rational and\n"
2825 * "integer values form subsets of the set of numbers, i. e. the\n"
2826 * "predicate will be fulfilled for any number."
2827 */
a1ec6916 2828SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0,
1bbd0b84 2829 (SCM x),
942e5b91 2830 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
bb2c02f2 2831 "otherwise. Note that the sets of real, rational and integer\n"
942e5b91
MG		 2832 "values form subsets of the set of complex numbers, i. e. the\n"
2833 "predicate will also be fulfilled if @var{x} is a real,\n"
2834 "rational or integer number.")
1bbd0b84 2835#define FUNC_NAME s_scm_number_p
0f2d19dd 2836{
bb628794 2837 return SCM_BOOL (SCM_NUMBERP (x));
0f2d19dd 2838}
1bbd0b84 2839#undef FUNC_NAME
0f2d19dd
JB		 2840
2841
f92e85f7
MV		 2842SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
2843 (SCM x),
2844 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
2845 "otherwise. Note that the set of integer values forms a subset of\n"
2846 "the set of real numbers, i. e. the predicate will also be\n"
2847 "fulfilled if @var{x} is an integer number.")
2848#define FUNC_NAME s_scm_real_p
2849{
2850 /* we can't represent irrational numbers. */
2851 return scm_rational_p (x);
2852}
2853#undef FUNC_NAME
2854
2855SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
1bbd0b84 2856 (SCM x),
942e5b91 2857 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
bb2c02f2 2858 "otherwise. Note that the set of integer values forms a subset of\n"
942e5b91 2859 "the set of rational numbers, i. e. the predicate will also be\n"
f92e85f7
MV		 2860 "fulfilled if @var{x} is an integer number.")
2861#define FUNC_NAME s_scm_rational_p
0f2d19dd 2862{
0aacf84e 2863 if (SCM_INUMP (x))
0f2d19dd 2864 return SCM_BOOL_T;
0aacf84e 2865 else if (SCM_IMP (x))
0f2d19dd 2866 return SCM_BOOL_F;
0aacf84e 2867 else if (SCM_BIGP (x))
0f2d19dd 2868 return SCM_BOOL_T;
f92e85f7
MV		 2869 else if (SCM_FRACTIONP (x))
2870 return SCM_BOOL_T;
2871 else if (SCM_REALP (x))
2872 /* due to their limited precision, all floating point numbers are
2873 rational as well. */
2874 return SCM_BOOL_T;
0aacf84e 2875 else
bb628794 2876 return SCM_BOOL_F;
0f2d19dd 2877}
1bbd0b84 2878#undef FUNC_NAME
0f2d19dd
JB		 2879
2880
a1ec6916 2881SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
1bbd0b84 2882 (SCM x),
942e5b91
MG		 2883 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2884 "else.")
1bbd0b84 2885#define FUNC_NAME s_scm_integer_p
0f2d19dd
JB		 2886{
2887 double r;
f872b822
MD		 2888 if (SCM_INUMP (x))
2889 return SCM_BOOL_T;
2890 if (SCM_IMP (x))
2891 return SCM_BOOL_F;
f872b822
MD		 2892 if (SCM_BIGP (x))
2893 return SCM_BOOL_T;
3c9a524f 2894 if (!SCM_INEXACTP (x))
f872b822 2895 return SCM_BOOL_F;
3c9a524f 2896 if (SCM_COMPLEXP (x))
f872b822 2897 return SCM_BOOL_F;
5986c47d 2898 r = SCM_REAL_VALUE (x);
f872b822
MD		 2899 if (r == floor (r))
2900 return SCM_BOOL_T;
0f2d19dd
JB		 2901 return SCM_BOOL_F;
2902}
1bbd0b84 2903#undef FUNC_NAME
0f2d19dd
JB		 2904
2905
a1ec6916 2906SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
1bbd0b84 2907 (SCM x),
942e5b91
MG		 2908 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2909 "else.")
1bbd0b84 2910#define FUNC_NAME s_scm_inexact_p
0f2d19dd 2911{
eb927cb9
MV		 2912 if (SCM_INEXACTP (x))
2913 return SCM_BOOL_T;
2914 if (SCM_NUMBERP (x))
2915 return SCM_BOOL_F;
2916 SCM_WRONG_TYPE_ARG (1, x);
0f2d19dd 2917}
1bbd0b84 2918#undef FUNC_NAME
0f2d19dd
JB		 2919
2920
152f82bf 2921SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
942e5b91 2922/* "Return @code{#t} if all parameters are numerically equal." */
0f2d19dd 2923SCM
6e8d25a6 2924scm_num_eq_p (SCM x, SCM y)
0f2d19dd 2925{
0aacf84e
MD		 2926 if (SCM_INUMP (x))
2927 {
2928 long xx = SCM_INUM (x);
2929 if (SCM_INUMP (y))
2930 {
2931 long yy = SCM_INUM (y);
2932 return SCM_BOOL (xx == yy);
2933 }
2934 else if (SCM_BIGP (y))
2935 return SCM_BOOL_F;
2936 else if (SCM_REALP (y))
2937 return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));
2938 else if (SCM_COMPLEXP (y))
2939 return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))
2940 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 2941 else if (SCM_FRACTIONP (y))
2942 return SCM_BOOL_F;
0aacf84e
MD		 2943 else
2944 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2945 }
0aacf84e
MD		 2946 else if (SCM_BIGP (x))
2947 {
2948 if (SCM_INUMP (y))
2949 return SCM_BOOL_F;
2950 else if (SCM_BIGP (y))
2951 {
2952 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2953 scm_remember_upto_here_2 (x, y);
2954 return SCM_BOOL (0 == cmp);
2955 }
2956 else if (SCM_REALP (y))
2957 {
2958 int cmp;
2959 if (xisnan (SCM_REAL_VALUE (y)))
2960 return SCM_BOOL_F;
2961 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2962 scm_remember_upto_here_1 (x);
2963 return SCM_BOOL (0 == cmp);
2964 }
2965 else if (SCM_COMPLEXP (y))
2966 {
2967 int cmp;
2968 if (0.0 != SCM_COMPLEX_IMAG (y))
2969 return SCM_BOOL_F;
2970 if (xisnan (SCM_COMPLEX_REAL (y)))
2971 return SCM_BOOL_F;
2972 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
2973 scm_remember_upto_here_1 (x);
2974 return SCM_BOOL (0 == cmp);
2975 }
f92e85f7
MV		 2976 else if (SCM_FRACTIONP (y))
2977 return SCM_BOOL_F;
0aacf84e
MD		 2978 else
2979 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 2980 }
0aacf84e
MD		 2981 else if (SCM_REALP (x))
2982 {
2983 if (SCM_INUMP (y))
2984 return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));
2985 else if (SCM_BIGP (y))
2986 {
2987 int cmp;
2988 if (xisnan (SCM_REAL_VALUE (x)))
2989 return SCM_BOOL_F;
2990 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2991 scm_remember_upto_here_1 (y);
2992 return SCM_BOOL (0 == cmp);
2993 }
2994 else if (SCM_REALP (y))
2995 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
2996 else if (SCM_COMPLEXP (y))
2997 return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
2998 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 2999 else if (SCM_FRACTIONP (y))
3000 return SCM_BOOL (SCM_REAL_VALUE (x) == scm_i_fraction2double (y));
0aacf84e
MD		 3001 else
3002 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 3003 }
0aacf84e
MD		 3004 else if (SCM_COMPLEXP (x))
3005 {
3006 if (SCM_INUMP (y))
3007 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))
3008 && (SCM_COMPLEX_IMAG (x) == 0.0));
3009 else if (SCM_BIGP (y))
3010 {
3011 int cmp;
3012 if (0.0 != SCM_COMPLEX_IMAG (x))
3013 return SCM_BOOL_F;
3014 if (xisnan (SCM_COMPLEX_REAL (x)))
3015 return SCM_BOOL_F;
3016 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
3017 scm_remember_upto_here_1 (y);
3018 return SCM_BOOL (0 == cmp);
3019 }
3020 else if (SCM_REALP (y))
3021 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
3022 && (SCM_COMPLEX_IMAG (x) == 0.0));
3023 else if (SCM_COMPLEXP (y))
3024 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
3025 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 3026 else if (SCM_FRACTIONP (y))
3027 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_i_fraction2double (y))
3028 && (SCM_COMPLEX_IMAG (x) == 0.0));
3029 else
3030 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
3031 }
3032 else if (SCM_FRACTIONP (x))
3033 {
3034 if (SCM_INUMP (y))
3035 return SCM_BOOL_F;
3036 else if (SCM_BIGP (y))
3037 return SCM_BOOL_F;
3038 else if (SCM_REALP (y))
3039 return SCM_BOOL (scm_i_fraction2double (x) == SCM_REAL_VALUE (y));
3040 else if (SCM_COMPLEXP (y))
3041 return SCM_BOOL ((scm_i_fraction2double (x) == SCM_COMPLEX_REAL (y))
3042 && (0.0 == SCM_COMPLEX_IMAG (y)));
3043 else if (SCM_FRACTIONP (y))
3044 return scm_i_fraction_equalp (x, y);
0aacf84e
MD		 3045 else
3046 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 3047 }
0aacf84e 3048 else
f4c627b3 3049 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
0f2d19dd
JB		 3050}
3051
3052
152f82bf 3053SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
942e5b91
MG		 3054/* "Return @code{#t} if the list of parameters is monotonically\n"
3055 * "increasing."
3056 */
0f2d19dd 3057SCM
6e8d25a6 3058scm_less_p (SCM x, SCM y)
0f2d19dd 3059{
0aacf84e
MD		 3060 if (SCM_INUMP (x))
3061 {
3062 long xx = SCM_INUM (x);
3063 if (SCM_INUMP (y))
3064 {
3065 long yy = SCM_INUM (y);
3066 return SCM_BOOL (xx < yy);
3067 }
3068 else if (SCM_BIGP (y))
3069 {
3070 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3071 scm_remember_upto_here_1 (y);
3072 return SCM_BOOL (sgn > 0);
3073 }
3074 else if (SCM_REALP (y))
3075 return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
f92e85f7
MV		 3076 else if (SCM_FRACTIONP (y))
3077 return SCM_BOOL ((double) xx < scm_i_fraction2double (y));
0aacf84e
MD		 3078 else
3079 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 3080 }
0aacf84e
MD		 3081 else if (SCM_BIGP (x))
3082 {
3083 if (SCM_INUMP (y))
3084 {
3085 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3086 scm_remember_upto_here_1 (x);
3087 return SCM_BOOL (sgn < 0);
3088 }
3089 else if (SCM_BIGP (y))
3090 {
3091 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3092 scm_remember_upto_here_2 (x, y);
3093 return SCM_BOOL (cmp < 0);
3094 }
3095 else if (SCM_REALP (y))
3096 {
3097 int cmp;
3098 if (xisnan (SCM_REAL_VALUE (y)))
3099 return SCM_BOOL_F;
3100 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
3101 scm_remember_upto_here_1 (x);
3102 return SCM_BOOL (cmp < 0);
3103 }
f92e85f7
MV		 3104 else if (SCM_FRACTIONP (y))
3105 {
3106 int cmp;
3107 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), scm_i_fraction2double (y));
3108 scm_remember_upto_here_1 (x);
3109 return SCM_BOOL (cmp < 0);
3110 }
0aacf84e
MD		 3111 else
3112 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f4c627b3 3113 }
0aacf84e
MD		 3114 else if (SCM_REALP (x))
3115 {
3116 if (SCM_INUMP (y))
3117 return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));
3118 else if (SCM_BIGP (y))
3119 {
3120 int cmp;
3121 if (xisnan (SCM_REAL_VALUE (x)))
3122 return SCM_BOOL_F;
3123 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
3124 scm_remember_upto_here_1 (y);
3125 return SCM_BOOL (cmp > 0);
3126 }
3127 else if (SCM_REALP (y))
3128 return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
f92e85f7
MV		 3129 else if (SCM_FRACTIONP (y))
3130 return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_fraction2double (y));
3131 else
3132 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
3133 }
3134 else if (SCM_FRACTIONP (x))
3135 {
3136 if (SCM_INUMP (y))
3137 return SCM_BOOL (scm_i_fraction2double (x) < (double) SCM_INUM (y));
3138 else if (SCM_BIGP (y))
3139 {
3140 int cmp;
3141 if (xisnan (SCM_REAL_VALUE (x)))
3142 return SCM_BOOL_F;
3143 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x));
3144 scm_remember_upto_here_1 (y);
3145 return SCM_BOOL (cmp > 0);
3146 }
3147 else if (SCM_REALP (y))
3148 return SCM_BOOL (scm_i_fraction2double (x) < SCM_REAL_VALUE (y));
3149 else if (SCM_FRACTIONP (y))
3150 return SCM_BOOL (scm_i_fraction2double (x) < scm_i_fraction2double (y));
0aacf84e
MD		 3151 else
3152 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 3153 }
0aacf84e 3154 else
f4c627b3 3155 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
0f2d19dd
JB		 3156}
3157
3158
c76b1eaf 3159SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
942e5b91
MG		 3160/* "Return @code{#t} if the list of parameters is monotonically\n"
3161 * "decreasing."
c76b1eaf 3162 */
1bbd0b84 3163#define FUNC_NAME s_scm_gr_p
c76b1eaf
MD		 3164SCM
3165scm_gr_p (SCM x, SCM y)
0f2d19dd 3166{
c76b1eaf
MD		 3167 if (!SCM_NUMBERP (x))
3168 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
3169 else if (!SCM_NUMBERP (y))
3170 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
3171 else
3172 return scm_less_p (y, x);
0f2d19dd 3173}
1bbd0b84 3174#undef FUNC_NAME
0f2d19dd
JB		 3175
3176
c76b1eaf 3177SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
942e5b91 3178/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 3179 * "non-decreasing."
3180 */
1bbd0b84 3181#define FUNC_NAME s_scm_leq_p
c76b1eaf
MD		 3182SCM
3183scm_leq_p (SCM x, SCM y)
0f2d19dd 3184{
c76b1eaf
MD		 3185 if (!SCM_NUMBERP (x))
3186 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
3187 else if (!SCM_NUMBERP (y))
3188 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 3189 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
3190 return SCM_BOOL_F;
c76b1eaf
MD		 3191 else
3192 return SCM_BOOL_NOT (scm_less_p (y, x));
0f2d19dd 3193}
1bbd0b84 3194#undef FUNC_NAME
0f2d19dd
JB		 3195
3196
c76b1eaf 3197SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
942e5b91 3198/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 3199 * "non-increasing."
3200 */
1bbd0b84 3201#define FUNC_NAME s_scm_geq_p
c76b1eaf
MD		 3202SCM
3203scm_geq_p (SCM x, SCM y)
0f2d19dd 3204{
c76b1eaf
MD		 3205 if (!SCM_NUMBERP (x))
3206 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
3207 else if (!SCM_NUMBERP (y))
3208 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 3209 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
3210 return SCM_BOOL_F;
c76b1eaf 3211 else
fc194577 3212 return SCM_BOOL_NOT (scm_less_p (x, y));
0f2d19dd 3213}
1bbd0b84 3214#undef FUNC_NAME
0f2d19dd
JB		 3215
3216
152f82bf 3217SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
942e5b91
MG		 3218/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3219 * "zero."
3220 */
0f2d19dd 3221SCM
6e8d25a6 3222scm_zero_p (SCM z)
0f2d19dd 3223{
0aacf84e 3224 if (SCM_INUMP (z))
c2ff8ab0 3225 return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));
0aacf84e 3226 else if (SCM_BIGP (z))
c2ff8ab0 3227 return SCM_BOOL_F;
0aacf84e 3228 else if (SCM_REALP (z))
c2ff8ab0 3229 return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);
0aacf84e 3230 else if (SCM_COMPLEXP (z))
c2ff8ab0
DH		 3231 return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0
3232 && SCM_COMPLEX_IMAG (z) == 0.0);
f92e85f7
MV		 3233 else if (SCM_FRACTIONP (z))
3234 return SCM_BOOL_F;
0aacf84e 3235 else
c2ff8ab0 3236 SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
0f2d19dd
JB		 3237}
3238
3239
152f82bf 3240SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
942e5b91
MG		 3241/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3242 * "zero."
3243 */
0f2d19dd 3244SCM
6e8d25a6 3245scm_positive_p (SCM x)
0f2d19dd 3246{
0aacf84e 3247 if (SCM_INUMP (x))
c2ff8ab0 3248 return SCM_BOOL (SCM_INUM (x) > 0);
0aacf84e
MD		 3249 else if (SCM_BIGP (x))
3250 {
3251 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3252 scm_remember_upto_here_1 (x);
3253 return SCM_BOOL (sgn > 0);
3254 }
3255 else if (SCM_REALP (x))
c2ff8ab0 3256 return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);
f92e85f7
MV		 3257 else if (SCM_FRACTIONP (x))
3258 return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 3259 else
c2ff8ab0 3260 SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
0f2d19dd
JB		 3261}
3262
3263
152f82bf 3264SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
942e5b91
MG		 3265/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3266 * "zero."
3267 */
0f2d19dd 3268SCM
6e8d25a6 3269scm_negative_p (SCM x)
0f2d19dd 3270{
0aacf84e 3271 if (SCM_INUMP (x))
c2ff8ab0 3272 return SCM_BOOL (SCM_INUM (x) < 0);
0aacf84e
MD		 3273 else if (SCM_BIGP (x))
3274 {
3275 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3276 scm_remember_upto_here_1 (x);
3277 return SCM_BOOL (sgn < 0);
3278 }
3279 else if (SCM_REALP (x))
c2ff8ab0 3280 return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);
f92e85f7
MV		 3281 else if (SCM_FRACTIONP (x))
3282 return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 3283 else
c2ff8ab0 3284 SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
0f2d19dd
JB		 3285}
3286
3287
9de33deb 3288SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
942e5b91
MG		 3289/* "Return the maximum of all parameter values."
3290 */
0f2d19dd 3291SCM
6e8d25a6 3292scm_max (SCM x, SCM y)
0f2d19dd 3293{
0aacf84e
MD		 3294 if (SCM_UNBNDP (y))
3295 {
3296 if (SCM_UNBNDP (x))
3297 SCM_WTA_DISPATCH_0 (g_max, s_max);
3298 else if (SCM_NUMBERP (x))
3299 return x;
3300 else
3301 SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
f872b822 3302 }
f4c627b3 3303
0aacf84e
MD		 3304 if (SCM_INUMP (x))
3305 {
3306 long xx = SCM_INUM (x);
3307 if (SCM_INUMP (y))
3308 {
3309 long yy = SCM_INUM (y);
3310 return (xx < yy) ? y : x;
3311 }
3312 else if (SCM_BIGP (y))
3313 {
3314 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3315 scm_remember_upto_here_1 (y);
3316 return (sgn < 0) ? x : y;
3317 }
3318 else if (SCM_REALP (y))
3319 {
3320 double z = xx;
3321 /* if y==NaN then ">" is false and we return NaN */
3322 return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3323 }
f92e85f7
MV		 3324 else if (SCM_FRACTIONP (y))
3325 {
3326 double z = xx;
3327 return (z > scm_i_fraction2double (y)) ? x : y;
3328 }
0aacf84e
MD		 3329 else
3330 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3331 }
0aacf84e
MD		 3332 else if (SCM_BIGP (x))
3333 {
3334 if (SCM_INUMP (y))
3335 {
3336 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3337 scm_remember_upto_here_1 (x);
3338 return (sgn < 0) ? y : x;
3339 }
3340 else if (SCM_BIGP (y))
3341 {
3342 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3343 scm_remember_upto_here_2 (x, y);
3344 return (cmp > 0) ? x : y;
3345 }
3346 else if (SCM_REALP (y))
3347 {
3348 double yy = SCM_REAL_VALUE (y);
3349 int cmp;
3350 if (xisnan (yy))
3351 return y;
3352 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3353 scm_remember_upto_here_1 (x);
3354 return (cmp > 0) ? x : y;
3355 }
f92e85f7
MV		 3356 else if (SCM_FRACTIONP (y))
3357 {
3358 double yy = scm_i_fraction2double (y);
3359 int cmp;
3360 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3361 scm_remember_upto_here_1 (x);
3362 return (cmp > 0) ? x : y;
3363 }
0aacf84e
MD		 3364 else
3365 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f4c627b3 3366 }
0aacf84e
MD		 3367 else if (SCM_REALP (x))
3368 {
3369 if (SCM_INUMP (y))
3370 {
3371 double z = SCM_INUM (y);
3372 /* if x==NaN then "<" is false and we return NaN */
3373 return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;
3374 }
3375 else if (SCM_BIGP (y))
3376 {
3377 double xx = SCM_REAL_VALUE (x);
3378 int cmp;
3379 if (xisnan (xx))
3380 return x;
3381 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3382 scm_remember_upto_here_1 (y);
3383 return (cmp < 0) ? x : y;
3384 }
3385 else if (SCM_REALP (y))
3386 {
3387 /* if x==NaN then our explicit check means we return NaN
3388 if y==NaN then ">" is false and we return NaN
3389 calling isnan is unavoidable, since it's the only way to know
3390 which of x or y causes any compares to be false */
3391 double xx = SCM_REAL_VALUE (x);
3392 return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
3393 }
f92e85f7
MV		 3394 else if (SCM_FRACTIONP (y))
3395 {
3396 double yy = scm_i_fraction2double (y);
3397 double xx = SCM_REAL_VALUE (x);
3398 return (xx < yy) ? scm_make_real (yy) : x;
3399 }
3400 else
3401 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3402 }
3403 else if (SCM_FRACTIONP (x))
3404 {
3405 if (SCM_INUMP (y))
3406 {
3407 double z = SCM_INUM (y);
3408 return (scm_i_fraction2double (x) < z) ? y : x;
3409 }
3410 else if (SCM_BIGP (y))
3411 {
3412 double xx = scm_i_fraction2double (x);
3413 int cmp;
3414 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3415 scm_remember_upto_here_1 (y);
3416 return (cmp < 0) ? x : y;
3417 }
3418 else if (SCM_REALP (y))
3419 {
3420 double xx = scm_i_fraction2double (x);
3421 return (xx < SCM_REAL_VALUE (y)) ? y : scm_make_real (xx);
3422 }
3423 else if (SCM_FRACTIONP (y))
3424 {
3425 double yy = scm_i_fraction2double (y);
3426 double xx = scm_i_fraction2double (x);
3427 return (xx < yy) ? y : x;
3428 }
0aacf84e
MD		 3429 else
3430 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3431 }
0aacf84e 3432 else
f4c627b3 3433 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
0f2d19dd
JB		 3434}
3435
3436
9de33deb 3437SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
942e5b91
MG		 3438/* "Return the minium of all parameter values."
3439 */
0f2d19dd 3440SCM
6e8d25a6 3441scm_min (SCM x, SCM y)
0f2d19dd 3442{
0aacf84e
MD		 3443 if (SCM_UNBNDP (y))
3444 {
3445 if (SCM_UNBNDP (x))
3446 SCM_WTA_DISPATCH_0 (g_min, s_min);
3447 else if (SCM_NUMBERP (x))
3448 return x;
3449 else
3450 SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
f872b822 3451 }
f4c627b3 3452
0aacf84e
MD		 3453 if (SCM_INUMP (x))
3454 {
3455 long xx = SCM_INUM (x);
3456 if (SCM_INUMP (y))
3457 {
3458 long yy = SCM_INUM (y);
3459 return (xx < yy) ? x : y;
3460 }
3461 else if (SCM_BIGP (y))
3462 {
3463 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3464 scm_remember_upto_here_1 (y);
3465 return (sgn < 0) ? y : x;
3466 }
3467 else if (SCM_REALP (y))
3468 {
3469 double z = xx;
3470 /* if y==NaN then "<" is false and we return NaN */
3471 return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3472 }
f92e85f7
MV		 3473 else if (SCM_FRACTIONP (y))
3474 {
3475 double z = xx;
3476 return (z < scm_i_fraction2double (y)) ? x : y;
3477 }
0aacf84e
MD		 3478 else
3479 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3480 }
0aacf84e
MD		 3481 else if (SCM_BIGP (x))
3482 {
3483 if (SCM_INUMP (y))
3484 {
3485 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3486 scm_remember_upto_here_1 (x);
3487 return (sgn < 0) ? x : y;
3488 }
3489 else if (SCM_BIGP (y))
3490 {
3491 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3492 scm_remember_upto_here_2 (x, y);
3493 return (cmp > 0) ? y : x;
3494 }
3495 else if (SCM_REALP (y))
3496 {
3497 double yy = SCM_REAL_VALUE (y);
3498 int cmp;
3499 if (xisnan (yy))
3500 return y;
3501 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3502 scm_remember_upto_here_1 (x);
3503 return (cmp > 0) ? y : x;
3504 }
f92e85f7
MV		 3505 else if (SCM_FRACTIONP (y))
3506 {
3507 double yy = scm_i_fraction2double (y);
3508 int cmp;
3509 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3510 scm_remember_upto_here_1 (x);
3511 return (cmp > 0) ? y : x;
3512 }
0aacf84e
MD		 3513 else
3514 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f4c627b3 3515 }
0aacf84e
MD		 3516 else if (SCM_REALP (x))
3517 {
3518 if (SCM_INUMP (y))
3519 {
3520 double z = SCM_INUM (y);
3521 /* if x==NaN then "<" is false and we return NaN */
3522 return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x;
3523 }
3524 else if (SCM_BIGP (y))
3525 {
3526 double xx = SCM_REAL_VALUE (x);
3527 int cmp;
3528 if (xisnan (xx))
3529 return x;
3530 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3531 scm_remember_upto_here_1 (y);
3532 return (cmp < 0) ? y : x;
3533 }
3534 else if (SCM_REALP (y))
3535 {
3536 /* if x==NaN then our explicit check means we return NaN
3537 if y==NaN then "<" is false and we return NaN
3538 calling isnan is unavoidable, since it's the only way to know
3539 which of x or y causes any compares to be false */
3540 double xx = SCM_REAL_VALUE (x);
3541 return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
3542 }
f92e85f7
MV		 3543 else if (SCM_FRACTIONP (y))
3544 {
3545 double yy = scm_i_fraction2double (y);
3546 double xx = SCM_REAL_VALUE (x);
3547 return (yy < xx) ? scm_make_real (yy) : x;
3548 }
0aacf84e
MD		 3549 else
3550 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3551 }
f92e85f7
MV		 3552 else if (SCM_FRACTIONP (x))
3553 {
3554 if (SCM_INUMP (y))
3555 {
3556 double z = SCM_INUM (y);
3557 return (scm_i_fraction2double (x) < z) ? x : y;
3558 }
3559 else if (SCM_BIGP (y))
3560 {
3561 double xx = scm_i_fraction2double (x);
3562 int cmp;
3563 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3564 scm_remember_upto_here_1 (y);
3565 return (cmp < 0) ? y : x;
3566 }
3567 else if (SCM_REALP (y))
3568 {
3569 double xx = scm_i_fraction2double (x);
3570 return (SCM_REAL_VALUE (y) < xx) ? y : scm_make_real (xx);
3571 }
3572 else if (SCM_FRACTIONP (y))
3573 {
3574 double yy = scm_i_fraction2double (y);
3575 double xx = scm_i_fraction2double (x);
3576 return (xx < yy) ? x : y;
3577 }
3578 else
3579 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3580 }
0aacf84e 3581 else
f4c627b3 3582 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
0f2d19dd
JB		 3583}
3584
3585
9de33deb 3586SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
942e5b91
MG		 3587/* "Return the sum of all parameter values. Return 0 if called without\n"
3588 * "any parameters."
3589 */
0f2d19dd 3590SCM
6e8d25a6 3591scm_sum (SCM x, SCM y)
0f2d19dd 3592{
ca46fb90
RB		 3593 if (SCM_UNBNDP (y))
3594 {
3595 if (SCM_NUMBERP (x)) return x;
3596 if (SCM_UNBNDP (x)) return SCM_INUM0;
98cb6e75 3597 SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
f872b822 3598 }
c209c88e 3599
ca46fb90
RB		 3600 if (SCM_INUMP (x))
3601 {
3602 if (SCM_INUMP (y))
3603 {
3604 long xx = SCM_INUM (x);
3605 long yy = SCM_INUM (y);
3606 long int z = xx + yy;
3607 return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z);
3608 }
3609 else if (SCM_BIGP (y))
3610 {
3611 SCM_SWAP (x, y);
3612 goto add_big_inum;
3613 }
3614 else if (SCM_REALP (y))
3615 {
3616 long int xx = SCM_INUM (x);
3617 return scm_make_real (xx + SCM_REAL_VALUE (y));
3618 }
3619 else if (SCM_COMPLEXP (y))
3620 {
3621 long int xx = SCM_INUM (x);
3622 return scm_make_complex (xx + SCM_COMPLEX_REAL (y),
3623 SCM_COMPLEX_IMAG (y));
3624 }
f92e85f7
MV		 3625 else if (SCM_FRACTIONP (y))
3626 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
3627 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
3628 SCM_FRACTION_DENOMINATOR (y));
ca46fb90
RB		 3629 else
3630 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0aacf84e
MD		 3631 } else if (SCM_BIGP (x))
3632 {
3633 if (SCM_INUMP (y))
3634 {
3635 long int inum;
3636 int bigsgn;
3637 add_big_inum:
3638 inum = SCM_INUM (y);
3639 if (inum == 0)
3640 return x;
3641 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3642 if (inum < 0)
3643 {
3644 SCM result = scm_i_mkbig ();
3645 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
3646 scm_remember_upto_here_1 (x);
3647 /* we know the result will have to be a bignum */
3648 if (bigsgn == -1)
3649 return result;
3650 return scm_i_normbig (result);
3651 }
3652 else
3653 {
3654 SCM result = scm_i_mkbig ();
3655 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
3656 scm_remember_upto_here_1 (x);
3657 /* we know the result will have to be a bignum */
3658 if (bigsgn == 1)
3659 return result;
3660 return scm_i_normbig (result);
3661 }
3662 }
3663 else if (SCM_BIGP (y))
3664 {
3665 SCM result = scm_i_mkbig ();
3666 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3667 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3668 mpz_add (SCM_I_BIG_MPZ (result),
3669 SCM_I_BIG_MPZ (x),
3670 SCM_I_BIG_MPZ (y));
3671 scm_remember_upto_here_2 (x, y);
3672 /* we know the result will have to be a bignum */
3673 if (sgn_x == sgn_y)
3674 return result;
3675 return scm_i_normbig (result);
3676 }
3677 else if (SCM_REALP (y))
3678 {
3679 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
3680 scm_remember_upto_here_1 (x);
3681 return scm_make_real (result);
3682 }
3683 else if (SCM_COMPLEXP (y))
3684 {
3685 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3686 + SCM_COMPLEX_REAL (y));
3687 scm_remember_upto_here_1 (x);
3688 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3689 }
f92e85f7
MV		 3690 else if (SCM_FRACTIONP (y))
3691 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
3692 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
3693 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 3694 else
3695 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0f2d19dd 3696 }
0aacf84e
MD		 3697 else if (SCM_REALP (x))
3698 {
3699 if (SCM_INUMP (y))
3700 return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));
3701 else if (SCM_BIGP (y))
3702 {
3703 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
3704 scm_remember_upto_here_1 (y);
3705 return scm_make_real (result);
3706 }
3707 else if (SCM_REALP (y))
3708 return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
3709 else if (SCM_COMPLEXP (y))
3710 return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
3711 SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3712 else if (SCM_FRACTIONP (y))
3713 return scm_make_real (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
0aacf84e
MD		 3714 else
3715 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3716 }
0aacf84e
MD		 3717 else if (SCM_COMPLEXP (x))
3718 {
3719 if (SCM_INUMP (y))
3720 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),
3721 SCM_COMPLEX_IMAG (x));
3722 else if (SCM_BIGP (y))
3723 {
3724 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
3725 + SCM_COMPLEX_REAL (x));
3726 scm_remember_upto_here_1 (y);
3727 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));
3728 }
3729 else if (SCM_REALP (y))
3730 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
3731 SCM_COMPLEX_IMAG (x));
3732 else if (SCM_COMPLEXP (y))
3733 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
3734 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3735 else if (SCM_FRACTIONP (y))
3736 return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
3737 SCM_COMPLEX_IMAG (x));
3738 else
3739 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3740 }
3741 else if (SCM_FRACTIONP (x))
3742 {
3743 if (SCM_INUMP (y))
3744 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
3745 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
3746 SCM_FRACTION_DENOMINATOR (x));
3747 else if (SCM_BIGP (y))
3748 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
3749 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
3750 SCM_FRACTION_DENOMINATOR (x));
3751 else if (SCM_REALP (y))
3752 return scm_make_real (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
3753 else if (SCM_COMPLEXP (y))
3754 return scm_make_complex (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
3755 SCM_COMPLEX_IMAG (y));
3756 else if (SCM_FRACTIONP (y))
3757 /* a/b + c/d = (ad + bc) / bd */
3758 return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
3759 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
3760 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 3761 else
3762 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
98cb6e75 3763 }
0aacf84e 3764 else
98cb6e75 3765 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
0f2d19dd
JB		 3766}
3767
3768
9de33deb 3769SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
609c3d30
MG		 3770/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3771 * the sum of all but the first argument are subtracted from the first
3772 * argument. */
c05e97b7 3773#define FUNC_NAME s_difference
0f2d19dd 3774SCM
6e8d25a6 3775scm_difference (SCM x, SCM y)
0f2d19dd 3776{
ca46fb90
RB		 3777 if (SCM_UNBNDP (y))
3778 {
3779 if (SCM_UNBNDP (x))
3780 SCM_WTA_DISPATCH_0 (g_difference, s_difference);
3781 else
3782 if (SCM_INUMP (x))
3783 {
3784 long xx = -SCM_INUM (x);
3785 if (SCM_FIXABLE (xx))
3786 return SCM_MAKINUM (xx);
3787 else
3788 return scm_i_long2big (xx);
3789 }
3790 else if (SCM_BIGP (x))
3791 /* FIXME: do we really need to normalize here? */
3792 return scm_i_normbig (scm_i_clonebig (x, 0));
3793 else if (SCM_REALP (x))
3794 return scm_make_real (-SCM_REAL_VALUE (x));
3795 else if (SCM_COMPLEXP (x))
3796 return scm_make_complex (-SCM_COMPLEX_REAL (x),
3797 -SCM_COMPLEX_IMAG (x));
f92e85f7
MV		 3798 else if (SCM_FRACTIONP (x))
3799 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
3800 SCM_FRACTION_DENOMINATOR (x));
ca46fb90
RB		 3801 else
3802 SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
f872b822 3803 }
ca46fb90 3804
0aacf84e
MD		 3805 if (SCM_INUMP (x))
3806 {
3807 if (SCM_INUMP (y))
3808 {
3809 long int xx = SCM_INUM (x);
3810 long int yy = SCM_INUM (y);
3811 long int z = xx - yy;
3812 if (SCM_FIXABLE (z))
3813 return SCM_MAKINUM (z);
3814 else
3815 return scm_i_long2big (z);
3816 }
3817 else if (SCM_BIGP (y))
3818 {
3819 /* inum-x - big-y */
3820 long xx = SCM_INUM (x);
ca46fb90 3821
0aacf84e
MD		 3822 if (xx == 0)
3823 return scm_i_clonebig (y, 0);
3824 else
3825 {
3826 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3827 SCM result = scm_i_mkbig ();
ca46fb90 3828
0aacf84e
MD		 3829 if (xx >= 0)
3830 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
3831 else
3832 {
3833 /* x - y == -(y + -x) */
3834 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
3835 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3836 }
3837 scm_remember_upto_here_1 (y);
ca46fb90 3838
0aacf84e
MD		 3839 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
3840 /* we know the result will have to be a bignum */
3841 return result;
3842 else
3843 return scm_i_normbig (result);
3844 }
3845 }
3846 else if (SCM_REALP (y))
3847 {
3848 long int xx = SCM_INUM (x);
3849 return scm_make_real (xx - SCM_REAL_VALUE (y));
3850 }
3851 else if (SCM_COMPLEXP (y))
3852 {
3853 long int xx = SCM_INUM (x);
3854 return scm_make_complex (xx - SCM_COMPLEX_REAL (y),
3855 - SCM_COMPLEX_IMAG (y));
3856 }
f92e85f7
MV		 3857 else if (SCM_FRACTIONP (y))
3858 /* a - b/c = (ac - b) / c */
3859 return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
3860 SCM_FRACTION_NUMERATOR (y)),
3861 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 3862 else
3863 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3864 }
0aacf84e
MD		 3865 else if (SCM_BIGP (x))
3866 {
3867 if (SCM_INUMP (y))
3868 {
3869 /* big-x - inum-y */
3870 long yy = SCM_INUM (y);
3871 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
ca46fb90 3872
0aacf84e
MD		 3873 scm_remember_upto_here_1 (x);
3874 if (sgn_x == 0)
3875 return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);
3876 else
3877 {
3878 SCM result = scm_i_mkbig ();
ca46fb90 3879
708f22c6
KR		 3880 if (yy >= 0)
3881 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
3882 else
3883 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
0aacf84e 3884 scm_remember_upto_here_1 (x);
ca46fb90 3885
0aacf84e
MD		 3886 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
3887 /* we know the result will have to be a bignum */
3888 return result;
3889 else
3890 return scm_i_normbig (result);
3891 }
3892 }
3893 else if (SCM_BIGP (y))
3894 {
3895 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3896 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3897 SCM result = scm_i_mkbig ();
3898 mpz_sub (SCM_I_BIG_MPZ (result),
3899 SCM_I_BIG_MPZ (x),
3900 SCM_I_BIG_MPZ (y));
3901 scm_remember_upto_here_2 (x, y);
3902 /* we know the result will have to be a bignum */
3903 if ((sgn_x == 1) && (sgn_y == -1))
3904 return result;
3905 if ((sgn_x == -1) && (sgn_y == 1))
3906 return result;
3907 return scm_i_normbig (result);
3908 }
3909 else if (SCM_REALP (y))
3910 {
3911 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
3912 scm_remember_upto_here_1 (x);
3913 return scm_make_real (result);
3914 }
3915 else if (SCM_COMPLEXP (y))
3916 {
3917 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3918 - SCM_COMPLEX_REAL (y));
3919 scm_remember_upto_here_1 (x);
3920 return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));
3921 }
f92e85f7
MV		 3922 else if (SCM_FRACTIONP (y))
3923 return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
3924 SCM_FRACTION_NUMERATOR (y)),
3925 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 3926 else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
ca46fb90 3927 }
0aacf84e
MD		 3928 else if (SCM_REALP (x))
3929 {
3930 if (SCM_INUMP (y))
3931 return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));
3932 else if (SCM_BIGP (y))
3933 {
3934 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
3935 scm_remember_upto_here_1 (x);
3936 return scm_make_real (result);
3937 }
3938 else if (SCM_REALP (y))
3939 return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
3940 else if (SCM_COMPLEXP (y))
3941 return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
3942 -SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3943 else if (SCM_FRACTIONP (y))
3944 return scm_make_real (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
0aacf84e
MD		 3945 else
3946 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 3947 }
0aacf84e
MD		 3948 else if (SCM_COMPLEXP (x))
3949 {
3950 if (SCM_INUMP (y))
3951 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),
3952 SCM_COMPLEX_IMAG (x));
3953 else if (SCM_BIGP (y))
3954 {
3955 double real_part = (SCM_COMPLEX_REAL (x)
3956 - mpz_get_d (SCM_I_BIG_MPZ (y)));
3957 scm_remember_upto_here_1 (x);
3958 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3959 }
3960 else if (SCM_REALP (y))
3961 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
3962 SCM_COMPLEX_IMAG (x));
3963 else if (SCM_COMPLEXP (y))
3964 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
3965 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3966 else if (SCM_FRACTIONP (y))
3967 return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
3968 SCM_COMPLEX_IMAG (x));
3969 else
3970 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3971 }
3972 else if (SCM_FRACTIONP (x))
3973 {
3974 if (SCM_INUMP (y))
3975 /* a/b - c = (a - cb) / b */
3976 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
3977 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
3978 SCM_FRACTION_DENOMINATOR (x));
3979 else if (SCM_BIGP (y))
3980 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
3981 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
3982 SCM_FRACTION_DENOMINATOR (x));
3983 else if (SCM_REALP (y))
3984 return scm_make_real (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
3985 else if (SCM_COMPLEXP (y))
3986 return scm_make_complex (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
3987 -SCM_COMPLEX_IMAG (y));
3988 else if (SCM_FRACTIONP (y))
3989 /* a/b - c/d = (ad - bc) / bd */
3990 return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
3991 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
3992 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 3993 else
3994 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 3995 }
0aacf84e 3996 else
98cb6e75 3997 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
0f2d19dd 3998}
c05e97b7 3999#undef FUNC_NAME
0f2d19dd 4000
ca46fb90 4001
9de33deb 4002SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
942e5b91
MG		 4003/* "Return the product of all arguments. If called without arguments,\n"
4004 * "1 is returned."
4005 */
0f2d19dd 4006SCM
6e8d25a6 4007scm_product (SCM x, SCM y)
0f2d19dd 4008{
0aacf84e
MD		 4009 if (SCM_UNBNDP (y))
4010 {
4011 if (SCM_UNBNDP (x))
4012 return SCM_MAKINUM (1L);
4013 else if (SCM_NUMBERP (x))
4014 return x;
4015 else
4016 SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
f872b822 4017 }
ca46fb90 4018
0aacf84e
MD		 4019 if (SCM_INUMP (x))
4020 {
4021 long xx;
f4c627b3 4022
0aacf84e
MD		 4023 intbig:
4024 xx = SCM_INUM (x);
f4c627b3 4025
0aacf84e
MD		 4026 switch (xx)
4027 {
ca46fb90
RB		 4028 case 0: return x; break;
4029 case 1: return y; break;
0aacf84e 4030 }
f4c627b3 4031
0aacf84e
MD		 4032 if (SCM_INUMP (y))
4033 {
4034 long yy = SCM_INUM (y);
4035 long kk = xx * yy;
4036 SCM k = SCM_MAKINUM (kk);
4037 if ((kk == SCM_INUM (k)) && (kk / xx == yy))
4038 return k;
4039 else
4040 {
4041 SCM result = scm_i_long2big (xx);
4042 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
4043 return scm_i_normbig (result);
4044 }
4045 }
4046 else if (SCM_BIGP (y))
4047 {
4048 SCM result = scm_i_mkbig ();
4049 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
4050 scm_remember_upto_here_1 (y);
4051 return result;
4052 }
4053 else if (SCM_REALP (y))
4054 return scm_make_real (xx * SCM_REAL_VALUE (y));
4055 else if (SCM_COMPLEXP (y))
4056 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
4057 xx * SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4058 else if (SCM_FRACTIONP (y))
4059 return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
4060 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4061 else
4062 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4063 }
0aacf84e
MD		 4064 else if (SCM_BIGP (x))
4065 {
4066 if (SCM_INUMP (y))
4067 {
4068 SCM_SWAP (x, y);
4069 goto intbig;
4070 }
4071 else if (SCM_BIGP (y))
4072 {
4073 SCM result = scm_i_mkbig ();
4074 mpz_mul (SCM_I_BIG_MPZ (result),
4075 SCM_I_BIG_MPZ (x),
4076 SCM_I_BIG_MPZ (y));
4077 scm_remember_upto_here_2 (x, y);
4078 return result;
4079 }
4080 else if (SCM_REALP (y))
4081 {
4082 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
4083 scm_remember_upto_here_1 (x);
4084 return scm_make_real (result);
4085 }
4086 else if (SCM_COMPLEXP (y))
4087 {
4088 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
4089 scm_remember_upto_here_1 (x);
4090 return scm_make_complex (z * SCM_COMPLEX_REAL (y),
4091 z * SCM_COMPLEX_IMAG (y));
4092 }
f92e85f7
MV		 4093 else if (SCM_FRACTIONP (y))
4094 return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
4095 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4096 else
4097 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4098 }
0aacf84e
MD		 4099 else if (SCM_REALP (x))
4100 {
4101 if (SCM_INUMP (y))
4102 return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));
4103 else if (SCM_BIGP (y))
4104 {
4105 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
4106 scm_remember_upto_here_1 (y);
4107 return scm_make_real (result);
4108 }
4109 else if (SCM_REALP (y))
4110 return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
4111 else if (SCM_COMPLEXP (y))
4112 return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
4113 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4114 else if (SCM_FRACTIONP (y))
4115 return scm_make_real (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
0aacf84e
MD		 4116 else
4117 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4118 }
0aacf84e
MD		 4119 else if (SCM_COMPLEXP (x))
4120 {
4121 if (SCM_INUMP (y))
4122 return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),
4123 SCM_INUM (y) * SCM_COMPLEX_IMAG (x));
4124 else if (SCM_BIGP (y))
4125 {
4126 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
4127 scm_remember_upto_here_1 (y);
76506335
KR		 4128 return scm_make_complex (z * SCM_COMPLEX_REAL (x),
4129 z * SCM_COMPLEX_IMAG (x));
0aacf84e
MD		 4130 }
4131 else if (SCM_REALP (y))
4132 return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
4133 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
4134 else if (SCM_COMPLEXP (y))
4135 {
4136 return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
4137 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
4138 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
4139 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
4140 }
f92e85f7
MV		 4141 else if (SCM_FRACTIONP (y))
4142 {
4143 double yy = scm_i_fraction2double (y);
4144 return scm_make_complex (yy * SCM_COMPLEX_REAL (x),
4145 yy * SCM_COMPLEX_IMAG (x));
4146 }
4147 else
4148 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
4149 }
4150 else if (SCM_FRACTIONP (x))
4151 {
4152 if (SCM_INUMP (y))
4153 return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
4154 SCM_FRACTION_DENOMINATOR (x));
4155 else if (SCM_BIGP (y))
4156 return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
4157 SCM_FRACTION_DENOMINATOR (x));
4158 else if (SCM_REALP (y))
4159 return scm_make_real (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
4160 else if (SCM_COMPLEXP (y))
4161 {
4162 double xx = scm_i_fraction2double (x);
4163 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
4164 xx * SCM_COMPLEX_IMAG (y));
4165 }
4166 else if (SCM_FRACTIONP (y))
4167 /* a/b * c/d = ac / bd */
4168 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
4169 SCM_FRACTION_NUMERATOR (y)),
4170 scm_product (SCM_FRACTION_DENOMINATOR (x),
4171 SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 4172 else
4173 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4174 }
0aacf84e 4175 else
f4c627b3 4176 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
0f2d19dd
JB		 4177}
4178
0f2d19dd 4179double
6e8d25a6 4180scm_num2dbl (SCM a, const char *why)
f4c627b3 4181#define FUNC_NAME why
0f2d19dd 4182{
0aacf84e 4183 if (SCM_INUMP (a))
0f2d19dd 4184 return (double) SCM_INUM (a);
0aacf84e
MD		 4185 else if (SCM_BIGP (a))
4186 {
4187 double result = mpz_get_d (SCM_I_BIG_MPZ (a));
4188 scm_remember_upto_here_1 (a);
4189 return result;
4190 }
4191 else if (SCM_REALP (a))
f4c627b3 4192 return (SCM_REAL_VALUE (a));
f92e85f7
MV		 4193 else if (SCM_FRACTIONP (a))
4194 return scm_i_fraction2double (a);
0aacf84e 4195 else
f4c627b3 4196 SCM_WRONG_TYPE_ARG (SCM_ARGn, a);
0f2d19dd 4197}
f4c627b3 4198#undef FUNC_NAME
0f2d19dd 4199
7351e207
MV		 4200#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
4201 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
4202#define ALLOW_DIVIDE_BY_ZERO
4203/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
4204#endif
0f2d19dd 4205
ba74ef4e
MV		 4206/* The code below for complex division is adapted from the GNU
4207 libstdc++, which adapted it from f2c's libF77, and is subject to
4208 this copyright: */
4209
4210/****************************************************************
4211Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
4212
4213Permission to use, copy, modify, and distribute this software
4214and its documentation for any purpose and without fee is hereby
4215granted, provided that the above copyright notice appear in all
4216copies and that both that the copyright notice and this
4217permission notice and warranty disclaimer appear in supporting
4218documentation, and that the names of AT&T Bell Laboratories or
4219Bellcore or any of their entities not be used in advertising or
4220publicity pertaining to distribution of the software without
4221specific, written prior permission.
4222
4223AT&T and Bellcore disclaim all warranties with regard to this
4224software, including all implied warranties of merchantability
4225and fitness. In no event shall AT&T or Bellcore be liable for
4226any special, indirect or consequential damages or any damages
4227whatsoever resulting from loss of use, data or profits, whether
4228in an action of contract, negligence or other tortious action,
4229arising out of or in connection with the use or performance of
4230this software.
4231****************************************************************/
4232
9de33deb 4233SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
609c3d30
MG		 4234/* Divide the first argument by the product of the remaining
4235 arguments. If called with one argument @var{z1}, 1/@var{z1} is
4236 returned. */
c05e97b7 4237#define FUNC_NAME s_divide
f92e85f7
MV		 4238static SCM
4239scm_i_divide (SCM x, SCM y, int inexact)
0f2d19dd 4240{
f8de44c1
DH		 4241 double a;
4242
0aacf84e
MD		 4243 if (SCM_UNBNDP (y))
4244 {
4245 if (SCM_UNBNDP (x))
4246 SCM_WTA_DISPATCH_0 (g_divide, s_divide);
4247 else if (SCM_INUMP (x))
4248 {
4249 long xx = SCM_INUM (x);
4250 if (xx == 1 || xx == -1)
4251 return x;
7351e207 4252#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4253 else if (xx == 0)
4254 scm_num_overflow (s_divide);
7351e207 4255#endif
0aacf84e 4256 else
f92e85f7
MV		 4257 {
4258 if (inexact)
4259 return scm_make_real (1.0 / (double) xx);
4260 else return scm_make_ratio (SCM_MAKINUM(1), x);
4261 }
0aacf84e
MD		 4262 }
4263 else if (SCM_BIGP (x))
f92e85f7
MV		 4264 {
4265 if (inexact)
4266 return scm_make_real (1.0 / scm_i_big2dbl (x));
4267 else return scm_make_ratio (SCM_MAKINUM(1), x);
4268 }
0aacf84e
MD		 4269 else if (SCM_REALP (x))
4270 {
4271 double xx = SCM_REAL_VALUE (x);
7351e207 4272#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4273 if (xx == 0.0)
4274 scm_num_overflow (s_divide);
4275 else
7351e207 4276#endif
0aacf84e
MD		 4277 return scm_make_real (1.0 / xx);
4278 }
4279 else if (SCM_COMPLEXP (x))
4280 {
4281 double r = SCM_COMPLEX_REAL (x);
4282 double i = SCM_COMPLEX_IMAG (x);
4283 if (r <= i)
4284 {
4285 double t = r / i;
4286 double d = i * (1.0 + t * t);
4287 return scm_make_complex (t / d, -1.0 / d);
4288 }
4289 else
4290 {
4291 double t = i / r;
4292 double d = r * (1.0 + t * t);
4293 return scm_make_complex (1.0 / d, -t / d);
4294 }
4295 }
f92e85f7
MV		 4296 else if (SCM_FRACTIONP (x))
4297 return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x),
4298 SCM_FRACTION_NUMERATOR (x));
0aacf84e
MD		 4299 else
4300 SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
f8de44c1 4301 }
f8de44c1 4302
0aacf84e
MD		 4303 if (SCM_INUMP (x))
4304 {
4305 long xx = SCM_INUM (x);
4306 if (SCM_INUMP (y))
4307 {
4308 long yy = SCM_INUM (y);
4309 if (yy == 0)
4310 {
7351e207 4311#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4312 scm_num_overflow (s_divide);
7351e207 4313#else
0aacf84e 4314 return scm_make_real ((double) xx / (double) yy);
7351e207 4315#endif
0aacf84e
MD		 4316 }
4317 else if (xx % yy != 0)
f92e85f7
MV		 4318 {
4319 if (inexact)
4320 return scm_make_real ((double) xx / (double) yy);
4321 else return scm_make_ratio (x, y);
4322 }
0aacf84e
MD		 4323 else
4324 {
4325 long z = xx / yy;
4326 if (SCM_FIXABLE (z))
4327 return SCM_MAKINUM (z);
4328 else
4329 return scm_i_long2big (z);
4330 }
f872b822 4331 }
0aacf84e 4332 else if (SCM_BIGP (y))
f92e85f7
MV		 4333 {
4334 if (inexact)
4335 return scm_make_real ((double) xx / scm_i_big2dbl (y));
4336 else return scm_make_ratio (x, y);
4337 }
0aacf84e
MD		 4338 else if (SCM_REALP (y))
4339 {
4340 double yy = SCM_REAL_VALUE (y);
7351e207 4341#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4342 if (yy == 0.0)
4343 scm_num_overflow (s_divide);
4344 else
7351e207 4345#endif
0aacf84e 4346 return scm_make_real ((double) xx / yy);
ba74ef4e 4347 }
0aacf84e
MD		 4348 else if (SCM_COMPLEXP (y))
4349 {
4350 a = xx;
4351 complex_div: /* y _must_ be a complex number */
4352 {
4353 double r = SCM_COMPLEX_REAL (y);
4354 double i = SCM_COMPLEX_IMAG (y);
4355 if (r <= i)
4356 {
4357 double t = r / i;
4358 double d = i * (1.0 + t * t);
4359 return scm_make_complex ((a * t) / d, -a / d);
4360 }
4361 else
4362 {
4363 double t = i / r;
4364 double d = r * (1.0 + t * t);
4365 return scm_make_complex (a / d, -(a * t) / d);
4366 }
4367 }
4368 }
f92e85f7
MV		 4369 else if (SCM_FRACTIONP (y))
4370 /* a / b/c = ac / b */
4371 return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4372 SCM_FRACTION_NUMERATOR (y));
0aacf84e
MD		 4373 else
4374 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 4375 }
0aacf84e
MD		 4376 else if (SCM_BIGP (x))
4377 {
4378 if (SCM_INUMP (y))
4379 {
4380 long int yy = SCM_INUM (y);
4381 if (yy == 0)
4382 {
7351e207 4383#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4384 scm_num_overflow (s_divide);
7351e207 4385#else
0aacf84e
MD		 4386 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
4387 scm_remember_upto_here_1 (x);
4388 return (sgn == 0) ? scm_nan () : scm_inf ();
7351e207 4389#endif
0aacf84e
MD		 4390 }
4391 else if (yy == 1)
4392 return x;
4393 else
4394 {
4395 /* FIXME: HMM, what are the relative performance issues here?
4396 We need to test. Is it faster on average to test
4397 divisible_p, then perform whichever operation, or is it
4398 faster to perform the integer div opportunistically and
4399 switch to real if there's a remainder? For now we take the
4400 middle ground: test, then if divisible, use the faster div
4401 func. */
4402
4403 long abs_yy = yy < 0 ? -yy : yy;
4404 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
4405
4406 if (divisible_p)
4407 {
4408 SCM result = scm_i_mkbig ();
4409 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
4410 scm_remember_upto_here_1 (x);
4411 if (yy < 0)
4412 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
4413 return scm_i_normbig (result);
4414 }
4415 else
f92e85f7
MV		 4416 {
4417 if (inexact)
4418 return scm_make_real (scm_i_big2dbl (x) / (double) yy);
4419 else return scm_make_ratio (x, y);
4420 }
0aacf84e
MD		 4421 }
4422 }
4423 else if (SCM_BIGP (y))
4424 {
4425 int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
4426 if (y_is_zero)
4427 {
ca46fb90 4428#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4429 scm_num_overflow (s_divide);
f872b822 4430#else
0aacf84e
MD		 4431 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
4432 scm_remember_upto_here_1 (x);
4433 return (sgn == 0) ? scm_nan () : scm_inf ();
f872b822 4434#endif
0aacf84e
MD		 4435 }
4436 else
4437 {
4438 /* big_x / big_y */
4439 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
4440 SCM_I_BIG_MPZ (y));
4441 if (divisible_p)
4442 {
4443 SCM result = scm_i_mkbig ();
4444 mpz_divexact (SCM_I_BIG_MPZ (result),
4445 SCM_I_BIG_MPZ (x),
4446 SCM_I_BIG_MPZ (y));
4447 scm_remember_upto_here_2 (x, y);
4448 return scm_i_normbig (result);
4449 }
4450 else
4451 {
f92e85f7
MV		 4452 if (inexact)
4453 {
4454 double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));
4455 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4456 scm_remember_upto_here_2 (x, y);
4457 return scm_make_real (dbx / dby);
4458 }
4459 else return scm_make_ratio (x, y);
0aacf84e
MD		 4460 }
4461 }
4462 }
4463 else if (SCM_REALP (y))
4464 {
4465 double yy = SCM_REAL_VALUE (y);
7351e207 4466#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4467 if (yy == 0.0)
4468 scm_num_overflow (s_divide);
4469 else
7351e207 4470#endif
0aacf84e
MD		 4471 return scm_make_real (scm_i_big2dbl (x) / yy);
4472 }
4473 else if (SCM_COMPLEXP (y))
4474 {
4475 a = scm_i_big2dbl (x);
4476 goto complex_div;
4477 }
f92e85f7
MV		 4478 else if (SCM_FRACTIONP (y))
4479 return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4480 SCM_FRACTION_NUMERATOR (y));
0aacf84e
MD		 4481 else
4482 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 4483 }
0aacf84e
MD		 4484 else if (SCM_REALP (x))
4485 {
4486 double rx = SCM_REAL_VALUE (x);
4487 if (SCM_INUMP (y))
4488 {
4489 long int yy = SCM_INUM (y);
7351e207 4490#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4491 if (yy == 0)
4492 scm_num_overflow (s_divide);
4493 else
7351e207 4494#endif
0aacf84e
MD		 4495 return scm_make_real (rx / (double) yy);
4496 }
4497 else if (SCM_BIGP (y))
4498 {
4499 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4500 scm_remember_upto_here_1 (y);
4501 return scm_make_real (rx / dby);
4502 }
4503 else if (SCM_REALP (y))
4504 {
4505 double yy = SCM_REAL_VALUE (y);
7351e207 4506#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4507 if (yy == 0.0)
4508 scm_num_overflow (s_divide);
4509 else
7351e207 4510#endif
0aacf84e
MD		 4511 return scm_make_real (rx / yy);
4512 }
4513 else if (SCM_COMPLEXP (y))
4514 {
4515 a = rx;
4516 goto complex_div;
4517 }
f92e85f7
MV		 4518 else if (SCM_FRACTIONP (y))
4519 return scm_make_real (rx / scm_i_fraction2double (y));
0aacf84e
MD		 4520 else
4521 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 4522 }
0aacf84e
MD		 4523 else if (SCM_COMPLEXP (x))
4524 {
4525 double rx = SCM_COMPLEX_REAL (x);
4526 double ix = SCM_COMPLEX_IMAG (x);
4527 if (SCM_INUMP (y))
4528 {
4529 long int yy = SCM_INUM (y);
7351e207 4530#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4531 if (yy == 0)
4532 scm_num_overflow (s_divide);
4533 else
7351e207 4534#endif
0aacf84e
MD		 4535 {
4536 double d = yy;
4537 return scm_make_complex (rx / d, ix / d);
4538 }
4539 }
4540 else if (SCM_BIGP (y))
4541 {
4542 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4543 scm_remember_upto_here_1 (y);
4544 return scm_make_complex (rx / dby, ix / dby);
4545 }
4546 else if (SCM_REALP (y))
4547 {
4548 double yy = SCM_REAL_VALUE (y);
7351e207 4549#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4550 if (yy == 0.0)
4551 scm_num_overflow (s_divide);
4552 else
7351e207 4553#endif
0aacf84e
MD		 4554 return scm_make_complex (rx / yy, ix / yy);
4555 }
4556 else if (SCM_COMPLEXP (y))
4557 {
4558 double ry = SCM_COMPLEX_REAL (y);
4559 double iy = SCM_COMPLEX_IMAG (y);
4560 if (ry <= iy)
4561 {
4562 double t = ry / iy;
4563 double d = iy * (1.0 + t * t);
4564 return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);
4565 }
4566 else
4567 {
4568 double t = iy / ry;
4569 double d = ry * (1.0 + t * t);
4570 return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);
4571 }
4572 }
f92e85f7
MV		 4573 else if (SCM_FRACTIONP (y))
4574 {
4575 double yy = scm_i_fraction2double (y);
4576 return scm_make_complex (rx / yy, ix / yy);
4577 }
0aacf84e
MD		 4578 else
4579 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 4580 }
f92e85f7
MV		 4581 else if (SCM_FRACTIONP (x))
4582 {
4583 if (SCM_INUMP (y))
4584 {
4585 long int yy = SCM_INUM (y);
4586#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4587 if (yy == 0)
4588 scm_num_overflow (s_divide);
4589 else
4590#endif
4591 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x),
4592 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
4593 }
4594 else if (SCM_BIGP (y))
4595 {
4596 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x),
4597 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
4598 }
4599 else if (SCM_REALP (y))
4600 {
4601 double yy = SCM_REAL_VALUE (y);
4602#ifndef ALLOW_DIVIDE_BY_ZERO
4603 if (yy == 0.0)
4604 scm_num_overflow (s_divide);
4605 else
4606#endif
4607 return scm_make_real (scm_i_fraction2double (x) / yy);
4608 }
4609 else if (SCM_COMPLEXP (y))
4610 {
4611 a = scm_i_fraction2double (x);
4612 goto complex_div;
4613 }
4614 else if (SCM_FRACTIONP (y))
4615 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
4616 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
4617 else
4618 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
4619 }
0aacf84e 4620 else
f8de44c1 4621 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
0f2d19dd 4622}
f92e85f7
MV		 4623
4624SCM
4625scm_divide (SCM x, SCM y)
4626{
4627 return scm_i_divide (x, y, 0);
4628}
4629
4630static SCM scm_divide2real (SCM x, SCM y)
4631{
4632 return scm_i_divide (x, y, 1);
4633}
c05e97b7 4634#undef FUNC_NAME
0f2d19dd 4635
fa605590 4636
0f2d19dd 4637double
6e8d25a6 4638scm_asinh (double x)
0f2d19dd 4639{
fa605590
KR		 4640#if HAVE_ASINH
4641 return asinh (x);
4642#else
4643#define asinh scm_asinh
f872b822 4644 return log (x + sqrt (x * x + 1));
fa605590 4645#endif
0f2d19dd 4646}
fa605590
KR		 4647SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
4648/* "Return the inverse hyperbolic sine of @var{x}."
4649 */
0f2d19dd
JB		 4650
4651
0f2d19dd 4652double
6e8d25a6 4653scm_acosh (double x)
0f2d19dd 4654{
fa605590
KR		 4655#if HAVE_ACOSH
4656 return acosh (x);
4657#else
4658#define acosh scm_acosh
f872b822 4659 return log (x + sqrt (x * x - 1));
fa605590 4660#endif
0f2d19dd 4661}
fa605590
KR		 4662SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
4663/* "Return the inverse hyperbolic cosine of @var{x}."
4664 */
0f2d19dd
JB		 4665
4666
0f2d19dd 4667double
6e8d25a6 4668scm_atanh (double x)
0f2d19dd 4669{
fa605590
KR		 4670#if HAVE_ATANH
4671 return atanh (x);
4672#else
4673#define atanh scm_atanh
f872b822 4674 return 0.5 * log ((1 + x) / (1 - x));
fa605590 4675#endif
0f2d19dd 4676}
fa605590
KR		 4677SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
4678/* "Return the inverse hyperbolic tangent of @var{x}."
4679 */
0f2d19dd
JB		 4680
4681
f92e85f7
MV		 4682/* XXX - eventually, we should remove this definition of scm_round and
4683 rename scm_round_number to scm_round. Likewise for scm_truncate
4684 and scm_truncate_number.
4685 */
4686
0f2d19dd 4687double
6e8d25a6 4688scm_truncate (double x)
0f2d19dd 4689{
fa605590
KR		 4690#if HAVE_TRUNC
4691 return trunc (x);
4692#else
4693#define trunc scm_truncate
f872b822
MD		 4694 if (x < 0.0)
4695 return -floor (-x);
4696 return floor (x);
fa605590 4697#endif
0f2d19dd 4698}
0f2d19dd 4699
0f2d19dd 4700double
6e8d25a6 4701scm_round (double x)
0f2d19dd
JB		 4702{
4703 double plus_half = x + 0.5;
f872b822 4704 double result = floor (plus_half);
0f2d19dd 4705 /* Adjust so that the scm_round is towards even. */
0aacf84e
MD		 4706 return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
4707 ? result - 1
4708 : result);
0f2d19dd
JB		 4709}
4710
f92e85f7
MV		 4711SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0,
4712 (SCM x),
4713 "Round the number @var{x} towards zero.")
4714#define FUNC_NAME s_scm_truncate_number
4715{
4716 if (SCM_FALSEP (scm_negative_p (x)))
4717 return scm_floor (x);
4718 else
4719 return scm_ceiling (x);
4720}
4721#undef FUNC_NAME
4722
4723static SCM exactly_one_half;
4724
4725SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
4726 (SCM x),
4727 "Round the number @var{x} towards the nearest integer. "
4728 "When it is exactly halfway between two integers, "
4729 "round towards the even one.")
4730#define FUNC_NAME s_scm_round_number
4731{
4732 SCM plus_half = scm_sum (x, exactly_one_half);
4733 SCM result = scm_floor (plus_half);
4734 /* Adjust so that the scm_round is towards even. */
4735 if (!SCM_FALSEP (scm_num_eq_p (plus_half, result))
4736 && !SCM_FALSEP (scm_odd_p (result)))
4737 return scm_difference (result, SCM_MAKINUM (1));
4738 else
4739 return result;
4740}
4741#undef FUNC_NAME
4742
4743SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
4744 (SCM x),
4745 "Round the number @var{x} towards minus infinity.")
4746#define FUNC_NAME s_scm_floor
4747{
4748 if (SCM_INUMP (x) || SCM_BIGP (x))
4749 return x;
4750 else if (SCM_REALP (x))
4751 return scm_make_real (floor (SCM_REAL_VALUE (x)));
4752 else if (SCM_FRACTIONP (x))
4753 {
4754 SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
4755 SCM_FRACTION_DENOMINATOR (x));
4756 if (SCM_FALSEP (scm_negative_p (x)))
4757 {
4758 /* For positive x, rounding towards zero is correct. */
4759 return q;
4760 }
4761 else
4762 {
4763 /* For negative x, we need to return q-1 unless x is an
4764 integer. But fractions are never integer, per our
4765 assumptions. */
4766 return scm_difference (q, SCM_MAKINUM (1));
4767 }
4768 }
4769 else
4770 SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
4771}
4772#undef FUNC_NAME
4773
4774SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
4775 (SCM x),
4776 "Round the number @var{x} towards infinity.")
4777#define FUNC_NAME s_scm_ceiling
4778{
4779 if (SCM_INUMP (x) || SCM_BIGP (x))
4780 return x;
4781 else if (SCM_REALP (x))
4782 return scm_make_real (ceil (SCM_REAL_VALUE (x)));
4783 else if (SCM_FRACTIONP (x))
4784 {
4785 SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
4786 SCM_FRACTION_DENOMINATOR (x));
4787 if (SCM_FALSEP (scm_positive_p (x)))
4788 {
4789 /* For negative x, rounding towards zero is correct. */
4790 return q;
4791 }
4792 else
4793 {
4794 /* For positive x, we need to return q+1 unless x is an
4795 integer. But fractions are never integer, per our
4796 assumptions. */
4797 return scm_sum (q, SCM_MAKINUM (1));
4798 }
4799 }
4800 else
4801 SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
4802}
4803#undef FUNC_NAME
0f2d19dd 4804
14b18ed6 4805SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
942e5b91
MG		 4806/* "Return the square root of the real number @var{x}."
4807 */
14b18ed6 4808SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
942e5b91
MG		 4809/* "Return the absolute value of the real number @var{x}."
4810 */
14b18ed6 4811SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
942e5b91
MG		 4812/* "Return the @var{x}th power of e."
4813 */
14b18ed6 4814SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
b3fcac34 4815/* "Return the natural logarithm of the real number @var{x}."
942e5b91 4816 */
14b18ed6 4817SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
942e5b91
MG		 4818/* "Return the sine of the real number @var{x}."
4819 */
14b18ed6 4820SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
942e5b91
MG		 4821/* "Return the cosine of the real number @var{x}."
4822 */
14b18ed6 4823SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
942e5b91
MG		 4824/* "Return the tangent of the real number @var{x}."
4825 */
14b18ed6 4826SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
942e5b91
MG		 4827/* "Return the arc sine of the real number @var{x}."
4828 */
14b18ed6 4829SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
942e5b91
MG		 4830/* "Return the arc cosine of the real number @var{x}."
4831 */
14b18ed6 4832SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
942e5b91
MG		 4833/* "Return the arc tangent of the real number @var{x}."
4834 */
14b18ed6 4835SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
942e5b91
MG		 4836/* "Return the hyperbolic sine of the real number @var{x}."
4837 */
14b18ed6 4838SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
942e5b91
MG		 4839/* "Return the hyperbolic cosine of the real number @var{x}."
4840 */
14b18ed6 4841SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
942e5b91
MG		 4842/* "Return the hyperbolic tangent of the real number @var{x}."
4843 */
f872b822
MD		 4844
4845struct dpair
4846{
4847 double x, y;
4848};
4849
27c37006
NJ		 4850static void scm_two_doubles (SCM x,
4851 SCM y,
3eeba8d4
JB		 4852 const char *sstring,
4853 struct dpair * xy);
f872b822
MD		 4854
4855static void
27c37006
NJ		 4856scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
4857{
0aacf84e 4858 if (SCM_INUMP (x))
27c37006 4859 xy->x = SCM_INUM (x);
0aacf84e 4860 else if (SCM_BIGP (x))
1be6b49c 4861 xy->x = scm_i_big2dbl (x);
0aacf84e 4862 else if (SCM_REALP (x))
27c37006 4863 xy->x = SCM_REAL_VALUE (x);
f92e85f7
MV		 4864 else if (SCM_FRACTIONP (x))
4865 xy->x = scm_i_fraction2double (x);
0aacf84e 4866 else
27c37006 4867 scm_wrong_type_arg (sstring, SCM_ARG1, x);
98cb6e75 4868
0aacf84e 4869 if (SCM_INUMP (y))
27c37006 4870 xy->y = SCM_INUM (y);
0aacf84e 4871 else if (SCM_BIGP (y))
1be6b49c 4872 xy->y = scm_i_big2dbl (y);
0aacf84e 4873 else if (SCM_REALP (y))
27c37006 4874 xy->y = SCM_REAL_VALUE (y);
f92e85f7
MV		 4875 else if (SCM_FRACTIONP (y))
4876 xy->y = scm_i_fraction2double (y);
0aacf84e 4877 else
27c37006 4878 scm_wrong_type_arg (sstring, SCM_ARG2, y);
0f2d19dd
JB		 4879}
4880
4881
a1ec6916 4882SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
27c37006
NJ		 4883 (SCM x, SCM y),
4884 "Return @var{x} raised to the power of @var{y}. This\n"
0137a31b 4885 "procedure does not accept complex arguments.")
1bbd0b84 4886#define FUNC_NAME s_scm_sys_expt
0f2d19dd
JB		 4887{
4888 struct dpair xy;
27c37006 4889 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 4890 return scm_make_real (pow (xy.x, xy.y));
0f2d19dd 4891}
1bbd0b84 4892#undef FUNC_NAME
0f2d19dd
JB		 4893
4894
a1ec6916 4895SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
27c37006
NJ		 4896 (SCM x, SCM y),
4897 "Return the arc tangent of the two arguments @var{x} and\n"
4898 "@var{y}. This is similar to calculating the arc tangent of\n"
4899 "@var{x} / @var{y}, except that the signs of both arguments\n"
0137a31b
MG		 4900 "are used to determine the quadrant of the result. This\n"
4901 "procedure does not accept complex arguments.")
1bbd0b84 4902#define FUNC_NAME s_scm_sys_atan2
0f2d19dd
JB		 4903{
4904 struct dpair xy;
27c37006 4905 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 4906 return scm_make_real (atan2 (xy.x, xy.y));
0f2d19dd 4907}
1bbd0b84 4908#undef FUNC_NAME
0f2d19dd
JB		 4909
4910
a1ec6916 4911SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
bb628794 4912 (SCM real, SCM imaginary),
942e5b91
MG		 4913 "Return a complex number constructed of the given @var{real} and\n"
4914 "@var{imaginary} parts.")
1bbd0b84 4915#define FUNC_NAME s_scm_make_rectangular
0f2d19dd
JB		 4916{
4917 struct dpair xy;
bb628794 4918 scm_two_doubles (real, imaginary, FUNC_NAME, &xy);
f8de44c1 4919 return scm_make_complex (xy.x, xy.y);
0f2d19dd 4920}
1bbd0b84 4921#undef FUNC_NAME
0f2d19dd
JB		 4922
4923
4924
a1ec6916 4925SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
27c37006 4926 (SCM x, SCM y),
942e5b91 4927 "Return the complex number @var{x} * e^(i * @var{y}).")
1bbd0b84 4928#define FUNC_NAME s_scm_make_polar
0f2d19dd
JB		 4929{
4930 struct dpair xy;
6efadd7c 4931 double s, c;
27c37006 4932 scm_two_doubles (x, y, FUNC_NAME, &xy);
6efadd7c
KR		 4933#if HAVE_SINCOS
4934 sincos (xy.y, &s, &c);
4935#else
4936 s = sin (xy.y);
4937 c = cos (xy.y);
4938#endif
4939 return scm_make_complex (xy.x * c, xy.x * s);
0f2d19dd 4940}
1bbd0b84 4941#undef FUNC_NAME
0f2d19dd
JB		 4942
4943
152f82bf 4944SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
942e5b91
MG		 4945/* "Return the real part of the number @var{z}."
4946 */
0f2d19dd 4947SCM
6e8d25a6 4948scm_real_part (SCM z)
0f2d19dd 4949{
0aacf84e 4950 if (SCM_INUMP (z))
c2ff8ab0 4951 return z;
0aacf84e 4952 else if (SCM_BIGP (z))
c2ff8ab0 4953 return z;
0aacf84e 4954 else if (SCM_REALP (z))
c2ff8ab0 4955 return z;
0aacf84e 4956 else if (SCM_COMPLEXP (z))
c2ff8ab0 4957 return scm_make_real (SCM_COMPLEX_REAL (z));
f92e85f7
MV		 4958 else if (SCM_FRACTIONP (z))
4959 return scm_make_real (scm_i_fraction2double (z));
0aacf84e 4960 else
c2ff8ab0 4961 SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
0f2d19dd
JB		 4962}
4963
4964
152f82bf 4965SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
942e5b91
MG		 4966/* "Return the imaginary part of the number @var{z}."
4967 */
0f2d19dd 4968SCM
6e8d25a6 4969scm_imag_part (SCM z)
0f2d19dd 4970{
0aacf84e 4971 if (SCM_INUMP (z))
f872b822 4972 return SCM_INUM0;
0aacf84e 4973 else if (SCM_BIGP (z))
f872b822 4974 return SCM_INUM0;
0aacf84e 4975 else if (SCM_REALP (z))
c2ff8ab0 4976 return scm_flo0;
0aacf84e 4977 else if (SCM_COMPLEXP (z))
c2ff8ab0 4978 return scm_make_real (SCM_COMPLEX_IMAG (z));
f92e85f7
MV		 4979 else if (SCM_FRACTIONP (z))
4980 return SCM_INUM0;
0aacf84e 4981 else
c2ff8ab0 4982 SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
0f2d19dd
JB		 4983}
4984
f92e85f7
MV		 4985SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator);
4986/* "Return the numerator of the number @var{z}."
4987 */
4988SCM
4989scm_numerator (SCM z)
4990{
4991 if (SCM_INUMP (z))
4992 return z;
4993 else if (SCM_BIGP (z))
4994 return z;
4995 else if (SCM_FRACTIONP (z))
4996 {
4997 scm_i_fraction_reduce (z);
4998 return SCM_FRACTION_NUMERATOR (z);
4999 }
5000 else if (SCM_REALP (z))
5001 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
5002 else
5003 SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator);
5004}
5005
5006
5007SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator);
5008/* "Return the denominator of the number @var{z}."
5009 */
5010SCM
5011scm_denominator (SCM z)
5012{
5013 if (SCM_INUMP (z))
5014 return SCM_MAKINUM (1);
5015 else if (SCM_BIGP (z))
5016 return SCM_MAKINUM (1);
5017 else if (SCM_FRACTIONP (z))
5018 {
5019 scm_i_fraction_reduce (z);
5020 return SCM_FRACTION_DENOMINATOR (z);
5021 }
5022 else if (SCM_REALP (z))
5023 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
5024 else
5025 SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator);
5026}
0f2d19dd 5027
9de33deb 5028SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
942e5b91
MG		 5029/* "Return the magnitude of the number @var{z}. This is the same as\n"
5030 * "@code{abs} for real arguments, but also allows complex numbers."
5031 */
0f2d19dd 5032SCM
6e8d25a6 5033scm_magnitude (SCM z)
0f2d19dd 5034{
0aacf84e
MD		 5035 if (SCM_INUMP (z))
5036 {
5037 long int zz = SCM_INUM (z);
5038 if (zz >= 0)
5039 return z;
5040 else if (SCM_POSFIXABLE (-zz))
5041 return SCM_MAKINUM (-zz);
5042 else
5043 return scm_i_long2big (-zz);
5986c47d 5044 }
0aacf84e
MD		 5045 else if (SCM_BIGP (z))
5046 {
5047 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
5048 scm_remember_upto_here_1 (z);
5049 if (sgn < 0)
5050 return scm_i_clonebig (z, 0);
5051 else
5052 return z;
5986c47d 5053 }
0aacf84e 5054 else if (SCM_REALP (z))
c2ff8ab0 5055 return scm_make_real (fabs (SCM_REAL_VALUE (z)));
0aacf84e 5056 else if (SCM_COMPLEXP (z))
6efadd7c 5057 return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
f92e85f7
MV		 5058 else if (SCM_FRACTIONP (z))
5059 {
5060 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
5061 return z;
5062 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
5063 SCM_FRACTION_DENOMINATOR (z));
5064 }
0aacf84e 5065 else
c2ff8ab0 5066 SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
0f2d19dd
JB		 5067}
5068
5069
9de33deb 5070SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
942e5b91
MG		 5071/* "Return the angle of the complex number @var{z}."
5072 */
0f2d19dd 5073SCM
6e8d25a6 5074scm_angle (SCM z)
0f2d19dd 5075{
c8ae173e
KR		 5076 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
5077 scm_flo0 to save allocating a new flonum with scm_make_real each time.
5078 But if atan2 follows the floating point rounding mode, then the value
5079 is not a constant. Maybe it'd be close enough though. */
0aacf84e
MD		 5080 if (SCM_INUMP (z))
5081 {
5082 if (SCM_INUM (z) >= 0)
c8ae173e 5083 return scm_flo0;
0aacf84e
MD		 5084 else
5085 return scm_make_real (atan2 (0.0, -1.0));
f872b822 5086 }
0aacf84e
MD		 5087 else if (SCM_BIGP (z))
5088 {
5089 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
5090 scm_remember_upto_here_1 (z);
5091 if (sgn < 0)
5092 return scm_make_real (atan2 (0.0, -1.0));
5093 else
c8ae173e 5094 return scm_flo0;
0f2d19dd 5095 }
0aacf84e 5096 else if (SCM_REALP (z))
c8ae173e
KR		 5097 {
5098 if (SCM_REAL_VALUE (z) >= 0)
5099 return scm_flo0;
5100 else
5101 return scm_make_real (atan2 (0.0, -1.0));
5102 }
0aacf84e 5103 else if (SCM_COMPLEXP (z))
f4c627b3 5104 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
f92e85f7
MV		 5105 else if (SCM_FRACTIONP (z))
5106 {
5107 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
5108 return scm_flo0;
5109 else return scm_make_real (atan2 (0.0, -1.0));
5110 }
0aacf84e 5111 else
f4c627b3 5112 SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
0f2d19dd
JB		 5113}
5114
5115
3c9a524f
DH		 5116SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact);
5117/* Convert the number @var{x} to its inexact representation.\n"
5118 */
5119SCM
5120scm_exact_to_inexact (SCM z)
5121{
5122 if (SCM_INUMP (z))
5123 return scm_make_real ((double) SCM_INUM (z));
5124 else if (SCM_BIGP (z))
5125 return scm_make_real (scm_i_big2dbl (z));
f92e85f7
MV		 5126 else if (SCM_FRACTIONP (z))
5127 return scm_make_real (scm_i_fraction2double (z));
3c9a524f
DH		 5128 else if (SCM_INEXACTP (z))
5129 return z;
5130 else
5131 SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact);
5132}
5133
5134
a1ec6916 5135SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
1bbd0b84 5136 (SCM z),
1e6808ea 5137 "Return an exact number that is numerically closest to @var{z}.")
1bbd0b84 5138#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 5139{
0aacf84e 5140 if (SCM_INUMP (z))
f872b822 5141 return z;
0aacf84e 5142 else if (SCM_BIGP (z))
f872b822 5143 return z;
0aacf84e
MD		 5144 else if (SCM_REALP (z))
5145 {
f92e85f7
MV		 5146 if (xisinf (SCM_REAL_VALUE (z)) || xisnan (SCM_REAL_VALUE (z)))
5147 SCM_OUT_OF_RANGE (1, z);
2be24db4 5148 else
f92e85f7
MV		 5149 {
5150 mpq_t frac;
5151 SCM q;
5152
5153 mpq_init (frac);
5154 mpq_set_d (frac, SCM_REAL_VALUE (z));
5155 q = scm_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
5156 scm_i_mpz2num (mpq_denref (frac)));
5157
5158 /* When scm_make_ratio throws, we leak the memory allocated
5159 for frac...
5160 */
5161 mpq_clear (frac);
5162 return q;
5163 }
c2ff8ab0 5164 }
f92e85f7
MV		 5165 else if (SCM_FRACTIONP (z))
5166 return z;
0aacf84e 5167 else
c2ff8ab0 5168 SCM_WRONG_TYPE_ARG (1, z);
0f2d19dd 5169}
1bbd0b84 5170#undef FUNC_NAME
0f2d19dd 5171
f92e85f7
MV		 5172SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
5173 (SCM x, SCM err),
5174 "Return an exact number that is within @var{err} of @var{x}.")
5175#define FUNC_NAME s_scm_rationalize
5176{
5177 if (SCM_INUMP (x))
5178 return x;
5179 else if (SCM_BIGP (x))
5180 return x;
5181 else if ((SCM_REALP (x)) || SCM_FRACTIONP (x))
5182 {
5183 /* Use continued fractions to find closest ratio. All
5184 arithmetic is done with exact numbers.
5185 */
5186
5187 SCM ex = scm_inexact_to_exact (x);
5188 SCM int_part = scm_floor (ex);
5189 SCM tt = SCM_MAKINUM (1);
5190 SCM a1 = SCM_MAKINUM (0), a2 = SCM_MAKINUM (1), a = SCM_MAKINUM (0);
5191 SCM b1 = SCM_MAKINUM (1), b2 = SCM_MAKINUM (0), b = SCM_MAKINUM (0);
5192 SCM rx;
5193 int i = 0;
5194
5195 if (!SCM_FALSEP (scm_num_eq_p (ex, int_part)))
5196 return ex;
5197
5198 ex = scm_difference (ex, int_part); /* x = x-int_part */
5199 rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
5200
5201 /* We stop after a million iterations just to be absolutely sure
5202 that we don't go into an infinite loop. The process normally
5203 converges after less than a dozen iterations.
5204 */
5205
5206 err = scm_abs (err);
5207 while (++i < 1000000)
5208 {
5209 a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
5210 b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
5211 if (SCM_FALSEP (scm_zero_p (b)) && /* b != 0 */
5212 SCM_FALSEP
5213 (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
5214 err))) /* abs(x-a/b) <= err */
02164269
MV		 5215 {
5216 SCM res = scm_sum (int_part, scm_divide (a, b));
5217 if (SCM_FALSEP (scm_exact_p (x))
5218 || SCM_FALSEP (scm_exact_p (err)))
5219 return scm_exact_to_inexact (res);
5220 else
5221 return res;
5222 }
f92e85f7
MV		 5223 rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
5224 SCM_UNDEFINED);
5225 tt = scm_floor (rx); /* tt = floor (rx) */
5226 a2 = a1;
5227 b2 = b1;
5228 a1 = a;
5229 b1 = b;
5230 }
5231 scm_num_overflow (s_scm_rationalize);
5232 }
5233 else
5234 SCM_WRONG_TYPE_ARG (1, x);
5235}
5236#undef FUNC_NAME
5237
87617347 5238/* if you need to change this, change test-num2integral.c as well */
ee33d62a 5239#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 5240# ifndef LLONG_MAX
5241# define ULLONG_MAX ((unsigned long long) (-1))
5242# define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
5243# define LLONG_MIN (~LLONG_MAX)
5244# endif
f872b822 5245#endif
0f2d19dd 5246
3d2e8ceb
MV		 5247/* Parameters for creating integer conversion routines.
5248
5249 Define the following preprocessor macros before including
5250 "libguile/num2integral.i.c":
5251
5252 NUM2INTEGRAL - the name of the function for converting from a
ca46fb90
RB		 5253 Scheme object to the integral type. This function will be
5254 defined when including "num2integral.i.c".
3d2e8ceb
MV		 5255
5256 INTEGRAL2NUM - the name of the function for converting from the
ca46fb90 5257 integral type to a Scheme object. This function will be defined.
3d2e8ceb
MV		 5258
5259 INTEGRAL2BIG - the name of an internal function that createas a
ca46fb90
RB		 5260 bignum from the integral type. This function will be defined.
5261 The name should start with "scm_i_".
5262
5263 ITYPE - the name of the integral type.
5264
9dd023e1
MV		 5265 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
5266 it to 0 otherwise.
ca46fb90
RB		 5267
5268 UNSIGNED_ITYPE - the name of the the unsigned variant of the
5269 integral type. If you don't define this, it defaults to
5270 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
5271 ones.
5272
5273 SIZEOF_ITYPE - an expression giving the size of the integral type
5274 in bytes. This expression must be computable by the
5275 preprocessor. (SIZEOF_FOO values are calculated by configure.in
5276 for common types).
5277
3d2e8ceb
MV		 5278*/
5279
1be6b49c
ML		 5280#define NUM2INTEGRAL scm_num2short
5281#define INTEGRAL2NUM scm_short2num
5282#define INTEGRAL2BIG scm_i_short2big
ca46fb90 5283#define UNSIGNED 0
1be6b49c 5284#define ITYPE short
3d2e8ceb 5285#define SIZEOF_ITYPE SIZEOF_SHORT
1be6b49c
ML		 5286#include "libguile/num2integral.i.c"
5287
5288#define NUM2INTEGRAL scm_num2ushort
5289#define INTEGRAL2NUM scm_ushort2num
5290#define INTEGRAL2BIG scm_i_ushort2big
ca46fb90 5291#define UNSIGNED 1
1be6b49c 5292#define ITYPE unsigned short
ca46fb90 5293#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
1be6b49c
ML		 5294#include "libguile/num2integral.i.c"
5295
5296#define NUM2INTEGRAL scm_num2int
5297#define INTEGRAL2NUM scm_int2num
5298#define INTEGRAL2BIG scm_i_int2big
ca46fb90 5299#define UNSIGNED 0
1be6b49c 5300#define ITYPE int
3d2e8ceb 5301#define SIZEOF_ITYPE SIZEOF_INT
1be6b49c
ML		 5302#include "libguile/num2integral.i.c"
5303
5304#define NUM2INTEGRAL scm_num2uint
5305#define INTEGRAL2NUM scm_uint2num
5306#define INTEGRAL2BIG scm_i_uint2big
ca46fb90 5307#define UNSIGNED 1
1be6b49c 5308#define ITYPE unsigned int
ca46fb90 5309#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
1be6b49c
ML		 5310#include "libguile/num2integral.i.c"
5311
5312#define NUM2INTEGRAL scm_num2long
5313#define INTEGRAL2NUM scm_long2num
5314#define INTEGRAL2BIG scm_i_long2big
ca46fb90 5315#define UNSIGNED 0
1be6b49c 5316#define ITYPE long
3d2e8ceb 5317#define SIZEOF_ITYPE SIZEOF_LONG
1be6b49c
ML		 5318#include "libguile/num2integral.i.c"
5319
5320#define NUM2INTEGRAL scm_num2ulong
5321#define INTEGRAL2NUM scm_ulong2num
5322#define INTEGRAL2BIG scm_i_ulong2big
ca46fb90 5323#define UNSIGNED 1
1be6b49c 5324#define ITYPE unsigned long
ca46fb90 5325#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
1be6b49c
ML		 5326#include "libguile/num2integral.i.c"
5327
1be6b49c
ML		 5328#define NUM2INTEGRAL scm_num2ptrdiff
5329#define INTEGRAL2NUM scm_ptrdiff2num
5330#define INTEGRAL2BIG scm_i_ptrdiff2big
ca46fb90 5331#define UNSIGNED 0
ee33d62a 5332#define ITYPE scm_t_ptrdiff
3d2e8ceb 5333#define UNSIGNED_ITYPE size_t
ee33d62a 5334#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
1be6b49c
ML		 5335#include "libguile/num2integral.i.c"
5336
5337#define NUM2INTEGRAL scm_num2size
5338#define INTEGRAL2NUM scm_size2num
5339#define INTEGRAL2BIG scm_i_size2big
ca46fb90 5340#define UNSIGNED 1
1be6b49c 5341#define ITYPE size_t
3d2e8ceb 5342#define SIZEOF_ITYPE SIZEOF_SIZE_T
1be6b49c 5343#include "libguile/num2integral.i.c"
0f2d19dd 5344
ee33d62a 5345#if SCM_SIZEOF_LONG_LONG != 0
1cc91f1b 5346
caf08e65
MV		 5347#ifndef ULONG_LONG_MAX
5348#define ULONG_LONG_MAX (~0ULL)
5349#endif
5350
1be6b49c
ML		 5351#define NUM2INTEGRAL scm_num2long_long
5352#define INTEGRAL2NUM scm_long_long2num
5353#define INTEGRAL2BIG scm_i_long_long2big
ca46fb90 5354#define UNSIGNED 0
1be6b49c 5355#define ITYPE long long
3d2e8ceb 5356#define SIZEOF_ITYPE SIZEOF_LONG_LONG
1be6b49c
ML		 5357#include "libguile/num2integral.i.c"
5358
5359#define NUM2INTEGRAL scm_num2ulong_long
5360#define INTEGRAL2NUM scm_ulong_long2num
5361#define INTEGRAL2BIG scm_i_ulong_long2big
ca46fb90 5362#define UNSIGNED 1
1be6b49c 5363#define ITYPE unsigned long long
ca46fb90 5364#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
1be6b49c 5365#include "libguile/num2integral.i.c"
0f2d19dd 5366
ee33d62a 5367#endif /* SCM_SIZEOF_LONG_LONG != 0 */
caf08e65 5368
5437598b
MD		 5369#define NUM2FLOAT scm_num2float
5370#define FLOAT2NUM scm_float2num
5371#define FTYPE float
5372#include "libguile/num2float.i.c"
5373
5374#define NUM2FLOAT scm_num2double
5375#define FLOAT2NUM scm_double2num
5376#define FTYPE double
5377#include "libguile/num2float.i.c"
5378
1be6b49c 5379#ifdef GUILE_DEBUG
caf08e65 5380
6063dc1d
SJ		 5381#ifndef SIZE_MAX
5382#define SIZE_MAX ((size_t) (-1))
5383#endif
5384#ifndef PTRDIFF_MIN
5385#define PTRDIFF_MIN \
b4fb7de8
RB		 5386 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
5387 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
6063dc1d
SJ		 5388#endif
5389#ifndef PTRDIFF_MAX
5390#define PTRDIFF_MAX (~ PTRDIFF_MIN)
5391#endif
5392
0aacf84e
MD		 5393#define CHECK(type, v) \
5394 do \
5395 { \
5396 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
5397 abort (); \
5398 } \
5399 while (0)
caf08e65 5400
1be6b49c
ML		 5401static void
5402check_sanity ()
5403{
5404 CHECK (short, 0);
5405 CHECK (ushort, 0U);
5406 CHECK (int, 0);
5407 CHECK (uint, 0U);
5408 CHECK (long, 0L);
5409 CHECK (ulong, 0UL);
5410 CHECK (size, 0);
5411 CHECK (ptrdiff, 0);
5412
5413 CHECK (short, -1);
5414 CHECK (int, -1);
5415 CHECK (long, -1L);
5416 CHECK (ptrdiff, -1);
5417
5418 CHECK (short, SHRT_MAX);
5419 CHECK (short, SHRT_MIN);
5420 CHECK (ushort, USHRT_MAX);
5421 CHECK (int, INT_MAX);
5422 CHECK (int, INT_MIN);
5423 CHECK (uint, UINT_MAX);
5424 CHECK (long, LONG_MAX);
5425 CHECK (long, LONG_MIN);
5426 CHECK (ulong, ULONG_MAX);
5427 CHECK (size, SIZE_MAX);
5428 CHECK (ptrdiff, PTRDIFF_MAX);
5429 CHECK (ptrdiff, PTRDIFF_MIN);
0f2d19dd 5430
ee33d62a 5431#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 5432 CHECK (long_long, 0LL);
5433 CHECK (ulong_long, 0ULL);
1be6b49c 5434 CHECK (long_long, -1LL);
1be6b49c
ML		 5435 CHECK (long_long, LLONG_MAX);
5436 CHECK (long_long, LLONG_MIN);
5437 CHECK (ulong_long, ULLONG_MAX);
5438#endif
0f2d19dd
JB		 5439}
5440
b10586f0
ML		 5441#undef CHECK
5442
5443#define CHECK \
5444 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
5445 if (!SCM_FALSEP (data)) abort();
5446
5447static SCM
5448check_body (void *data)
5449{
5450 SCM num = *(SCM *) data;
5451 scm_num2ulong (num, 1, NULL);
5452
5453 return SCM_UNSPECIFIED;
5454}
5455
5456static SCM
5457check_handler (void *data, SCM tag, SCM throw_args)
5458{
5459 SCM *num = (SCM *) data;
5460 *num = SCM_BOOL_F;
5461
5462 return SCM_UNSPECIFIED;
5463}
5464
5465SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0,
b4e15479 5466 (void),
b10586f0
ML		 5467 "Number conversion sanity checking.")
5468#define FUNC_NAME s_scm_sys_check_number_conversions
5469{
5470 SCM data = SCM_MAKINUM (-1);
5471 CHECK;
5472 data = scm_int2num (INT_MIN);
5473 CHECK;
5474 data = scm_ulong2num (ULONG_MAX);
5475 data = scm_difference (SCM_INUM0, data);
5476 CHECK;
5477 data = scm_ulong2num (ULONG_MAX);
5478 data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data);
5479 CHECK;
5480 data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data);
5481 CHECK;
5482
5483 return SCM_UNSPECIFIED;
5484}
5485#undef FUNC_NAME
5486
1be6b49c 5487#endif
0f2d19dd 5488
0f2d19dd
JB		 5489void
5490scm_init_numbers ()
0f2d19dd 5491{
1be6b49c 5492 abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM);
ac0c002c
DH		 5493 scm_permanent_object (abs_most_negative_fixnum);
5494
713a4259
KR		 5495 mpz_init_set_si (z_negative_one, -1);
5496
a261c0e9
DH		 5497 /* It may be possible to tune the performance of some algorithms by using
5498 * the following constants to avoid the creation of bignums. Please, before
5499 * using these values, remember the two rules of program optimization:
5500 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
86d31dfe
MV		 5501 scm_c_define ("most-positive-fixnum",
5502 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
5503 scm_c_define ("most-negative-fixnum",
5504 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
a261c0e9 5505
f3ae5d60
MD		 5506 scm_add_feature ("complex");
5507 scm_add_feature ("inexact");
5986c47d 5508 scm_flo0 = scm_make_real (0.0);
f872b822 5509#ifdef DBL_DIG
0f2d19dd 5510 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
f872b822 5511#else
0f2d19dd
JB		 5512 { /* determine floating point precision */
5513 double f = 0.1;
f872b822 5514 double fsum = 1.0 + f;
0aacf84e
MD		 5515 while (fsum != 1.0)
5516 {
5517 if (++scm_dblprec > 20)
5518 fsum = 1.0;
5519 else
5520 {
5521 f /= 10.0;
5522 fsum = f + 1.0;
5523 }
f872b822
MD		 5524 }
5525 scm_dblprec = scm_dblprec - 1;
0f2d19dd 5526 }
f872b822 5527#endif /* DBL_DIG */
1be6b49c
ML		 5528
5529#ifdef GUILE_DEBUG
5530 check_sanity ();
5531#endif
f92e85f7
MV		 5532
5533 exactly_one_half = scm_permanent_object (scm_divide (SCM_MAKINUM (1),
5534 SCM_MAKINUM (2)));
a0599745 5535#include "libguile/numbers.x"
0f2d19dd 5536}
89e00824
ML		 5537
5538/*
5539 Local Variables:
5540 c-file-style: "gnu"
5541 End:
5542*/
Unnamed repository; edit this file 'description' to name the repository.