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