HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Clean up stack tests
[bpt/guile.git] / libguile / numbers.c
CommitLineData
6978c673 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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 7 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
0f2d19dd 11 *
53befeb7
NJ		 12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV		 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
53befeb7
NJ		 19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
20 * 02110-1301 USA
73be1d9e 21 */
1bbd0b84 22
0f2d19dd 23\f
ca46fb90 24/* General assumptions:
ca46fb90
RB		 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.
c7218482 28 * XXX What about infinities? They are equal to their own floor! -mhw
f92e85f7 29 * All objects satisfying SCM_FRACTIONP are never an integer.
ca46fb90
RB		 30 */
31
32/* TODO:
33
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
36
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
39
40 - see if direct mpz operations can help in ash and elsewhere.
41
42 */
0f2d19dd 43
dbb605f5 44#ifdef HAVE_CONFIG_H
ee33d62a
RB		 45# include <config.h>
46#endif
47
bbec4602
LC		 48#include <verify.h>
49
0f2d19dd 50#include <math.h>
fc194577 51#include <string.h>
3f47e526
MG		 52#include <unicase.h>
53#include <unictype.h>
f92e85f7 54
8ab3d8a0
KR		 55#if HAVE_COMPLEX_H
56#include <complex.h>
57#endif
58
a0599745 59#include "libguile/_scm.h"
a0599745
MD		 60#include "libguile/feature.h"
61#include "libguile/ports.h"
62#include "libguile/root.h"
63#include "libguile/smob.h"
64#include "libguile/strings.h"
864e7d42 65#include "libguile/bdw-gc.h"
a0599745
MD		 66
67#include "libguile/validate.h"
68#include "libguile/numbers.h"
1be6b49c 69#include "libguile/deprecation.h"
f4c627b3 70
f92e85f7
MV		 71#include "libguile/eq.h"
72
8ab3d8a0
KR		 73/* values per glibc, if not already defined */
74#ifndef M_LOG10E
75#define M_LOG10E 0.43429448190325182765
76#endif
85bdb6ac
MW		 77#ifndef M_LN2
78#define M_LN2 0.69314718055994530942
79#endif
8ab3d8a0
KR		 80#ifndef M_PI
81#define M_PI 3.14159265358979323846
82#endif
83
e25f3727
AW		 84typedef scm_t_signed_bits scm_t_inum;
85#define scm_from_inum(x) (scm_from_signed_integer (x))
86
7112615f
MW		 87/* Tests to see if a C double is neither infinite nor a NaN.
88 TODO: if it's available, use C99's isfinite(x) instead */
89#define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
90
041fccf6
MW		 91/* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
92 of the infinity, but other platforms return a boolean only. */
93#define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
94#define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
95
0f2d19dd 96\f
f4c627b3 97
ca46fb90
RB		 98/*
99 Wonder if this might be faster for some of our code? A switch on
100 the numtag would jump directly to the right case, and the
101 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
102
103 #define SCM_I_NUMTAG_NOTNUM 0
104 #define SCM_I_NUMTAG_INUM 1
105 #define SCM_I_NUMTAG_BIG scm_tc16_big
106 #define SCM_I_NUMTAG_REAL scm_tc16_real
107 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
108 #define SCM_I_NUMTAG(x) \
e11e83f3 109 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
ca46fb90 110 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
534c55a9 111 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
ca46fb90
RB		 112 : SCM_I_NUMTAG_NOTNUM)))
113*/
f92e85f7 114/* the macro above will not work as is with fractions */
f4c627b3
DH		 115
116
b57bf272
AW		 117/* Default to 1, because as we used to hard-code `free' as the
118 deallocator, we know that overriding these functions with
119 instrumented `malloc' / `free' is OK. */
120int scm_install_gmp_memory_functions = 1;
e7efe8e7 121static SCM flo0;
ff62c168 122static SCM exactly_one_half;
a5f6b751 123static SCM flo_log10e;
e7efe8e7 124
34d19ef6 125#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
09fb7599 126
56e55ac7 127/* FLOBUFLEN is the maximum number of characters neccessary for the
3a9809df
DH		 128 * printed or scm_string representation of an inexact number.
129 */
0b799eea 130#define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
3a9809df 131
b127c712 132
ad79736c
AW		 133#if !defined (HAVE_ASINH)
134static double asinh (double x) { return log (x + sqrt (x * x + 1)); }
135#endif
136#if !defined (HAVE_ACOSH)
137static double acosh (double x) { return log (x + sqrt (x * x - 1)); }
138#endif
139#if !defined (HAVE_ATANH)
140static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
141#endif
142
18d78c5e
MW		 143/* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
144 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
145 in March 2006), mpz_cmp_d now handles infinities properly. */
f8a8200b 146#if 1
b127c712 147#define xmpz_cmp_d(z, d) \
2e65b52f 148 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
b127c712
KR		 149#else
150#define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
151#endif
152
f92e85f7 153
4b26c03e 154#if defined (GUILE_I)
03976fee 155#if defined HAVE_COMPLEX_DOUBLE
8ab3d8a0
KR		 156
157/* For an SCM object Z which is a complex number (ie. satisfies
158 SCM_COMPLEXP), return its value as a C level "complex double". */
159#define SCM_COMPLEX_VALUE(z) \
4b26c03e 160 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
8ab3d8a0 161
7a35784c 162static inline SCM scm_from_complex_double (complex double z) SCM_UNUSED;
8ab3d8a0
KR		 163
164/* Convert a C "complex double" to an SCM value. */
7a35784c 165static inline SCM
8ab3d8a0
KR		 166scm_from_complex_double (complex double z)
167{
168 return scm_c_make_rectangular (creal (z), cimag (z));
169}
bca69a9f 170
8ab3d8a0 171#endif /* HAVE_COMPLEX_DOUBLE */
bca69a9f 172#endif /* GUILE_I */
8ab3d8a0 173
0f2d19dd
JB		 174\f
175
713a4259 176static mpz_t z_negative_one;
ac0c002c
DH		 177
178\f
b57bf272 179
864e7d42
LC		 180/* Clear the `mpz_t' embedded in bignum PTR. */
181static void
182finalize_bignum (GC_PTR ptr, GC_PTR data)
183{
184 SCM bignum;
185
21041372 186 bignum = SCM_PACK_POINTER (ptr);
864e7d42
LC		 187 mpz_clear (SCM_I_BIG_MPZ (bignum));
188}
189
b57bf272
AW		 190/* The next three functions (custom_libgmp_*) are passed to
191 mp_set_memory_functions (in GMP) so that memory used by the digits
192 themselves is known to the garbage collector. This is needed so
193 that GC will be run at appropriate times. Otherwise, a program which
194 creates many large bignums would malloc a huge amount of memory
195 before the GC runs. */
196static void *
197custom_gmp_malloc (size_t alloc_size)
198{
199 return scm_malloc (alloc_size);
200}
201
202static void *
203custom_gmp_realloc (void *old_ptr, size_t old_size, size_t new_size)
204{
205 return scm_realloc (old_ptr, new_size);
206}
207
208static void
209custom_gmp_free (void *ptr, size_t size)
210{
211 free (ptr);
212}
213
214
d017fcdf
LC		 215/* Return a new uninitialized bignum. */
216static inline SCM
217make_bignum (void)
218{
219 scm_t_bits *p;
220
221 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
222 p = scm_gc_malloc_pointerless (sizeof (scm_t_bits) + sizeof (mpz_t),
223 "bignum");
224 p[0] = scm_tc16_big;
225
6978c673 226 scm_i_set_finalizer (p, finalize_bignum, NULL);
864e7d42 227
d017fcdf
LC		 228 return SCM_PACK (p);
229}
ac0c002c 230
864e7d42 231
189171c5 232SCM
ca46fb90
RB		 233scm_i_mkbig ()
234{
235 /* Return a newly created bignum. */
d017fcdf 236 SCM z = make_bignum ();
ca46fb90
RB		 237 mpz_init (SCM_I_BIG_MPZ (z));
238 return z;
239}
240
e25f3727
AW		 241static SCM
242scm_i_inum2big (scm_t_inum x)
243{
244 /* Return a newly created bignum initialized to X. */
245 SCM z = make_bignum ();
246#if SIZEOF_VOID_P == SIZEOF_LONG
247 mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
248#else
249 /* Note that in this case, you'll also have to check all mpz_*_ui and
250 mpz_*_si invocations in Guile. */
251#error creation of mpz not implemented for this inum size
252#endif
253 return z;
254}
255
189171c5 256SCM
c71b0706
MV		 257scm_i_long2big (long x)
258{
259 /* Return a newly created bignum initialized to X. */
d017fcdf 260 SCM z = make_bignum ();
c71b0706
MV		 261 mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
262 return z;
263}
264
189171c5 265SCM
c71b0706
MV		 266scm_i_ulong2big (unsigned long x)
267{
268 /* Return a newly created bignum initialized to X. */
d017fcdf 269 SCM z = make_bignum ();
c71b0706
MV		 270 mpz_init_set_ui (SCM_I_BIG_MPZ (z), x);
271 return z;
272}
273
189171c5 274SCM
ca46fb90
RB		 275scm_i_clonebig (SCM src_big, int same_sign_p)
276{
277 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
d017fcdf 278 SCM z = make_bignum ();
ca46fb90 279 mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
0aacf84e
MD		 280 if (!same_sign_p)
281 mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
ca46fb90
RB		 282 return z;
283}
284
189171c5 285int
ca46fb90
RB		 286scm_i_bigcmp (SCM x, SCM y)
287{
288 /* Return neg if x < y, pos if x > y, and 0 if x == y */
289 /* presume we already know x and y are bignums */
290 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
291 scm_remember_upto_here_2 (x, y);
292 return result;
293}
294
189171c5 295SCM
ca46fb90
RB		 296scm_i_dbl2big (double d)
297{
298 /* results are only defined if d is an integer */
d017fcdf 299 SCM z = make_bignum ();
ca46fb90
RB		 300 mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
301 return z;
302}
303
f92e85f7
MV		 304/* Convert a integer in double representation to a SCM number. */
305
189171c5 306SCM
f92e85f7
MV		 307scm_i_dbl2num (double u)
308{
309 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
310 powers of 2, so there's no rounding when making "double" values
311 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
312 get rounded on a 64-bit machine, hence the "+1".
313
314 The use of floor() to force to an integer value ensures we get a
315 "numerically closest" value without depending on how a
316 double->long cast or how mpz_set_d will round. For reference,
317 double->long probably follows the hardware rounding mode,
318 mpz_set_d truncates towards zero. */
319
320 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
321 representable as a double? */
322
323 if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
324 && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
e25f3727 325 return SCM_I_MAKINUM ((scm_t_inum) u);
f92e85f7
MV		 326 else
327 return scm_i_dbl2big (u);
328}
329
089c9a59
KR		 330/* scm_i_big2dbl() rounds to the closest representable double, in accordance
331 with R5RS exact->inexact.
332
333 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
f8a8200b
KR		 334 (ie. truncate towards zero), then adjust to get the closest double by
335 examining the next lower bit and adding 1 (to the absolute value) if
336 necessary.
337
338 Bignums exactly half way between representable doubles are rounded to the
339 next higher absolute value (ie. away from zero). This seems like an
340 adequate interpretation of R5RS "numerically closest", and it's easier
341 and faster than a full "nearest-even" style.
342
343 The bit test must be done on the absolute value of the mpz_t, which means
344 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
345 negatives as twos complement.
346
18d78c5e
MW		 347 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
348 following the hardware rounding mode, but applied to the absolute
349 value of the mpz_t operand. This is not what we want so we put the
350 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
351 (released in March 2006) mpz_get_d now always truncates towards zero.
f8a8200b 352
18d78c5e
MW		 353 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
354 before 4.2 is a slowdown. It'd be faster to pick out the relevant
355 high bits with mpz_getlimbn. */
089c9a59
KR		 356
357double
ca46fb90
RB		 358scm_i_big2dbl (SCM b)
359{
089c9a59
KR		 360 double result;
361 size_t bits;
362
363 bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
364
f8a8200b 365#if 1
089c9a59 366 {
18d78c5e
MW		 367 /* For GMP earlier than 4.2, force truncation towards zero */
368
369 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
370 _not_ the number of bits, so this code will break badly on a
371 system with non-binary doubles. */
372
089c9a59
KR		 373 mpz_t tmp;
374 if (bits > DBL_MANT_DIG)
375 {
376 size_t shift = bits - DBL_MANT_DIG;
377 mpz_init2 (tmp, DBL_MANT_DIG);
378 mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
379 result = ldexp (mpz_get_d (tmp), shift);
380 mpz_clear (tmp);
381 }
382 else
383 {
384 result = mpz_get_d (SCM_I_BIG_MPZ (b));
385 }
386 }
387#else
18d78c5e 388 /* GMP 4.2 or later */
089c9a59
KR		 389 result = mpz_get_d (SCM_I_BIG_MPZ (b));
390#endif
391
392 if (bits > DBL_MANT_DIG)
393 {
394 unsigned long pos = bits - DBL_MANT_DIG - 1;
395 /* test bit number "pos" in absolute value */
396 if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
397 & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
398 {
399 result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
400 }
401 }
402
ca46fb90
RB		 403 scm_remember_upto_here_1 (b);
404 return result;
405}
406
189171c5 407SCM
ca46fb90
RB		 408scm_i_normbig (SCM b)
409{
410 /* convert a big back to a fixnum if it'll fit */
411 /* presume b is a bignum */
412 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
413 {
e25f3727 414 scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b));
ca46fb90 415 if (SCM_FIXABLE (val))
d956fa6f 416 b = SCM_I_MAKINUM (val);
ca46fb90
RB		 417 }
418 return b;
419}
f872b822 420
f92e85f7
MV		 421static SCM_C_INLINE_KEYWORD SCM
422scm_i_mpz2num (mpz_t b)
423{
424 /* convert a mpz number to a SCM number. */
425 if (mpz_fits_slong_p (b))
426 {
e25f3727 427 scm_t_inum val = mpz_get_si (b);
f92e85f7 428 if (SCM_FIXABLE (val))
d956fa6f 429 return SCM_I_MAKINUM (val);
f92e85f7
MV		 430 }
431
432 {
d017fcdf 433 SCM z = make_bignum ();
f92e85f7
MV		 434 mpz_init_set (SCM_I_BIG_MPZ (z), b);
435 return z;
436 }
437}
438
439/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
440static SCM scm_divide2real (SCM x, SCM y);
441
cba42c93
MV		 442static SCM
443scm_i_make_ratio (SCM numerator, SCM denominator)
c60e130c 444#define FUNC_NAME "make-ratio"
f92e85f7 445{
c60e130c
MV		 446 /* First make sure the arguments are proper.
447 */
e11e83f3 448 if (SCM_I_INUMP (denominator))
f92e85f7 449 {
bc36d050 450 if (scm_is_eq (denominator, SCM_INUM0))
f92e85f7 451 scm_num_overflow ("make-ratio");
cff5fa33 452 if (scm_is_eq (denominator, SCM_INUM1))
f92e85f7
MV		 453 return numerator;
454 }
455 else
456 {
457 if (!(SCM_BIGP(denominator)))
458 SCM_WRONG_TYPE_ARG (2, denominator);
459 }
e11e83f3 460 if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator))
c60e130c
MV		 461 SCM_WRONG_TYPE_ARG (1, numerator);
462
463 /* Then flip signs so that the denominator is positive.
464 */
73e4de09 465 if (scm_is_true (scm_negative_p (denominator)))
c60e130c
MV		 466 {
467 numerator = scm_difference (numerator, SCM_UNDEFINED);
468 denominator = scm_difference (denominator, SCM_UNDEFINED);
469 }
470
471 /* Now consider for each of the four fixnum/bignum combinations
472 whether the rational number is really an integer.
473 */
e11e83f3 474 if (SCM_I_INUMP (numerator))
f92e85f7 475 {
e25f3727 476 scm_t_inum x = SCM_I_INUM (numerator);
bc36d050 477 if (scm_is_eq (numerator, SCM_INUM0))
f92e85f7 478 return SCM_INUM0;
e11e83f3 479 if (SCM_I_INUMP (denominator))
f92e85f7 480 {
e25f3727 481 scm_t_inum y;
e11e83f3 482 y = SCM_I_INUM (denominator);
f92e85f7 483 if (x == y)
cff5fa33 484 return SCM_INUM1;
f92e85f7 485 if ((x % y) == 0)
d956fa6f 486 return SCM_I_MAKINUM (x / y);
f92e85f7 487 }
dd5130ca
KR		 488 else
489 {
490 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
3271a325
KR		 491 of that value for the denominator, as a bignum. Apart from
492 that case, abs(bignum) > abs(inum) so inum/bignum is not an
493 integer. */
494 if (x == SCM_MOST_NEGATIVE_FIXNUM
495 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator),
496 - SCM_MOST_NEGATIVE_FIXNUM) == 0)
d956fa6f 497 return SCM_I_MAKINUM(-1);
dd5130ca 498 }
f92e85f7 499 }
c60e130c 500 else if (SCM_BIGP (numerator))
f92e85f7 501 {
e11e83f3 502 if (SCM_I_INUMP (denominator))
c60e130c 503 {
e25f3727 504 scm_t_inum yy = SCM_I_INUM (denominator);
c60e130c
MV		 505 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
506 return scm_divide (numerator, denominator);
507 }
508 else
f92e85f7 509 {
bc36d050 510 if (scm_is_eq (numerator, denominator))
cff5fa33 511 return SCM_INUM1;
c60e130c
MV		 512 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
513 SCM_I_BIG_MPZ (denominator)))
514 return scm_divide(numerator, denominator);
f92e85f7 515 }
f92e85f7 516 }
c60e130c
MV		 517
518 /* No, it's a proper fraction.
519 */
e2bf3b19
HWN		 520 {
521 SCM divisor = scm_gcd (numerator, denominator);
cff5fa33 522 if (!(scm_is_eq (divisor, SCM_INUM1)))
e2bf3b19
HWN		 523 {
524 numerator = scm_divide (numerator, divisor);
525 denominator = scm_divide (denominator, divisor);
526 }
527
528 return scm_double_cell (scm_tc16_fraction,
529 SCM_UNPACK (numerator),
530 SCM_UNPACK (denominator), 0);
531 }
f92e85f7 532}
c60e130c 533#undef FUNC_NAME
f92e85f7 534
f92e85f7
MV		 535double
536scm_i_fraction2double (SCM z)
537{
55f26379
MV		 538 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
539 SCM_FRACTION_DENOMINATOR (z)));
f92e85f7
MV		 540}
541
2e274311
MW		 542static int
543double_is_non_negative_zero (double x)
544{
545 static double zero = 0.0;
546
547 return !memcmp (&x, &zero, sizeof(double));
548}
549
2519490c
MW		 550SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
551 (SCM x),
942e5b91
MG		 552 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
553 "otherwise.")
1bbd0b84 554#define FUNC_NAME s_scm_exact_p
0f2d19dd 555{
41df63cf
MW		 556 if (SCM_INEXACTP (x))
557 return SCM_BOOL_F;
558 else if (SCM_NUMBERP (x))
0aacf84e 559 return SCM_BOOL_T;
41df63cf 560 else
fa075d40 561 return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
41df63cf
MW		 562}
563#undef FUNC_NAME
564
022dda69
MG		 565int
566scm_is_exact (SCM val)
567{
568 return scm_is_true (scm_exact_p (val));
569}
41df63cf 570
2519490c 571SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0,
41df63cf
MW		 572 (SCM x),
573 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
574 "else.")
575#define FUNC_NAME s_scm_inexact_p
576{
577 if (SCM_INEXACTP (x))
f92e85f7 578 return SCM_BOOL_T;
41df63cf 579 else if (SCM_NUMBERP (x))
eb927cb9 580 return SCM_BOOL_F;
41df63cf 581 else
fa075d40 582 return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
0f2d19dd 583}
1bbd0b84 584#undef FUNC_NAME
0f2d19dd 585
022dda69
MG		 586int
587scm_is_inexact (SCM val)
588{
589 return scm_is_true (scm_inexact_p (val));
590}
4219f20d 591
2519490c 592SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0,
1bbd0b84 593 (SCM n),
942e5b91
MG		 594 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
595 "otherwise.")
1bbd0b84 596#define FUNC_NAME s_scm_odd_p
0f2d19dd 597{
e11e83f3 598 if (SCM_I_INUMP (n))
0aacf84e 599 {
e25f3727 600 scm_t_inum val = SCM_I_INUM (n);
73e4de09 601 return scm_from_bool ((val & 1L) != 0);
0aacf84e
MD		 602 }
603 else if (SCM_BIGP (n))
604 {
605 int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
606 scm_remember_upto_here_1 (n);
73e4de09 607 return scm_from_bool (odd_p);
0aacf84e 608 }
f92e85f7
MV		 609 else if (SCM_REALP (n))
610 {
2519490c
MW		 611 double val = SCM_REAL_VALUE (n);
612 if (DOUBLE_IS_FINITE (val))
613 {
614 double rem = fabs (fmod (val, 2.0));
615 if (rem == 1.0)
616 return SCM_BOOL_T;
617 else if (rem == 0.0)
618 return SCM_BOOL_F;
619 }
f92e85f7 620 }
fa075d40 621 return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
0f2d19dd 622}
1bbd0b84 623#undef FUNC_NAME
0f2d19dd 624
4219f20d 625
2519490c 626SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0,
1bbd0b84 627 (SCM n),
942e5b91
MG		 628 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
629 "otherwise.")
1bbd0b84 630#define FUNC_NAME s_scm_even_p
0f2d19dd 631{
e11e83f3 632 if (SCM_I_INUMP (n))
0aacf84e 633 {
e25f3727 634 scm_t_inum val = SCM_I_INUM (n);
73e4de09 635 return scm_from_bool ((val & 1L) == 0);
0aacf84e
MD		 636 }
637 else if (SCM_BIGP (n))
638 {
639 int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
640 scm_remember_upto_here_1 (n);
73e4de09 641 return scm_from_bool (even_p);
0aacf84e 642 }
f92e85f7
MV		 643 else if (SCM_REALP (n))
644 {
2519490c
MW		 645 double val = SCM_REAL_VALUE (n);
646 if (DOUBLE_IS_FINITE (val))
647 {
648 double rem = fabs (fmod (val, 2.0));
649 if (rem == 1.0)
650 return SCM_BOOL_F;
651 else if (rem == 0.0)
652 return SCM_BOOL_T;
653 }
f92e85f7 654 }
fa075d40 655 return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
0f2d19dd 656}
1bbd0b84 657#undef FUNC_NAME
0f2d19dd 658
2519490c
MW		 659SCM_PRIMITIVE_GENERIC (scm_finite_p, "finite?", 1, 0, 0,
660 (SCM x),
10391e06
AW		 661 "Return @code{#t} if the real number @var{x} is neither\n"
662 "infinite nor a NaN, @code{#f} otherwise.")
7112615f
MW		 663#define FUNC_NAME s_scm_finite_p
664{
665 if (SCM_REALP (x))
666 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x)));
10391e06 667 else if (scm_is_real (x))
7112615f
MW		 668 return SCM_BOOL_T;
669 else
fa075d40 670 return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
7112615f
MW		 671}
672#undef FUNC_NAME
673
2519490c
MW		 674SCM_PRIMITIVE_GENERIC (scm_inf_p, "inf?", 1, 0, 0,
675 (SCM x),
676 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
677 "@samp{-inf.0}. Otherwise return @code{#f}.")
7351e207
MV		 678#define FUNC_NAME s_scm_inf_p
679{
b1092b3a 680 if (SCM_REALP (x))
2e65b52f 681 return scm_from_bool (isinf (SCM_REAL_VALUE (x)));
10391e06 682 else if (scm_is_real (x))
7351e207 683 return SCM_BOOL_F;
10391e06 684 else
fa075d40 685 return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
7351e207
MV		 686}
687#undef FUNC_NAME
688
2519490c
MW		 689SCM_PRIMITIVE_GENERIC (scm_nan_p, "nan?", 1, 0, 0,
690 (SCM x),
10391e06
AW		 691 "Return @code{#t} if the real number @var{x} is a NaN,\n"
692 "or @code{#f} otherwise.")
7351e207
MV		 693#define FUNC_NAME s_scm_nan_p
694{
10391e06
AW		 695 if (SCM_REALP (x))
696 return scm_from_bool (isnan (SCM_REAL_VALUE (x)));
697 else if (scm_is_real (x))
7351e207 698 return SCM_BOOL_F;
10391e06 699 else
fa075d40 700 return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
7351e207
MV		 701}
702#undef FUNC_NAME
703
704/* Guile's idea of infinity. */
705static double guile_Inf;
706
707/* Guile's idea of not a number. */
708static double guile_NaN;
709
710static void
711guile_ieee_init (void)
712{
7351e207
MV		 713/* Some version of gcc on some old version of Linux used to crash when
714 trying to make Inf and NaN. */
715
240a27d2
KR		 716#ifdef INFINITY
717 /* C99 INFINITY, when available.
718 FIXME: The standard allows for INFINITY to be something that overflows
719 at compile time. We ought to have a configure test to check for that
720 before trying to use it. (But in practice we believe this is not a
721 problem on any system guile is likely to target.) */
722 guile_Inf = INFINITY;
56a3dcd4 723#elif defined HAVE_DINFINITY
240a27d2 724 /* OSF */
7351e207 725 extern unsigned int DINFINITY[2];
eaa94eaa 726 guile_Inf = (*((double *) (DINFINITY)));
7351e207
MV		 727#else
728 double tmp = 1e+10;
729 guile_Inf = tmp;
730 for (;;)
731 {
732 guile_Inf *= 1e+10;
733 if (guile_Inf == tmp)
734 break;
735 tmp = guile_Inf;
736 }
737#endif
738
240a27d2
KR		 739#ifdef NAN
740 /* C99 NAN, when available */
741 guile_NaN = NAN;
56a3dcd4 742#elif defined HAVE_DQNAN
eaa94eaa
LC		 743 {
744 /* OSF */
745 extern unsigned int DQNAN[2];
746 guile_NaN = (*((double *)(DQNAN)));
747 }
7351e207
MV		 748#else
749 guile_NaN = guile_Inf / guile_Inf;
750#endif
7351e207
MV		 751}
752
753SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
754 (void),
755 "Return Inf.")
756#define FUNC_NAME s_scm_inf
757{
758 static int initialized = 0;
759 if (! initialized)
760 {
761 guile_ieee_init ();
762 initialized = 1;
763 }
55f26379 764 return scm_from_double (guile_Inf);
7351e207
MV		 765}
766#undef FUNC_NAME
767
768SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
769 (void),
770 "Return NaN.")
771#define FUNC_NAME s_scm_nan
772{
773 static int initialized = 0;
0aacf84e 774 if (!initialized)
7351e207
MV		 775 {
776 guile_ieee_init ();
777 initialized = 1;
778 }
55f26379 779 return scm_from_double (guile_NaN);
7351e207
MV		 780}
781#undef FUNC_NAME
782
4219f20d 783
a48d60b1
MD		 784SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
785 (SCM x),
786 "Return the absolute value of @var{x}.")
2519490c 787#define FUNC_NAME s_scm_abs
0f2d19dd 788{
e11e83f3 789 if (SCM_I_INUMP (x))
0aacf84e 790 {
e25f3727 791 scm_t_inum xx = SCM_I_INUM (x);
0aacf84e
MD		 792 if (xx >= 0)
793 return x;
794 else if (SCM_POSFIXABLE (-xx))
d956fa6f 795 return SCM_I_MAKINUM (-xx);
0aacf84e 796 else
e25f3727 797 return scm_i_inum2big (-xx);
4219f20d 798 }
9b9ef10c
MW		 799 else if (SCM_LIKELY (SCM_REALP (x)))
800 {
801 double xx = SCM_REAL_VALUE (x);
802 /* If x is a NaN then xx<0 is false so we return x unchanged */
803 if (xx < 0.0)
804 return scm_from_double (-xx);
805 /* Handle signed zeroes properly */
806 else if (SCM_UNLIKELY (xx == 0.0))
807 return flo0;
808 else
809 return x;
810 }
0aacf84e
MD		 811 else if (SCM_BIGP (x))
812 {
813 const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
814 if (sgn < 0)
815 return scm_i_clonebig (x, 0);
816 else
817 return x;
4219f20d 818 }
f92e85f7
MV		 819 else if (SCM_FRACTIONP (x))
820 {
73e4de09 821 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
f92e85f7 822 return x;
cba42c93 823 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
f92e85f7
MV		 824 SCM_FRACTION_DENOMINATOR (x));
825 }
0aacf84e 826 else
fa075d40 827 return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
0f2d19dd 828}
a48d60b1 829#undef FUNC_NAME
0f2d19dd 830
4219f20d 831
2519490c
MW		 832SCM_PRIMITIVE_GENERIC (scm_quotient, "quotient", 2, 0, 0,
833 (SCM x, SCM y),
834 "Return the quotient of the numbers @var{x} and @var{y}.")
835#define FUNC_NAME s_scm_quotient
0f2d19dd 836{
495a39c4 837 if (SCM_LIKELY (scm_is_integer (x)))
0aacf84e 838 {
495a39c4 839 if (SCM_LIKELY (scm_is_integer (y)))
a8da6d93 840 return scm_truncate_quotient (x, y);
0aacf84e 841 else
fa075d40 842 return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
f872b822 843 }
0aacf84e 844 else
fa075d40 845 return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
0f2d19dd 846}
2519490c 847#undef FUNC_NAME
0f2d19dd 848
2519490c
MW		 849SCM_PRIMITIVE_GENERIC (scm_remainder, "remainder", 2, 0, 0,
850 (SCM x, SCM y),
851 "Return the remainder of the numbers @var{x} and @var{y}.\n"
852 "@lisp\n"
853 "(remainder 13 4) @result{} 1\n"
854 "(remainder -13 4) @result{} -1\n"
855 "@end lisp")
856#define FUNC_NAME s_scm_remainder
0f2d19dd 857{
495a39c4 858 if (SCM_LIKELY (scm_is_integer (x)))
0aacf84e 859 {
495a39c4 860 if (SCM_LIKELY (scm_is_integer (y)))
a8da6d93 861 return scm_truncate_remainder (x, y);
0aacf84e 862 else
fa075d40 863 return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
f872b822 864 }
0aacf84e 865 else
fa075d40 866 return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
0f2d19dd 867}
2519490c 868#undef FUNC_NAME
0f2d19dd 869
89a7e495 870
2519490c
MW		 871SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
872 (SCM x, SCM y),
873 "Return the modulo of the numbers @var{x} and @var{y}.\n"
874 "@lisp\n"
875 "(modulo 13 4) @result{} 1\n"
876 "(modulo -13 4) @result{} 3\n"
877 "@end lisp")
878#define FUNC_NAME s_scm_modulo
0f2d19dd 879{
495a39c4 880 if (SCM_LIKELY (scm_is_integer (x)))
0aacf84e 881 {
495a39c4 882 if (SCM_LIKELY (scm_is_integer (y)))
a8da6d93 883 return scm_floor_remainder (x, y);
0aacf84e 884 else
fa075d40 885 return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
828865c3 886 }
0aacf84e 887 else
fa075d40 888 return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
0f2d19dd 889}
2519490c 890#undef FUNC_NAME
0f2d19dd 891
5fbf680b
MW		 892/* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
893 two-valued functions. It is called from primitive generics that take
894 two arguments and return two values, when the core procedure is
895 unable to handle the given argument types. If there are GOOPS
896 methods for this primitive generic, it dispatches to GOOPS and, if
897 successful, expects two values to be returned, which are placed in
898 *rp1 and *rp2. If there are no GOOPS methods, it throws a
899 wrong-type-arg exception.
900
901 FIXME: This obviously belongs somewhere else, but until we decide on
902 the right API, it is here as a static function, because it is needed
903 by the *_divide functions below.
904*/
905static void
906two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
907 const char *subr, SCM *rp1, SCM *rp2)
908{
fa075d40
AW		 909 SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
910
911 scm_i_extract_values_2 (vals, rp1, rp2);
5fbf680b
MW		 912}
913
a8da6d93
MW		 914SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
915 (SCM x, SCM y),
916 "Return the integer @var{q} such that\n"
917 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
918 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
919 "@lisp\n"
920 "(euclidean-quotient 123 10) @result{} 12\n"
921 "(euclidean-quotient 123 -10) @result{} -12\n"
922 "(euclidean-quotient -123 10) @result{} -13\n"
923 "(euclidean-quotient -123 -10) @result{} 13\n"
924 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
925 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
926 "@end lisp")
ff62c168
MW		 927#define FUNC_NAME s_scm_euclidean_quotient
928{
a8da6d93
MW		 929 if (scm_is_false (scm_negative_p (y)))
930 return scm_floor_quotient (x, y);
ff62c168 931 else
a8da6d93 932 return scm_ceiling_quotient (x, y);
ff62c168
MW		 933}
934#undef FUNC_NAME
935
a8da6d93
MW		 936SCM_DEFINE (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
937 (SCM x, SCM y),
938 "Return the real number @var{r} such that\n"
939 "@math{0 <= @var{r} < abs(@var{y})} and\n"
940 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
941 "for some integer @var{q}.\n"
942 "@lisp\n"
943 "(euclidean-remainder 123 10) @result{} 3\n"
944 "(euclidean-remainder 123 -10) @result{} 3\n"
945 "(euclidean-remainder -123 10) @result{} 7\n"
946 "(euclidean-remainder -123 -10) @result{} 7\n"
947 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
948 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
949 "@end lisp")
ff62c168
MW		 950#define FUNC_NAME s_scm_euclidean_remainder
951{
a8da6d93
MW		 952 if (scm_is_false (scm_negative_p (y)))
953 return scm_floor_remainder (x, y);
ff62c168 954 else
a8da6d93 955 return scm_ceiling_remainder (x, y);
ff62c168
MW		 956}
957#undef FUNC_NAME
958
a8da6d93
MW		 959SCM_DEFINE (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
960 (SCM x, SCM y),
961 "Return the integer @var{q} and the real number @var{r}\n"
962 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
963 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
964 "@lisp\n"
965 "(euclidean/ 123 10) @result{} 12 and 3\n"
966 "(euclidean/ 123 -10) @result{} -12 and 3\n"
967 "(euclidean/ -123 10) @result{} -13 and 7\n"
968 "(euclidean/ -123 -10) @result{} 13 and 7\n"
969 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
970 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
971 "@end lisp")
5fbf680b
MW		 972#define FUNC_NAME s_scm_i_euclidean_divide
973{
a8da6d93
MW		 974 if (scm_is_false (scm_negative_p (y)))
975 return scm_i_floor_divide (x, y);
976 else
977 return scm_i_ceiling_divide (x, y);
5fbf680b
MW		 978}
979#undef FUNC_NAME
980
5fbf680b
MW		 981void
982scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
ff62c168 983{
a8da6d93
MW		 984 if (scm_is_false (scm_negative_p (y)))
985 return scm_floor_divide (x, y, qp, rp);
ff62c168 986 else
a8da6d93 987 return scm_ceiling_divide (x, y, qp, rp);
ff62c168
MW		 988}
989
8f9da340
MW		 990static SCM scm_i_inexact_floor_quotient (double x, double y);
991static SCM scm_i_exact_rational_floor_quotient (SCM x, SCM y);
992
993SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
994 (SCM x, SCM y),
995 "Return the floor of @math{@var{x} / @var{y}}.\n"
996 "@lisp\n"
997 "(floor-quotient 123 10) @result{} 12\n"
998 "(floor-quotient 123 -10) @result{} -13\n"
999 "(floor-quotient -123 10) @result{} -13\n"
1000 "(floor-quotient -123 -10) @result{} 12\n"
1001 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1002 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1003 "@end lisp")
1004#define FUNC_NAME s_scm_floor_quotient
1005{
1006 if (SCM_LIKELY (SCM_I_INUMP (x)))
1007 {
1008 scm_t_inum xx = SCM_I_INUM (x);
1009 if (SCM_LIKELY (SCM_I_INUMP (y)))
1010 {
1011 scm_t_inum yy = SCM_I_INUM (y);
1012 scm_t_inum xx1 = xx;
1013 scm_t_inum qq;
1014 if (SCM_LIKELY (yy > 0))
1015 {
1016 if (SCM_UNLIKELY (xx < 0))
1017 xx1 = xx - yy + 1;
1018 }
1019 else if (SCM_UNLIKELY (yy == 0))
1020 scm_num_overflow (s_scm_floor_quotient);
1021 else if (xx > 0)
1022 xx1 = xx - yy - 1;
1023 qq = xx1 / yy;
1024 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1025 return SCM_I_MAKINUM (qq);
1026 else
1027 return scm_i_inum2big (qq);
1028 }
1029 else if (SCM_BIGP (y))
1030 {
1031 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1032 scm_remember_upto_here_1 (y);
1033 if (sign > 0)
1034 return SCM_I_MAKINUM ((xx < 0) ? -1 : 0);
1035 else
1036 return SCM_I_MAKINUM ((xx > 0) ? -1 : 0);
1037 }
1038 else if (SCM_REALP (y))
1039 return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
1040 else if (SCM_FRACTIONP (y))
1041 return scm_i_exact_rational_floor_quotient (x, y);
1042 else
fa075d40
AW		 1043 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1044 s_scm_floor_quotient);
8f9da340
MW		 1045 }
1046 else if (SCM_BIGP (x))
1047 {
1048 if (SCM_LIKELY (SCM_I_INUMP (y)))
1049 {
1050 scm_t_inum yy = SCM_I_INUM (y);
1051 if (SCM_UNLIKELY (yy == 0))
1052 scm_num_overflow (s_scm_floor_quotient);
1053 else if (SCM_UNLIKELY (yy == 1))
1054 return x;
1055 else
1056 {
1057 SCM q = scm_i_mkbig ();
1058 if (yy > 0)
1059 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
1060 else
1061 {
1062 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
1063 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1064 }
1065 scm_remember_upto_here_1 (x);
1066 return scm_i_normbig (q);
1067 }
1068 }
1069 else if (SCM_BIGP (y))
1070 {
1071 SCM q = scm_i_mkbig ();
1072 mpz_fdiv_q (SCM_I_BIG_MPZ (q),
1073 SCM_I_BIG_MPZ (x),
1074 SCM_I_BIG_MPZ (y));
1075 scm_remember_upto_here_2 (x, y);
1076 return scm_i_normbig (q);
1077 }
1078 else if (SCM_REALP (y))
1079 return scm_i_inexact_floor_quotient
1080 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1081 else if (SCM_FRACTIONP (y))
1082 return scm_i_exact_rational_floor_quotient (x, y);
1083 else
fa075d40
AW		 1084 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1085 s_scm_floor_quotient);
8f9da340
MW		 1086 }
1087 else if (SCM_REALP (x))
1088 {
1089 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1090 SCM_BIGP (y) || SCM_FRACTIONP (y))
1091 return scm_i_inexact_floor_quotient
1092 (SCM_REAL_VALUE (x), scm_to_double (y));
1093 else
fa075d40
AW		 1094 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1095 s_scm_floor_quotient);
8f9da340
MW		 1096 }
1097 else if (SCM_FRACTIONP (x))
1098 {
1099 if (SCM_REALP (y))
1100 return scm_i_inexact_floor_quotient
1101 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1102 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1103 return scm_i_exact_rational_floor_quotient (x, y);
1104 else
fa075d40
AW		 1105 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1106 s_scm_floor_quotient);
8f9da340
MW		 1107 }
1108 else
fa075d40
AW		 1109 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
1110 s_scm_floor_quotient);
8f9da340
MW		 1111}
1112#undef FUNC_NAME
1113
1114static SCM
1115scm_i_inexact_floor_quotient (double x, double y)
1116{
1117 if (SCM_UNLIKELY (y == 0))
1118 scm_num_overflow (s_scm_floor_quotient); /* or return a NaN? */
1119 else
1120 return scm_from_double (floor (x / y));
1121}
1122
1123static SCM
1124scm_i_exact_rational_floor_quotient (SCM x, SCM y)
1125{
1126 return scm_floor_quotient
1127 (scm_product (scm_numerator (x), scm_denominator (y)),
1128 scm_product (scm_numerator (y), scm_denominator (x)));
1129}
1130
1131static SCM scm_i_inexact_floor_remainder (double x, double y);
1132static SCM scm_i_exact_rational_floor_remainder (SCM x, SCM y);
1133
1134SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
1135 (SCM x, SCM y),
1136 "Return the real number @var{r} such that\n"
1137 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1138 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1139 "@lisp\n"
1140 "(floor-remainder 123 10) @result{} 3\n"
1141 "(floor-remainder 123 -10) @result{} -7\n"
1142 "(floor-remainder -123 10) @result{} 7\n"
1143 "(floor-remainder -123 -10) @result{} -3\n"
1144 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1145 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1146 "@end lisp")
1147#define FUNC_NAME s_scm_floor_remainder
1148{
1149 if (SCM_LIKELY (SCM_I_INUMP (x)))
1150 {
1151 scm_t_inum xx = SCM_I_INUM (x);
1152 if (SCM_LIKELY (SCM_I_INUMP (y)))
1153 {
1154 scm_t_inum yy = SCM_I_INUM (y);
1155 if (SCM_UNLIKELY (yy == 0))
1156 scm_num_overflow (s_scm_floor_remainder);
1157 else
1158 {
1159 scm_t_inum rr = xx % yy;
1160 int needs_adjustment;
1161
1162 if (SCM_LIKELY (yy > 0))
1163 needs_adjustment = (rr < 0);
1164 else
1165 needs_adjustment = (rr > 0);
1166
1167 if (needs_adjustment)
1168 rr += yy;
1169 return SCM_I_MAKINUM (rr);
1170 }
1171 }
1172 else if (SCM_BIGP (y))
1173 {
1174 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1175 scm_remember_upto_here_1 (y);
1176 if (sign > 0)
1177 {
1178 if (xx < 0)
1179 {
1180 SCM r = scm_i_mkbig ();
1181 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1182 scm_remember_upto_here_1 (y);
1183 return scm_i_normbig (r);
1184 }
1185 else
1186 return x;
1187 }
1188 else if (xx <= 0)
1189 return x;
1190 else
1191 {
1192 SCM r = scm_i_mkbig ();
1193 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1194 scm_remember_upto_here_1 (y);
1195 return scm_i_normbig (r);
1196 }
1197 }
1198 else if (SCM_REALP (y))
1199 return scm_i_inexact_floor_remainder (xx, SCM_REAL_VALUE (y));
1200 else if (SCM_FRACTIONP (y))
1201 return scm_i_exact_rational_floor_remainder (x, y);
1202 else
fa075d40
AW		 1203 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1204 s_scm_floor_remainder);
8f9da340
MW		 1205 }
1206 else if (SCM_BIGP (x))
1207 {
1208 if (SCM_LIKELY (SCM_I_INUMP (y)))
1209 {
1210 scm_t_inum yy = SCM_I_INUM (y);
1211 if (SCM_UNLIKELY (yy == 0))
1212 scm_num_overflow (s_scm_floor_remainder);
1213 else
1214 {
1215 scm_t_inum rr;
1216 if (yy > 0)
1217 rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
1218 else
1219 rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
1220 scm_remember_upto_here_1 (x);
1221 return SCM_I_MAKINUM (rr);
1222 }
1223 }
1224 else if (SCM_BIGP (y))
1225 {
1226 SCM r = scm_i_mkbig ();
1227 mpz_fdiv_r (SCM_I_BIG_MPZ (r),
1228 SCM_I_BIG_MPZ (x),
1229 SCM_I_BIG_MPZ (y));
1230 scm_remember_upto_here_2 (x, y);
1231 return scm_i_normbig (r);
1232 }
1233 else if (SCM_REALP (y))
1234 return scm_i_inexact_floor_remainder
1235 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1236 else if (SCM_FRACTIONP (y))
1237 return scm_i_exact_rational_floor_remainder (x, y);
1238 else
fa075d40
AW		 1239 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1240 s_scm_floor_remainder);
8f9da340
MW		 1241 }
1242 else if (SCM_REALP (x))
1243 {
1244 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1245 SCM_BIGP (y) || SCM_FRACTIONP (y))
1246 return scm_i_inexact_floor_remainder
1247 (SCM_REAL_VALUE (x), scm_to_double (y));
1248 else
fa075d40
AW		 1249 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1250 s_scm_floor_remainder);
8f9da340
MW		 1251 }
1252 else if (SCM_FRACTIONP (x))
1253 {
1254 if (SCM_REALP (y))
1255 return scm_i_inexact_floor_remainder
1256 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1257 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1258 return scm_i_exact_rational_floor_remainder (x, y);
1259 else
fa075d40
AW		 1260 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1261 s_scm_floor_remainder);
8f9da340
MW		 1262 }
1263 else
fa075d40
AW		 1264 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
1265 s_scm_floor_remainder);
8f9da340
MW		 1266}
1267#undef FUNC_NAME
1268
1269static SCM
1270scm_i_inexact_floor_remainder (double x, double y)
1271{
1272 /* Although it would be more efficient to use fmod here, we can't
1273 because it would in some cases produce results inconsistent with
1274 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1275 close). In particular, when x is very close to a multiple of y,
1276 then r might be either 0.0 or y, but those two cases must
1277 correspond to different choices of q. If r = 0.0 then q must be
1278 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1279 and remainder chooses the other, it would be bad. */
1280 if (SCM_UNLIKELY (y == 0))
1281 scm_num_overflow (s_scm_floor_remainder); /* or return a NaN? */
1282 else
1283 return scm_from_double (x - y * floor (x / y));
1284}
1285
1286static SCM
1287scm_i_exact_rational_floor_remainder (SCM x, SCM y)
1288{
1289 SCM xd = scm_denominator (x);
1290 SCM yd = scm_denominator (y);
1291 SCM r1 = scm_floor_remainder (scm_product (scm_numerator (x), yd),
1292 scm_product (scm_numerator (y), xd));
1293 return scm_divide (r1, scm_product (xd, yd));
1294}
1295
1296
1297static void scm_i_inexact_floor_divide (double x, double y,
1298 SCM *qp, SCM *rp);
1299static void scm_i_exact_rational_floor_divide (SCM x, SCM y,
1300 SCM *qp, SCM *rp);
1301
1302SCM_PRIMITIVE_GENERIC (scm_i_floor_divide, "floor/", 2, 0, 0,
1303 (SCM x, SCM y),
1304 "Return the integer @var{q} and the real number @var{r}\n"
1305 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1306 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1307 "@lisp\n"
1308 "(floor/ 123 10) @result{} 12 and 3\n"
1309 "(floor/ 123 -10) @result{} -13 and -7\n"
1310 "(floor/ -123 10) @result{} -13 and 7\n"
1311 "(floor/ -123 -10) @result{} 12 and -3\n"
1312 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1313 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1314 "@end lisp")
1315#define FUNC_NAME s_scm_i_floor_divide
1316{
1317 SCM q, r;
1318
1319 scm_floor_divide(x, y, &q, &r);
1320 return scm_values (scm_list_2 (q, r));
1321}
1322#undef FUNC_NAME
1323
1324#define s_scm_floor_divide s_scm_i_floor_divide
1325#define g_scm_floor_divide g_scm_i_floor_divide
1326
1327void
1328scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
1329{
1330 if (SCM_LIKELY (SCM_I_INUMP (x)))
1331 {
1332 scm_t_inum xx = SCM_I_INUM (x);
1333 if (SCM_LIKELY (SCM_I_INUMP (y)))
1334 {
1335 scm_t_inum yy = SCM_I_INUM (y);
1336 if (SCM_UNLIKELY (yy == 0))
1337 scm_num_overflow (s_scm_floor_divide);
1338 else
1339 {
1340 scm_t_inum qq = xx / yy;
1341 scm_t_inum rr = xx % yy;
1342 int needs_adjustment;
1343
1344 if (SCM_LIKELY (yy > 0))
1345 needs_adjustment = (rr < 0);
1346 else
1347 needs_adjustment = (rr > 0);
1348
1349 if (needs_adjustment)
1350 {
1351 rr += yy;
1352 qq--;
1353 }
1354
1355 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1356 *qp = SCM_I_MAKINUM (qq);
1357 else
1358 *qp = scm_i_inum2big (qq);
1359 *rp = SCM_I_MAKINUM (rr);
1360 }
1361 return;
1362 }
1363 else if (SCM_BIGP (y))
1364 {
1365 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1366 scm_remember_upto_here_1 (y);
1367 if (sign > 0)
1368 {
1369 if (xx < 0)
1370 {
1371 SCM r = scm_i_mkbig ();
1372 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1373 scm_remember_upto_here_1 (y);
1374 *qp = SCM_I_MAKINUM (-1);
1375 *rp = scm_i_normbig (r);
1376 }
1377 else
1378 {
1379 *qp = SCM_INUM0;
1380 *rp = x;
1381 }
1382 }
1383 else if (xx <= 0)
1384 {
1385 *qp = SCM_INUM0;
1386 *rp = x;
1387 }
1388 else
1389 {
1390 SCM r = scm_i_mkbig ();
1391 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1392 scm_remember_upto_here_1 (y);
1393 *qp = SCM_I_MAKINUM (-1);
1394 *rp = scm_i_normbig (r);
1395 }
1396 return;
1397 }
1398 else if (SCM_REALP (y))
1399 return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp);
1400 else if (SCM_FRACTIONP (y))
1401 return scm_i_exact_rational_floor_divide (x, y, qp, rp);
1402 else
1403 return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1404 s_scm_floor_divide, qp, rp);
1405 }
1406 else if (SCM_BIGP (x))
1407 {
1408 if (SCM_LIKELY (SCM_I_INUMP (y)))
1409 {
1410 scm_t_inum yy = SCM_I_INUM (y);
1411 if (SCM_UNLIKELY (yy == 0))
1412 scm_num_overflow (s_scm_floor_divide);
1413 else
1414 {
1415 SCM q = scm_i_mkbig ();
1416 SCM r = scm_i_mkbig ();
1417 if (yy > 0)
1418 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1419 SCM_I_BIG_MPZ (x), yy);
1420 else
1421 {
1422 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1423 SCM_I_BIG_MPZ (x), -yy);
1424 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1425 }
1426 scm_remember_upto_here_1 (x);
1427 *qp = scm_i_normbig (q);
1428 *rp = scm_i_normbig (r);
1429 }
1430 return;
1431 }
1432 else if (SCM_BIGP (y))
1433 {
1434 SCM q = scm_i_mkbig ();
1435 SCM r = scm_i_mkbig ();
1436 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1437 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
1438 scm_remember_upto_here_2 (x, y);
1439 *qp = scm_i_normbig (q);
1440 *rp = scm_i_normbig (r);
1441 return;
1442 }
1443 else if (SCM_REALP (y))
1444 return scm_i_inexact_floor_divide
1445 (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
1446 else if (SCM_FRACTIONP (y))
1447 return scm_i_exact_rational_floor_divide (x, y, qp, rp);
1448 else
1449 return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1450 s_scm_floor_divide, qp, rp);
1451 }
1452 else if (SCM_REALP (x))
1453 {
1454 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1455 SCM_BIGP (y) || SCM_FRACTIONP (y))
1456 return scm_i_inexact_floor_divide
1457 (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
1458 else
1459 return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1460 s_scm_floor_divide, qp, rp);
1461 }
1462 else if (SCM_FRACTIONP (x))
1463 {
1464 if (SCM_REALP (y))
1465 return scm_i_inexact_floor_divide
1466 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
1467 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1468 return scm_i_exact_rational_floor_divide (x, y, qp, rp);
1469 else
1470 return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1471 s_scm_floor_divide, qp, rp);
1472 }
1473 else
1474 return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1,
1475 s_scm_floor_divide, qp, rp);
1476}
1477
1478static void
1479scm_i_inexact_floor_divide (double x, double y, SCM *qp, SCM *rp)
1480{
1481 if (SCM_UNLIKELY (y == 0))
1482 scm_num_overflow (s_scm_floor_divide); /* or return a NaN? */
1483 else
1484 {
1485 double q = floor (x / y);
1486 double r = x - q * y;
1487 *qp = scm_from_double (q);
1488 *rp = scm_from_double (r);
1489 }
1490}
1491
1492static void
1493scm_i_exact_rational_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
1494{
1495 SCM r1;
1496 SCM xd = scm_denominator (x);
1497 SCM yd = scm_denominator (y);
1498
1499 scm_floor_divide (scm_product (scm_numerator (x), yd),
1500 scm_product (scm_numerator (y), xd),
1501 qp, &r1);
1502 *rp = scm_divide (r1, scm_product (xd, yd));
1503}
1504
1505static SCM scm_i_inexact_ceiling_quotient (double x, double y);
1506static SCM scm_i_exact_rational_ceiling_quotient (SCM x, SCM y);
1507
1508SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
1509 (SCM x, SCM y),
1510 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1511 "@lisp\n"
1512 "(ceiling-quotient 123 10) @result{} 13\n"
1513 "(ceiling-quotient 123 -10) @result{} -12\n"
1514 "(ceiling-quotient -123 10) @result{} -12\n"
1515 "(ceiling-quotient -123 -10) @result{} 13\n"
1516 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1517 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1518 "@end lisp")
1519#define FUNC_NAME s_scm_ceiling_quotient
1520{
1521 if (SCM_LIKELY (SCM_I_INUMP (x)))
1522 {
1523 scm_t_inum xx = SCM_I_INUM (x);
1524 if (SCM_LIKELY (SCM_I_INUMP (y)))
1525 {
1526 scm_t_inum yy = SCM_I_INUM (y);
1527 if (SCM_UNLIKELY (yy == 0))
1528 scm_num_overflow (s_scm_ceiling_quotient);
1529 else
1530 {
1531 scm_t_inum xx1 = xx;
1532 scm_t_inum qq;
1533 if (SCM_LIKELY (yy > 0))
1534 {
1535 if (SCM_LIKELY (xx >= 0))
1536 xx1 = xx + yy - 1;
1537 }
8f9da340
MW		 1538 else if (xx < 0)
1539 xx1 = xx + yy + 1;
1540 qq = xx1 / yy;
1541 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1542 return SCM_I_MAKINUM (qq);
1543 else
1544 return scm_i_inum2big (qq);
1545 }
1546 }
1547 else if (SCM_BIGP (y))
1548 {
1549 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1550 scm_remember_upto_here_1 (y);
1551 if (SCM_LIKELY (sign > 0))
1552 {
1553 if (SCM_LIKELY (xx > 0))
1554 return SCM_INUM1;
1555 else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
1556 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
1557 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
1558 {
1559 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1560 scm_remember_upto_here_1 (y);
1561 return SCM_I_MAKINUM (-1);
1562 }
1563 else
1564 return SCM_INUM0;
1565 }
1566 else if (xx >= 0)
1567 return SCM_INUM0;
1568 else
1569 return SCM_INUM1;
1570 }
1571 else if (SCM_REALP (y))
1572 return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
1573 else if (SCM_FRACTIONP (y))
1574 return scm_i_exact_rational_ceiling_quotient (x, y);
1575 else
fa075d40
AW		 1576 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1577 s_scm_ceiling_quotient);
8f9da340
MW		 1578 }
1579 else if (SCM_BIGP (x))
1580 {
1581 if (SCM_LIKELY (SCM_I_INUMP (y)))
1582 {
1583 scm_t_inum yy = SCM_I_INUM (y);
1584 if (SCM_UNLIKELY (yy == 0))
1585 scm_num_overflow (s_scm_ceiling_quotient);
1586 else if (SCM_UNLIKELY (yy == 1))
1587 return x;
1588 else
1589 {
1590 SCM q = scm_i_mkbig ();
1591 if (yy > 0)
1592 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
1593 else
1594 {
1595 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
1596 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1597 }
1598 scm_remember_upto_here_1 (x);
1599 return scm_i_normbig (q);
1600 }
1601 }
1602 else if (SCM_BIGP (y))
1603 {
1604 SCM q = scm_i_mkbig ();
1605 mpz_cdiv_q (SCM_I_BIG_MPZ (q),
1606 SCM_I_BIG_MPZ (x),
1607 SCM_I_BIG_MPZ (y));
1608 scm_remember_upto_here_2 (x, y);
1609 return scm_i_normbig (q);
1610 }
1611 else if (SCM_REALP (y))
1612 return scm_i_inexact_ceiling_quotient
1613 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1614 else if (SCM_FRACTIONP (y))
1615 return scm_i_exact_rational_ceiling_quotient (x, y);
1616 else
fa075d40
AW		 1617 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1618 s_scm_ceiling_quotient);
8f9da340
MW		 1619 }
1620 else if (SCM_REALP (x))
1621 {
1622 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1623 SCM_BIGP (y) || SCM_FRACTIONP (y))
1624 return scm_i_inexact_ceiling_quotient
1625 (SCM_REAL_VALUE (x), scm_to_double (y));
1626 else
fa075d40
AW		 1627 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1628 s_scm_ceiling_quotient);
8f9da340
MW		 1629 }
1630 else if (SCM_FRACTIONP (x))
1631 {
1632 if (SCM_REALP (y))
1633 return scm_i_inexact_ceiling_quotient
1634 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1635 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1636 return scm_i_exact_rational_ceiling_quotient (x, y);
1637 else
fa075d40
AW		 1638 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1639 s_scm_ceiling_quotient);
8f9da340
MW		 1640 }
1641 else
fa075d40
AW		 1642 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
1643 s_scm_ceiling_quotient);
8f9da340
MW		 1644}
1645#undef FUNC_NAME
1646
1647static SCM
1648scm_i_inexact_ceiling_quotient (double x, double y)
1649{
1650 if (SCM_UNLIKELY (y == 0))
1651 scm_num_overflow (s_scm_ceiling_quotient); /* or return a NaN? */
1652 else
1653 return scm_from_double (ceil (x / y));
1654}
1655
1656static SCM
1657scm_i_exact_rational_ceiling_quotient (SCM x, SCM y)
1658{
1659 return scm_ceiling_quotient
1660 (scm_product (scm_numerator (x), scm_denominator (y)),
1661 scm_product (scm_numerator (y), scm_denominator (x)));
1662}
1663
1664static SCM scm_i_inexact_ceiling_remainder (double x, double y);
1665static SCM scm_i_exact_rational_ceiling_remainder (SCM x, SCM y);
1666
1667SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
1668 (SCM x, SCM y),
1669 "Return the real number @var{r} such that\n"
1670 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1671 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1672 "@lisp\n"
1673 "(ceiling-remainder 123 10) @result{} -7\n"
1674 "(ceiling-remainder 123 -10) @result{} 3\n"
1675 "(ceiling-remainder -123 10) @result{} -3\n"
1676 "(ceiling-remainder -123 -10) @result{} 7\n"
1677 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1678 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1679 "@end lisp")
1680#define FUNC_NAME s_scm_ceiling_remainder
1681{
1682 if (SCM_LIKELY (SCM_I_INUMP (x)))
1683 {
1684 scm_t_inum xx = SCM_I_INUM (x);
1685 if (SCM_LIKELY (SCM_I_INUMP (y)))
1686 {
1687 scm_t_inum yy = SCM_I_INUM (y);
1688 if (SCM_UNLIKELY (yy == 0))
1689 scm_num_overflow (s_scm_ceiling_remainder);
1690 else
1691 {
1692 scm_t_inum rr = xx % yy;
1693 int needs_adjustment;
1694
1695 if (SCM_LIKELY (yy > 0))
1696 needs_adjustment = (rr > 0);
1697 else
1698 needs_adjustment = (rr < 0);
1699
1700 if (needs_adjustment)
1701 rr -= yy;
1702 return SCM_I_MAKINUM (rr);
1703 }
1704 }
1705 else if (SCM_BIGP (y))
1706 {
1707 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1708 scm_remember_upto_here_1 (y);
1709 if (SCM_LIKELY (sign > 0))
1710 {
1711 if (SCM_LIKELY (xx > 0))
1712 {
1713 SCM r = scm_i_mkbig ();
1714 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1715 scm_remember_upto_here_1 (y);
1716 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
1717 return scm_i_normbig (r);
1718 }
1719 else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
1720 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
1721 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
1722 {
1723 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1724 scm_remember_upto_here_1 (y);
1725 return SCM_INUM0;
1726 }
1727 else
1728 return x;
1729 }
1730 else if (xx >= 0)
1731 return x;
1732 else
1733 {
1734 SCM r = scm_i_mkbig ();
1735 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1736 scm_remember_upto_here_1 (y);
1737 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
1738 return scm_i_normbig (r);
1739 }
1740 }
1741 else if (SCM_REALP (y))
1742 return scm_i_inexact_ceiling_remainder (xx, SCM_REAL_VALUE (y));
1743 else if (SCM_FRACTIONP (y))
1744 return scm_i_exact_rational_ceiling_remainder (x, y);
1745 else
fa075d40
AW		 1746 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1747 s_scm_ceiling_remainder);
8f9da340
MW		 1748 }
1749 else if (SCM_BIGP (x))
1750 {
1751 if (SCM_LIKELY (SCM_I_INUMP (y)))
1752 {
1753 scm_t_inum yy = SCM_I_INUM (y);
1754 if (SCM_UNLIKELY (yy == 0))
1755 scm_num_overflow (s_scm_ceiling_remainder);
1756 else
1757 {
1758 scm_t_inum rr;
1759 if (yy > 0)
1760 rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
1761 else
1762 rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), -yy);
1763 scm_remember_upto_here_1 (x);
1764 return SCM_I_MAKINUM (rr);
1765 }
1766 }
1767 else if (SCM_BIGP (y))
1768 {
1769 SCM r = scm_i_mkbig ();
1770 mpz_cdiv_r (SCM_I_BIG_MPZ (r),
1771 SCM_I_BIG_MPZ (x),
1772 SCM_I_BIG_MPZ (y));
1773 scm_remember_upto_here_2 (x, y);
1774 return scm_i_normbig (r);
1775 }
1776 else if (SCM_REALP (y))
1777 return scm_i_inexact_ceiling_remainder
1778 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1779 else if (SCM_FRACTIONP (y))
1780 return scm_i_exact_rational_ceiling_remainder (x, y);
1781 else
fa075d40
AW		 1782 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1783 s_scm_ceiling_remainder);
8f9da340
MW		 1784 }
1785 else if (SCM_REALP (x))
1786 {
1787 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1788 SCM_BIGP (y) || SCM_FRACTIONP (y))
1789 return scm_i_inexact_ceiling_remainder
1790 (SCM_REAL_VALUE (x), scm_to_double (y));
1791 else
fa075d40
AW		 1792 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1793 s_scm_ceiling_remainder);
8f9da340
MW		 1794 }
1795 else if (SCM_FRACTIONP (x))
1796 {
1797 if (SCM_REALP (y))
1798 return scm_i_inexact_ceiling_remainder
1799 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1800 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1801 return scm_i_exact_rational_ceiling_remainder (x, y);
1802 else
fa075d40
AW		 1803 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1804 s_scm_ceiling_remainder);
8f9da340
MW		 1805 }
1806 else
fa075d40
AW		 1807 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
1808 s_scm_ceiling_remainder);
8f9da340
MW		 1809}
1810#undef FUNC_NAME
1811
1812static SCM
1813scm_i_inexact_ceiling_remainder (double x, double y)
1814{
1815 /* Although it would be more efficient to use fmod here, we can't
1816 because it would in some cases produce results inconsistent with
1817 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1818 close). In particular, when x is very close to a multiple of y,
1819 then r might be either 0.0 or -y, but those two cases must
1820 correspond to different choices of q. If r = 0.0 then q must be
1821 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1822 and remainder chooses the other, it would be bad. */
1823 if (SCM_UNLIKELY (y == 0))
1824 scm_num_overflow (s_scm_ceiling_remainder); /* or return a NaN? */
1825 else
1826 return scm_from_double (x - y * ceil (x / y));
1827}
1828
1829static SCM
1830scm_i_exact_rational_ceiling_remainder (SCM x, SCM y)
1831{
1832 SCM xd = scm_denominator (x);
1833 SCM yd = scm_denominator (y);
1834 SCM r1 = scm_ceiling_remainder (scm_product (scm_numerator (x), yd),
1835 scm_product (scm_numerator (y), xd));
1836 return scm_divide (r1, scm_product (xd, yd));
1837}
1838
1839static void scm_i_inexact_ceiling_divide (double x, double y,
1840 SCM *qp, SCM *rp);
1841static void scm_i_exact_rational_ceiling_divide (SCM x, SCM y,
1842 SCM *qp, SCM *rp);
1843
1844SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide, "ceiling/", 2, 0, 0,
1845 (SCM x, SCM y),
1846 "Return the integer @var{q} and the real number @var{r}\n"
1847 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1848 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1849 "@lisp\n"
1850 "(ceiling/ 123 10) @result{} 13 and -7\n"
1851 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1852 "(ceiling/ -123 10) @result{} -12 and -3\n"
1853 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1854 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1855 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1856 "@end lisp")
1857#define FUNC_NAME s_scm_i_ceiling_divide
1858{
1859 SCM q, r;
1860
1861 scm_ceiling_divide(x, y, &q, &r);
1862 return scm_values (scm_list_2 (q, r));
1863}
1864#undef FUNC_NAME
1865
1866#define s_scm_ceiling_divide s_scm_i_ceiling_divide
1867#define g_scm_ceiling_divide g_scm_i_ceiling_divide
1868
1869void
1870scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
1871{
1872 if (SCM_LIKELY (SCM_I_INUMP (x)))
1873 {
1874 scm_t_inum xx = SCM_I_INUM (x);
1875 if (SCM_LIKELY (SCM_I_INUMP (y)))
1876 {
1877 scm_t_inum yy = SCM_I_INUM (y);
1878 if (SCM_UNLIKELY (yy == 0))
1879 scm_num_overflow (s_scm_ceiling_divide);
1880 else
1881 {
1882 scm_t_inum qq = xx / yy;
1883 scm_t_inum rr = xx % yy;
1884 int needs_adjustment;
1885
1886 if (SCM_LIKELY (yy > 0))
1887 needs_adjustment = (rr > 0);
1888 else
1889 needs_adjustment = (rr < 0);
1890
1891 if (needs_adjustment)
1892 {
1893 rr -= yy;
1894 qq++;
1895 }
1896 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1897 *qp = SCM_I_MAKINUM (qq);
1898 else
1899 *qp = scm_i_inum2big (qq);
1900 *rp = SCM_I_MAKINUM (rr);
1901 }
1902 return;
1903 }
1904 else if (SCM_BIGP (y))
1905 {
1906 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1907 scm_remember_upto_here_1 (y);
1908 if (SCM_LIKELY (sign > 0))
1909 {
1910 if (SCM_LIKELY (xx > 0))
1911 {
1912 SCM r = scm_i_mkbig ();
1913 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1914 scm_remember_upto_here_1 (y);
1915 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
1916 *qp = SCM_INUM1;
1917 *rp = scm_i_normbig (r);
1918 }
1919 else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
1920 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
1921 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
1922 {
1923 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1924 scm_remember_upto_here_1 (y);
1925 *qp = SCM_I_MAKINUM (-1);
1926 *rp = SCM_INUM0;
1927 }
1928 else
1929 {
1930 *qp = SCM_INUM0;
1931 *rp = x;
1932 }
1933 }
1934 else if (xx >= 0)
1935 {
1936 *qp = SCM_INUM0;
1937 *rp = x;
1938 }
1939 else
1940 {
1941 SCM r = scm_i_mkbig ();
1942 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1943 scm_remember_upto_here_1 (y);
1944 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
1945 *qp = SCM_INUM1;
1946 *rp = scm_i_normbig (r);
1947 }
1948 return;
1949 }
1950 else if (SCM_REALP (y))
1951 return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp);
1952 else if (SCM_FRACTIONP (y))
1953 return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
1954 else
1955 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
1956 s_scm_ceiling_divide, qp, rp);
1957 }
1958 else if (SCM_BIGP (x))
1959 {
1960 if (SCM_LIKELY (SCM_I_INUMP (y)))
1961 {
1962 scm_t_inum yy = SCM_I_INUM (y);
1963 if (SCM_UNLIKELY (yy == 0))
1964 scm_num_overflow (s_scm_ceiling_divide);
1965 else
1966 {
1967 SCM q = scm_i_mkbig ();
1968 SCM r = scm_i_mkbig ();
1969 if (yy > 0)
1970 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1971 SCM_I_BIG_MPZ (x), yy);
1972 else
1973 {
1974 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1975 SCM_I_BIG_MPZ (x), -yy);
1976 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1977 }
1978 scm_remember_upto_here_1 (x);
1979 *qp = scm_i_normbig (q);
1980 *rp = scm_i_normbig (r);
1981 }
1982 return;
1983 }
1984 else if (SCM_BIGP (y))
1985 {
1986 SCM q = scm_i_mkbig ();
1987 SCM r = scm_i_mkbig ();
1988 mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1989 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
1990 scm_remember_upto_here_2 (x, y);
1991 *qp = scm_i_normbig (q);
1992 *rp = scm_i_normbig (r);
1993 return;
1994 }
1995 else if (SCM_REALP (y))
1996 return scm_i_inexact_ceiling_divide
1997 (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
1998 else if (SCM_FRACTIONP (y))
1999 return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
2000 else
2001 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2002 s_scm_ceiling_divide, qp, rp);
2003 }
2004 else if (SCM_REALP (x))
2005 {
2006 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2007 SCM_BIGP (y) || SCM_FRACTIONP (y))
2008 return scm_i_inexact_ceiling_divide
2009 (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
2010 else
2011 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2012 s_scm_ceiling_divide, qp, rp);
2013 }
2014 else if (SCM_FRACTIONP (x))
2015 {
2016 if (SCM_REALP (y))
2017 return scm_i_inexact_ceiling_divide
2018 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
2019 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2020 return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
2021 else
2022 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2023 s_scm_ceiling_divide, qp, rp);
2024 }
2025 else
2026 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
2027 s_scm_ceiling_divide, qp, rp);
2028}
2029
2030static void
2031scm_i_inexact_ceiling_divide (double x, double y, SCM *qp, SCM *rp)
2032{
2033 if (SCM_UNLIKELY (y == 0))
2034 scm_num_overflow (s_scm_ceiling_divide); /* or return a NaN? */
2035 else
2036 {
2037 double q = ceil (x / y);
2038 double r = x - q * y;
2039 *qp = scm_from_double (q);
2040 *rp = scm_from_double (r);
2041 }
2042}
2043
2044static void
2045scm_i_exact_rational_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2046{
2047 SCM r1;
2048 SCM xd = scm_denominator (x);
2049 SCM yd = scm_denominator (y);
2050
2051 scm_ceiling_divide (scm_product (scm_numerator (x), yd),
2052 scm_product (scm_numerator (y), xd),
2053 qp, &r1);
2054 *rp = scm_divide (r1, scm_product (xd, yd));
2055}
2056
2057static SCM scm_i_inexact_truncate_quotient (double x, double y);
2058static SCM scm_i_exact_rational_truncate_quotient (SCM x, SCM y);
2059
2060SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
2061 (SCM x, SCM y),
2062 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2063 "@lisp\n"
2064 "(truncate-quotient 123 10) @result{} 12\n"
2065 "(truncate-quotient 123 -10) @result{} -12\n"
2066 "(truncate-quotient -123 10) @result{} -12\n"
2067 "(truncate-quotient -123 -10) @result{} 12\n"
2068 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2069 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2070 "@end lisp")
2071#define FUNC_NAME s_scm_truncate_quotient
2072{
2073 if (SCM_LIKELY (SCM_I_INUMP (x)))
2074 {
2075 scm_t_inum xx = SCM_I_INUM (x);
2076 if (SCM_LIKELY (SCM_I_INUMP (y)))
2077 {
2078 scm_t_inum yy = SCM_I_INUM (y);
2079 if (SCM_UNLIKELY (yy == 0))
2080 scm_num_overflow (s_scm_truncate_quotient);
2081 else
2082 {
2083 scm_t_inum qq = xx / yy;
2084 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2085 return SCM_I_MAKINUM (qq);
2086 else
2087 return scm_i_inum2big (qq);
2088 }
2089 }
2090 else if (SCM_BIGP (y))
2091 {
2092 if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2093 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2094 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2095 {
2096 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2097 scm_remember_upto_here_1 (y);
2098 return SCM_I_MAKINUM (-1);
2099 }
2100 else
2101 return SCM_INUM0;
2102 }
2103 else if (SCM_REALP (y))
2104 return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y));
2105 else if (SCM_FRACTIONP (y))
2106 return scm_i_exact_rational_truncate_quotient (x, y);
2107 else
fa075d40
AW		 2108 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2109 s_scm_truncate_quotient);
8f9da340
MW		 2110 }
2111 else if (SCM_BIGP (x))
2112 {
2113 if (SCM_LIKELY (SCM_I_INUMP (y)))
2114 {
2115 scm_t_inum yy = SCM_I_INUM (y);
2116 if (SCM_UNLIKELY (yy == 0))
2117 scm_num_overflow (s_scm_truncate_quotient);
2118 else if (SCM_UNLIKELY (yy == 1))
2119 return x;
2120 else
2121 {
2122 SCM q = scm_i_mkbig ();
2123 if (yy > 0)
2124 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
2125 else
2126 {
2127 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
2128 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2129 }
2130 scm_remember_upto_here_1 (x);
2131 return scm_i_normbig (q);
2132 }
2133 }
2134 else if (SCM_BIGP (y))
2135 {
2136 SCM q = scm_i_mkbig ();
2137 mpz_tdiv_q (SCM_I_BIG_MPZ (q),
2138 SCM_I_BIG_MPZ (x),
2139 SCM_I_BIG_MPZ (y));
2140 scm_remember_upto_here_2 (x, y);
2141 return scm_i_normbig (q);
2142 }
2143 else if (SCM_REALP (y))
2144 return scm_i_inexact_truncate_quotient
2145 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2146 else if (SCM_FRACTIONP (y))
2147 return scm_i_exact_rational_truncate_quotient (x, y);
2148 else
fa075d40
AW		 2149 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2150 s_scm_truncate_quotient);
8f9da340
MW		 2151 }
2152 else if (SCM_REALP (x))
2153 {
2154 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2155 SCM_BIGP (y) || SCM_FRACTIONP (y))
2156 return scm_i_inexact_truncate_quotient
2157 (SCM_REAL_VALUE (x), scm_to_double (y));
2158 else
fa075d40
AW		 2159 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2160 s_scm_truncate_quotient);
8f9da340
MW		 2161 }
2162 else if (SCM_FRACTIONP (x))
2163 {
2164 if (SCM_REALP (y))
2165 return scm_i_inexact_truncate_quotient
2166 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2167 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2168 return scm_i_exact_rational_truncate_quotient (x, y);
2169 else
fa075d40
AW		 2170 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2171 s_scm_truncate_quotient);
8f9da340
MW		 2172 }
2173 else
fa075d40
AW		 2174 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
2175 s_scm_truncate_quotient);
8f9da340
MW		 2176}
2177#undef FUNC_NAME
2178
2179static SCM
2180scm_i_inexact_truncate_quotient (double x, double y)
2181{
2182 if (SCM_UNLIKELY (y == 0))
2183 scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
2184 else
c251ab63 2185 return scm_from_double (trunc (x / y));
8f9da340
MW		 2186}
2187
2188static SCM
2189scm_i_exact_rational_truncate_quotient (SCM x, SCM y)
2190{
2191 return scm_truncate_quotient
2192 (scm_product (scm_numerator (x), scm_denominator (y)),
2193 scm_product (scm_numerator (y), scm_denominator (x)));
2194}
2195
2196static SCM scm_i_inexact_truncate_remainder (double x, double y);
2197static SCM scm_i_exact_rational_truncate_remainder (SCM x, SCM y);
2198
2199SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
2200 (SCM x, SCM y),
2201 "Return the real number @var{r} such that\n"
2202 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2203 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2204 "@lisp\n"
2205 "(truncate-remainder 123 10) @result{} 3\n"
2206 "(truncate-remainder 123 -10) @result{} 3\n"
2207 "(truncate-remainder -123 10) @result{} -3\n"
2208 "(truncate-remainder -123 -10) @result{} -3\n"
2209 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2210 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2211 "@end lisp")
2212#define FUNC_NAME s_scm_truncate_remainder
2213{
2214 if (SCM_LIKELY (SCM_I_INUMP (x)))
2215 {
2216 scm_t_inum xx = SCM_I_INUM (x);
2217 if (SCM_LIKELY (SCM_I_INUMP (y)))
2218 {
2219 scm_t_inum yy = SCM_I_INUM (y);
2220 if (SCM_UNLIKELY (yy == 0))
2221 scm_num_overflow (s_scm_truncate_remainder);
2222 else
2223 return SCM_I_MAKINUM (xx % yy);
2224 }
2225 else if (SCM_BIGP (y))
2226 {
2227 if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2228 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2229 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2230 {
2231 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2232 scm_remember_upto_here_1 (y);
2233 return SCM_INUM0;
2234 }
2235 else
2236 return x;
2237 }
2238 else if (SCM_REALP (y))
2239 return scm_i_inexact_truncate_remainder (xx, SCM_REAL_VALUE (y));
2240 else if (SCM_FRACTIONP (y))
2241 return scm_i_exact_rational_truncate_remainder (x, y);
2242 else
fa075d40
AW		 2243 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2244 s_scm_truncate_remainder);
8f9da340
MW		 2245 }
2246 else if (SCM_BIGP (x))
2247 {
2248 if (SCM_LIKELY (SCM_I_INUMP (y)))
2249 {
2250 scm_t_inum yy = SCM_I_INUM (y);
2251 if (SCM_UNLIKELY (yy == 0))
2252 scm_num_overflow (s_scm_truncate_remainder);
2253 else
2254 {
2255 scm_t_inum rr = (mpz_tdiv_ui (SCM_I_BIG_MPZ (x),
2256 (yy > 0) ? yy : -yy)
2257 * mpz_sgn (SCM_I_BIG_MPZ (x)));
2258 scm_remember_upto_here_1 (x);
2259 return SCM_I_MAKINUM (rr);
2260 }
2261 }
2262 else if (SCM_BIGP (y))
2263 {
2264 SCM r = scm_i_mkbig ();
2265 mpz_tdiv_r (SCM_I_BIG_MPZ (r),
2266 SCM_I_BIG_MPZ (x),
2267 SCM_I_BIG_MPZ (y));
2268 scm_remember_upto_here_2 (x, y);
2269 return scm_i_normbig (r);
2270 }
2271 else if (SCM_REALP (y))
2272 return scm_i_inexact_truncate_remainder
2273 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2274 else if (SCM_FRACTIONP (y))
2275 return scm_i_exact_rational_truncate_remainder (x, y);
2276 else
fa075d40
AW		 2277 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2278 s_scm_truncate_remainder);
8f9da340
MW		 2279 }
2280 else if (SCM_REALP (x))
2281 {
2282 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2283 SCM_BIGP (y) || SCM_FRACTIONP (y))
2284 return scm_i_inexact_truncate_remainder
2285 (SCM_REAL_VALUE (x), scm_to_double (y));
2286 else
fa075d40
AW		 2287 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2288 s_scm_truncate_remainder);
8f9da340
MW		 2289 }
2290 else if (SCM_FRACTIONP (x))
2291 {
2292 if (SCM_REALP (y))
2293 return scm_i_inexact_truncate_remainder
2294 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2295 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2296 return scm_i_exact_rational_truncate_remainder (x, y);
2297 else
fa075d40
AW		 2298 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2299 s_scm_truncate_remainder);
8f9da340
MW		 2300 }
2301 else
fa075d40
AW		 2302 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
2303 s_scm_truncate_remainder);
8f9da340
MW		 2304}
2305#undef FUNC_NAME
2306
2307static SCM
2308scm_i_inexact_truncate_remainder (double x, double y)
2309{
2310 /* Although it would be more efficient to use fmod here, we can't
2311 because it would in some cases produce results inconsistent with
2312 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2313 close). In particular, when x is very close to a multiple of y,
2314 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2315 correspond to different choices of q. If quotient chooses one and
2316 remainder chooses the other, it would be bad. */
2317 if (SCM_UNLIKELY (y == 0))
2318 scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
2319 else
c251ab63 2320 return scm_from_double (x - y * trunc (x / y));
8f9da340
MW		 2321}
2322
2323static SCM
2324scm_i_exact_rational_truncate_remainder (SCM x, SCM y)
2325{
2326 SCM xd = scm_denominator (x);
2327 SCM yd = scm_denominator (y);
2328 SCM r1 = scm_truncate_remainder (scm_product (scm_numerator (x), yd),
2329 scm_product (scm_numerator (y), xd));
2330 return scm_divide (r1, scm_product (xd, yd));
2331}
2332
2333
2334static void scm_i_inexact_truncate_divide (double x, double y,
2335 SCM *qp, SCM *rp);
2336static void scm_i_exact_rational_truncate_divide (SCM x, SCM y,
2337 SCM *qp, SCM *rp);
2338
2339SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide, "truncate/", 2, 0, 0,
2340 (SCM x, SCM y),
2341 "Return the integer @var{q} and the real number @var{r}\n"
2342 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2343 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2344 "@lisp\n"
2345 "(truncate/ 123 10) @result{} 12 and 3\n"
2346 "(truncate/ 123 -10) @result{} -12 and 3\n"
2347 "(truncate/ -123 10) @result{} -12 and -3\n"
2348 "(truncate/ -123 -10) @result{} 12 and -3\n"
2349 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2350 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2351 "@end lisp")
2352#define FUNC_NAME s_scm_i_truncate_divide
2353{
2354 SCM q, r;
2355
2356 scm_truncate_divide(x, y, &q, &r);
2357 return scm_values (scm_list_2 (q, r));
2358}
2359#undef FUNC_NAME
2360
2361#define s_scm_truncate_divide s_scm_i_truncate_divide
2362#define g_scm_truncate_divide g_scm_i_truncate_divide
2363
2364void
2365scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2366{
2367 if (SCM_LIKELY (SCM_I_INUMP (x)))
2368 {
2369 scm_t_inum xx = SCM_I_INUM (x);
2370 if (SCM_LIKELY (SCM_I_INUMP (y)))
2371 {
2372 scm_t_inum yy = SCM_I_INUM (y);
2373 if (SCM_UNLIKELY (yy == 0))
2374 scm_num_overflow (s_scm_truncate_divide);
2375 else
2376 {
2377 scm_t_inum qq = xx / yy;
2378 scm_t_inum rr = xx % yy;
2379 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2380 *qp = SCM_I_MAKINUM (qq);
2381 else
2382 *qp = scm_i_inum2big (qq);
2383 *rp = SCM_I_MAKINUM (rr);
2384 }
2385 return;
2386 }
2387 else if (SCM_BIGP (y))
2388 {
2389 if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2390 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2391 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2392 {
2393 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2394 scm_remember_upto_here_1 (y);
2395 *qp = SCM_I_MAKINUM (-1);
2396 *rp = SCM_INUM0;
2397 }
2398 else
2399 {
2400 *qp = SCM_INUM0;
2401 *rp = x;
2402 }
2403 return;
2404 }
2405 else if (SCM_REALP (y))
2406 return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp);
2407 else if (SCM_FRACTIONP (y))
2408 return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
2409 else
2410 return two_valued_wta_dispatch_2
2411 (g_scm_truncate_divide, x, y, SCM_ARG2,
2412 s_scm_truncate_divide, qp, rp);
2413 }
2414 else if (SCM_BIGP (x))
2415 {
2416 if (SCM_LIKELY (SCM_I_INUMP (y)))
2417 {
2418 scm_t_inum yy = SCM_I_INUM (y);
2419 if (SCM_UNLIKELY (yy == 0))
2420 scm_num_overflow (s_scm_truncate_divide);
2421 else
2422 {
2423 SCM q = scm_i_mkbig ();
2424 scm_t_inum rr;
2425 if (yy > 0)
2426 rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
2427 SCM_I_BIG_MPZ (x), yy);
2428 else
2429 {
2430 rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
2431 SCM_I_BIG_MPZ (x), -yy);
2432 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2433 }
2434 rr *= mpz_sgn (SCM_I_BIG_MPZ (x));
2435 scm_remember_upto_here_1 (x);
2436 *qp = scm_i_normbig (q);
2437 *rp = SCM_I_MAKINUM (rr);
2438 }
2439 return;
2440 }
2441 else if (SCM_BIGP (y))
2442 {
2443 SCM q = scm_i_mkbig ();
2444 SCM r = scm_i_mkbig ();
2445 mpz_tdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2446 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2447 scm_remember_upto_here_2 (x, y);
2448 *qp = scm_i_normbig (q);
2449 *rp = scm_i_normbig (r);
2450 }
2451 else if (SCM_REALP (y))
2452 return scm_i_inexact_truncate_divide
2453 (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
2454 else if (SCM_FRACTIONP (y))
2455 return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
2456 else
2457 return two_valued_wta_dispatch_2
2458 (g_scm_truncate_divide, x, y, SCM_ARG2,
2459 s_scm_truncate_divide, qp, rp);
2460 }
2461 else if (SCM_REALP (x))
2462 {
2463 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2464 SCM_BIGP (y) || SCM_FRACTIONP (y))
2465 return scm_i_inexact_truncate_divide
2466 (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
2467 else
2468 return two_valued_wta_dispatch_2
2469 (g_scm_truncate_divide, x, y, SCM_ARG2,
2470 s_scm_truncate_divide, qp, rp);
2471 }
2472 else if (SCM_FRACTIONP (x))
2473 {
2474 if (SCM_REALP (y))
2475 return scm_i_inexact_truncate_divide
2476 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
2477 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2478 return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
2479 else
2480 return two_valued_wta_dispatch_2
2481 (g_scm_truncate_divide, x, y, SCM_ARG2,
2482 s_scm_truncate_divide, qp, rp);
2483 }
2484 else
2485 return two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
2486 s_scm_truncate_divide, qp, rp);
2487}
2488
2489static void
2490scm_i_inexact_truncate_divide (double x, double y, SCM *qp, SCM *rp)
2491{
2492 if (SCM_UNLIKELY (y == 0))
2493 scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
2494 else
2495 {
c15fe499
MW		 2496 double q = trunc (x / y);
2497 double r = x - q * y;
8f9da340
MW		 2498 *qp = scm_from_double (q);
2499 *rp = scm_from_double (r);
2500 }
2501}
2502
2503static void
2504scm_i_exact_rational_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2505{
2506 SCM r1;
2507 SCM xd = scm_denominator (x);
2508 SCM yd = scm_denominator (y);
2509
2510 scm_truncate_divide (scm_product (scm_numerator (x), yd),
2511 scm_product (scm_numerator (y), xd),
2512 qp, &r1);
2513 *rp = scm_divide (r1, scm_product (xd, yd));
2514}
2515
ff62c168
MW		 2516static SCM scm_i_inexact_centered_quotient (double x, double y);
2517static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
03ddd15b 2518static SCM scm_i_exact_rational_centered_quotient (SCM x, SCM y);
ff62c168 2519
8f9da340
MW		 2520SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
2521 (SCM x, SCM y),
2522 "Return the integer @var{q} such that\n"
2523 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2524 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2525 "@lisp\n"
2526 "(centered-quotient 123 10) @result{} 12\n"
2527 "(centered-quotient 123 -10) @result{} -12\n"
2528 "(centered-quotient -123 10) @result{} -12\n"
2529 "(centered-quotient -123 -10) @result{} 12\n"
2530 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2531 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2532 "@end lisp")
2533#define FUNC_NAME s_scm_centered_quotient
2534{
2535 if (SCM_LIKELY (SCM_I_INUMP (x)))
2536 {
2537 scm_t_inum xx = SCM_I_INUM (x);
2538 if (SCM_LIKELY (SCM_I_INUMP (y)))
2539 {
2540 scm_t_inum yy = SCM_I_INUM (y);
2541 if (SCM_UNLIKELY (yy == 0))
2542 scm_num_overflow (s_scm_centered_quotient);
2543 else
2544 {
2545 scm_t_inum qq = xx / yy;
2546 scm_t_inum rr = xx % yy;
2547 if (SCM_LIKELY (xx > 0))
2548 {
2549 if (SCM_LIKELY (yy > 0))
2550 {
2551 if (rr >= (yy + 1) / 2)
2552 qq++;
2553 }
2554 else
2555 {
2556 if (rr >= (1 - yy) / 2)
2557 qq--;
2558 }
2559 }
2560 else
2561 {
2562 if (SCM_LIKELY (yy > 0))
2563 {
2564 if (rr < -yy / 2)
2565 qq--;
2566 }
2567 else
2568 {
2569 if (rr < yy / 2)
2570 qq++;
2571 }
2572 }
2573 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2574 return SCM_I_MAKINUM (qq);
2575 else
2576 return scm_i_inum2big (qq);
2577 }
2578 }
2579 else if (SCM_BIGP (y))
2580 {
2581 /* Pass a denormalized bignum version of x (even though it
2582 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2583 return scm_i_bigint_centered_quotient (scm_i_long2big (xx), y);
2584 }
2585 else if (SCM_REALP (y))
2586 return scm_i_inexact_centered_quotient (xx, SCM_REAL_VALUE (y));
2587 else if (SCM_FRACTIONP (y))
2588 return scm_i_exact_rational_centered_quotient (x, y);
2589 else
fa075d40
AW		 2590 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2591 s_scm_centered_quotient);
8f9da340
MW		 2592 }
2593 else if (SCM_BIGP (x))
2594 {
2595 if (SCM_LIKELY (SCM_I_INUMP (y)))
2596 {
2597 scm_t_inum yy = SCM_I_INUM (y);
2598 if (SCM_UNLIKELY (yy == 0))
2599 scm_num_overflow (s_scm_centered_quotient);
2600 else if (SCM_UNLIKELY (yy == 1))
2601 return x;
2602 else
2603 {
2604 SCM q = scm_i_mkbig ();
2605 scm_t_inum rr;
2606 /* Arrange for rr to initially be non-positive,
2607 because that simplifies the test to see
2608 if it is within the needed bounds. */
2609 if (yy > 0)
2610 {
2611 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
2612 SCM_I_BIG_MPZ (x), yy);
2613 scm_remember_upto_here_1 (x);
2614 if (rr < -yy / 2)
2615 mpz_sub_ui (SCM_I_BIG_MPZ (q),
2616 SCM_I_BIG_MPZ (q), 1);
2617 }
2618 else
2619 {
2620 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
2621 SCM_I_BIG_MPZ (x), -yy);
2622 scm_remember_upto_here_1 (x);
2623 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2624 if (rr < yy / 2)
2625 mpz_add_ui (SCM_I_BIG_MPZ (q),
2626 SCM_I_BIG_MPZ (q), 1);
2627 }
2628 return scm_i_normbig (q);
2629 }
2630 }
2631 else if (SCM_BIGP (y))
2632 return scm_i_bigint_centered_quotient (x, y);
2633 else if (SCM_REALP (y))
2634 return scm_i_inexact_centered_quotient
2635 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2636 else if (SCM_FRACTIONP (y))
2637 return scm_i_exact_rational_centered_quotient (x, y);
2638 else
fa075d40
AW		 2639 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2640 s_scm_centered_quotient);
8f9da340
MW		 2641 }
2642 else if (SCM_REALP (x))
2643 {
2644 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2645 SCM_BIGP (y) || SCM_FRACTIONP (y))
2646 return scm_i_inexact_centered_quotient
2647 (SCM_REAL_VALUE (x), scm_to_double (y));
2648 else
fa075d40
AW		 2649 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2650 s_scm_centered_quotient);
8f9da340
MW		 2651 }
2652 else if (SCM_FRACTIONP (x))
2653 {
2654 if (SCM_REALP (y))
2655 return scm_i_inexact_centered_quotient
2656 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2657 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2658 return scm_i_exact_rational_centered_quotient (x, y);
2659 else
fa075d40
AW		 2660 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2661 s_scm_centered_quotient);
8f9da340
MW		 2662 }
2663 else
fa075d40
AW		 2664 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
2665 s_scm_centered_quotient);
8f9da340
MW		 2666}
2667#undef FUNC_NAME
2668
2669static SCM
2670scm_i_inexact_centered_quotient (double x, double y)
2671{
2672 if (SCM_LIKELY (y > 0))
2673 return scm_from_double (floor (x/y + 0.5));
2674 else if (SCM_LIKELY (y < 0))
2675 return scm_from_double (ceil (x/y - 0.5));
2676 else if (y == 0)
2677 scm_num_overflow (s_scm_centered_quotient); /* or return a NaN? */
2678 else
2679 return scm_nan ();
2680}
2681
2682/* Assumes that both x and y are bigints, though
2683 x might be able to fit into a fixnum. */
2684static SCM
2685scm_i_bigint_centered_quotient (SCM x, SCM y)
2686{
2687 SCM q, r, min_r;
2688
2689 /* Note that x might be small enough to fit into a
2690 fixnum, so we must not let it escape into the wild */
2691 q = scm_i_mkbig ();
2692 r = scm_i_mkbig ();
2693
2694 /* min_r will eventually become -abs(y)/2 */
2695 min_r = scm_i_mkbig ();
2696 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
2697 SCM_I_BIG_MPZ (y), 1);
2698
2699 /* Arrange for rr to initially be non-positive,
2700 because that simplifies the test to see
2701 if it is within the needed bounds. */
2702 if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
2703 {
2704 mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2705 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2706 scm_remember_upto_here_2 (x, y);
2707 mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
2708 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
2709 mpz_sub_ui (SCM_I_BIG_MPZ (q),
2710 SCM_I_BIG_MPZ (q), 1);
2711 }
2712 else
2713 {
2714 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2715 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2716 scm_remember_upto_here_2 (x, y);
2717 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
2718 mpz_add_ui (SCM_I_BIG_MPZ (q),
2719 SCM_I_BIG_MPZ (q), 1);
2720 }
2721 scm_remember_upto_here_2 (r, min_r);
2722 return scm_i_normbig (q);
2723}
2724
2725static SCM
2726scm_i_exact_rational_centered_quotient (SCM x, SCM y)
2727{
2728 return scm_centered_quotient
2729 (scm_product (scm_numerator (x), scm_denominator (y)),
2730 scm_product (scm_numerator (y), scm_denominator (x)));
2731}
2732
2733static SCM scm_i_inexact_centered_remainder (double x, double y);
2734static SCM scm_i_bigint_centered_remainder (SCM x, SCM y);
2735static SCM scm_i_exact_rational_centered_remainder (SCM x, SCM y);
2736
2737SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
2738 (SCM x, SCM y),
2739 "Return the real number @var{r} such that\n"
2740 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2741 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2742 "for some integer @var{q}.\n"
2743 "@lisp\n"
2744 "(centered-remainder 123 10) @result{} 3\n"
2745 "(centered-remainder 123 -10) @result{} 3\n"
2746 "(centered-remainder -123 10) @result{} -3\n"
2747 "(centered-remainder -123 -10) @result{} -3\n"
2748 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2749 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2750 "@end lisp")
2751#define FUNC_NAME s_scm_centered_remainder
2752{
2753 if (SCM_LIKELY (SCM_I_INUMP (x)))
2754 {
2755 scm_t_inum xx = SCM_I_INUM (x);
2756 if (SCM_LIKELY (SCM_I_INUMP (y)))
2757 {
2758 scm_t_inum yy = SCM_I_INUM (y);
2759 if (SCM_UNLIKELY (yy == 0))
2760 scm_num_overflow (s_scm_centered_remainder);
2761 else
2762 {
2763 scm_t_inum rr = xx % yy;
2764 if (SCM_LIKELY (xx > 0))
2765 {
2766 if (SCM_LIKELY (yy > 0))
2767 {
2768 if (rr >= (yy + 1) / 2)
2769 rr -= yy;
2770 }
2771 else
2772 {
2773 if (rr >= (1 - yy) / 2)
2774 rr += yy;
2775 }
2776 }
2777 else
2778 {
2779 if (SCM_LIKELY (yy > 0))
2780 {
2781 if (rr < -yy / 2)
2782 rr += yy;
2783 }
2784 else
2785 {
2786 if (rr < yy / 2)
2787 rr -= yy;
2788 }
2789 }
2790 return SCM_I_MAKINUM (rr);
2791 }
2792 }
2793 else if (SCM_BIGP (y))
2794 {
2795 /* Pass a denormalized bignum version of x (even though it
2796 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2797 return scm_i_bigint_centered_remainder (scm_i_long2big (xx), y);
2798 }
2799 else if (SCM_REALP (y))
2800 return scm_i_inexact_centered_remainder (xx, SCM_REAL_VALUE (y));
2801 else if (SCM_FRACTIONP (y))
2802 return scm_i_exact_rational_centered_remainder (x, y);
2803 else
fa075d40
AW		 2804 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
2805 s_scm_centered_remainder);
8f9da340
MW		 2806 }
2807 else if (SCM_BIGP (x))
2808 {
2809 if (SCM_LIKELY (SCM_I_INUMP (y)))
2810 {
2811 scm_t_inum yy = SCM_I_INUM (y);
2812 if (SCM_UNLIKELY (yy == 0))
2813 scm_num_overflow (s_scm_centered_remainder);
2814 else
2815 {
2816 scm_t_inum rr;
2817 /* Arrange for rr to initially be non-positive,
2818 because that simplifies the test to see
2819 if it is within the needed bounds. */
2820 if (yy > 0)
2821 {
2822 rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
2823 scm_remember_upto_here_1 (x);
2824 if (rr < -yy / 2)
2825 rr += yy;
2826 }
2827 else
2828 {
2829 rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
2830 scm_remember_upto_here_1 (x);
2831 if (rr < yy / 2)
2832 rr -= yy;
2833 }
2834 return SCM_I_MAKINUM (rr);
2835 }
2836 }
2837 else if (SCM_BIGP (y))
2838 return scm_i_bigint_centered_remainder (x, y);
2839 else if (SCM_REALP (y))
2840 return scm_i_inexact_centered_remainder
2841 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2842 else if (SCM_FRACTIONP (y))
2843 return scm_i_exact_rational_centered_remainder (x, y);
2844 else
fa075d40
AW		 2845 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
2846 s_scm_centered_remainder);
8f9da340
MW		 2847 }
2848 else if (SCM_REALP (x))
2849 {
2850 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2851 SCM_BIGP (y) || SCM_FRACTIONP (y))
2852 return scm_i_inexact_centered_remainder
2853 (SCM_REAL_VALUE (x), scm_to_double (y));
2854 else
fa075d40
AW		 2855 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
2856 s_scm_centered_remainder);
8f9da340
MW		 2857 }
2858 else if (SCM_FRACTIONP (x))
2859 {
2860 if (SCM_REALP (y))
2861 return scm_i_inexact_centered_remainder
2862 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2863 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2864 return scm_i_exact_rational_centered_remainder (x, y);
2865 else
fa075d40
AW		 2866 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
2867 s_scm_centered_remainder);
8f9da340
MW		 2868 }
2869 else
fa075d40
AW		 2870 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
2871 s_scm_centered_remainder);
8f9da340
MW		 2872}
2873#undef FUNC_NAME
2874
2875static SCM
2876scm_i_inexact_centered_remainder (double x, double y)
2877{
2878 double q;
2879
2880 /* Although it would be more efficient to use fmod here, we can't
2881 because it would in some cases produce results inconsistent with
2882 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2883 close). In particular, when x-y/2 is very close to a multiple of
2884 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2885 two cases must correspond to different choices of q. If quotient
2886 chooses one and remainder chooses the other, it would be bad. */
2887 if (SCM_LIKELY (y > 0))
2888 q = floor (x/y + 0.5);
2889 else if (SCM_LIKELY (y < 0))
2890 q = ceil (x/y - 0.5);
2891 else if (y == 0)
2892 scm_num_overflow (s_scm_centered_remainder); /* or return a NaN? */
2893 else
2894 return scm_nan ();
2895 return scm_from_double (x - q * y);
2896}
2897
2898/* Assumes that both x and y are bigints, though
2899 x might be able to fit into a fixnum. */
2900static SCM
2901scm_i_bigint_centered_remainder (SCM x, SCM y)
2902{
2903 SCM r, min_r;
2904
2905 /* Note that x might be small enough to fit into a
2906 fixnum, so we must not let it escape into the wild */
2907 r = scm_i_mkbig ();
2908
2909 /* min_r will eventually become -abs(y)/2 */
2910 min_r = scm_i_mkbig ();
2911 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
2912 SCM_I_BIG_MPZ (y), 1);
2913
2914 /* Arrange for rr to initially be non-positive,
2915 because that simplifies the test to see
2916 if it is within the needed bounds. */
2917 if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
2918 {
2919 mpz_cdiv_r (SCM_I_BIG_MPZ (r),
2920 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2921 mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
2922 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
2923 mpz_add (SCM_I_BIG_MPZ (r),
2924 SCM_I_BIG_MPZ (r),
2925 SCM_I_BIG_MPZ (y));
2926 }
2927 else
2928 {
2929 mpz_fdiv_r (SCM_I_BIG_MPZ (r),
2930 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2931 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
2932 mpz_sub (SCM_I_BIG_MPZ (r),
2933 SCM_I_BIG_MPZ (r),
2934 SCM_I_BIG_MPZ (y));
2935 }
2936 scm_remember_upto_here_2 (x, y);
2937 return scm_i_normbig (r);
2938}
2939
2940static SCM
2941scm_i_exact_rational_centered_remainder (SCM x, SCM y)
2942{
2943 SCM xd = scm_denominator (x);
2944 SCM yd = scm_denominator (y);
2945 SCM r1 = scm_centered_remainder (scm_product (scm_numerator (x), yd),
2946 scm_product (scm_numerator (y), xd));
2947 return scm_divide (r1, scm_product (xd, yd));
2948}
2949
2950
2951static void scm_i_inexact_centered_divide (double x, double y,
2952 SCM *qp, SCM *rp);
2953static void scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp);
2954static void scm_i_exact_rational_centered_divide (SCM x, SCM y,
2955 SCM *qp, SCM *rp);
2956
2957SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0,
2958 (SCM x, SCM y),
2959 "Return the integer @var{q} and the real number @var{r}\n"
2960 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2961 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2962 "@lisp\n"
2963 "(centered/ 123 10) @result{} 12 and 3\n"
2964 "(centered/ 123 -10) @result{} -12 and 3\n"
2965 "(centered/ -123 10) @result{} -12 and -3\n"
2966 "(centered/ -123 -10) @result{} 12 and -3\n"
2967 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2968 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2969 "@end lisp")
2970#define FUNC_NAME s_scm_i_centered_divide
2971{
2972 SCM q, r;
2973
2974 scm_centered_divide(x, y, &q, &r);
2975 return scm_values (scm_list_2 (q, r));
2976}
2977#undef FUNC_NAME
2978
2979#define s_scm_centered_divide s_scm_i_centered_divide
2980#define g_scm_centered_divide g_scm_i_centered_divide
2981
2982void
2983scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2984{
2985 if (SCM_LIKELY (SCM_I_INUMP (x)))
2986 {
2987 scm_t_inum xx = SCM_I_INUM (x);
2988 if (SCM_LIKELY (SCM_I_INUMP (y)))
2989 {
2990 scm_t_inum yy = SCM_I_INUM (y);
2991 if (SCM_UNLIKELY (yy == 0))
2992 scm_num_overflow (s_scm_centered_divide);
2993 else
2994 {
2995 scm_t_inum qq = xx / yy;
2996 scm_t_inum rr = xx % yy;
2997 if (SCM_LIKELY (xx > 0))
2998 {
2999 if (SCM_LIKELY (yy > 0))
3000 {
3001 if (rr >= (yy + 1) / 2)
3002 { qq++; rr -= yy; }
3003 }
3004 else
3005 {
3006 if (rr >= (1 - yy) / 2)
3007 { qq--; rr += yy; }
3008 }
3009 }
3010 else
3011 {
3012 if (SCM_LIKELY (yy > 0))
3013 {
3014 if (rr < -yy / 2)
3015 { qq--; rr += yy; }
3016 }
3017 else
3018 {
3019 if (rr < yy / 2)
3020 { qq++; rr -= yy; }
3021 }
3022 }
3023 if (SCM_LIKELY (SCM_FIXABLE (qq)))
3024 *qp = SCM_I_MAKINUM (qq);
3025 else
3026 *qp = scm_i_inum2big (qq);
3027 *rp = SCM_I_MAKINUM (rr);
3028 }
3029 return;
3030 }
3031 else if (SCM_BIGP (y))
3032 {
3033 /* Pass a denormalized bignum version of x (even though it
3034 can fit in a fixnum) to scm_i_bigint_centered_divide */
3035 return scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp);
3036 }
3037 else if (SCM_REALP (y))
3038 return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
3039 else if (SCM_FRACTIONP (y))
3040 return scm_i_exact_rational_centered_divide (x, y, qp, rp);
3041 else
3042 return two_valued_wta_dispatch_2
3043 (g_scm_centered_divide, x, y, SCM_ARG2,
3044 s_scm_centered_divide, qp, rp);
3045 }
3046 else if (SCM_BIGP (x))
3047 {
3048 if (SCM_LIKELY (SCM_I_INUMP (y)))
3049 {
3050 scm_t_inum yy = SCM_I_INUM (y);
3051 if (SCM_UNLIKELY (yy == 0))
3052 scm_num_overflow (s_scm_centered_divide);
3053 else
3054 {
3055 SCM q = scm_i_mkbig ();
3056 scm_t_inum rr;
3057 /* Arrange for rr to initially be non-positive,
3058 because that simplifies the test to see
3059 if it is within the needed bounds. */
3060 if (yy > 0)
3061 {
3062 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3063 SCM_I_BIG_MPZ (x), yy);
3064 scm_remember_upto_here_1 (x);
3065 if (rr < -yy / 2)
3066 {
3067 mpz_sub_ui (SCM_I_BIG_MPZ (q),
3068 SCM_I_BIG_MPZ (q), 1);
3069 rr += yy;
3070 }
3071 }
3072 else
3073 {
3074 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3075 SCM_I_BIG_MPZ (x), -yy);
3076 scm_remember_upto_here_1 (x);
3077 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
3078 if (rr < yy / 2)
3079 {
3080 mpz_add_ui (SCM_I_BIG_MPZ (q),
3081 SCM_I_BIG_MPZ (q), 1);
3082 rr -= yy;
3083 }
3084 }
3085 *qp = scm_i_normbig (q);
3086 *rp = SCM_I_MAKINUM (rr);
3087 }
3088 return;
3089 }
3090 else if (SCM_BIGP (y))
3091 return scm_i_bigint_centered_divide (x, y, qp, rp);
3092 else if (SCM_REALP (y))
3093 return scm_i_inexact_centered_divide
3094 (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
3095 else if (SCM_FRACTIONP (y))
3096 return scm_i_exact_rational_centered_divide (x, y, qp, rp);
3097 else
3098 return two_valued_wta_dispatch_2
3099 (g_scm_centered_divide, x, y, SCM_ARG2,
3100 s_scm_centered_divide, qp, rp);
3101 }
3102 else if (SCM_REALP (x))
3103 {
3104 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3105 SCM_BIGP (y) || SCM_FRACTIONP (y))
3106 return scm_i_inexact_centered_divide
3107 (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
3108 else
3109 return two_valued_wta_dispatch_2
3110 (g_scm_centered_divide, x, y, SCM_ARG2,
3111 s_scm_centered_divide, qp, rp);
3112 }
3113 else if (SCM_FRACTIONP (x))
3114 {
3115 if (SCM_REALP (y))
3116 return scm_i_inexact_centered_divide
3117 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
3118 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
3119 return scm_i_exact_rational_centered_divide (x, y, qp, rp);
3120 else
3121 return two_valued_wta_dispatch_2
3122 (g_scm_centered_divide, x, y, SCM_ARG2,
3123 s_scm_centered_divide, qp, rp);
3124 }
3125 else
3126 return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
3127 s_scm_centered_divide, qp, rp);
3128}
3129
3130static void
3131scm_i_inexact_centered_divide (double x, double y, SCM *qp, SCM *rp)
3132{
3133 double q, r;
3134
3135 if (SCM_LIKELY (y > 0))
3136 q = floor (x/y + 0.5);
3137 else if (SCM_LIKELY (y < 0))
3138 q = ceil (x/y - 0.5);
3139 else if (y == 0)
3140 scm_num_overflow (s_scm_centered_divide); /* or return a NaN? */
3141 else
3142 q = guile_NaN;
3143 r = x - q * y;
3144 *qp = scm_from_double (q);
3145 *rp = scm_from_double (r);
3146}
3147
3148/* Assumes that both x and y are bigints, though
3149 x might be able to fit into a fixnum. */
3150static void
3151scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3152{
3153 SCM q, r, min_r;
3154
3155 /* Note that x might be small enough to fit into a
3156 fixnum, so we must not let it escape into the wild */
3157 q = scm_i_mkbig ();
3158 r = scm_i_mkbig ();
3159
3160 /* min_r will eventually become -abs(y/2) */
3161 min_r = scm_i_mkbig ();
3162 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
3163 SCM_I_BIG_MPZ (y), 1);
3164
3165 /* Arrange for rr to initially be non-positive,
3166 because that simplifies the test to see
3167 if it is within the needed bounds. */
3168 if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
3169 {
3170 mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3171 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3172 mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
3173 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
3174 {
3175 mpz_sub_ui (SCM_I_BIG_MPZ (q),
3176 SCM_I_BIG_MPZ (q), 1);
3177 mpz_add (SCM_I_BIG_MPZ (r),
3178 SCM_I_BIG_MPZ (r),
3179 SCM_I_BIG_MPZ (y));
3180 }
3181 }
3182 else
3183 {
3184 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3185 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3186 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
3187 {
3188 mpz_add_ui (SCM_I_BIG_MPZ (q),
3189 SCM_I_BIG_MPZ (q), 1);
3190 mpz_sub (SCM_I_BIG_MPZ (r),
3191 SCM_I_BIG_MPZ (r),
3192 SCM_I_BIG_MPZ (y));
3193 }
3194 }
3195 scm_remember_upto_here_2 (x, y);
3196 *qp = scm_i_normbig (q);
3197 *rp = scm_i_normbig (r);
3198}
3199
3200static void
3201scm_i_exact_rational_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3202{
3203 SCM r1;
3204 SCM xd = scm_denominator (x);
3205 SCM yd = scm_denominator (y);
3206
3207 scm_centered_divide (scm_product (scm_numerator (x), yd),
3208 scm_product (scm_numerator (y), xd),
3209 qp, &r1);
3210 *rp = scm_divide (r1, scm_product (xd, yd));
3211}
3212
3213static SCM scm_i_inexact_round_quotient (double x, double y);
3214static SCM scm_i_bigint_round_quotient (SCM x, SCM y);
3215static SCM scm_i_exact_rational_round_quotient (SCM x, SCM y);
3216
3217SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
ff62c168 3218 (SCM x, SCM y),
8f9da340
MW		 3219 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3220 "with ties going to the nearest even integer.\n"
ff62c168 3221 "@lisp\n"
8f9da340
MW		 3222 "(round-quotient 123 10) @result{} 12\n"
3223 "(round-quotient 123 -10) @result{} -12\n"
3224 "(round-quotient -123 10) @result{} -12\n"
3225 "(round-quotient -123 -10) @result{} 12\n"
3226 "(round-quotient 125 10) @result{} 12\n"
3227 "(round-quotient 127 10) @result{} 13\n"
3228 "(round-quotient 135 10) @result{} 14\n"
3229 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3230 "(round-quotient 16/3 -10/7) @result{} -4\n"
ff62c168 3231 "@end lisp")
8f9da340 3232#define FUNC_NAME s_scm_round_quotient
ff62c168
MW		 3233{
3234 if (SCM_LIKELY (SCM_I_INUMP (x)))
3235 {
4a46bc2a 3236 scm_t_inum xx = SCM_I_INUM (x);
ff62c168
MW		 3237 if (SCM_LIKELY (SCM_I_INUMP (y)))
3238 {
3239 scm_t_inum yy = SCM_I_INUM (y);
3240 if (SCM_UNLIKELY (yy == 0))
8f9da340 3241 scm_num_overflow (s_scm_round_quotient);
ff62c168
MW		 3242 else
3243 {
ff62c168 3244 scm_t_inum qq = xx / yy;
4a46bc2a 3245 scm_t_inum rr = xx % yy;
8f9da340
MW		 3246 scm_t_inum ay = yy;
3247 scm_t_inum r2 = 2 * rr;
3248
3249 if (SCM_LIKELY (yy < 0))
ff62c168 3250 {
8f9da340
MW		 3251 ay = -ay;
3252 r2 = -r2;
3253 }
3254
3255 if (qq & 1L)
3256 {
3257 if (r2 >= ay)
3258 qq++;
3259 else if (r2 <= -ay)
3260 qq--;
ff62c168
MW		 3261 }
3262 else
3263 {
8f9da340
MW		 3264 if (r2 > ay)
3265 qq++;
3266 else if (r2 < -ay)
3267 qq--;
ff62c168 3268 }
4a46bc2a
MW		 3269 if (SCM_LIKELY (SCM_FIXABLE (qq)))
3270 return SCM_I_MAKINUM (qq);
3271 else
3272 return scm_i_inum2big (qq);
ff62c168
MW		 3273 }
3274 }
3275 else if (SCM_BIGP (y))
3276 {
3277 /* Pass a denormalized bignum version of x (even though it
8f9da340
MW		 3278 can fit in a fixnum) to scm_i_bigint_round_quotient */
3279 return scm_i_bigint_round_quotient (scm_i_long2big (xx), y);
ff62c168
MW		 3280 }
3281 else if (SCM_REALP (y))
8f9da340 3282 return scm_i_inexact_round_quotient (xx, SCM_REAL_VALUE (y));
ff62c168 3283 else if (SCM_FRACTIONP (y))
8f9da340 3284 return scm_i_exact_rational_round_quotient (x, y);
ff62c168 3285 else
fa075d40
AW		 3286 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3287 s_scm_round_quotient);
ff62c168
MW		 3288 }
3289 else if (SCM_BIGP (x))
3290 {
3291 if (SCM_LIKELY (SCM_I_INUMP (y)))
3292 {
3293 scm_t_inum yy = SCM_I_INUM (y);
3294 if (SCM_UNLIKELY (yy == 0))
8f9da340 3295 scm_num_overflow (s_scm_round_quotient);
4a46bc2a
MW		 3296 else if (SCM_UNLIKELY (yy == 1))
3297 return x;
ff62c168
MW		 3298 else
3299 {
3300 SCM q = scm_i_mkbig ();
3301 scm_t_inum rr;
8f9da340
MW		 3302 int needs_adjustment;
3303
ff62c168
MW		 3304 if (yy > 0)
3305 {
8f9da340
MW		 3306 rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
3307 SCM_I_BIG_MPZ (x), yy);
3308 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3309 needs_adjustment = (2*rr >= yy);
3310 else
3311 needs_adjustment = (2*rr > yy);
ff62c168
MW		 3312 }
3313 else
3314 {
3315 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3316 SCM_I_BIG_MPZ (x), -yy);
ff62c168 3317 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
8f9da340
MW		 3318 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3319 needs_adjustment = (2*rr <= yy);
3320 else
3321 needs_adjustment = (2*rr < yy);
ff62c168 3322 }
8f9da340
MW		 3323 scm_remember_upto_here_1 (x);
3324 if (needs_adjustment)
3325 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
ff62c168
MW		 3326 return scm_i_normbig (q);
3327 }
3328 }
3329 else if (SCM_BIGP (y))
8f9da340 3330 return scm_i_bigint_round_quotient (x, y);
ff62c168 3331 else if (SCM_REALP (y))
8f9da340 3332 return scm_i_inexact_round_quotient
ff62c168
MW		 3333 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
3334 else if (SCM_FRACTIONP (y))
8f9da340 3335 return scm_i_exact_rational_round_quotient (x, y);
ff62c168 3336 else
fa075d40
AW		 3337 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3338 s_scm_round_quotient);
ff62c168
MW		 3339 }
3340 else if (SCM_REALP (x))
3341 {
3342 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3343 SCM_BIGP (y) || SCM_FRACTIONP (y))
8f9da340 3344 return scm_i_inexact_round_quotient
ff62c168
MW		 3345 (SCM_REAL_VALUE (x), scm_to_double (y));
3346 else
fa075d40
AW		 3347 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3348 s_scm_round_quotient);
ff62c168
MW		 3349 }
3350 else if (SCM_FRACTIONP (x))
3351 {
3352 if (SCM_REALP (y))
8f9da340 3353 return scm_i_inexact_round_quotient
ff62c168 3354 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
03ddd15b 3355 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
8f9da340 3356 return scm_i_exact_rational_round_quotient (x, y);
ff62c168 3357 else
fa075d40
AW		 3358 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3359 s_scm_round_quotient);
ff62c168
MW		 3360 }
3361 else
fa075d40
AW		 3362 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
3363 s_scm_round_quotient);
ff62c168
MW		 3364}
3365#undef FUNC_NAME
3366
3367static SCM
8f9da340 3368scm_i_inexact_round_quotient (double x, double y)
ff62c168 3369{
8f9da340
MW		 3370 if (SCM_UNLIKELY (y == 0))
3371 scm_num_overflow (s_scm_round_quotient); /* or return a NaN? */
ff62c168 3372 else
8f9da340 3373 return scm_from_double (scm_c_round (x / y));
ff62c168
MW		 3374}
3375
3376/* Assumes that both x and y are bigints, though
3377 x might be able to fit into a fixnum. */
3378static SCM
8f9da340 3379scm_i_bigint_round_quotient (SCM x, SCM y)
ff62c168 3380{
8f9da340
MW		 3381 SCM q, r, r2;
3382 int cmp, needs_adjustment;
ff62c168
MW		 3383
3384 /* Note that x might be small enough to fit into a
3385 fixnum, so we must not let it escape into the wild */
3386 q = scm_i_mkbig ();
3387 r = scm_i_mkbig ();
8f9da340 3388 r2 = scm_i_mkbig ();
ff62c168 3389
8f9da340
MW		 3390 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3391 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3392 mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
3393 scm_remember_upto_here_2 (x, r);
ff62c168 3394
8f9da340
MW		 3395 cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
3396 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3397 needs_adjustment = (cmp >= 0);
ff62c168 3398 else
8f9da340
MW		 3399 needs_adjustment = (cmp > 0);
3400 scm_remember_upto_here_2 (r2, y);
3401
3402 if (needs_adjustment)
3403 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
3404
ff62c168
MW		 3405 return scm_i_normbig (q);
3406}
3407
ff62c168 3408static SCM
8f9da340 3409scm_i_exact_rational_round_quotient (SCM x, SCM y)
ff62c168 3410{
8f9da340 3411 return scm_round_quotient
03ddd15b
MW		 3412 (scm_product (scm_numerator (x), scm_denominator (y)),
3413 scm_product (scm_numerator (y), scm_denominator (x)));
ff62c168
MW		 3414}
3415
8f9da340
MW		 3416static SCM scm_i_inexact_round_remainder (double x, double y);
3417static SCM scm_i_bigint_round_remainder (SCM x, SCM y);
3418static SCM scm_i_exact_rational_round_remainder (SCM x, SCM y);
ff62c168 3419
8f9da340 3420SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
ff62c168
MW		 3421 (SCM x, SCM y),
3422 "Return the real number @var{r} such that\n"
8f9da340
MW		 3423 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3424 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3425 "nearest integer, with ties going to the nearest\n"
3426 "even integer.\n"
ff62c168 3427 "@lisp\n"
8f9da340
MW		 3428 "(round-remainder 123 10) @result{} 3\n"
3429 "(round-remainder 123 -10) @result{} 3\n"
3430 "(round-remainder -123 10) @result{} -3\n"
3431 "(round-remainder -123 -10) @result{} -3\n"
3432 "(round-remainder 125 10) @result{} 5\n"
3433 "(round-remainder 127 10) @result{} -3\n"
3434 "(round-remainder 135 10) @result{} -5\n"
3435 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3436 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
ff62c168 3437 "@end lisp")
8f9da340 3438#define FUNC_NAME s_scm_round_remainder
ff62c168
MW		 3439{
3440 if (SCM_LIKELY (SCM_I_INUMP (x)))
3441 {
4a46bc2a 3442 scm_t_inum xx = SCM_I_INUM (x);
ff62c168
MW		 3443 if (SCM_LIKELY (SCM_I_INUMP (y)))
3444 {
3445 scm_t_inum yy = SCM_I_INUM (y);
3446 if (SCM_UNLIKELY (yy == 0))
8f9da340 3447 scm_num_overflow (s_scm_round_remainder);
ff62c168
MW		 3448 else
3449 {
8f9da340 3450 scm_t_inum qq = xx / yy;
ff62c168 3451 scm_t_inum rr = xx % yy;
8f9da340
MW		 3452 scm_t_inum ay = yy;
3453 scm_t_inum r2 = 2 * rr;
3454
3455 if (SCM_LIKELY (yy < 0))
ff62c168 3456 {
8f9da340
MW		 3457 ay = -ay;
3458 r2 = -r2;
3459 }
3460
3461 if (qq & 1L)
3462 {
3463 if (r2 >= ay)
3464 rr -= yy;
3465 else if (r2 <= -ay)
3466 rr += yy;
ff62c168
MW		 3467 }
3468 else
3469 {
8f9da340
MW		 3470 if (r2 > ay)
3471 rr -= yy;
3472 else if (r2 < -ay)
3473 rr += yy;
ff62c168
MW		 3474 }
3475 return SCM_I_MAKINUM (rr);
3476 }
3477 }
3478 else if (SCM_BIGP (y))
3479 {
3480 /* Pass a denormalized bignum version of x (even though it
8f9da340
MW		 3481 can fit in a fixnum) to scm_i_bigint_round_remainder */
3482 return scm_i_bigint_round_remainder
3483 (scm_i_long2big (xx), y);
ff62c168
MW		 3484 }
3485 else if (SCM_REALP (y))
8f9da340 3486 return scm_i_inexact_round_remainder (xx, SCM_REAL_VALUE (y));
ff62c168 3487 else if (SCM_FRACTIONP (y))
8f9da340 3488 return scm_i_exact_rational_round_remainder (x, y);
ff62c168 3489 else
fa075d40
AW		 3490 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3491 s_scm_round_remainder);
ff62c168
MW		 3492 }
3493 else if (SCM_BIGP (x))
3494 {
3495 if (SCM_LIKELY (SCM_I_INUMP (y)))
3496 {
3497 scm_t_inum yy = SCM_I_INUM (y);
3498 if (SCM_UNLIKELY (yy == 0))
8f9da340 3499 scm_num_overflow (s_scm_round_remainder);
ff62c168
MW		 3500 else
3501 {
8f9da340 3502 SCM q = scm_i_mkbig ();
ff62c168 3503 scm_t_inum rr;
8f9da340
MW		 3504 int needs_adjustment;
3505
ff62c168
MW		 3506 if (yy > 0)
3507 {
8f9da340
MW		 3508 rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
3509 SCM_I_BIG_MPZ (x), yy);
3510 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3511 needs_adjustment = (2*rr >= yy);
3512 else
3513 needs_adjustment = (2*rr > yy);
ff62c168
MW		 3514 }
3515 else
3516 {
8f9da340
MW		 3517 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3518 SCM_I_BIG_MPZ (x), -yy);
3519 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3520 needs_adjustment = (2*rr <= yy);
3521 else
3522 needs_adjustment = (2*rr < yy);
ff62c168 3523 }
8f9da340
MW		 3524 scm_remember_upto_here_2 (x, q);
3525 if (needs_adjustment)
3526 rr -= yy;
ff62c168
MW		 3527 return SCM_I_MAKINUM (rr);
3528 }
3529 }
3530 else if (SCM_BIGP (y))
8f9da340 3531 return scm_i_bigint_round_remainder (x, y);
ff62c168 3532 else if (SCM_REALP (y))
8f9da340 3533 return scm_i_inexact_round_remainder
ff62c168
MW		 3534 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
3535 else if (SCM_FRACTIONP (y))
8f9da340 3536 return scm_i_exact_rational_round_remainder (x, y);
ff62c168 3537 else
fa075d40
AW		 3538 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3539 s_scm_round_remainder);
ff62c168
MW		 3540 }
3541 else if (SCM_REALP (x))
3542 {
3543 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3544 SCM_BIGP (y) || SCM_FRACTIONP (y))
8f9da340 3545 return scm_i_inexact_round_remainder
ff62c168
MW		 3546 (SCM_REAL_VALUE (x), scm_to_double (y));
3547 else
fa075d40
AW		 3548 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3549 s_scm_round_remainder);
ff62c168
MW		 3550 }
3551 else if (SCM_FRACTIONP (x))
3552 {
3553 if (SCM_REALP (y))
8f9da340 3554 return scm_i_inexact_round_remainder
ff62c168 3555 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
03ddd15b 3556 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
8f9da340 3557 return scm_i_exact_rational_round_remainder (x, y);
ff62c168 3558 else
fa075d40
AW		 3559 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3560 s_scm_round_remainder);
ff62c168
MW		 3561 }
3562 else
fa075d40
AW		 3563 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
3564 s_scm_round_remainder);
ff62c168
MW		 3565}
3566#undef FUNC_NAME
3567
3568static SCM
8f9da340 3569scm_i_inexact_round_remainder (double x, double y)
ff62c168 3570{
ff62c168
MW		 3571 /* Although it would be more efficient to use fmod here, we can't
3572 because it would in some cases produce results inconsistent with
8f9da340 3573 scm_i_inexact_round_quotient, such that x != r + q * y (not even
ff62c168 3574 close). In particular, when x-y/2 is very close to a multiple of
8f9da340
MW		 3575 y, then r might be either -abs(y/2) or abs(y/2), but those two
3576 cases must correspond to different choices of q. If quotient
ff62c168 3577 chooses one and remainder chooses the other, it would be bad. */
8f9da340
MW		 3578
3579 if (SCM_UNLIKELY (y == 0))
3580 scm_num_overflow (s_scm_round_remainder); /* or return a NaN? */
ff62c168 3581 else
8f9da340
MW		 3582 {
3583 double q = scm_c_round (x / y);
3584 return scm_from_double (x - q * y);
3585 }
ff62c168
MW		 3586}
3587
3588/* Assumes that both x and y are bigints, though
3589 x might be able to fit into a fixnum. */
3590static SCM
8f9da340 3591scm_i_bigint_round_remainder (SCM x, SCM y)
ff62c168 3592{
8f9da340
MW		 3593 SCM q, r, r2;
3594 int cmp, needs_adjustment;
ff62c168
MW		 3595
3596 /* Note that x might be small enough to fit into a
3597 fixnum, so we must not let it escape into the wild */
8f9da340 3598 q = scm_i_mkbig ();
ff62c168 3599 r = scm_i_mkbig ();
8f9da340 3600 r2 = scm_i_mkbig ();
ff62c168 3601
8f9da340
MW		 3602 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3603 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3604 scm_remember_upto_here_1 (x);
3605 mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
ff62c168 3606
8f9da340
MW		 3607 cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
3608 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3609 needs_adjustment = (cmp >= 0);
ff62c168 3610 else
8f9da340
MW		 3611 needs_adjustment = (cmp > 0);
3612 scm_remember_upto_here_2 (q, r2);
3613
3614 if (needs_adjustment)
3615 mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
3616
3617 scm_remember_upto_here_1 (y);
ff62c168
MW		 3618 return scm_i_normbig (r);
3619}
3620
ff62c168 3621static SCM
8f9da340 3622scm_i_exact_rational_round_remainder (SCM x, SCM y)
ff62c168 3623{
03ddd15b
MW		 3624 SCM xd = scm_denominator (x);
3625 SCM yd = scm_denominator (y);
8f9da340
MW		 3626 SCM r1 = scm_round_remainder (scm_product (scm_numerator (x), yd),
3627 scm_product (scm_numerator (y), xd));
03ddd15b 3628 return scm_divide (r1, scm_product (xd, yd));
ff62c168
MW		 3629}
3630
3631
8f9da340
MW		 3632static void scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp);
3633static void scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
3634static void scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
ff62c168 3635
8f9da340 3636SCM_PRIMITIVE_GENERIC (scm_i_round_divide, "round/", 2, 0, 0,
ff62c168
MW		 3637 (SCM x, SCM y),
3638 "Return the integer @var{q} and the real number @var{r}\n"
3639 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
8f9da340
MW		 3640 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3641 "nearest integer, with ties going to the nearest even integer.\n"
ff62c168 3642 "@lisp\n"
8f9da340
MW		 3643 "(round/ 123 10) @result{} 12 and 3\n"
3644 "(round/ 123 -10) @result{} -12 and 3\n"
3645 "(round/ -123 10) @result{} -12 and -3\n"
3646 "(round/ -123 -10) @result{} 12 and -3\n"
3647 "(round/ 125 10) @result{} 12 and 5\n"
3648 "(round/ 127 10) @result{} 13 and -3\n"
3649 "(round/ 135 10) @result{} 14 and -5\n"
3650 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3651 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
ff62c168 3652 "@end lisp")
8f9da340 3653#define FUNC_NAME s_scm_i_round_divide
5fbf680b
MW		 3654{
3655 SCM q, r;
3656
8f9da340 3657 scm_round_divide(x, y, &q, &r);
5fbf680b
MW		 3658 return scm_values (scm_list_2 (q, r));
3659}
3660#undef FUNC_NAME
3661
8f9da340
MW		 3662#define s_scm_round_divide s_scm_i_round_divide
3663#define g_scm_round_divide g_scm_i_round_divide
5fbf680b
MW		 3664
3665void
8f9da340 3666scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
ff62c168
MW		 3667{
3668 if (SCM_LIKELY (SCM_I_INUMP (x)))
3669 {
4a46bc2a 3670 scm_t_inum xx = SCM_I_INUM (x);
ff62c168
MW		 3671 if (SCM_LIKELY (SCM_I_INUMP (y)))
3672 {
3673 scm_t_inum yy = SCM_I_INUM (y);
3674 if (SCM_UNLIKELY (yy == 0))
8f9da340 3675 scm_num_overflow (s_scm_round_divide);
ff62c168
MW		 3676 else
3677 {
ff62c168 3678 scm_t_inum qq = xx / yy;
4a46bc2a 3679 scm_t_inum rr = xx % yy;
8f9da340
MW		 3680 scm_t_inum ay = yy;
3681 scm_t_inum r2 = 2 * rr;
3682
3683 if (SCM_LIKELY (yy < 0))
ff62c168 3684 {
8f9da340
MW		 3685 ay = -ay;
3686 r2 = -r2;
3687 }
3688
3689 if (qq & 1L)
3690 {
3691 if (r2 >= ay)
3692 { qq++; rr -= yy; }
3693 else if (r2 <= -ay)
3694 { qq--; rr += yy; }
ff62c168
MW		 3695 }
3696 else
3697 {
8f9da340
MW		 3698 if (r2 > ay)
3699 { qq++; rr -= yy; }
3700 else if (r2 < -ay)
3701 { qq--; rr += yy; }
ff62c168 3702 }
4a46bc2a 3703 if (SCM_LIKELY (SCM_FIXABLE (qq)))
5fbf680b 3704 *qp = SCM_I_MAKINUM (qq);
4a46bc2a 3705 else
5fbf680b
MW		 3706 *qp = scm_i_inum2big (qq);
3707 *rp = SCM_I_MAKINUM (rr);
ff62c168 3708 }
5fbf680b 3709 return;
ff62c168
MW		 3710 }
3711 else if (SCM_BIGP (y))
3712 {
3713 /* Pass a denormalized bignum version of x (even though it
8f9da340
MW		 3714 can fit in a fixnum) to scm_i_bigint_round_divide */
3715 return scm_i_bigint_round_divide
3716 (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp);
ff62c168
MW		 3717 }
3718 else if (SCM_REALP (y))
8f9da340 3719 return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp);
ff62c168 3720 else if (SCM_FRACTIONP (y))
8f9da340 3721 return scm_i_exact_rational_round_divide (x, y, qp, rp);
ff62c168 3722 else
8f9da340
MW		 3723 return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3724 s_scm_round_divide, qp, rp);
ff62c168
MW		 3725 }
3726 else if (SCM_BIGP (x))
3727 {
3728 if (SCM_LIKELY (SCM_I_INUMP (y)))
3729 {
3730 scm_t_inum yy = SCM_I_INUM (y);
3731 if (SCM_UNLIKELY (yy == 0))
8f9da340 3732 scm_num_overflow (s_scm_round_divide);
ff62c168
MW		 3733 else
3734 {
3735 SCM q = scm_i_mkbig ();
3736 scm_t_inum rr;
8f9da340
MW		 3737 int needs_adjustment;
3738
ff62c168
MW		 3739 if (yy > 0)
3740 {
8f9da340
MW		 3741 rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
3742 SCM_I_BIG_MPZ (x), yy);
3743 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3744 needs_adjustment = (2*rr >= yy);
3745 else
3746 needs_adjustment = (2*rr > yy);
ff62c168
MW		 3747 }
3748 else
3749 {
3750 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3751 SCM_I_BIG_MPZ (x), -yy);
ff62c168 3752 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
8f9da340
MW		 3753 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3754 needs_adjustment = (2*rr <= yy);
3755 else
3756 needs_adjustment = (2*rr < yy);
3757 }
3758 scm_remember_upto_here_1 (x);
3759 if (needs_adjustment)
3760 {
3761 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
3762 rr -= yy;
ff62c168 3763 }
5fbf680b
MW		 3764 *qp = scm_i_normbig (q);
3765 *rp = SCM_I_MAKINUM (rr);
ff62c168 3766 }
5fbf680b 3767 return;
ff62c168
MW		 3768 }
3769 else if (SCM_BIGP (y))
8f9da340 3770 return scm_i_bigint_round_divide (x, y, qp, rp);
ff62c168 3771 else if (SCM_REALP (y))
8f9da340 3772 return scm_i_inexact_round_divide
5fbf680b 3773 (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
ff62c168 3774 else if (SCM_FRACTIONP (y))
8f9da340 3775 return scm_i_exact_rational_round_divide (x, y, qp, rp);
ff62c168 3776 else
8f9da340
MW		 3777 return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3778 s_scm_round_divide, qp, rp);
ff62c168
MW		 3779 }
3780 else if (SCM_REALP (x))
3781 {
3782 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3783 SCM_BIGP (y) || SCM_FRACTIONP (y))
8f9da340 3784 return scm_i_inexact_round_divide
5fbf680b 3785 (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
03ddd15b 3786 else
8f9da340
MW		 3787 return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3788 s_scm_round_divide, qp, rp);
ff62c168
MW		 3789 }
3790 else if (SCM_FRACTIONP (x))
3791 {
3792 if (SCM_REALP (y))
8f9da340 3793 return scm_i_inexact_round_divide
5fbf680b 3794 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
03ddd15b 3795 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
8f9da340 3796 return scm_i_exact_rational_round_divide (x, y, qp, rp);
ff62c168 3797 else
8f9da340
MW		 3798 return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3799 s_scm_round_divide, qp, rp);
ff62c168
MW		 3800 }
3801 else
8f9da340
MW		 3802 return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1,
3803 s_scm_round_divide, qp, rp);
ff62c168 3804}
ff62c168 3805
5fbf680b 3806static void
8f9da340 3807scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp)
ff62c168 3808{
8f9da340
MW		 3809 if (SCM_UNLIKELY (y == 0))
3810 scm_num_overflow (s_scm_round_divide); /* or return a NaN? */
ff62c168 3811 else
8f9da340
MW		 3812 {
3813 double q = scm_c_round (x / y);
3814 double r = x - q * y;
3815 *qp = scm_from_double (q);
3816 *rp = scm_from_double (r);
3817 }
ff62c168
MW		 3818}
3819
3820/* Assumes that both x and y are bigints, though
3821 x might be able to fit into a fixnum. */
5fbf680b 3822static void
8f9da340 3823scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
ff62c168 3824{
8f9da340
MW		 3825 SCM q, r, r2;
3826 int cmp, needs_adjustment;
ff62c168
MW		 3827
3828 /* Note that x might be small enough to fit into a
3829 fixnum, so we must not let it escape into the wild */
3830 q = scm_i_mkbig ();
3831 r = scm_i_mkbig ();
8f9da340 3832 r2 = scm_i_mkbig ();
ff62c168 3833
8f9da340
MW		 3834 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3835 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3836 scm_remember_upto_here_1 (x);
3837 mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
ff62c168 3838
8f9da340
MW		 3839 cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
3840 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3841 needs_adjustment = (cmp >= 0);
ff62c168 3842 else
8f9da340
MW		 3843 needs_adjustment = (cmp > 0);
3844
3845 if (needs_adjustment)
ff62c168 3846 {
8f9da340
MW		 3847 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
3848 mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
ff62c168 3849 }
8f9da340
MW		 3850
3851 scm_remember_upto_here_2 (r2, y);
5fbf680b
MW		 3852 *qp = scm_i_normbig (q);
3853 *rp = scm_i_normbig (r);
ff62c168
MW		 3854}
3855
5fbf680b 3856static void
8f9da340 3857scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
ff62c168 3858{
03ddd15b
MW		 3859 SCM r1;
3860 SCM xd = scm_denominator (x);
3861 SCM yd = scm_denominator (y);
3862
8f9da340
MW		 3863 scm_round_divide (scm_product (scm_numerator (x), yd),
3864 scm_product (scm_numerator (y), xd),
3865 qp, &r1);
03ddd15b 3866 *rp = scm_divide (r1, scm_product (xd, yd));
ff62c168
MW		 3867}
3868
3869
78d3deb1
AW		 3870SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
3871 (SCM x, SCM y, SCM rest),
3872 "Return the greatest common divisor of all parameter values.\n"
3873 "If called without arguments, 0 is returned.")
3874#define FUNC_NAME s_scm_i_gcd
3875{
3876 while (!scm_is_null (rest))
3877 { x = scm_gcd (x, y);
3878 y = scm_car (rest);
3879 rest = scm_cdr (rest);
3880 }
3881 return scm_gcd (x, y);
3882}
3883#undef FUNC_NAME
3884
3885#define s_gcd s_scm_i_gcd
3886#define g_gcd g_scm_i_gcd
3887
0f2d19dd 3888SCM
6e8d25a6 3889scm_gcd (SCM x, SCM y)
0f2d19dd 3890{
ca46fb90 3891 if (SCM_UNBNDP (y))
1dd79792 3892 return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x);
ca46fb90 3893
e11e83f3 3894 if (SCM_I_INUMP (x))
ca46fb90 3895 {
e11e83f3 3896 if (SCM_I_INUMP (y))
ca46fb90 3897 {
e25f3727
AW		 3898 scm_t_inum xx = SCM_I_INUM (x);
3899 scm_t_inum yy = SCM_I_INUM (y);
3900 scm_t_inum u = xx < 0 ? -xx : xx;
3901 scm_t_inum v = yy < 0 ? -yy : yy;
3902 scm_t_inum result;
0aacf84e
MD		 3903 if (xx == 0)
3904 result = v;
3905 else if (yy == 0)
3906 result = u;
3907 else
3908 {
e25f3727
AW		 3909 scm_t_inum k = 1;
3910 scm_t_inum t;
0aacf84e
MD		 3911 /* Determine a common factor 2^k */
3912 while (!(1 & (u | v)))
3913 {
3914 k <<= 1;
3915 u >>= 1;
3916 v >>= 1;
3917 }
3918 /* Now, any factor 2^n can be eliminated */
3919 if (u & 1)
3920 t = -v;
3921 else
3922 {
3923 t = u;
3924 b3:
3925 t = SCM_SRS (t, 1);
3926 }
3927 if (!(1 & t))
3928 goto b3;
3929 if (t > 0)
3930 u = t;
3931 else
3932 v = -t;
3933 t = u - v;
3934 if (t != 0)
3935 goto b3;
3936 result = u * k;
3937 }
3938 return (SCM_POSFIXABLE (result)
d956fa6f 3939 ? SCM_I_MAKINUM (result)
e25f3727 3940 : scm_i_inum2big (result));
ca46fb90
RB		 3941 }
3942 else if (SCM_BIGP (y))
3943 {
0bff4dce
KR		 3944 SCM_SWAP (x, y);
3945 goto big_inum;
ca46fb90
RB		 3946 }
3947 else
fa075d40 3948 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
f872b822 3949 }
ca46fb90
RB		 3950 else if (SCM_BIGP (x))
3951 {
e11e83f3 3952 if (SCM_I_INUMP (y))
ca46fb90 3953 {
e25f3727
AW		 3954 scm_t_bits result;
3955 scm_t_inum yy;
0bff4dce 3956 big_inum:
e11e83f3 3957 yy = SCM_I_INUM (y);
8c5b0afc
KR		 3958 if (yy == 0)
3959 return scm_abs (x);
0aacf84e
MD		 3960 if (yy < 0)
3961 yy = -yy;
ca46fb90
RB		 3962 result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
3963 scm_remember_upto_here_1 (x);
0aacf84e 3964 return (SCM_POSFIXABLE (result)
d956fa6f 3965 ? SCM_I_MAKINUM (result)
e25f3727 3966 : scm_from_unsigned_integer (result));
ca46fb90
RB		 3967 }
3968 else if (SCM_BIGP (y))
3969 {
3970 SCM result = scm_i_mkbig ();
0aacf84e
MD		 3971 mpz_gcd (SCM_I_BIG_MPZ (result),
3972 SCM_I_BIG_MPZ (x),
3973 SCM_I_BIG_MPZ (y));
3974 scm_remember_upto_here_2 (x, y);
ca46fb90
RB		 3975 return scm_i_normbig (result);
3976 }
3977 else
fa075d40 3978 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
09fb7599 3979 }
ca46fb90 3980 else
fa075d40 3981 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
0f2d19dd
JB		 3982}
3983
78d3deb1
AW		 3984SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
3985 (SCM x, SCM y, SCM rest),
3986 "Return the least common multiple of the arguments.\n"
3987 "If called without arguments, 1 is returned.")
3988#define FUNC_NAME s_scm_i_lcm
3989{
3990 while (!scm_is_null (rest))
3991 { x = scm_lcm (x, y);
3992 y = scm_car (rest);
3993 rest = scm_cdr (rest);
3994 }
3995 return scm_lcm (x, y);
3996}
3997#undef FUNC_NAME
3998
3999#define s_lcm s_scm_i_lcm
4000#define g_lcm g_scm_i_lcm
4001
0f2d19dd 4002SCM
6e8d25a6 4003scm_lcm (SCM n1, SCM n2)
0f2d19dd 4004{
ca46fb90
RB		 4005 if (SCM_UNBNDP (n2))
4006 {
4007 if (SCM_UNBNDP (n1))
d956fa6f
MV		 4008 return SCM_I_MAKINUM (1L);
4009 n2 = SCM_I_MAKINUM (1L);
09fb7599 4010 }
09fb7599 4011
fa075d40
AW		 4012 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1) || SCM_BIGP (n1))))
4013 return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
4014
4015 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2) || SCM_BIGP (n2))))
4016 return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
09fb7599 4017
e11e83f3 4018 if (SCM_I_INUMP (n1))
ca46fb90 4019 {
e11e83f3 4020 if (SCM_I_INUMP (n2))
ca46fb90
RB		 4021 {
4022 SCM d = scm_gcd (n1, n2);
bc36d050 4023 if (scm_is_eq (d, SCM_INUM0))
ca46fb90
RB		 4024 return d;
4025 else
4026 return scm_abs (scm_product (n1, scm_quotient (n2, d)));
4027 }
4028 else
4029 {
4030 /* inum n1, big n2 */
4031 inumbig:
4032 {
4033 SCM result = scm_i_mkbig ();
e25f3727 4034 scm_t_inum nn1 = SCM_I_INUM (n1);
ca46fb90
RB		 4035 if (nn1 == 0) return SCM_INUM0;
4036 if (nn1 < 0) nn1 = - nn1;
4037 mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
4038 scm_remember_upto_here_1 (n2);
4039 return result;
4040 }
4041 }
4042 }
4043 else
4044 {
4045 /* big n1 */
e11e83f3 4046 if (SCM_I_INUMP (n2))
ca46fb90
RB		 4047 {
4048 SCM_SWAP (n1, n2);
4049 goto inumbig;
4050 }
4051 else
4052 {
4053 SCM result = scm_i_mkbig ();
4054 mpz_lcm(SCM_I_BIG_MPZ (result),
4055 SCM_I_BIG_MPZ (n1),
4056 SCM_I_BIG_MPZ (n2));
4057 scm_remember_upto_here_2(n1, n2);
4058 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4059 return result;
4060 }
f872b822 4061 }
0f2d19dd
JB		 4062}
4063
8a525303
GB		 4064/* Emulating 2's complement bignums with sign magnitude arithmetic:
4065
4066 Logand:
4067 X Y Result Method:
4068 (len)
4069 + + + x (map digit:logand X Y)
4070 + - + x (map digit:logand X (lognot (+ -1 Y)))
4071 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4072 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4073
4074 Logior:
4075 X Y Result Method:
4076
4077 + + + (map digit:logior X Y)
4078 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4079 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4080 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4081
4082 Logxor:
4083 X Y Result Method:
4084
4085 + + + (map digit:logxor X Y)
4086 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4087 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4088 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4089
4090 Logtest:
4091 X Y Result
4092
4093 + + (any digit:logand X Y)
4094 + - (any digit:logand X (lognot (+ -1 Y)))
4095 - + (any digit:logand (lognot (+ -1 X)) Y)
4096 - - #t
4097
4098*/
4099
78d3deb1
AW		 4100SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
4101 (SCM x, SCM y, SCM rest),
4102 "Return the bitwise AND of the integer arguments.\n\n"
4103 "@lisp\n"
4104 "(logand) @result{} -1\n"
4105 "(logand 7) @result{} 7\n"
4106 "(logand #b111 #b011 #b001) @result{} 1\n"
4107 "@end lisp")
4108#define FUNC_NAME s_scm_i_logand
4109{
4110 while (!scm_is_null (rest))
4111 { x = scm_logand (x, y);
4112 y = scm_car (rest);
4113 rest = scm_cdr (rest);
4114 }
4115 return scm_logand (x, y);
4116}
4117#undef FUNC_NAME
4118
4119#define s_scm_logand s_scm_i_logand
4120
4121SCM scm_logand (SCM n1, SCM n2)
1bbd0b84 4122#define FUNC_NAME s_scm_logand
0f2d19dd 4123{
e25f3727 4124 scm_t_inum nn1;
9a00c9fc 4125
0aacf84e
MD		 4126 if (SCM_UNBNDP (n2))
4127 {
4128 if (SCM_UNBNDP (n1))
d956fa6f 4129 return SCM_I_MAKINUM (-1);
0aacf84e
MD		 4130 else if (!SCM_NUMBERP (n1))
4131 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4132 else if (SCM_NUMBERP (n1))
4133 return n1;
4134 else
4135 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 4136 }
09fb7599 4137
e11e83f3 4138 if (SCM_I_INUMP (n1))
0aacf84e 4139 {
e11e83f3
MV		 4140 nn1 = SCM_I_INUM (n1);
4141 if (SCM_I_INUMP (n2))
0aacf84e 4142 {
e25f3727 4143 scm_t_inum nn2 = SCM_I_INUM (n2);
d956fa6f 4144 return SCM_I_MAKINUM (nn1 & nn2);
0aacf84e
MD		 4145 }
4146 else if SCM_BIGP (n2)
4147 {
4148 intbig:
2e16a342 4149 if (nn1 == 0)
0aacf84e
MD		 4150 return SCM_INUM0;
4151 {
4152 SCM result_z = scm_i_mkbig ();
4153 mpz_t nn1_z;
4154 mpz_init_set_si (nn1_z, nn1);
4155 mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
4156 scm_remember_upto_here_1 (n2);
4157 mpz_clear (nn1_z);
4158 return scm_i_normbig (result_z);
4159 }
4160 }
4161 else
4162 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4163 }
4164 else if (SCM_BIGP (n1))
4165 {
e11e83f3 4166 if (SCM_I_INUMP (n2))
0aacf84e
MD		 4167 {
4168 SCM_SWAP (n1, n2);
e11e83f3 4169 nn1 = SCM_I_INUM (n1);
0aacf84e
MD		 4170 goto intbig;
4171 }
4172 else if (SCM_BIGP (n2))
4173 {
4174 SCM result_z = scm_i_mkbig ();
4175 mpz_and (SCM_I_BIG_MPZ (result_z),
4176 SCM_I_BIG_MPZ (n1),
4177 SCM_I_BIG_MPZ (n2));
4178 scm_remember_upto_here_2 (n1, n2);
4179 return scm_i_normbig (result_z);
4180 }
4181 else
4182 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 4183 }
0aacf84e 4184 else
09fb7599 4185 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 4186}
1bbd0b84 4187#undef FUNC_NAME
0f2d19dd 4188
09fb7599 4189
78d3deb1
AW		 4190SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
4191 (SCM x, SCM y, SCM rest),
4192 "Return the bitwise OR of the integer arguments.\n\n"
4193 "@lisp\n"
4194 "(logior) @result{} 0\n"
4195 "(logior 7) @result{} 7\n"
4196 "(logior #b000 #b001 #b011) @result{} 3\n"
4197 "@end lisp")
4198#define FUNC_NAME s_scm_i_logior
4199{
4200 while (!scm_is_null (rest))
4201 { x = scm_logior (x, y);
4202 y = scm_car (rest);
4203 rest = scm_cdr (rest);
4204 }
4205 return scm_logior (x, y);
4206}
4207#undef FUNC_NAME
4208
4209#define s_scm_logior s_scm_i_logior
4210
4211SCM scm_logior (SCM n1, SCM n2)
1bbd0b84 4212#define FUNC_NAME s_scm_logior
0f2d19dd 4213{
e25f3727 4214 scm_t_inum nn1;
9a00c9fc 4215
0aacf84e
MD		 4216 if (SCM_UNBNDP (n2))
4217 {
4218 if (SCM_UNBNDP (n1))
4219 return SCM_INUM0;
4220 else if (SCM_NUMBERP (n1))
4221 return n1;
4222 else
4223 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 4224 }
09fb7599 4225
e11e83f3 4226 if (SCM_I_INUMP (n1))
0aacf84e 4227 {
e11e83f3
MV		 4228 nn1 = SCM_I_INUM (n1);
4229 if (SCM_I_INUMP (n2))
0aacf84e 4230 {
e11e83f3 4231 long nn2 = SCM_I_INUM (n2);
d956fa6f 4232 return SCM_I_MAKINUM (nn1 | nn2);
0aacf84e
MD		 4233 }
4234 else if (SCM_BIGP (n2))
4235 {
4236 intbig:
4237 if (nn1 == 0)
4238 return n2;
4239 {
4240 SCM result_z = scm_i_mkbig ();
4241 mpz_t nn1_z;
4242 mpz_init_set_si (nn1_z, nn1);
4243 mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
4244 scm_remember_upto_here_1 (n2);
4245 mpz_clear (nn1_z);
9806de0d 4246 return scm_i_normbig (result_z);
0aacf84e
MD		 4247 }
4248 }
4249 else
4250 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4251 }
4252 else if (SCM_BIGP (n1))
4253 {
e11e83f3 4254 if (SCM_I_INUMP (n2))
0aacf84e
MD		 4255 {
4256 SCM_SWAP (n1, n2);
e11e83f3 4257 nn1 = SCM_I_INUM (n1);
0aacf84e
MD		 4258 goto intbig;
4259 }
4260 else if (SCM_BIGP (n2))
4261 {
4262 SCM result_z = scm_i_mkbig ();
4263 mpz_ior (SCM_I_BIG_MPZ (result_z),
4264 SCM_I_BIG_MPZ (n1),
4265 SCM_I_BIG_MPZ (n2));
4266 scm_remember_upto_here_2 (n1, n2);
9806de0d 4267 return scm_i_normbig (result_z);
0aacf84e
MD		 4268 }
4269 else
4270 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 4271 }
0aacf84e 4272 else
09fb7599 4273 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 4274}
1bbd0b84 4275#undef FUNC_NAME
0f2d19dd 4276
09fb7599 4277
78d3deb1
AW		 4278SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
4279 (SCM x, SCM y, SCM rest),
3c3db128
GH		 4280 "Return the bitwise XOR of the integer arguments. A bit is\n"
4281 "set in the result if it is set in an odd number of arguments.\n"
4282 "@lisp\n"
4283 "(logxor) @result{} 0\n"
4284 "(logxor 7) @result{} 7\n"
4285 "(logxor #b000 #b001 #b011) @result{} 2\n"
4286 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1e6808ea 4287 "@end lisp")
78d3deb1
AW		 4288#define FUNC_NAME s_scm_i_logxor
4289{
4290 while (!scm_is_null (rest))
4291 { x = scm_logxor (x, y);
4292 y = scm_car (rest);
4293 rest = scm_cdr (rest);
4294 }
4295 return scm_logxor (x, y);
4296}
4297#undef FUNC_NAME
4298
4299#define s_scm_logxor s_scm_i_logxor
4300
4301SCM scm_logxor (SCM n1, SCM n2)
1bbd0b84 4302#define FUNC_NAME s_scm_logxor
0f2d19dd 4303{
e25f3727 4304 scm_t_inum nn1;
9a00c9fc 4305
0aacf84e
MD		 4306 if (SCM_UNBNDP (n2))
4307 {
4308 if (SCM_UNBNDP (n1))
4309 return SCM_INUM0;
4310 else if (SCM_NUMBERP (n1))
4311 return n1;
4312 else
4313 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 4314 }
09fb7599 4315
e11e83f3 4316 if (SCM_I_INUMP (n1))
0aacf84e 4317 {
e11e83f3
MV		 4318 nn1 = SCM_I_INUM (n1);
4319 if (SCM_I_INUMP (n2))
0aacf84e 4320 {
e25f3727 4321 scm_t_inum nn2 = SCM_I_INUM (n2);
d956fa6f 4322 return SCM_I_MAKINUM (nn1 ^ nn2);
0aacf84e
MD		 4323 }
4324 else if (SCM_BIGP (n2))
4325 {
4326 intbig:
4327 {
4328 SCM result_z = scm_i_mkbig ();
4329 mpz_t nn1_z;
4330 mpz_init_set_si (nn1_z, nn1);
4331 mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
4332 scm_remember_upto_here_1 (n2);
4333 mpz_clear (nn1_z);
4334 return scm_i_normbig (result_z);
4335 }
4336 }
4337 else
4338 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4339 }
4340 else if (SCM_BIGP (n1))
4341 {
e11e83f3 4342 if (SCM_I_INUMP (n2))
0aacf84e
MD		 4343 {
4344 SCM_SWAP (n1, n2);
e11e83f3 4345 nn1 = SCM_I_INUM (n1);
0aacf84e
MD		 4346 goto intbig;
4347 }
4348 else if (SCM_BIGP (n2))
4349 {
4350 SCM result_z = scm_i_mkbig ();
4351 mpz_xor (SCM_I_BIG_MPZ (result_z),
4352 SCM_I_BIG_MPZ (n1),
4353 SCM_I_BIG_MPZ (n2));
4354 scm_remember_upto_here_2 (n1, n2);
4355 return scm_i_normbig (result_z);
4356 }
4357 else
4358 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 4359 }
0aacf84e 4360 else
09fb7599 4361 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 4362}
1bbd0b84 4363#undef FUNC_NAME
0f2d19dd 4364
09fb7599 4365
a1ec6916 4366SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
1e6808ea 4367 (SCM j, SCM k),
ba6e7231
KR		 4368 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4369 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4370 "without actually calculating the @code{logand}, just testing\n"
4371 "for non-zero.\n"
4372 "\n"
1e6808ea 4373 "@lisp\n"
b380b885
MD		 4374 "(logtest #b0100 #b1011) @result{} #f\n"
4375 "(logtest #b0100 #b0111) @result{} #t\n"
1e6808ea 4376 "@end lisp")
1bbd0b84 4377#define FUNC_NAME s_scm_logtest
0f2d19dd 4378{
e25f3727 4379 scm_t_inum nj;
9a00c9fc 4380
e11e83f3 4381 if (SCM_I_INUMP (j))
0aacf84e 4382 {
e11e83f3
MV		 4383 nj = SCM_I_INUM (j);
4384 if (SCM_I_INUMP (k))
0aacf84e 4385 {
e25f3727 4386 scm_t_inum nk = SCM_I_INUM (k);
73e4de09 4387 return scm_from_bool (nj & nk);
0aacf84e
MD		 4388 }
4389 else if (SCM_BIGP (k))
4390 {
4391 intbig:
4392 if (nj == 0)
4393 return SCM_BOOL_F;
4394 {
4395 SCM result;
4396 mpz_t nj_z;
4397 mpz_init_set_si (nj_z, nj);
4398 mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
4399 scm_remember_upto_here_1 (k);
73e4de09 4400 result = scm_from_bool (mpz_sgn (nj_z) != 0);
0aacf84e
MD		 4401 mpz_clear (nj_z);
4402 return result;
4403 }
4404 }
4405 else
4406 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
4407 }
4408 else if (SCM_BIGP (j))
4409 {
e11e83f3 4410 if (SCM_I_INUMP (k))
0aacf84e
MD		 4411 {
4412 SCM_SWAP (j, k);
e11e83f3 4413 nj = SCM_I_INUM (j);
0aacf84e
MD		 4414 goto intbig;
4415 }
4416 else if (SCM_BIGP (k))
4417 {
4418 SCM result;
4419 mpz_t result_z;
4420 mpz_init (result_z);
4421 mpz_and (result_z,
4422 SCM_I_BIG_MPZ (j),
4423 SCM_I_BIG_MPZ (k));
4424 scm_remember_upto_here_2 (j, k);
73e4de09 4425 result = scm_from_bool (mpz_sgn (result_z) != 0);
0aacf84e
MD		 4426 mpz_clear (result_z);
4427 return result;
4428 }
4429 else
4430 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
4431 }
4432 else
4433 SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
0f2d19dd 4434}
1bbd0b84 4435#undef FUNC_NAME
0f2d19dd 4436
c1bfcf60 4437
a1ec6916 4438SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
2cd04b42 4439 (SCM index, SCM j),
ba6e7231
KR		 4440 "Test whether bit number @var{index} in @var{j} is set.\n"
4441 "@var{index} starts from 0 for the least significant bit.\n"
4442 "\n"
1e6808ea 4443 "@lisp\n"
b380b885
MD		 4444 "(logbit? 0 #b1101) @result{} #t\n"
4445 "(logbit? 1 #b1101) @result{} #f\n"
4446 "(logbit? 2 #b1101) @result{} #t\n"
4447 "(logbit? 3 #b1101) @result{} #t\n"
4448 "(logbit? 4 #b1101) @result{} #f\n"
1e6808ea 4449 "@end lisp")
1bbd0b84 4450#define FUNC_NAME s_scm_logbit_p
0f2d19dd 4451{
78166ad5 4452 unsigned long int iindex;
5efd3c7d 4453 iindex = scm_to_ulong (index);
78166ad5 4454
e11e83f3 4455 if (SCM_I_INUMP (j))
0d75f6d8
KR		 4456 {
4457 /* bits above what's in an inum follow the sign bit */
20fcc8ed 4458 iindex = min (iindex, SCM_LONG_BIT - 1);
e11e83f3 4459 return scm_from_bool ((1L << iindex) & SCM_I_INUM (j));
0d75f6d8 4460 }
0aacf84e
MD		 4461 else if (SCM_BIGP (j))
4462 {
4463 int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
4464 scm_remember_upto_here_1 (j);
73e4de09 4465 return scm_from_bool (val);
0aacf84e
MD		 4466 }
4467 else
78166ad5 4468 SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
0f2d19dd 4469}
1bbd0b84 4470#undef FUNC_NAME
0f2d19dd 4471
78166ad5 4472
a1ec6916 4473SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
1bbd0b84 4474 (SCM n),
4d814788 4475 "Return the integer which is the ones-complement of the integer\n"
1e6808ea
MG		 4476 "argument.\n"
4477 "\n"
b380b885
MD		 4478 "@lisp\n"
4479 "(number->string (lognot #b10000000) 2)\n"
4480 " @result{} \"-10000001\"\n"
4481 "(number->string (lognot #b0) 2)\n"
4482 " @result{} \"-1\"\n"
1e6808ea 4483 "@end lisp")
1bbd0b84 4484#define FUNC_NAME s_scm_lognot
0f2d19dd 4485{
e11e83f3 4486 if (SCM_I_INUMP (n)) {
f9811f9f
KR		 4487 /* No overflow here, just need to toggle all the bits making up the inum.
4488 Enhancement: No need to strip the tag and add it back, could just xor
4489 a block of 1 bits, if that worked with the various debug versions of
4490 the SCM typedef. */
e11e83f3 4491 return SCM_I_MAKINUM (~ SCM_I_INUM (n));
f9811f9f
KR		 4492
4493 } else if (SCM_BIGP (n)) {
4494 SCM result = scm_i_mkbig ();
4495 mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
4496 scm_remember_upto_here_1 (n);
4497 return result;
4498
4499 } else {
4500 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
4501 }
0f2d19dd 4502}
1bbd0b84 4503#undef FUNC_NAME
0f2d19dd 4504
518b7508
KR		 4505/* returns 0 if IN is not an integer. OUT must already be
4506 initialized. */
4507static int
4508coerce_to_big (SCM in, mpz_t out)
4509{
4510 if (SCM_BIGP (in))
4511 mpz_set (out, SCM_I_BIG_MPZ (in));
e11e83f3
MV		 4512 else if (SCM_I_INUMP (in))
4513 mpz_set_si (out, SCM_I_INUM (in));
518b7508
KR		 4514 else
4515 return 0;
4516
4517 return 1;
4518}
4519
d885e204 4520SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0,
518b7508
KR		 4521 (SCM n, SCM k, SCM m),
4522 "Return @var{n} raised to the integer exponent\n"
4523 "@var{k}, modulo @var{m}.\n"
4524 "\n"
4525 "@lisp\n"
4526 "(modulo-expt 2 3 5)\n"
4527 " @result{} 3\n"
4528 "@end lisp")
d885e204 4529#define FUNC_NAME s_scm_modulo_expt
518b7508
KR		 4530{
4531 mpz_t n_tmp;
4532 mpz_t k_tmp;
4533 mpz_t m_tmp;
4534
4535 /* There are two classes of error we might encounter --
4536 1) Math errors, which we'll report by calling scm_num_overflow,
4537 and
4538 2) wrong-type errors, which of course we'll report by calling
4539 SCM_WRONG_TYPE_ARG.
4540 We don't report those errors immediately, however; instead we do
4541 some cleanup first. These variables tell us which error (if
4542 any) we should report after cleaning up.
4543 */
4544 int report_overflow = 0;
4545
4546 int position_of_wrong_type = 0;
4547 SCM value_of_wrong_type = SCM_INUM0;
4548
4549 SCM result = SCM_UNDEFINED;
4550
4551 mpz_init (n_tmp);
4552 mpz_init (k_tmp);
4553 mpz_init (m_tmp);
4554
bc36d050 4555 if (scm_is_eq (m, SCM_INUM0))
518b7508
KR		 4556 {
4557 report_overflow = 1;
4558 goto cleanup;
4559 }
4560
4561 if (!coerce_to_big (n, n_tmp))
4562 {
4563 value_of_wrong_type = n;
4564 position_of_wrong_type = 1;
4565 goto cleanup;
4566 }
4567
4568 if (!coerce_to_big (k, k_tmp))
4569 {
4570 value_of_wrong_type = k;
4571 position_of_wrong_type = 2;
4572 goto cleanup;
4573 }
4574
4575 if (!coerce_to_big (m, m_tmp))
4576 {
4577 value_of_wrong_type = m;
4578 position_of_wrong_type = 3;
4579 goto cleanup;
4580 }
4581
4582 /* if the exponent K is negative, and we simply call mpz_powm, we
4583 will get a divide-by-zero exception when an inverse 1/n mod m
4584 doesn't exist (or is not unique). Since exceptions are hard to
4585 handle, we'll attempt the inversion "by hand" -- that way, we get
4586 a simple failure code, which is easy to handle. */
4587
4588 if (-1 == mpz_sgn (k_tmp))
4589 {
4590 if (!mpz_invert (n_tmp, n_tmp, m_tmp))
4591 {
4592 report_overflow = 1;
4593 goto cleanup;
4594 }
4595 mpz_neg (k_tmp, k_tmp);
4596 }
4597
4598 result = scm_i_mkbig ();
4599 mpz_powm (SCM_I_BIG_MPZ (result),
4600 n_tmp,
4601 k_tmp,
4602 m_tmp);
b7b8c575
KR		 4603
4604 if (mpz_sgn (m_tmp) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
4605 mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), m_tmp);
4606
518b7508
KR		 4607 cleanup:
4608 mpz_clear (m_tmp);
4609 mpz_clear (k_tmp);
4610 mpz_clear (n_tmp);
4611
4612 if (report_overflow)
4613 scm_num_overflow (FUNC_NAME);
4614
4615 if (position_of_wrong_type)
4616 SCM_WRONG_TYPE_ARG (position_of_wrong_type,
4617 value_of_wrong_type);
4618
4619 return scm_i_normbig (result);
4620}
4621#undef FUNC_NAME
4622
a1ec6916 4623SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
2cd04b42 4624 (SCM n, SCM k),
ba6e7231
KR		 4625 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4626 "exact integer, @var{n} can be any number.\n"
4627 "\n"
2519490c
MW		 4628 "Negative @var{k} is supported, and results in\n"
4629 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4630 "@math{@var{n}^0} is 1, as usual, and that\n"
ba6e7231 4631 "includes @math{0^0} is 1.\n"
1e6808ea 4632 "\n"
b380b885 4633 "@lisp\n"
ba6e7231
KR		 4634 "(integer-expt 2 5) @result{} 32\n"
4635 "(integer-expt -3 3) @result{} -27\n"
4636 "(integer-expt 5 -3) @result{} 1/125\n"
4637 "(integer-expt 0 0) @result{} 1\n"
b380b885 4638 "@end lisp")
1bbd0b84 4639#define FUNC_NAME s_scm_integer_expt
0f2d19dd 4640{
e25f3727 4641 scm_t_inum i2 = 0;
1c35cb19
RB		 4642 SCM z_i2 = SCM_BOOL_F;
4643 int i2_is_big = 0;
d956fa6f 4644 SCM acc = SCM_I_MAKINUM (1L);
ca46fb90 4645
bfe1f03a
MW		 4646 /* Specifically refrain from checking the type of the first argument.
4647 This allows us to exponentiate any object that can be multiplied.
4648 If we must raise to a negative power, we must also be able to
4649 take its reciprocal. */
4650 if (!SCM_LIKELY (SCM_I_INUMP (k)) && !SCM_LIKELY (SCM_BIGP (k)))
01c7284a 4651 SCM_WRONG_TYPE_ARG (2, k);
5a8fc758 4652
bfe1f03a
MW		 4653 if (SCM_UNLIKELY (scm_is_eq (k, SCM_INUM0)))
4654 return SCM_INUM1; /* n^(exact0) is exact 1, regardless of n */
4655 else if (SCM_UNLIKELY (scm_is_eq (n, SCM_I_MAKINUM (-1L))))
4656 return scm_is_false (scm_even_p (k)) ? n : SCM_INUM1;
4657 /* The next check is necessary only because R6RS specifies different
4658 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4659 we simply skip this case and move on. */
4660 else if (SCM_NUMBERP (n) && scm_is_true (scm_zero_p (n)))
4661 {
4662 /* k cannot be 0 at this point, because we
4663 have already checked for that case above */
4664 if (scm_is_true (scm_positive_p (k)))
01c7284a
MW		 4665 return n;
4666 else /* return NaN for (0 ^ k) for negative k per R6RS */
4667 return scm_nan ();
4668 }
ca46fb90 4669
e11e83f3
MV		 4670 if (SCM_I_INUMP (k))
4671 i2 = SCM_I_INUM (k);
ca46fb90
RB		 4672 else if (SCM_BIGP (k))
4673 {
4674 z_i2 = scm_i_clonebig (k, 1);
ca46fb90
RB		 4675 scm_remember_upto_here_1 (k);
4676 i2_is_big = 1;
4677 }
2830fd91 4678 else
ca46fb90
RB		 4679 SCM_WRONG_TYPE_ARG (2, k);
4680
4681 if (i2_is_big)
f872b822 4682 {
ca46fb90
RB		 4683 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
4684 {
4685 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
4686 n = scm_divide (n, SCM_UNDEFINED);
4687 }
4688 while (1)
4689 {
4690 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
4691 {
ca46fb90
RB		 4692 return acc;
4693 }
4694 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
4695 {
ca46fb90
RB		 4696 return scm_product (acc, n);
4697 }
4698 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
4699 acc = scm_product (acc, n);
4700 n = scm_product (n, n);
4701 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
4702 }
f872b822 4703 }
ca46fb90 4704 else
f872b822 4705 {
ca46fb90
RB		 4706 if (i2 < 0)
4707 {
4708 i2 = -i2;
4709 n = scm_divide (n, SCM_UNDEFINED);
4710 }
4711 while (1)
4712 {
4713 if (0 == i2)
4714 return acc;
4715 if (1 == i2)
4716 return scm_product (acc, n);
4717 if (i2 & 1)
4718 acc = scm_product (acc, n);
4719 n = scm_product (n, n);
4720 i2 >>= 1;
4721 }
f872b822 4722 }
0f2d19dd 4723}
1bbd0b84 4724#undef FUNC_NAME
0f2d19dd 4725
a1ec6916 4726SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
1bbd0b84 4727 (SCM n, SCM cnt),
32f19569
KR		 4728 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4729 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1e6808ea 4730 "\n"
e7644cb2 4731 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
32f19569
KR		 4732 "@var{cnt} is negative it's a division, rounded towards negative\n"
4733 "infinity. (Note that this is not the same rounding as\n"
4734 "@code{quotient} does.)\n"
4735 "\n"
4736 "With @var{n} viewed as an infinite precision twos complement,\n"
4737 "@code{ash} means a left shift introducing zero bits, or a right\n"
4738 "shift dropping bits.\n"
1e6808ea 4739 "\n"
b380b885 4740 "@lisp\n"
1e6808ea
MG		 4741 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4742 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
32f19569
KR		 4743 "\n"
4744 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4745 "(ash -23 -2) @result{} -6\n"
a3c8b9fc 4746 "@end lisp")
1bbd0b84 4747#define FUNC_NAME s_scm_ash
0f2d19dd 4748{
3ab9f56e 4749 long bits_to_shift;
5efd3c7d 4750 bits_to_shift = scm_to_long (cnt);
ca46fb90 4751
788aca27
KR		 4752 if (SCM_I_INUMP (n))
4753 {
e25f3727 4754 scm_t_inum nn = SCM_I_INUM (n);
788aca27
KR		 4755
4756 if (bits_to_shift > 0)
4757 {
4758 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4759 overflow a non-zero fixnum. For smaller shifts we check the
4760 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4761 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4762 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4763 bits_to_shift)". */
4764
4765 if (nn == 0)
4766 return n;
4767
4768 if (bits_to_shift < SCM_I_FIXNUM_BIT-1
e25f3727 4769 && ((scm_t_bits)
788aca27
KR		 4770 (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
4771 <= 1))
4772 {
4773 return SCM_I_MAKINUM (nn << bits_to_shift);
4774 }
4775 else
4776 {
e25f3727 4777 SCM result = scm_i_inum2big (nn);
788aca27
KR		 4778 mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
4779 bits_to_shift);
4780 return result;
4781 }
4782 }
4783 else
4784 {
4785 bits_to_shift = -bits_to_shift;
4786 if (bits_to_shift >= SCM_LONG_BIT)
cff5fa33 4787 return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1));
788aca27
KR		 4788 else
4789 return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift));
4790 }
4791
4792 }
4793 else if (SCM_BIGP (n))
ca46fb90 4794 {
788aca27
KR		 4795 SCM result;
4796
4797 if (bits_to_shift == 0)
4798 return n;
4799
4800 result = scm_i_mkbig ();
4801 if (bits_to_shift >= 0)
4802 {
4803 mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
4804 bits_to_shift);
4805 return result;
4806 }
ca46fb90 4807 else
788aca27
KR		 4808 {
4809 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4810 we have to allocate a bignum even if the result is going to be a
4811 fixnum. */
4812 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
4813 -bits_to_shift);
4814 return scm_i_normbig (result);
4815 }
4816
ca46fb90
RB		 4817 }
4818 else
788aca27
KR		 4819 {
4820 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
4821 }
0f2d19dd 4822}
1bbd0b84 4823#undef FUNC_NAME
0f2d19dd 4824
3c9f20f8 4825
a1ec6916 4826SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
1bbd0b84 4827 (SCM n, SCM start, SCM end),
1e6808ea
MG		 4828 "Return the integer composed of the @var{start} (inclusive)\n"
4829 "through @var{end} (exclusive) bits of @var{n}. The\n"
4830 "@var{start}th bit becomes the 0-th bit in the result.\n"
4831 "\n"
b380b885
MD		 4832 "@lisp\n"
4833 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4834 " @result{} \"1010\"\n"
4835 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4836 " @result{} \"10110\"\n"
4837 "@end lisp")
1bbd0b84 4838#define FUNC_NAME s_scm_bit_extract
0f2d19dd 4839{
7f848242 4840 unsigned long int istart, iend, bits;
5efd3c7d
MV		 4841 istart = scm_to_ulong (start);
4842 iend = scm_to_ulong (end);
c1bfcf60 4843 SCM_ASSERT_RANGE (3, end, (iend >= istart));
78166ad5 4844
7f848242
KR		 4845 /* how many bits to keep */
4846 bits = iend - istart;
4847
e11e83f3 4848 if (SCM_I_INUMP (n))
0aacf84e 4849 {
e25f3727 4850 scm_t_inum in = SCM_I_INUM (n);
7f848242
KR		 4851
4852 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
d77ad560 4853 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
857ae6af 4854 in = SCM_SRS (in, min (istart, SCM_I_FIXNUM_BIT-1));
ac0c002c 4855
0aacf84e
MD		 4856 if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
4857 {
4858 /* Since we emulate two's complement encoded numbers, this
4859 * special case requires us to produce a result that has
7f848242 4860 * more bits than can be stored in a fixnum.
0aacf84e 4861 */
e25f3727 4862 SCM result = scm_i_inum2big (in);
7f848242
KR		 4863 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
4864 bits);
4865 return result;
0aacf84e 4866 }
ac0c002c 4867
7f848242 4868 /* mask down to requisite bits */
857ae6af 4869 bits = min (bits, SCM_I_FIXNUM_BIT);
d956fa6f 4870 return SCM_I_MAKINUM (in & ((1L << bits) - 1));
0aacf84e
MD		 4871 }
4872 else if (SCM_BIGP (n))
ac0c002c 4873 {
7f848242
KR		 4874 SCM result;
4875 if (bits == 1)
4876 {
d956fa6f 4877 result = SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart));
7f848242
KR		 4878 }
4879 else
4880 {
4881 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4882 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4883 such bits into a ulong. */
4884 result = scm_i_mkbig ();
4885 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(n), istart);
4886 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(result), bits);
4887 result = scm_i_normbig (result);
4888 }
4889 scm_remember_upto_here_1 (n);
4890 return result;
ac0c002c 4891 }
0aacf84e 4892 else
78166ad5 4893 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 4894}
1bbd0b84 4895#undef FUNC_NAME
0f2d19dd 4896
7f848242 4897
e4755e5c
JB		 4898static const char scm_logtab[] = {
4899 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4900};
1cc91f1b 4901
a1ec6916 4902SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
1bbd0b84 4903 (SCM n),
1e6808ea
MG		 4904 "Return the number of bits in integer @var{n}. If integer is\n"
4905 "positive, the 1-bits in its binary representation are counted.\n"
4906 "If negative, the 0-bits in its two's-complement binary\n"
4907 "representation are counted. If 0, 0 is returned.\n"
4908 "\n"
b380b885
MD		 4909 "@lisp\n"
4910 "(logcount #b10101010)\n"
ca46fb90
RB		 4911 " @result{} 4\n"
4912 "(logcount 0)\n"
4913 " @result{} 0\n"
4914 "(logcount -2)\n"
4915 " @result{} 1\n"
4916 "@end lisp")
4917#define FUNC_NAME s_scm_logcount
4918{
e11e83f3 4919 if (SCM_I_INUMP (n))
f872b822 4920 {
e25f3727
AW		 4921 unsigned long c = 0;
4922 scm_t_inum nn = SCM_I_INUM (n);
ca46fb90
RB		 4923 if (nn < 0)
4924 nn = -1 - nn;
4925 while (nn)
4926 {
4927 c += scm_logtab[15 & nn];
4928 nn >>= 4;
4929 }
d956fa6f 4930 return SCM_I_MAKINUM (c);
f872b822 4931 }
ca46fb90 4932 else if (SCM_BIGP (n))
f872b822 4933 {
ca46fb90 4934 unsigned long count;
713a4259
KR		 4935 if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
4936 count = mpz_popcount (SCM_I_BIG_MPZ (n));
ca46fb90 4937 else
713a4259
KR		 4938 count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
4939 scm_remember_upto_here_1 (n);
d956fa6f 4940 return SCM_I_MAKINUM (count);
f872b822 4941 }
ca46fb90
RB		 4942 else
4943 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 4944}
ca46fb90 4945#undef FUNC_NAME
0f2d19dd
JB		 4946
4947
ca46fb90
RB		 4948static const char scm_ilentab[] = {
4949 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4950};
4951
0f2d19dd 4952
ca46fb90
RB		 4953SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
4954 (SCM n),
4955 "Return the number of bits necessary to represent @var{n}.\n"
4956 "\n"
4957 "@lisp\n"
4958 "(integer-length #b10101010)\n"
4959 " @result{} 8\n"
4960 "(integer-length 0)\n"
4961 " @result{} 0\n"
4962 "(integer-length #b1111)\n"
4963 " @result{} 4\n"
4964 "@end lisp")
4965#define FUNC_NAME s_scm_integer_length
4966{
e11e83f3 4967 if (SCM_I_INUMP (n))
0aacf84e 4968 {
e25f3727 4969 unsigned long c = 0;
0aacf84e 4970 unsigned int l = 4;
e25f3727 4971 scm_t_inum nn = SCM_I_INUM (n);
0aacf84e
MD		 4972 if (nn < 0)
4973 nn = -1 - nn;
4974 while (nn)
4975 {
4976 c += 4;
4977 l = scm_ilentab [15 & nn];
4978 nn >>= 4;
4979 }
d956fa6f 4980 return SCM_I_MAKINUM (c - 4 + l);
0aacf84e
MD		 4981 }
4982 else if (SCM_BIGP (n))
4983 {
4984 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4985 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4986 1 too big, so check for that and adjust. */
4987 size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
4988 if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
4989 && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
4990 mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
4991 size--;
4992 scm_remember_upto_here_1 (n);
d956fa6f 4993 return SCM_I_MAKINUM (size);
0aacf84e
MD		 4994 }
4995 else
ca46fb90 4996 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
ca46fb90
RB		 4997}
4998#undef FUNC_NAME
0f2d19dd
JB		 4999
5000/*** NUMBERS -> STRINGS ***/
0b799eea
MV		 5001#define SCM_MAX_DBL_PREC 60
5002#define SCM_MAX_DBL_RADIX 36
5003
5004/* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5005static int scm_dblprec[SCM_MAX_DBL_RADIX - 1];
5006static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC];
5007
5008static
5009void init_dblprec(int *prec, int radix) {
5010 /* determine floating point precision by adding successively
5011 smaller increments to 1.0 until it is considered == 1.0 */
5012 double f = ((double)1.0)/radix;
5013 double fsum = 1.0 + f;
5014
5015 *prec = 0;
5016 while (fsum != 1.0)
5017 {
5018 if (++(*prec) > SCM_MAX_DBL_PREC)
5019 fsum = 1.0;
5020 else
5021 {
5022 f /= radix;
5023 fsum = f + 1.0;
5024 }
5025 }
5026 (*prec) -= 1;
5027}
5028
5029static
5030void init_fx_radix(double *fx_list, int radix)
5031{
5032 /* initialize a per-radix list of tolerances. When added
5033 to a number < 1.0, we can determine if we should raund
5034 up and quit converting a number to a string. */
5035 int i;
5036 fx_list[0] = 0.0;
5037 fx_list[1] = 0.5;
5038 for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i )
5039 fx_list[i] = (fx_list[i-1] / radix);
5040}
5041
5042/* use this array as a way to generate a single digit */
9b5fcde6 5043static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
0f2d19dd 5044
1be6b49c 5045static size_t
0b799eea 5046idbl2str (double f, char *a, int radix)
0f2d19dd 5047{
0b799eea
MV		 5048 int efmt, dpt, d, i, wp;
5049 double *fx;
5050#ifdef DBL_MIN_10_EXP
5051 double f_cpy;
5052 int exp_cpy;
5053#endif /* DBL_MIN_10_EXP */
5054 size_t ch = 0;
5055 int exp = 0;
5056
5057 if(radix < 2 ||
5058 radix > SCM_MAX_DBL_RADIX)
5059 {
5060 /* revert to existing behavior */
5061 radix = 10;
5062 }
5063
5064 wp = scm_dblprec[radix-2];
5065 fx = fx_per_radix[radix-2];
0f2d19dd 5066
f872b822 5067 if (f == 0.0)
abb7e44d
MV		 5068 {
5069#ifdef HAVE_COPYSIGN
5070 double sgn = copysign (1.0, f);
5071
5072 if (sgn < 0.0)
5073 a[ch++] = '-';
5074#endif
abb7e44d
MV		 5075 goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5076 }
7351e207 5077
2e65b52f 5078 if (isinf (f))
7351e207
MV		 5079 {
5080 if (f < 0)
5081 strcpy (a, "-inf.0");
5082 else
5083 strcpy (a, "+inf.0");
5084 return ch+6;
5085 }
2e65b52f 5086 else if (isnan (f))
7351e207
MV		 5087 {
5088 strcpy (a, "+nan.0");
5089 return ch+6;
5090 }
5091
f872b822
MD		 5092 if (f < 0.0)
5093 {
5094 f = -f;
5095 a[ch++] = '-';
5096 }
7351e207 5097
f872b822
MD		 5098#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5099 make-uniform-vector, from causing infinite loops. */
0b799eea
MV		 5100 /* just do the checking...if it passes, we do the conversion for our
5101 radix again below */
5102 f_cpy = f;
5103 exp_cpy = exp;
5104
5105 while (f_cpy < 1.0)
f872b822 5106 {
0b799eea
MV		 5107 f_cpy *= 10.0;
5108 if (exp_cpy-- < DBL_MIN_10_EXP)
7351e207
MV		 5109 {
5110 a[ch++] = '#';
5111 a[ch++] = '.';
5112 a[ch++] = '#';
5113 return ch;
5114 }
f872b822 5115 }
0b799eea 5116 while (f_cpy > 10.0)
f872b822 5117 {
0b799eea
MV		 5118 f_cpy *= 0.10;
5119 if (exp_cpy++ > DBL_MAX_10_EXP)
7351e207
MV		 5120 {
5121 a[ch++] = '#';
5122 a[ch++] = '.';
5123 a[ch++] = '#';
5124 return ch;
5125 }
f872b822 5126 }
0b799eea
MV		 5127#endif
5128
f872b822
MD		 5129 while (f < 1.0)
5130 {
0b799eea 5131 f *= radix;
f872b822
MD		 5132 exp--;
5133 }
0b799eea 5134 while (f > radix)
f872b822 5135 {
0b799eea 5136 f /= radix;
f872b822
MD		 5137 exp++;
5138 }
0b799eea
MV		 5139
5140 if (f + fx[wp] >= radix)
f872b822
MD		 5141 {
5142 f = 1.0;
5143 exp++;
5144 }
0f2d19dd 5145 zero:
f872b822 5146 efmt = (exp < -3) || (exp > wp + 2);
0f2d19dd 5147 if (!efmt)
cda139a7
MD		 5148 {
5149 if (exp < 0)
5150 {
5151 a[ch++] = '0';
5152 a[ch++] = '.';
5153 dpt = exp;
f872b822
MD		 5154 while (++dpt)
5155 a[ch++] = '0';
cda139a7
MD		 5156 }
5157 else
f872b822 5158 dpt = exp + 1;
cda139a7 5159 }
0f2d19dd
JB		 5160 else
5161 dpt = 1;
f872b822
MD		 5162
5163 do
5164 {
5165 d = f;
5166 f -= d;
0b799eea 5167 a[ch++] = number_chars[d];
f872b822
MD		 5168 if (f < fx[wp])
5169 break;
5170 if (f + fx[wp] >= 1.0)
5171 {
0b799eea 5172 a[ch - 1] = number_chars[d+1];
f872b822
MD		 5173 break;
5174 }
0b799eea 5175 f *= radix;
f872b822
MD		 5176 if (!(--dpt))
5177 a[ch++] = '.';
0f2d19dd 5178 }
f872b822 5179 while (wp--);
0f2d19dd
JB		 5180
5181 if (dpt > 0)
cda139a7 5182 {
cda139a7
MD		 5183 if ((dpt > 4) && (exp > 6))
5184 {
f872b822 5185 d = (a[0] == '-' ? 2 : 1);
cda139a7 5186 for (i = ch++; i > d; i--)
f872b822 5187 a[i] = a[i - 1];
cda139a7
MD		 5188 a[d] = '.';
5189 efmt = 1;
5190 }
5191 else
cda139a7 5192 {
f872b822
MD		 5193 while (--dpt)
5194 a[ch++] = '0';
cda139a7
MD		 5195 a[ch++] = '.';
5196 }
5197 }
f872b822
MD		 5198 if (a[ch - 1] == '.')
5199 a[ch++] = '0'; /* trailing zero */
5200 if (efmt && exp)
5201 {
5202 a[ch++] = 'e';
5203 if (exp < 0)
5204 {
5205 exp = -exp;
5206 a[ch++] = '-';
5207 }
0b799eea
MV		 5208 for (i = radix; i <= exp; i *= radix);
5209 for (i /= radix; i; i /= radix)
f872b822 5210 {
0b799eea 5211 a[ch++] = number_chars[exp / i];
f872b822
MD		 5212 exp %= i;
5213 }
0f2d19dd 5214 }
0f2d19dd
JB		 5215 return ch;
5216}
5217
7a1aba42
MV		 5218
5219static size_t
5220icmplx2str (double real, double imag, char *str, int radix)
5221{
5222 size_t i;
c7218482 5223 double sgn;
7a1aba42
MV		 5224
5225 i = idbl2str (real, str, radix);
c7218482
MW		 5226#ifdef HAVE_COPYSIGN
5227 sgn = copysign (1.0, imag);
5228#else
5229 sgn = imag;
5230#endif
5231 /* Don't output a '+' for negative numbers or for Inf and
5232 NaN. They will provide their own sign. */
5233 if (sgn >= 0 && DOUBLE_IS_FINITE (imag))
5234 str[i++] = '+';
5235 i += idbl2str (imag, &str[i], radix);
5236 str[i++] = 'i';
7a1aba42
MV		 5237 return i;
5238}
5239
1be6b49c 5240static size_t
0b799eea 5241iflo2str (SCM flt, char *str, int radix)
0f2d19dd 5242{
1be6b49c 5243 size_t i;
3c9a524f 5244 if (SCM_REALP (flt))
0b799eea 5245 i = idbl2str (SCM_REAL_VALUE (flt), str, radix);
0f2d19dd 5246 else
7a1aba42
MV		 5247 i = icmplx2str (SCM_COMPLEX_REAL (flt), SCM_COMPLEX_IMAG (flt),
5248 str, radix);
0f2d19dd
JB		 5249 return i;
5250}
0f2d19dd 5251
2881e77b 5252/* convert a scm_t_intmax to a string (unterminated). returns the number of
1bbd0b84
GB		 5253 characters in the result.
5254 rad is output base
5255 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1be6b49c 5256size_t
2881e77b
MV		 5257scm_iint2str (scm_t_intmax num, int rad, char *p)
5258{
5259 if (num < 0)
5260 {
5261 *p++ = '-';
5262 return scm_iuint2str (-num, rad, p) + 1;
5263 }
5264 else
5265 return scm_iuint2str (num, rad, p);
5266}
5267
5268/* convert a scm_t_intmax to a string (unterminated). returns the number of
5269 characters in the result.
5270 rad is output base
5271 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5272size_t
5273scm_iuint2str (scm_t_uintmax num, int rad, char *p)
0f2d19dd 5274{
1be6b49c
ML		 5275 size_t j = 1;
5276 size_t i;
2881e77b 5277 scm_t_uintmax n = num;
5c11cc9d 5278
a6f3af16
AW		 5279 if (rad < 2 || rad > 36)
5280 scm_out_of_range ("scm_iuint2str", scm_from_int (rad));
5281
f872b822 5282 for (n /= rad; n > 0; n /= rad)
5c11cc9d
GH		 5283 j++;
5284
5285 i = j;
2881e77b 5286 n = num;
f872b822
MD		 5287 while (i--)
5288 {
5c11cc9d
GH		 5289 int d = n % rad;
5290
f872b822 5291 n /= rad;
a6f3af16 5292 p[i] = number_chars[d];
f872b822 5293 }
0f2d19dd
JB		 5294 return j;
5295}
5296
a1ec6916 5297SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
bb628794
DH		 5298 (SCM n, SCM radix),
5299 "Return a string holding the external representation of the\n"
942e5b91
MG		 5300 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5301 "inexact, a radix of 10 will be used.")
1bbd0b84 5302#define FUNC_NAME s_scm_number_to_string
0f2d19dd 5303{
1bbd0b84 5304 int base;
98cb6e75 5305
0aacf84e 5306 if (SCM_UNBNDP (radix))
98cb6e75 5307 base = 10;
0aacf84e 5308 else
5efd3c7d 5309 base = scm_to_signed_integer (radix, 2, 36);
98cb6e75 5310
e11e83f3 5311 if (SCM_I_INUMP (n))
0aacf84e
MD		 5312 {
5313 char num_buf [SCM_INTBUFLEN];
e11e83f3 5314 size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf);
cc95e00a 5315 return scm_from_locale_stringn (num_buf, length);
0aacf84e
MD		 5316 }
5317 else if (SCM_BIGP (n))
5318 {
5319 char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
d88f5323
AW		 5320 size_t len = strlen (str);
5321 void (*freefunc) (void *, size_t);
5322 SCM ret;
5323 mp_get_memory_functions (NULL, NULL, &freefunc);
0aacf84e 5324 scm_remember_upto_here_1 (n);
d88f5323
AW		 5325 ret = scm_from_latin1_stringn (str, len);
5326 freefunc (str, len + 1);
5327 return ret;
0aacf84e 5328 }
f92e85f7
MV		 5329 else if (SCM_FRACTIONP (n))
5330 {
f92e85f7 5331 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
cc95e00a 5332 scm_from_locale_string ("/"),
f92e85f7
MV		 5333 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
5334 }
0aacf84e
MD		 5335 else if (SCM_INEXACTP (n))
5336 {
5337 char num_buf [FLOBUFLEN];
cc95e00a 5338 return scm_from_locale_stringn (num_buf, iflo2str (n, num_buf, base));
0aacf84e
MD		 5339 }
5340 else
bb628794 5341 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 5342}
1bbd0b84 5343#undef FUNC_NAME
0f2d19dd
JB		 5344
5345
ca46fb90
RB		 5346/* These print routines used to be stubbed here so that scm_repl.c
5347 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1cc91f1b 5348
0f2d19dd 5349int
e81d98ec 5350scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 5351{
56e55ac7 5352 char num_buf[FLOBUFLEN];
f209aeee 5353 scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
0f2d19dd
JB		 5354 return !0;
5355}
5356
b479fe9a
MV		 5357void
5358scm_i_print_double (double val, SCM port)
5359{
5360 char num_buf[FLOBUFLEN];
f209aeee 5361 scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
b479fe9a
MV		 5362}
5363
f3ae5d60 5364int
e81d98ec 5365scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
f92e85f7 5366
f3ae5d60 5367{
56e55ac7 5368 char num_buf[FLOBUFLEN];
f209aeee 5369 scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
f3ae5d60
MD		 5370 return !0;
5371}
1cc91f1b 5372
7a1aba42
MV		 5373void
5374scm_i_print_complex (double real, double imag, SCM port)
5375{
5376 char num_buf[FLOBUFLEN];
f209aeee 5377 scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
7a1aba42
MV		 5378}
5379
f92e85f7
MV		 5380int
5381scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
5382{
5383 SCM str;
f92e85f7 5384 str = scm_number_to_string (sexp, SCM_UNDEFINED);
a9178715 5385 scm_display (str, port);
f92e85f7
MV		 5386 scm_remember_upto_here_1 (str);
5387 return !0;
5388}
5389
0f2d19dd 5390int
e81d98ec 5391scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 5392{
ca46fb90 5393 char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
b57bf272
AW		 5394 size_t len = strlen (str);
5395 void (*freefunc) (void *, size_t);
5396 mp_get_memory_functions (NULL, NULL, &freefunc);
ca46fb90 5397 scm_remember_upto_here_1 (exp);
ea0582c2 5398 scm_lfwrite_unlocked (str, len, port);
b57bf272 5399 freefunc (str, len + 1);
0f2d19dd
JB		 5400 return !0;
5401}
5402/*** END nums->strs ***/
5403
3c9a524f 5404
0f2d19dd 5405/*** STRINGS -> NUMBERS ***/
2a8fecee 5406
3c9a524f
DH		 5407/* The following functions implement the conversion from strings to numbers.
5408 * The implementation somehow follows the grammar for numbers as it is given
5409 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5410 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5411 * points should be noted about the implementation:
bc3d34f5 5412 *
3c9a524f
DH		 5413 * * Each function keeps a local index variable 'idx' that points at the
5414 * current position within the parsed string. The global index is only
5415 * updated if the function could parse the corresponding syntactic unit
5416 * successfully.
bc3d34f5 5417 *
3c9a524f 5418 * * Similarly, the functions keep track of indicators of inexactness ('#',
bc3d34f5
MW		 5419 * '.' or exponents) using local variables ('hash_seen', 'x').
5420 *
3c9a524f
DH		 5421 * * Sequences of digits are parsed into temporary variables holding fixnums.
5422 * Only if these fixnums would overflow, the result variables are updated
5423 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5424 * the temporary variables holding the fixnums are cleared, and the process
5425 * starts over again. If for example fixnums were able to store five decimal
5426 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5427 * and the result was computed as 12345 * 100000 + 67890. In other words,
5428 * only every five digits two bignum operations were performed.
bc3d34f5
MW		 5429 *
5430 * Notes on the handling of exactness specifiers:
5431 *
5432 * When parsing non-real complex numbers, we apply exactness specifiers on
5433 * per-component basis, as is done in PLT Scheme. For complex numbers
5434 * written in rectangular form, exactness specifiers are applied to the
5435 * real and imaginary parts before calling scm_make_rectangular. For
5436 * complex numbers written in polar form, exactness specifiers are applied
5437 * to the magnitude and angle before calling scm_make_polar.
5438 *
5439 * There are two kinds of exactness specifiers: forced and implicit. A
5440 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5441 * the entire number, and applies to both components of a complex number.
5442 * "#e" causes each component to be made exact, and "#i" causes each
5443 * component to be made inexact. If no forced exactness specifier is
5444 * present, then the exactness of each component is determined
5445 * independently by the presence or absence of a decimal point or hash mark
5446 * within that component. If a decimal point or hash mark is present, the
5447 * component is made inexact, otherwise it is made exact.
5448 *
5449 * After the exactness specifiers have been applied to each component, they
5450 * are passed to either scm_make_rectangular or scm_make_polar to produce
5451 * the final result. Note that this will result in a real number if the
5452 * imaginary part, magnitude, or angle is an exact 0.
5453 *
5454 * For example, (string->number "#i5.0+0i") does the equivalent of:
5455 *
5456 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
3c9a524f
DH		 5457 */
5458
5459enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
5460
5461/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5462
a6f3af16
AW		 5463/* Caller is responsible for checking that the return value is in range
5464 for the given radix, which should be <= 36. */
5465static unsigned int
5466char_decimal_value (scm_t_uint32 c)
5467{
5468 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5469 that's certainly above any valid decimal, so we take advantage of
5470 that to elide some tests. */
5471 unsigned int d = (unsigned int) uc_decimal_value (c);
5472
5473 /* If that failed, try extended hexadecimals, then. Only accept ascii
5474 hexadecimals. */
5475 if (d >= 10U)
5476 {
5477 c = uc_tolower (c);
5478 if (c >= (scm_t_uint32) 'a')
5479 d = c - (scm_t_uint32)'a' + 10U;
5480 }
5481 return d;
5482}
3c9a524f 5483
91db4a37
LC		 5484/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5485 in base RADIX. Upon success, return the unsigned integer and update
5486 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
2a8fecee 5487static SCM
3f47e526 5488mem2uinteger (SCM mem, unsigned int *p_idx,
3c9a524f 5489 unsigned int radix, enum t_exactness *p_exactness)
2a8fecee 5490{
3c9a524f
DH		 5491 unsigned int idx = *p_idx;
5492 unsigned int hash_seen = 0;
5493 scm_t_bits shift = 1;
5494 scm_t_bits add = 0;
5495 unsigned int digit_value;
5496 SCM result;
5497 char c;
3f47e526 5498 size_t len = scm_i_string_length (mem);
3c9a524f
DH		 5499
5500 if (idx == len)
5501 return SCM_BOOL_F;
2a8fecee 5502
3f47e526 5503 c = scm_i_string_ref (mem, idx);
a6f3af16 5504 digit_value = char_decimal_value (c);
3c9a524f
DH		 5505 if (digit_value >= radix)
5506 return SCM_BOOL_F;
5507
5508 idx++;
d956fa6f 5509 result = SCM_I_MAKINUM (digit_value);
3c9a524f 5510 while (idx != len)
f872b822 5511 {
3f47e526 5512 scm_t_wchar c = scm_i_string_ref (mem, idx);
a6f3af16 5513 if (c == '#')
3c9a524f
DH		 5514 {
5515 hash_seen = 1;
5516 digit_value = 0;
5517 }
a6f3af16
AW		 5518 else if (hash_seen)
5519 break;
3c9a524f 5520 else
a6f3af16
AW		 5521 {
5522 digit_value = char_decimal_value (c);
5523 /* This check catches non-decimals in addition to out-of-range
5524 decimals. */
5525 if (digit_value >= radix)
5526 break;
5527 }
3c9a524f
DH		 5528
5529 idx++;
5530 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
5531 {
d956fa6f 5532 result = scm_product (result, SCM_I_MAKINUM (shift));
3c9a524f 5533 if (add > 0)
d956fa6f 5534 result = scm_sum (result, SCM_I_MAKINUM (add));
3c9a524f
DH		 5535
5536 shift = radix;
5537 add = digit_value;
5538 }
5539 else
5540 {
5541 shift = shift * radix;
5542 add = add * radix + digit_value;
5543 }
5544 };
5545
5546 if (shift > 1)
d956fa6f 5547 result = scm_product (result, SCM_I_MAKINUM (shift));
3c9a524f 5548 if (add > 0)
d956fa6f 5549 result = scm_sum (result, SCM_I_MAKINUM (add));
3c9a524f
DH		 5550
5551 *p_idx = idx;
5552 if (hash_seen)
5553 *p_exactness = INEXACT;
5554
5555 return result;
2a8fecee
JB		 5556}
5557
5558
3c9a524f
DH		 5559/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5560 * covers the parts of the rules that start at a potential point. The value
5561 * of the digits up to the point have been parsed by the caller and are given
79d34f68
DH		 5562 * in variable result. The content of *p_exactness indicates, whether a hash
5563 * has already been seen in the digits before the point.
3c9a524f 5564 */
1cc91f1b 5565
3f47e526 5566#define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
3c9a524f
DH		 5567
5568static SCM
3f47e526 5569mem2decimal_from_point (SCM result, SCM mem,
3c9a524f 5570 unsigned int *p_idx, enum t_exactness *p_exactness)
0f2d19dd 5571{
3c9a524f
DH		 5572 unsigned int idx = *p_idx;
5573 enum t_exactness x = *p_exactness;
3f47e526 5574 size_t len = scm_i_string_length (mem);
3c9a524f
DH		 5575
5576 if (idx == len)
79d34f68 5577 return result;
3c9a524f 5578
3f47e526 5579 if (scm_i_string_ref (mem, idx) == '.')
3c9a524f
DH		 5580 {
5581 scm_t_bits shift = 1;
5582 scm_t_bits add = 0;
5583 unsigned int digit_value;
cff5fa33 5584 SCM big_shift = SCM_INUM1;
3c9a524f
DH		 5585
5586 idx++;
5587 while (idx != len)
5588 {
3f47e526
MG		 5589 scm_t_wchar c = scm_i_string_ref (mem, idx);
5590 if (uc_is_property_decimal_digit ((scm_t_uint32) c))
3c9a524f
DH		 5591 {
5592 if (x == INEXACT)
5593 return SCM_BOOL_F;
5594 else
5595 digit_value = DIGIT2UINT (c);
5596 }
5597 else if (c == '#')
5598 {
5599 x = INEXACT;
5600 digit_value = 0;
5601 }
5602 else
5603 break;
5604
5605 idx++;
5606 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
5607 {
d956fa6f
MV		 5608 big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
5609 result = scm_product (result, SCM_I_MAKINUM (shift));
3c9a524f 5610 if (add > 0)
d956fa6f 5611 result = scm_sum (result, SCM_I_MAKINUM (add));
3c9a524f
DH		 5612
5613 shift = 10;
5614 add = digit_value;
5615 }
5616 else
5617 {
5618 shift = shift * 10;
5619 add = add * 10 + digit_value;
5620 }
5621 };
5622
5623 if (add > 0)
5624 {
d956fa6f
MV		 5625 big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
5626 result = scm_product (result, SCM_I_MAKINUM (shift));
5627 result = scm_sum (result, SCM_I_MAKINUM (add));
3c9a524f
DH		 5628 }
5629
d8592269 5630 result = scm_divide (result, big_shift);
79d34f68 5631
3c9a524f
DH		 5632 /* We've seen a decimal point, thus the value is implicitly inexact. */
5633 x = INEXACT;
f872b822 5634 }
3c9a524f 5635
3c9a524f 5636 if (idx != len)
f872b822 5637 {
3c9a524f
DH		 5638 int sign = 1;
5639 unsigned int start;
3f47e526 5640 scm_t_wchar c;
3c9a524f
DH		 5641 int exponent;
5642 SCM e;
5643
5644 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5645
3f47e526 5646 switch (scm_i_string_ref (mem, idx))
f872b822 5647 {
3c9a524f
DH		 5648 case 'd': case 'D':
5649 case 'e': case 'E':
5650 case 'f': case 'F':
5651 case 'l': case 'L':
5652 case 's': case 'S':
5653 idx++;
ee0ddd21
AW		 5654 if (idx == len)
5655 return SCM_BOOL_F;
5656
3c9a524f 5657 start = idx;
3f47e526 5658 c = scm_i_string_ref (mem, idx);
3c9a524f
DH		 5659 if (c == '-')
5660 {
5661 idx++;
ee0ddd21
AW		 5662 if (idx == len)
5663 return SCM_BOOL_F;
5664
3c9a524f 5665 sign = -1;
3f47e526 5666 c = scm_i_string_ref (mem, idx);
3c9a524f
DH		 5667 }
5668 else if (c == '+')
5669 {
5670 idx++;
ee0ddd21
AW		 5671 if (idx == len)
5672 return SCM_BOOL_F;
5673
3c9a524f 5674 sign = 1;
3f47e526 5675 c = scm_i_string_ref (mem, idx);
3c9a524f
DH		 5676 }
5677 else
5678 sign = 1;
5679
3f47e526 5680 if (!uc_is_property_decimal_digit ((scm_t_uint32) c))
3c9a524f
DH		 5681 return SCM_BOOL_F;
5682
5683 idx++;
5684 exponent = DIGIT2UINT (c);
5685 while (idx != len)
f872b822 5686 {
3f47e526
MG		 5687 scm_t_wchar c = scm_i_string_ref (mem, idx);
5688 if (uc_is_property_decimal_digit ((scm_t_uint32) c))
3c9a524f
DH		 5689 {
5690 idx++;
5691 if (exponent <= SCM_MAXEXP)
5692 exponent = exponent * 10 + DIGIT2UINT (c);
5693 }
5694 else
5695 break;
f872b822 5696 }
3c9a524f
DH		 5697
5698 if (exponent > SCM_MAXEXP)
f872b822 5699 {
3c9a524f 5700 size_t exp_len = idx - start;
3f47e526 5701 SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len);
3c9a524f
DH		 5702 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
5703 scm_out_of_range ("string->number", exp_num);
f872b822 5704 }
3c9a524f 5705
d956fa6f 5706 e = scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent));
3c9a524f
DH		 5707 if (sign == 1)
5708 result = scm_product (result, e);
5709 else
6ebecdeb 5710 result = scm_divide (result, e);
3c9a524f
DH		 5711
5712 /* We've seen an exponent, thus the value is implicitly inexact. */
5713 x = INEXACT;
5714
f872b822 5715 break;
3c9a524f 5716
f872b822 5717 default:
3c9a524f 5718 break;
f872b822 5719 }
0f2d19dd 5720 }
3c9a524f
DH		 5721
5722 *p_idx = idx;
5723 if (x == INEXACT)
5724 *p_exactness = x;
5725
5726 return result;
0f2d19dd 5727}
0f2d19dd 5728
3c9a524f
DH		 5729
5730/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5731
5732static SCM
3f47e526 5733mem2ureal (SCM mem, unsigned int *p_idx,
9d427b2c 5734 unsigned int radix, enum t_exactness forced_x)
0f2d19dd 5735{
3c9a524f 5736 unsigned int idx = *p_idx;
164d2481 5737 SCM result;
3f47e526 5738 size_t len = scm_i_string_length (mem);
3c9a524f 5739
40f89215
NJ		 5740 /* Start off believing that the number will be exact. This changes
5741 to INEXACT if we see a decimal point or a hash. */
9d427b2c 5742 enum t_exactness implicit_x = EXACT;
40f89215 5743
3c9a524f
DH		 5744 if (idx == len)
5745 return SCM_BOOL_F;
5746
3f47e526 5747 if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0"))
7351e207
MV		 5748 {
5749 *p_idx = idx+5;
5750 return scm_inf ();
5751 }
5752
3f47e526 5753 if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan."))
7351e207 5754 {
d8592269
MV		 5755 /* Cobble up the fractional part. We might want to set the
5756 NaN's mantissa from it. */
7351e207 5757 idx += 4;
91db4a37 5758 if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0))
5f237d6e
AW		 5759 {
5760#if SCM_ENABLE_DEPRECATED == 1
5761 scm_c_issue_deprecation_warning
5762 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5763#else
5764 return SCM_BOOL_F;
5765#endif
5766 }
5767
7351e207
MV		 5768 *p_idx = idx;
5769 return scm_nan ();
5770 }
5771
3f47e526 5772 if (scm_i_string_ref (mem, idx) == '.')
3c9a524f
DH		 5773 {
5774 if (radix != 10)
5775 return SCM_BOOL_F;
5776 else if (idx + 1 == len)
5777 return SCM_BOOL_F;
3f47e526 5778 else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1)))
3c9a524f
DH		 5779 return SCM_BOOL_F;
5780 else
cff5fa33 5781 result = mem2decimal_from_point (SCM_INUM0, mem,
9d427b2c 5782 p_idx, &implicit_x);
f872b822 5783 }
3c9a524f
DH		 5784 else
5785 {
3c9a524f 5786 SCM uinteger;
3c9a524f 5787
9d427b2c 5788 uinteger = mem2uinteger (mem, &idx, radix, &implicit_x);
73e4de09 5789 if (scm_is_false (uinteger))
3c9a524f
DH		 5790 return SCM_BOOL_F;
5791
5792 if (idx == len)
5793 result = uinteger;
3f47e526 5794 else if (scm_i_string_ref (mem, idx) == '/')
f872b822 5795 {
3c9a524f
DH		 5796 SCM divisor;
5797
5798 idx++;
ee0ddd21
AW		 5799 if (idx == len)
5800 return SCM_BOOL_F;
3c9a524f 5801
9d427b2c 5802 divisor = mem2uinteger (mem, &idx, radix, &implicit_x);
73e4de09 5803 if (scm_is_false (divisor))
3c9a524f
DH		 5804 return SCM_BOOL_F;
5805
f92e85f7 5806 /* both are int/big here, I assume */
cba42c93 5807 result = scm_i_make_ratio (uinteger, divisor);
f872b822 5808 }
3c9a524f
DH		 5809 else if (radix == 10)
5810 {
9d427b2c 5811 result = mem2decimal_from_point (uinteger, mem, &idx, &implicit_x);
73e4de09 5812 if (scm_is_false (result))
3c9a524f
DH		 5813 return SCM_BOOL_F;
5814 }
5815 else
5816 result = uinteger;
5817
5818 *p_idx = idx;
f872b822 5819 }
164d2481 5820
9d427b2c
MW		 5821 switch (forced_x)
5822 {
5823 case EXACT:
5824 if (SCM_INEXACTP (result))
5825 return scm_inexact_to_exact (result);
5826 else
5827 return result;
5828 case INEXACT:
5829 if (SCM_INEXACTP (result))
5830 return result;
5831 else
5832 return scm_exact_to_inexact (result);
5833 case NO_EXACTNESS:
5834 if (implicit_x == INEXACT)
5835 {
5836 if (SCM_INEXACTP (result))
5837 return result;
5838 else
5839 return scm_exact_to_inexact (result);
5840 }
5841 else
5842 return result;
5843 }
164d2481 5844
9d427b2c
MW		 5845 /* We should never get here */
5846 scm_syserror ("mem2ureal");
3c9a524f 5847}
0f2d19dd 5848
0f2d19dd 5849
3c9a524f 5850/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
0f2d19dd 5851
3c9a524f 5852static SCM
3f47e526 5853mem2complex (SCM mem, unsigned int idx,
9d427b2c 5854 unsigned int radix, enum t_exactness forced_x)
3c9a524f 5855{
3f47e526 5856 scm_t_wchar c;
3c9a524f
DH		 5857 int sign = 0;
5858 SCM ureal;
3f47e526 5859 size_t len = scm_i_string_length (mem);
3c9a524f
DH		 5860
5861 if (idx == len)
5862 return SCM_BOOL_F;
5863
3f47e526 5864 c = scm_i_string_ref (mem, idx);
3c9a524f
DH		 5865 if (c == '+')
5866 {
5867 idx++;
5868 sign = 1;
5869 }
5870 else if (c == '-')
5871 {
5872 idx++;
5873 sign = -1;
0f2d19dd 5874 }
0f2d19dd 5875
3c9a524f
DH		 5876 if (idx == len)
5877 return SCM_BOOL_F;
5878
9d427b2c 5879 ureal = mem2ureal (mem, &idx, radix, forced_x);
73e4de09 5880 if (scm_is_false (ureal))
f872b822 5881 {
3c9a524f
DH		 5882 /* input must be either +i or -i */
5883
5884 if (sign == 0)
5885 return SCM_BOOL_F;
5886
3f47e526
MG		 5887 if (scm_i_string_ref (mem, idx) == 'i'
5888 || scm_i_string_ref (mem, idx) == 'I')
f872b822 5889 {
3c9a524f
DH		 5890 idx++;
5891 if (idx != len)
5892 return SCM_BOOL_F;
5893
cff5fa33 5894 return scm_make_rectangular (SCM_INUM0, SCM_I_MAKINUM (sign));
f872b822 5895 }
3c9a524f
DH		 5896 else
5897 return SCM_BOOL_F;
0f2d19dd 5898 }
3c9a524f
DH		 5899 else
5900 {
73e4de09 5901 if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
3c9a524f 5902 ureal = scm_difference (ureal, SCM_UNDEFINED);
f872b822 5903
3c9a524f
DH		 5904 if (idx == len)
5905 return ureal;
5906
3f47e526 5907 c = scm_i_string_ref (mem, idx);
3c9a524f 5908 switch (c)
f872b822 5909 {
3c9a524f
DH		 5910 case 'i': case 'I':
5911 /* either +<ureal>i or -<ureal>i */
5912
5913 idx++;
5914 if (sign == 0)
5915 return SCM_BOOL_F;
5916 if (idx != len)
5917 return SCM_BOOL_F;
cff5fa33 5918 return scm_make_rectangular (SCM_INUM0, ureal);
3c9a524f
DH		 5919
5920 case '@':
5921 /* polar input: <real>@<real>. */
5922
5923 idx++;
5924 if (idx == len)
5925 return SCM_BOOL_F;
5926 else
f872b822 5927 {
3c9a524f
DH		 5928 int sign;
5929 SCM angle;
5930 SCM result;
5931
3f47e526 5932 c = scm_i_string_ref (mem, idx);
3c9a524f
DH		 5933 if (c == '+')
5934 {
5935 idx++;
ee0ddd21
AW		 5936 if (idx == len)
5937 return SCM_BOOL_F;
3c9a524f
DH		 5938 sign = 1;
5939 }
5940 else if (c == '-')
5941 {
5942 idx++;
ee0ddd21
AW		 5943 if (idx == len)
5944 return SCM_BOOL_F;
3c9a524f
DH		 5945 sign = -1;
5946 }
5947 else
5948 sign = 1;
5949
9d427b2c 5950 angle = mem2ureal (mem, &idx, radix, forced_x);
73e4de09 5951 if (scm_is_false (angle))
3c9a524f
DH		 5952 return SCM_BOOL_F;
5953 if (idx != len)
5954 return SCM_BOOL_F;
5955
73e4de09 5956 if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
3c9a524f
DH		 5957 angle = scm_difference (angle, SCM_UNDEFINED);
5958
5959 result = scm_make_polar (ureal, angle);
5960 return result;
f872b822 5961 }
3c9a524f
DH		 5962 case '+':
5963 case '-':
5964 /* expecting input matching <real>[+-]<ureal>?i */
0f2d19dd 5965
3c9a524f
DH		 5966 idx++;
5967 if (idx == len)
5968 return SCM_BOOL_F;
5969 else
5970 {
5971 int sign = (c == '+') ? 1 : -1;
9d427b2c 5972 SCM imag = mem2ureal (mem, &idx, radix, forced_x);
0f2d19dd 5973
73e4de09 5974 if (scm_is_false (imag))
d956fa6f 5975 imag = SCM_I_MAKINUM (sign);
23295dc3 5976 else if (sign == -1 && scm_is_false (scm_nan_p (imag)))
1fe5e088 5977 imag = scm_difference (imag, SCM_UNDEFINED);
0f2d19dd 5978
3c9a524f
DH		 5979 if (idx == len)
5980 return SCM_BOOL_F;
3f47e526
MG		 5981 if (scm_i_string_ref (mem, idx) != 'i'
5982 && scm_i_string_ref (mem, idx) != 'I')
3c9a524f 5983 return SCM_BOOL_F;
0f2d19dd 5984
3c9a524f
DH		 5985 idx++;
5986 if (idx != len)
5987 return SCM_BOOL_F;
0f2d19dd 5988
1fe5e088 5989 return scm_make_rectangular (ureal, imag);
3c9a524f
DH		 5990 }
5991 default:
5992 return SCM_BOOL_F;
5993 }
5994 }
0f2d19dd 5995}
0f2d19dd
JB		 5996
5997
3c9a524f
DH		 5998/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5999
6000enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
1cc91f1b 6001
0f2d19dd 6002SCM
3f47e526 6003scm_i_string_to_number (SCM mem, unsigned int default_radix)
0f2d19dd 6004{
3c9a524f
DH		 6005 unsigned int idx = 0;
6006 unsigned int radix = NO_RADIX;
6007 enum t_exactness forced_x = NO_EXACTNESS;
3f47e526 6008 size_t len = scm_i_string_length (mem);
3c9a524f
DH		 6009
6010 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
3f47e526 6011 while (idx + 2 < len && scm_i_string_ref (mem, idx) == '#')
3c9a524f 6012 {
3f47e526 6013 switch (scm_i_string_ref (mem, idx + 1))
3c9a524f
DH		 6014 {
6015 case 'b': case 'B':
6016 if (radix != NO_RADIX)
6017 return SCM_BOOL_F;
6018 radix = DUAL;
6019 break;
6020 case 'd': case 'D':
6021 if (radix != NO_RADIX)
6022 return SCM_BOOL_F;
6023 radix = DEC;
6024 break;
6025 case 'i': case 'I':
6026 if (forced_x != NO_EXACTNESS)
6027 return SCM_BOOL_F;
6028 forced_x = INEXACT;
6029 break;
6030 case 'e': case 'E':
6031 if (forced_x != NO_EXACTNESS)
6032 return SCM_BOOL_F;
6033 forced_x = EXACT;
6034 break;
6035 case 'o': case 'O':
6036 if (radix != NO_RADIX)
6037 return SCM_BOOL_F;
6038 radix = OCT;
6039 break;
6040 case 'x': case 'X':
6041 if (radix != NO_RADIX)
6042 return SCM_BOOL_F;
6043 radix = HEX;
6044 break;
6045 default:
f872b822 6046 return SCM_BOOL_F;
3c9a524f
DH		 6047 }
6048 idx += 2;
6049 }
6050
6051 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6052 if (radix == NO_RADIX)
9d427b2c 6053 radix = default_radix;
f872b822 6054
9d427b2c 6055 return mem2complex (mem, idx, radix, forced_x);
0f2d19dd
JB		 6056}
6057
3f47e526
MG		 6058SCM
6059scm_c_locale_stringn_to_number (const char* mem, size_t len,
6060 unsigned int default_radix)
6061{
6062 SCM str = scm_from_locale_stringn (mem, len);
6063
6064 return scm_i_string_to_number (str, default_radix);
6065}
6066
0f2d19dd 6067
a1ec6916 6068SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
bb628794 6069 (SCM string, SCM radix),
1e6808ea 6070 "Return a number of the maximally precise representation\n"
942e5b91 6071 "expressed by the given @var{string}. @var{radix} must be an\n"
5352393c
MG		 6072 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6073 "is a default radix that may be overridden by an explicit radix\n"
6074 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6075 "supplied, then the default radix is 10. If string is not a\n"
6076 "syntactically valid notation for a number, then\n"
6077 "@code{string->number} returns @code{#f}.")
1bbd0b84 6078#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 6079{
6080 SCM answer;
5efd3c7d 6081 unsigned int base;
a6d9e5ab 6082 SCM_VALIDATE_STRING (1, string);
5efd3c7d
MV		 6083
6084 if (SCM_UNBNDP (radix))
6085 base = 10;
6086 else
6087 base = scm_to_unsigned_integer (radix, 2, INT_MAX);
6088
3f47e526 6089 answer = scm_i_string_to_number (string, base);
8824ac88
MV		 6090 scm_remember_upto_here_1 (string);
6091 return answer;
0f2d19dd 6092}
1bbd0b84 6093#undef FUNC_NAME
3c9a524f
DH		 6094
6095
0f2d19dd
JB		 6096/*** END strs->nums ***/
6097
5986c47d 6098
8507ec80
MV		 6099SCM_DEFINE (scm_number_p, "number?", 1, 0, 0,
6100 (SCM x),
6101 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6102 "otherwise.")
6103#define FUNC_NAME s_scm_number_p
6104{
6105 return scm_from_bool (SCM_NUMBERP (x));
6106}
6107#undef FUNC_NAME
6108
6109SCM_DEFINE (scm_complex_p, "complex?", 1, 0, 0,
1bbd0b84 6110 (SCM x),
942e5b91 6111 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
bb2c02f2 6112 "otherwise. Note that the sets of real, rational and integer\n"
942e5b91
MG		 6113 "values form subsets of the set of complex numbers, i. e. the\n"
6114 "predicate will also be fulfilled if @var{x} is a real,\n"
6115 "rational or integer number.")
8507ec80 6116#define FUNC_NAME s_scm_complex_p
0f2d19dd 6117{
8507ec80
MV		 6118 /* all numbers are complex. */
6119 return scm_number_p (x);
0f2d19dd 6120}
1bbd0b84 6121#undef FUNC_NAME
0f2d19dd 6122
f92e85f7
MV		 6123SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
6124 (SCM x),
6125 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6126 "otherwise. Note that the set of integer values forms a subset of\n"
6127 "the set of real numbers, i. e. the predicate will also be\n"
6128 "fulfilled if @var{x} is an integer number.")
6129#define FUNC_NAME s_scm_real_p
6130{
c960e556
MW		 6131 return scm_from_bool
6132 (SCM_I_INUMP (x) || SCM_REALP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x));
f92e85f7
MV		 6133}
6134#undef FUNC_NAME
6135
6136SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
1bbd0b84 6137 (SCM x),
942e5b91 6138 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
bb2c02f2 6139 "otherwise. Note that the set of integer values forms a subset of\n"
942e5b91 6140 "the set of rational numbers, i. e. the predicate will also be\n"
f92e85f7
MV		 6141 "fulfilled if @var{x} is an integer number.")
6142#define FUNC_NAME s_scm_rational_p
0f2d19dd 6143{
c960e556 6144 if (SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))
f92e85f7
MV		 6145 return SCM_BOOL_T;
6146 else if (SCM_REALP (x))
c960e556
MW		 6147 /* due to their limited precision, finite floating point numbers are
6148 rational as well. (finite means neither infinity nor a NaN) */
6149 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x)));
0aacf84e 6150 else
bb628794 6151 return SCM_BOOL_F;
0f2d19dd 6152}
1bbd0b84 6153#undef FUNC_NAME
0f2d19dd 6154
a1ec6916 6155SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
1bbd0b84 6156 (SCM x),
942e5b91
MG		 6157 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6158 "else.")
1bbd0b84 6159#define FUNC_NAME s_scm_integer_p
0f2d19dd 6160{
c960e556 6161 if (SCM_I_INUMP (x) || SCM_BIGP (x))
f872b822 6162 return SCM_BOOL_T;
c960e556
MW		 6163 else if (SCM_REALP (x))
6164 {
6165 double val = SCM_REAL_VALUE (x);
6166 return scm_from_bool (!isinf (val) && (val == floor (val)));
6167 }
6168 else
8e43ed5d 6169 return SCM_BOOL_F;
0f2d19dd 6170}
1bbd0b84 6171#undef FUNC_NAME
0f2d19dd
JB		 6172
6173
8a1f4f98
AW		 6174SCM scm_i_num_eq_p (SCM, SCM, SCM);
6175SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
6176 (SCM x, SCM y, SCM rest),
6177 "Return @code{#t} if all parameters are numerically equal.")
6178#define FUNC_NAME s_scm_i_num_eq_p
6179{
6180 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6181 return SCM_BOOL_T;
6182 while (!scm_is_null (rest))
6183 {
6184 if (scm_is_false (scm_num_eq_p (x, y)))
6185 return SCM_BOOL_F;
6186 x = y;
6187 y = scm_car (rest);
6188 rest = scm_cdr (rest);
6189 }
6190 return scm_num_eq_p (x, y);
6191}
6192#undef FUNC_NAME
0f2d19dd 6193SCM
6e8d25a6 6194scm_num_eq_p (SCM x, SCM y)
0f2d19dd 6195{
d8b95e27 6196 again:
e11e83f3 6197 if (SCM_I_INUMP (x))
0aacf84e 6198 {
e25f3727 6199 scm_t_signed_bits xx = SCM_I_INUM (x);
e11e83f3 6200 if (SCM_I_INUMP (y))
0aacf84e 6201 {
e25f3727 6202 scm_t_signed_bits yy = SCM_I_INUM (y);
73e4de09 6203 return scm_from_bool (xx == yy);
0aacf84e
MD		 6204 }
6205 else if (SCM_BIGP (y))
6206 return SCM_BOOL_F;
6207 else if (SCM_REALP (y))
e8c5b1f2
KR		 6208 {
6209 /* On a 32-bit system an inum fits a double, we can cast the inum
6210 to a double and compare.
6211
6212 But on a 64-bit system an inum is bigger than a double and
6213 casting it to a double (call that dxx) will round. dxx is at
6214 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6215 an integer and fits a long. So we cast yy to a long and
6216 compare with plain xx.
6217
6218 An alternative (for any size system actually) would be to check
6219 yy is an integer (with floor) and is in range of an inum
6220 (compare against appropriate powers of 2) then test
e25f3727
AW		 6221 xx==(scm_t_signed_bits)yy. It's just a matter of which
6222 casts/comparisons might be fastest or easiest for the cpu. */
e8c5b1f2
KR		 6223
6224 double yy = SCM_REAL_VALUE (y);
3a1b45fd
MV		 6225 return scm_from_bool ((double) xx == yy
6226 && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
e25f3727 6227 || xx == (scm_t_signed_bits) yy));
e8c5b1f2 6228 }
0aacf84e 6229 else if (SCM_COMPLEXP (y))
73e4de09 6230 return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
0aacf84e 6231 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 6232 else if (SCM_FRACTIONP (y))
6233 return SCM_BOOL_F;
0aacf84e 6234 else
fa075d40
AW		 6235 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6236 s_scm_i_num_eq_p);
f872b822 6237 }
0aacf84e
MD		 6238 else if (SCM_BIGP (x))
6239 {
e11e83f3 6240 if (SCM_I_INUMP (y))
0aacf84e
MD		 6241 return SCM_BOOL_F;
6242 else if (SCM_BIGP (y))
6243 {
6244 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
6245 scm_remember_upto_here_2 (x, y);
73e4de09 6246 return scm_from_bool (0 == cmp);
0aacf84e
MD		 6247 }
6248 else if (SCM_REALP (y))
6249 {
6250 int cmp;
2e65b52f 6251 if (isnan (SCM_REAL_VALUE (y)))
0aacf84e
MD		 6252 return SCM_BOOL_F;
6253 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
6254 scm_remember_upto_here_1 (x);
73e4de09 6255 return scm_from_bool (0 == cmp);
0aacf84e
MD		 6256 }
6257 else if (SCM_COMPLEXP (y))
6258 {
6259 int cmp;
6260 if (0.0 != SCM_COMPLEX_IMAG (y))
6261 return SCM_BOOL_F;
2e65b52f 6262 if (isnan (SCM_COMPLEX_REAL (y)))
0aacf84e
MD		 6263 return SCM_BOOL_F;
6264 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
6265 scm_remember_upto_here_1 (x);
73e4de09 6266 return scm_from_bool (0 == cmp);
0aacf84e 6267 }
f92e85f7
MV		 6268 else if (SCM_FRACTIONP (y))
6269 return SCM_BOOL_F;
0aacf84e 6270 else
fa075d40
AW		 6271 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6272 s_scm_i_num_eq_p);
f4c627b3 6273 }
0aacf84e
MD		 6274 else if (SCM_REALP (x))
6275 {
e8c5b1f2 6276 double xx = SCM_REAL_VALUE (x);
e11e83f3 6277 if (SCM_I_INUMP (y))
e8c5b1f2
KR		 6278 {
6279 /* see comments with inum/real above */
e25f3727 6280 scm_t_signed_bits yy = SCM_I_INUM (y);
3a1b45fd
MV		 6281 return scm_from_bool (xx == (double) yy
6282 && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
e25f3727 6283 || (scm_t_signed_bits) xx == yy));
e8c5b1f2 6284 }
0aacf84e
MD		 6285 else if (SCM_BIGP (y))
6286 {
6287 int cmp;
2e65b52f 6288 if (isnan (SCM_REAL_VALUE (x)))
0aacf84e
MD		 6289 return SCM_BOOL_F;
6290 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
6291 scm_remember_upto_here_1 (y);
73e4de09 6292 return scm_from_bool (0 == cmp);
0aacf84e
MD		 6293 }
6294 else if (SCM_REALP (y))
73e4de09 6295 return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
0aacf84e 6296 else if (SCM_COMPLEXP (y))
73e4de09 6297 return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
0aacf84e 6298 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7 6299 else if (SCM_FRACTIONP (y))
d8b95e27
KR		 6300 {
6301 double xx = SCM_REAL_VALUE (x);
2e65b52f 6302 if (isnan (xx))
d8b95e27 6303 return SCM_BOOL_F;
2e65b52f 6304 if (isinf (xx))
73e4de09 6305 return scm_from_bool (xx < 0.0);
d8b95e27
KR		 6306 x = scm_inexact_to_exact (x); /* with x as frac or int */
6307 goto again;
6308 }
0aacf84e 6309 else
fa075d40
AW		 6310 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6311 s_scm_i_num_eq_p);
f872b822 6312 }
0aacf84e
MD		 6313 else if (SCM_COMPLEXP (x))
6314 {
e11e83f3
MV		 6315 if (SCM_I_INUMP (y))
6316 return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y))
0aacf84e
MD		 6317 && (SCM_COMPLEX_IMAG (x) == 0.0));
6318 else if (SCM_BIGP (y))
6319 {
6320 int cmp;
6321 if (0.0 != SCM_COMPLEX_IMAG (x))
6322 return SCM_BOOL_F;
2e65b52f 6323 if (isnan (SCM_COMPLEX_REAL (x)))
0aacf84e
MD		 6324 return SCM_BOOL_F;
6325 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
6326 scm_remember_upto_here_1 (y);
73e4de09 6327 return scm_from_bool (0 == cmp);
0aacf84e
MD		 6328 }
6329 else if (SCM_REALP (y))
73e4de09 6330 return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
0aacf84e
MD		 6331 && (SCM_COMPLEX_IMAG (x) == 0.0));
6332 else if (SCM_COMPLEXP (y))
73e4de09 6333 return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
0aacf84e 6334 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
f92e85f7 6335 else if (SCM_FRACTIONP (y))
d8b95e27
KR		 6336 {
6337 double xx;
6338 if (SCM_COMPLEX_IMAG (x) != 0.0)
6339 return SCM_BOOL_F;
6340 xx = SCM_COMPLEX_REAL (x);
2e65b52f 6341 if (isnan (xx))
d8b95e27 6342 return SCM_BOOL_F;
2e65b52f 6343 if (isinf (xx))
73e4de09 6344 return scm_from_bool (xx < 0.0);
d8b95e27
KR		 6345 x = scm_inexact_to_exact (x); /* with x as frac or int */
6346 goto again;
6347 }
f92e85f7 6348 else
fa075d40
AW		 6349 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6350 s_scm_i_num_eq_p);
f92e85f7
MV		 6351 }
6352 else if (SCM_FRACTIONP (x))
6353 {
e11e83f3 6354 if (SCM_I_INUMP (y))
f92e85f7
MV		 6355 return SCM_BOOL_F;
6356 else if (SCM_BIGP (y))
6357 return SCM_BOOL_F;
6358 else if (SCM_REALP (y))
d8b95e27
KR		 6359 {
6360 double yy = SCM_REAL_VALUE (y);
2e65b52f 6361 if (isnan (yy))
d8b95e27 6362 return SCM_BOOL_F;
2e65b52f 6363 if (isinf (yy))
73e4de09 6364 return scm_from_bool (0.0 < yy);
d8b95e27
KR		 6365 y = scm_inexact_to_exact (y); /* with y as frac or int */
6366 goto again;
6367 }
f92e85f7 6368 else if (SCM_COMPLEXP (y))
d8b95e27
KR		 6369 {
6370 double yy;
6371 if (SCM_COMPLEX_IMAG (y) != 0.0)
6372 return SCM_BOOL_F;
6373 yy = SCM_COMPLEX_REAL (y);
2e65b52f 6374 if (isnan (yy))
d8b95e27 6375 return SCM_BOOL_F;
2e65b52f 6376 if (isinf (yy))
73e4de09 6377 return scm_from_bool (0.0 < yy);
d8b95e27
KR		 6378 y = scm_inexact_to_exact (y); /* with y as frac or int */
6379 goto again;
6380 }
f92e85f7
MV		 6381 else if (SCM_FRACTIONP (y))
6382 return scm_i_fraction_equalp (x, y);
0aacf84e 6383 else
fa075d40
AW		 6384 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6385 s_scm_i_num_eq_p);
f4c627b3 6386 }
0aacf84e 6387 else
fa075d40
AW		 6388 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
6389 s_scm_i_num_eq_p);
0f2d19dd
JB		 6390}
6391
6392
a5f0b599
KR		 6393/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6394 done are good for inums, but for bignums an answer can almost always be
6395 had by just examining a few high bits of the operands, as done by GMP in
6396 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6397 of the float exponent to take into account. */
6398
8c93b597 6399SCM_INTERNAL SCM scm_i_num_less_p (SCM, SCM, SCM);
8a1f4f98
AW		 6400SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
6401 (SCM x, SCM y, SCM rest),
6402 "Return @code{#t} if the list of parameters is monotonically\n"
6403 "increasing.")
6404#define FUNC_NAME s_scm_i_num_less_p
6405{
6406 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6407 return SCM_BOOL_T;
6408 while (!scm_is_null (rest))
6409 {
6410 if (scm_is_false (scm_less_p (x, y)))
6411 return SCM_BOOL_F;
6412 x = y;
6413 y = scm_car (rest);
6414 rest = scm_cdr (rest);
6415 }
6416 return scm_less_p (x, y);
6417}
6418#undef FUNC_NAME
0f2d19dd 6419SCM
6e8d25a6 6420scm_less_p (SCM x, SCM y)
0f2d19dd 6421{
a5f0b599 6422 again:
e11e83f3 6423 if (SCM_I_INUMP (x))
0aacf84e 6424 {
e25f3727 6425 scm_t_inum xx = SCM_I_INUM (x);
e11e83f3 6426 if (SCM_I_INUMP (y))
0aacf84e 6427 {
e25f3727 6428 scm_t_inum yy = SCM_I_INUM (y);
73e4de09 6429 return scm_from_bool (xx < yy);
0aacf84e
MD		 6430 }
6431 else if (SCM_BIGP (y))
6432 {
6433 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
6434 scm_remember_upto_here_1 (y);
73e4de09 6435 return scm_from_bool (sgn > 0);
0aacf84e
MD		 6436 }
6437 else if (SCM_REALP (y))
73e4de09 6438 return scm_from_bool ((double) xx < SCM_REAL_VALUE (y));
f92e85f7 6439 else if (SCM_FRACTIONP (y))
a5f0b599
KR		 6440 {
6441 /* "x < a/b" becomes "x*b < a" */
6442 int_frac:
6443 x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
6444 y = SCM_FRACTION_NUMERATOR (y);
6445 goto again;
6446 }
0aacf84e 6447 else
fa075d40
AW		 6448 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6449 s_scm_i_num_less_p);
f872b822 6450 }
0aacf84e
MD		 6451 else if (SCM_BIGP (x))
6452 {
e11e83f3 6453 if (SCM_I_INUMP (y))
0aacf84e
MD		 6454 {
6455 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
6456 scm_remember_upto_here_1 (x);
73e4de09 6457 return scm_from_bool (sgn < 0);
0aacf84e
MD		 6458 }
6459 else if (SCM_BIGP (y))
6460 {
6461 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
6462 scm_remember_upto_here_2 (x, y);
73e4de09 6463 return scm_from_bool (cmp < 0);
0aacf84e
MD		 6464 }
6465 else if (SCM_REALP (y))
6466 {
6467 int cmp;
2e65b52f 6468 if (isnan (SCM_REAL_VALUE (y)))
0aacf84e
MD		 6469 return SCM_BOOL_F;
6470 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
6471 scm_remember_upto_here_1 (x);
73e4de09 6472 return scm_from_bool (cmp < 0);
0aacf84e 6473 }
f92e85f7 6474 else if (SCM_FRACTIONP (y))
a5f0b599 6475 goto int_frac;
0aacf84e 6476 else
fa075d40
AW		 6477 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6478 s_scm_i_num_less_p);
f4c627b3 6479 }
0aacf84e
MD		 6480 else if (SCM_REALP (x))
6481 {
e11e83f3
MV		 6482 if (SCM_I_INUMP (y))
6483 return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y));
0aacf84e
MD		 6484 else if (SCM_BIGP (y))
6485 {
6486 int cmp;
2e65b52f 6487 if (isnan (SCM_REAL_VALUE (x)))
0aacf84e
MD		 6488 return SCM_BOOL_F;
6489 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
6490 scm_remember_upto_here_1 (y);
73e4de09 6491 return scm_from_bool (cmp > 0);
0aacf84e
MD		 6492 }
6493 else if (SCM_REALP (y))
73e4de09 6494 return scm_from_bool (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
f92e85f7 6495 else if (SCM_FRACTIONP (y))
a5f0b599
KR		 6496 {
6497 double xx = SCM_REAL_VALUE (x);
2e65b52f 6498 if (isnan (xx))
a5f0b599 6499 return SCM_BOOL_F;
2e65b52f 6500 if (isinf (xx))
73e4de09 6501 return scm_from_bool (xx < 0.0);
a5f0b599
KR		 6502 x = scm_inexact_to_exact (x); /* with x as frac or int */
6503 goto again;
6504 }
f92e85f7 6505 else
fa075d40
AW		 6506 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6507 s_scm_i_num_less_p);
f92e85f7
MV		 6508 }
6509 else if (SCM_FRACTIONP (x))
6510 {
e11e83f3 6511 if (SCM_I_INUMP (y) || SCM_BIGP (y))
a5f0b599
KR		 6512 {
6513 /* "a/b < y" becomes "a < y*b" */
6514 y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
6515 x = SCM_FRACTION_NUMERATOR (x);
6516 goto again;
6517 }
f92e85f7 6518 else if (SCM_REALP (y))
a5f0b599
KR		 6519 {
6520 double yy = SCM_REAL_VALUE (y);
2e65b52f 6521 if (isnan (yy))
a5f0b599 6522 return SCM_BOOL_F;
2e65b52f 6523 if (isinf (yy))
73e4de09 6524 return scm_from_bool (0.0 < yy);
a5f0b599
KR		 6525 y = scm_inexact_to_exact (y); /* with y as frac or int */
6526 goto again;
6527 }
f92e85f7 6528 else if (SCM_FRACTIONP (y))
a5f0b599
KR		 6529 {
6530 /* "a/b < c/d" becomes "a*d < c*b" */
6531 SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
6532 SCM_FRACTION_DENOMINATOR (y));
6533 SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
6534 SCM_FRACTION_DENOMINATOR (x));
6535 x = new_x;
6536 y = new_y;
6537 goto again;
6538 }
0aacf84e 6539 else
fa075d40
AW		 6540 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6541 s_scm_i_num_less_p);
f872b822 6542 }
0aacf84e 6543 else
fa075d40
AW		 6544 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
6545 s_scm_i_num_less_p);
0f2d19dd
JB		 6546}
6547
6548
8a1f4f98
AW		 6549SCM scm_i_num_gr_p (SCM, SCM, SCM);
6550SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
6551 (SCM x, SCM y, SCM rest),
6552 "Return @code{#t} if the list of parameters is monotonically\n"
6553 "decreasing.")
6554#define FUNC_NAME s_scm_i_num_gr_p
6555{
6556 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6557 return SCM_BOOL_T;
6558 while (!scm_is_null (rest))
6559 {
6560 if (scm_is_false (scm_gr_p (x, y)))
6561 return SCM_BOOL_F;
6562 x = y;
6563 y = scm_car (rest);
6564 rest = scm_cdr (rest);
6565 }
6566 return scm_gr_p (x, y);
6567}
6568#undef FUNC_NAME
6569#define FUNC_NAME s_scm_i_num_gr_p
c76b1eaf
MD		 6570SCM
6571scm_gr_p (SCM x, SCM y)
0f2d19dd 6572{
c76b1eaf 6573 if (!SCM_NUMBERP (x))
fa075d40 6574 return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
c76b1eaf 6575 else if (!SCM_NUMBERP (y))
fa075d40 6576 return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
c76b1eaf
MD		 6577 else
6578 return scm_less_p (y, x);
0f2d19dd 6579}
1bbd0b84 6580#undef FUNC_NAME
0f2d19dd
JB		 6581
6582
8a1f4f98
AW		 6583SCM scm_i_num_leq_p (SCM, SCM, SCM);
6584SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
6585 (SCM x, SCM y, SCM rest),
6586 "Return @code{#t} if the list of parameters is monotonically\n"
6587 "non-decreasing.")
6588#define FUNC_NAME s_scm_i_num_leq_p
6589{
6590 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6591 return SCM_BOOL_T;
6592 while (!scm_is_null (rest))
6593 {
6594 if (scm_is_false (scm_leq_p (x, y)))
6595 return SCM_BOOL_F;
6596 x = y;
6597 y = scm_car (rest);
6598 rest = scm_cdr (rest);
6599 }
6600 return scm_leq_p (x, y);
6601}
6602#undef FUNC_NAME
6603#define FUNC_NAME s_scm_i_num_leq_p
c76b1eaf
MD		 6604SCM
6605scm_leq_p (SCM x, SCM y)
0f2d19dd 6606{
c76b1eaf 6607 if (!SCM_NUMBERP (x))
fa075d40 6608 return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
c76b1eaf 6609 else if (!SCM_NUMBERP (y))
fa075d40 6610 return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
73e4de09 6611 else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
fc194577 6612 return SCM_BOOL_F;
c76b1eaf 6613 else
73e4de09 6614 return scm_not (scm_less_p (y, x));
0f2d19dd 6615}
1bbd0b84 6616#undef FUNC_NAME
0f2d19dd
JB		 6617
6618
8a1f4f98
AW		 6619SCM scm_i_num_geq_p (SCM, SCM, SCM);
6620SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
6621 (SCM x, SCM y, SCM rest),
6622 "Return @code{#t} if the list of parameters is monotonically\n"
6623 "non-increasing.")
6624#define FUNC_NAME s_scm_i_num_geq_p
6625{
6626 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6627 return SCM_BOOL_T;
6628 while (!scm_is_null (rest))
6629 {
6630 if (scm_is_false (scm_geq_p (x, y)))
6631 return SCM_BOOL_F;
6632 x = y;
6633 y = scm_car (rest);
6634 rest = scm_cdr (rest);
6635 }
6636 return scm_geq_p (x, y);
6637}
6638#undef FUNC_NAME
6639#define FUNC_NAME s_scm_i_num_geq_p
c76b1eaf
MD		 6640SCM
6641scm_geq_p (SCM x, SCM y)
0f2d19dd 6642{
c76b1eaf 6643 if (!SCM_NUMBERP (x))
fa075d40 6644 return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
c76b1eaf 6645 else if (!SCM_NUMBERP (y))
fa075d40 6646 return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
73e4de09 6647 else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
fc194577 6648 return SCM_BOOL_F;
c76b1eaf 6649 else
73e4de09 6650 return scm_not (scm_less_p (x, y));
0f2d19dd 6651}
1bbd0b84 6652#undef FUNC_NAME
0f2d19dd
JB		 6653
6654
2519490c
MW		 6655SCM_PRIMITIVE_GENERIC (scm_zero_p, "zero?", 1, 0, 0,
6656 (SCM z),
6657 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6658 "zero.")
6659#define FUNC_NAME s_scm_zero_p
0f2d19dd 6660{
e11e83f3 6661 if (SCM_I_INUMP (z))
bc36d050 6662 return scm_from_bool (scm_is_eq (z, SCM_INUM0));
0aacf84e 6663 else if (SCM_BIGP (z))
c2ff8ab0 6664 return SCM_BOOL_F;
0aacf84e 6665 else if (SCM_REALP (z))
73e4de09 6666 return scm_from_bool (SCM_REAL_VALUE (z) == 0.0);
0aacf84e 6667 else if (SCM_COMPLEXP (z))
73e4de09 6668 return scm_from_bool (SCM_COMPLEX_REAL (z) == 0.0
c2ff8ab0 6669 && SCM_COMPLEX_IMAG (z) == 0.0);
f92e85f7
MV		 6670 else if (SCM_FRACTIONP (z))
6671 return SCM_BOOL_F;
0aacf84e 6672 else
fa075d40 6673 return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
0f2d19dd 6674}
2519490c 6675#undef FUNC_NAME
0f2d19dd
JB		 6676
6677
2519490c
MW		 6678SCM_PRIMITIVE_GENERIC (scm_positive_p, "positive?", 1, 0, 0,
6679 (SCM x),
6680 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6681 "zero.")
6682#define FUNC_NAME s_scm_positive_p
0f2d19dd 6683{
e11e83f3
MV		 6684 if (SCM_I_INUMP (x))
6685 return scm_from_bool (SCM_I_INUM (x) > 0);
0aacf84e
MD		 6686 else if (SCM_BIGP (x))
6687 {
6688 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
6689 scm_remember_upto_here_1 (x);
73e4de09 6690 return scm_from_bool (sgn > 0);
0aacf84e
MD		 6691 }
6692 else if (SCM_REALP (x))
73e4de09 6693 return scm_from_bool(SCM_REAL_VALUE (x) > 0.0);
f92e85f7
MV		 6694 else if (SCM_FRACTIONP (x))
6695 return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 6696 else
fa075d40 6697 return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
0f2d19dd 6698}
2519490c 6699#undef FUNC_NAME
0f2d19dd
JB		 6700
6701
2519490c
MW		 6702SCM_PRIMITIVE_GENERIC (scm_negative_p, "negative?", 1, 0, 0,
6703 (SCM x),
6704 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6705 "zero.")
6706#define FUNC_NAME s_scm_negative_p
0f2d19dd 6707{
e11e83f3
MV		 6708 if (SCM_I_INUMP (x))
6709 return scm_from_bool (SCM_I_INUM (x) < 0);
0aacf84e
MD		 6710 else if (SCM_BIGP (x))
6711 {
6712 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
6713 scm_remember_upto_here_1 (x);
73e4de09 6714 return scm_from_bool (sgn < 0);
0aacf84e
MD		 6715 }
6716 else if (SCM_REALP (x))
73e4de09 6717 return scm_from_bool(SCM_REAL_VALUE (x) < 0.0);
f92e85f7
MV		 6718 else if (SCM_FRACTIONP (x))
6719 return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 6720 else
fa075d40 6721 return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
0f2d19dd 6722}
2519490c 6723#undef FUNC_NAME
0f2d19dd
JB		 6724
6725
2a06f791
KR		 6726/* scm_min and scm_max return an inexact when either argument is inexact, as
6727 required by r5rs. On that basis, for exact/inexact combinations the
6728 exact is converted to inexact to compare and possibly return. This is
6729 unlike scm_less_p above which takes some trouble to preserve all bits in
6730 its test, such trouble is not required for min and max. */
6731
78d3deb1
AW		 6732SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
6733 (SCM x, SCM y, SCM rest),
6734 "Return the maximum of all parameter values.")
6735#define FUNC_NAME s_scm_i_max
6736{
6737 while (!scm_is_null (rest))
6738 { x = scm_max (x, y);
6739 y = scm_car (rest);
6740 rest = scm_cdr (rest);
6741 }
6742 return scm_max (x, y);
6743}
6744#undef FUNC_NAME
6745
6746#define s_max s_scm_i_max
6747#define g_max g_scm_i_max
6748
0f2d19dd 6749SCM
6e8d25a6 6750scm_max (SCM x, SCM y)
0f2d19dd 6751{
0aacf84e
MD		 6752 if (SCM_UNBNDP (y))
6753 {
6754 if (SCM_UNBNDP (x))
fa075d40 6755 return scm_wta_dispatch_0 (g_max, s_max);
e11e83f3 6756 else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
0aacf84e
MD		 6757 return x;
6758 else
fa075d40 6759 return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
f872b822 6760 }
f4c627b3 6761
e11e83f3 6762 if (SCM_I_INUMP (x))
0aacf84e 6763 {
e25f3727 6764 scm_t_inum xx = SCM_I_INUM (x);
e11e83f3 6765 if (SCM_I_INUMP (y))
0aacf84e 6766 {
e25f3727 6767 scm_t_inum yy = SCM_I_INUM (y);
0aacf84e
MD		 6768 return (xx < yy) ? y : x;
6769 }
6770 else if (SCM_BIGP (y))
6771 {
6772 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
6773 scm_remember_upto_here_1 (y);
6774 return (sgn < 0) ? x : y;
6775 }
6776 else if (SCM_REALP (y))
6777 {
2e274311
MW		 6778 double xxd = xx;
6779 double yyd = SCM_REAL_VALUE (y);
6780
6781 if (xxd > yyd)
6782 return scm_from_double (xxd);
6783 /* If y is a NaN, then "==" is false and we return the NaN */
6784 else if (SCM_LIKELY (!(xxd == yyd)))
6785 return y;
6786 /* Handle signed zeroes properly */
6787 else if (xx == 0)
6788 return flo0;
6789 else
6790 return y;
0aacf84e 6791 }
f92e85f7
MV		 6792 else if (SCM_FRACTIONP (y))
6793 {
e4bc5d6c 6794 use_less:
73e4de09 6795 return (scm_is_false (scm_less_p (x, y)) ? x : y);
f92e85f7 6796 }
0aacf84e 6797 else
fa075d40 6798 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 6799 }
0aacf84e
MD		 6800 else if (SCM_BIGP (x))
6801 {
e11e83f3 6802 if (SCM_I_INUMP (y))
0aacf84e
MD		 6803 {
6804 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
6805 scm_remember_upto_here_1 (x);
6806 return (sgn < 0) ? y : x;
6807 }
6808 else if (SCM_BIGP (y))
6809 {
6810 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
6811 scm_remember_upto_here_2 (x, y);
6812 return (cmp > 0) ? x : y;
6813 }
6814 else if (SCM_REALP (y))
6815 {
2a06f791
KR		 6816 /* if y==NaN then xx>yy is false, so we return the NaN y */
6817 double xx, yy;
6818 big_real:
6819 xx = scm_i_big2dbl (x);
6820 yy = SCM_REAL_VALUE (y);
55f26379 6821 return (xx > yy ? scm_from_double (xx) : y);
0aacf84e 6822 }
f92e85f7
MV		 6823 else if (SCM_FRACTIONP (y))
6824 {
e4bc5d6c 6825 goto use_less;
f92e85f7 6826 }
0aacf84e 6827 else
fa075d40 6828 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
f4c627b3 6829 }
0aacf84e
MD		 6830 else if (SCM_REALP (x))
6831 {
e11e83f3 6832 if (SCM_I_INUMP (y))
0aacf84e 6833 {
2e274311
MW		 6834 scm_t_inum yy = SCM_I_INUM (y);
6835 double xxd = SCM_REAL_VALUE (x);
6836 double yyd = yy;
6837
6838 if (yyd > xxd)
6839 return scm_from_double (yyd);
6840 /* If x is a NaN, then "==" is false and we return the NaN */
6841 else if (SCM_LIKELY (!(xxd == yyd)))
6842 return x;
6843 /* Handle signed zeroes properly */
6844 else if (yy == 0)
6845 return flo0;
6846 else
6847 return x;
0aacf84e
MD		 6848 }
6849 else if (SCM_BIGP (y))
6850 {
b6f8f763 6851 SCM_SWAP (x, y);
2a06f791 6852 goto big_real;
0aacf84e
MD		 6853 }
6854 else if (SCM_REALP (y))
6855 {
0aacf84e 6856 double xx = SCM_REAL_VALUE (x);
2e274311
MW		 6857 double yy = SCM_REAL_VALUE (y);
6858
6859 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6860 if (xx > yy)
6861 return x;
6862 else if (SCM_LIKELY (xx < yy))
6863 return y;
6864 /* If neither (xx > yy) nor (xx < yy), then
6865 either they're equal or one is a NaN */
6866 else if (SCM_UNLIKELY (isnan (xx)))
041fccf6 6867 return DOUBLE_IS_POSITIVE_INFINITY (yy) ? y : x;
2e274311 6868 else if (SCM_UNLIKELY (isnan (yy)))
041fccf6 6869 return DOUBLE_IS_POSITIVE_INFINITY (xx) ? x : y;
2e274311
MW		 6870 /* xx == yy, but handle signed zeroes properly */
6871 else if (double_is_non_negative_zero (yy))
6872 return y;
6873 else
6874 return x;
0aacf84e 6875 }
f92e85f7
MV		 6876 else if (SCM_FRACTIONP (y))
6877 {
6878 double yy = scm_i_fraction2double (y);
6879 double xx = SCM_REAL_VALUE (x);
55f26379 6880 return (xx < yy) ? scm_from_double (yy) : x;
f92e85f7
MV		 6881 }
6882 else
fa075d40 6883 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
f92e85f7
MV		 6884 }
6885 else if (SCM_FRACTIONP (x))
6886 {
e11e83f3 6887 if (SCM_I_INUMP (y))
f92e85f7 6888 {
e4bc5d6c 6889 goto use_less;
f92e85f7
MV		 6890 }
6891 else if (SCM_BIGP (y))
6892 {
e4bc5d6c 6893 goto use_less;
f92e85f7
MV		 6894 }
6895 else if (SCM_REALP (y))
6896 {
6897 double xx = scm_i_fraction2double (x);
2e274311
MW		 6898 /* if y==NaN then ">" is false, so we return the NaN y */
6899 return (xx > SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
f92e85f7
MV		 6900 }
6901 else if (SCM_FRACTIONP (y))
6902 {
e4bc5d6c 6903 goto use_less;
f92e85f7 6904 }
0aacf84e 6905 else
fa075d40 6906 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 6907 }
0aacf84e 6908 else
fa075d40 6909 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
0f2d19dd
JB		 6910}
6911
6912
78d3deb1
AW		 6913SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
6914 (SCM x, SCM y, SCM rest),
6915 "Return the minimum of all parameter values.")
6916#define FUNC_NAME s_scm_i_min
6917{
6918 while (!scm_is_null (rest))
6919 { x = scm_min (x, y);
6920 y = scm_car (rest);
6921 rest = scm_cdr (rest);
6922 }
6923 return scm_min (x, y);
6924}
6925#undef FUNC_NAME
6926
6927#define s_min s_scm_i_min
6928#define g_min g_scm_i_min
6929
0f2d19dd 6930SCM
6e8d25a6 6931scm_min (SCM x, SCM y)
0f2d19dd 6932{
0aacf84e
MD		 6933 if (SCM_UNBNDP (y))
6934 {
6935 if (SCM_UNBNDP (x))
fa075d40 6936 return scm_wta_dispatch_0 (g_min, s_min);
e11e83f3 6937 else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
0aacf84e
MD		 6938 return x;
6939 else
fa075d40 6940 return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
f872b822 6941 }
f4c627b3 6942
e11e83f3 6943 if (SCM_I_INUMP (x))
0aacf84e 6944 {
e25f3727 6945 scm_t_inum xx = SCM_I_INUM (x);
e11e83f3 6946 if (SCM_I_INUMP (y))
0aacf84e 6947 {
e25f3727 6948 scm_t_inum yy = SCM_I_INUM (y);
0aacf84e
MD		 6949 return (xx < yy) ? x : y;
6950 }
6951 else if (SCM_BIGP (y))
6952 {
6953 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
6954 scm_remember_upto_here_1 (y);
6955 return (sgn < 0) ? y : x;
6956 }
6957 else if (SCM_REALP (y))
6958 {
6959 double z = xx;
6960 /* if y==NaN then "<" is false and we return NaN */
55f26379 6961 return (z < SCM_REAL_VALUE (y)) ? scm_from_double (z) : y;
0aacf84e 6962 }
f92e85f7
MV		 6963 else if (SCM_FRACTIONP (y))
6964 {
e4bc5d6c 6965 use_less:
73e4de09 6966 return (scm_is_false (scm_less_p (x, y)) ? y : x);
f92e85f7 6967 }
0aacf84e 6968 else
fa075d40 6969 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 6970 }
0aacf84e
MD		 6971 else if (SCM_BIGP (x))
6972 {
e11e83f3 6973 if (SCM_I_INUMP (y))
0aacf84e
MD		 6974 {
6975 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
6976 scm_remember_upto_here_1 (x);
6977 return (sgn < 0) ? x : y;
6978 }
6979 else if (SCM_BIGP (y))
6980 {
6981 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
6982 scm_remember_upto_here_2 (x, y);
6983 return (cmp > 0) ? y : x;
6984 }
6985 else if (SCM_REALP (y))
6986 {
2a06f791
KR		 6987 /* if y==NaN then xx<yy is false, so we return the NaN y */
6988 double xx, yy;
6989 big_real:
6990 xx = scm_i_big2dbl (x);
6991 yy = SCM_REAL_VALUE (y);
55f26379 6992 return (xx < yy ? scm_from_double (xx) : y);
0aacf84e 6993 }
f92e85f7
MV		 6994 else if (SCM_FRACTIONP (y))
6995 {
e4bc5d6c 6996 goto use_less;
f92e85f7 6997 }
0aacf84e 6998 else
fa075d40 6999 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
f4c627b3 7000 }
0aacf84e
MD		 7001 else if (SCM_REALP (x))
7002 {
e11e83f3 7003 if (SCM_I_INUMP (y))
0aacf84e 7004 {
e11e83f3 7005 double z = SCM_I_INUM (y);
0aacf84e 7006 /* if x==NaN then "<" is false and we return NaN */
55f26379 7007 return (z < SCM_REAL_VALUE (x)) ? scm_from_double (z) : x;
0aacf84e
MD		 7008 }
7009 else if (SCM_BIGP (y))
7010 {
b6f8f763 7011 SCM_SWAP (x, y);
2a06f791 7012 goto big_real;
0aacf84e
MD		 7013 }
7014 else if (SCM_REALP (y))
7015 {
0aacf84e 7016 double xx = SCM_REAL_VALUE (x);
2e274311
MW		 7017 double yy = SCM_REAL_VALUE (y);
7018
7019 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7020 if (xx < yy)
7021 return x;
7022 else if (SCM_LIKELY (xx > yy))
7023 return y;
7024 /* If neither (xx < yy) nor (xx > yy), then
7025 either they're equal or one is a NaN */
7026 else if (SCM_UNLIKELY (isnan (xx)))
041fccf6 7027 return DOUBLE_IS_NEGATIVE_INFINITY (yy) ? y : x;
2e274311 7028 else if (SCM_UNLIKELY (isnan (yy)))
041fccf6 7029 return DOUBLE_IS_NEGATIVE_INFINITY (xx) ? x : y;
2e274311
MW		 7030 /* xx == yy, but handle signed zeroes properly */
7031 else if (double_is_non_negative_zero (xx))
7032 return y;
7033 else
7034 return x;
0aacf84e 7035 }
f92e85f7
MV		 7036 else if (SCM_FRACTIONP (y))
7037 {
7038 double yy = scm_i_fraction2double (y);
7039 double xx = SCM_REAL_VALUE (x);
55f26379 7040 return (yy < xx) ? scm_from_double (yy) : x;
f92e85f7 7041 }
0aacf84e 7042 else
fa075d40 7043 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 7044 }
f92e85f7
MV		 7045 else if (SCM_FRACTIONP (x))
7046 {
e11e83f3 7047 if (SCM_I_INUMP (y))
f92e85f7 7048 {
e4bc5d6c 7049 goto use_less;
f92e85f7
MV		 7050 }
7051 else if (SCM_BIGP (y))
7052 {
e4bc5d6c 7053 goto use_less;
f92e85f7
MV		 7054 }
7055 else if (SCM_REALP (y))
7056 {
7057 double xx = scm_i_fraction2double (x);
2e274311
MW		 7058 /* if y==NaN then "<" is false, so we return the NaN y */
7059 return (xx < SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
f92e85f7
MV		 7060 }
7061 else if (SCM_FRACTIONP (y))
7062 {
e4bc5d6c 7063 goto use_less;
f92e85f7
MV		 7064 }
7065 else
fa075d40 7066 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
f92e85f7 7067 }
0aacf84e 7068 else
fa075d40 7069 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
0f2d19dd
JB		 7070}
7071
7072
8ccd24f7
AW		 7073SCM_PRIMITIVE_GENERIC (scm_i_sum, "+", 0, 2, 1,
7074 (SCM x, SCM y, SCM rest),
7075 "Return the sum of all parameter values. Return 0 if called without\n"
7076 "any parameters." )
7077#define FUNC_NAME s_scm_i_sum
7078{
7079 while (!scm_is_null (rest))
7080 { x = scm_sum (x, y);
7081 y = scm_car (rest);
7082 rest = scm_cdr (rest);
7083 }
7084 return scm_sum (x, y);
7085}
7086#undef FUNC_NAME
7087
7088#define s_sum s_scm_i_sum
7089#define g_sum g_scm_i_sum
7090
0f2d19dd 7091SCM
6e8d25a6 7092scm_sum (SCM x, SCM y)
0f2d19dd 7093{
9cc37597 7094 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
ca46fb90
RB		 7095 {
7096 if (SCM_NUMBERP (x)) return x;
7097 if (SCM_UNBNDP (x)) return SCM_INUM0;
fa075d40 7098 return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
f872b822 7099 }
c209c88e 7100
9cc37597 7101 if (SCM_LIKELY (SCM_I_INUMP (x)))
ca46fb90 7102 {
9cc37597 7103 if (SCM_LIKELY (SCM_I_INUMP (y)))
ca46fb90 7104 {
e25f3727
AW		 7105 scm_t_inum xx = SCM_I_INUM (x);
7106 scm_t_inum yy = SCM_I_INUM (y);
7107 scm_t_inum z = xx + yy;
7108 return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_inum2big (z);
ca46fb90
RB		 7109 }
7110 else if (SCM_BIGP (y))
7111 {
7112 SCM_SWAP (x, y);
7113 goto add_big_inum;
7114 }
7115 else if (SCM_REALP (y))
7116 {
e25f3727 7117 scm_t_inum xx = SCM_I_INUM (x);
55f26379 7118 return scm_from_double (xx + SCM_REAL_VALUE (y));
ca46fb90
RB		 7119 }
7120 else if (SCM_COMPLEXP (y))
7121 {
e25f3727 7122 scm_t_inum xx = SCM_I_INUM (x);
8507ec80 7123 return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y),
ca46fb90
RB		 7124 SCM_COMPLEX_IMAG (y));
7125 }
f92e85f7 7126 else if (SCM_FRACTIONP (y))
cba42c93 7127 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
f92e85f7
MV		 7128 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
7129 SCM_FRACTION_DENOMINATOR (y));
ca46fb90 7130 else
fa075d40 7131 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
0aacf84e
MD		 7132 } else if (SCM_BIGP (x))
7133 {
e11e83f3 7134 if (SCM_I_INUMP (y))
0aacf84e 7135 {
e25f3727 7136 scm_t_inum inum;
0aacf84e
MD		 7137 int bigsgn;
7138 add_big_inum:
e11e83f3 7139 inum = SCM_I_INUM (y);
0aacf84e
MD		 7140 if (inum == 0)
7141 return x;
7142 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7143 if (inum < 0)
7144 {
7145 SCM result = scm_i_mkbig ();
7146 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
7147 scm_remember_upto_here_1 (x);
7148 /* we know the result will have to be a bignum */
7149 if (bigsgn == -1)
7150 return result;
7151 return scm_i_normbig (result);
7152 }
7153 else
7154 {
7155 SCM result = scm_i_mkbig ();
7156 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
7157 scm_remember_upto_here_1 (x);
7158 /* we know the result will have to be a bignum */
7159 if (bigsgn == 1)
7160 return result;
7161 return scm_i_normbig (result);
7162 }
7163 }
7164 else if (SCM_BIGP (y))
7165 {
7166 SCM result = scm_i_mkbig ();
7167 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
7168 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
7169 mpz_add (SCM_I_BIG_MPZ (result),
7170 SCM_I_BIG_MPZ (x),
7171 SCM_I_BIG_MPZ (y));
7172 scm_remember_upto_here_2 (x, y);
7173 /* we know the result will have to be a bignum */
7174 if (sgn_x == sgn_y)
7175 return result;
7176 return scm_i_normbig (result);
7177 }
7178 else if (SCM_REALP (y))
7179 {
7180 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
7181 scm_remember_upto_here_1 (x);
55f26379 7182 return scm_from_double (result);
0aacf84e
MD		 7183 }
7184 else if (SCM_COMPLEXP (y))
7185 {
7186 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
7187 + SCM_COMPLEX_REAL (y));
7188 scm_remember_upto_here_1 (x);
8507ec80 7189 return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
0aacf84e 7190 }
f92e85f7 7191 else if (SCM_FRACTIONP (y))
cba42c93 7192 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
f92e85f7
MV		 7193 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
7194 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 7195 else
fa075d40 7196 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
0f2d19dd 7197 }
0aacf84e
MD		 7198 else if (SCM_REALP (x))
7199 {
e11e83f3 7200 if (SCM_I_INUMP (y))
55f26379 7201 return scm_from_double (SCM_REAL_VALUE (x) + SCM_I_INUM (y));
0aacf84e
MD		 7202 else if (SCM_BIGP (y))
7203 {
7204 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
7205 scm_remember_upto_here_1 (y);
55f26379 7206 return scm_from_double (result);
0aacf84e
MD		 7207 }
7208 else if (SCM_REALP (y))
55f26379 7209 return scm_from_double (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
0aacf84e 7210 else if (SCM_COMPLEXP (y))
8507ec80 7211 return scm_c_make_rectangular (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
0aacf84e 7212 SCM_COMPLEX_IMAG (y));
f92e85f7 7213 else if (SCM_FRACTIONP (y))
55f26379 7214 return scm_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
0aacf84e 7215 else
fa075d40 7216 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 7217 }
0aacf84e
MD		 7218 else if (SCM_COMPLEXP (x))
7219 {
e11e83f3 7220 if (SCM_I_INUMP (y))
8507ec80 7221 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_I_INUM (y),
0aacf84e
MD		 7222 SCM_COMPLEX_IMAG (x));
7223 else if (SCM_BIGP (y))
7224 {
7225 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
7226 + SCM_COMPLEX_REAL (x));
7227 scm_remember_upto_here_1 (y);
8507ec80 7228 return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (x));
0aacf84e
MD		 7229 }
7230 else if (SCM_REALP (y))
8507ec80 7231 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
0aacf84e
MD		 7232 SCM_COMPLEX_IMAG (x));
7233 else if (SCM_COMPLEXP (y))
8507ec80 7234 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
0aacf84e 7235 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
f92e85f7 7236 else if (SCM_FRACTIONP (y))
8507ec80 7237 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
f92e85f7
MV		 7238 SCM_COMPLEX_IMAG (x));
7239 else
fa075d40 7240 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
f92e85f7
MV		 7241 }
7242 else if (SCM_FRACTIONP (x))
7243 {
e11e83f3 7244 if (SCM_I_INUMP (y))
cba42c93 7245 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 7246 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
7247 SCM_FRACTION_DENOMINATOR (x));
7248 else if (SCM_BIGP (y))
cba42c93 7249 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 7250 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
7251 SCM_FRACTION_DENOMINATOR (x));
7252 else if (SCM_REALP (y))
55f26379 7253 return scm_from_double (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
f92e85f7 7254 else if (SCM_COMPLEXP (y))
8507ec80 7255 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
f92e85f7
MV		 7256 SCM_COMPLEX_IMAG (y));
7257 else if (SCM_FRACTIONP (y))
7258 /* a/b + c/d = (ad + bc) / bd */
cba42c93 7259 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
f92e85f7
MV		 7260 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
7261 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e 7262 else
fa075d40 7263 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
98cb6e75 7264 }
0aacf84e 7265 else
fa075d40 7266 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
0f2d19dd
JB		 7267}
7268
7269
40882e3d
KR		 7270SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0,
7271 (SCM x),
7272 "Return @math{@var{x}+1}.")
7273#define FUNC_NAME s_scm_oneplus
7274{
cff5fa33 7275 return scm_sum (x, SCM_INUM1);
40882e3d
KR		 7276}
7277#undef FUNC_NAME
7278
7279
78d3deb1
AW		 7280SCM_PRIMITIVE_GENERIC (scm_i_difference, "-", 0, 2, 1,
7281 (SCM x, SCM y, SCM rest),
7282 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7283 "the sum of all but the first argument are subtracted from the first\n"
7284 "argument.")
7285#define FUNC_NAME s_scm_i_difference
7286{
7287 while (!scm_is_null (rest))
7288 { x = scm_difference (x, y);
7289 y = scm_car (rest);
7290 rest = scm_cdr (rest);
7291 }
7292 return scm_difference (x, y);
7293}
7294#undef FUNC_NAME
7295
7296#define s_difference s_scm_i_difference
7297#define g_difference g_scm_i_difference
7298
0f2d19dd 7299SCM
6e8d25a6 7300scm_difference (SCM x, SCM y)
78d3deb1 7301#define FUNC_NAME s_difference
0f2d19dd 7302{
9cc37597 7303 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
ca46fb90
RB		 7304 {
7305 if (SCM_UNBNDP (x))
fa075d40 7306 return scm_wta_dispatch_0 (g_difference, s_difference);
ca46fb90 7307 else
e11e83f3 7308 if (SCM_I_INUMP (x))
ca46fb90 7309 {
e25f3727 7310 scm_t_inum xx = -SCM_I_INUM (x);
ca46fb90 7311 if (SCM_FIXABLE (xx))
d956fa6f 7312 return SCM_I_MAKINUM (xx);
ca46fb90 7313 else
e25f3727 7314 return scm_i_inum2big (xx);
ca46fb90
RB		 7315 }
7316 else if (SCM_BIGP (x))
a9ad4847
KR		 7317 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7318 bignum, but negating that gives a fixnum. */
ca46fb90
RB		 7319 return scm_i_normbig (scm_i_clonebig (x, 0));
7320 else if (SCM_REALP (x))
55f26379 7321 return scm_from_double (-SCM_REAL_VALUE (x));
ca46fb90 7322 else if (SCM_COMPLEXP (x))
8507ec80 7323 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
ca46fb90 7324 -SCM_COMPLEX_IMAG (x));
f92e85f7 7325 else if (SCM_FRACTIONP (x))
cba42c93 7326 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
f92e85f7 7327 SCM_FRACTION_DENOMINATOR (x));
ca46fb90 7328 else
fa075d40 7329 return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
f872b822 7330 }
ca46fb90 7331
9cc37597 7332 if (SCM_LIKELY (SCM_I_INUMP (x)))
0aacf84e 7333 {
9cc37597 7334 if (SCM_LIKELY (SCM_I_INUMP (y)))
0aacf84e 7335 {
e25f3727
AW		 7336 scm_t_inum xx = SCM_I_INUM (x);
7337 scm_t_inum yy = SCM_I_INUM (y);
7338 scm_t_inum z = xx - yy;
0aacf84e 7339 if (SCM_FIXABLE (z))
d956fa6f 7340 return SCM_I_MAKINUM (z);
0aacf84e 7341 else
e25f3727 7342 return scm_i_inum2big (z);
0aacf84e
MD		 7343 }
7344 else if (SCM_BIGP (y))
7345 {
7346 /* inum-x - big-y */
e25f3727 7347 scm_t_inum xx = SCM_I_INUM (x);
ca46fb90 7348
0aacf84e 7349 if (xx == 0)
b5c40589
MW		 7350 {
7351 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7352 bignum, but negating that gives a fixnum. */
7353 return scm_i_normbig (scm_i_clonebig (y, 0));
7354 }
0aacf84e
MD		 7355 else
7356 {
7357 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
7358 SCM result = scm_i_mkbig ();
ca46fb90 7359
0aacf84e
MD		 7360 if (xx >= 0)
7361 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
7362 else
7363 {
7364 /* x - y == -(y + -x) */
7365 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
7366 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
7367 }
7368 scm_remember_upto_here_1 (y);
ca46fb90 7369
0aacf84e
MD		 7370 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
7371 /* we know the result will have to be a bignum */
7372 return result;
7373 else
7374 return scm_i_normbig (result);
7375 }
7376 }
7377 else if (SCM_REALP (y))
7378 {
e25f3727 7379 scm_t_inum xx = SCM_I_INUM (x);
9b9ef10c
MW		 7380
7381 /*
7382 * We need to handle x == exact 0
7383 * specially because R6RS states that:
7384 * (- 0.0) ==> -0.0 and
7385 * (- 0.0 0.0) ==> 0.0
7386 * and the scheme compiler changes
7387 * (- 0.0) into (- 0 0.0)
7388 * So we need to treat (- 0 0.0) like (- 0.0).
7389 * At the C level, (-x) is different than (0.0 - x).
7390 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7391 */
7392 if (xx == 0)
7393 return scm_from_double (- SCM_REAL_VALUE (y));
7394 else
7395 return scm_from_double (xx - SCM_REAL_VALUE (y));
0aacf84e
MD		 7396 }
7397 else if (SCM_COMPLEXP (y))
7398 {
e25f3727 7399 scm_t_inum xx = SCM_I_INUM (x);
9b9ef10c
MW		 7400
7401 /* We need to handle x == exact 0 specially.
7402 See the comment above (for SCM_REALP (y)) */
7403 if (xx == 0)
7404 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y),
7405 - SCM_COMPLEX_IMAG (y));
7406 else
7407 return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
7408 - SCM_COMPLEX_IMAG (y));
0aacf84e 7409 }
f92e85f7
MV		 7410 else if (SCM_FRACTIONP (y))
7411 /* a - b/c = (ac - b) / c */
cba42c93 7412 return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
f92e85f7
MV		 7413 SCM_FRACTION_NUMERATOR (y)),
7414 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 7415 else
fa075d40 7416 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 7417 }
0aacf84e
MD		 7418 else if (SCM_BIGP (x))
7419 {
e11e83f3 7420 if (SCM_I_INUMP (y))
0aacf84e
MD		 7421 {
7422 /* big-x - inum-y */
e25f3727 7423 scm_t_inum yy = SCM_I_INUM (y);
0aacf84e 7424 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
ca46fb90 7425
0aacf84e
MD		 7426 scm_remember_upto_here_1 (x);
7427 if (sgn_x == 0)
c71b0706 7428 return (SCM_FIXABLE (-yy) ?
e25f3727 7429 SCM_I_MAKINUM (-yy) : scm_from_inum (-yy));
0aacf84e
MD		 7430 else
7431 {
7432 SCM result = scm_i_mkbig ();
ca46fb90 7433
708f22c6
KR		 7434 if (yy >= 0)
7435 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
7436 else
7437 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
0aacf84e 7438 scm_remember_upto_here_1 (x);
ca46fb90 7439
0aacf84e
MD		 7440 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
7441 /* we know the result will have to be a bignum */
7442 return result;
7443 else
7444 return scm_i_normbig (result);
7445 }
7446 }
7447 else if (SCM_BIGP (y))
7448 {
7449 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
7450 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
7451 SCM result = scm_i_mkbig ();
7452 mpz_sub (SCM_I_BIG_MPZ (result),
7453 SCM_I_BIG_MPZ (x),
7454 SCM_I_BIG_MPZ (y));
7455 scm_remember_upto_here_2 (x, y);
7456 /* we know the result will have to be a bignum */
7457 if ((sgn_x == 1) && (sgn_y == -1))
7458 return result;
7459 if ((sgn_x == -1) && (sgn_y == 1))
7460 return result;
7461 return scm_i_normbig (result);
7462 }
7463 else if (SCM_REALP (y))
7464 {
7465 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
7466 scm_remember_upto_here_1 (x);
55f26379 7467 return scm_from_double (result);
0aacf84e
MD		 7468 }
7469 else if (SCM_COMPLEXP (y))
7470 {
7471 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
7472 - SCM_COMPLEX_REAL (y));
7473 scm_remember_upto_here_1 (x);
8507ec80 7474 return scm_c_make_rectangular (real_part, - SCM_COMPLEX_IMAG (y));
0aacf84e 7475 }
f92e85f7 7476 else if (SCM_FRACTIONP (y))
cba42c93 7477 return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
f92e85f7
MV		 7478 SCM_FRACTION_NUMERATOR (y)),
7479 SCM_FRACTION_DENOMINATOR (y));
fa075d40
AW		 7480 else
7481 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
ca46fb90 7482 }
0aacf84e
MD		 7483 else if (SCM_REALP (x))
7484 {
e11e83f3 7485 if (SCM_I_INUMP (y))
55f26379 7486 return scm_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y));
0aacf84e
MD		 7487 else if (SCM_BIGP (y))
7488 {
7489 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
7490 scm_remember_upto_here_1 (x);
55f26379 7491 return scm_from_double (result);
0aacf84e
MD		 7492 }
7493 else if (SCM_REALP (y))
55f26379 7494 return scm_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
0aacf84e 7495 else if (SCM_COMPLEXP (y))
8507ec80 7496 return scm_c_make_rectangular (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
0aacf84e 7497 -SCM_COMPLEX_IMAG (y));
f92e85f7 7498 else if (SCM_FRACTIONP (y))
55f26379 7499 return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
0aacf84e 7500 else
fa075d40 7501 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 7502 }
0aacf84e
MD		 7503 else if (SCM_COMPLEXP (x))
7504 {
e11e83f3 7505 if (SCM_I_INUMP (y))
8507ec80 7506 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_I_INUM (y),
0aacf84e
MD		 7507 SCM_COMPLEX_IMAG (x));
7508 else if (SCM_BIGP (y))
7509 {
7510 double real_part = (SCM_COMPLEX_REAL (x)
7511 - mpz_get_d (SCM_I_BIG_MPZ (y)));
7512 scm_remember_upto_here_1 (x);
8507ec80 7513 return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
0aacf84e
MD		 7514 }
7515 else if (SCM_REALP (y))
8507ec80 7516 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
0aacf84e
MD		 7517 SCM_COMPLEX_IMAG (x));
7518 else if (SCM_COMPLEXP (y))
8507ec80 7519 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
0aacf84e 7520 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
f92e85f7 7521 else if (SCM_FRACTIONP (y))
8507ec80 7522 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
f92e85f7
MV		 7523 SCM_COMPLEX_IMAG (x));
7524 else
fa075d40 7525 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
f92e85f7
MV		 7526 }
7527 else if (SCM_FRACTIONP (x))
7528 {
e11e83f3 7529 if (SCM_I_INUMP (y))
f92e85f7 7530 /* a/b - c = (a - cb) / b */
cba42c93 7531 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 7532 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
7533 SCM_FRACTION_DENOMINATOR (x));
7534 else if (SCM_BIGP (y))
cba42c93 7535 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 7536 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
7537 SCM_FRACTION_DENOMINATOR (x));
7538 else if (SCM_REALP (y))
55f26379 7539 return scm_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
f92e85f7 7540 else if (SCM_COMPLEXP (y))
8507ec80 7541 return scm_c_make_rectangular (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
f92e85f7
MV		 7542 -SCM_COMPLEX_IMAG (y));
7543 else if (SCM_FRACTIONP (y))
7544 /* a/b - c/d = (ad - bc) / bd */
cba42c93 7545 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
f92e85f7
MV		 7546 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
7547 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e 7548 else
fa075d40 7549 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 7550 }
0aacf84e 7551 else
fa075d40 7552 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
0f2d19dd 7553}
c05e97b7 7554#undef FUNC_NAME
0f2d19dd 7555
ca46fb90 7556
40882e3d
KR		 7557SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
7558 (SCM x),
7559 "Return @math{@var{x}-1}.")
7560#define FUNC_NAME s_scm_oneminus
7561{
cff5fa33 7562 return scm_difference (x, SCM_INUM1);
40882e3d
KR		 7563}
7564#undef FUNC_NAME
7565
7566
78d3deb1
AW		 7567SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
7568 (SCM x, SCM y, SCM rest),
7569 "Return the product of all arguments. If called without arguments,\n"
7570 "1 is returned.")
7571#define FUNC_NAME s_scm_i_product
7572{
7573 while (!scm_is_null (rest))
7574 { x = scm_product (x, y);
7575 y = scm_car (rest);
7576 rest = scm_cdr (rest);
7577 }
7578 return scm_product (x, y);
7579}
7580#undef FUNC_NAME
7581
7582#define s_product s_scm_i_product
7583#define g_product g_scm_i_product
7584
0f2d19dd 7585SCM
6e8d25a6 7586scm_product (SCM x, SCM y)
0f2d19dd 7587{
9cc37597 7588 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
0aacf84e
MD		 7589 {
7590 if (SCM_UNBNDP (x))
d956fa6f 7591 return SCM_I_MAKINUM (1L);
0aacf84e
MD		 7592 else if (SCM_NUMBERP (x))
7593 return x;
7594 else
fa075d40 7595 return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
f872b822 7596 }
ca46fb90 7597
9cc37597 7598 if (SCM_LIKELY (SCM_I_INUMP (x)))
0aacf84e 7599 {
e25f3727 7600 scm_t_inum xx;
f4c627b3 7601
5e791807 7602 xinum:
e11e83f3 7603 xx = SCM_I_INUM (x);
f4c627b3 7604
0aacf84e
MD		 7605 switch (xx)
7606 {
5e791807
MW		 7607 case 1:
7608 /* exact1 is the universal multiplicative identity */
7609 return y;
7610 break;
7611 case 0:
7612 /* exact0 times a fixnum is exact0: optimize this case */
7613 if (SCM_LIKELY (SCM_I_INUMP (y)))
7614 return SCM_INUM0;
7615 /* if the other argument is inexact, the result is inexact,
7616 and we must do the multiplication in order to handle
7617 infinities and NaNs properly. */
7618 else if (SCM_REALP (y))
7619 return scm_from_double (0.0 * SCM_REAL_VALUE (y));
7620 else if (SCM_COMPLEXP (y))
7621 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y),
7622 0.0 * SCM_COMPLEX_IMAG (y));
7623 /* we've already handled inexact numbers,
7624 so y must be exact, and we return exact0 */
7625 else if (SCM_NUMP (y))
7626 return SCM_INUM0;
7627 else
fa075d40 7628 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
5e791807
MW		 7629 break;
7630 case -1:
b5c40589 7631 /*
5e791807
MW		 7632 * This case is important for more than just optimization.
7633 * It handles the case of negating
b5c40589
MW		 7634 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7635 * which is a bignum that must be changed back into a fixnum.
7636 * Failure to do so will cause the following to return #f:
7637 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7638 */
b5c40589
MW		 7639 return scm_difference(y, SCM_UNDEFINED);
7640 break;
0aacf84e 7641 }
f4c627b3 7642
9cc37597 7643 if (SCM_LIKELY (SCM_I_INUMP (y)))
0aacf84e 7644 {
e25f3727
AW		 7645 scm_t_inum yy = SCM_I_INUM (y);
7646 scm_t_inum kk = xx * yy;
d956fa6f 7647 SCM k = SCM_I_MAKINUM (kk);
e11e83f3 7648 if ((kk == SCM_I_INUM (k)) && (kk / xx == yy))
0aacf84e
MD		 7649 return k;
7650 else
7651 {
e25f3727 7652 SCM result = scm_i_inum2big (xx);
0aacf84e
MD		 7653 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
7654 return scm_i_normbig (result);
7655 }
7656 }
7657 else if (SCM_BIGP (y))
7658 {
7659 SCM result = scm_i_mkbig ();
7660 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
7661 scm_remember_upto_here_1 (y);
7662 return result;
7663 }
7664 else if (SCM_REALP (y))
55f26379 7665 return scm_from_double (xx * SCM_REAL_VALUE (y));
0aacf84e 7666 else if (SCM_COMPLEXP (y))
8507ec80 7667 return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
0aacf84e 7668 xx * SCM_COMPLEX_IMAG (y));
f92e85f7 7669 else if (SCM_FRACTIONP (y))
cba42c93 7670 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
f92e85f7 7671 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 7672 else
fa075d40 7673 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 7674 }
0aacf84e
MD		 7675 else if (SCM_BIGP (x))
7676 {
e11e83f3 7677 if (SCM_I_INUMP (y))
0aacf84e
MD		 7678 {
7679 SCM_SWAP (x, y);
5e791807 7680 goto xinum;
0aacf84e
MD		 7681 }
7682 else if (SCM_BIGP (y))
7683 {
7684 SCM result = scm_i_mkbig ();
7685 mpz_mul (SCM_I_BIG_MPZ (result),
7686 SCM_I_BIG_MPZ (x),
7687 SCM_I_BIG_MPZ (y));
7688 scm_remember_upto_here_2 (x, y);
7689 return result;
7690 }
7691 else if (SCM_REALP (y))
7692 {
7693 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
7694 scm_remember_upto_here_1 (x);
55f26379 7695 return scm_from_double (result);
0aacf84e
MD		 7696 }
7697 else if (SCM_COMPLEXP (y))
7698 {
7699 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
7700 scm_remember_upto_here_1 (x);
8507ec80 7701 return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y),
0aacf84e
MD		 7702 z * SCM_COMPLEX_IMAG (y));
7703 }
f92e85f7 7704 else if (SCM_FRACTIONP (y))
cba42c93 7705 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
f92e85f7 7706 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 7707 else
fa075d40 7708 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 7709 }
0aacf84e
MD		 7710 else if (SCM_REALP (x))
7711 {
e11e83f3 7712 if (SCM_I_INUMP (y))
5e791807
MW		 7713 {
7714 SCM_SWAP (x, y);
7715 goto xinum;
7716 }
0aacf84e
MD		 7717 else if (SCM_BIGP (y))
7718 {
7719 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
7720 scm_remember_upto_here_1 (y);
55f26379 7721 return scm_from_double (result);
0aacf84e
MD		 7722 }
7723 else if (SCM_REALP (y))
55f26379 7724 return scm_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
0aacf84e 7725 else if (SCM_COMPLEXP (y))
8507ec80 7726 return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
0aacf84e 7727 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
f92e85f7 7728 else if (SCM_FRACTIONP (y))
55f26379 7729 return scm_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
0aacf84e 7730 else
fa075d40 7731 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 7732 }
0aacf84e
MD		 7733 else if (SCM_COMPLEXP (x))
7734 {
e11e83f3 7735 if (SCM_I_INUMP (y))
5e791807
MW		 7736 {
7737 SCM_SWAP (x, y);
7738 goto xinum;
7739 }
0aacf84e
MD		 7740 else if (SCM_BIGP (y))
7741 {
7742 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
7743 scm_remember_upto_here_1 (y);
8507ec80 7744 return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (x),
76506335 7745 z * SCM_COMPLEX_IMAG (x));
0aacf84e
MD		 7746 }
7747 else if (SCM_REALP (y))
8507ec80 7748 return scm_c_make_rectangular (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
0aacf84e
MD		 7749 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
7750 else if (SCM_COMPLEXP (y))
7751 {
8507ec80 7752 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
0aacf84e
MD		 7753 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
7754 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
7755 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
7756 }
f92e85f7
MV		 7757 else if (SCM_FRACTIONP (y))
7758 {
7759 double yy = scm_i_fraction2double (y);
8507ec80 7760 return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x),
f92e85f7
MV		 7761 yy * SCM_COMPLEX_IMAG (x));
7762 }
7763 else
fa075d40 7764 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
f92e85f7
MV		 7765 }
7766 else if (SCM_FRACTIONP (x))
7767 {
e11e83f3 7768 if (SCM_I_INUMP (y))
cba42c93 7769 return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
f92e85f7
MV		 7770 SCM_FRACTION_DENOMINATOR (x));
7771 else if (SCM_BIGP (y))
cba42c93 7772 return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
f92e85f7
MV		 7773 SCM_FRACTION_DENOMINATOR (x));
7774 else if (SCM_REALP (y))
55f26379 7775 return scm_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
f92e85f7
MV		 7776 else if (SCM_COMPLEXP (y))
7777 {
7778 double xx = scm_i_fraction2double (x);
8507ec80 7779 return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
f92e85f7
MV		 7780 xx * SCM_COMPLEX_IMAG (y));
7781 }
7782 else if (SCM_FRACTIONP (y))
7783 /* a/b * c/d = ac / bd */
cba42c93 7784 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 7785 SCM_FRACTION_NUMERATOR (y)),
7786 scm_product (SCM_FRACTION_DENOMINATOR (x),
7787 SCM_FRACTION_DENOMINATOR (y)));
0aacf84e 7788 else
fa075d40 7789 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 7790 }
0aacf84e 7791 else
fa075d40 7792 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
0f2d19dd
JB		 7793}
7794
7351e207
MV		 7795#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7796 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7797#define ALLOW_DIVIDE_BY_ZERO
7798/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7799#endif
0f2d19dd 7800
ba74ef4e
MV		 7801/* The code below for complex division is adapted from the GNU
7802 libstdc++, which adapted it from f2c's libF77, and is subject to
7803 this copyright: */
7804
7805/****************************************************************
7806Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7807
7808Permission to use, copy, modify, and distribute this software
7809and its documentation for any purpose and without fee is hereby
7810granted, provided that the above copyright notice appear in all
7811copies and that both that the copyright notice and this
7812permission notice and warranty disclaimer appear in supporting
7813documentation, and that the names of AT&T Bell Laboratories or
7814Bellcore or any of their entities not be used in advertising or
7815publicity pertaining to distribution of the software without
7816specific, written prior permission.
7817
7818AT&T and Bellcore disclaim all warranties with regard to this
7819software, including all implied warranties of merchantability
7820and fitness. In no event shall AT&T or Bellcore be liable for
7821any special, indirect or consequential damages or any damages
7822whatsoever resulting from loss of use, data or profits, whether
7823in an action of contract, negligence or other tortious action,
7824arising out of or in connection with the use or performance of
7825this software.
7826****************************************************************/
7827
78d3deb1
AW		 7828SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
7829 (SCM x, SCM y, SCM rest),
7830 "Divide the first argument by the product of the remaining\n"
7831 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7832 "returned.")
7833#define FUNC_NAME s_scm_i_divide
7834{
7835 while (!scm_is_null (rest))
7836 { x = scm_divide (x, y);
7837 y = scm_car (rest);
7838 rest = scm_cdr (rest);
7839 }
7840 return scm_divide (x, y);
7841}
7842#undef FUNC_NAME
7843
7844#define s_divide s_scm_i_divide
7845#define g_divide g_scm_i_divide
7846
f92e85f7 7847static SCM
78d3deb1
AW		 7848do_divide (SCM x, SCM y, int inexact)
7849#define FUNC_NAME s_divide
0f2d19dd 7850{
f8de44c1
DH		 7851 double a;
7852
9cc37597 7853 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
0aacf84e
MD		 7854 {
7855 if (SCM_UNBNDP (x))
fa075d40 7856 return scm_wta_dispatch_0 (g_divide, s_divide);
e11e83f3 7857 else if (SCM_I_INUMP (x))
0aacf84e 7858 {
e25f3727 7859 scm_t_inum xx = SCM_I_INUM (x);
0aacf84e
MD		 7860 if (xx == 1 || xx == -1)
7861 return x;
7351e207 7862#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 7863 else if (xx == 0)
7864 scm_num_overflow (s_divide);
7351e207 7865#endif
0aacf84e 7866 else
f92e85f7
MV		 7867 {
7868 if (inexact)
55f26379 7869 return scm_from_double (1.0 / (double) xx);
cff5fa33 7870 else return scm_i_make_ratio (SCM_INUM1, x);
f92e85f7 7871 }
0aacf84e
MD		 7872 }
7873 else if (SCM_BIGP (x))
f92e85f7
MV		 7874 {
7875 if (inexact)
55f26379 7876 return scm_from_double (1.0 / scm_i_big2dbl (x));
cff5fa33 7877 else return scm_i_make_ratio (SCM_INUM1, x);
f92e85f7 7878 }
0aacf84e
MD		 7879 else if (SCM_REALP (x))
7880 {
7881 double xx = SCM_REAL_VALUE (x);
7351e207 7882#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 7883 if (xx == 0.0)
7884 scm_num_overflow (s_divide);
7885 else
7351e207 7886#endif
55f26379 7887 return scm_from_double (1.0 / xx);
0aacf84e
MD		 7888 }
7889 else if (SCM_COMPLEXP (x))
7890 {
7891 double r = SCM_COMPLEX_REAL (x);
7892 double i = SCM_COMPLEX_IMAG (x);
4c6e36a6 7893 if (fabs(r) <= fabs(i))
0aacf84e
MD		 7894 {
7895 double t = r / i;
7896 double d = i * (1.0 + t * t);
8507ec80 7897 return scm_c_make_rectangular (t / d, -1.0 / d);
0aacf84e
MD		 7898 }
7899 else
7900 {
7901 double t = i / r;
7902 double d = r * (1.0 + t * t);
8507ec80 7903 return scm_c_make_rectangular (1.0 / d, -t / d);
0aacf84e
MD		 7904 }
7905 }
f92e85f7 7906 else if (SCM_FRACTIONP (x))
cba42c93 7907 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
f92e85f7 7908 SCM_FRACTION_NUMERATOR (x));
0aacf84e 7909 else
fa075d40 7910 return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
f8de44c1 7911 }
f8de44c1 7912
9cc37597 7913 if (SCM_LIKELY (SCM_I_INUMP (x)))
0aacf84e 7914 {
e25f3727 7915 scm_t_inum xx = SCM_I_INUM (x);
9cc37597 7916 if (SCM_LIKELY (SCM_I_INUMP (y)))
0aacf84e 7917 {
e25f3727 7918 scm_t_inum yy = SCM_I_INUM (y);
0aacf84e
MD		 7919 if (yy == 0)
7920 {
7351e207 7921#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 7922 scm_num_overflow (s_divide);
7351e207 7923#else
55f26379 7924 return scm_from_double ((double) xx / (double) yy);
7351e207 7925#endif
0aacf84e
MD		 7926 }
7927 else if (xx % yy != 0)
f92e85f7
MV		 7928 {
7929 if (inexact)
55f26379 7930 return scm_from_double ((double) xx / (double) yy);
cba42c93 7931 else return scm_i_make_ratio (x, y);
f92e85f7 7932 }
0aacf84e
MD		 7933 else
7934 {
e25f3727 7935 scm_t_inum z = xx / yy;
0aacf84e 7936 if (SCM_FIXABLE (z))
d956fa6f 7937 return SCM_I_MAKINUM (z);
0aacf84e 7938 else
e25f3727 7939 return scm_i_inum2big (z);
0aacf84e 7940 }
f872b822 7941 }
0aacf84e 7942 else if (SCM_BIGP (y))
f92e85f7
MV		 7943 {
7944 if (inexact)
55f26379 7945 return scm_from_double ((double) xx / scm_i_big2dbl (y));
cba42c93 7946 else return scm_i_make_ratio (x, y);
f92e85f7 7947 }
0aacf84e
MD		 7948 else if (SCM_REALP (y))
7949 {
7950 double yy = SCM_REAL_VALUE (y);
7351e207 7951#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 7952 if (yy == 0.0)
7953 scm_num_overflow (s_divide);
7954 else
7351e207 7955#endif
55f26379 7956 return scm_from_double ((double) xx / yy);
ba74ef4e 7957 }
0aacf84e
MD		 7958 else if (SCM_COMPLEXP (y))
7959 {
7960 a = xx;
7961 complex_div: /* y _must_ be a complex number */
7962 {
7963 double r = SCM_COMPLEX_REAL (y);
7964 double i = SCM_COMPLEX_IMAG (y);
4c6e36a6 7965 if (fabs(r) <= fabs(i))
0aacf84e
MD		 7966 {
7967 double t = r / i;
7968 double d = i * (1.0 + t * t);
8507ec80 7969 return scm_c_make_rectangular ((a * t) / d, -a / d);
0aacf84e
MD		 7970 }
7971 else
7972 {
7973 double t = i / r;
7974 double d = r * (1.0 + t * t);
8507ec80 7975 return scm_c_make_rectangular (a / d, -(a * t) / d);
0aacf84e
MD		 7976 }
7977 }
7978 }
f92e85f7
MV		 7979 else if (SCM_FRACTIONP (y))
7980 /* a / b/c = ac / b */
cba42c93 7981 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
f92e85f7 7982 SCM_FRACTION_NUMERATOR (y));
0aacf84e 7983 else
fa075d40 7984 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 7985 }
0aacf84e
MD		 7986 else if (SCM_BIGP (x))
7987 {
e11e83f3 7988 if (SCM_I_INUMP (y))
0aacf84e 7989 {
e25f3727 7990 scm_t_inum yy = SCM_I_INUM (y);
0aacf84e
MD		 7991 if (yy == 0)
7992 {
7351e207 7993#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 7994 scm_num_overflow (s_divide);
7351e207 7995#else
0aacf84e
MD		 7996 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7997 scm_remember_upto_here_1 (x);
7998 return (sgn == 0) ? scm_nan () : scm_inf ();
7351e207 7999#endif
0aacf84e
MD		 8000 }
8001 else if (yy == 1)
8002 return x;
8003 else
8004 {
8005 /* FIXME: HMM, what are the relative performance issues here?
8006 We need to test. Is it faster on average to test
8007 divisible_p, then perform whichever operation, or is it
8008 faster to perform the integer div opportunistically and
8009 switch to real if there's a remainder? For now we take the
8010 middle ground: test, then if divisible, use the faster div
8011 func. */
8012
e25f3727 8013 scm_t_inum abs_yy = yy < 0 ? -yy : yy;
0aacf84e
MD		 8014 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
8015
8016 if (divisible_p)
8017 {
8018 SCM result = scm_i_mkbig ();
8019 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
8020 scm_remember_upto_here_1 (x);
8021 if (yy < 0)
8022 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
8023 return scm_i_normbig (result);
8024 }
8025 else
f92e85f7
MV		 8026 {
8027 if (inexact)
55f26379 8028 return scm_from_double (scm_i_big2dbl (x) / (double) yy);
cba42c93 8029 else return scm_i_make_ratio (x, y);
f92e85f7 8030 }
0aacf84e
MD		 8031 }
8032 }
8033 else if (SCM_BIGP (y))
8034 {
a4955a04
MW		 8035 /* big_x / big_y */
8036 if (inexact)
0aacf84e 8037 {
a4955a04
MW		 8038 /* It's easily possible for the ratio x/y to fit a double
8039 but one or both x and y be too big to fit a double,
8040 hence the use of mpq_get_d rather than converting and
8041 dividing. */
8042 mpq_t q;
8043 *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
8044 *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
8045 return scm_from_double (mpq_get_d (q));
0aacf84e
MD		 8046 }
8047 else
8048 {
a4955a04
MW		 8049 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
8050 SCM_I_BIG_MPZ (y));
8051 if (divisible_p)
8052 {
8053 SCM result = scm_i_mkbig ();
8054 mpz_divexact (SCM_I_BIG_MPZ (result),
8055 SCM_I_BIG_MPZ (x),
8056 SCM_I_BIG_MPZ (y));
8057 scm_remember_upto_here_2 (x, y);
8058 return scm_i_normbig (result);
8059 }
8060 else
8061 return scm_i_make_ratio (x, y);
0aacf84e
MD		 8062 }
8063 }
8064 else if (SCM_REALP (y))
8065 {
8066 double yy = SCM_REAL_VALUE (y);
7351e207 8067#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 8068 if (yy == 0.0)
8069 scm_num_overflow (s_divide);
8070 else
7351e207 8071#endif
55f26379 8072 return scm_from_double (scm_i_big2dbl (x) / yy);
0aacf84e
MD		 8073 }
8074 else if (SCM_COMPLEXP (y))
8075 {
8076 a = scm_i_big2dbl (x);
8077 goto complex_div;
8078 }
f92e85f7 8079 else if (SCM_FRACTIONP (y))
cba42c93 8080 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
f92e85f7 8081 SCM_FRACTION_NUMERATOR (y));
0aacf84e 8082 else
fa075d40 8083 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 8084 }
0aacf84e
MD		 8085 else if (SCM_REALP (x))
8086 {
8087 double rx = SCM_REAL_VALUE (x);
e11e83f3 8088 if (SCM_I_INUMP (y))
0aacf84e 8089 {
e25f3727 8090 scm_t_inum yy = SCM_I_INUM (y);
7351e207 8091#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 8092 if (yy == 0)
8093 scm_num_overflow (s_divide);
8094 else
7351e207 8095#endif
55f26379 8096 return scm_from_double (rx / (double) yy);
0aacf84e
MD		 8097 }
8098 else if (SCM_BIGP (y))
8099 {
8100 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
8101 scm_remember_upto_here_1 (y);
55f26379 8102 return scm_from_double (rx / dby);
0aacf84e
MD		 8103 }
8104 else if (SCM_REALP (y))
8105 {
8106 double yy = SCM_REAL_VALUE (y);
7351e207 8107#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 8108 if (yy == 0.0)
8109 scm_num_overflow (s_divide);
8110 else
7351e207 8111#endif
55f26379 8112 return scm_from_double (rx / yy);
0aacf84e
MD		 8113 }
8114 else if (SCM_COMPLEXP (y))
8115 {
8116 a = rx;
8117 goto complex_div;
8118 }
f92e85f7 8119 else if (SCM_FRACTIONP (y))
55f26379 8120 return scm_from_double (rx / scm_i_fraction2double (y));
0aacf84e 8121 else
fa075d40 8122 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 8123 }
0aacf84e
MD		 8124 else if (SCM_COMPLEXP (x))
8125 {
8126 double rx = SCM_COMPLEX_REAL (x);
8127 double ix = SCM_COMPLEX_IMAG (x);
e11e83f3 8128 if (SCM_I_INUMP (y))
0aacf84e 8129 {
e25f3727 8130 scm_t_inum yy = SCM_I_INUM (y);
7351e207 8131#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 8132 if (yy == 0)
8133 scm_num_overflow (s_divide);
8134 else
7351e207 8135#endif
0aacf84e
MD		 8136 {
8137 double d = yy;
8507ec80 8138 return scm_c_make_rectangular (rx / d, ix / d);
0aacf84e
MD		 8139 }
8140 }
8141 else if (SCM_BIGP (y))
8142 {
8143 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
8144 scm_remember_upto_here_1 (y);
8507ec80 8145 return scm_c_make_rectangular (rx / dby, ix / dby);
0aacf84e
MD		 8146 }
8147 else if (SCM_REALP (y))
8148 {
8149 double yy = SCM_REAL_VALUE (y);
7351e207 8150#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 8151 if (yy == 0.0)
8152 scm_num_overflow (s_divide);
8153 else
7351e207 8154#endif
8507ec80 8155 return scm_c_make_rectangular (rx / yy, ix / yy);
0aacf84e
MD		 8156 }
8157 else if (SCM_COMPLEXP (y))
8158 {
8159 double ry = SCM_COMPLEX_REAL (y);
8160 double iy = SCM_COMPLEX_IMAG (y);
4c6e36a6 8161 if (fabs(ry) <= fabs(iy))
0aacf84e
MD		 8162 {
8163 double t = ry / iy;
8164 double d = iy * (1.0 + t * t);
8507ec80 8165 return scm_c_make_rectangular ((rx * t + ix) / d, (ix * t - rx) / d);
0aacf84e
MD		 8166 }
8167 else
8168 {
8169 double t = iy / ry;
8170 double d = ry * (1.0 + t * t);
8507ec80 8171 return scm_c_make_rectangular ((rx + ix * t) / d, (ix - rx * t) / d);
0aacf84e
MD		 8172 }
8173 }
f92e85f7
MV		 8174 else if (SCM_FRACTIONP (y))
8175 {
8176 double yy = scm_i_fraction2double (y);
8507ec80 8177 return scm_c_make_rectangular (rx / yy, ix / yy);
f92e85f7 8178 }
0aacf84e 8179 else
fa075d40 8180 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 8181 }
f92e85f7
MV		 8182 else if (SCM_FRACTIONP (x))
8183 {
e11e83f3 8184 if (SCM_I_INUMP (y))
f92e85f7 8185 {
e25f3727 8186 scm_t_inum yy = SCM_I_INUM (y);
f92e85f7
MV		 8187#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8188 if (yy == 0)
8189 scm_num_overflow (s_divide);
8190 else
8191#endif
cba42c93 8192 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 8193 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
8194 }
8195 else if (SCM_BIGP (y))
8196 {
cba42c93 8197 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
f92e85f7
MV		 8198 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
8199 }
8200 else if (SCM_REALP (y))
8201 {
8202 double yy = SCM_REAL_VALUE (y);
8203#ifndef ALLOW_DIVIDE_BY_ZERO
8204 if (yy == 0.0)
8205 scm_num_overflow (s_divide);
8206 else
8207#endif
55f26379 8208 return scm_from_double (scm_i_fraction2double (x) / yy);
f92e85f7
MV		 8209 }
8210 else if (SCM_COMPLEXP (y))
8211 {
8212 a = scm_i_fraction2double (x);
8213 goto complex_div;
8214 }
8215 else if (SCM_FRACTIONP (y))
cba42c93 8216 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
f92e85f7
MV		 8217 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
8218 else
fa075d40 8219 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
f92e85f7 8220 }
0aacf84e 8221 else
fa075d40 8222 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
0f2d19dd 8223}
f92e85f7
MV		 8224
8225SCM
8226scm_divide (SCM x, SCM y)
8227{
78d3deb1 8228 return do_divide (x, y, 0);
f92e85f7
MV		 8229}
8230
8231static SCM scm_divide2real (SCM x, SCM y)
8232{
78d3deb1 8233 return do_divide (x, y, 1);
f92e85f7 8234}
c05e97b7 8235#undef FUNC_NAME
0f2d19dd 8236
fa605590 8237
0f2d19dd 8238double
3101f40f 8239scm_c_truncate (double x)
0f2d19dd 8240{
fa605590 8241 return trunc (x);
0f2d19dd 8242}
0f2d19dd 8243
3101f40f
MV		 8244/* scm_c_round is done using floor(x+0.5) to round to nearest and with
8245 half-way case (ie. when x is an integer plus 0.5) going upwards.
8246 Then half-way cases are identified and adjusted down if the
8247 round-upwards didn't give the desired even integer.
6187f48b
KR		 8248
8249 "plus_half == result" identifies a half-way case. If plus_half, which is
8250 x + 0.5, is an integer then x must be an integer plus 0.5.
8251
8252 An odd "result" value is identified with result/2 != floor(result/2).
8253 This is done with plus_half, since that value is ready for use sooner in
8254 a pipelined cpu, and we're already requiring plus_half == result.
8255
8256 Note however that we need to be careful when x is big and already an
8257 integer. In that case "x+0.5" may round to an adjacent integer, causing
8258 us to return such a value, incorrectly. For instance if the hardware is
8259 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8260 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8261 returned. Or if the hardware is in round-upwards mode, then other bigger
8262 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8263 representable value, 2^128+2^76 (or whatever), again incorrect.
8264
8265 These bad roundings of x+0.5 are avoided by testing at the start whether
8266 x is already an integer. If it is then clearly that's the desired result
8267 already. And if it's not then the exponent must be small enough to allow
8268 an 0.5 to be represented, and hence added without a bad rounding. */
8269
0f2d19dd 8270double
3101f40f 8271scm_c_round (double x)
0f2d19dd 8272{
6187f48b
KR		 8273 double plus_half, result;
8274
8275 if (x == floor (x))
8276 return x;
8277
8278 plus_half = x + 0.5;
8279 result = floor (plus_half);
3101f40f 8280 /* Adjust so that the rounding is towards even. */
0aacf84e
MD		 8281 return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
8282 ? result - 1
8283 : result);
0f2d19dd
JB		 8284}
8285
8b56bcec
MW		 8286SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0,
8287 (SCM x),
8288 "Round the number @var{x} towards zero.")
f92e85f7
MV		 8289#define FUNC_NAME s_scm_truncate_number
8290{
8b56bcec
MW		 8291 if (SCM_I_INUMP (x) || SCM_BIGP (x))
8292 return x;
8293 else if (SCM_REALP (x))
c251ab63 8294 return scm_from_double (trunc (SCM_REAL_VALUE (x)));
8b56bcec
MW		 8295 else if (SCM_FRACTIONP (x))
8296 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
8297 SCM_FRACTION_DENOMINATOR (x));
f92e85f7 8298 else
fa075d40 8299 return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
8b56bcec 8300 s_scm_truncate_number);
f92e85f7
MV		 8301}
8302#undef FUNC_NAME
8303
8b56bcec
MW		 8304SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0,
8305 (SCM x),
8306 "Round the number @var{x} towards the nearest integer. "
8307 "When it is exactly halfway between two integers, "
8308 "round towards the even one.")
f92e85f7
MV		 8309#define FUNC_NAME s_scm_round_number
8310{
e11e83f3 8311 if (SCM_I_INUMP (x) || SCM_BIGP (x))
bae30667
KR		 8312 return x;
8313 else if (SCM_REALP (x))
3101f40f 8314 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x)));
8b56bcec
MW		 8315 else if (SCM_FRACTIONP (x))
8316 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
8317 SCM_FRACTION_DENOMINATOR (x));
f92e85f7 8318 else
fa075d40
AW		 8319 return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
8320 s_scm_round_number);
f92e85f7
MV		 8321}
8322#undef FUNC_NAME
8323
8324SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
8325 (SCM x),
8326 "Round the number @var{x} towards minus infinity.")
8327#define FUNC_NAME s_scm_floor
8328{
e11e83f3 8329 if (SCM_I_INUMP (x) || SCM_BIGP (x))
f92e85f7
MV		 8330 return x;
8331 else if (SCM_REALP (x))
55f26379 8332 return scm_from_double (floor (SCM_REAL_VALUE (x)));
f92e85f7 8333 else if (SCM_FRACTIONP (x))
8b56bcec
MW		 8334 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
8335 SCM_FRACTION_DENOMINATOR (x));
f92e85f7 8336 else
fa075d40 8337 return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
f92e85f7
MV		 8338}
8339#undef FUNC_NAME
8340
8341SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
8342 (SCM x),
8343 "Round the number @var{x} towards infinity.")
8344#define FUNC_NAME s_scm_ceiling
8345{
e11e83f3 8346 if (SCM_I_INUMP (x) || SCM_BIGP (x))
f92e85f7
MV		 8347 return x;
8348 else if (SCM_REALP (x))
55f26379 8349 return scm_from_double (ceil (SCM_REAL_VALUE (x)));
f92e85f7 8350 else if (SCM_FRACTIONP (x))
8b56bcec
MW		 8351 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
8352 SCM_FRACTION_DENOMINATOR (x));
f92e85f7 8353 else
fa075d40 8354 return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
f92e85f7
MV		 8355}
8356#undef FUNC_NAME
0f2d19dd 8357
2519490c
MW		 8358SCM_PRIMITIVE_GENERIC (scm_expt, "expt", 2, 0, 0,
8359 (SCM x, SCM y),
8360 "Return @var{x} raised to the power of @var{y}.")
6fc4d012 8361#define FUNC_NAME s_scm_expt
0f2d19dd 8362{
01c7284a
MW		 8363 if (scm_is_integer (y))
8364 {
8365 if (scm_is_true (scm_exact_p (y)))
8366 return scm_integer_expt (x, y);
8367 else
8368 {
8369 /* Here we handle the case where the exponent is an inexact
8370 integer. We make the exponent exact in order to use
8371 scm_integer_expt, and thus avoid the spurious imaginary
8372 parts that may result from round-off errors in the general
8373 e^(y log x) method below (for example when squaring a large
8374 negative number). In this case, we must return an inexact
8375 result for correctness. We also make the base inexact so
8376 that scm_integer_expt will use fast inexact arithmetic
8377 internally. Note that making the base inexact is not
8378 sufficient to guarantee an inexact result, because
8379 scm_integer_expt will return an exact 1 when the exponent
8380 is 0, even if the base is inexact. */
8381 return scm_exact_to_inexact
8382 (scm_integer_expt (scm_exact_to_inexact (x),
8383 scm_inexact_to_exact (y)));
8384 }
8385 }
6fc4d012
AW		 8386 else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
8387 {
8388 return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
8389 }
2519490c 8390 else if (scm_is_complex (x) && scm_is_complex (y))
6fc4d012 8391 return scm_exp (scm_product (scm_log (x), y));
2519490c 8392 else if (scm_is_complex (x))
fa075d40 8393 return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
2519490c 8394 else
fa075d40 8395 return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
0f2d19dd 8396}
1bbd0b84 8397#undef FUNC_NAME
0f2d19dd 8398
7f41099e
MW		 8399/* sin/cos/tan/asin/acos/atan
8400 sinh/cosh/tanh/asinh/acosh/atanh
8401 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8402 Written by Jerry D. Hedden, (C) FSF.
8403 See the file `COPYING' for terms applying to this program. */
8404
ad79736c
AW		 8405SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
8406 (SCM z),
8407 "Compute the sine of @var{z}.")
8408#define FUNC_NAME s_scm_sin
8409{
8deddc94
MW		 8410 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8411 return z; /* sin(exact0) = exact0 */
8412 else if (scm_is_real (z))
ad79736c
AW		 8413 return scm_from_double (sin (scm_to_double (z)));
8414 else if (SCM_COMPLEXP (z))
8415 { double x, y;
8416 x = SCM_COMPLEX_REAL (z);
8417 y = SCM_COMPLEX_IMAG (z);
8418 return scm_c_make_rectangular (sin (x) * cosh (y),
8419 cos (x) * sinh (y));
8420 }
8421 else
fa075d40 8422 return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
ad79736c
AW		 8423}
8424#undef FUNC_NAME
0f2d19dd 8425
ad79736c
AW		 8426SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
8427 (SCM z),
8428 "Compute the cosine of @var{z}.")
8429#define FUNC_NAME s_scm_cos
8430{
8deddc94
MW		 8431 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8432 return SCM_INUM1; /* cos(exact0) = exact1 */
8433 else if (scm_is_real (z))
ad79736c
AW		 8434 return scm_from_double (cos (scm_to_double (z)));
8435 else if (SCM_COMPLEXP (z))
8436 { double x, y;
8437 x = SCM_COMPLEX_REAL (z);
8438 y = SCM_COMPLEX_IMAG (z);
8439 return scm_c_make_rectangular (cos (x) * cosh (y),
8440 -sin (x) * sinh (y));
8441 }
8442 else
fa075d40 8443 return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
ad79736c
AW		 8444}
8445#undef FUNC_NAME
8446
8447SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
8448 (SCM z),
8449 "Compute the tangent of @var{z}.")
8450#define FUNC_NAME s_scm_tan
0f2d19dd 8451{
8deddc94
MW		 8452 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8453 return z; /* tan(exact0) = exact0 */
8454 else if (scm_is_real (z))
ad79736c
AW		 8455 return scm_from_double (tan (scm_to_double (z)));
8456 else if (SCM_COMPLEXP (z))
8457 { double x, y, w;
8458 x = 2.0 * SCM_COMPLEX_REAL (z);
8459 y = 2.0 * SCM_COMPLEX_IMAG (z);
8460 w = cos (x) + cosh (y);
8461#ifndef ALLOW_DIVIDE_BY_ZERO
8462 if (w == 0.0)
8463 scm_num_overflow (s_scm_tan);
8464#endif
8465 return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
8466 }
8467 else
fa075d40 8468 return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
ad79736c
AW		 8469}
8470#undef FUNC_NAME
8471
8472SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
8473 (SCM z),
8474 "Compute the hyperbolic sine of @var{z}.")
8475#define FUNC_NAME s_scm_sinh
8476{
8deddc94
MW		 8477 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8478 return z; /* sinh(exact0) = exact0 */
8479 else if (scm_is_real (z))
ad79736c
AW		 8480 return scm_from_double (sinh (scm_to_double (z)));
8481 else if (SCM_COMPLEXP (z))
8482 { double x, y;
8483 x = SCM_COMPLEX_REAL (z);
8484 y = SCM_COMPLEX_IMAG (z);
8485 return scm_c_make_rectangular (sinh (x) * cos (y),
8486 cosh (x) * sin (y));
8487 }
8488 else
fa075d40 8489 return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
ad79736c
AW		 8490}
8491#undef FUNC_NAME
8492
8493SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
8494 (SCM z),
8495 "Compute the hyperbolic cosine of @var{z}.")
8496#define FUNC_NAME s_scm_cosh
8497{
8deddc94
MW		 8498 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8499 return SCM_INUM1; /* cosh(exact0) = exact1 */
8500 else if (scm_is_real (z))
ad79736c
AW		 8501 return scm_from_double (cosh (scm_to_double (z)));
8502 else if (SCM_COMPLEXP (z))
8503 { double x, y;
8504 x = SCM_COMPLEX_REAL (z);
8505 y = SCM_COMPLEX_IMAG (z);
8506 return scm_c_make_rectangular (cosh (x) * cos (y),
8507 sinh (x) * sin (y));
8508 }
8509 else
fa075d40 8510 return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
ad79736c
AW		 8511}
8512#undef FUNC_NAME
8513
8514SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
8515 (SCM z),
8516 "Compute the hyperbolic tangent of @var{z}.")
8517#define FUNC_NAME s_scm_tanh
8518{
8deddc94
MW		 8519 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8520 return z; /* tanh(exact0) = exact0 */
8521 else if (scm_is_real (z))
ad79736c
AW		 8522 return scm_from_double (tanh (scm_to_double (z)));
8523 else if (SCM_COMPLEXP (z))
8524 { double x, y, w;
8525 x = 2.0 * SCM_COMPLEX_REAL (z);
8526 y = 2.0 * SCM_COMPLEX_IMAG (z);
8527 w = cosh (x) + cos (y);
8528#ifndef ALLOW_DIVIDE_BY_ZERO
8529 if (w == 0.0)
8530 scm_num_overflow (s_scm_tanh);
8531#endif
8532 return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
8533 }
8534 else
fa075d40 8535 return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
ad79736c
AW		 8536}
8537#undef FUNC_NAME
8538
8539SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
8540 (SCM z),
8541 "Compute the arc sine of @var{z}.")
8542#define FUNC_NAME s_scm_asin
8543{
8deddc94
MW		 8544 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8545 return z; /* asin(exact0) = exact0 */
8546 else if (scm_is_real (z))
ad79736c
AW		 8547 {
8548 double w = scm_to_double (z);
8549 if (w >= -1.0 && w <= 1.0)
8550 return scm_from_double (asin (w));
8551 else
8552 return scm_product (scm_c_make_rectangular (0, -1),
8553 scm_sys_asinh (scm_c_make_rectangular (0, w)));
8554 }
8555 else if (SCM_COMPLEXP (z))
8556 { double x, y;
8557 x = SCM_COMPLEX_REAL (z);
8558 y = SCM_COMPLEX_IMAG (z);
8559 return scm_product (scm_c_make_rectangular (0, -1),
8560 scm_sys_asinh (scm_c_make_rectangular (-y, x)));
8561 }
8562 else
fa075d40 8563 return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
ad79736c
AW		 8564}
8565#undef FUNC_NAME
8566
8567SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
8568 (SCM z),
8569 "Compute the arc cosine of @var{z}.")
8570#define FUNC_NAME s_scm_acos
8571{
8deddc94
MW		 8572 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
8573 return SCM_INUM0; /* acos(exact1) = exact0 */
8574 else if (scm_is_real (z))
ad79736c
AW		 8575 {
8576 double w = scm_to_double (z);
8577 if (w >= -1.0 && w <= 1.0)
8578 return scm_from_double (acos (w));
8579 else
8580 return scm_sum (scm_from_double (acos (0.0)),
8581 scm_product (scm_c_make_rectangular (0, 1),
8582 scm_sys_asinh (scm_c_make_rectangular (0, w))));
8583 }
8584 else if (SCM_COMPLEXP (z))
8585 { double x, y;
8586 x = SCM_COMPLEX_REAL (z);
8587 y = SCM_COMPLEX_IMAG (z);
8588 return scm_sum (scm_from_double (acos (0.0)),
8589 scm_product (scm_c_make_rectangular (0, 1),
8590 scm_sys_asinh (scm_c_make_rectangular (-y, x))));
8591 }
8592 else
fa075d40 8593 return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
ad79736c
AW		 8594}
8595#undef FUNC_NAME
8596
8597SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
8598 (SCM z, SCM y),
8599 "With one argument, compute the arc tangent of @var{z}.\n"
8600 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8601 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8602#define FUNC_NAME s_scm_atan
8603{
8604 if (SCM_UNBNDP (y))
8605 {
8deddc94
MW		 8606 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8607 return z; /* atan(exact0) = exact0 */
8608 else if (scm_is_real (z))
ad79736c
AW		 8609 return scm_from_double (atan (scm_to_double (z)));
8610 else if (SCM_COMPLEXP (z))
8611 {
8612 double v, w;
8613 v = SCM_COMPLEX_REAL (z);
8614 w = SCM_COMPLEX_IMAG (z);
8615 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w - 1.0),
8616 scm_c_make_rectangular (v, w + 1.0))),
8617 scm_c_make_rectangular (0, 2));
8618 }
8619 else
fa075d40 8620 return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
ad79736c
AW		 8621 }
8622 else if (scm_is_real (z))
8623 {
8624 if (scm_is_real (y))
8625 return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
8626 else
fa075d40 8627 return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
ad79736c
AW		 8628 }
8629 else
fa075d40 8630 return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
ad79736c
AW		 8631}
8632#undef FUNC_NAME
8633
8634SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
8635 (SCM z),
8636 "Compute the inverse hyperbolic sine of @var{z}.")
8637#define FUNC_NAME s_scm_sys_asinh
8638{
8deddc94
MW		 8639 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8640 return z; /* asinh(exact0) = exact0 */
8641 else if (scm_is_real (z))
ad79736c
AW		 8642 return scm_from_double (asinh (scm_to_double (z)));
8643 else if (scm_is_number (z))
8644 return scm_log (scm_sum (z,
8645 scm_sqrt (scm_sum (scm_product (z, z),
cff5fa33 8646 SCM_INUM1))));
ad79736c 8647 else
fa075d40 8648 return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
ad79736c
AW		 8649}
8650#undef FUNC_NAME
8651
8652SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
8653 (SCM z),
8654 "Compute the inverse hyperbolic cosine of @var{z}.")
8655#define FUNC_NAME s_scm_sys_acosh
8656{
8deddc94
MW		 8657 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
8658 return SCM_INUM0; /* acosh(exact1) = exact0 */
8659 else if (scm_is_real (z) && scm_to_double (z) >= 1.0)
ad79736c
AW		 8660 return scm_from_double (acosh (scm_to_double (z)));
8661 else if (scm_is_number (z))
8662 return scm_log (scm_sum (z,
8663 scm_sqrt (scm_difference (scm_product (z, z),
cff5fa33 8664 SCM_INUM1))));
ad79736c 8665 else
fa075d40 8666 return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
ad79736c
AW		 8667}
8668#undef FUNC_NAME
8669
8670SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
8671 (SCM z),
8672 "Compute the inverse hyperbolic tangent of @var{z}.")
8673#define FUNC_NAME s_scm_sys_atanh
8674{
8deddc94
MW		 8675 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8676 return z; /* atanh(exact0) = exact0 */
8677 else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
ad79736c
AW		 8678 return scm_from_double (atanh (scm_to_double (z)));
8679 else if (scm_is_number (z))
cff5fa33
MW		 8680 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z),
8681 scm_difference (SCM_INUM1, z))),
ad79736c
AW		 8682 SCM_I_MAKINUM (2));
8683 else
fa075d40 8684 return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
0f2d19dd 8685}
1bbd0b84 8686#undef FUNC_NAME
0f2d19dd 8687
8507ec80
MV		 8688SCM
8689scm_c_make_rectangular (double re, double im)
8690{
c7218482 8691 SCM z;
03604fcf 8692
21041372 8693 z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
c7218482
MW		 8694 "complex"));
8695 SCM_SET_CELL_TYPE (z, scm_tc16_complex);
8696 SCM_COMPLEX_REAL (z) = re;
8697 SCM_COMPLEX_IMAG (z) = im;
8698 return z;
8507ec80 8699}
0f2d19dd 8700
a1ec6916 8701SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
a2c25234 8702 (SCM real_part, SCM imaginary_part),
b7e64f8b
BT		 8703 "Return a complex number constructed of the given @var{real_part} "
8704 "and @var{imaginary_part} parts.")
1bbd0b84 8705#define FUNC_NAME s_scm_make_rectangular
0f2d19dd 8706{
ad79736c
AW		 8707 SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
8708 SCM_ARG1, FUNC_NAME, "real");
8709 SCM_ASSERT_TYPE (scm_is_real (imaginary_part), imaginary_part,
8710 SCM_ARG2, FUNC_NAME, "real");
c7218482
MW		 8711
8712 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8713 if (scm_is_eq (imaginary_part, SCM_INUM0))
8714 return real_part;
8715 else
8716 return scm_c_make_rectangular (scm_to_double (real_part),
8717 scm_to_double (imaginary_part));
0f2d19dd 8718}
1bbd0b84 8719#undef FUNC_NAME
0f2d19dd 8720
8507ec80
MV		 8721SCM
8722scm_c_make_polar (double mag, double ang)
8723{
8724 double s, c;
5e647d08
LC		 8725
8726 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8727 use it on Glibc-based systems that have it (it's a GNU extension). See
8728 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8729 details. */
8730#if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8507ec80
MV		 8731 sincos (ang, &s, &c);
8732#else
8733 s = sin (ang);
8734 c = cos (ang);
8735#endif
9d427b2c
MW		 8736
8737 /* If s and c are NaNs, this indicates that the angle is a NaN,
8738 infinite, or perhaps simply too large to determine its value
8739 mod 2*pi. However, we know something that the floating-point
8740 implementation doesn't know: We know that s and c are finite.
8741 Therefore, if the magnitude is zero, return a complex zero.
8742
8743 The reason we check for the NaNs instead of using this case
8744 whenever mag == 0.0 is because when the angle is known, we'd
8745 like to return the correct kind of non-real complex zero:
8746 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8747 on which quadrant the angle is in.
8748 */
8749 if (SCM_UNLIKELY (isnan(s)) && isnan(c) && (mag == 0.0))
8750 return scm_c_make_rectangular (0.0, 0.0);
8751 else
8752 return scm_c_make_rectangular (mag * c, mag * s);
8507ec80 8753}
0f2d19dd 8754
a1ec6916 8755SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
c7218482
MW		 8756 (SCM mag, SCM ang),
8757 "Return the complex number @var{mag} * e^(i * @var{ang}).")
1bbd0b84 8758#define FUNC_NAME s_scm_make_polar
0f2d19dd 8759{
c7218482
MW		 8760 SCM_ASSERT_TYPE (scm_is_real (mag), mag, SCM_ARG1, FUNC_NAME, "real");
8761 SCM_ASSERT_TYPE (scm_is_real (ang), ang, SCM_ARG2, FUNC_NAME, "real");
8762
8763 /* If mag is exact0, return exact0 */
8764 if (scm_is_eq (mag, SCM_INUM0))
8765 return SCM_INUM0;
8766 /* Return a real if ang is exact0 */
8767 else if (scm_is_eq (ang, SCM_INUM0))
8768 return mag;
8769 else
8770 return scm_c_make_polar (scm_to_double (mag), scm_to_double (ang));
0f2d19dd 8771}
1bbd0b84 8772#undef FUNC_NAME
0f2d19dd
JB		 8773
8774
2519490c
MW		 8775SCM_PRIMITIVE_GENERIC (scm_real_part, "real-part", 1, 0, 0,
8776 (SCM z),
8777 "Return the real part of the number @var{z}.")
8778#define FUNC_NAME s_scm_real_part
0f2d19dd 8779{
2519490c 8780 if (SCM_COMPLEXP (z))
55f26379 8781 return scm_from_double (SCM_COMPLEX_REAL (z));
2519490c 8782 else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
2fa2d879 8783 return z;
0aacf84e 8784 else
fa075d40 8785 return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
0f2d19dd 8786}
2519490c 8787#undef FUNC_NAME
0f2d19dd
JB		 8788
8789
2519490c
MW		 8790SCM_PRIMITIVE_GENERIC (scm_imag_part, "imag-part", 1, 0, 0,
8791 (SCM z),
8792 "Return the imaginary part of the number @var{z}.")
8793#define FUNC_NAME s_scm_imag_part
0f2d19dd 8794{
2519490c
MW		 8795 if (SCM_COMPLEXP (z))
8796 return scm_from_double (SCM_COMPLEX_IMAG (z));
c7218482 8797 else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
f92e85f7 8798 return SCM_INUM0;
0aacf84e 8799 else
fa075d40 8800 return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
0f2d19dd 8801}
2519490c 8802#undef FUNC_NAME
0f2d19dd 8803
2519490c
MW		 8804SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0,
8805 (SCM z),
8806 "Return the numerator of the number @var{z}.")
8807#define FUNC_NAME s_scm_numerator
f92e85f7 8808{
2519490c 8809 if (SCM_I_INUMP (z) || SCM_BIGP (z))
f92e85f7
MV		 8810 return z;
8811 else if (SCM_FRACTIONP (z))
e2bf3b19 8812 return SCM_FRACTION_NUMERATOR (z);
f92e85f7
MV		 8813 else if (SCM_REALP (z))
8814 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
8815 else
fa075d40 8816 return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
f92e85f7 8817}
2519490c 8818#undef FUNC_NAME
f92e85f7
MV		 8819
8820
2519490c
MW		 8821SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0,
8822 (SCM z),
8823 "Return the denominator of the number @var{z}.")
8824#define FUNC_NAME s_scm_denominator
f92e85f7 8825{
2519490c 8826 if (SCM_I_INUMP (z) || SCM_BIGP (z))
cff5fa33 8827 return SCM_INUM1;
f92e85f7 8828 else if (SCM_FRACTIONP (z))
e2bf3b19 8829 return SCM_FRACTION_DENOMINATOR (z);
f92e85f7
MV		 8830 else if (SCM_REALP (z))
8831 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
8832 else
fa075d40
AW		 8833 return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
8834 s_scm_denominator);
f92e85f7 8835}
2519490c 8836#undef FUNC_NAME
0f2d19dd 8837
2519490c
MW		 8838
8839SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0,
8840 (SCM z),
8841 "Return the magnitude of the number @var{z}. This is the same as\n"
8842 "@code{abs} for real arguments, but also allows complex numbers.")
8843#define FUNC_NAME s_scm_magnitude
0f2d19dd 8844{
e11e83f3 8845 if (SCM_I_INUMP (z))
0aacf84e 8846 {
e25f3727 8847 scm_t_inum zz = SCM_I_INUM (z);
0aacf84e
MD		 8848 if (zz >= 0)
8849 return z;
8850 else if (SCM_POSFIXABLE (-zz))
d956fa6f 8851 return SCM_I_MAKINUM (-zz);
0aacf84e 8852 else
e25f3727 8853 return scm_i_inum2big (-zz);
5986c47d 8854 }
0aacf84e
MD		 8855 else if (SCM_BIGP (z))
8856 {
8857 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
8858 scm_remember_upto_here_1 (z);
8859 if (sgn < 0)
8860 return scm_i_clonebig (z, 0);
8861 else
8862 return z;
5986c47d 8863 }
0aacf84e 8864 else if (SCM_REALP (z))
55f26379 8865 return scm_from_double (fabs (SCM_REAL_VALUE (z)));
0aacf84e 8866 else if (SCM_COMPLEXP (z))
55f26379 8867 return scm_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
f92e85f7
MV		 8868 else if (SCM_FRACTIONP (z))
8869 {
73e4de09 8870 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
f92e85f7 8871 return z;
cba42c93 8872 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
f92e85f7
MV		 8873 SCM_FRACTION_DENOMINATOR (z));
8874 }
0aacf84e 8875 else
fa075d40
AW		 8876 return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
8877 s_scm_magnitude);
0f2d19dd 8878}
2519490c 8879#undef FUNC_NAME
0f2d19dd
JB		 8880
8881
2519490c
MW		 8882SCM_PRIMITIVE_GENERIC (scm_angle, "angle", 1, 0, 0,
8883 (SCM z),
8884 "Return the angle of the complex number @var{z}.")
8885#define FUNC_NAME s_scm_angle
0f2d19dd 8886{
c8ae173e 8887 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
e7efe8e7 8888 flo0 to save allocating a new flonum with scm_from_double each time.
c8ae173e
KR		 8889 But if atan2 follows the floating point rounding mode, then the value
8890 is not a constant. Maybe it'd be close enough though. */
e11e83f3 8891 if (SCM_I_INUMP (z))
0aacf84e 8892 {
e11e83f3 8893 if (SCM_I_INUM (z) >= 0)
e7efe8e7 8894 return flo0;
0aacf84e 8895 else
55f26379 8896 return scm_from_double (atan2 (0.0, -1.0));
f872b822 8897 }
0aacf84e
MD		 8898 else if (SCM_BIGP (z))
8899 {
8900 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
8901 scm_remember_upto_here_1 (z);
8902 if (sgn < 0)
55f26379 8903 return scm_from_double (atan2 (0.0, -1.0));
0aacf84e 8904 else
e7efe8e7 8905 return flo0;
0f2d19dd 8906 }
0aacf84e 8907 else if (SCM_REALP (z))
c8ae173e
KR		 8908 {
8909 if (SCM_REAL_VALUE (z) >= 0)
e7efe8e7 8910 return flo0;
c8ae173e 8911 else
55f26379 8912 return scm_from_double (atan2 (0.0, -1.0));
c8ae173e 8913 }
0aacf84e 8914 else if (SCM_COMPLEXP (z))
55f26379 8915 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
f92e85f7
MV		 8916 else if (SCM_FRACTIONP (z))
8917 {
73e4de09 8918 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
e7efe8e7 8919 return flo0;
55f26379 8920 else return scm_from_double (atan2 (0.0, -1.0));
f92e85f7 8921 }
0aacf84e 8922 else
fa075d40 8923 return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
0f2d19dd 8924}
2519490c 8925#undef FUNC_NAME
0f2d19dd
JB		 8926
8927
2519490c
MW		 8928SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact, "exact->inexact", 1, 0, 0,
8929 (SCM z),
8930 "Convert the number @var{z} to its inexact representation.\n")
8931#define FUNC_NAME s_scm_exact_to_inexact
3c9a524f 8932{
e11e83f3 8933 if (SCM_I_INUMP (z))
55f26379 8934 return scm_from_double ((double) SCM_I_INUM (z));
3c9a524f 8935 else if (SCM_BIGP (z))
55f26379 8936 return scm_from_double (scm_i_big2dbl (z));
f92e85f7 8937 else if (SCM_FRACTIONP (z))
55f26379 8938 return scm_from_double (scm_i_fraction2double (z));
3c9a524f
DH		 8939 else if (SCM_INEXACTP (z))
8940 return z;
8941 else
fa075d40
AW		 8942 return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
8943 s_scm_exact_to_inexact);
3c9a524f 8944}
2519490c 8945#undef FUNC_NAME
3c9a524f
DH		 8946
8947
2519490c
MW		 8948SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
8949 (SCM z),
8950 "Return an exact number that is numerically closest to @var{z}.")
1bbd0b84 8951#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 8952{
c7218482 8953 if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
f872b822 8954 return z;
c7218482 8955 else
0aacf84e 8956 {
c7218482
MW		 8957 double val;
8958
8959 if (SCM_REALP (z))
8960 val = SCM_REAL_VALUE (z);
8961 else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
8962 val = SCM_COMPLEX_REAL (z);
8963 else
fa075d40
AW		 8964 return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
8965 s_scm_inexact_to_exact);
c7218482
MW		 8966
8967 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val)))
f92e85f7 8968 SCM_OUT_OF_RANGE (1, z);
2be24db4 8969 else
f92e85f7
MV		 8970 {
8971 mpq_t frac;
8972 SCM q;
8973
8974 mpq_init (frac);
c7218482 8975 mpq_set_d (frac, val);
cba42c93 8976 q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
c7218482 8977 scm_i_mpz2num (mpq_denref (frac)));
f92e85f7 8978
cba42c93 8979 /* When scm_i_make_ratio throws, we leak the memory allocated
f92e85f7
MV		 8980 for frac...
8981 */
8982 mpq_clear (frac);
8983 return q;
8984 }
c2ff8ab0 8985 }
0f2d19dd 8986}
1bbd0b84 8987#undef FUNC_NAME
0f2d19dd 8988
f92e85f7 8989SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
76dae881
NJ		 8990 (SCM x, SCM eps),
8991 "Returns the @emph{simplest} rational number differing\n"
8992 "from @var{x} by no more than @var{eps}.\n"
8993 "\n"
8994 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8995 "exact result when both its arguments are exact. Thus, you might need\n"
8996 "to use @code{inexact->exact} on the arguments.\n"
8997 "\n"
8998 "@lisp\n"
8999 "(rationalize (inexact->exact 1.2) 1/100)\n"
9000 "@result{} 6/5\n"
9001 "@end lisp")
f92e85f7
MV		 9002#define FUNC_NAME s_scm_rationalize
9003{
605f6980
MW		 9004 SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
9005 SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real");
9006 eps = scm_abs (eps);
9007 if (scm_is_false (scm_positive_p (eps)))
9008 {
9009 /* eps is either zero or a NaN */
9010 if (scm_is_true (scm_nan_p (eps)))
9011 return scm_nan ();
9012 else if (SCM_INEXACTP (eps))
9013 return scm_exact_to_inexact (x);
9014 else
9015 return x;
9016 }
9017 else if (scm_is_false (scm_finite_p (eps)))
9018 {
9019 if (scm_is_true (scm_finite_p (x)))
9020 return flo0;
9021 else
9022 return scm_nan ();
9023 }
9024 else if (scm_is_false (scm_finite_p (x))) /* checks for both inf and nan */
f92e85f7 9025 return x;
605f6980
MW		 9026 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x, eps)),
9027 scm_ceiling (scm_difference (x, eps)))))
9028 {
9029 /* There's an integer within range; we want the one closest to zero */
9030 if (scm_is_false (scm_less_p (eps, scm_abs (x))))
9031 {
9032 /* zero is within range */
9033 if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
9034 return flo0;
9035 else
9036 return SCM_INUM0;
9037 }
9038 else if (scm_is_true (scm_positive_p (x)))
9039 return scm_ceiling (scm_difference (x, eps));
9040 else
9041 return scm_floor (scm_sum (x, eps));
9042 }
9043 else
f92e85f7
MV		 9044 {
9045 /* Use continued fractions to find closest ratio. All
9046 arithmetic is done with exact numbers.
9047 */
9048
9049 SCM ex = scm_inexact_to_exact (x);
9050 SCM int_part = scm_floor (ex);
cff5fa33
MW		 9051 SCM tt = SCM_INUM1;
9052 SCM a1 = SCM_INUM0, a2 = SCM_INUM1, a = SCM_INUM0;
9053 SCM b1 = SCM_INUM1, b2 = SCM_INUM0, b = SCM_INUM0;
f92e85f7
MV		 9054 SCM rx;
9055 int i = 0;
9056
f92e85f7
MV		 9057 ex = scm_difference (ex, int_part); /* x = x-int_part */
9058 rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
9059
9060 /* We stop after a million iterations just to be absolutely sure
9061 that we don't go into an infinite loop. The process normally
9062 converges after less than a dozen iterations.
9063 */
9064
f92e85f7
MV		 9065 while (++i < 1000000)
9066 {
9067 a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
9068 b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
73e4de09
MV		 9069 if (scm_is_false (scm_zero_p (b)) && /* b != 0 */
9070 scm_is_false
f92e85f7 9071 (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
76dae881 9072 eps))) /* abs(x-a/b) <= eps */
02164269
MV		 9073 {
9074 SCM res = scm_sum (int_part, scm_divide (a, b));
605f6980 9075 if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
02164269
MV		 9076 return scm_exact_to_inexact (res);
9077 else
9078 return res;
9079 }
f92e85f7
MV		 9080 rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
9081 SCM_UNDEFINED);
9082 tt = scm_floor (rx); /* tt = floor (rx) */
9083 a2 = a1;
9084 b2 = b1;
9085 a1 = a;
9086 b1 = b;
9087 }
9088 scm_num_overflow (s_scm_rationalize);
9089 }
f92e85f7
MV		 9090}
9091#undef FUNC_NAME
9092
73e4de09
MV		 9093/* conversion functions */
9094
9095int
9096scm_is_integer (SCM val)
9097{
9098 return scm_is_true (scm_integer_p (val));
9099}
9100
9101int
9102scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
9103{
e11e83f3 9104 if (SCM_I_INUMP (val))
73e4de09 9105 {
e11e83f3 9106 scm_t_signed_bits n = SCM_I_INUM (val);
73e4de09
MV		 9107 return n >= min && n <= max;
9108 }
9109 else if (SCM_BIGP (val))
9110 {
9111 if (min >= SCM_MOST_NEGATIVE_FIXNUM && max <= SCM_MOST_POSITIVE_FIXNUM)
9112 return 0;
9113 else if (min >= LONG_MIN && max <= LONG_MAX)
d956fa6f
MV		 9114 {
9115 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
9116 {
9117 long n = mpz_get_si (SCM_I_BIG_MPZ (val));
9118 return n >= min && n <= max;
9119 }
9120 else
9121 return 0;
9122 }
73e4de09
MV		 9123 else
9124 {
d956fa6f
MV		 9125 scm_t_intmax n;
9126 size_t count;
73e4de09 9127
d956fa6f
MV		 9128 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
9129 > CHAR_BIT*sizeof (scm_t_uintmax))
9130 return 0;
9131
9132 mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
9133 SCM_I_BIG_MPZ (val));
73e4de09 9134
d956fa6f 9135 if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
73e4de09 9136 {
d956fa6f
MV		 9137 if (n < 0)
9138 return 0;
73e4de09 9139 }
73e4de09
MV		 9140 else
9141 {
d956fa6f
MV		 9142 n = -n;
9143 if (n >= 0)
9144 return 0;
73e4de09 9145 }
d956fa6f
MV		 9146
9147 return n >= min && n <= max;
73e4de09
MV		 9148 }
9149 }
73e4de09
MV		 9150 else
9151 return 0;
9152}
9153
9154int
9155scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max)
9156{
e11e83f3 9157 if (SCM_I_INUMP (val))
73e4de09 9158 {
e11e83f3 9159 scm_t_signed_bits n = SCM_I_INUM (val);
73e4de09
MV		 9160 return n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max;
9161 }
9162 else if (SCM_BIGP (val))
9163 {
9164 if (max <= SCM_MOST_POSITIVE_FIXNUM)
9165 return 0;
9166 else if (max <= ULONG_MAX)
d956fa6f
MV		 9167 {
9168 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val)))
9169 {
9170 unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val));
9171 return n >= min && n <= max;
9172 }
9173 else
9174 return 0;
9175 }
73e4de09
MV		 9176 else
9177 {
d956fa6f
MV		 9178 scm_t_uintmax n;
9179 size_t count;
73e4de09 9180
d956fa6f
MV		 9181 if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0)
9182 return 0;
73e4de09 9183
d956fa6f
MV		 9184 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
9185 > CHAR_BIT*sizeof (scm_t_uintmax))
73e4de09 9186 return 0;
d956fa6f
MV		 9187
9188 mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
9189 SCM_I_BIG_MPZ (val));
73e4de09 9190
d956fa6f 9191 return n >= min && n <= max;
73e4de09
MV		 9192 }
9193 }
73e4de09
MV		 9194 else
9195 return 0;
9196}
9197
1713d319
MV		 9198static void
9199scm_i_range_error (SCM bad_val, SCM min, SCM max)
9200{
9201 scm_error (scm_out_of_range_key,
9202 NULL,
9203 "Value out of range ~S to ~S: ~S",
9204 scm_list_3 (min, max, bad_val),
9205 scm_list_1 (bad_val));
9206}
9207
bfd7932e
MV		 9208#define TYPE scm_t_intmax
9209#define TYPE_MIN min
9210#define TYPE_MAX max
9211#define SIZEOF_TYPE 0
9212#define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9213#define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9214#include "libguile/conv-integer.i.c"
9215
9216#define TYPE scm_t_uintmax
9217#define TYPE_MIN min
9218#define TYPE_MAX max
9219#define SIZEOF_TYPE 0
9220#define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9221#define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9222#include "libguile/conv-uinteger.i.c"
9223
9224#define TYPE scm_t_int8
9225#define TYPE_MIN SCM_T_INT8_MIN
9226#define TYPE_MAX SCM_T_INT8_MAX
9227#define SIZEOF_TYPE 1
9228#define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9229#define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9230#include "libguile/conv-integer.i.c"
9231
9232#define TYPE scm_t_uint8
9233#define TYPE_MIN 0
9234#define TYPE_MAX SCM_T_UINT8_MAX
9235#define SIZEOF_TYPE 1
9236#define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9237#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9238#include "libguile/conv-uinteger.i.c"
9239
9240#define TYPE scm_t_int16
9241#define TYPE_MIN SCM_T_INT16_MIN
9242#define TYPE_MAX SCM_T_INT16_MAX
9243#define SIZEOF_TYPE 2
9244#define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9245#define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9246#include "libguile/conv-integer.i.c"
9247
9248#define TYPE scm_t_uint16
9249#define TYPE_MIN 0
9250#define TYPE_MAX SCM_T_UINT16_MAX
9251#define SIZEOF_TYPE 2
9252#define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9253#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9254#include "libguile/conv-uinteger.i.c"
9255
9256#define TYPE scm_t_int32
9257#define TYPE_MIN SCM_T_INT32_MIN
9258#define TYPE_MAX SCM_T_INT32_MAX
9259#define SIZEOF_TYPE 4
9260#define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9261#define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9262#include "libguile/conv-integer.i.c"
9263
9264#define TYPE scm_t_uint32
9265#define TYPE_MIN 0
9266#define TYPE_MAX SCM_T_UINT32_MAX
9267#define SIZEOF_TYPE 4
9268#define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9269#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9270#include "libguile/conv-uinteger.i.c"
9271
904a78f1
MG		 9272#define TYPE scm_t_wchar
9273#define TYPE_MIN (scm_t_int32)-1
9274#define TYPE_MAX (scm_t_int32)0x10ffff
9275#define SIZEOF_TYPE 4
9276#define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9277#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9278#include "libguile/conv-integer.i.c"
9279
bfd7932e
MV		 9280#define TYPE scm_t_int64
9281#define TYPE_MIN SCM_T_INT64_MIN
9282#define TYPE_MAX SCM_T_INT64_MAX
9283#define SIZEOF_TYPE 8
9284#define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9285#define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9286#include "libguile/conv-integer.i.c"
9287
9288#define TYPE scm_t_uint64
9289#define TYPE_MIN 0
9290#define TYPE_MAX SCM_T_UINT64_MAX
9291#define SIZEOF_TYPE 8
9292#define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9293#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9294#include "libguile/conv-uinteger.i.c"
73e4de09 9295
cd036260
MV		 9296void
9297scm_to_mpz (SCM val, mpz_t rop)
9298{
9299 if (SCM_I_INUMP (val))
9300 mpz_set_si (rop, SCM_I_INUM (val));
9301 else if (SCM_BIGP (val))
9302 mpz_set (rop, SCM_I_BIG_MPZ (val));
9303 else
9304 scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
9305}
9306
9307SCM
9308scm_from_mpz (mpz_t val)
9309{
9310 return scm_i_mpz2num (val);
9311}
9312
73e4de09
MV		 9313int
9314scm_is_real (SCM val)
9315{
9316 return scm_is_true (scm_real_p (val));
9317}
9318
55f26379
MV		 9319int
9320scm_is_rational (SCM val)
9321{
9322 return scm_is_true (scm_rational_p (val));
9323}
9324
73e4de09
MV		 9325double
9326scm_to_double (SCM val)
9327{
55f26379
MV		 9328 if (SCM_I_INUMP (val))
9329 return SCM_I_INUM (val);
9330 else if (SCM_BIGP (val))
9331 return scm_i_big2dbl (val);
9332 else if (SCM_FRACTIONP (val))
9333 return scm_i_fraction2double (val);
9334 else if (SCM_REALP (val))
9335 return SCM_REAL_VALUE (val);
9336 else
7a1aba42 9337 scm_wrong_type_arg_msg (NULL, 0, val, "real number");
73e4de09
MV		 9338}
9339
9340SCM
9341scm_from_double (double val)
9342{
978c52d1
LC		 9343 SCM z;
9344
21041372 9345 z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
978c52d1
LC		 9346
9347 SCM_SET_CELL_TYPE (z, scm_tc16_real);
55f26379 9348 SCM_REAL_VALUE (z) = val;
978c52d1 9349
55f26379 9350 return z;
73e4de09
MV		 9351}
9352
8507ec80
MV		 9353int
9354scm_is_complex (SCM val)
9355{
9356 return scm_is_true (scm_complex_p (val));
9357}
9358
9359double
9360scm_c_real_part (SCM z)
9361{
9362 if (SCM_COMPLEXP (z))
9363 return SCM_COMPLEX_REAL (z);
9364 else
9365 {
9366 /* Use the scm_real_part to get proper error checking and
9367 dispatching.
9368 */
9369 return scm_to_double (scm_real_part (z));
9370 }
9371}
9372
9373double
9374scm_c_imag_part (SCM z)
9375{
9376 if (SCM_COMPLEXP (z))
9377 return SCM_COMPLEX_IMAG (z);
9378 else
9379 {
9380 /* Use the scm_imag_part to get proper error checking and
9381 dispatching. The result will almost always be 0.0, but not
9382 always.
9383 */
9384 return scm_to_double (scm_imag_part (z));
9385 }
9386}
9387
9388double
9389scm_c_magnitude (SCM z)
9390{
9391 return scm_to_double (scm_magnitude (z));
9392}
9393
9394double
9395scm_c_angle (SCM z)
9396{
9397 return scm_to_double (scm_angle (z));
9398}
9399
9400int
9401scm_is_number (SCM z)
9402{
9403 return scm_is_true (scm_number_p (z));
9404}
9405
8ab3d8a0 9406
a5f6b751
MW		 9407/* Returns log(x * 2^shift) */
9408static SCM
9409log_of_shifted_double (double x, long shift)
9410{
9411 double ans = log (fabs (x)) + shift * M_LN2;
9412
9413 if (x > 0.0 || double_is_non_negative_zero (x))
9414 return scm_from_double (ans);
9415 else
9416 return scm_c_make_rectangular (ans, M_PI);
9417}
9418
9419/* Returns log(n), for exact integer n of integer-length size */
9420static SCM
9421log_of_exact_integer_with_size (SCM n, long size)
9422{
9423 long shift = size - 2 * scm_dblprec[0];
9424
9425 if (shift > 0)
9426 return log_of_shifted_double
9427 (scm_to_double (scm_ash (n, scm_from_long(-shift))),
9428 shift);
9429 else
9430 return log_of_shifted_double (scm_to_double (n), 0);
9431}
9432
85bdb6ac 9433/* Returns log(n), for exact integer n */
a5f6b751
MW		 9434static SCM
9435log_of_exact_integer (SCM n)
9436{
9437 return log_of_exact_integer_with_size
9438 (n, scm_to_long (scm_integer_length (n)));
9439}
9440
9441/* Returns log(n/d), for exact non-zero integers n and d */
9442static SCM
9443log_of_fraction (SCM n, SCM d)
9444{
9445 long n_size = scm_to_long (scm_integer_length (n));
9446 long d_size = scm_to_long (scm_integer_length (d));
9447
9448 if (abs (n_size - d_size) > 1)
9449 return (scm_difference (log_of_exact_integer_with_size (n, n_size),
9450 log_of_exact_integer_with_size (d, d_size)));
9451 else if (scm_is_false (scm_negative_p (n)))
9452 return scm_from_double
9453 (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d))));
9454 else
9455 return scm_c_make_rectangular
9456 (log1p (scm_to_double (scm_divide2real
9457 (scm_difference (scm_abs (n), d),
9458 d))),
9459 M_PI);
9460}
9461
9462
8ab3d8a0
KR		 9463/* In the following functions we dispatch to the real-arg funcs like log()
9464 when we know the arg is real, instead of just handing everything to
9465 clog() for instance. This is in case clog() doesn't optimize for a
9466 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9467 well use it to go straight to the applicable C func. */
9468
2519490c
MW		 9469SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0,
9470 (SCM z),
9471 "Return the natural logarithm of @var{z}.")
8ab3d8a0
KR		 9472#define FUNC_NAME s_scm_log
9473{
9474 if (SCM_COMPLEXP (z))
9475 {
03976fee
AW		 9476#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9477 && defined (SCM_COMPLEX_VALUE)
8ab3d8a0
KR		 9478 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
9479#else
9480 double re = SCM_COMPLEX_REAL (z);
9481 double im = SCM_COMPLEX_IMAG (z);
9482 return scm_c_make_rectangular (log (hypot (re, im)),
9483 atan2 (im, re));
9484#endif
9485 }
a5f6b751
MW		 9486 else if (SCM_REALP (z))
9487 return log_of_shifted_double (SCM_REAL_VALUE (z), 0);
9488 else if (SCM_I_INUMP (z))
8ab3d8a0 9489 {
a5f6b751
MW		 9490#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9491 if (scm_is_eq (z, SCM_INUM0))
9492 scm_num_overflow (s_scm_log);
9493#endif
9494 return log_of_shifted_double (SCM_I_INUM (z), 0);
8ab3d8a0 9495 }
a5f6b751
MW		 9496 else if (SCM_BIGP (z))
9497 return log_of_exact_integer (z);
9498 else if (SCM_FRACTIONP (z))
9499 return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
9500 SCM_FRACTION_DENOMINATOR (z));
2519490c 9501 else
fa075d40 9502 return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
8ab3d8a0
KR		 9503}
9504#undef FUNC_NAME
9505
9506
2519490c
MW		 9507SCM_PRIMITIVE_GENERIC (scm_log10, "log10", 1, 0, 0,
9508 (SCM z),
9509 "Return the base 10 logarithm of @var{z}.")
8ab3d8a0
KR		 9510#define FUNC_NAME s_scm_log10
9511{
9512 if (SCM_COMPLEXP (z))
9513 {
9514 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9515 clog() and a multiply by M_LOG10E, rather than the fallback
9516 log10+hypot+atan2.) */
f328f862
LC		 9517#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9518 && defined SCM_COMPLEX_VALUE
8ab3d8a0
KR		 9519 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z)));
9520#else
9521 double re = SCM_COMPLEX_REAL (z);
9522 double im = SCM_COMPLEX_IMAG (z);
9523 return scm_c_make_rectangular (log10 (hypot (re, im)),
9524 M_LOG10E * atan2 (im, re));
9525#endif
9526 }
a5f6b751 9527 else if (SCM_REALP (z) || SCM_I_INUMP (z))
8ab3d8a0 9528 {
a5f6b751
MW		 9529#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9530 if (scm_is_eq (z, SCM_INUM0))
9531 scm_num_overflow (s_scm_log10);
9532#endif
9533 {
9534 double re = scm_to_double (z);
9535 double l = log10 (fabs (re));
9536 if (re > 0.0 || double_is_non_negative_zero (re))
9537 return scm_from_double (l);
9538 else
9539 return scm_c_make_rectangular (l, M_LOG10E * M_PI);
9540 }
8ab3d8a0 9541 }
a5f6b751
MW		 9542 else if (SCM_BIGP (z))
9543 return scm_product (flo_log10e, log_of_exact_integer (z));
9544 else if (SCM_FRACTIONP (z))
9545 return scm_product (flo_log10e,
9546 log_of_fraction (SCM_FRACTION_NUMERATOR (z),
9547 SCM_FRACTION_DENOMINATOR (z)));
2519490c 9548 else
fa075d40 9549 return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
8ab3d8a0
KR		 9550}
9551#undef FUNC_NAME
9552
9553
2519490c
MW		 9554SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
9555 (SCM z),
9556 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9557 "base of natural logarithms (2.71828@dots{}).")
8ab3d8a0
KR		 9558#define FUNC_NAME s_scm_exp
9559{
9560 if (SCM_COMPLEXP (z))
9561 {
03976fee
AW		 9562#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9563 && defined (SCM_COMPLEX_VALUE)
8ab3d8a0
KR		 9564 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
9565#else
9566 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
9567 SCM_COMPLEX_IMAG (z));
9568#endif
9569 }
2519490c 9570 else if (SCM_NUMBERP (z))
8ab3d8a0
KR		 9571 {
9572 /* When z is a negative bignum the conversion to double overflows,
9573 giving -infinity, but that's ok, the exp is still 0.0. */
9574 return scm_from_double (exp (scm_to_double (z)));
9575 }
2519490c 9576 else
fa075d40 9577 return scm_wta_dispatch_1 (g_scm_exp, z, 1, s_scm_exp);
8ab3d8a0
KR		 9578}
9579#undef FUNC_NAME
9580
9581
882c8963
MW		 9582SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
9583 (SCM k),
9584 "Return two exact non-negative integers @var{s} and @var{r}\n"
9585 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9586 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9587 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9588 "\n"
9589 "@lisp\n"
9590 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9591 "@end lisp")
9592#define FUNC_NAME s_scm_i_exact_integer_sqrt
9593{
9594 SCM s, r;
9595
9596 scm_exact_integer_sqrt (k, &s, &r);
9597 return scm_values (scm_list_2 (s, r));
9598}
9599#undef FUNC_NAME
9600
9601void
9602scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
9603{
9604 if (SCM_LIKELY (SCM_I_INUMP (k)))
9605 {
9606 scm_t_inum kk = SCM_I_INUM (k);
9607 scm_t_inum uu = kk;
9608 scm_t_inum ss;
9609
9610 if (SCM_LIKELY (kk > 0))
9611 {
9612 do
9613 {
9614 ss = uu;
9615 uu = (ss + kk/ss) / 2;
9616 } while (uu < ss);
9617 *sp = SCM_I_MAKINUM (ss);
9618 *rp = SCM_I_MAKINUM (kk - ss*ss);
9619 }
9620 else if (SCM_LIKELY (kk == 0))
9621 *sp = *rp = SCM_INUM0;
9622 else
9623 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
9624 "exact non-negative integer");
9625 }
9626 else if (SCM_LIKELY (SCM_BIGP (k)))
9627 {
9628 SCM s, r;
9629
9630 if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0)
9631 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
9632 "exact non-negative integer");
9633 s = scm_i_mkbig ();
9634 r = scm_i_mkbig ();
9635 mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k));
9636 scm_remember_upto_here_1 (k);
9637 *sp = scm_i_normbig (s);
9638 *rp = scm_i_normbig (r);
9639 }
9640 else
9641 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
9642 "exact non-negative integer");
9643}
9644
9645
2519490c
MW		 9646SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
9647 (SCM z),
9648 "Return the square root of @var{z}. Of the two possible roots\n"
ffb62a43 9649 "(positive and negative), the one with positive real part\n"
2519490c
MW		 9650 "is returned, or if that's zero then a positive imaginary part.\n"
9651 "Thus,\n"
9652 "\n"
9653 "@example\n"
9654 "(sqrt 9.0) @result{} 3.0\n"
9655 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9656 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9657 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9658 "@end example")
8ab3d8a0
KR		 9659#define FUNC_NAME s_scm_sqrt
9660{
2519490c 9661 if (SCM_COMPLEXP (z))
8ab3d8a0 9662 {
f328f862
LC		 9663#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9664 && defined SCM_COMPLEX_VALUE
2519490c 9665 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z)));
8ab3d8a0 9666#else
2519490c
MW		 9667 double re = SCM_COMPLEX_REAL (z);
9668 double im = SCM_COMPLEX_IMAG (z);
8ab3d8a0
KR		 9669 return scm_c_make_polar (sqrt (hypot (re, im)),
9670 0.5 * atan2 (im, re));
9671#endif
9672 }
2519490c 9673 else if (SCM_NUMBERP (z))
8ab3d8a0 9674 {
2519490c 9675 double xx = scm_to_double (z);
8ab3d8a0
KR		 9676 if (xx < 0)
9677 return scm_c_make_rectangular (0.0, sqrt (-xx));
9678 else
9679 return scm_from_double (sqrt (xx));
9680 }
2519490c 9681 else
fa075d40 9682 return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
8ab3d8a0
KR		 9683}
9684#undef FUNC_NAME
9685
9686
9687
0f2d19dd
JB		 9688void
9689scm_init_numbers ()
0f2d19dd 9690{
0b799eea
MV		 9691 int i;
9692
b57bf272
AW		 9693 if (scm_install_gmp_memory_functions)
9694 mp_set_memory_functions (custom_gmp_malloc,
9695 custom_gmp_realloc,
9696 custom_gmp_free);
9697
713a4259
KR		 9698 mpz_init_set_si (z_negative_one, -1);
9699
a261c0e9
DH		 9700 /* It may be possible to tune the performance of some algorithms by using
9701 * the following constants to avoid the creation of bignums. Please, before
9702 * using these values, remember the two rules of program optimization:
9703 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
86d31dfe 9704 scm_c_define ("most-positive-fixnum",
d956fa6f 9705 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
86d31dfe 9706 scm_c_define ("most-negative-fixnum",
d956fa6f 9707 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
a261c0e9 9708
f3ae5d60
MD		 9709 scm_add_feature ("complex");
9710 scm_add_feature ("inexact");
e7efe8e7 9711 flo0 = scm_from_double (0.0);
a5f6b751 9712 flo_log10e = scm_from_double (M_LOG10E);
0b799eea
MV		 9713
9714 /* determine floating point precision */
55f26379 9715 for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
0b799eea
MV		 9716 {
9717 init_dblprec(&scm_dblprec[i-2],i);
9718 init_fx_radix(fx_per_radix[i-2],i);
9719 }
f872b822 9720#ifdef DBL_DIG
0b799eea 9721 /* hard code precision for base 10 if the preprocessor tells us to... */
f39448c5 9722 scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
0b799eea 9723#endif
1be6b49c 9724
cff5fa33 9725 exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2));
a0599745 9726#include "libguile/numbers.x"
0f2d19dd 9727}
89e00824
ML		 9728
9729/*
9730 Local Variables:
9731 c-file-style: "gnu"
9732 End:
9733*/
Unnamed repository; edit this file 'description' to name the repository.