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))
0d75f6d8
KR		 1486 {
1487 /* bits above what's in an inum follow the sign bit */
1488 iindex = min (iindex, LONG_BIT-1);
1489 return SCM_BOOL ((1L << iindex) & SCM_INUM (j));
1490 }
0aacf84e
MD		 1491 else if (SCM_BIGP (j))
1492 {
1493 int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
1494 scm_remember_upto_here_1 (j);
1495 return SCM_BOOL (val);
1496 }
1497 else
78166ad5 1498 SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
0f2d19dd 1499}
1bbd0b84 1500#undef FUNC_NAME
0f2d19dd 1501
78166ad5 1502
a1ec6916 1503SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
1bbd0b84 1504 (SCM n),
4d814788 1505 "Return the integer which is the ones-complement of the integer\n"
1e6808ea
MG		 1506 "argument.\n"
1507 "\n"
b380b885
MD		 1508 "@lisp\n"
1509 "(number->string (lognot #b10000000) 2)\n"
1510 " @result{} \"-10000001\"\n"
1511 "(number->string (lognot #b0) 2)\n"
1512 " @result{} \"-1\"\n"
1e6808ea 1513 "@end lisp")
1bbd0b84 1514#define FUNC_NAME s_scm_lognot
0f2d19dd 1515{
f9811f9f
KR		 1516 if (SCM_INUMP (n)) {
1517 /* No overflow here, just need to toggle all the bits making up the inum.
1518 Enhancement: No need to strip the tag and add it back, could just xor
1519 a block of 1 bits, if that worked with the various debug versions of
1520 the SCM typedef. */
1521 return SCM_MAKINUM (~ SCM_INUM (n));
1522
1523 } else if (SCM_BIGP (n)) {
1524 SCM result = scm_i_mkbig ();
1525 mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
1526 scm_remember_upto_here_1 (n);
1527 return result;
1528
1529 } else {
1530 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
1531 }
0f2d19dd 1532}
1bbd0b84 1533#undef FUNC_NAME
0f2d19dd 1534
518b7508
KR		 1535/* returns 0 if IN is not an integer. OUT must already be
1536 initialized. */
1537static int
1538coerce_to_big (SCM in, mpz_t out)
1539{
1540 if (SCM_BIGP (in))
1541 mpz_set (out, SCM_I_BIG_MPZ (in));
1542 else if (SCM_INUMP (in))
1543 mpz_set_si (out, SCM_INUM (in));
1544 else
1545 return 0;
1546
1547 return 1;
1548}
1549
d885e204 1550SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0,
518b7508
KR		 1551 (SCM n, SCM k, SCM m),
1552 "Return @var{n} raised to the integer exponent\n"
1553 "@var{k}, modulo @var{m}.\n"
1554 "\n"
1555 "@lisp\n"
1556 "(modulo-expt 2 3 5)\n"
1557 " @result{} 3\n"
1558 "@end lisp")
d885e204 1559#define FUNC_NAME s_scm_modulo_expt
518b7508
KR		 1560{
1561 mpz_t n_tmp;
1562 mpz_t k_tmp;
1563 mpz_t m_tmp;
1564
1565 /* There are two classes of error we might encounter --
1566 1) Math errors, which we'll report by calling scm_num_overflow,
1567 and
1568 2) wrong-type errors, which of course we'll report by calling
1569 SCM_WRONG_TYPE_ARG.
1570 We don't report those errors immediately, however; instead we do
1571 some cleanup first. These variables tell us which error (if
1572 any) we should report after cleaning up.
1573 */
1574 int report_overflow = 0;
1575
1576 int position_of_wrong_type = 0;
1577 SCM value_of_wrong_type = SCM_INUM0;
1578
1579 SCM result = SCM_UNDEFINED;
1580
1581 mpz_init (n_tmp);
1582 mpz_init (k_tmp);
1583 mpz_init (m_tmp);
1584
1585 if (SCM_EQ_P (m, SCM_INUM0))
1586 {
1587 report_overflow = 1;
1588 goto cleanup;
1589 }
1590
1591 if (!coerce_to_big (n, n_tmp))
1592 {
1593 value_of_wrong_type = n;
1594 position_of_wrong_type = 1;
1595 goto cleanup;
1596 }
1597
1598 if (!coerce_to_big (k, k_tmp))
1599 {
1600 value_of_wrong_type = k;
1601 position_of_wrong_type = 2;
1602 goto cleanup;
1603 }
1604
1605 if (!coerce_to_big (m, m_tmp))
1606 {
1607 value_of_wrong_type = m;
1608 position_of_wrong_type = 3;
1609 goto cleanup;
1610 }
1611
1612 /* if the exponent K is negative, and we simply call mpz_powm, we
1613 will get a divide-by-zero exception when an inverse 1/n mod m
1614 doesn't exist (or is not unique). Since exceptions are hard to
1615 handle, we'll attempt the inversion "by hand" -- that way, we get
1616 a simple failure code, which is easy to handle. */
1617
1618 if (-1 == mpz_sgn (k_tmp))
1619 {
1620 if (!mpz_invert (n_tmp, n_tmp, m_tmp))
1621 {
1622 report_overflow = 1;
1623 goto cleanup;
1624 }
1625 mpz_neg (k_tmp, k_tmp);
1626 }
1627
1628 result = scm_i_mkbig ();
1629 mpz_powm (SCM_I_BIG_MPZ (result),
1630 n_tmp,
1631 k_tmp,
1632 m_tmp);
b7b8c575
KR		 1633
1634 if (mpz_sgn (m_tmp) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
1635 mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), m_tmp);
1636
518b7508
KR		 1637 cleanup:
1638 mpz_clear (m_tmp);
1639 mpz_clear (k_tmp);
1640 mpz_clear (n_tmp);
1641
1642 if (report_overflow)
1643 scm_num_overflow (FUNC_NAME);
1644
1645 if (position_of_wrong_type)
1646 SCM_WRONG_TYPE_ARG (position_of_wrong_type,
1647 value_of_wrong_type);
1648
1649 return scm_i_normbig (result);
1650}
1651#undef FUNC_NAME
1652
a1ec6916 1653SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
2cd04b42 1654 (SCM n, SCM k),
1e6808ea
MG		 1655 "Return @var{n} raised to the non-negative integer exponent\n"
1656 "@var{k}.\n"
1657 "\n"
b380b885
MD		 1658 "@lisp\n"
1659 "(integer-expt 2 5)\n"
1660 " @result{} 32\n"
1661 "(integer-expt -3 3)\n"
1662 " @result{} -27\n"
1663 "@end lisp")
1bbd0b84 1664#define FUNC_NAME s_scm_integer_expt
0f2d19dd 1665{
1c35cb19
RB		 1666 long i2 = 0;
1667 SCM z_i2 = SCM_BOOL_F;
1668 int i2_is_big = 0;
f872b822 1669 SCM acc = SCM_MAKINUM (1L);
ca46fb90 1670
d57ed702 1671 /* 0^0 == 1 according to R5RS */
4260a7fc 1672 if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc))
7b3381f4 1673 return SCM_FALSEP (scm_zero_p(k)) ? n : acc;
4260a7fc
DH		 1674 else if (SCM_EQ_P (n, SCM_MAKINUM (-1L)))
1675 return SCM_FALSEP (scm_even_p (k)) ? n : acc;
ca46fb90 1676
ca46fb90
RB		 1677 if (SCM_INUMP (k))
1678 i2 = SCM_INUM (k);
1679 else if (SCM_BIGP (k))
1680 {
1681 z_i2 = scm_i_clonebig (k, 1);
ca46fb90
RB		 1682 scm_remember_upto_here_1 (k);
1683 i2_is_big = 1;
1684 }
1685 else if (SCM_REALP (k))
2830fd91
MD		 1686 {
1687 double r = SCM_REAL_VALUE (k);
ca46fb90
RB		 1688 if (floor (r) != r)
1689 SCM_WRONG_TYPE_ARG (2, k);
1690 if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM))
1691 {
1692 z_i2 = scm_i_mkbig ();
753ac1e7 1693 mpz_set_d (SCM_I_BIG_MPZ (z_i2), r);
ca46fb90
RB		 1694 i2_is_big = 1;
1695 }
1696 else
1697 {
1698 i2 = r;
1699 }
2830fd91
MD		 1700 }
1701 else
ca46fb90
RB		 1702 SCM_WRONG_TYPE_ARG (2, k);
1703
1704 if (i2_is_big)
f872b822 1705 {
ca46fb90
RB		 1706 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
1707 {
1708 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
1709 n = scm_divide (n, SCM_UNDEFINED);
1710 }
1711 while (1)
1712 {
1713 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
1714 {
ca46fb90
RB		 1715 return acc;
1716 }
1717 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
1718 {
ca46fb90
RB		 1719 return scm_product (acc, n);
1720 }
1721 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
1722 acc = scm_product (acc, n);
1723 n = scm_product (n, n);
1724 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
1725 }
f872b822 1726 }
ca46fb90 1727 else
f872b822 1728 {
ca46fb90
RB		 1729 if (i2 < 0)
1730 {
1731 i2 = -i2;
1732 n = scm_divide (n, SCM_UNDEFINED);
1733 }
1734 while (1)
1735 {
1736 if (0 == i2)
1737 return acc;
1738 if (1 == i2)
1739 return scm_product (acc, n);
1740 if (i2 & 1)
1741 acc = scm_product (acc, n);
1742 n = scm_product (n, n);
1743 i2 >>= 1;
1744 }
f872b822 1745 }
0f2d19dd 1746}
1bbd0b84 1747#undef FUNC_NAME
0f2d19dd 1748
a1ec6916 1749SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
1bbd0b84 1750 (SCM n, SCM cnt),
32f19569
KR		 1751 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
1752 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1e6808ea 1753 "\n"
e7644cb2 1754 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
32f19569
KR		 1755 "@var{cnt} is negative it's a division, rounded towards negative\n"
1756 "infinity. (Note that this is not the same rounding as\n"
1757 "@code{quotient} does.)\n"
1758 "\n"
1759 "With @var{n} viewed as an infinite precision twos complement,\n"
1760 "@code{ash} means a left shift introducing zero bits, or a right\n"
1761 "shift dropping bits.\n"
1e6808ea 1762 "\n"
b380b885 1763 "@lisp\n"
1e6808ea
MG		 1764 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1765 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
32f19569
KR		 1766 "\n"
1767 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
1768 "(ash -23 -2) @result{} -6\n"
a3c8b9fc 1769 "@end lisp")
1bbd0b84 1770#define FUNC_NAME s_scm_ash
0f2d19dd 1771{
3ab9f56e
DH		 1772 long bits_to_shift;
1773
3ab9f56e
DH		 1774 SCM_VALIDATE_INUM (2, cnt);
1775
1776 bits_to_shift = SCM_INUM (cnt);
ca46fb90
RB		 1777
1778 if (bits_to_shift < 0)
1779 {
1780 /* Shift right by abs(cnt) bits. This is realized as a division
1781 by div:=2^abs(cnt). However, to guarantee the floor
1782 rounding, negative values require some special treatment.
1783 */
1784 SCM div = scm_integer_expt (SCM_MAKINUM (2),
1785 SCM_MAKINUM (-bits_to_shift));
f92e85f7
MV		 1786
1787 /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */
ca46fb90
RB		 1788 if (SCM_FALSEP (scm_negative_p (n)))
1789 return scm_quotient (n, div);
1790 else
1791 return scm_sum (SCM_MAKINUM (-1L),
1792 scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div));
1793 }
1794 else
3ab9f56e 1795 /* Shift left is done by multiplication with 2^CNT */
f872b822 1796 return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
0f2d19dd 1797}
1bbd0b84 1798#undef FUNC_NAME
0f2d19dd 1799
3c9f20f8 1800
a1ec6916 1801SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
1bbd0b84 1802 (SCM n, SCM start, SCM end),
1e6808ea
MG		 1803 "Return the integer composed of the @var{start} (inclusive)\n"
1804 "through @var{end} (exclusive) bits of @var{n}. The\n"
1805 "@var{start}th bit becomes the 0-th bit in the result.\n"
1806 "\n"
b380b885
MD		 1807 "@lisp\n"
1808 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1809 " @result{} \"1010\"\n"
1810 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1811 " @result{} \"10110\"\n"
1812 "@end lisp")
1bbd0b84 1813#define FUNC_NAME s_scm_bit_extract
0f2d19dd 1814{
7f848242 1815 unsigned long int istart, iend, bits;
34d19ef6 1816 SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart);
c1bfcf60
GB		 1817 SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
1818 SCM_ASSERT_RANGE (3, end, (iend >= istart));
78166ad5 1819
7f848242
KR		 1820 /* how many bits to keep */
1821 bits = iend - istart;
1822
0aacf84e
MD		 1823 if (SCM_INUMP (n))
1824 {
1825 long int in = SCM_INUM (n);
7f848242
KR		 1826
1827 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
d77ad560 1828 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
857ae6af 1829 in = SCM_SRS (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 1843 /* mask down to requisite bits */
857ae6af 1844 bits = min (bits, SCM_I_FIXNUM_BIT);
7f848242 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. */
71df73ac
KR		 2323#define XDIGIT2UINT(d) \
2324 (isdigit ((int) (unsigned char) d) \
2325 ? (d) - '0' \
2326 : tolower ((int) (unsigned char) d) - 'a' + 10)
3c9a524f 2327
2a8fecee 2328static SCM
3c9a524f
DH		 2329mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
2330 unsigned int radix, enum t_exactness *p_exactness)
2a8fecee 2331{
3c9a524f
DH		 2332 unsigned int idx = *p_idx;
2333 unsigned int hash_seen = 0;
2334 scm_t_bits shift = 1;
2335 scm_t_bits add = 0;
2336 unsigned int digit_value;
2337 SCM result;
2338 char c;
2339
2340 if (idx == len)
2341 return SCM_BOOL_F;
2a8fecee 2342
3c9a524f 2343 c = mem[idx];
71df73ac 2344 if (!isxdigit ((int) (unsigned char) c))
3c9a524f
DH		 2345 return SCM_BOOL_F;
2346 digit_value = XDIGIT2UINT (c);
2347 if (digit_value >= radix)
2348 return SCM_BOOL_F;
2349
2350 idx++;
2351 result = SCM_MAKINUM (digit_value);
2352 while (idx != len)
f872b822 2353 {
3c9a524f 2354 char c = mem[idx];
71df73ac 2355 if (isxdigit ((int) (unsigned char) c))
f872b822 2356 {
3c9a524f 2357 if (hash_seen)
1fe5e088 2358 break;
3c9a524f
DH		 2359 digit_value = XDIGIT2UINT (c);
2360 if (digit_value >= radix)
1fe5e088 2361 break;
f872b822 2362 }
3c9a524f
DH		 2363 else if (c == '#')
2364 {
2365 hash_seen = 1;
2366 digit_value = 0;
2367 }
2368 else
2369 break;
2370
2371 idx++;
2372 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
2373 {
2374 result = scm_product (result, SCM_MAKINUM (shift));
2375 if (add > 0)
2376 result = scm_sum (result, SCM_MAKINUM (add));
2377
2378 shift = radix;
2379 add = digit_value;
2380 }
2381 else
2382 {
2383 shift = shift * radix;
2384 add = add * radix + digit_value;
2385 }
2386 };
2387
2388 if (shift > 1)
2389 result = scm_product (result, SCM_MAKINUM (shift));
2390 if (add > 0)
2391 result = scm_sum (result, SCM_MAKINUM (add));
2392
2393 *p_idx = idx;
2394 if (hash_seen)
2395 *p_exactness = INEXACT;
2396
2397 return result;
2a8fecee
JB		 2398}
2399
2400
3c9a524f
DH		 2401/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2402 * covers the parts of the rules that start at a potential point. The value
2403 * of the digits up to the point have been parsed by the caller and are given
79d34f68
DH		 2404 * in variable result. The content of *p_exactness indicates, whether a hash
2405 * has already been seen in the digits before the point.
3c9a524f 2406 */
1cc91f1b 2407
3c9a524f
DH		 2408/* In non ASCII-style encodings the following macro might not work. */
2409#define DIGIT2UINT(d) ((d) - '0')
2410
2411static SCM
79d34f68 2412mem2decimal_from_point (SCM result, const char* mem, size_t len,
3c9a524f 2413 unsigned int *p_idx, enum t_exactness *p_exactness)
0f2d19dd 2414{
3c9a524f
DH		 2415 unsigned int idx = *p_idx;
2416 enum t_exactness x = *p_exactness;
3c9a524f
DH		 2417
2418 if (idx == len)
79d34f68 2419 return result;
3c9a524f
DH		 2420
2421 if (mem[idx] == '.')
2422 {
2423 scm_t_bits shift = 1;
2424 scm_t_bits add = 0;
2425 unsigned int digit_value;
79d34f68 2426 SCM big_shift = SCM_MAKINUM (1);
3c9a524f
DH		 2427
2428 idx++;
2429 while (idx != len)
2430 {
2431 char c = mem[idx];
71df73ac 2432 if (isdigit ((int) (unsigned char) c))
3c9a524f
DH		 2433 {
2434 if (x == INEXACT)
2435 return SCM_BOOL_F;
2436 else
2437 digit_value = DIGIT2UINT (c);
2438 }
2439 else if (c == '#')
2440 {
2441 x = INEXACT;
2442 digit_value = 0;
2443 }
2444 else
2445 break;
2446
2447 idx++;
2448 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
2449 {
2450 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68 2451 result = scm_product (result, SCM_MAKINUM (shift));
3c9a524f 2452 if (add > 0)
79d34f68 2453 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2454
2455 shift = 10;
2456 add = digit_value;
2457 }
2458 else
2459 {
2460 shift = shift * 10;
2461 add = add * 10 + digit_value;
2462 }
2463 };
2464
2465 if (add > 0)
2466 {
2467 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68
DH		 2468 result = scm_product (result, SCM_MAKINUM (shift));
2469 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2470 }
2471
d8592269 2472 result = scm_divide (result, big_shift);
79d34f68 2473
3c9a524f
DH		 2474 /* We've seen a decimal point, thus the value is implicitly inexact. */
2475 x = INEXACT;
f872b822 2476 }
3c9a524f 2477
3c9a524f 2478 if (idx != len)
f872b822 2479 {
3c9a524f
DH		 2480 int sign = 1;
2481 unsigned int start;
2482 char c;
2483 int exponent;
2484 SCM e;
2485
2486 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2487
2488 switch (mem[idx])
f872b822 2489 {
3c9a524f
DH		 2490 case 'd': case 'D':
2491 case 'e': case 'E':
2492 case 'f': case 'F':
2493 case 'l': case 'L':
2494 case 's': case 'S':
2495 idx++;
2496 start = idx;
2497 c = mem[idx];
2498 if (c == '-')
2499 {
2500 idx++;
2501 sign = -1;
2502 c = mem[idx];
2503 }
2504 else if (c == '+')
2505 {
2506 idx++;
2507 sign = 1;
2508 c = mem[idx];
2509 }
2510 else
2511 sign = 1;
2512
71df73ac 2513 if (!isdigit ((int) (unsigned char) c))
3c9a524f
DH		 2514 return SCM_BOOL_F;
2515
2516 idx++;
2517 exponent = DIGIT2UINT (c);
2518 while (idx != len)
f872b822 2519 {
3c9a524f 2520 char c = mem[idx];
71df73ac 2521 if (isdigit ((int) (unsigned char) c))
3c9a524f
DH		 2522 {
2523 idx++;
2524 if (exponent <= SCM_MAXEXP)
2525 exponent = exponent * 10 + DIGIT2UINT (c);
2526 }
2527 else
2528 break;
f872b822 2529 }
3c9a524f
DH		 2530
2531 if (exponent > SCM_MAXEXP)
f872b822 2532 {
3c9a524f
DH		 2533 size_t exp_len = idx - start;
2534 SCM exp_string = scm_mem2string (&mem[start], exp_len);
2535 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
2536 scm_out_of_range ("string->number", exp_num);
f872b822 2537 }
3c9a524f
DH		 2538
2539 e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent));
2540 if (sign == 1)
2541 result = scm_product (result, e);
2542 else
f92e85f7 2543 result = scm_divide2real (result, e);
3c9a524f
DH		 2544
2545 /* We've seen an exponent, thus the value is implicitly inexact. */
2546 x = INEXACT;
2547
f872b822 2548 break;
3c9a524f 2549
f872b822 2550 default:
3c9a524f 2551 break;
f872b822 2552 }
0f2d19dd 2553 }
3c9a524f
DH		 2554
2555 *p_idx = idx;
2556 if (x == INEXACT)
2557 *p_exactness = x;
2558
2559 return result;
0f2d19dd 2560}
0f2d19dd 2561
3c9a524f
DH		 2562
2563/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2564
2565static SCM
2566mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
2567 unsigned int radix, enum t_exactness *p_exactness)
0f2d19dd 2568{
3c9a524f 2569 unsigned int idx = *p_idx;
164d2481 2570 SCM result;
3c9a524f
DH		 2571
2572 if (idx == len)
2573 return SCM_BOOL_F;
2574
7351e207
MV		 2575 if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
2576 {
2577 *p_idx = idx+5;
2578 return scm_inf ();
2579 }
2580
2581 if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
2582 {
2583 enum t_exactness x = EXACT;
2584
d8592269
MV		 2585 /* Cobble up the fractional part. We might want to set the
2586 NaN's mantissa from it. */
7351e207
MV		 2587 idx += 4;
2588 mem2uinteger (mem, len, &idx, 10, &x);
2589 *p_idx = idx;
2590 return scm_nan ();
2591 }
2592
3c9a524f
DH		 2593 if (mem[idx] == '.')
2594 {
2595 if (radix != 10)
2596 return SCM_BOOL_F;
2597 else if (idx + 1 == len)
2598 return SCM_BOOL_F;
71df73ac 2599 else if (!isdigit ((int) (unsigned char) mem[idx + 1]))
3c9a524f
DH		 2600 return SCM_BOOL_F;
2601 else
164d2481
MV		 2602 result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
2603 p_idx, p_exactness);
f872b822 2604 }
3c9a524f
DH		 2605 else
2606 {
2607 enum t_exactness x = EXACT;
2608 SCM uinteger;
3c9a524f
DH		 2609
2610 uinteger = mem2uinteger (mem, len, &idx, radix, &x);
2611 if (SCM_FALSEP (uinteger))
2612 return SCM_BOOL_F;
2613
2614 if (idx == len)
2615 result = uinteger;
2616 else if (mem[idx] == '/')
f872b822 2617 {
3c9a524f
DH		 2618 SCM divisor;
2619
2620 idx++;
2621
2622 divisor = mem2uinteger (mem, len, &idx, radix, &x);
2623 if (SCM_FALSEP (divisor))
2624 return SCM_BOOL_F;
2625
f92e85f7
MV		 2626 /* both are int/big here, I assume */
2627 result = scm_make_ratio (uinteger, divisor);
f872b822 2628 }
3c9a524f
DH		 2629 else if (radix == 10)
2630 {
2631 result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
2632 if (SCM_FALSEP (result))
2633 return SCM_BOOL_F;
2634 }
2635 else
2636 result = uinteger;
2637
2638 *p_idx = idx;
2639 if (x == INEXACT)
2640 *p_exactness = x;
f872b822 2641 }
164d2481
MV		 2642
2643 /* When returning an inexact zero, make sure it is represented as a
2644 floating point value so that we can change its sign.
2645 */
2646 if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT)
2647 result = scm_make_real (0.0);
2648
2649 return result;
3c9a524f 2650}
0f2d19dd 2651
0f2d19dd 2652
3c9a524f 2653/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
0f2d19dd 2654
3c9a524f
DH		 2655static SCM
2656mem2complex (const char* mem, size_t len, unsigned int idx,
2657 unsigned int radix, enum t_exactness *p_exactness)
2658{
2659 char c;
2660 int sign = 0;
2661 SCM ureal;
2662
2663 if (idx == len)
2664 return SCM_BOOL_F;
2665
2666 c = mem[idx];
2667 if (c == '+')
2668 {
2669 idx++;
2670 sign = 1;
2671 }
2672 else if (c == '-')
2673 {
2674 idx++;
2675 sign = -1;
0f2d19dd 2676 }
0f2d19dd 2677
3c9a524f
DH		 2678 if (idx == len)
2679 return SCM_BOOL_F;
2680
2681 ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
2682 if (SCM_FALSEP (ureal))
f872b822 2683 {
3c9a524f
DH		 2684 /* input must be either +i or -i */
2685
2686 if (sign == 0)
2687 return SCM_BOOL_F;
2688
2689 if (mem[idx] == 'i' || mem[idx] == 'I')
f872b822 2690 {
3c9a524f
DH		 2691 idx++;
2692 if (idx != len)
2693 return SCM_BOOL_F;
2694
2695 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign));
f872b822 2696 }
3c9a524f
DH		 2697 else
2698 return SCM_BOOL_F;
0f2d19dd 2699 }
3c9a524f
DH		 2700 else
2701 {
fc194577 2702 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f 2703 ureal = scm_difference (ureal, SCM_UNDEFINED);
f872b822 2704
3c9a524f
DH		 2705 if (idx == len)
2706 return ureal;
2707
2708 c = mem[idx];
2709 switch (c)
f872b822 2710 {
3c9a524f
DH		 2711 case 'i': case 'I':
2712 /* either +<ureal>i or -<ureal>i */
2713
2714 idx++;
2715 if (sign == 0)
2716 return SCM_BOOL_F;
2717 if (idx != len)
2718 return SCM_BOOL_F;
2719 return scm_make_rectangular (SCM_MAKINUM (0), ureal);
2720
2721 case '@':
2722 /* polar input: <real>@<real>. */
2723
2724 idx++;
2725 if (idx == len)
2726 return SCM_BOOL_F;
2727 else
f872b822 2728 {
3c9a524f
DH		 2729 int sign;
2730 SCM angle;
2731 SCM result;
2732
2733 c = mem[idx];
2734 if (c == '+')
2735 {
2736 idx++;
2737 sign = 1;
2738 }
2739 else if (c == '-')
2740 {
2741 idx++;
2742 sign = -1;
2743 }
2744 else
2745 sign = 1;
2746
2747 angle = mem2ureal (mem, len, &idx, radix, p_exactness);
2748 if (SCM_FALSEP (angle))
2749 return SCM_BOOL_F;
2750 if (idx != len)
2751 return SCM_BOOL_F;
2752
fc194577 2753 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f
DH		 2754 angle = scm_difference (angle, SCM_UNDEFINED);
2755
2756 result = scm_make_polar (ureal, angle);
2757 return result;
f872b822 2758 }
3c9a524f
DH		 2759 case '+':
2760 case '-':
2761 /* expecting input matching <real>[+-]<ureal>?i */
0f2d19dd 2762
3c9a524f
DH		 2763 idx++;
2764 if (idx == len)
2765 return SCM_BOOL_F;
2766 else
2767 {
2768 int sign = (c == '+') ? 1 : -1;
2769 SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
0f2d19dd 2770
3c9a524f
DH		 2771 if (SCM_FALSEP (imag))
2772 imag = SCM_MAKINUM (sign);
fc194577 2773 else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
1fe5e088 2774 imag = scm_difference (imag, SCM_UNDEFINED);
0f2d19dd 2775
3c9a524f
DH		 2776 if (idx == len)
2777 return SCM_BOOL_F;
2778 if (mem[idx] != 'i' && mem[idx] != 'I')
2779 return SCM_BOOL_F;
0f2d19dd 2780
3c9a524f
DH		 2781 idx++;
2782 if (idx != len)
2783 return SCM_BOOL_F;
0f2d19dd 2784
1fe5e088 2785 return scm_make_rectangular (ureal, imag);
3c9a524f
DH		 2786 }
2787 default:
2788 return SCM_BOOL_F;
2789 }
2790 }
0f2d19dd 2791}
0f2d19dd
JB		 2792
2793
3c9a524f
DH		 2794/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2795
2796enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
1cc91f1b 2797
0f2d19dd 2798SCM
3c9a524f 2799scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix)
0f2d19dd 2800{
3c9a524f
DH		 2801 unsigned int idx = 0;
2802 unsigned int radix = NO_RADIX;
2803 enum t_exactness forced_x = NO_EXACTNESS;
2804 enum t_exactness implicit_x = EXACT;
2805 SCM result;
2806
2807 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2808 while (idx + 2 < len && mem[idx] == '#')
2809 {
2810 switch (mem[idx + 1])
2811 {
2812 case 'b': case 'B':
2813 if (radix != NO_RADIX)
2814 return SCM_BOOL_F;
2815 radix = DUAL;
2816 break;
2817 case 'd': case 'D':
2818 if (radix != NO_RADIX)
2819 return SCM_BOOL_F;
2820 radix = DEC;
2821 break;
2822 case 'i': case 'I':
2823 if (forced_x != NO_EXACTNESS)
2824 return SCM_BOOL_F;
2825 forced_x = INEXACT;
2826 break;
2827 case 'e': case 'E':
2828 if (forced_x != NO_EXACTNESS)
2829 return SCM_BOOL_F;
2830 forced_x = EXACT;
2831 break;
2832 case 'o': case 'O':
2833 if (radix != NO_RADIX)
2834 return SCM_BOOL_F;
2835 radix = OCT;
2836 break;
2837 case 'x': case 'X':
2838 if (radix != NO_RADIX)
2839 return SCM_BOOL_F;
2840 radix = HEX;
2841 break;
2842 default:
f872b822 2843 return SCM_BOOL_F;
3c9a524f
DH		 2844 }
2845 idx += 2;
2846 }
2847
2848 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2849 if (radix == NO_RADIX)
2850 result = mem2complex (mem, len, idx, default_radix, &implicit_x);
2851 else
2852 result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
2853
2854 if (SCM_FALSEP (result))
2855 return SCM_BOOL_F;
f872b822 2856
3c9a524f 2857 switch (forced_x)
f872b822 2858 {
3c9a524f
DH		 2859 case EXACT:
2860 if (SCM_INEXACTP (result))
3c9a524f
DH		 2861 return scm_inexact_to_exact (result);
2862 else
2863 return result;
2864 case INEXACT:
2865 if (SCM_INEXACTP (result))
2866 return result;
2867 else
2868 return scm_exact_to_inexact (result);
2869 case NO_EXACTNESS:
2870 default:
2871 if (implicit_x == INEXACT)
2872 {
2873 if (SCM_INEXACTP (result))
2874 return result;
2875 else
2876 return scm_exact_to_inexact (result);
2877 }
2878 else
2879 return result;
f872b822 2880 }
0f2d19dd
JB		 2881}
2882
2883
a1ec6916 2884SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
bb628794 2885 (SCM string, SCM radix),
1e6808ea 2886 "Return a number of the maximally precise representation\n"
942e5b91 2887 "expressed by the given @var{string}. @var{radix} must be an\n"
5352393c
MG		 2888 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2889 "is a default radix that may be overridden by an explicit radix\n"
2890 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2891 "supplied, then the default radix is 10. If string is not a\n"
2892 "syntactically valid notation for a number, then\n"
2893 "@code{string->number} returns @code{#f}.")
1bbd0b84 2894#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 2895{
2896 SCM answer;
1bbd0b84 2897 int base;
a6d9e5ab 2898 SCM_VALIDATE_STRING (1, string);
34d19ef6 2899 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base);
3c9a524f 2900 answer = scm_i_mem2number (SCM_STRING_CHARS (string),
d8592269
MV		 2901 SCM_STRING_LENGTH (string),
2902 base);
bb628794 2903 return scm_return_first (answer, string);
0f2d19dd 2904}
1bbd0b84 2905#undef FUNC_NAME
3c9a524f
DH		 2906
2907
0f2d19dd
JB		 2908/*** END strs->nums ***/
2909
5986c47d 2910
0f2d19dd 2911SCM
f3ae5d60 2912scm_make_real (double x)
0f2d19dd 2913{
3553e1d1
GH		 2914 SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
2915
3a9809df 2916 SCM_REAL_VALUE (z) = x;
0f2d19dd
JB		 2917 return z;
2918}
0f2d19dd 2919
5986c47d 2920
f3ae5d60
MD		 2921SCM
2922scm_make_complex (double x, double y)
2923{
0aacf84e 2924 if (y == 0.0)
3a9809df 2925 return scm_make_real (x);
0aacf84e
MD		 2926 else
2927 {
2928 SCM z;
29c4382a 2929 SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
0aacf84e
MD		 2930 "complex"));
2931 SCM_COMPLEX_REAL (z) = x;
2932 SCM_COMPLEX_IMAG (z) = y;
2933 return z;
2934 }
f3ae5d60 2935}
1cc91f1b 2936
5986c47d 2937
0f2d19dd 2938SCM
1bbd0b84 2939scm_bigequal (SCM x, SCM y)
0f2d19dd 2940{
47ae1f0e 2941 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
ca46fb90
RB		 2942 scm_remember_upto_here_2 (x, y);
2943 return SCM_BOOL (0 == result);
0f2d19dd
JB		 2944}
2945
0f2d19dd 2946SCM
f3ae5d60 2947scm_real_equalp (SCM x, SCM y)
0f2d19dd 2948{
f3ae5d60 2949 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
0f2d19dd
JB		 2950}
2951
f3ae5d60
MD		 2952SCM
2953scm_complex_equalp (SCM x, SCM y)
2954{
2955 return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
2956 && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
2957}
0f2d19dd 2958
f92e85f7
MV		 2959SCM
2960scm_i_fraction_equalp (SCM x, SCM y)
2961{
2962 scm_i_fraction_reduce (x);
2963 scm_i_fraction_reduce (y);
02164269
MV		 2964 if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
2965 SCM_FRACTION_NUMERATOR (y)))
2966 || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
2967 SCM_FRACTION_DENOMINATOR (y))))
2968 return SCM_BOOL_F;
2969 else
2970 return SCM_BOOL_T;
f92e85f7 2971}
0f2d19dd
JB		 2972
2973
1bbd0b84 2974SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
942e5b91
MG		 2975/* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2976 * "else. Note that the sets of complex, real, rational and\n"
2977 * "integer values form subsets of the set of numbers, i. e. the\n"
2978 * "predicate will be fulfilled for any number."
2979 */
a1ec6916 2980SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0,
1bbd0b84 2981 (SCM x),
942e5b91 2982 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
bb2c02f2 2983 "otherwise. Note that the sets of real, rational and integer\n"
942e5b91
MG		 2984 "values form subsets of the set of complex numbers, i. e. the\n"
2985 "predicate will also be fulfilled if @var{x} is a real,\n"
2986 "rational or integer number.")
1bbd0b84 2987#define FUNC_NAME s_scm_number_p
0f2d19dd 2988{
bb628794 2989 return SCM_BOOL (SCM_NUMBERP (x));
0f2d19dd 2990}
1bbd0b84 2991#undef FUNC_NAME
0f2d19dd
JB		 2992
2993
f92e85f7
MV		 2994SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
2995 (SCM x),
2996 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
2997 "otherwise. Note that the set of integer values forms a subset of\n"
2998 "the set of real numbers, i. e. the predicate will also be\n"
2999 "fulfilled if @var{x} is an integer number.")
3000#define FUNC_NAME s_scm_real_p
3001{
3002 /* we can't represent irrational numbers. */
3003 return scm_rational_p (x);
3004}
3005#undef FUNC_NAME
3006
3007SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
1bbd0b84 3008 (SCM x),
942e5b91 3009 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
bb2c02f2 3010 "otherwise. Note that the set of integer values forms a subset of\n"
942e5b91 3011 "the set of rational numbers, i. e. the predicate will also be\n"
f92e85f7
MV		 3012 "fulfilled if @var{x} is an integer number.")
3013#define FUNC_NAME s_scm_rational_p
0f2d19dd 3014{
0aacf84e 3015 if (SCM_INUMP (x))
0f2d19dd 3016 return SCM_BOOL_T;
0aacf84e 3017 else if (SCM_IMP (x))
0f2d19dd 3018 return SCM_BOOL_F;
0aacf84e 3019 else if (SCM_BIGP (x))
0f2d19dd 3020 return SCM_BOOL_T;
f92e85f7
MV		 3021 else if (SCM_FRACTIONP (x))
3022 return SCM_BOOL_T;
3023 else if (SCM_REALP (x))
3024 /* due to their limited precision, all floating point numbers are
3025 rational as well. */
3026 return SCM_BOOL_T;
0aacf84e 3027 else
bb628794 3028 return SCM_BOOL_F;
0f2d19dd 3029}
1bbd0b84 3030#undef FUNC_NAME
0f2d19dd
JB		 3031
3032
a1ec6916 3033SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
1bbd0b84 3034 (SCM x),
942e5b91
MG		 3035 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
3036 "else.")
1bbd0b84 3037#define FUNC_NAME s_scm_integer_p
0f2d19dd
JB		 3038{
3039 double r;
f872b822
MD		 3040 if (SCM_INUMP (x))
3041 return SCM_BOOL_T;
3042 if (SCM_IMP (x))
3043 return SCM_BOOL_F;
f872b822
MD		 3044 if (SCM_BIGP (x))
3045 return SCM_BOOL_T;
3c9a524f 3046 if (!SCM_INEXACTP (x))
f872b822 3047 return SCM_BOOL_F;
3c9a524f 3048 if (SCM_COMPLEXP (x))
f872b822 3049 return SCM_BOOL_F;
5986c47d 3050 r = SCM_REAL_VALUE (x);
f872b822
MD		 3051 if (r == floor (r))
3052 return SCM_BOOL_T;
0f2d19dd
JB		 3053 return SCM_BOOL_F;
3054}
1bbd0b84 3055#undef FUNC_NAME
0f2d19dd
JB		 3056
3057
a1ec6916 3058SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
1bbd0b84 3059 (SCM x),
942e5b91
MG		 3060 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3061 "else.")
1bbd0b84 3062#define FUNC_NAME s_scm_inexact_p
0f2d19dd 3063{
eb927cb9
MV		 3064 if (SCM_INEXACTP (x))
3065 return SCM_BOOL_T;
3066 if (SCM_NUMBERP (x))
3067 return SCM_BOOL_F;
3068 SCM_WRONG_TYPE_ARG (1, x);
0f2d19dd 3069}
1bbd0b84 3070#undef FUNC_NAME
0f2d19dd
JB		 3071
3072
152f82bf 3073SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
942e5b91 3074/* "Return @code{#t} if all parameters are numerically equal." */
0f2d19dd 3075SCM
6e8d25a6 3076scm_num_eq_p (SCM x, SCM y)
0f2d19dd 3077{
d8b95e27 3078 again:
0aacf84e
MD		 3079 if (SCM_INUMP (x))
3080 {
3081 long xx = SCM_INUM (x);
3082 if (SCM_INUMP (y))
3083 {
3084 long yy = SCM_INUM (y);
3085 return SCM_BOOL (xx == yy);
3086 }
3087 else if (SCM_BIGP (y))
3088 return SCM_BOOL_F;
3089 else if (SCM_REALP (y))
3090 return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));
3091 else if (SCM_COMPLEXP (y))
3092 return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))
3093 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 3094 else if (SCM_FRACTIONP (y))
3095 return SCM_BOOL_F;
0aacf84e
MD		 3096 else
3097 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 3098 }
0aacf84e
MD		 3099 else if (SCM_BIGP (x))
3100 {
3101 if (SCM_INUMP (y))
3102 return SCM_BOOL_F;
3103 else if (SCM_BIGP (y))
3104 {
3105 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3106 scm_remember_upto_here_2 (x, y);
3107 return SCM_BOOL (0 == cmp);
3108 }
3109 else if (SCM_REALP (y))
3110 {
3111 int cmp;
3112 if (xisnan (SCM_REAL_VALUE (y)))
3113 return SCM_BOOL_F;
3114 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
3115 scm_remember_upto_here_1 (x);
3116 return SCM_BOOL (0 == cmp);
3117 }
3118 else if (SCM_COMPLEXP (y))
3119 {
3120 int cmp;
3121 if (0.0 != SCM_COMPLEX_IMAG (y))
3122 return SCM_BOOL_F;
3123 if (xisnan (SCM_COMPLEX_REAL (y)))
3124 return SCM_BOOL_F;
3125 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
3126 scm_remember_upto_here_1 (x);
3127 return SCM_BOOL (0 == cmp);
3128 }
f92e85f7
MV		 3129 else if (SCM_FRACTIONP (y))
3130 return SCM_BOOL_F;
0aacf84e
MD		 3131 else
3132 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 3133 }
0aacf84e
MD		 3134 else if (SCM_REALP (x))
3135 {
3136 if (SCM_INUMP (y))
3137 return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));
3138 else if (SCM_BIGP (y))
3139 {
3140 int cmp;
3141 if (xisnan (SCM_REAL_VALUE (x)))
3142 return SCM_BOOL_F;
3143 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
3144 scm_remember_upto_here_1 (y);
3145 return SCM_BOOL (0 == cmp);
3146 }
3147 else if (SCM_REALP (y))
3148 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
3149 else if (SCM_COMPLEXP (y))
3150 return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
3151 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7 3152 else if (SCM_FRACTIONP (y))
d8b95e27
KR		 3153 {
3154 double xx = SCM_REAL_VALUE (x);
3155 if (xisnan (xx))
3156 return SCM_BOOL_F;
3157 if (xisinf (xx))
3158 return SCM_BOOL (xx < 0.0);
3159 x = scm_inexact_to_exact (x); /* with x as frac or int */
3160 goto again;
3161 }
0aacf84e
MD		 3162 else
3163 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 3164 }
0aacf84e
MD		 3165 else if (SCM_COMPLEXP (x))
3166 {
3167 if (SCM_INUMP (y))
3168 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))
3169 && (SCM_COMPLEX_IMAG (x) == 0.0));
3170 else if (SCM_BIGP (y))
3171 {
3172 int cmp;
3173 if (0.0 != SCM_COMPLEX_IMAG (x))
3174 return SCM_BOOL_F;
3175 if (xisnan (SCM_COMPLEX_REAL (x)))
3176 return SCM_BOOL_F;
3177 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
3178 scm_remember_upto_here_1 (y);
3179 return SCM_BOOL (0 == cmp);
3180 }
3181 else if (SCM_REALP (y))
3182 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
3183 && (SCM_COMPLEX_IMAG (x) == 0.0));
3184 else if (SCM_COMPLEXP (y))
3185 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
3186 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
f92e85f7 3187 else if (SCM_FRACTIONP (y))
d8b95e27
KR		 3188 {
3189 double xx;
3190 if (SCM_COMPLEX_IMAG (x) != 0.0)
3191 return SCM_BOOL_F;
3192 xx = SCM_COMPLEX_REAL (x);
3193 if (xisnan (xx))
3194 return SCM_BOOL_F;
3195 if (xisinf (xx))
3196 return SCM_BOOL (xx < 0.0);
3197 x = scm_inexact_to_exact (x); /* with x as frac or int */
3198 goto again;
3199 }
f92e85f7
MV		 3200 else
3201 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
3202 }
3203 else if (SCM_FRACTIONP (x))
3204 {
3205 if (SCM_INUMP (y))
3206 return SCM_BOOL_F;
3207 else if (SCM_BIGP (y))
3208 return SCM_BOOL_F;
3209 else if (SCM_REALP (y))
d8b95e27
KR		 3210 {
3211 double yy = SCM_REAL_VALUE (y);
3212 if (xisnan (yy))
3213 return SCM_BOOL_F;
3214 if (xisinf (yy))
3215 return SCM_BOOL (0.0 < yy);
3216 y = scm_inexact_to_exact (y); /* with y as frac or int */
3217 goto again;
3218 }
f92e85f7 3219 else if (SCM_COMPLEXP (y))
d8b95e27
KR		 3220 {
3221 double yy;
3222 if (SCM_COMPLEX_IMAG (y) != 0.0)
3223 return SCM_BOOL_F;
3224 yy = SCM_COMPLEX_REAL (y);
3225 if (xisnan (yy))
3226 return SCM_BOOL_F;
3227 if (xisinf (yy))
3228 return SCM_BOOL (0.0 < yy);
3229 y = scm_inexact_to_exact (y); /* with y as frac or int */
3230 goto again;
3231 }
f92e85f7
MV		 3232 else if (SCM_FRACTIONP (y))
3233 return scm_i_fraction_equalp (x, y);
0aacf84e
MD		 3234 else
3235 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 3236 }
0aacf84e 3237 else
f4c627b3 3238 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
0f2d19dd
JB		 3239}
3240
3241
a5f0b599
KR		 3242/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
3243 done are good for inums, but for bignums an answer can almost always be
3244 had by just examining a few high bits of the operands, as done by GMP in
3245 mpq_cmp. flonum/frac compares likewise, but with the slight complication
3246 of the float exponent to take into account. */
3247
152f82bf 3248SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
942e5b91
MG		 3249/* "Return @code{#t} if the list of parameters is monotonically\n"
3250 * "increasing."
3251 */
0f2d19dd 3252SCM
6e8d25a6 3253scm_less_p (SCM x, SCM y)
0f2d19dd 3254{
a5f0b599 3255 again:
0aacf84e
MD		 3256 if (SCM_INUMP (x))
3257 {
3258 long xx = SCM_INUM (x);
3259 if (SCM_INUMP (y))
3260 {
3261 long yy = SCM_INUM (y);
3262 return SCM_BOOL (xx < yy);
3263 }
3264 else if (SCM_BIGP (y))
3265 {
3266 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3267 scm_remember_upto_here_1 (y);
3268 return SCM_BOOL (sgn > 0);
3269 }
3270 else if (SCM_REALP (y))
3271 return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
f92e85f7 3272 else if (SCM_FRACTIONP (y))
a5f0b599
KR		 3273 {
3274 /* "x < a/b" becomes "x*b < a" */
3275 int_frac:
3276 x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
3277 y = SCM_FRACTION_NUMERATOR (y);
3278 goto again;
3279 }
0aacf84e
MD		 3280 else
3281 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 3282 }
0aacf84e
MD		 3283 else if (SCM_BIGP (x))
3284 {
3285 if (SCM_INUMP (y))
3286 {
3287 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3288 scm_remember_upto_here_1 (x);
3289 return SCM_BOOL (sgn < 0);
3290 }
3291 else if (SCM_BIGP (y))
3292 {
3293 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3294 scm_remember_upto_here_2 (x, y);
3295 return SCM_BOOL (cmp < 0);
3296 }
3297 else if (SCM_REALP (y))
3298 {
3299 int cmp;
3300 if (xisnan (SCM_REAL_VALUE (y)))
3301 return SCM_BOOL_F;
3302 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
3303 scm_remember_upto_here_1 (x);
3304 return SCM_BOOL (cmp < 0);
3305 }
f92e85f7 3306 else if (SCM_FRACTIONP (y))
a5f0b599 3307 goto int_frac;
0aacf84e
MD		 3308 else
3309 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f4c627b3 3310 }
0aacf84e
MD		 3311 else if (SCM_REALP (x))
3312 {
3313 if (SCM_INUMP (y))
3314 return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));
3315 else if (SCM_BIGP (y))
3316 {
3317 int cmp;
3318 if (xisnan (SCM_REAL_VALUE (x)))
3319 return SCM_BOOL_F;
3320 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
3321 scm_remember_upto_here_1 (y);
3322 return SCM_BOOL (cmp > 0);
3323 }
3324 else if (SCM_REALP (y))
3325 return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
f92e85f7 3326 else if (SCM_FRACTIONP (y))
a5f0b599
KR		 3327 {
3328 double xx = SCM_REAL_VALUE (x);
3329 if (xisnan (xx))
3330 return SCM_BOOL_F;
3331 if (xisinf (xx))
3332 return SCM_BOOL (xx < 0.0);
3333 x = scm_inexact_to_exact (x); /* with x as frac or int */
3334 goto again;
3335 }
f92e85f7
MV		 3336 else
3337 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
3338 }
3339 else if (SCM_FRACTIONP (x))
3340 {
a5f0b599
KR		 3341 if (SCM_INUMP (y) || SCM_BIGP (y))
3342 {
3343 /* "a/b < y" becomes "a < y*b" */
3344 y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
3345 x = SCM_FRACTION_NUMERATOR (x);
3346 goto again;
3347 }
f92e85f7 3348 else if (SCM_REALP (y))
a5f0b599
KR		 3349 {
3350 double yy = SCM_REAL_VALUE (y);
3351 if (xisnan (yy))
3352 return SCM_BOOL_F;
3353 if (xisinf (yy))
3354 return SCM_BOOL (0.0 < yy);
3355 y = scm_inexact_to_exact (y); /* with y as frac or int */
3356 goto again;
3357 }
f92e85f7 3358 else if (SCM_FRACTIONP (y))
a5f0b599
KR		 3359 {
3360 /* "a/b < c/d" becomes "a*d < c*b" */
3361 SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
3362 SCM_FRACTION_DENOMINATOR (y));
3363 SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
3364 SCM_FRACTION_DENOMINATOR (x));
3365 x = new_x;
3366 y = new_y;
3367 goto again;
3368 }
0aacf84e
MD		 3369 else
3370 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 3371 }
0aacf84e 3372 else
f4c627b3 3373 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
0f2d19dd
JB		 3374}
3375
3376
c76b1eaf 3377SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
942e5b91
MG		 3378/* "Return @code{#t} if the list of parameters is monotonically\n"
3379 * "decreasing."
c76b1eaf 3380 */
1bbd0b84 3381#define FUNC_NAME s_scm_gr_p
c76b1eaf
MD		 3382SCM
3383scm_gr_p (SCM x, SCM y)
0f2d19dd 3384{
c76b1eaf
MD		 3385 if (!SCM_NUMBERP (x))
3386 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
3387 else if (!SCM_NUMBERP (y))
3388 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
3389 else
3390 return scm_less_p (y, x);
0f2d19dd 3391}
1bbd0b84 3392#undef FUNC_NAME
0f2d19dd
JB		 3393
3394
c76b1eaf 3395SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
942e5b91 3396/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 3397 * "non-decreasing."
3398 */
1bbd0b84 3399#define FUNC_NAME s_scm_leq_p
c76b1eaf
MD		 3400SCM
3401scm_leq_p (SCM x, SCM y)
0f2d19dd 3402{
c76b1eaf
MD		 3403 if (!SCM_NUMBERP (x))
3404 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
3405 else if (!SCM_NUMBERP (y))
3406 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 3407 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
3408 return SCM_BOOL_F;
c76b1eaf
MD		 3409 else
3410 return SCM_BOOL_NOT (scm_less_p (y, x));
0f2d19dd 3411}
1bbd0b84 3412#undef FUNC_NAME
0f2d19dd
JB		 3413
3414
c76b1eaf 3415SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
942e5b91 3416/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 3417 * "non-increasing."
3418 */
1bbd0b84 3419#define FUNC_NAME s_scm_geq_p
c76b1eaf
MD		 3420SCM
3421scm_geq_p (SCM x, SCM y)
0f2d19dd 3422{
c76b1eaf
MD		 3423 if (!SCM_NUMBERP (x))
3424 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
3425 else if (!SCM_NUMBERP (y))
3426 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 3427 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
3428 return SCM_BOOL_F;
c76b1eaf 3429 else
fc194577 3430 return SCM_BOOL_NOT (scm_less_p (x, y));
0f2d19dd 3431}
1bbd0b84 3432#undef FUNC_NAME
0f2d19dd
JB		 3433
3434
152f82bf 3435SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
942e5b91
MG		 3436/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3437 * "zero."
3438 */
0f2d19dd 3439SCM
6e8d25a6 3440scm_zero_p (SCM z)
0f2d19dd 3441{
0aacf84e 3442 if (SCM_INUMP (z))
c2ff8ab0 3443 return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));
0aacf84e 3444 else if (SCM_BIGP (z))
c2ff8ab0 3445 return SCM_BOOL_F;
0aacf84e 3446 else if (SCM_REALP (z))
c2ff8ab0 3447 return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);
0aacf84e 3448 else if (SCM_COMPLEXP (z))
c2ff8ab0
DH		 3449 return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0
3450 && SCM_COMPLEX_IMAG (z) == 0.0);
f92e85f7
MV		 3451 else if (SCM_FRACTIONP (z))
3452 return SCM_BOOL_F;
0aacf84e 3453 else
c2ff8ab0 3454 SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
0f2d19dd
JB		 3455}
3456
3457
152f82bf 3458SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
942e5b91
MG		 3459/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3460 * "zero."
3461 */
0f2d19dd 3462SCM
6e8d25a6 3463scm_positive_p (SCM x)
0f2d19dd 3464{
0aacf84e 3465 if (SCM_INUMP (x))
c2ff8ab0 3466 return SCM_BOOL (SCM_INUM (x) > 0);
0aacf84e
MD		 3467 else if (SCM_BIGP (x))
3468 {
3469 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3470 scm_remember_upto_here_1 (x);
3471 return SCM_BOOL (sgn > 0);
3472 }
3473 else if (SCM_REALP (x))
c2ff8ab0 3474 return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);
f92e85f7
MV		 3475 else if (SCM_FRACTIONP (x))
3476 return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 3477 else
c2ff8ab0 3478 SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
0f2d19dd
JB		 3479}
3480
3481
152f82bf 3482SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
942e5b91
MG		 3483/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3484 * "zero."
3485 */
0f2d19dd 3486SCM
6e8d25a6 3487scm_negative_p (SCM x)
0f2d19dd 3488{
0aacf84e 3489 if (SCM_INUMP (x))
c2ff8ab0 3490 return SCM_BOOL (SCM_INUM (x) < 0);
0aacf84e
MD		 3491 else if (SCM_BIGP (x))
3492 {
3493 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3494 scm_remember_upto_here_1 (x);
3495 return SCM_BOOL (sgn < 0);
3496 }
3497 else if (SCM_REALP (x))
c2ff8ab0 3498 return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);
f92e85f7
MV		 3499 else if (SCM_FRACTIONP (x))
3500 return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 3501 else
c2ff8ab0 3502 SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
0f2d19dd
JB		 3503}
3504
3505
2a06f791
KR		 3506/* scm_min and scm_max return an inexact when either argument is inexact, as
3507 required by r5rs. On that basis, for exact/inexact combinations the
3508 exact is converted to inexact to compare and possibly return. This is
3509 unlike scm_less_p above which takes some trouble to preserve all bits in
3510 its test, such trouble is not required for min and max. */
3511
9de33deb 3512SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
942e5b91
MG		 3513/* "Return the maximum of all parameter values."
3514 */
0f2d19dd 3515SCM
6e8d25a6 3516scm_max (SCM x, SCM y)
0f2d19dd 3517{
0aacf84e
MD		 3518 if (SCM_UNBNDP (y))
3519 {
3520 if (SCM_UNBNDP (x))
3521 SCM_WTA_DISPATCH_0 (g_max, s_max);
dab4e67a 3522 else if (SCM_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
0aacf84e
MD		 3523 return x;
3524 else
3525 SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
f872b822 3526 }
f4c627b3 3527
0aacf84e
MD		 3528 if (SCM_INUMP (x))
3529 {
3530 long xx = SCM_INUM (x);
3531 if (SCM_INUMP (y))
3532 {
3533 long yy = SCM_INUM (y);
3534 return (xx < yy) ? y : x;
3535 }
3536 else if (SCM_BIGP (y))
3537 {
3538 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3539 scm_remember_upto_here_1 (y);
3540 return (sgn < 0) ? x : y;
3541 }
3542 else if (SCM_REALP (y))
3543 {
3544 double z = xx;
3545 /* if y==NaN then ">" is false and we return NaN */
3546 return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3547 }
f92e85f7
MV		 3548 else if (SCM_FRACTIONP (y))
3549 {
e4bc5d6c
KR		 3550 use_less:
3551 return (SCM_FALSEP (scm_less_p (x, y)) ? x : y);
f92e85f7 3552 }
0aacf84e
MD		 3553 else
3554 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3555 }
0aacf84e
MD		 3556 else if (SCM_BIGP (x))
3557 {
3558 if (SCM_INUMP (y))
3559 {
3560 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3561 scm_remember_upto_here_1 (x);
3562 return (sgn < 0) ? y : x;
3563 }
3564 else if (SCM_BIGP (y))
3565 {
3566 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3567 scm_remember_upto_here_2 (x, y);
3568 return (cmp > 0) ? x : y;
3569 }
3570 else if (SCM_REALP (y))
3571 {
2a06f791
KR		 3572 /* if y==NaN then xx>yy is false, so we return the NaN y */
3573 double xx, yy;
3574 big_real:
3575 xx = scm_i_big2dbl (x);
3576 yy = SCM_REAL_VALUE (y);
3577 return (xx > yy ? scm_make_real (xx) : y);
0aacf84e 3578 }
f92e85f7
MV		 3579 else if (SCM_FRACTIONP (y))
3580 {
e4bc5d6c 3581 goto use_less;
f92e85f7 3582 }
0aacf84e
MD		 3583 else
3584 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f4c627b3 3585 }
0aacf84e
MD		 3586 else if (SCM_REALP (x))
3587 {
3588 if (SCM_INUMP (y))
3589 {
3590 double z = SCM_INUM (y);
3591 /* if x==NaN then "<" is false and we return NaN */
3592 return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;
3593 }
3594 else if (SCM_BIGP (y))
3595 {
b6f8f763 3596 SCM_SWAP (x, y);
2a06f791 3597 goto big_real;
0aacf84e
MD		 3598 }
3599 else if (SCM_REALP (y))
3600 {
3601 /* if x==NaN then our explicit check means we return NaN
3602 if y==NaN then ">" is false and we return NaN
3603 calling isnan is unavoidable, since it's the only way to know
3604 which of x or y causes any compares to be false */
3605 double xx = SCM_REAL_VALUE (x);
3606 return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
3607 }
f92e85f7
MV		 3608 else if (SCM_FRACTIONP (y))
3609 {
3610 double yy = scm_i_fraction2double (y);
3611 double xx = SCM_REAL_VALUE (x);
3612 return (xx < yy) ? scm_make_real (yy) : x;
3613 }
3614 else
3615 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3616 }
3617 else if (SCM_FRACTIONP (x))
3618 {
3619 if (SCM_INUMP (y))
3620 {
e4bc5d6c 3621 goto use_less;
f92e85f7
MV		 3622 }
3623 else if (SCM_BIGP (y))
3624 {
e4bc5d6c 3625 goto use_less;
f92e85f7
MV		 3626 }
3627 else if (SCM_REALP (y))
3628 {
3629 double xx = scm_i_fraction2double (x);
3630 return (xx < SCM_REAL_VALUE (y)) ? y : scm_make_real (xx);
3631 }
3632 else if (SCM_FRACTIONP (y))
3633 {
e4bc5d6c 3634 goto use_less;
f92e85f7 3635 }
0aacf84e
MD		 3636 else
3637 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3638 }
0aacf84e 3639 else
f4c627b3 3640 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
0f2d19dd
JB		 3641}
3642
3643
9de33deb 3644SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
942e5b91
MG		 3645/* "Return the minium of all parameter values."
3646 */
0f2d19dd 3647SCM
6e8d25a6 3648scm_min (SCM x, SCM y)
0f2d19dd 3649{
0aacf84e
MD		 3650 if (SCM_UNBNDP (y))
3651 {
3652 if (SCM_UNBNDP (x))
3653 SCM_WTA_DISPATCH_0 (g_min, s_min);
dab4e67a 3654 else if (SCM_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
0aacf84e
MD		 3655 return x;
3656 else
3657 SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
f872b822 3658 }
f4c627b3 3659
0aacf84e
MD		 3660 if (SCM_INUMP (x))
3661 {
3662 long xx = SCM_INUM (x);
3663 if (SCM_INUMP (y))
3664 {
3665 long yy = SCM_INUM (y);
3666 return (xx < yy) ? x : y;
3667 }
3668 else if (SCM_BIGP (y))
3669 {
3670 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3671 scm_remember_upto_here_1 (y);
3672 return (sgn < 0) ? y : x;
3673 }
3674 else if (SCM_REALP (y))
3675 {
3676 double z = xx;
3677 /* if y==NaN then "<" is false and we return NaN */
3678 return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3679 }
f92e85f7
MV		 3680 else if (SCM_FRACTIONP (y))
3681 {
e4bc5d6c
KR		 3682 use_less:
3683 return (SCM_FALSEP (scm_less_p (x, y)) ? y : x);
f92e85f7 3684 }
0aacf84e
MD		 3685 else
3686 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3687 }
0aacf84e
MD		 3688 else if (SCM_BIGP (x))
3689 {
3690 if (SCM_INUMP (y))
3691 {
3692 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3693 scm_remember_upto_here_1 (x);
3694 return (sgn < 0) ? x : y;
3695 }
3696 else if (SCM_BIGP (y))
3697 {
3698 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3699 scm_remember_upto_here_2 (x, y);
3700 return (cmp > 0) ? y : x;
3701 }
3702 else if (SCM_REALP (y))
3703 {
2a06f791
KR		 3704 /* if y==NaN then xx<yy is false, so we return the NaN y */
3705 double xx, yy;
3706 big_real:
3707 xx = scm_i_big2dbl (x);
3708 yy = SCM_REAL_VALUE (y);
3709 return (xx < yy ? scm_make_real (xx) : y);
0aacf84e 3710 }
f92e85f7
MV		 3711 else if (SCM_FRACTIONP (y))
3712 {
e4bc5d6c 3713 goto use_less;
f92e85f7 3714 }
0aacf84e
MD		 3715 else
3716 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f4c627b3 3717 }
0aacf84e
MD		 3718 else if (SCM_REALP (x))
3719 {
3720 if (SCM_INUMP (y))
3721 {
3722 double z = SCM_INUM (y);
3723 /* if x==NaN then "<" is false and we return NaN */
3724 return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x;
3725 }
3726 else if (SCM_BIGP (y))
3727 {
b6f8f763 3728 SCM_SWAP (x, y);
2a06f791 3729 goto big_real;
0aacf84e
MD		 3730 }
3731 else if (SCM_REALP (y))
3732 {
3733 /* if x==NaN then our explicit check means we return NaN
3734 if y==NaN then "<" is false and we return NaN
3735 calling isnan is unavoidable, since it's the only way to know
3736 which of x or y causes any compares to be false */
3737 double xx = SCM_REAL_VALUE (x);
3738 return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
3739 }
f92e85f7
MV		 3740 else if (SCM_FRACTIONP (y))
3741 {
3742 double yy = scm_i_fraction2double (y);
3743 double xx = SCM_REAL_VALUE (x);
3744 return (yy < xx) ? scm_make_real (yy) : x;
3745 }
0aacf84e
MD		 3746 else
3747 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3748 }
f92e85f7
MV		 3749 else if (SCM_FRACTIONP (x))
3750 {
3751 if (SCM_INUMP (y))
3752 {
e4bc5d6c 3753 goto use_less;
f92e85f7
MV		 3754 }
3755 else if (SCM_BIGP (y))
3756 {
e4bc5d6c 3757 goto use_less;
f92e85f7
MV		 3758 }
3759 else if (SCM_REALP (y))
3760 {
3761 double xx = scm_i_fraction2double (x);
3762 return (SCM_REAL_VALUE (y) < xx) ? y : scm_make_real (xx);
3763 }
3764 else if (SCM_FRACTIONP (y))
3765 {
e4bc5d6c 3766 goto use_less;
f92e85f7
MV		 3767 }
3768 else
3769 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3770 }
0aacf84e 3771 else
f4c627b3 3772 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
0f2d19dd
JB		 3773}
3774
3775
9de33deb 3776SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
942e5b91
MG		 3777/* "Return the sum of all parameter values. Return 0 if called without\n"
3778 * "any parameters."
3779 */
0f2d19dd 3780SCM
6e8d25a6 3781scm_sum (SCM x, SCM y)
0f2d19dd 3782{
ca46fb90
RB		 3783 if (SCM_UNBNDP (y))
3784 {
3785 if (SCM_NUMBERP (x)) return x;
3786 if (SCM_UNBNDP (x)) return SCM_INUM0;
98cb6e75 3787 SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
f872b822 3788 }
c209c88e 3789
ca46fb90
RB		 3790 if (SCM_INUMP (x))
3791 {
3792 if (SCM_INUMP (y))
3793 {
3794 long xx = SCM_INUM (x);
3795 long yy = SCM_INUM (y);
3796 long int z = xx + yy;
3797 return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z);
3798 }
3799 else if (SCM_BIGP (y))
3800 {
3801 SCM_SWAP (x, y);
3802 goto add_big_inum;
3803 }
3804 else if (SCM_REALP (y))
3805 {
3806 long int xx = SCM_INUM (x);
3807 return scm_make_real (xx + SCM_REAL_VALUE (y));
3808 }
3809 else if (SCM_COMPLEXP (y))
3810 {
3811 long int xx = SCM_INUM (x);
3812 return scm_make_complex (xx + SCM_COMPLEX_REAL (y),
3813 SCM_COMPLEX_IMAG (y));
3814 }
f92e85f7
MV		 3815 else if (SCM_FRACTIONP (y))
3816 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
3817 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
3818 SCM_FRACTION_DENOMINATOR (y));
ca46fb90
RB		 3819 else
3820 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0aacf84e
MD		 3821 } else if (SCM_BIGP (x))
3822 {
3823 if (SCM_INUMP (y))
3824 {
3825 long int inum;
3826 int bigsgn;
3827 add_big_inum:
3828 inum = SCM_INUM (y);
3829 if (inum == 0)
3830 return x;
3831 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3832 if (inum < 0)
3833 {
3834 SCM result = scm_i_mkbig ();
3835 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
3836 scm_remember_upto_here_1 (x);
3837 /* we know the result will have to be a bignum */
3838 if (bigsgn == -1)
3839 return result;
3840 return scm_i_normbig (result);
3841 }
3842 else
3843 {
3844 SCM result = scm_i_mkbig ();
3845 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
3846 scm_remember_upto_here_1 (x);
3847 /* we know the result will have to be a bignum */
3848 if (bigsgn == 1)
3849 return result;
3850 return scm_i_normbig (result);
3851 }
3852 }
3853 else if (SCM_BIGP (y))
3854 {
3855 SCM result = scm_i_mkbig ();
3856 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3857 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3858 mpz_add (SCM_I_BIG_MPZ (result),
3859 SCM_I_BIG_MPZ (x),
3860 SCM_I_BIG_MPZ (y));
3861 scm_remember_upto_here_2 (x, y);
3862 /* we know the result will have to be a bignum */
3863 if (sgn_x == sgn_y)
3864 return result;
3865 return scm_i_normbig (result);
3866 }
3867 else if (SCM_REALP (y))
3868 {
3869 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
3870 scm_remember_upto_here_1 (x);
3871 return scm_make_real (result);
3872 }
3873 else if (SCM_COMPLEXP (y))
3874 {
3875 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3876 + SCM_COMPLEX_REAL (y));
3877 scm_remember_upto_here_1 (x);
3878 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3879 }
f92e85f7
MV		 3880 else if (SCM_FRACTIONP (y))
3881 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
3882 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
3883 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 3884 else
3885 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0f2d19dd 3886 }
0aacf84e
MD		 3887 else if (SCM_REALP (x))
3888 {
3889 if (SCM_INUMP (y))
3890 return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));
3891 else if (SCM_BIGP (y))
3892 {
3893 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
3894 scm_remember_upto_here_1 (y);
3895 return scm_make_real (result);
3896 }
3897 else if (SCM_REALP (y))
3898 return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
3899 else if (SCM_COMPLEXP (y))
3900 return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
3901 SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3902 else if (SCM_FRACTIONP (y))
3903 return scm_make_real (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
0aacf84e
MD		 3904 else
3905 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3906 }
0aacf84e
MD		 3907 else if (SCM_COMPLEXP (x))
3908 {
3909 if (SCM_INUMP (y))
3910 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),
3911 SCM_COMPLEX_IMAG (x));
3912 else if (SCM_BIGP (y))
3913 {
3914 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
3915 + SCM_COMPLEX_REAL (x));
3916 scm_remember_upto_here_1 (y);
3917 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));
3918 }
3919 else if (SCM_REALP (y))
3920 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
3921 SCM_COMPLEX_IMAG (x));
3922 else if (SCM_COMPLEXP (y))
3923 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
3924 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3925 else if (SCM_FRACTIONP (y))
3926 return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
3927 SCM_COMPLEX_IMAG (x));
3928 else
3929 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3930 }
3931 else if (SCM_FRACTIONP (x))
3932 {
3933 if (SCM_INUMP (y))
3934 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
3935 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
3936 SCM_FRACTION_DENOMINATOR (x));
3937 else if (SCM_BIGP (y))
3938 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
3939 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
3940 SCM_FRACTION_DENOMINATOR (x));
3941 else if (SCM_REALP (y))
3942 return scm_make_real (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
3943 else if (SCM_COMPLEXP (y))
3944 return scm_make_complex (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
3945 SCM_COMPLEX_IMAG (y));
3946 else if (SCM_FRACTIONP (y))
3947 /* a/b + c/d = (ad + bc) / bd */
3948 return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
3949 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
3950 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 3951 else
3952 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
98cb6e75 3953 }
0aacf84e 3954 else
98cb6e75 3955 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
0f2d19dd
JB		 3956}
3957
3958
9de33deb 3959SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
609c3d30
MG		 3960/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3961 * the sum of all but the first argument are subtracted from the first
3962 * argument. */
c05e97b7 3963#define FUNC_NAME s_difference
0f2d19dd 3964SCM
6e8d25a6 3965scm_difference (SCM x, SCM y)
0f2d19dd 3966{
ca46fb90
RB		 3967 if (SCM_UNBNDP (y))
3968 {
3969 if (SCM_UNBNDP (x))
3970 SCM_WTA_DISPATCH_0 (g_difference, s_difference);
3971 else
3972 if (SCM_INUMP (x))
3973 {
3974 long xx = -SCM_INUM (x);
3975 if (SCM_FIXABLE (xx))
3976 return SCM_MAKINUM (xx);
3977 else
3978 return scm_i_long2big (xx);
3979 }
3980 else if (SCM_BIGP (x))
3981 /* FIXME: do we really need to normalize here? */
3982 return scm_i_normbig (scm_i_clonebig (x, 0));
3983 else if (SCM_REALP (x))
3984 return scm_make_real (-SCM_REAL_VALUE (x));
3985 else if (SCM_COMPLEXP (x))
3986 return scm_make_complex (-SCM_COMPLEX_REAL (x),
3987 -SCM_COMPLEX_IMAG (x));
f92e85f7
MV		 3988 else if (SCM_FRACTIONP (x))
3989 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
3990 SCM_FRACTION_DENOMINATOR (x));
ca46fb90
RB		 3991 else
3992 SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
f872b822 3993 }
ca46fb90 3994
0aacf84e
MD		 3995 if (SCM_INUMP (x))
3996 {
3997 if (SCM_INUMP (y))
3998 {
3999 long int xx = SCM_INUM (x);
4000 long int yy = SCM_INUM (y);
4001 long int z = xx - yy;
4002 if (SCM_FIXABLE (z))
4003 return SCM_MAKINUM (z);
4004 else
4005 return scm_i_long2big (z);
4006 }
4007 else if (SCM_BIGP (y))
4008 {
4009 /* inum-x - big-y */
4010 long xx = SCM_INUM (x);
ca46fb90 4011
0aacf84e
MD		 4012 if (xx == 0)
4013 return scm_i_clonebig (y, 0);
4014 else
4015 {
4016 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
4017 SCM result = scm_i_mkbig ();
ca46fb90 4018
0aacf84e
MD		 4019 if (xx >= 0)
4020 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
4021 else
4022 {
4023 /* x - y == -(y + -x) */
4024 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
4025 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
4026 }
4027 scm_remember_upto_here_1 (y);
ca46fb90 4028
0aacf84e
MD		 4029 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
4030 /* we know the result will have to be a bignum */
4031 return result;
4032 else
4033 return scm_i_normbig (result);
4034 }
4035 }
4036 else if (SCM_REALP (y))
4037 {
4038 long int xx = SCM_INUM (x);
4039 return scm_make_real (xx - SCM_REAL_VALUE (y));
4040 }
4041 else if (SCM_COMPLEXP (y))
4042 {
4043 long int xx = SCM_INUM (x);
4044 return scm_make_complex (xx - SCM_COMPLEX_REAL (y),
4045 - SCM_COMPLEX_IMAG (y));
4046 }
f92e85f7
MV		 4047 else if (SCM_FRACTIONP (y))
4048 /* a - b/c = (ac - b) / c */
4049 return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4050 SCM_FRACTION_NUMERATOR (y)),
4051 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4052 else
4053 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 4054 }
0aacf84e
MD		 4055 else if (SCM_BIGP (x))
4056 {
4057 if (SCM_INUMP (y))
4058 {
4059 /* big-x - inum-y */
4060 long yy = SCM_INUM (y);
4061 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
ca46fb90 4062
0aacf84e
MD		 4063 scm_remember_upto_here_1 (x);
4064 if (sgn_x == 0)
4065 return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);
4066 else
4067 {
4068 SCM result = scm_i_mkbig ();
ca46fb90 4069
708f22c6
KR		 4070 if (yy >= 0)
4071 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
4072 else
4073 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
0aacf84e 4074 scm_remember_upto_here_1 (x);
ca46fb90 4075
0aacf84e
MD		 4076 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
4077 /* we know the result will have to be a bignum */
4078 return result;
4079 else
4080 return scm_i_normbig (result);
4081 }
4082 }
4083 else if (SCM_BIGP (y))
4084 {
4085 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
4086 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
4087 SCM result = scm_i_mkbig ();
4088 mpz_sub (SCM_I_BIG_MPZ (result),
4089 SCM_I_BIG_MPZ (x),
4090 SCM_I_BIG_MPZ (y));
4091 scm_remember_upto_here_2 (x, y);
4092 /* we know the result will have to be a bignum */
4093 if ((sgn_x == 1) && (sgn_y == -1))
4094 return result;
4095 if ((sgn_x == -1) && (sgn_y == 1))
4096 return result;
4097 return scm_i_normbig (result);
4098 }
4099 else if (SCM_REALP (y))
4100 {
4101 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
4102 scm_remember_upto_here_1 (x);
4103 return scm_make_real (result);
4104 }
4105 else if (SCM_COMPLEXP (y))
4106 {
4107 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
4108 - SCM_COMPLEX_REAL (y));
4109 scm_remember_upto_here_1 (x);
4110 return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));
4111 }
f92e85f7
MV		 4112 else if (SCM_FRACTIONP (y))
4113 return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4114 SCM_FRACTION_NUMERATOR (y)),
4115 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 4116 else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
ca46fb90 4117 }
0aacf84e
MD		 4118 else if (SCM_REALP (x))
4119 {
4120 if (SCM_INUMP (y))
4121 return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));
4122 else if (SCM_BIGP (y))
4123 {
4124 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
4125 scm_remember_upto_here_1 (x);
4126 return scm_make_real (result);
4127 }
4128 else if (SCM_REALP (y))
4129 return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
4130 else if (SCM_COMPLEXP (y))
4131 return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
4132 -SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4133 else if (SCM_FRACTIONP (y))
4134 return scm_make_real (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
0aacf84e
MD		 4135 else
4136 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 4137 }
0aacf84e
MD		 4138 else if (SCM_COMPLEXP (x))
4139 {
4140 if (SCM_INUMP (y))
4141 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),
4142 SCM_COMPLEX_IMAG (x));
4143 else if (SCM_BIGP (y))
4144 {
4145 double real_part = (SCM_COMPLEX_REAL (x)
4146 - mpz_get_d (SCM_I_BIG_MPZ (y)));
4147 scm_remember_upto_here_1 (x);
4148 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
4149 }
4150 else if (SCM_REALP (y))
4151 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
4152 SCM_COMPLEX_IMAG (x));
4153 else if (SCM_COMPLEXP (y))
4154 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
4155 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4156 else if (SCM_FRACTIONP (y))
4157 return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
4158 SCM_COMPLEX_IMAG (x));
4159 else
4160 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
4161 }
4162 else if (SCM_FRACTIONP (x))
4163 {
4164 if (SCM_INUMP (y))
4165 /* a/b - c = (a - cb) / b */
4166 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
4167 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
4168 SCM_FRACTION_DENOMINATOR (x));
4169 else if (SCM_BIGP (y))
4170 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
4171 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
4172 SCM_FRACTION_DENOMINATOR (x));
4173 else if (SCM_REALP (y))
4174 return scm_make_real (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
4175 else if (SCM_COMPLEXP (y))
4176 return scm_make_complex (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
4177 -SCM_COMPLEX_IMAG (y));
4178 else if (SCM_FRACTIONP (y))
4179 /* a/b - c/d = (ad - bc) / bd */
4180 return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
4181 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
4182 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 4183 else
4184 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 4185 }
0aacf84e 4186 else
98cb6e75 4187 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
0f2d19dd 4188}
c05e97b7 4189#undef FUNC_NAME
0f2d19dd 4190
ca46fb90 4191
9de33deb 4192SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
942e5b91
MG		 4193/* "Return the product of all arguments. If called without arguments,\n"
4194 * "1 is returned."
4195 */
0f2d19dd 4196SCM
6e8d25a6 4197scm_product (SCM x, SCM y)
0f2d19dd 4198{
0aacf84e
MD		 4199 if (SCM_UNBNDP (y))
4200 {
4201 if (SCM_UNBNDP (x))
4202 return SCM_MAKINUM (1L);
4203 else if (SCM_NUMBERP (x))
4204 return x;
4205 else
4206 SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
f872b822 4207 }
ca46fb90 4208
0aacf84e
MD		 4209 if (SCM_INUMP (x))
4210 {
4211 long xx;
f4c627b3 4212
0aacf84e
MD		 4213 intbig:
4214 xx = SCM_INUM (x);
f4c627b3 4215
0aacf84e
MD		 4216 switch (xx)
4217 {
ca46fb90
RB		 4218 case 0: return x; break;
4219 case 1: return y; break;
0aacf84e 4220 }
f4c627b3 4221
0aacf84e
MD		 4222 if (SCM_INUMP (y))
4223 {
4224 long yy = SCM_INUM (y);
4225 long kk = xx * yy;
4226 SCM k = SCM_MAKINUM (kk);
4227 if ((kk == SCM_INUM (k)) && (kk / xx == yy))
4228 return k;
4229 else
4230 {
4231 SCM result = scm_i_long2big (xx);
4232 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
4233 return scm_i_normbig (result);
4234 }
4235 }
4236 else if (SCM_BIGP (y))
4237 {
4238 SCM result = scm_i_mkbig ();
4239 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
4240 scm_remember_upto_here_1 (y);
4241 return result;
4242 }
4243 else if (SCM_REALP (y))
4244 return scm_make_real (xx * SCM_REAL_VALUE (y));
4245 else if (SCM_COMPLEXP (y))
4246 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
4247 xx * SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4248 else if (SCM_FRACTIONP (y))
4249 return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
4250 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4251 else
4252 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4253 }
0aacf84e
MD		 4254 else if (SCM_BIGP (x))
4255 {
4256 if (SCM_INUMP (y))
4257 {
4258 SCM_SWAP (x, y);
4259 goto intbig;
4260 }
4261 else if (SCM_BIGP (y))
4262 {
4263 SCM result = scm_i_mkbig ();
4264 mpz_mul (SCM_I_BIG_MPZ (result),
4265 SCM_I_BIG_MPZ (x),
4266 SCM_I_BIG_MPZ (y));
4267 scm_remember_upto_here_2 (x, y);
4268 return result;
4269 }
4270 else if (SCM_REALP (y))
4271 {
4272 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
4273 scm_remember_upto_here_1 (x);
4274 return scm_make_real (result);
4275 }
4276 else if (SCM_COMPLEXP (y))
4277 {
4278 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
4279 scm_remember_upto_here_1 (x);
4280 return scm_make_complex (z * SCM_COMPLEX_REAL (y),
4281 z * SCM_COMPLEX_IMAG (y));
4282 }
f92e85f7
MV		 4283 else if (SCM_FRACTIONP (y))
4284 return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
4285 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4286 else
4287 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4288 }
0aacf84e
MD		 4289 else if (SCM_REALP (x))
4290 {
4291 if (SCM_INUMP (y))
4292 return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));
4293 else if (SCM_BIGP (y))
4294 {
4295 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
4296 scm_remember_upto_here_1 (y);
4297 return scm_make_real (result);
4298 }
4299 else if (SCM_REALP (y))
4300 return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
4301 else if (SCM_COMPLEXP (y))
4302 return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
4303 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4304 else if (SCM_FRACTIONP (y))
4305 return scm_make_real (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
0aacf84e
MD		 4306 else
4307 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4308 }
0aacf84e
MD		 4309 else if (SCM_COMPLEXP (x))
4310 {
4311 if (SCM_INUMP (y))
4312 return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),
4313 SCM_INUM (y) * SCM_COMPLEX_IMAG (x));
4314 else if (SCM_BIGP (y))
4315 {
4316 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
4317 scm_remember_upto_here_1 (y);
76506335
KR		 4318 return scm_make_complex (z * SCM_COMPLEX_REAL (x),
4319 z * SCM_COMPLEX_IMAG (x));
0aacf84e
MD		 4320 }
4321 else if (SCM_REALP (y))
4322 return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
4323 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
4324 else if (SCM_COMPLEXP (y))
4325 {
4326 return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
4327 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
4328 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
4329 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
4330 }
f92e85f7
MV		 4331 else if (SCM_FRACTIONP (y))
4332 {
4333 double yy = scm_i_fraction2double (y);
4334 return scm_make_complex (yy * SCM_COMPLEX_REAL (x),
4335 yy * SCM_COMPLEX_IMAG (x));
4336 }
4337 else
4338 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
4339 }
4340 else if (SCM_FRACTIONP (x))
4341 {
4342 if (SCM_INUMP (y))
4343 return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
4344 SCM_FRACTION_DENOMINATOR (x));
4345 else if (SCM_BIGP (y))
4346 return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
4347 SCM_FRACTION_DENOMINATOR (x));
4348 else if (SCM_REALP (y))
4349 return scm_make_real (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
4350 else if (SCM_COMPLEXP (y))
4351 {
4352 double xx = scm_i_fraction2double (x);
4353 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
4354 xx * SCM_COMPLEX_IMAG (y));
4355 }
4356 else if (SCM_FRACTIONP (y))
4357 /* a/b * c/d = ac / bd */
4358 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
4359 SCM_FRACTION_NUMERATOR (y)),
4360 scm_product (SCM_FRACTION_DENOMINATOR (x),
4361 SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 4362 else
4363 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4364 }
0aacf84e 4365 else
f4c627b3 4366 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
0f2d19dd
JB		 4367}
4368
0f2d19dd 4369double
6e8d25a6 4370scm_num2dbl (SCM a, const char *why)
f4c627b3 4371#define FUNC_NAME why
0f2d19dd 4372{
0aacf84e 4373 if (SCM_INUMP (a))
0f2d19dd 4374 return (double) SCM_INUM (a);
0aacf84e
MD		 4375 else if (SCM_BIGP (a))
4376 {
4377 double result = mpz_get_d (SCM_I_BIG_MPZ (a));
4378 scm_remember_upto_here_1 (a);
4379 return result;
4380 }
4381 else if (SCM_REALP (a))
f4c627b3 4382 return (SCM_REAL_VALUE (a));
f92e85f7
MV		 4383 else if (SCM_FRACTIONP (a))
4384 return scm_i_fraction2double (a);
0aacf84e 4385 else
f4c627b3 4386 SCM_WRONG_TYPE_ARG (SCM_ARGn, a);
0f2d19dd 4387}
f4c627b3 4388#undef FUNC_NAME
0f2d19dd 4389
7351e207
MV		 4390#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
4391 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
4392#define ALLOW_DIVIDE_BY_ZERO
4393/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
4394#endif
0f2d19dd 4395
ba74ef4e
MV		 4396/* The code below for complex division is adapted from the GNU
4397 libstdc++, which adapted it from f2c's libF77, and is subject to
4398 this copyright: */
4399
4400/****************************************************************
4401Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
4402
4403Permission to use, copy, modify, and distribute this software
4404and its documentation for any purpose and without fee is hereby
4405granted, provided that the above copyright notice appear in all
4406copies and that both that the copyright notice and this
4407permission notice and warranty disclaimer appear in supporting
4408documentation, and that the names of AT&T Bell Laboratories or
4409Bellcore or any of their entities not be used in advertising or
4410publicity pertaining to distribution of the software without
4411specific, written prior permission.
4412
4413AT&T and Bellcore disclaim all warranties with regard to this
4414software, including all implied warranties of merchantability
4415and fitness. In no event shall AT&T or Bellcore be liable for
4416any special, indirect or consequential damages or any damages
4417whatsoever resulting from loss of use, data or profits, whether
4418in an action of contract, negligence or other tortious action,
4419arising out of or in connection with the use or performance of
4420this software.
4421****************************************************************/
4422
9de33deb 4423SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
609c3d30
MG		 4424/* Divide the first argument by the product of the remaining
4425 arguments. If called with one argument @var{z1}, 1/@var{z1} is
4426 returned. */
c05e97b7 4427#define FUNC_NAME s_divide
f92e85f7
MV		 4428static SCM
4429scm_i_divide (SCM x, SCM y, int inexact)
0f2d19dd 4430{
f8de44c1
DH		 4431 double a;
4432
0aacf84e
MD		 4433 if (SCM_UNBNDP (y))
4434 {
4435 if (SCM_UNBNDP (x))
4436 SCM_WTA_DISPATCH_0 (g_divide, s_divide);
4437 else if (SCM_INUMP (x))
4438 {
4439 long xx = SCM_INUM (x);
4440 if (xx == 1 || xx == -1)
4441 return x;
7351e207 4442#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4443 else if (xx == 0)
4444 scm_num_overflow (s_divide);
7351e207 4445#endif
0aacf84e 4446 else
f92e85f7
MV		 4447 {
4448 if (inexact)
4449 return scm_make_real (1.0 / (double) xx);
4450 else return scm_make_ratio (SCM_MAKINUM(1), x);
4451 }
0aacf84e
MD		 4452 }
4453 else if (SCM_BIGP (x))
f92e85f7
MV		 4454 {
4455 if (inexact)
4456 return scm_make_real (1.0 / scm_i_big2dbl (x));
4457 else return scm_make_ratio (SCM_MAKINUM(1), x);
4458 }
0aacf84e
MD		 4459 else if (SCM_REALP (x))
4460 {
4461 double xx = SCM_REAL_VALUE (x);
7351e207 4462#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4463 if (xx == 0.0)
4464 scm_num_overflow (s_divide);
4465 else
7351e207 4466#endif
0aacf84e
MD		 4467 return scm_make_real (1.0 / xx);
4468 }
4469 else if (SCM_COMPLEXP (x))
4470 {
4471 double r = SCM_COMPLEX_REAL (x);
4472 double i = SCM_COMPLEX_IMAG (x);
4473 if (r <= i)
4474 {
4475 double t = r / i;
4476 double d = i * (1.0 + t * t);
4477 return scm_make_complex (t / d, -1.0 / d);
4478 }
4479 else
4480 {
4481 double t = i / r;
4482 double d = r * (1.0 + t * t);
4483 return scm_make_complex (1.0 / d, -t / d);
4484 }
4485 }
f92e85f7
MV		 4486 else if (SCM_FRACTIONP (x))
4487 return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x),
4488 SCM_FRACTION_NUMERATOR (x));
0aacf84e
MD		 4489 else
4490 SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
f8de44c1 4491 }
f8de44c1 4492
0aacf84e
MD		 4493 if (SCM_INUMP (x))
4494 {
4495 long xx = SCM_INUM (x);
4496 if (SCM_INUMP (y))
4497 {
4498 long yy = SCM_INUM (y);
4499 if (yy == 0)
4500 {
7351e207 4501#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4502 scm_num_overflow (s_divide);
7351e207 4503#else
0aacf84e 4504 return scm_make_real ((double) xx / (double) yy);
7351e207 4505#endif
0aacf84e
MD		 4506 }
4507 else if (xx % yy != 0)
f92e85f7
MV		 4508 {
4509 if (inexact)
4510 return scm_make_real ((double) xx / (double) yy);
4511 else return scm_make_ratio (x, y);
4512 }
0aacf84e
MD		 4513 else
4514 {
4515 long z = xx / yy;
4516 if (SCM_FIXABLE (z))
4517 return SCM_MAKINUM (z);
4518 else
4519 return scm_i_long2big (z);
4520 }
f872b822 4521 }
0aacf84e 4522 else if (SCM_BIGP (y))
f92e85f7
MV		 4523 {
4524 if (inexact)
4525 return scm_make_real ((double) xx / scm_i_big2dbl (y));
4526 else return scm_make_ratio (x, y);
4527 }
0aacf84e
MD		 4528 else if (SCM_REALP (y))
4529 {
4530 double yy = SCM_REAL_VALUE (y);
7351e207 4531#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4532 if (yy == 0.0)
4533 scm_num_overflow (s_divide);
4534 else
7351e207 4535#endif
0aacf84e 4536 return scm_make_real ((double) xx / yy);
ba74ef4e 4537 }
0aacf84e
MD		 4538 else if (SCM_COMPLEXP (y))
4539 {
4540 a = xx;
4541 complex_div: /* y _must_ be a complex number */
4542 {
4543 double r = SCM_COMPLEX_REAL (y);
4544 double i = SCM_COMPLEX_IMAG (y);
4545 if (r <= i)
4546 {
4547 double t = r / i;
4548 double d = i * (1.0 + t * t);
4549 return scm_make_complex ((a * t) / d, -a / d);
4550 }
4551 else
4552 {
4553 double t = i / r;
4554 double d = r * (1.0 + t * t);
4555 return scm_make_complex (a / d, -(a * t) / d);
4556 }
4557 }
4558 }
f92e85f7
MV		 4559 else if (SCM_FRACTIONP (y))
4560 /* a / b/c = ac / b */
4561 return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4562 SCM_FRACTION_NUMERATOR (y));
0aacf84e
MD		 4563 else
4564 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 4565 }
0aacf84e
MD		 4566 else if (SCM_BIGP (x))
4567 {
4568 if (SCM_INUMP (y))
4569 {
4570 long int yy = SCM_INUM (y);
4571 if (yy == 0)
4572 {
7351e207 4573#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4574 scm_num_overflow (s_divide);
7351e207 4575#else
0aacf84e
MD		 4576 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
4577 scm_remember_upto_here_1 (x);
4578 return (sgn == 0) ? scm_nan () : scm_inf ();
7351e207 4579#endif
0aacf84e
MD		 4580 }
4581 else if (yy == 1)
4582 return x;
4583 else
4584 {
4585 /* FIXME: HMM, what are the relative performance issues here?
4586 We need to test. Is it faster on average to test
4587 divisible_p, then perform whichever operation, or is it
4588 faster to perform the integer div opportunistically and
4589 switch to real if there's a remainder? For now we take the
4590 middle ground: test, then if divisible, use the faster div
4591 func. */
4592
4593 long abs_yy = yy < 0 ? -yy : yy;
4594 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
4595
4596 if (divisible_p)
4597 {
4598 SCM result = scm_i_mkbig ();
4599 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
4600 scm_remember_upto_here_1 (x);
4601 if (yy < 0)
4602 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
4603 return scm_i_normbig (result);
4604 }
4605 else
f92e85f7
MV		 4606 {
4607 if (inexact)
4608 return scm_make_real (scm_i_big2dbl (x) / (double) yy);
4609 else return scm_make_ratio (x, y);
4610 }
0aacf84e
MD		 4611 }
4612 }
4613 else if (SCM_BIGP (y))
4614 {
4615 int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
4616 if (y_is_zero)
4617 {
ca46fb90 4618#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4619 scm_num_overflow (s_divide);
f872b822 4620#else
0aacf84e
MD		 4621 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
4622 scm_remember_upto_here_1 (x);
4623 return (sgn == 0) ? scm_nan () : scm_inf ();
f872b822 4624#endif
0aacf84e
MD		 4625 }
4626 else
4627 {
4628 /* big_x / big_y */
4629 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
4630 SCM_I_BIG_MPZ (y));
4631 if (divisible_p)
4632 {
4633 SCM result = scm_i_mkbig ();
4634 mpz_divexact (SCM_I_BIG_MPZ (result),
4635 SCM_I_BIG_MPZ (x),
4636 SCM_I_BIG_MPZ (y));
4637 scm_remember_upto_here_2 (x, y);
4638 return scm_i_normbig (result);
4639 }
4640 else
4641 {
f92e85f7
MV		 4642 if (inexact)
4643 {
4644 double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));
4645 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4646 scm_remember_upto_here_2 (x, y);
4647 return scm_make_real (dbx / dby);
4648 }
4649 else return scm_make_ratio (x, y);
0aacf84e
MD		 4650 }
4651 }
4652 }
4653 else if (SCM_REALP (y))
4654 {
4655 double yy = SCM_REAL_VALUE (y);
7351e207 4656#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4657 if (yy == 0.0)
4658 scm_num_overflow (s_divide);
4659 else
7351e207 4660#endif
0aacf84e
MD		 4661 return scm_make_real (scm_i_big2dbl (x) / yy);
4662 }
4663 else if (SCM_COMPLEXP (y))
4664 {
4665 a = scm_i_big2dbl (x);
4666 goto complex_div;
4667 }
f92e85f7
MV		 4668 else if (SCM_FRACTIONP (y))
4669 return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4670 SCM_FRACTION_NUMERATOR (y));
0aacf84e
MD		 4671 else
4672 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 4673 }
0aacf84e
MD		 4674 else if (SCM_REALP (x))
4675 {
4676 double rx = SCM_REAL_VALUE (x);
4677 if (SCM_INUMP (y))
4678 {
4679 long int yy = SCM_INUM (y);
7351e207 4680#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4681 if (yy == 0)
4682 scm_num_overflow (s_divide);
4683 else
7351e207 4684#endif
0aacf84e
MD		 4685 return scm_make_real (rx / (double) yy);
4686 }
4687 else if (SCM_BIGP (y))
4688 {
4689 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4690 scm_remember_upto_here_1 (y);
4691 return scm_make_real (rx / dby);
4692 }
4693 else if (SCM_REALP (y))
4694 {
4695 double yy = SCM_REAL_VALUE (y);
7351e207 4696#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4697 if (yy == 0.0)
4698 scm_num_overflow (s_divide);
4699 else
7351e207 4700#endif
0aacf84e
MD		 4701 return scm_make_real (rx / yy);
4702 }
4703 else if (SCM_COMPLEXP (y))
4704 {
4705 a = rx;
4706 goto complex_div;
4707 }
f92e85f7
MV		 4708 else if (SCM_FRACTIONP (y))
4709 return scm_make_real (rx / scm_i_fraction2double (y));
0aacf84e
MD		 4710 else
4711 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 4712 }
0aacf84e
MD		 4713 else if (SCM_COMPLEXP (x))
4714 {
4715 double rx = SCM_COMPLEX_REAL (x);
4716 double ix = SCM_COMPLEX_IMAG (x);
4717 if (SCM_INUMP (y))
4718 {
4719 long int yy = SCM_INUM (y);
7351e207 4720#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4721 if (yy == 0)
4722 scm_num_overflow (s_divide);
4723 else
7351e207 4724#endif
0aacf84e
MD		 4725 {
4726 double d = yy;
4727 return scm_make_complex (rx / d, ix / d);
4728 }
4729 }
4730 else if (SCM_BIGP (y))
4731 {
4732 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4733 scm_remember_upto_here_1 (y);
4734 return scm_make_complex (rx / dby, ix / dby);
4735 }
4736 else if (SCM_REALP (y))
4737 {
4738 double yy = SCM_REAL_VALUE (y);
7351e207 4739#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4740 if (yy == 0.0)
4741 scm_num_overflow (s_divide);
4742 else
7351e207 4743#endif
0aacf84e
MD		 4744 return scm_make_complex (rx / yy, ix / yy);
4745 }
4746 else if (SCM_COMPLEXP (y))
4747 {
4748 double ry = SCM_COMPLEX_REAL (y);
4749 double iy = SCM_COMPLEX_IMAG (y);
4750 if (ry <= iy)
4751 {
4752 double t = ry / iy;
4753 double d = iy * (1.0 + t * t);
4754 return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);
4755 }
4756 else
4757 {
4758 double t = iy / ry;
4759 double d = ry * (1.0 + t * t);
4760 return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);
4761 }
4762 }
f92e85f7
MV		 4763 else if (SCM_FRACTIONP (y))
4764 {
4765 double yy = scm_i_fraction2double (y);
4766 return scm_make_complex (rx / yy, ix / yy);
4767 }
0aacf84e
MD		 4768 else
4769 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 4770 }
f92e85f7
MV		 4771 else if (SCM_FRACTIONP (x))
4772 {
4773 if (SCM_INUMP (y))
4774 {
4775 long int yy = SCM_INUM (y);
4776#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4777 if (yy == 0)
4778 scm_num_overflow (s_divide);
4779 else
4780#endif
4781 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x),
4782 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
4783 }
4784 else if (SCM_BIGP (y))
4785 {
4786 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x),
4787 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
4788 }
4789 else if (SCM_REALP (y))
4790 {
4791 double yy = SCM_REAL_VALUE (y);
4792#ifndef ALLOW_DIVIDE_BY_ZERO
4793 if (yy == 0.0)
4794 scm_num_overflow (s_divide);
4795 else
4796#endif
4797 return scm_make_real (scm_i_fraction2double (x) / yy);
4798 }
4799 else if (SCM_COMPLEXP (y))
4800 {
4801 a = scm_i_fraction2double (x);
4802 goto complex_div;
4803 }
4804 else if (SCM_FRACTIONP (y))
4805 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
4806 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
4807 else
4808 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
4809 }
0aacf84e 4810 else
f8de44c1 4811 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
0f2d19dd 4812}
f92e85f7
MV		 4813
4814SCM
4815scm_divide (SCM x, SCM y)
4816{
4817 return scm_i_divide (x, y, 0);
4818}
4819
4820static SCM scm_divide2real (SCM x, SCM y)
4821{
4822 return scm_i_divide (x, y, 1);
4823}
c05e97b7 4824#undef FUNC_NAME
0f2d19dd 4825
fa605590 4826
0f2d19dd 4827double
6e8d25a6 4828scm_asinh (double x)
0f2d19dd 4829{
fa605590
KR		 4830#if HAVE_ASINH
4831 return asinh (x);
4832#else
4833#define asinh scm_asinh
f872b822 4834 return log (x + sqrt (x * x + 1));
fa605590 4835#endif
0f2d19dd 4836}
fa605590
KR		 4837SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
4838/* "Return the inverse hyperbolic sine of @var{x}."
4839 */
0f2d19dd
JB		 4840
4841
0f2d19dd 4842double
6e8d25a6 4843scm_acosh (double x)
0f2d19dd 4844{
fa605590
KR		 4845#if HAVE_ACOSH
4846 return acosh (x);
4847#else
4848#define acosh scm_acosh
f872b822 4849 return log (x + sqrt (x * x - 1));
fa605590 4850#endif
0f2d19dd 4851}
fa605590
KR		 4852SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
4853/* "Return the inverse hyperbolic cosine of @var{x}."
4854 */
0f2d19dd
JB		 4855
4856
0f2d19dd 4857double
6e8d25a6 4858scm_atanh (double x)
0f2d19dd 4859{
fa605590
KR		 4860#if HAVE_ATANH
4861 return atanh (x);
4862#else
4863#define atanh scm_atanh
f872b822 4864 return 0.5 * log ((1 + x) / (1 - x));
fa605590 4865#endif
0f2d19dd 4866}
fa605590
KR		 4867SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
4868/* "Return the inverse hyperbolic tangent of @var{x}."
4869 */
0f2d19dd
JB		 4870
4871
f92e85f7
MV		 4872/* XXX - eventually, we should remove this definition of scm_round and
4873 rename scm_round_number to scm_round. Likewise for scm_truncate
4874 and scm_truncate_number.
4875 */
4876
0f2d19dd 4877double
6e8d25a6 4878scm_truncate (double x)
0f2d19dd 4879{
fa605590
KR		 4880#if HAVE_TRUNC
4881 return trunc (x);
4882#else
4883#define trunc scm_truncate
f872b822
MD		 4884 if (x < 0.0)
4885 return -floor (-x);
4886 return floor (x);
fa605590 4887#endif
0f2d19dd 4888}
0f2d19dd 4889
6187f48b
KR		 4890/* scm_round is done using floor(x+0.5) to round to nearest and with
4891 half-way case (ie. when x is an integer plus 0.5) going upwards. Then
4892 half-way cases are identified and adjusted down if the round-upwards
4893 didn't give the desired even integer.
4894
4895 "plus_half == result" identifies a half-way case. If plus_half, which is
4896 x + 0.5, is an integer then x must be an integer plus 0.5.
4897
4898 An odd "result" value is identified with result/2 != floor(result/2).
4899 This is done with plus_half, since that value is ready for use sooner in
4900 a pipelined cpu, and we're already requiring plus_half == result.
4901
4902 Note however that we need to be careful when x is big and already an
4903 integer. In that case "x+0.5" may round to an adjacent integer, causing
4904 us to return such a value, incorrectly. For instance if the hardware is
4905 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
4906 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
4907 returned. Or if the hardware is in round-upwards mode, then other bigger
4908 values like say x == 2^128 will see x+0.5 rounding up to the next higher
4909 representable value, 2^128+2^76 (or whatever), again incorrect.
4910
4911 These bad roundings of x+0.5 are avoided by testing at the start whether
4912 x is already an integer. If it is then clearly that's the desired result
4913 already. And if it's not then the exponent must be small enough to allow
4914 an 0.5 to be represented, and hence added without a bad rounding. */
4915
0f2d19dd 4916double
6e8d25a6 4917scm_round (double x)
0f2d19dd 4918{
6187f48b
KR		 4919 double plus_half, result;
4920
4921 if (x == floor (x))
4922 return x;
4923
4924 plus_half = x + 0.5;
4925 result = floor (plus_half);
0f2d19dd 4926 /* Adjust so that the scm_round is towards even. */
0aacf84e
MD		 4927 return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
4928 ? result - 1
4929 : result);
0f2d19dd
JB		 4930}
4931
f92e85f7
MV		 4932SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0,
4933 (SCM x),
4934 "Round the number @var{x} towards zero.")
4935#define FUNC_NAME s_scm_truncate_number
4936{
4937 if (SCM_FALSEP (scm_negative_p (x)))
4938 return scm_floor (x);
4939 else
4940 return scm_ceiling (x);
4941}
4942#undef FUNC_NAME
4943
4944static SCM exactly_one_half;
4945
4946SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
4947 (SCM x),
4948 "Round the number @var{x} towards the nearest integer. "
4949 "When it is exactly halfway between two integers, "
4950 "round towards the even one.")
4951#define FUNC_NAME s_scm_round_number
4952{
4953 SCM plus_half = scm_sum (x, exactly_one_half);
4954 SCM result = scm_floor (plus_half);
4955 /* Adjust so that the scm_round is towards even. */
4956 if (!SCM_FALSEP (scm_num_eq_p (plus_half, result))
4957 && !SCM_FALSEP (scm_odd_p (result)))
4958 return scm_difference (result, SCM_MAKINUM (1));
4959 else
4960 return result;
4961}
4962#undef FUNC_NAME
4963
4964SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
4965 (SCM x),
4966 "Round the number @var{x} towards minus infinity.")
4967#define FUNC_NAME s_scm_floor
4968{
4969 if (SCM_INUMP (x) || SCM_BIGP (x))
4970 return x;
4971 else if (SCM_REALP (x))
4972 return scm_make_real (floor (SCM_REAL_VALUE (x)));
4973 else if (SCM_FRACTIONP (x))
4974 {
4975 SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
4976 SCM_FRACTION_DENOMINATOR (x));
4977 if (SCM_FALSEP (scm_negative_p (x)))
4978 {
4979 /* For positive x, rounding towards zero is correct. */
4980 return q;
4981 }
4982 else
4983 {
4984 /* For negative x, we need to return q-1 unless x is an
4985 integer. But fractions are never integer, per our
4986 assumptions. */
4987 return scm_difference (q, SCM_MAKINUM (1));
4988 }
4989 }
4990 else
4991 SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
4992}
4993#undef FUNC_NAME
4994
4995SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
4996 (SCM x),
4997 "Round the number @var{x} towards infinity.")
4998#define FUNC_NAME s_scm_ceiling
4999{
5000 if (SCM_INUMP (x) || SCM_BIGP (x))
5001 return x;
5002 else if (SCM_REALP (x))
5003 return scm_make_real (ceil (SCM_REAL_VALUE (x)));
5004 else if (SCM_FRACTIONP (x))
5005 {
5006 SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
5007 SCM_FRACTION_DENOMINATOR (x));
5008 if (SCM_FALSEP (scm_positive_p (x)))
5009 {
5010 /* For negative x, rounding towards zero is correct. */
5011 return q;
5012 }
5013 else
5014 {
5015 /* For positive x, we need to return q+1 unless x is an
5016 integer. But fractions are never integer, per our
5017 assumptions. */
5018 return scm_sum (q, SCM_MAKINUM (1));
5019 }
5020 }
5021 else
5022 SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
5023}
5024#undef FUNC_NAME
0f2d19dd 5025
14b18ed6 5026SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
942e5b91
MG		 5027/* "Return the square root of the real number @var{x}."
5028 */
14b18ed6 5029SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
942e5b91
MG		 5030/* "Return the absolute value of the real number @var{x}."
5031 */
14b18ed6 5032SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
942e5b91
MG		 5033/* "Return the @var{x}th power of e."
5034 */
14b18ed6 5035SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
b3fcac34 5036/* "Return the natural logarithm of the real number @var{x}."
942e5b91 5037 */
14b18ed6 5038SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
942e5b91
MG		 5039/* "Return the sine of the real number @var{x}."
5040 */
14b18ed6 5041SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
942e5b91
MG		 5042/* "Return the cosine of the real number @var{x}."
5043 */
14b18ed6 5044SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
942e5b91
MG		 5045/* "Return the tangent of the real number @var{x}."
5046 */
14b18ed6 5047SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
942e5b91
MG		 5048/* "Return the arc sine of the real number @var{x}."
5049 */
14b18ed6 5050SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
942e5b91
MG		 5051/* "Return the arc cosine of the real number @var{x}."
5052 */
14b18ed6 5053SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
942e5b91
MG		 5054/* "Return the arc tangent of the real number @var{x}."
5055 */
14b18ed6 5056SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
942e5b91
MG		 5057/* "Return the hyperbolic sine of the real number @var{x}."
5058 */
14b18ed6 5059SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
942e5b91
MG		 5060/* "Return the hyperbolic cosine of the real number @var{x}."
5061 */
14b18ed6 5062SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
942e5b91
MG		 5063/* "Return the hyperbolic tangent of the real number @var{x}."
5064 */
f872b822
MD		 5065
5066struct dpair
5067{
5068 double x, y;
5069};
5070
27c37006
NJ		 5071static void scm_two_doubles (SCM x,
5072 SCM y,
3eeba8d4
JB		 5073 const char *sstring,
5074 struct dpair * xy);
f872b822
MD		 5075
5076static void
27c37006
NJ		 5077scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
5078{
0aacf84e 5079 if (SCM_INUMP (x))
27c37006 5080 xy->x = SCM_INUM (x);
0aacf84e 5081 else if (SCM_BIGP (x))
1be6b49c 5082 xy->x = scm_i_big2dbl (x);
0aacf84e 5083 else if (SCM_REALP (x))
27c37006 5084 xy->x = SCM_REAL_VALUE (x);
f92e85f7
MV		 5085 else if (SCM_FRACTIONP (x))
5086 xy->x = scm_i_fraction2double (x);
0aacf84e 5087 else
27c37006 5088 scm_wrong_type_arg (sstring, SCM_ARG1, x);
98cb6e75 5089
0aacf84e 5090 if (SCM_INUMP (y))
27c37006 5091 xy->y = SCM_INUM (y);
0aacf84e 5092 else if (SCM_BIGP (y))
1be6b49c 5093 xy->y = scm_i_big2dbl (y);
0aacf84e 5094 else if (SCM_REALP (y))
27c37006 5095 xy->y = SCM_REAL_VALUE (y);
f92e85f7
MV		 5096 else if (SCM_FRACTIONP (y))
5097 xy->y = scm_i_fraction2double (y);
0aacf84e 5098 else
27c37006 5099 scm_wrong_type_arg (sstring, SCM_ARG2, y);
0f2d19dd
JB		 5100}
5101
5102
a1ec6916 5103SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
27c37006
NJ		 5104 (SCM x, SCM y),
5105 "Return @var{x} raised to the power of @var{y}. This\n"
0137a31b 5106 "procedure does not accept complex arguments.")
1bbd0b84 5107#define FUNC_NAME s_scm_sys_expt
0f2d19dd
JB		 5108{
5109 struct dpair xy;
27c37006 5110 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 5111 return scm_make_real (pow (xy.x, xy.y));
0f2d19dd 5112}
1bbd0b84 5113#undef FUNC_NAME
0f2d19dd
JB		 5114
5115
a1ec6916 5116SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
27c37006
NJ		 5117 (SCM x, SCM y),
5118 "Return the arc tangent of the two arguments @var{x} and\n"
5119 "@var{y}. This is similar to calculating the arc tangent of\n"
5120 "@var{x} / @var{y}, except that the signs of both arguments\n"
0137a31b
MG		 5121 "are used to determine the quadrant of the result. This\n"
5122 "procedure does not accept complex arguments.")
1bbd0b84 5123#define FUNC_NAME s_scm_sys_atan2
0f2d19dd
JB		 5124{
5125 struct dpair xy;
27c37006 5126 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 5127 return scm_make_real (atan2 (xy.x, xy.y));
0f2d19dd 5128}
1bbd0b84 5129#undef FUNC_NAME
0f2d19dd
JB		 5130
5131
a1ec6916 5132SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
bb628794 5133 (SCM real, SCM imaginary),
942e5b91
MG		 5134 "Return a complex number constructed of the given @var{real} and\n"
5135 "@var{imaginary} parts.")
1bbd0b84 5136#define FUNC_NAME s_scm_make_rectangular
0f2d19dd
JB		 5137{
5138 struct dpair xy;
bb628794 5139 scm_two_doubles (real, imaginary, FUNC_NAME, &xy);
f8de44c1 5140 return scm_make_complex (xy.x, xy.y);
0f2d19dd 5141}
1bbd0b84 5142#undef FUNC_NAME
0f2d19dd
JB		 5143
5144
5145
a1ec6916 5146SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
27c37006 5147 (SCM x, SCM y),
942e5b91 5148 "Return the complex number @var{x} * e^(i * @var{y}).")
1bbd0b84 5149#define FUNC_NAME s_scm_make_polar
0f2d19dd
JB		 5150{
5151 struct dpair xy;
6efadd7c 5152 double s, c;
27c37006 5153 scm_two_doubles (x, y, FUNC_NAME, &xy);
6efadd7c
KR		 5154#if HAVE_SINCOS
5155 sincos (xy.y, &s, &c);
5156#else
5157 s = sin (xy.y);
5158 c = cos (xy.y);
5159#endif
5160 return scm_make_complex (xy.x * c, xy.x * s);
0f2d19dd 5161}
1bbd0b84 5162#undef FUNC_NAME
0f2d19dd
JB		 5163
5164
152f82bf 5165SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
942e5b91
MG		 5166/* "Return the real part of the number @var{z}."
5167 */
0f2d19dd 5168SCM
6e8d25a6 5169scm_real_part (SCM z)
0f2d19dd 5170{
0aacf84e 5171 if (SCM_INUMP (z))
c2ff8ab0 5172 return z;
0aacf84e 5173 else if (SCM_BIGP (z))
c2ff8ab0 5174 return z;
0aacf84e 5175 else if (SCM_REALP (z))
c2ff8ab0 5176 return z;
0aacf84e 5177 else if (SCM_COMPLEXP (z))
c2ff8ab0 5178 return scm_make_real (SCM_COMPLEX_REAL (z));
f92e85f7 5179 else if (SCM_FRACTIONP (z))
2fa2d879 5180 return z;
0aacf84e 5181 else
c2ff8ab0 5182 SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
0f2d19dd
JB		 5183}
5184
5185
152f82bf 5186SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
942e5b91
MG		 5187/* "Return the imaginary part of the number @var{z}."
5188 */
0f2d19dd 5189SCM
6e8d25a6 5190scm_imag_part (SCM z)
0f2d19dd 5191{
0aacf84e 5192 if (SCM_INUMP (z))
f872b822 5193 return SCM_INUM0;
0aacf84e 5194 else if (SCM_BIGP (z))
f872b822 5195 return SCM_INUM0;
0aacf84e 5196 else if (SCM_REALP (z))
c2ff8ab0 5197 return scm_flo0;
0aacf84e 5198 else if (SCM_COMPLEXP (z))
c2ff8ab0 5199 return scm_make_real (SCM_COMPLEX_IMAG (z));
f92e85f7
MV		 5200 else if (SCM_FRACTIONP (z))
5201 return SCM_INUM0;
0aacf84e 5202 else
c2ff8ab0 5203 SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
0f2d19dd
JB		 5204}
5205
f92e85f7
MV		 5206SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator);
5207/* "Return the numerator of the number @var{z}."
5208 */
5209SCM
5210scm_numerator (SCM z)
5211{
5212 if (SCM_INUMP (z))
5213 return z;
5214 else if (SCM_BIGP (z))
5215 return z;
5216 else if (SCM_FRACTIONP (z))
5217 {
5218 scm_i_fraction_reduce (z);
5219 return SCM_FRACTION_NUMERATOR (z);
5220 }
5221 else if (SCM_REALP (z))
5222 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
5223 else
5224 SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator);
5225}
5226
5227
5228SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator);
5229/* "Return the denominator of the number @var{z}."
5230 */
5231SCM
5232scm_denominator (SCM z)
5233{
5234 if (SCM_INUMP (z))
5235 return SCM_MAKINUM (1);
5236 else if (SCM_BIGP (z))
5237 return SCM_MAKINUM (1);
5238 else if (SCM_FRACTIONP (z))
5239 {
5240 scm_i_fraction_reduce (z);
5241 return SCM_FRACTION_DENOMINATOR (z);
5242 }
5243 else if (SCM_REALP (z))
5244 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
5245 else
5246 SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator);
5247}
0f2d19dd 5248
9de33deb 5249SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
942e5b91
MG		 5250/* "Return the magnitude of the number @var{z}. This is the same as\n"
5251 * "@code{abs} for real arguments, but also allows complex numbers."
5252 */
0f2d19dd 5253SCM
6e8d25a6 5254scm_magnitude (SCM z)
0f2d19dd 5255{
0aacf84e
MD		 5256 if (SCM_INUMP (z))
5257 {
5258 long int zz = SCM_INUM (z);
5259 if (zz >= 0)
5260 return z;
5261 else if (SCM_POSFIXABLE (-zz))
5262 return SCM_MAKINUM (-zz);
5263 else
5264 return scm_i_long2big (-zz);
5986c47d 5265 }
0aacf84e
MD		 5266 else if (SCM_BIGP (z))
5267 {
5268 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
5269 scm_remember_upto_here_1 (z);
5270 if (sgn < 0)
5271 return scm_i_clonebig (z, 0);
5272 else
5273 return z;
5986c47d 5274 }
0aacf84e 5275 else if (SCM_REALP (z))
c2ff8ab0 5276 return scm_make_real (fabs (SCM_REAL_VALUE (z)));
0aacf84e 5277 else if (SCM_COMPLEXP (z))
6efadd7c 5278 return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
f92e85f7
MV		 5279 else if (SCM_FRACTIONP (z))
5280 {
5281 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
5282 return z;
5283 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
5284 SCM_FRACTION_DENOMINATOR (z));
5285 }
0aacf84e 5286 else
c2ff8ab0 5287 SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
0f2d19dd
JB		 5288}
5289
5290
9de33deb 5291SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
942e5b91
MG		 5292/* "Return the angle of the complex number @var{z}."
5293 */
0f2d19dd 5294SCM
6e8d25a6 5295scm_angle (SCM z)
0f2d19dd 5296{
c8ae173e
KR		 5297 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
5298 scm_flo0 to save allocating a new flonum with scm_make_real each time.
5299 But if atan2 follows the floating point rounding mode, then the value
5300 is not a constant. Maybe it'd be close enough though. */
0aacf84e
MD		 5301 if (SCM_INUMP (z))
5302 {
5303 if (SCM_INUM (z) >= 0)
c8ae173e 5304 return scm_flo0;
0aacf84e
MD		 5305 else
5306 return scm_make_real (atan2 (0.0, -1.0));
f872b822 5307 }
0aacf84e
MD		 5308 else if (SCM_BIGP (z))
5309 {
5310 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
5311 scm_remember_upto_here_1 (z);
5312 if (sgn < 0)
5313 return scm_make_real (atan2 (0.0, -1.0));
5314 else
c8ae173e 5315 return scm_flo0;
0f2d19dd 5316 }
0aacf84e 5317 else if (SCM_REALP (z))
c8ae173e
KR		 5318 {
5319 if (SCM_REAL_VALUE (z) >= 0)
5320 return scm_flo0;
5321 else
5322 return scm_make_real (atan2 (0.0, -1.0));
5323 }
0aacf84e 5324 else if (SCM_COMPLEXP (z))
f4c627b3 5325 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
f92e85f7
MV		 5326 else if (SCM_FRACTIONP (z))
5327 {
5328 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
5329 return scm_flo0;
5330 else return scm_make_real (atan2 (0.0, -1.0));
5331 }
0aacf84e 5332 else
f4c627b3 5333 SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
0f2d19dd
JB		 5334}
5335
5336
3c9a524f
DH		 5337SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact);
5338/* Convert the number @var{x} to its inexact representation.\n"
5339 */
5340SCM
5341scm_exact_to_inexact (SCM z)
5342{
5343 if (SCM_INUMP (z))
5344 return scm_make_real ((double) SCM_INUM (z));
5345 else if (SCM_BIGP (z))
5346 return scm_make_real (scm_i_big2dbl (z));
f92e85f7
MV		 5347 else if (SCM_FRACTIONP (z))
5348 return scm_make_real (scm_i_fraction2double (z));
3c9a524f
DH		 5349 else if (SCM_INEXACTP (z))
5350 return z;
5351 else
5352 SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact);
5353}
5354
5355
a1ec6916 5356SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
1bbd0b84 5357 (SCM z),
1e6808ea 5358 "Return an exact number that is numerically closest to @var{z}.")
1bbd0b84 5359#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 5360{
0aacf84e 5361 if (SCM_INUMP (z))
f872b822 5362 return z;
0aacf84e 5363 else if (SCM_BIGP (z))
f872b822 5364 return z;
0aacf84e
MD		 5365 else if (SCM_REALP (z))
5366 {
f92e85f7
MV		 5367 if (xisinf (SCM_REAL_VALUE (z)) || xisnan (SCM_REAL_VALUE (z)))
5368 SCM_OUT_OF_RANGE (1, z);
2be24db4 5369 else
f92e85f7
MV		 5370 {
5371 mpq_t frac;
5372 SCM q;
5373
5374 mpq_init (frac);
5375 mpq_set_d (frac, SCM_REAL_VALUE (z));
5376 q = scm_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
5377 scm_i_mpz2num (mpq_denref (frac)));
5378
5379 /* When scm_make_ratio throws, we leak the memory allocated
5380 for frac...
5381 */
5382 mpq_clear (frac);
5383 return q;
5384 }
c2ff8ab0 5385 }
f92e85f7
MV		 5386 else if (SCM_FRACTIONP (z))
5387 return z;
0aacf84e 5388 else
c2ff8ab0 5389 SCM_WRONG_TYPE_ARG (1, z);
0f2d19dd 5390}
1bbd0b84 5391#undef FUNC_NAME
0f2d19dd 5392
f92e85f7
MV		 5393SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
5394 (SCM x, SCM err),
5395 "Return an exact number that is within @var{err} of @var{x}.")
5396#define FUNC_NAME s_scm_rationalize
5397{
5398 if (SCM_INUMP (x))
5399 return x;
5400 else if (SCM_BIGP (x))
5401 return x;
5402 else if ((SCM_REALP (x)) || SCM_FRACTIONP (x))
5403 {
5404 /* Use continued fractions to find closest ratio. All
5405 arithmetic is done with exact numbers.
5406 */
5407
5408 SCM ex = scm_inexact_to_exact (x);
5409 SCM int_part = scm_floor (ex);
5410 SCM tt = SCM_MAKINUM (1);
5411 SCM a1 = SCM_MAKINUM (0), a2 = SCM_MAKINUM (1), a = SCM_MAKINUM (0);
5412 SCM b1 = SCM_MAKINUM (1), b2 = SCM_MAKINUM (0), b = SCM_MAKINUM (0);
5413 SCM rx;
5414 int i = 0;
5415
5416 if (!SCM_FALSEP (scm_num_eq_p (ex, int_part)))
5417 return ex;
5418
5419 ex = scm_difference (ex, int_part); /* x = x-int_part */
5420 rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
5421
5422 /* We stop after a million iterations just to be absolutely sure
5423 that we don't go into an infinite loop. The process normally
5424 converges after less than a dozen iterations.
5425 */
5426
5427 err = scm_abs (err);
5428 while (++i < 1000000)
5429 {
5430 a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
5431 b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
5432 if (SCM_FALSEP (scm_zero_p (b)) && /* b != 0 */
5433 SCM_FALSEP
5434 (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
5435 err))) /* abs(x-a/b) <= err */
02164269
MV		 5436 {
5437 SCM res = scm_sum (int_part, scm_divide (a, b));
5438 if (SCM_FALSEP (scm_exact_p (x))
5439 || SCM_FALSEP (scm_exact_p (err)))
5440 return scm_exact_to_inexact (res);
5441 else
5442 return res;
5443 }
f92e85f7
MV		 5444 rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
5445 SCM_UNDEFINED);
5446 tt = scm_floor (rx); /* tt = floor (rx) */
5447 a2 = a1;
5448 b2 = b1;
5449 a1 = a;
5450 b1 = b;
5451 }
5452 scm_num_overflow (s_scm_rationalize);
5453 }
5454 else
5455 SCM_WRONG_TYPE_ARG (1, x);
5456}
5457#undef FUNC_NAME
5458
87617347 5459/* if you need to change this, change test-num2integral.c as well */
ee33d62a 5460#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 5461# ifndef LLONG_MAX
5462# define ULLONG_MAX ((unsigned long long) (-1))
5463# define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
5464# define LLONG_MIN (~LLONG_MAX)
5465# endif
f872b822 5466#endif
0f2d19dd 5467
3d2e8ceb
MV		 5468/* Parameters for creating integer conversion routines.
5469
5470 Define the following preprocessor macros before including
5471 "libguile/num2integral.i.c":
5472
5473 NUM2INTEGRAL - the name of the function for converting from a
ca46fb90
RB		 5474 Scheme object to the integral type. This function will be
5475 defined when including "num2integral.i.c".
3d2e8ceb
MV		 5476
5477 INTEGRAL2NUM - the name of the function for converting from the
ca46fb90 5478 integral type to a Scheme object. This function will be defined.
3d2e8ceb
MV		 5479
5480 INTEGRAL2BIG - the name of an internal function that createas a
ca46fb90
RB		 5481 bignum from the integral type. This function will be defined.
5482 The name should start with "scm_i_".
5483
5484 ITYPE - the name of the integral type.
5485
9dd023e1
MV		 5486 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
5487 it to 0 otherwise.
ca46fb90
RB		 5488
5489 UNSIGNED_ITYPE - the name of the the unsigned variant of the
5490 integral type. If you don't define this, it defaults to
5491 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
5492 ones.
5493
5494 SIZEOF_ITYPE - an expression giving the size of the integral type
5495 in bytes. This expression must be computable by the
5496 preprocessor. (SIZEOF_FOO values are calculated by configure.in
5497 for common types).
5498
3d2e8ceb
MV		 5499*/
5500
1be6b49c
ML		 5501#define NUM2INTEGRAL scm_num2short
5502#define INTEGRAL2NUM scm_short2num
5503#define INTEGRAL2BIG scm_i_short2big
ca46fb90 5504#define UNSIGNED 0
1be6b49c 5505#define ITYPE short
3d2e8ceb 5506#define SIZEOF_ITYPE SIZEOF_SHORT
1be6b49c
ML		 5507#include "libguile/num2integral.i.c"
5508
5509#define NUM2INTEGRAL scm_num2ushort
5510#define INTEGRAL2NUM scm_ushort2num
5511#define INTEGRAL2BIG scm_i_ushort2big
ca46fb90 5512#define UNSIGNED 1
1be6b49c 5513#define ITYPE unsigned short
ca46fb90 5514#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
1be6b49c
ML		 5515#include "libguile/num2integral.i.c"
5516
5517#define NUM2INTEGRAL scm_num2int
5518#define INTEGRAL2NUM scm_int2num
5519#define INTEGRAL2BIG scm_i_int2big
ca46fb90 5520#define UNSIGNED 0
1be6b49c 5521#define ITYPE int
3d2e8ceb 5522#define SIZEOF_ITYPE SIZEOF_INT
1be6b49c
ML		 5523#include "libguile/num2integral.i.c"
5524
5525#define NUM2INTEGRAL scm_num2uint
5526#define INTEGRAL2NUM scm_uint2num
5527#define INTEGRAL2BIG scm_i_uint2big
ca46fb90 5528#define UNSIGNED 1
1be6b49c 5529#define ITYPE unsigned int
ca46fb90 5530#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
1be6b49c
ML		 5531#include "libguile/num2integral.i.c"
5532
5533#define NUM2INTEGRAL scm_num2long
5534#define INTEGRAL2NUM scm_long2num
5535#define INTEGRAL2BIG scm_i_long2big
ca46fb90 5536#define UNSIGNED 0
1be6b49c 5537#define ITYPE long
3d2e8ceb 5538#define SIZEOF_ITYPE SIZEOF_LONG
1be6b49c
ML		 5539#include "libguile/num2integral.i.c"
5540
5541#define NUM2INTEGRAL scm_num2ulong
5542#define INTEGRAL2NUM scm_ulong2num
5543#define INTEGRAL2BIG scm_i_ulong2big
ca46fb90 5544#define UNSIGNED 1
1be6b49c 5545#define ITYPE unsigned long
ca46fb90 5546#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
1be6b49c
ML		 5547#include "libguile/num2integral.i.c"
5548
1be6b49c
ML		 5549#define NUM2INTEGRAL scm_num2ptrdiff
5550#define INTEGRAL2NUM scm_ptrdiff2num
5551#define INTEGRAL2BIG scm_i_ptrdiff2big
ca46fb90 5552#define UNSIGNED 0
ee33d62a 5553#define ITYPE scm_t_ptrdiff
3d2e8ceb 5554#define UNSIGNED_ITYPE size_t
ee33d62a 5555#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
1be6b49c
ML		 5556#include "libguile/num2integral.i.c"
5557
5558#define NUM2INTEGRAL scm_num2size
5559#define INTEGRAL2NUM scm_size2num
5560#define INTEGRAL2BIG scm_i_size2big
ca46fb90 5561#define UNSIGNED 1
1be6b49c 5562#define ITYPE size_t
3d2e8ceb 5563#define SIZEOF_ITYPE SIZEOF_SIZE_T
1be6b49c 5564#include "libguile/num2integral.i.c"
0f2d19dd 5565
ee33d62a 5566#if SCM_SIZEOF_LONG_LONG != 0
1cc91f1b 5567
caf08e65
MV		 5568#ifndef ULONG_LONG_MAX
5569#define ULONG_LONG_MAX (~0ULL)
5570#endif
5571
1be6b49c
ML		 5572#define NUM2INTEGRAL scm_num2long_long
5573#define INTEGRAL2NUM scm_long_long2num
5574#define INTEGRAL2BIG scm_i_long_long2big
ca46fb90 5575#define UNSIGNED 0
1be6b49c 5576#define ITYPE long long
3d2e8ceb 5577#define SIZEOF_ITYPE SIZEOF_LONG_LONG
1be6b49c
ML		 5578#include "libguile/num2integral.i.c"
5579
5580#define NUM2INTEGRAL scm_num2ulong_long
5581#define INTEGRAL2NUM scm_ulong_long2num
5582#define INTEGRAL2BIG scm_i_ulong_long2big
ca46fb90 5583#define UNSIGNED 1
1be6b49c 5584#define ITYPE unsigned long long
ca46fb90 5585#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
1be6b49c 5586#include "libguile/num2integral.i.c"
0f2d19dd 5587
ee33d62a 5588#endif /* SCM_SIZEOF_LONG_LONG != 0 */
caf08e65 5589
5437598b
MD		 5590#define NUM2FLOAT scm_num2float
5591#define FLOAT2NUM scm_float2num
5592#define FTYPE float
5593#include "libguile/num2float.i.c"
5594
5595#define NUM2FLOAT scm_num2double
5596#define FLOAT2NUM scm_double2num
5597#define FTYPE double
5598#include "libguile/num2float.i.c"
5599
1be6b49c 5600#ifdef GUILE_DEBUG
caf08e65 5601
6063dc1d
SJ		 5602#ifndef SIZE_MAX
5603#define SIZE_MAX ((size_t) (-1))
5604#endif
5605#ifndef PTRDIFF_MIN
5606#define PTRDIFF_MIN \
b4fb7de8
RB		 5607 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
5608 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
6063dc1d
SJ		 5609#endif
5610#ifndef PTRDIFF_MAX
5611#define PTRDIFF_MAX (~ PTRDIFF_MIN)
5612#endif
5613
0aacf84e
MD		 5614#define CHECK(type, v) \
5615 do \
5616 { \
5617 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
5618 abort (); \
5619 } \
5620 while (0)
caf08e65 5621
1be6b49c
ML		 5622static void
5623check_sanity ()
5624{
5625 CHECK (short, 0);
5626 CHECK (ushort, 0U);
5627 CHECK (int, 0);
5628 CHECK (uint, 0U);
5629 CHECK (long, 0L);
5630 CHECK (ulong, 0UL);
5631 CHECK (size, 0);
5632 CHECK (ptrdiff, 0);
5633
5634 CHECK (short, -1);
5635 CHECK (int, -1);
5636 CHECK (long, -1L);
5637 CHECK (ptrdiff, -1);
5638
5639 CHECK (short, SHRT_MAX);
5640 CHECK (short, SHRT_MIN);
5641 CHECK (ushort, USHRT_MAX);
5642 CHECK (int, INT_MAX);
5643 CHECK (int, INT_MIN);
5644 CHECK (uint, UINT_MAX);
5645 CHECK (long, LONG_MAX);
5646 CHECK (long, LONG_MIN);
5647 CHECK (ulong, ULONG_MAX);
5648 CHECK (size, SIZE_MAX);
5649 CHECK (ptrdiff, PTRDIFF_MAX);
5650 CHECK (ptrdiff, PTRDIFF_MIN);
0f2d19dd 5651
ee33d62a 5652#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 5653 CHECK (long_long, 0LL);
5654 CHECK (ulong_long, 0ULL);
1be6b49c 5655 CHECK (long_long, -1LL);
1be6b49c
ML		 5656 CHECK (long_long, LLONG_MAX);
5657 CHECK (long_long, LLONG_MIN);
5658 CHECK (ulong_long, ULLONG_MAX);
5659#endif
0f2d19dd
JB		 5660}
5661
b10586f0
ML		 5662#undef CHECK
5663
5664#define CHECK \
5665 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
5666 if (!SCM_FALSEP (data)) abort();
5667
5668static SCM
5669check_body (void *data)
5670{
5671 SCM num = *(SCM *) data;
5672 scm_num2ulong (num, 1, NULL);
5673
5674 return SCM_UNSPECIFIED;
5675}
5676
5677static SCM
5678check_handler (void *data, SCM tag, SCM throw_args)
5679{
5680 SCM *num = (SCM *) data;
5681 *num = SCM_BOOL_F;
5682
5683 return SCM_UNSPECIFIED;
5684}
5685
5686SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0,
b4e15479 5687 (void),
b10586f0
ML		 5688 "Number conversion sanity checking.")
5689#define FUNC_NAME s_scm_sys_check_number_conversions
5690{
5691 SCM data = SCM_MAKINUM (-1);
5692 CHECK;
5693 data = scm_int2num (INT_MIN);
5694 CHECK;
5695 data = scm_ulong2num (ULONG_MAX);
5696 data = scm_difference (SCM_INUM0, data);
5697 CHECK;
5698 data = scm_ulong2num (ULONG_MAX);
5699 data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data);
5700 CHECK;
5701 data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data);
5702 CHECK;
5703
5704 return SCM_UNSPECIFIED;
5705}
5706#undef FUNC_NAME
5707
1be6b49c 5708#endif
0f2d19dd 5709
0f2d19dd
JB		 5710void
5711scm_init_numbers ()
0f2d19dd 5712{
713a4259
KR		 5713 mpz_init_set_si (z_negative_one, -1);
5714
a261c0e9
DH		 5715 /* It may be possible to tune the performance of some algorithms by using
5716 * the following constants to avoid the creation of bignums. Please, before
5717 * using these values, remember the two rules of program optimization:
5718 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
86d31dfe
MV		 5719 scm_c_define ("most-positive-fixnum",
5720 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
5721 scm_c_define ("most-negative-fixnum",
5722 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
a261c0e9 5723
f3ae5d60
MD		 5724 scm_add_feature ("complex");
5725 scm_add_feature ("inexact");
5986c47d 5726 scm_flo0 = scm_make_real (0.0);
f872b822 5727#ifdef DBL_DIG
0f2d19dd 5728 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
f872b822 5729#else
0f2d19dd
JB		 5730 { /* determine floating point precision */
5731 double f = 0.1;
f872b822 5732 double fsum = 1.0 + f;
0aacf84e
MD		 5733 while (fsum != 1.0)
5734 {
5735 if (++scm_dblprec > 20)
5736 fsum = 1.0;
5737 else
5738 {
5739 f /= 10.0;
5740 fsum = f + 1.0;
5741 }
f872b822
MD		 5742 }
5743 scm_dblprec = scm_dblprec - 1;
0f2d19dd 5744 }
f872b822 5745#endif /* DBL_DIG */
1be6b49c
ML		 5746
5747#ifdef GUILE_DEBUG
5748 check_sanity ();
5749#endif
f92e85f7
MV		 5750
5751 exactly_one_half = scm_permanent_object (scm_divide (SCM_MAKINUM (1),
5752 SCM_MAKINUM (2)));
a0599745 5753#include "libguile/numbers.x"
0f2d19dd 5754}
89e00824
ML		 5755
5756/*
5757 Local Variables:
5758 c-file-style: "gnu"
5759 End:
5760*/
Unnamed repository; edit this file 'description' to name the repository.