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