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