1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
3 * 2013 Free Software Foundation, Inc.
5 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
6 * and Bellcore. See scm_divide.
9 * This library is free software; you can redistribute it and/or
10 * modify it under the terms of the GNU Lesser General Public License
11 * as published by the Free Software Foundation; either version 3 of
12 * the License, or (at your option) any later version.
14 * This library is distributed in the hope that it will be useful, but
15 * WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * Lesser General Public License for more details.
19 * You should have received a copy of the GNU Lesser General Public
20 * License along with this library; if not, write to the Free Software
21 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 /* General assumptions:
27 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
28 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
29 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
30 * XXX What about infinities? They are equal to their own floor! -mhw
31 * All objects satisfying SCM_FRACTIONP are never an integer.
36 - see if special casing bignums and reals in integer-exponent when
37 possible (to use mpz_pow and mpf_pow_ui) is faster.
39 - look in to better short-circuiting of common cases in
40 integer-expt and elsewhere.
42 - see if direct mpz operations can help in ash and elsewhere.
63 #include "libguile/_scm.h"
64 #include "libguile/feature.h"
65 #include "libguile/ports.h"
66 #include "libguile/root.h"
67 #include "libguile/smob.h"
68 #include "libguile/strings.h"
69 #include "libguile/bdw-gc.h"
71 #include "libguile/validate.h"
72 #include "libguile/numbers.h"
73 #include "libguile/deprecation.h"
75 #include "libguile/eq.h"
77 /* values per glibc, if not already defined */
79 #define M_LOG10E 0.43429448190325182765
82 #define M_LN2 0.69314718055994530942
85 #define M_PI 3.14159265358979323846
88 /* FIXME: We assume that FLT_RADIX is 2 */
89 verify (FLT_RADIX
== 2);
91 typedef scm_t_signed_bits scm_t_inum
;
92 #define scm_from_inum(x) (scm_from_signed_integer (x))
94 /* Tests to see if a C double is neither infinite nor a NaN.
95 TODO: if it's available, use C99's isfinite(x) instead */
96 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
98 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
99 of the infinity, but other platforms return a boolean only. */
100 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
101 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
103 /* Test an inum to see if it can be converted to a double without loss
104 of precision. Note that this will sometimes return 0 even when 1
105 could have been returned, e.g. for large powers of 2. It is designed
106 to be a fast check to optimize common cases. */
107 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
108 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
109 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
111 #if ! HAVE_DECL_MPZ_INITS
113 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
115 #define VARARG_MPZ_ITERATOR(func) \
117 func ## s (mpz_t x, ...) \
125 x = va_arg (ap, mpz_ptr); \
130 VARARG_MPZ_ITERATOR (mpz_init
)
131 VARARG_MPZ_ITERATOR (mpz_clear
)
138 Wonder if this might be faster for some of our code? A switch on
139 the numtag would jump directly to the right case, and the
140 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
142 #define SCM_I_NUMTAG_NOTNUM 0
143 #define SCM_I_NUMTAG_INUM 1
144 #define SCM_I_NUMTAG_BIG scm_tc16_big
145 #define SCM_I_NUMTAG_REAL scm_tc16_real
146 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
147 #define SCM_I_NUMTAG(x) \
148 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
149 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
150 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
151 : SCM_I_NUMTAG_NOTNUM)))
153 /* the macro above will not work as is with fractions */
156 /* Default to 1, because as we used to hard-code `free' as the
157 deallocator, we know that overriding these functions with
158 instrumented `malloc' / `free' is OK. */
159 int scm_install_gmp_memory_functions
= 1;
161 static SCM exactly_one_half
;
162 static SCM flo_log10e
;
164 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
166 /* FLOBUFLEN is the maximum number of characters neccessary for the
167 * printed or scm_string representation of an inexact number.
169 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
172 #if !defined (HAVE_ASINH)
173 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
175 #if !defined (HAVE_ACOSH)
176 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
178 #if !defined (HAVE_ATANH)
179 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
182 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
183 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
184 in March 2006), mpz_cmp_d now handles infinities properly. */
186 #define xmpz_cmp_d(z, d) \
187 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
189 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
193 #if defined (GUILE_I)
194 #if defined HAVE_COMPLEX_DOUBLE
196 /* For an SCM object Z which is a complex number (ie. satisfies
197 SCM_COMPLEXP), return its value as a C level "complex double". */
198 #define SCM_COMPLEX_VALUE(z) \
199 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
201 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
203 /* Convert a C "complex double" to an SCM value. */
205 scm_from_complex_double (complex double z
)
207 return scm_c_make_rectangular (creal (z
), cimag (z
));
210 #endif /* HAVE_COMPLEX_DOUBLE */
215 static mpz_t z_negative_one
;
219 /* Clear the `mpz_t' embedded in bignum PTR. */
221 finalize_bignum (void *ptr
, void *data
)
225 bignum
= PTR2SCM (ptr
);
226 mpz_clear (SCM_I_BIG_MPZ (bignum
));
229 /* The next three functions (custom_libgmp_*) are passed to
230 mp_set_memory_functions (in GMP) so that memory used by the digits
231 themselves is known to the garbage collector. This is needed so
232 that GC will be run at appropriate times. Otherwise, a program which
233 creates many large bignums would malloc a huge amount of memory
234 before the GC runs. */
236 custom_gmp_malloc (size_t alloc_size
)
238 return scm_malloc (alloc_size
);
242 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
244 return scm_realloc (old_ptr
, new_size
);
248 custom_gmp_free (void *ptr
, size_t size
)
254 /* Return a new uninitialized bignum. */
260 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
261 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
265 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
274 /* Return a newly created bignum. */
275 SCM z
= make_bignum ();
276 mpz_init (SCM_I_BIG_MPZ (z
));
281 scm_i_inum2big (scm_t_inum x
)
283 /* Return a newly created bignum initialized to X. */
284 SCM z
= make_bignum ();
285 #if SIZEOF_VOID_P == SIZEOF_LONG
286 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
288 /* Note that in this case, you'll also have to check all mpz_*_ui and
289 mpz_*_si invocations in Guile. */
290 #error creation of mpz not implemented for this inum size
296 scm_i_long2big (long x
)
298 /* Return a newly created bignum initialized to X. */
299 SCM z
= make_bignum ();
300 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
305 scm_i_ulong2big (unsigned long x
)
307 /* Return a newly created bignum initialized to X. */
308 SCM z
= make_bignum ();
309 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
314 scm_i_clonebig (SCM src_big
, int same_sign_p
)
316 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
317 SCM z
= make_bignum ();
318 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
320 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
325 scm_i_bigcmp (SCM x
, SCM y
)
327 /* Return neg if x < y, pos if x > y, and 0 if x == y */
328 /* presume we already know x and y are bignums */
329 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
330 scm_remember_upto_here_2 (x
, y
);
335 scm_i_dbl2big (double d
)
337 /* results are only defined if d is an integer */
338 SCM z
= make_bignum ();
339 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
343 /* Convert a integer in double representation to a SCM number. */
346 scm_i_dbl2num (double u
)
348 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
349 powers of 2, so there's no rounding when making "double" values
350 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
351 get rounded on a 64-bit machine, hence the "+1".
353 The use of floor() to force to an integer value ensures we get a
354 "numerically closest" value without depending on how a
355 double->long cast or how mpz_set_d will round. For reference,
356 double->long probably follows the hardware rounding mode,
357 mpz_set_d truncates towards zero. */
359 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
360 representable as a double? */
362 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
363 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
364 return SCM_I_MAKINUM ((scm_t_inum
) u
);
366 return scm_i_dbl2big (u
);
369 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
371 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
372 bignum b into a normalized significand and exponent such that
373 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
374 The return value is the significand rounded to the closest
375 representable double, and the exponent is placed into *expon_p.
376 If b is zero, then the returned exponent and significand are both
380 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
382 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
385 if (bits
> DBL_MANT_DIG
)
387 shift
= bits
- DBL_MANT_DIG
;
388 b
= round_right_shift_exact_integer (b
, shift
);
392 double signif
= frexp (SCM_I_INUM (b
), &expon
);
393 *expon_p
= expon
+ shift
;
400 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
401 scm_remember_upto_here_1 (b
);
402 *expon_p
= expon
+ shift
;
407 /* scm_i_big2dbl() rounds to the closest representable double,
408 in accordance with R5RS exact->inexact. */
410 scm_i_big2dbl (SCM b
)
413 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
414 return ldexp (signif
, expon
);
418 scm_i_normbig (SCM b
)
420 /* convert a big back to a fixnum if it'll fit */
421 /* presume b is a bignum */
422 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
424 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
425 if (SCM_FIXABLE (val
))
426 b
= SCM_I_MAKINUM (val
);
431 static SCM_C_INLINE_KEYWORD SCM
432 scm_i_mpz2num (mpz_t b
)
434 /* convert a mpz number to a SCM number. */
435 if (mpz_fits_slong_p (b
))
437 scm_t_inum val
= mpz_get_si (b
);
438 if (SCM_FIXABLE (val
))
439 return SCM_I_MAKINUM (val
);
443 SCM z
= make_bignum ();
444 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
449 /* Make the ratio NUMERATOR/DENOMINATOR, where:
450 1. NUMERATOR and DENOMINATOR are exact integers
451 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
453 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
455 /* Flip signs so that the denominator is positive. */
456 if (scm_is_false (scm_positive_p (denominator
)))
458 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
459 scm_num_overflow ("make-ratio");
462 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
463 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
467 /* Check for the integer case */
468 if (scm_is_eq (denominator
, SCM_INUM1
))
471 return scm_double_cell (scm_tc16_fraction
,
472 SCM_UNPACK (numerator
),
473 SCM_UNPACK (denominator
), 0);
476 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
478 /* Make the ratio NUMERATOR/DENOMINATOR */
480 scm_i_make_ratio (SCM numerator
, SCM denominator
)
481 #define FUNC_NAME "make-ratio"
483 /* Make sure the arguments are proper */
484 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
485 SCM_WRONG_TYPE_ARG (1, numerator
);
486 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
487 SCM_WRONG_TYPE_ARG (2, denominator
);
490 SCM the_gcd
= scm_gcd (numerator
, denominator
);
491 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
493 /* Reduce to lowest terms */
494 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
495 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
497 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
502 static mpz_t scm_i_divide2double_lo2b
;
504 /* Return the double that is closest to the exact rational N/D, with
505 ties rounded toward even mantissas. N and D must be exact
508 scm_i_divide2double (SCM n
, SCM d
)
511 mpz_t nn
, dd
, lo
, hi
, x
;
514 if (SCM_LIKELY (SCM_I_INUMP (d
)))
518 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n
))
519 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d
))))
520 /* If both N and D can be losslessly converted to doubles, then
521 we can rely on IEEE floating point to do proper rounding much
522 faster than we can. */
523 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
525 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
527 if (scm_is_true (scm_positive_p (n
)))
529 else if (scm_is_true (scm_negative_p (n
)))
535 mpz_init_set_si (dd
, SCM_I_INUM (d
));
538 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
541 mpz_init_set_si (nn
, SCM_I_INUM (n
));
543 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
545 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
549 /* Now we need to find the value of e such that:
552 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
553 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
554 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
557 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
558 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
559 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
561 where: p = DBL_MANT_DIG
562 b = FLT_RADIX (here assumed to be 2)
564 After rounding, the mantissa must be an integer between b^{p-1} and
565 (b^p - 1), except for subnormal numbers. In the inequations [1A]
566 and [1B], the middle expression represents the mantissa *before*
567 rounding, and therefore is bounded by the range of values that will
568 round to a floating-point number with the exponent e. The upper
569 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
570 ties will round up to the next power of b. The lower bound is
571 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
572 this power of b. Here we subtract 1/2b instead of 1/2 because it
573 is in the range of the next smaller exponent, where the
574 representable numbers are closer together by a factor of b.
576 Inequations [2A] and [2B] are derived from [1A] and [1B] by
577 multiplying by 2b, and in [3A] and [3B] we multiply by the
578 denominator of the middle value to obtain integer expressions.
580 In the code below, we refer to the three expressions in [3A] or
581 [3B] as lo, x, and hi. If the number is normalizable, we will
582 achieve the goal: lo <= x < hi */
584 /* Make an initial guess for e */
585 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
586 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
587 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
589 /* Compute the initial values of lo, x, and hi
590 based on the initial guess of e */
591 mpz_inits (lo
, hi
, x
, NULL
);
592 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
593 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
595 mpz_mul_2exp (lo
, lo
, e
);
596 mpz_mul_2exp (hi
, lo
, 1);
598 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
599 (but without making e less then the minimum exponent) */
600 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
602 mpz_mul_2exp (x
, x
, 1);
605 while (mpz_cmp (x
, hi
) >= 0)
607 /* If we ever used lo's value again,
608 we would need to double lo here. */
609 mpz_mul_2exp (hi
, hi
, 1);
613 /* Now compute the rounded mantissa:
614 n / b^e d (if e >= 0)
615 n b^-e / d (if e <= 0) */
621 mpz_mul_2exp (nn
, nn
, -e
);
623 mpz_mul_2exp (dd
, dd
, e
);
625 /* mpz does not directly support rounded right
626 shifts, so we have to do it the hard way.
627 For efficiency, we reuse lo and hi.
628 hi == quotient, lo == remainder */
629 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
631 /* The fractional part of the unrounded mantissa would be
632 remainder/dividend, i.e. lo/dd. So we have a tie if
633 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
634 integer expression 2*lo = dd. Here we do that comparison
635 to decide whether to round up or down. */
636 mpz_mul_2exp (lo
, lo
, 1);
637 cmp
= mpz_cmp (lo
, dd
);
638 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
639 mpz_add_ui (hi
, hi
, 1);
641 result
= ldexp (mpz_get_d (hi
), e
);
645 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
651 scm_i_fraction2double (SCM z
)
653 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
654 SCM_FRACTION_DENOMINATOR (z
));
658 double_is_non_negative_zero (double x
)
660 static double zero
= 0.0;
662 return !memcmp (&x
, &zero
, sizeof(double));
665 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
667 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
669 #define FUNC_NAME s_scm_exact_p
671 if (SCM_INEXACTP (x
))
673 else if (SCM_NUMBERP (x
))
676 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
681 scm_is_exact (SCM val
)
683 return scm_is_true (scm_exact_p (val
));
686 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
688 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
690 #define FUNC_NAME s_scm_inexact_p
692 if (SCM_INEXACTP (x
))
694 else if (SCM_NUMBERP (x
))
697 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
702 scm_is_inexact (SCM val
)
704 return scm_is_true (scm_inexact_p (val
));
707 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
709 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
711 #define FUNC_NAME s_scm_odd_p
715 scm_t_inum val
= SCM_I_INUM (n
);
716 return scm_from_bool ((val
& 1L) != 0);
718 else if (SCM_BIGP (n
))
720 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
721 scm_remember_upto_here_1 (n
);
722 return scm_from_bool (odd_p
);
724 else if (SCM_REALP (n
))
726 double val
= SCM_REAL_VALUE (n
);
727 if (DOUBLE_IS_FINITE (val
))
729 double rem
= fabs (fmod (val
, 2.0));
736 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
741 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
743 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
745 #define FUNC_NAME s_scm_even_p
749 scm_t_inum val
= SCM_I_INUM (n
);
750 return scm_from_bool ((val
& 1L) == 0);
752 else if (SCM_BIGP (n
))
754 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
755 scm_remember_upto_here_1 (n
);
756 return scm_from_bool (even_p
);
758 else if (SCM_REALP (n
))
760 double val
= SCM_REAL_VALUE (n
);
761 if (DOUBLE_IS_FINITE (val
))
763 double rem
= fabs (fmod (val
, 2.0));
770 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
774 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
776 "Return @code{#t} if the real number @var{x} is neither\n"
777 "infinite nor a NaN, @code{#f} otherwise.")
778 #define FUNC_NAME s_scm_finite_p
781 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
782 else if (scm_is_real (x
))
785 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
789 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
791 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
792 "@samp{-inf.0}. Otherwise return @code{#f}.")
793 #define FUNC_NAME s_scm_inf_p
796 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
797 else if (scm_is_real (x
))
800 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
804 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
806 "Return @code{#t} if the real number @var{x} is a NaN,\n"
807 "or @code{#f} otherwise.")
808 #define FUNC_NAME s_scm_nan_p
811 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
812 else if (scm_is_real (x
))
815 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
819 /* Guile's idea of infinity. */
820 static double guile_Inf
;
822 /* Guile's idea of not a number. */
823 static double guile_NaN
;
826 guile_ieee_init (void)
828 /* Some version of gcc on some old version of Linux used to crash when
829 trying to make Inf and NaN. */
832 /* C99 INFINITY, when available.
833 FIXME: The standard allows for INFINITY to be something that overflows
834 at compile time. We ought to have a configure test to check for that
835 before trying to use it. (But in practice we believe this is not a
836 problem on any system guile is likely to target.) */
837 guile_Inf
= INFINITY
;
838 #elif defined HAVE_DINFINITY
840 extern unsigned int DINFINITY
[2];
841 guile_Inf
= (*((double *) (DINFINITY
)));
848 if (guile_Inf
== tmp
)
855 /* C99 NAN, when available */
857 #elif defined HAVE_DQNAN
860 extern unsigned int DQNAN
[2];
861 guile_NaN
= (*((double *)(DQNAN
)));
864 guile_NaN
= guile_Inf
/ guile_Inf
;
868 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
871 #define FUNC_NAME s_scm_inf
873 static int initialized
= 0;
879 return scm_from_double (guile_Inf
);
883 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
886 #define FUNC_NAME s_scm_nan
888 static int initialized
= 0;
894 return scm_from_double (guile_NaN
);
899 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
901 "Return the absolute value of @var{x}.")
902 #define FUNC_NAME s_scm_abs
906 scm_t_inum xx
= SCM_I_INUM (x
);
909 else if (SCM_POSFIXABLE (-xx
))
910 return SCM_I_MAKINUM (-xx
);
912 return scm_i_inum2big (-xx
);
914 else if (SCM_LIKELY (SCM_REALP (x
)))
916 double xx
= SCM_REAL_VALUE (x
);
917 /* If x is a NaN then xx<0 is false so we return x unchanged */
919 return scm_from_double (-xx
);
920 /* Handle signed zeroes properly */
921 else if (SCM_UNLIKELY (xx
== 0.0))
926 else if (SCM_BIGP (x
))
928 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
930 return scm_i_clonebig (x
, 0);
934 else if (SCM_FRACTIONP (x
))
936 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
938 return scm_i_make_ratio_already_reduced
939 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
940 SCM_FRACTION_DENOMINATOR (x
));
943 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
948 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
950 "Return the quotient of the numbers @var{x} and @var{y}.")
951 #define FUNC_NAME s_scm_quotient
953 if (SCM_LIKELY (scm_is_integer (x
)))
955 if (SCM_LIKELY (scm_is_integer (y
)))
956 return scm_truncate_quotient (x
, y
);
958 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
961 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
965 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
967 "Return the remainder of the numbers @var{x} and @var{y}.\n"
969 "(remainder 13 4) @result{} 1\n"
970 "(remainder -13 4) @result{} -1\n"
972 #define FUNC_NAME s_scm_remainder
974 if (SCM_LIKELY (scm_is_integer (x
)))
976 if (SCM_LIKELY (scm_is_integer (y
)))
977 return scm_truncate_remainder (x
, y
);
979 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
982 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
987 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
989 "Return the modulo of the numbers @var{x} and @var{y}.\n"
991 "(modulo 13 4) @result{} 1\n"
992 "(modulo -13 4) @result{} 3\n"
994 #define FUNC_NAME s_scm_modulo
996 if (SCM_LIKELY (scm_is_integer (x
)))
998 if (SCM_LIKELY (scm_is_integer (y
)))
999 return scm_floor_remainder (x
, y
);
1001 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
1004 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1008 /* Return the exact integer q such that n = q*d, for exact integers n
1009 and d, where d is known in advance to divide n evenly (with zero
1010 remainder). For large integers, this can be computed more
1011 efficiently than when the remainder is unknown. */
1013 scm_exact_integer_quotient (SCM n
, SCM d
)
1014 #define FUNC_NAME "exact-integer-quotient"
1016 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1018 scm_t_inum nn
= SCM_I_INUM (n
);
1019 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1021 scm_t_inum dd
= SCM_I_INUM (d
);
1022 if (SCM_UNLIKELY (dd
== 0))
1023 scm_num_overflow ("exact-integer-quotient");
1026 scm_t_inum qq
= nn
/ dd
;
1027 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1028 return SCM_I_MAKINUM (qq
);
1030 return scm_i_inum2big (qq
);
1033 else if (SCM_LIKELY (SCM_BIGP (d
)))
1035 /* n is an inum and d is a bignum. Given that d is known to
1036 divide n evenly, there are only two possibilities: n is 0,
1037 or else n is fixnum-min and d is abs(fixnum-min). */
1041 return SCM_I_MAKINUM (-1);
1044 SCM_WRONG_TYPE_ARG (2, d
);
1046 else if (SCM_LIKELY (SCM_BIGP (n
)))
1048 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1050 scm_t_inum dd
= SCM_I_INUM (d
);
1051 if (SCM_UNLIKELY (dd
== 0))
1052 scm_num_overflow ("exact-integer-quotient");
1053 else if (SCM_UNLIKELY (dd
== 1))
1057 SCM q
= scm_i_mkbig ();
1059 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1062 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1063 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1065 scm_remember_upto_here_1 (n
);
1066 return scm_i_normbig (q
);
1069 else if (SCM_LIKELY (SCM_BIGP (d
)))
1071 SCM q
= scm_i_mkbig ();
1072 mpz_divexact (SCM_I_BIG_MPZ (q
),
1075 scm_remember_upto_here_2 (n
, d
);
1076 return scm_i_normbig (q
);
1079 SCM_WRONG_TYPE_ARG (2, d
);
1082 SCM_WRONG_TYPE_ARG (1, n
);
1086 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1087 two-valued functions. It is called from primitive generics that take
1088 two arguments and return two values, when the core procedure is
1089 unable to handle the given argument types. If there are GOOPS
1090 methods for this primitive generic, it dispatches to GOOPS and, if
1091 successful, expects two values to be returned, which are placed in
1092 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1093 wrong-type-arg exception.
1095 FIXME: This obviously belongs somewhere else, but until we decide on
1096 the right API, it is here as a static function, because it is needed
1097 by the *_divide functions below.
1100 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1101 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1103 if (SCM_UNPACK (gf
))
1104 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
1106 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1109 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1111 "Return the integer @var{q} such that\n"
1112 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1113 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1115 "(euclidean-quotient 123 10) @result{} 12\n"
1116 "(euclidean-quotient 123 -10) @result{} -12\n"
1117 "(euclidean-quotient -123 10) @result{} -13\n"
1118 "(euclidean-quotient -123 -10) @result{} 13\n"
1119 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1120 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1122 #define FUNC_NAME s_scm_euclidean_quotient
1124 if (scm_is_false (scm_negative_p (y
)))
1125 return scm_floor_quotient (x
, y
);
1127 return scm_ceiling_quotient (x
, y
);
1131 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1133 "Return the real number @var{r} such that\n"
1134 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1135 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1136 "for some integer @var{q}.\n"
1138 "(euclidean-remainder 123 10) @result{} 3\n"
1139 "(euclidean-remainder 123 -10) @result{} 3\n"
1140 "(euclidean-remainder -123 10) @result{} 7\n"
1141 "(euclidean-remainder -123 -10) @result{} 7\n"
1142 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1143 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1145 #define FUNC_NAME s_scm_euclidean_remainder
1147 if (scm_is_false (scm_negative_p (y
)))
1148 return scm_floor_remainder (x
, y
);
1150 return scm_ceiling_remainder (x
, y
);
1154 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1156 "Return the integer @var{q} and the real number @var{r}\n"
1157 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1158 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1160 "(euclidean/ 123 10) @result{} 12 and 3\n"
1161 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1162 "(euclidean/ -123 10) @result{} -13 and 7\n"
1163 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1164 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1165 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1167 #define FUNC_NAME s_scm_i_euclidean_divide
1169 if (scm_is_false (scm_negative_p (y
)))
1170 return scm_i_floor_divide (x
, y
);
1172 return scm_i_ceiling_divide (x
, y
);
1177 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1179 if (scm_is_false (scm_negative_p (y
)))
1180 return scm_floor_divide (x
, y
, qp
, rp
);
1182 return scm_ceiling_divide (x
, y
, qp
, rp
);
1185 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1186 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1188 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1190 "Return the floor of @math{@var{x} / @var{y}}.\n"
1192 "(floor-quotient 123 10) @result{} 12\n"
1193 "(floor-quotient 123 -10) @result{} -13\n"
1194 "(floor-quotient -123 10) @result{} -13\n"
1195 "(floor-quotient -123 -10) @result{} 12\n"
1196 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1197 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1199 #define FUNC_NAME s_scm_floor_quotient
1201 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1203 scm_t_inum xx
= SCM_I_INUM (x
);
1204 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1206 scm_t_inum yy
= SCM_I_INUM (y
);
1207 scm_t_inum xx1
= xx
;
1209 if (SCM_LIKELY (yy
> 0))
1211 if (SCM_UNLIKELY (xx
< 0))
1214 else if (SCM_UNLIKELY (yy
== 0))
1215 scm_num_overflow (s_scm_floor_quotient
);
1219 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1220 return SCM_I_MAKINUM (qq
);
1222 return scm_i_inum2big (qq
);
1224 else if (SCM_BIGP (y
))
1226 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1227 scm_remember_upto_here_1 (y
);
1229 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1231 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1233 else if (SCM_REALP (y
))
1234 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1235 else if (SCM_FRACTIONP (y
))
1236 return scm_i_exact_rational_floor_quotient (x
, y
);
1238 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1239 s_scm_floor_quotient
);
1241 else if (SCM_BIGP (x
))
1243 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1245 scm_t_inum yy
= SCM_I_INUM (y
);
1246 if (SCM_UNLIKELY (yy
== 0))
1247 scm_num_overflow (s_scm_floor_quotient
);
1248 else if (SCM_UNLIKELY (yy
== 1))
1252 SCM q
= scm_i_mkbig ();
1254 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1257 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1258 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1260 scm_remember_upto_here_1 (x
);
1261 return scm_i_normbig (q
);
1264 else if (SCM_BIGP (y
))
1266 SCM q
= scm_i_mkbig ();
1267 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1270 scm_remember_upto_here_2 (x
, y
);
1271 return scm_i_normbig (q
);
1273 else if (SCM_REALP (y
))
1274 return scm_i_inexact_floor_quotient
1275 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1276 else if (SCM_FRACTIONP (y
))
1277 return scm_i_exact_rational_floor_quotient (x
, y
);
1279 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1280 s_scm_floor_quotient
);
1282 else if (SCM_REALP (x
))
1284 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1285 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1286 return scm_i_inexact_floor_quotient
1287 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1289 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1290 s_scm_floor_quotient
);
1292 else if (SCM_FRACTIONP (x
))
1295 return scm_i_inexact_floor_quotient
1296 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1297 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1298 return scm_i_exact_rational_floor_quotient (x
, y
);
1300 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1301 s_scm_floor_quotient
);
1304 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1305 s_scm_floor_quotient
);
1310 scm_i_inexact_floor_quotient (double x
, double y
)
1312 if (SCM_UNLIKELY (y
== 0))
1313 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1315 return scm_from_double (floor (x
/ y
));
1319 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1321 return scm_floor_quotient
1322 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1323 scm_product (scm_numerator (y
), scm_denominator (x
)));
1326 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1327 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1329 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1331 "Return the real number @var{r} such that\n"
1332 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1333 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1335 "(floor-remainder 123 10) @result{} 3\n"
1336 "(floor-remainder 123 -10) @result{} -7\n"
1337 "(floor-remainder -123 10) @result{} 7\n"
1338 "(floor-remainder -123 -10) @result{} -3\n"
1339 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1340 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1342 #define FUNC_NAME s_scm_floor_remainder
1344 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1346 scm_t_inum xx
= SCM_I_INUM (x
);
1347 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1349 scm_t_inum yy
= SCM_I_INUM (y
);
1350 if (SCM_UNLIKELY (yy
== 0))
1351 scm_num_overflow (s_scm_floor_remainder
);
1354 scm_t_inum rr
= xx
% yy
;
1355 int needs_adjustment
;
1357 if (SCM_LIKELY (yy
> 0))
1358 needs_adjustment
= (rr
< 0);
1360 needs_adjustment
= (rr
> 0);
1362 if (needs_adjustment
)
1364 return SCM_I_MAKINUM (rr
);
1367 else if (SCM_BIGP (y
))
1369 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1370 scm_remember_upto_here_1 (y
);
1375 SCM r
= scm_i_mkbig ();
1376 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1377 scm_remember_upto_here_1 (y
);
1378 return scm_i_normbig (r
);
1387 SCM r
= scm_i_mkbig ();
1388 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1389 scm_remember_upto_here_1 (y
);
1390 return scm_i_normbig (r
);
1393 else if (SCM_REALP (y
))
1394 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1395 else if (SCM_FRACTIONP (y
))
1396 return scm_i_exact_rational_floor_remainder (x
, y
);
1398 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1399 s_scm_floor_remainder
);
1401 else if (SCM_BIGP (x
))
1403 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1405 scm_t_inum yy
= SCM_I_INUM (y
);
1406 if (SCM_UNLIKELY (yy
== 0))
1407 scm_num_overflow (s_scm_floor_remainder
);
1412 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1414 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1415 scm_remember_upto_here_1 (x
);
1416 return SCM_I_MAKINUM (rr
);
1419 else if (SCM_BIGP (y
))
1421 SCM r
= scm_i_mkbig ();
1422 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1425 scm_remember_upto_here_2 (x
, y
);
1426 return scm_i_normbig (r
);
1428 else if (SCM_REALP (y
))
1429 return scm_i_inexact_floor_remainder
1430 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1431 else if (SCM_FRACTIONP (y
))
1432 return scm_i_exact_rational_floor_remainder (x
, y
);
1434 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1435 s_scm_floor_remainder
);
1437 else if (SCM_REALP (x
))
1439 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1440 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1441 return scm_i_inexact_floor_remainder
1442 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1444 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1445 s_scm_floor_remainder
);
1447 else if (SCM_FRACTIONP (x
))
1450 return scm_i_inexact_floor_remainder
1451 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1452 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1453 return scm_i_exact_rational_floor_remainder (x
, y
);
1455 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1456 s_scm_floor_remainder
);
1459 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1460 s_scm_floor_remainder
);
1465 scm_i_inexact_floor_remainder (double x
, double y
)
1467 /* Although it would be more efficient to use fmod here, we can't
1468 because it would in some cases produce results inconsistent with
1469 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1470 close). In particular, when x is very close to a multiple of y,
1471 then r might be either 0.0 or y, but those two cases must
1472 correspond to different choices of q. If r = 0.0 then q must be
1473 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1474 and remainder chooses the other, it would be bad. */
1475 if (SCM_UNLIKELY (y
== 0))
1476 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1478 return scm_from_double (x
- y
* floor (x
/ y
));
1482 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1484 SCM xd
= scm_denominator (x
);
1485 SCM yd
= scm_denominator (y
);
1486 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1487 scm_product (scm_numerator (y
), xd
));
1488 return scm_divide (r1
, scm_product (xd
, yd
));
1492 static void scm_i_inexact_floor_divide (double x
, double y
,
1494 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1497 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1499 "Return the integer @var{q} and the real number @var{r}\n"
1500 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1501 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1503 "(floor/ 123 10) @result{} 12 and 3\n"
1504 "(floor/ 123 -10) @result{} -13 and -7\n"
1505 "(floor/ -123 10) @result{} -13 and 7\n"
1506 "(floor/ -123 -10) @result{} 12 and -3\n"
1507 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1508 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1510 #define FUNC_NAME s_scm_i_floor_divide
1514 scm_floor_divide(x
, y
, &q
, &r
);
1515 return scm_values (scm_list_2 (q
, r
));
1519 #define s_scm_floor_divide s_scm_i_floor_divide
1520 #define g_scm_floor_divide g_scm_i_floor_divide
1523 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1525 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1527 scm_t_inum xx
= SCM_I_INUM (x
);
1528 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1530 scm_t_inum yy
= SCM_I_INUM (y
);
1531 if (SCM_UNLIKELY (yy
== 0))
1532 scm_num_overflow (s_scm_floor_divide
);
1535 scm_t_inum qq
= xx
/ yy
;
1536 scm_t_inum rr
= xx
% yy
;
1537 int needs_adjustment
;
1539 if (SCM_LIKELY (yy
> 0))
1540 needs_adjustment
= (rr
< 0);
1542 needs_adjustment
= (rr
> 0);
1544 if (needs_adjustment
)
1550 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1551 *qp
= SCM_I_MAKINUM (qq
);
1553 *qp
= scm_i_inum2big (qq
);
1554 *rp
= SCM_I_MAKINUM (rr
);
1558 else if (SCM_BIGP (y
))
1560 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1561 scm_remember_upto_here_1 (y
);
1566 SCM r
= scm_i_mkbig ();
1567 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1568 scm_remember_upto_here_1 (y
);
1569 *qp
= SCM_I_MAKINUM (-1);
1570 *rp
= scm_i_normbig (r
);
1585 SCM r
= scm_i_mkbig ();
1586 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1587 scm_remember_upto_here_1 (y
);
1588 *qp
= SCM_I_MAKINUM (-1);
1589 *rp
= scm_i_normbig (r
);
1593 else if (SCM_REALP (y
))
1594 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1595 else if (SCM_FRACTIONP (y
))
1596 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1598 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1599 s_scm_floor_divide
, qp
, rp
);
1601 else if (SCM_BIGP (x
))
1603 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1605 scm_t_inum yy
= SCM_I_INUM (y
);
1606 if (SCM_UNLIKELY (yy
== 0))
1607 scm_num_overflow (s_scm_floor_divide
);
1610 SCM q
= scm_i_mkbig ();
1611 SCM r
= scm_i_mkbig ();
1613 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1614 SCM_I_BIG_MPZ (x
), yy
);
1617 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1618 SCM_I_BIG_MPZ (x
), -yy
);
1619 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1621 scm_remember_upto_here_1 (x
);
1622 *qp
= scm_i_normbig (q
);
1623 *rp
= scm_i_normbig (r
);
1627 else if (SCM_BIGP (y
))
1629 SCM q
= scm_i_mkbig ();
1630 SCM r
= scm_i_mkbig ();
1631 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1632 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1633 scm_remember_upto_here_2 (x
, y
);
1634 *qp
= scm_i_normbig (q
);
1635 *rp
= scm_i_normbig (r
);
1638 else if (SCM_REALP (y
))
1639 return scm_i_inexact_floor_divide
1640 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1641 else if (SCM_FRACTIONP (y
))
1642 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1644 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1645 s_scm_floor_divide
, qp
, rp
);
1647 else if (SCM_REALP (x
))
1649 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1650 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1651 return scm_i_inexact_floor_divide
1652 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1654 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1655 s_scm_floor_divide
, qp
, rp
);
1657 else if (SCM_FRACTIONP (x
))
1660 return scm_i_inexact_floor_divide
1661 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1662 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1663 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1665 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1666 s_scm_floor_divide
, qp
, rp
);
1669 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1670 s_scm_floor_divide
, qp
, rp
);
1674 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1676 if (SCM_UNLIKELY (y
== 0))
1677 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1680 double q
= floor (x
/ y
);
1681 double r
= x
- q
* y
;
1682 *qp
= scm_from_double (q
);
1683 *rp
= scm_from_double (r
);
1688 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1691 SCM xd
= scm_denominator (x
);
1692 SCM yd
= scm_denominator (y
);
1694 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1695 scm_product (scm_numerator (y
), xd
),
1697 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1700 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1701 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1703 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1705 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1707 "(ceiling-quotient 123 10) @result{} 13\n"
1708 "(ceiling-quotient 123 -10) @result{} -12\n"
1709 "(ceiling-quotient -123 10) @result{} -12\n"
1710 "(ceiling-quotient -123 -10) @result{} 13\n"
1711 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1712 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1714 #define FUNC_NAME s_scm_ceiling_quotient
1716 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1718 scm_t_inum xx
= SCM_I_INUM (x
);
1719 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1721 scm_t_inum yy
= SCM_I_INUM (y
);
1722 if (SCM_UNLIKELY (yy
== 0))
1723 scm_num_overflow (s_scm_ceiling_quotient
);
1726 scm_t_inum xx1
= xx
;
1728 if (SCM_LIKELY (yy
> 0))
1730 if (SCM_LIKELY (xx
>= 0))
1736 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1737 return SCM_I_MAKINUM (qq
);
1739 return scm_i_inum2big (qq
);
1742 else if (SCM_BIGP (y
))
1744 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1745 scm_remember_upto_here_1 (y
);
1746 if (SCM_LIKELY (sign
> 0))
1748 if (SCM_LIKELY (xx
> 0))
1750 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1751 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1752 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1754 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1755 scm_remember_upto_here_1 (y
);
1756 return SCM_I_MAKINUM (-1);
1766 else if (SCM_REALP (y
))
1767 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1768 else if (SCM_FRACTIONP (y
))
1769 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1771 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1772 s_scm_ceiling_quotient
);
1774 else if (SCM_BIGP (x
))
1776 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1778 scm_t_inum yy
= SCM_I_INUM (y
);
1779 if (SCM_UNLIKELY (yy
== 0))
1780 scm_num_overflow (s_scm_ceiling_quotient
);
1781 else if (SCM_UNLIKELY (yy
== 1))
1785 SCM q
= scm_i_mkbig ();
1787 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1790 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1791 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1793 scm_remember_upto_here_1 (x
);
1794 return scm_i_normbig (q
);
1797 else if (SCM_BIGP (y
))
1799 SCM q
= scm_i_mkbig ();
1800 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1803 scm_remember_upto_here_2 (x
, y
);
1804 return scm_i_normbig (q
);
1806 else if (SCM_REALP (y
))
1807 return scm_i_inexact_ceiling_quotient
1808 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1809 else if (SCM_FRACTIONP (y
))
1810 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1812 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1813 s_scm_ceiling_quotient
);
1815 else if (SCM_REALP (x
))
1817 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1818 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1819 return scm_i_inexact_ceiling_quotient
1820 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1822 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1823 s_scm_ceiling_quotient
);
1825 else if (SCM_FRACTIONP (x
))
1828 return scm_i_inexact_ceiling_quotient
1829 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1830 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1831 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1833 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1834 s_scm_ceiling_quotient
);
1837 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1838 s_scm_ceiling_quotient
);
1843 scm_i_inexact_ceiling_quotient (double x
, double y
)
1845 if (SCM_UNLIKELY (y
== 0))
1846 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1848 return scm_from_double (ceil (x
/ y
));
1852 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1854 return scm_ceiling_quotient
1855 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1856 scm_product (scm_numerator (y
), scm_denominator (x
)));
1859 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1860 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1862 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1864 "Return the real number @var{r} such that\n"
1865 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1866 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1868 "(ceiling-remainder 123 10) @result{} -7\n"
1869 "(ceiling-remainder 123 -10) @result{} 3\n"
1870 "(ceiling-remainder -123 10) @result{} -3\n"
1871 "(ceiling-remainder -123 -10) @result{} 7\n"
1872 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1873 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1875 #define FUNC_NAME s_scm_ceiling_remainder
1877 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1879 scm_t_inum xx
= SCM_I_INUM (x
);
1880 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1882 scm_t_inum yy
= SCM_I_INUM (y
);
1883 if (SCM_UNLIKELY (yy
== 0))
1884 scm_num_overflow (s_scm_ceiling_remainder
);
1887 scm_t_inum rr
= xx
% yy
;
1888 int needs_adjustment
;
1890 if (SCM_LIKELY (yy
> 0))
1891 needs_adjustment
= (rr
> 0);
1893 needs_adjustment
= (rr
< 0);
1895 if (needs_adjustment
)
1897 return SCM_I_MAKINUM (rr
);
1900 else if (SCM_BIGP (y
))
1902 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1903 scm_remember_upto_here_1 (y
);
1904 if (SCM_LIKELY (sign
> 0))
1906 if (SCM_LIKELY (xx
> 0))
1908 SCM r
= scm_i_mkbig ();
1909 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1910 scm_remember_upto_here_1 (y
);
1911 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1912 return scm_i_normbig (r
);
1914 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1915 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1916 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1918 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1919 scm_remember_upto_here_1 (y
);
1929 SCM r
= scm_i_mkbig ();
1930 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1931 scm_remember_upto_here_1 (y
);
1932 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1933 return scm_i_normbig (r
);
1936 else if (SCM_REALP (y
))
1937 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1938 else if (SCM_FRACTIONP (y
))
1939 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1941 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1942 s_scm_ceiling_remainder
);
1944 else if (SCM_BIGP (x
))
1946 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1948 scm_t_inum yy
= SCM_I_INUM (y
);
1949 if (SCM_UNLIKELY (yy
== 0))
1950 scm_num_overflow (s_scm_ceiling_remainder
);
1955 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1957 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1958 scm_remember_upto_here_1 (x
);
1959 return SCM_I_MAKINUM (rr
);
1962 else if (SCM_BIGP (y
))
1964 SCM r
= scm_i_mkbig ();
1965 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1968 scm_remember_upto_here_2 (x
, y
);
1969 return scm_i_normbig (r
);
1971 else if (SCM_REALP (y
))
1972 return scm_i_inexact_ceiling_remainder
1973 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1974 else if (SCM_FRACTIONP (y
))
1975 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1977 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1978 s_scm_ceiling_remainder
);
1980 else if (SCM_REALP (x
))
1982 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1983 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1984 return scm_i_inexact_ceiling_remainder
1985 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1987 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1988 s_scm_ceiling_remainder
);
1990 else if (SCM_FRACTIONP (x
))
1993 return scm_i_inexact_ceiling_remainder
1994 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1995 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1996 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1998 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1999 s_scm_ceiling_remainder
);
2002 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
2003 s_scm_ceiling_remainder
);
2008 scm_i_inexact_ceiling_remainder (double x
, double y
)
2010 /* Although it would be more efficient to use fmod here, we can't
2011 because it would in some cases produce results inconsistent with
2012 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2013 close). In particular, when x is very close to a multiple of y,
2014 then r might be either 0.0 or -y, but those two cases must
2015 correspond to different choices of q. If r = 0.0 then q must be
2016 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2017 and remainder chooses the other, it would be bad. */
2018 if (SCM_UNLIKELY (y
== 0))
2019 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2021 return scm_from_double (x
- y
* ceil (x
/ y
));
2025 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2027 SCM xd
= scm_denominator (x
);
2028 SCM yd
= scm_denominator (y
);
2029 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2030 scm_product (scm_numerator (y
), xd
));
2031 return scm_divide (r1
, scm_product (xd
, yd
));
2034 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2036 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2039 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2041 "Return the integer @var{q} and the real number @var{r}\n"
2042 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2043 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2045 "(ceiling/ 123 10) @result{} 13 and -7\n"
2046 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2047 "(ceiling/ -123 10) @result{} -12 and -3\n"
2048 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2049 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2050 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2052 #define FUNC_NAME s_scm_i_ceiling_divide
2056 scm_ceiling_divide(x
, y
, &q
, &r
);
2057 return scm_values (scm_list_2 (q
, r
));
2061 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2062 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2065 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2067 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2069 scm_t_inum xx
= SCM_I_INUM (x
);
2070 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2072 scm_t_inum yy
= SCM_I_INUM (y
);
2073 if (SCM_UNLIKELY (yy
== 0))
2074 scm_num_overflow (s_scm_ceiling_divide
);
2077 scm_t_inum qq
= xx
/ yy
;
2078 scm_t_inum rr
= xx
% yy
;
2079 int needs_adjustment
;
2081 if (SCM_LIKELY (yy
> 0))
2082 needs_adjustment
= (rr
> 0);
2084 needs_adjustment
= (rr
< 0);
2086 if (needs_adjustment
)
2091 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2092 *qp
= SCM_I_MAKINUM (qq
);
2094 *qp
= scm_i_inum2big (qq
);
2095 *rp
= SCM_I_MAKINUM (rr
);
2099 else if (SCM_BIGP (y
))
2101 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2102 scm_remember_upto_here_1 (y
);
2103 if (SCM_LIKELY (sign
> 0))
2105 if (SCM_LIKELY (xx
> 0))
2107 SCM r
= scm_i_mkbig ();
2108 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2109 scm_remember_upto_here_1 (y
);
2110 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2112 *rp
= scm_i_normbig (r
);
2114 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2115 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2116 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2118 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2119 scm_remember_upto_here_1 (y
);
2120 *qp
= SCM_I_MAKINUM (-1);
2136 SCM r
= scm_i_mkbig ();
2137 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2138 scm_remember_upto_here_1 (y
);
2139 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2141 *rp
= scm_i_normbig (r
);
2145 else if (SCM_REALP (y
))
2146 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2147 else if (SCM_FRACTIONP (y
))
2148 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2150 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2151 s_scm_ceiling_divide
, qp
, rp
);
2153 else if (SCM_BIGP (x
))
2155 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2157 scm_t_inum yy
= SCM_I_INUM (y
);
2158 if (SCM_UNLIKELY (yy
== 0))
2159 scm_num_overflow (s_scm_ceiling_divide
);
2162 SCM q
= scm_i_mkbig ();
2163 SCM r
= scm_i_mkbig ();
2165 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2166 SCM_I_BIG_MPZ (x
), yy
);
2169 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2170 SCM_I_BIG_MPZ (x
), -yy
);
2171 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2173 scm_remember_upto_here_1 (x
);
2174 *qp
= scm_i_normbig (q
);
2175 *rp
= scm_i_normbig (r
);
2179 else if (SCM_BIGP (y
))
2181 SCM q
= scm_i_mkbig ();
2182 SCM r
= scm_i_mkbig ();
2183 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2184 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2185 scm_remember_upto_here_2 (x
, y
);
2186 *qp
= scm_i_normbig (q
);
2187 *rp
= scm_i_normbig (r
);
2190 else if (SCM_REALP (y
))
2191 return scm_i_inexact_ceiling_divide
2192 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2193 else if (SCM_FRACTIONP (y
))
2194 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2196 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2197 s_scm_ceiling_divide
, qp
, rp
);
2199 else if (SCM_REALP (x
))
2201 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2202 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2203 return scm_i_inexact_ceiling_divide
2204 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2206 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2207 s_scm_ceiling_divide
, qp
, rp
);
2209 else if (SCM_FRACTIONP (x
))
2212 return scm_i_inexact_ceiling_divide
2213 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2214 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2215 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2217 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2218 s_scm_ceiling_divide
, qp
, rp
);
2221 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2222 s_scm_ceiling_divide
, qp
, rp
);
2226 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2228 if (SCM_UNLIKELY (y
== 0))
2229 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2232 double q
= ceil (x
/ y
);
2233 double r
= x
- q
* y
;
2234 *qp
= scm_from_double (q
);
2235 *rp
= scm_from_double (r
);
2240 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2243 SCM xd
= scm_denominator (x
);
2244 SCM yd
= scm_denominator (y
);
2246 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2247 scm_product (scm_numerator (y
), xd
),
2249 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2252 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2253 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2255 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2257 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2259 "(truncate-quotient 123 10) @result{} 12\n"
2260 "(truncate-quotient 123 -10) @result{} -12\n"
2261 "(truncate-quotient -123 10) @result{} -12\n"
2262 "(truncate-quotient -123 -10) @result{} 12\n"
2263 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2264 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2266 #define FUNC_NAME s_scm_truncate_quotient
2268 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2270 scm_t_inum xx
= SCM_I_INUM (x
);
2271 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2273 scm_t_inum yy
= SCM_I_INUM (y
);
2274 if (SCM_UNLIKELY (yy
== 0))
2275 scm_num_overflow (s_scm_truncate_quotient
);
2278 scm_t_inum qq
= xx
/ yy
;
2279 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2280 return SCM_I_MAKINUM (qq
);
2282 return scm_i_inum2big (qq
);
2285 else if (SCM_BIGP (y
))
2287 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2288 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2289 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2291 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2292 scm_remember_upto_here_1 (y
);
2293 return SCM_I_MAKINUM (-1);
2298 else if (SCM_REALP (y
))
2299 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2300 else if (SCM_FRACTIONP (y
))
2301 return scm_i_exact_rational_truncate_quotient (x
, y
);
2303 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2304 s_scm_truncate_quotient
);
2306 else if (SCM_BIGP (x
))
2308 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2310 scm_t_inum yy
= SCM_I_INUM (y
);
2311 if (SCM_UNLIKELY (yy
== 0))
2312 scm_num_overflow (s_scm_truncate_quotient
);
2313 else if (SCM_UNLIKELY (yy
== 1))
2317 SCM q
= scm_i_mkbig ();
2319 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2322 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2323 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2325 scm_remember_upto_here_1 (x
);
2326 return scm_i_normbig (q
);
2329 else if (SCM_BIGP (y
))
2331 SCM q
= scm_i_mkbig ();
2332 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2335 scm_remember_upto_here_2 (x
, y
);
2336 return scm_i_normbig (q
);
2338 else if (SCM_REALP (y
))
2339 return scm_i_inexact_truncate_quotient
2340 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2341 else if (SCM_FRACTIONP (y
))
2342 return scm_i_exact_rational_truncate_quotient (x
, y
);
2344 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2345 s_scm_truncate_quotient
);
2347 else if (SCM_REALP (x
))
2349 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2350 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2351 return scm_i_inexact_truncate_quotient
2352 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2354 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2355 s_scm_truncate_quotient
);
2357 else if (SCM_FRACTIONP (x
))
2360 return scm_i_inexact_truncate_quotient
2361 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2362 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2363 return scm_i_exact_rational_truncate_quotient (x
, y
);
2365 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2366 s_scm_truncate_quotient
);
2369 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2370 s_scm_truncate_quotient
);
2375 scm_i_inexact_truncate_quotient (double x
, double y
)
2377 if (SCM_UNLIKELY (y
== 0))
2378 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2380 return scm_from_double (trunc (x
/ y
));
2384 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2386 return scm_truncate_quotient
2387 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2388 scm_product (scm_numerator (y
), scm_denominator (x
)));
2391 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2392 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2394 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2396 "Return the real number @var{r} such that\n"
2397 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2398 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2400 "(truncate-remainder 123 10) @result{} 3\n"
2401 "(truncate-remainder 123 -10) @result{} 3\n"
2402 "(truncate-remainder -123 10) @result{} -3\n"
2403 "(truncate-remainder -123 -10) @result{} -3\n"
2404 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2405 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2407 #define FUNC_NAME s_scm_truncate_remainder
2409 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2411 scm_t_inum xx
= SCM_I_INUM (x
);
2412 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2414 scm_t_inum yy
= SCM_I_INUM (y
);
2415 if (SCM_UNLIKELY (yy
== 0))
2416 scm_num_overflow (s_scm_truncate_remainder
);
2418 return SCM_I_MAKINUM (xx
% yy
);
2420 else if (SCM_BIGP (y
))
2422 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2423 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2424 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2426 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2427 scm_remember_upto_here_1 (y
);
2433 else if (SCM_REALP (y
))
2434 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2435 else if (SCM_FRACTIONP (y
))
2436 return scm_i_exact_rational_truncate_remainder (x
, y
);
2438 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2439 s_scm_truncate_remainder
);
2441 else if (SCM_BIGP (x
))
2443 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2445 scm_t_inum yy
= SCM_I_INUM (y
);
2446 if (SCM_UNLIKELY (yy
== 0))
2447 scm_num_overflow (s_scm_truncate_remainder
);
2450 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2451 (yy
> 0) ? yy
: -yy
)
2452 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2453 scm_remember_upto_here_1 (x
);
2454 return SCM_I_MAKINUM (rr
);
2457 else if (SCM_BIGP (y
))
2459 SCM r
= scm_i_mkbig ();
2460 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2463 scm_remember_upto_here_2 (x
, y
);
2464 return scm_i_normbig (r
);
2466 else if (SCM_REALP (y
))
2467 return scm_i_inexact_truncate_remainder
2468 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2469 else if (SCM_FRACTIONP (y
))
2470 return scm_i_exact_rational_truncate_remainder (x
, y
);
2472 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2473 s_scm_truncate_remainder
);
2475 else if (SCM_REALP (x
))
2477 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2478 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2479 return scm_i_inexact_truncate_remainder
2480 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2482 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2483 s_scm_truncate_remainder
);
2485 else if (SCM_FRACTIONP (x
))
2488 return scm_i_inexact_truncate_remainder
2489 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2490 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2491 return scm_i_exact_rational_truncate_remainder (x
, y
);
2493 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2494 s_scm_truncate_remainder
);
2497 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2498 s_scm_truncate_remainder
);
2503 scm_i_inexact_truncate_remainder (double x
, double y
)
2505 /* Although it would be more efficient to use fmod here, we can't
2506 because it would in some cases produce results inconsistent with
2507 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2508 close). In particular, when x is very close to a multiple of y,
2509 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2510 correspond to different choices of q. If quotient chooses one and
2511 remainder chooses the other, it would be bad. */
2512 if (SCM_UNLIKELY (y
== 0))
2513 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2515 return scm_from_double (x
- y
* trunc (x
/ y
));
2519 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2521 SCM xd
= scm_denominator (x
);
2522 SCM yd
= scm_denominator (y
);
2523 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2524 scm_product (scm_numerator (y
), xd
));
2525 return scm_divide (r1
, scm_product (xd
, yd
));
2529 static void scm_i_inexact_truncate_divide (double x
, double y
,
2531 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2534 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2536 "Return the integer @var{q} and the real number @var{r}\n"
2537 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2538 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2540 "(truncate/ 123 10) @result{} 12 and 3\n"
2541 "(truncate/ 123 -10) @result{} -12 and 3\n"
2542 "(truncate/ -123 10) @result{} -12 and -3\n"
2543 "(truncate/ -123 -10) @result{} 12 and -3\n"
2544 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2545 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2547 #define FUNC_NAME s_scm_i_truncate_divide
2551 scm_truncate_divide(x
, y
, &q
, &r
);
2552 return scm_values (scm_list_2 (q
, r
));
2556 #define s_scm_truncate_divide s_scm_i_truncate_divide
2557 #define g_scm_truncate_divide g_scm_i_truncate_divide
2560 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2562 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2564 scm_t_inum xx
= SCM_I_INUM (x
);
2565 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2567 scm_t_inum yy
= SCM_I_INUM (y
);
2568 if (SCM_UNLIKELY (yy
== 0))
2569 scm_num_overflow (s_scm_truncate_divide
);
2572 scm_t_inum qq
= xx
/ yy
;
2573 scm_t_inum rr
= xx
% yy
;
2574 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2575 *qp
= SCM_I_MAKINUM (qq
);
2577 *qp
= scm_i_inum2big (qq
);
2578 *rp
= SCM_I_MAKINUM (rr
);
2582 else if (SCM_BIGP (y
))
2584 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2585 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2586 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2588 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2589 scm_remember_upto_here_1 (y
);
2590 *qp
= SCM_I_MAKINUM (-1);
2600 else if (SCM_REALP (y
))
2601 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2602 else if (SCM_FRACTIONP (y
))
2603 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2605 return two_valued_wta_dispatch_2
2606 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2607 s_scm_truncate_divide
, qp
, rp
);
2609 else if (SCM_BIGP (x
))
2611 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2613 scm_t_inum yy
= SCM_I_INUM (y
);
2614 if (SCM_UNLIKELY (yy
== 0))
2615 scm_num_overflow (s_scm_truncate_divide
);
2618 SCM q
= scm_i_mkbig ();
2621 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2622 SCM_I_BIG_MPZ (x
), yy
);
2625 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2626 SCM_I_BIG_MPZ (x
), -yy
);
2627 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2629 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2630 scm_remember_upto_here_1 (x
);
2631 *qp
= scm_i_normbig (q
);
2632 *rp
= SCM_I_MAKINUM (rr
);
2636 else if (SCM_BIGP (y
))
2638 SCM q
= scm_i_mkbig ();
2639 SCM r
= scm_i_mkbig ();
2640 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2641 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2642 scm_remember_upto_here_2 (x
, y
);
2643 *qp
= scm_i_normbig (q
);
2644 *rp
= scm_i_normbig (r
);
2646 else if (SCM_REALP (y
))
2647 return scm_i_inexact_truncate_divide
2648 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2649 else if (SCM_FRACTIONP (y
))
2650 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2652 return two_valued_wta_dispatch_2
2653 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2654 s_scm_truncate_divide
, qp
, rp
);
2656 else if (SCM_REALP (x
))
2658 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2659 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2660 return scm_i_inexact_truncate_divide
2661 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2663 return two_valued_wta_dispatch_2
2664 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2665 s_scm_truncate_divide
, qp
, rp
);
2667 else if (SCM_FRACTIONP (x
))
2670 return scm_i_inexact_truncate_divide
2671 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2672 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2673 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2675 return two_valued_wta_dispatch_2
2676 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2677 s_scm_truncate_divide
, qp
, rp
);
2680 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2681 s_scm_truncate_divide
, qp
, rp
);
2685 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2687 if (SCM_UNLIKELY (y
== 0))
2688 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2691 double q
= trunc (x
/ y
);
2692 double r
= x
- q
* y
;
2693 *qp
= scm_from_double (q
);
2694 *rp
= scm_from_double (r
);
2699 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2702 SCM xd
= scm_denominator (x
);
2703 SCM yd
= scm_denominator (y
);
2705 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2706 scm_product (scm_numerator (y
), xd
),
2708 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2711 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2712 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2713 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2715 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2717 "Return the integer @var{q} such that\n"
2718 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2719 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2721 "(centered-quotient 123 10) @result{} 12\n"
2722 "(centered-quotient 123 -10) @result{} -12\n"
2723 "(centered-quotient -123 10) @result{} -12\n"
2724 "(centered-quotient -123 -10) @result{} 12\n"
2725 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2726 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2728 #define FUNC_NAME s_scm_centered_quotient
2730 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2732 scm_t_inum xx
= SCM_I_INUM (x
);
2733 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2735 scm_t_inum yy
= SCM_I_INUM (y
);
2736 if (SCM_UNLIKELY (yy
== 0))
2737 scm_num_overflow (s_scm_centered_quotient
);
2740 scm_t_inum qq
= xx
/ yy
;
2741 scm_t_inum rr
= xx
% yy
;
2742 if (SCM_LIKELY (xx
> 0))
2744 if (SCM_LIKELY (yy
> 0))
2746 if (rr
>= (yy
+ 1) / 2)
2751 if (rr
>= (1 - yy
) / 2)
2757 if (SCM_LIKELY (yy
> 0))
2768 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2769 return SCM_I_MAKINUM (qq
);
2771 return scm_i_inum2big (qq
);
2774 else if (SCM_BIGP (y
))
2776 /* Pass a denormalized bignum version of x (even though it
2777 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2778 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2780 else if (SCM_REALP (y
))
2781 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2782 else if (SCM_FRACTIONP (y
))
2783 return scm_i_exact_rational_centered_quotient (x
, y
);
2785 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2786 s_scm_centered_quotient
);
2788 else if (SCM_BIGP (x
))
2790 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2792 scm_t_inum yy
= SCM_I_INUM (y
);
2793 if (SCM_UNLIKELY (yy
== 0))
2794 scm_num_overflow (s_scm_centered_quotient
);
2795 else if (SCM_UNLIKELY (yy
== 1))
2799 SCM q
= scm_i_mkbig ();
2801 /* Arrange for rr to initially be non-positive,
2802 because that simplifies the test to see
2803 if it is within the needed bounds. */
2806 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2807 SCM_I_BIG_MPZ (x
), yy
);
2808 scm_remember_upto_here_1 (x
);
2810 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2811 SCM_I_BIG_MPZ (q
), 1);
2815 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2816 SCM_I_BIG_MPZ (x
), -yy
);
2817 scm_remember_upto_here_1 (x
);
2818 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2820 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2821 SCM_I_BIG_MPZ (q
), 1);
2823 return scm_i_normbig (q
);
2826 else if (SCM_BIGP (y
))
2827 return scm_i_bigint_centered_quotient (x
, y
);
2828 else if (SCM_REALP (y
))
2829 return scm_i_inexact_centered_quotient
2830 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2831 else if (SCM_FRACTIONP (y
))
2832 return scm_i_exact_rational_centered_quotient (x
, y
);
2834 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2835 s_scm_centered_quotient
);
2837 else if (SCM_REALP (x
))
2839 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2840 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2841 return scm_i_inexact_centered_quotient
2842 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2844 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2845 s_scm_centered_quotient
);
2847 else if (SCM_FRACTIONP (x
))
2850 return scm_i_inexact_centered_quotient
2851 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2852 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2853 return scm_i_exact_rational_centered_quotient (x
, y
);
2855 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2856 s_scm_centered_quotient
);
2859 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2860 s_scm_centered_quotient
);
2865 scm_i_inexact_centered_quotient (double x
, double y
)
2867 if (SCM_LIKELY (y
> 0))
2868 return scm_from_double (floor (x
/y
+ 0.5));
2869 else if (SCM_LIKELY (y
< 0))
2870 return scm_from_double (ceil (x
/y
- 0.5));
2872 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2877 /* Assumes that both x and y are bigints, though
2878 x might be able to fit into a fixnum. */
2880 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2884 /* Note that x might be small enough to fit into a
2885 fixnum, so we must not let it escape into the wild */
2889 /* min_r will eventually become -abs(y)/2 */
2890 min_r
= scm_i_mkbig ();
2891 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2892 SCM_I_BIG_MPZ (y
), 1);
2894 /* Arrange for rr to initially be non-positive,
2895 because that simplifies the test to see
2896 if it is within the needed bounds. */
2897 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2899 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2900 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2901 scm_remember_upto_here_2 (x
, y
);
2902 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2903 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2904 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2905 SCM_I_BIG_MPZ (q
), 1);
2909 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2910 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2911 scm_remember_upto_here_2 (x
, y
);
2912 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2913 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2914 SCM_I_BIG_MPZ (q
), 1);
2916 scm_remember_upto_here_2 (r
, min_r
);
2917 return scm_i_normbig (q
);
2921 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2923 return scm_centered_quotient
2924 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2925 scm_product (scm_numerator (y
), scm_denominator (x
)));
2928 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2929 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2930 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2932 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2934 "Return the real number @var{r} such that\n"
2935 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2936 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2937 "for some integer @var{q}.\n"
2939 "(centered-remainder 123 10) @result{} 3\n"
2940 "(centered-remainder 123 -10) @result{} 3\n"
2941 "(centered-remainder -123 10) @result{} -3\n"
2942 "(centered-remainder -123 -10) @result{} -3\n"
2943 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2944 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2946 #define FUNC_NAME s_scm_centered_remainder
2948 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2950 scm_t_inum xx
= SCM_I_INUM (x
);
2951 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2953 scm_t_inum yy
= SCM_I_INUM (y
);
2954 if (SCM_UNLIKELY (yy
== 0))
2955 scm_num_overflow (s_scm_centered_remainder
);
2958 scm_t_inum rr
= xx
% yy
;
2959 if (SCM_LIKELY (xx
> 0))
2961 if (SCM_LIKELY (yy
> 0))
2963 if (rr
>= (yy
+ 1) / 2)
2968 if (rr
>= (1 - yy
) / 2)
2974 if (SCM_LIKELY (yy
> 0))
2985 return SCM_I_MAKINUM (rr
);
2988 else if (SCM_BIGP (y
))
2990 /* Pass a denormalized bignum version of x (even though it
2991 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2992 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2994 else if (SCM_REALP (y
))
2995 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2996 else if (SCM_FRACTIONP (y
))
2997 return scm_i_exact_rational_centered_remainder (x
, y
);
2999 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3000 s_scm_centered_remainder
);
3002 else if (SCM_BIGP (x
))
3004 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3006 scm_t_inum yy
= SCM_I_INUM (y
);
3007 if (SCM_UNLIKELY (yy
== 0))
3008 scm_num_overflow (s_scm_centered_remainder
);
3012 /* Arrange for rr to initially be non-positive,
3013 because that simplifies the test to see
3014 if it is within the needed bounds. */
3017 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3018 scm_remember_upto_here_1 (x
);
3024 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3025 scm_remember_upto_here_1 (x
);
3029 return SCM_I_MAKINUM (rr
);
3032 else if (SCM_BIGP (y
))
3033 return scm_i_bigint_centered_remainder (x
, y
);
3034 else if (SCM_REALP (y
))
3035 return scm_i_inexact_centered_remainder
3036 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3037 else if (SCM_FRACTIONP (y
))
3038 return scm_i_exact_rational_centered_remainder (x
, y
);
3040 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3041 s_scm_centered_remainder
);
3043 else if (SCM_REALP (x
))
3045 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3046 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3047 return scm_i_inexact_centered_remainder
3048 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3050 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3051 s_scm_centered_remainder
);
3053 else if (SCM_FRACTIONP (x
))
3056 return scm_i_inexact_centered_remainder
3057 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3058 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3059 return scm_i_exact_rational_centered_remainder (x
, y
);
3061 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3062 s_scm_centered_remainder
);
3065 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3066 s_scm_centered_remainder
);
3071 scm_i_inexact_centered_remainder (double x
, double y
)
3075 /* Although it would be more efficient to use fmod here, we can't
3076 because it would in some cases produce results inconsistent with
3077 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3078 close). In particular, when x-y/2 is very close to a multiple of
3079 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3080 two cases must correspond to different choices of q. If quotient
3081 chooses one and remainder chooses the other, it would be bad. */
3082 if (SCM_LIKELY (y
> 0))
3083 q
= floor (x
/y
+ 0.5);
3084 else if (SCM_LIKELY (y
< 0))
3085 q
= ceil (x
/y
- 0.5);
3087 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3090 return scm_from_double (x
- q
* y
);
3093 /* Assumes that both x and y are bigints, though
3094 x might be able to fit into a fixnum. */
3096 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3100 /* Note that x might be small enough to fit into a
3101 fixnum, so we must not let it escape into the wild */
3104 /* min_r will eventually become -abs(y)/2 */
3105 min_r
= scm_i_mkbig ();
3106 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3107 SCM_I_BIG_MPZ (y
), 1);
3109 /* Arrange for rr to initially be non-positive,
3110 because that simplifies the test to see
3111 if it is within the needed bounds. */
3112 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3114 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3115 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3116 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3117 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3118 mpz_add (SCM_I_BIG_MPZ (r
),
3124 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3125 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3126 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3127 mpz_sub (SCM_I_BIG_MPZ (r
),
3131 scm_remember_upto_here_2 (x
, y
);
3132 return scm_i_normbig (r
);
3136 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3138 SCM xd
= scm_denominator (x
);
3139 SCM yd
= scm_denominator (y
);
3140 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3141 scm_product (scm_numerator (y
), xd
));
3142 return scm_divide (r1
, scm_product (xd
, yd
));
3146 static void scm_i_inexact_centered_divide (double x
, double y
,
3148 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3149 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3152 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3154 "Return the integer @var{q} and the real number @var{r}\n"
3155 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3156 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3158 "(centered/ 123 10) @result{} 12 and 3\n"
3159 "(centered/ 123 -10) @result{} -12 and 3\n"
3160 "(centered/ -123 10) @result{} -12 and -3\n"
3161 "(centered/ -123 -10) @result{} 12 and -3\n"
3162 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3163 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3165 #define FUNC_NAME s_scm_i_centered_divide
3169 scm_centered_divide(x
, y
, &q
, &r
);
3170 return scm_values (scm_list_2 (q
, r
));
3174 #define s_scm_centered_divide s_scm_i_centered_divide
3175 #define g_scm_centered_divide g_scm_i_centered_divide
3178 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3180 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3182 scm_t_inum xx
= SCM_I_INUM (x
);
3183 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3185 scm_t_inum yy
= SCM_I_INUM (y
);
3186 if (SCM_UNLIKELY (yy
== 0))
3187 scm_num_overflow (s_scm_centered_divide
);
3190 scm_t_inum qq
= xx
/ yy
;
3191 scm_t_inum rr
= xx
% yy
;
3192 if (SCM_LIKELY (xx
> 0))
3194 if (SCM_LIKELY (yy
> 0))
3196 if (rr
>= (yy
+ 1) / 2)
3201 if (rr
>= (1 - yy
) / 2)
3207 if (SCM_LIKELY (yy
> 0))
3218 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3219 *qp
= SCM_I_MAKINUM (qq
);
3221 *qp
= scm_i_inum2big (qq
);
3222 *rp
= SCM_I_MAKINUM (rr
);
3226 else if (SCM_BIGP (y
))
3228 /* Pass a denormalized bignum version of x (even though it
3229 can fit in a fixnum) to scm_i_bigint_centered_divide */
3230 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3232 else if (SCM_REALP (y
))
3233 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3234 else if (SCM_FRACTIONP (y
))
3235 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3237 return two_valued_wta_dispatch_2
3238 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3239 s_scm_centered_divide
, qp
, rp
);
3241 else if (SCM_BIGP (x
))
3243 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3245 scm_t_inum yy
= SCM_I_INUM (y
);
3246 if (SCM_UNLIKELY (yy
== 0))
3247 scm_num_overflow (s_scm_centered_divide
);
3250 SCM q
= scm_i_mkbig ();
3252 /* Arrange for rr to initially be non-positive,
3253 because that simplifies the test to see
3254 if it is within the needed bounds. */
3257 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3258 SCM_I_BIG_MPZ (x
), yy
);
3259 scm_remember_upto_here_1 (x
);
3262 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3263 SCM_I_BIG_MPZ (q
), 1);
3269 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3270 SCM_I_BIG_MPZ (x
), -yy
);
3271 scm_remember_upto_here_1 (x
);
3272 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3275 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3276 SCM_I_BIG_MPZ (q
), 1);
3280 *qp
= scm_i_normbig (q
);
3281 *rp
= SCM_I_MAKINUM (rr
);
3285 else if (SCM_BIGP (y
))
3286 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3287 else if (SCM_REALP (y
))
3288 return scm_i_inexact_centered_divide
3289 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3290 else if (SCM_FRACTIONP (y
))
3291 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3293 return two_valued_wta_dispatch_2
3294 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3295 s_scm_centered_divide
, qp
, rp
);
3297 else if (SCM_REALP (x
))
3299 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3300 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3301 return scm_i_inexact_centered_divide
3302 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3304 return two_valued_wta_dispatch_2
3305 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3306 s_scm_centered_divide
, qp
, rp
);
3308 else if (SCM_FRACTIONP (x
))
3311 return scm_i_inexact_centered_divide
3312 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3313 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3314 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3316 return two_valued_wta_dispatch_2
3317 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3318 s_scm_centered_divide
, qp
, rp
);
3321 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3322 s_scm_centered_divide
, qp
, rp
);
3326 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3330 if (SCM_LIKELY (y
> 0))
3331 q
= floor (x
/y
+ 0.5);
3332 else if (SCM_LIKELY (y
< 0))
3333 q
= ceil (x
/y
- 0.5);
3335 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3339 *qp
= scm_from_double (q
);
3340 *rp
= scm_from_double (r
);
3343 /* Assumes that both x and y are bigints, though
3344 x might be able to fit into a fixnum. */
3346 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3350 /* Note that x might be small enough to fit into a
3351 fixnum, so we must not let it escape into the wild */
3355 /* min_r will eventually become -abs(y/2) */
3356 min_r
= scm_i_mkbig ();
3357 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3358 SCM_I_BIG_MPZ (y
), 1);
3360 /* Arrange for rr to initially be non-positive,
3361 because that simplifies the test to see
3362 if it is within the needed bounds. */
3363 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3365 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3366 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3367 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3368 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3370 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3371 SCM_I_BIG_MPZ (q
), 1);
3372 mpz_add (SCM_I_BIG_MPZ (r
),
3379 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3380 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3381 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3383 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3384 SCM_I_BIG_MPZ (q
), 1);
3385 mpz_sub (SCM_I_BIG_MPZ (r
),
3390 scm_remember_upto_here_2 (x
, y
);
3391 *qp
= scm_i_normbig (q
);
3392 *rp
= scm_i_normbig (r
);
3396 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3399 SCM xd
= scm_denominator (x
);
3400 SCM yd
= scm_denominator (y
);
3402 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3403 scm_product (scm_numerator (y
), xd
),
3405 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3408 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3409 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3410 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3412 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3414 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3415 "with ties going to the nearest even integer.\n"
3417 "(round-quotient 123 10) @result{} 12\n"
3418 "(round-quotient 123 -10) @result{} -12\n"
3419 "(round-quotient -123 10) @result{} -12\n"
3420 "(round-quotient -123 -10) @result{} 12\n"
3421 "(round-quotient 125 10) @result{} 12\n"
3422 "(round-quotient 127 10) @result{} 13\n"
3423 "(round-quotient 135 10) @result{} 14\n"
3424 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3425 "(round-quotient 16/3 -10/7) @result{} -4\n"
3427 #define FUNC_NAME s_scm_round_quotient
3429 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3431 scm_t_inum xx
= SCM_I_INUM (x
);
3432 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3434 scm_t_inum yy
= SCM_I_INUM (y
);
3435 if (SCM_UNLIKELY (yy
== 0))
3436 scm_num_overflow (s_scm_round_quotient
);
3439 scm_t_inum qq
= xx
/ yy
;
3440 scm_t_inum rr
= xx
% yy
;
3442 scm_t_inum r2
= 2 * rr
;
3444 if (SCM_LIKELY (yy
< 0))
3464 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3465 return SCM_I_MAKINUM (qq
);
3467 return scm_i_inum2big (qq
);
3470 else if (SCM_BIGP (y
))
3472 /* Pass a denormalized bignum version of x (even though it
3473 can fit in a fixnum) to scm_i_bigint_round_quotient */
3474 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3476 else if (SCM_REALP (y
))
3477 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3478 else if (SCM_FRACTIONP (y
))
3479 return scm_i_exact_rational_round_quotient (x
, y
);
3481 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3482 s_scm_round_quotient
);
3484 else if (SCM_BIGP (x
))
3486 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3488 scm_t_inum yy
= SCM_I_INUM (y
);
3489 if (SCM_UNLIKELY (yy
== 0))
3490 scm_num_overflow (s_scm_round_quotient
);
3491 else if (SCM_UNLIKELY (yy
== 1))
3495 SCM q
= scm_i_mkbig ();
3497 int needs_adjustment
;
3501 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3502 SCM_I_BIG_MPZ (x
), yy
);
3503 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3504 needs_adjustment
= (2*rr
>= yy
);
3506 needs_adjustment
= (2*rr
> yy
);
3510 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3511 SCM_I_BIG_MPZ (x
), -yy
);
3512 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3513 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3514 needs_adjustment
= (2*rr
<= yy
);
3516 needs_adjustment
= (2*rr
< yy
);
3518 scm_remember_upto_here_1 (x
);
3519 if (needs_adjustment
)
3520 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3521 return scm_i_normbig (q
);
3524 else if (SCM_BIGP (y
))
3525 return scm_i_bigint_round_quotient (x
, y
);
3526 else if (SCM_REALP (y
))
3527 return scm_i_inexact_round_quotient
3528 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3529 else if (SCM_FRACTIONP (y
))
3530 return scm_i_exact_rational_round_quotient (x
, y
);
3532 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3533 s_scm_round_quotient
);
3535 else if (SCM_REALP (x
))
3537 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3538 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3539 return scm_i_inexact_round_quotient
3540 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3542 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3543 s_scm_round_quotient
);
3545 else if (SCM_FRACTIONP (x
))
3548 return scm_i_inexact_round_quotient
3549 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3550 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3551 return scm_i_exact_rational_round_quotient (x
, y
);
3553 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3554 s_scm_round_quotient
);
3557 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3558 s_scm_round_quotient
);
3563 scm_i_inexact_round_quotient (double x
, double y
)
3565 if (SCM_UNLIKELY (y
== 0))
3566 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3568 return scm_from_double (scm_c_round (x
/ y
));
3571 /* Assumes that both x and y are bigints, though
3572 x might be able to fit into a fixnum. */
3574 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3577 int cmp
, needs_adjustment
;
3579 /* Note that x might be small enough to fit into a
3580 fixnum, so we must not let it escape into the wild */
3583 r2
= scm_i_mkbig ();
3585 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3586 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3587 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3588 scm_remember_upto_here_2 (x
, r
);
3590 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3591 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3592 needs_adjustment
= (cmp
>= 0);
3594 needs_adjustment
= (cmp
> 0);
3595 scm_remember_upto_here_2 (r2
, y
);
3597 if (needs_adjustment
)
3598 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3600 return scm_i_normbig (q
);
3604 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3606 return scm_round_quotient
3607 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3608 scm_product (scm_numerator (y
), scm_denominator (x
)));
3611 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3612 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3613 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3615 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3617 "Return the real number @var{r} such that\n"
3618 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3619 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3620 "nearest integer, with ties going to the nearest\n"
3623 "(round-remainder 123 10) @result{} 3\n"
3624 "(round-remainder 123 -10) @result{} 3\n"
3625 "(round-remainder -123 10) @result{} -3\n"
3626 "(round-remainder -123 -10) @result{} -3\n"
3627 "(round-remainder 125 10) @result{} 5\n"
3628 "(round-remainder 127 10) @result{} -3\n"
3629 "(round-remainder 135 10) @result{} -5\n"
3630 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3631 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3633 #define FUNC_NAME s_scm_round_remainder
3635 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3637 scm_t_inum xx
= SCM_I_INUM (x
);
3638 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3640 scm_t_inum yy
= SCM_I_INUM (y
);
3641 if (SCM_UNLIKELY (yy
== 0))
3642 scm_num_overflow (s_scm_round_remainder
);
3645 scm_t_inum qq
= xx
/ yy
;
3646 scm_t_inum rr
= xx
% yy
;
3648 scm_t_inum r2
= 2 * rr
;
3650 if (SCM_LIKELY (yy
< 0))
3670 return SCM_I_MAKINUM (rr
);
3673 else if (SCM_BIGP (y
))
3675 /* Pass a denormalized bignum version of x (even though it
3676 can fit in a fixnum) to scm_i_bigint_round_remainder */
3677 return scm_i_bigint_round_remainder
3678 (scm_i_long2big (xx
), y
);
3680 else if (SCM_REALP (y
))
3681 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3682 else if (SCM_FRACTIONP (y
))
3683 return scm_i_exact_rational_round_remainder (x
, y
);
3685 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3686 s_scm_round_remainder
);
3688 else if (SCM_BIGP (x
))
3690 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3692 scm_t_inum yy
= SCM_I_INUM (y
);
3693 if (SCM_UNLIKELY (yy
== 0))
3694 scm_num_overflow (s_scm_round_remainder
);
3697 SCM q
= scm_i_mkbig ();
3699 int needs_adjustment
;
3703 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3704 SCM_I_BIG_MPZ (x
), yy
);
3705 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3706 needs_adjustment
= (2*rr
>= yy
);
3708 needs_adjustment
= (2*rr
> yy
);
3712 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3713 SCM_I_BIG_MPZ (x
), -yy
);
3714 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3715 needs_adjustment
= (2*rr
<= yy
);
3717 needs_adjustment
= (2*rr
< yy
);
3719 scm_remember_upto_here_2 (x
, q
);
3720 if (needs_adjustment
)
3722 return SCM_I_MAKINUM (rr
);
3725 else if (SCM_BIGP (y
))
3726 return scm_i_bigint_round_remainder (x
, y
);
3727 else if (SCM_REALP (y
))
3728 return scm_i_inexact_round_remainder
3729 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3730 else if (SCM_FRACTIONP (y
))
3731 return scm_i_exact_rational_round_remainder (x
, y
);
3733 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3734 s_scm_round_remainder
);
3736 else if (SCM_REALP (x
))
3738 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3739 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3740 return scm_i_inexact_round_remainder
3741 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3743 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3744 s_scm_round_remainder
);
3746 else if (SCM_FRACTIONP (x
))
3749 return scm_i_inexact_round_remainder
3750 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3751 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3752 return scm_i_exact_rational_round_remainder (x
, y
);
3754 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3755 s_scm_round_remainder
);
3758 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3759 s_scm_round_remainder
);
3764 scm_i_inexact_round_remainder (double x
, double y
)
3766 /* Although it would be more efficient to use fmod here, we can't
3767 because it would in some cases produce results inconsistent with
3768 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3769 close). In particular, when x-y/2 is very close to a multiple of
3770 y, then r might be either -abs(y/2) or abs(y/2), but those two
3771 cases must correspond to different choices of q. If quotient
3772 chooses one and remainder chooses the other, it would be bad. */
3774 if (SCM_UNLIKELY (y
== 0))
3775 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3778 double q
= scm_c_round (x
/ y
);
3779 return scm_from_double (x
- q
* y
);
3783 /* Assumes that both x and y are bigints, though
3784 x might be able to fit into a fixnum. */
3786 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3789 int cmp
, needs_adjustment
;
3791 /* Note that x might be small enough to fit into a
3792 fixnum, so we must not let it escape into the wild */
3795 r2
= scm_i_mkbig ();
3797 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3798 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3799 scm_remember_upto_here_1 (x
);
3800 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3802 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3803 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3804 needs_adjustment
= (cmp
>= 0);
3806 needs_adjustment
= (cmp
> 0);
3807 scm_remember_upto_here_2 (q
, r2
);
3809 if (needs_adjustment
)
3810 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3812 scm_remember_upto_here_1 (y
);
3813 return scm_i_normbig (r
);
3817 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3819 SCM xd
= scm_denominator (x
);
3820 SCM yd
= scm_denominator (y
);
3821 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3822 scm_product (scm_numerator (y
), xd
));
3823 return scm_divide (r1
, scm_product (xd
, yd
));
3827 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3828 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3829 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3831 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3833 "Return the integer @var{q} and the real number @var{r}\n"
3834 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3835 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3836 "nearest integer, with ties going to the nearest even integer.\n"
3838 "(round/ 123 10) @result{} 12 and 3\n"
3839 "(round/ 123 -10) @result{} -12 and 3\n"
3840 "(round/ -123 10) @result{} -12 and -3\n"
3841 "(round/ -123 -10) @result{} 12 and -3\n"
3842 "(round/ 125 10) @result{} 12 and 5\n"
3843 "(round/ 127 10) @result{} 13 and -3\n"
3844 "(round/ 135 10) @result{} 14 and -5\n"
3845 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3846 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3848 #define FUNC_NAME s_scm_i_round_divide
3852 scm_round_divide(x
, y
, &q
, &r
);
3853 return scm_values (scm_list_2 (q
, r
));
3857 #define s_scm_round_divide s_scm_i_round_divide
3858 #define g_scm_round_divide g_scm_i_round_divide
3861 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3863 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3865 scm_t_inum xx
= SCM_I_INUM (x
);
3866 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3868 scm_t_inum yy
= SCM_I_INUM (y
);
3869 if (SCM_UNLIKELY (yy
== 0))
3870 scm_num_overflow (s_scm_round_divide
);
3873 scm_t_inum qq
= xx
/ yy
;
3874 scm_t_inum rr
= xx
% yy
;
3876 scm_t_inum r2
= 2 * rr
;
3878 if (SCM_LIKELY (yy
< 0))
3898 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3899 *qp
= SCM_I_MAKINUM (qq
);
3901 *qp
= scm_i_inum2big (qq
);
3902 *rp
= SCM_I_MAKINUM (rr
);
3906 else if (SCM_BIGP (y
))
3908 /* Pass a denormalized bignum version of x (even though it
3909 can fit in a fixnum) to scm_i_bigint_round_divide */
3910 return scm_i_bigint_round_divide
3911 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3913 else if (SCM_REALP (y
))
3914 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3915 else if (SCM_FRACTIONP (y
))
3916 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3918 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3919 s_scm_round_divide
, qp
, rp
);
3921 else if (SCM_BIGP (x
))
3923 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3925 scm_t_inum yy
= SCM_I_INUM (y
);
3926 if (SCM_UNLIKELY (yy
== 0))
3927 scm_num_overflow (s_scm_round_divide
);
3930 SCM q
= scm_i_mkbig ();
3932 int needs_adjustment
;
3936 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3937 SCM_I_BIG_MPZ (x
), yy
);
3938 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3939 needs_adjustment
= (2*rr
>= yy
);
3941 needs_adjustment
= (2*rr
> yy
);
3945 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3946 SCM_I_BIG_MPZ (x
), -yy
);
3947 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3948 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3949 needs_adjustment
= (2*rr
<= yy
);
3951 needs_adjustment
= (2*rr
< yy
);
3953 scm_remember_upto_here_1 (x
);
3954 if (needs_adjustment
)
3956 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3959 *qp
= scm_i_normbig (q
);
3960 *rp
= SCM_I_MAKINUM (rr
);
3964 else if (SCM_BIGP (y
))
3965 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3966 else if (SCM_REALP (y
))
3967 return scm_i_inexact_round_divide
3968 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3969 else if (SCM_FRACTIONP (y
))
3970 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3972 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3973 s_scm_round_divide
, qp
, rp
);
3975 else if (SCM_REALP (x
))
3977 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3978 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3979 return scm_i_inexact_round_divide
3980 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3982 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3983 s_scm_round_divide
, qp
, rp
);
3985 else if (SCM_FRACTIONP (x
))
3988 return scm_i_inexact_round_divide
3989 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3990 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3991 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3993 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3994 s_scm_round_divide
, qp
, rp
);
3997 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3998 s_scm_round_divide
, qp
, rp
);
4002 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
4004 if (SCM_UNLIKELY (y
== 0))
4005 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4008 double q
= scm_c_round (x
/ y
);
4009 double r
= x
- q
* y
;
4010 *qp
= scm_from_double (q
);
4011 *rp
= scm_from_double (r
);
4015 /* Assumes that both x and y are bigints, though
4016 x might be able to fit into a fixnum. */
4018 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4021 int cmp
, needs_adjustment
;
4023 /* Note that x might be small enough to fit into a
4024 fixnum, so we must not let it escape into the wild */
4027 r2
= scm_i_mkbig ();
4029 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4030 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4031 scm_remember_upto_here_1 (x
);
4032 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4034 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4035 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4036 needs_adjustment
= (cmp
>= 0);
4038 needs_adjustment
= (cmp
> 0);
4040 if (needs_adjustment
)
4042 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4043 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4046 scm_remember_upto_here_2 (r2
, y
);
4047 *qp
= scm_i_normbig (q
);
4048 *rp
= scm_i_normbig (r
);
4052 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4055 SCM xd
= scm_denominator (x
);
4056 SCM yd
= scm_denominator (y
);
4058 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4059 scm_product (scm_numerator (y
), xd
),
4061 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4065 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4066 (SCM x
, SCM y
, SCM rest
),
4067 "Return the greatest common divisor of all parameter values.\n"
4068 "If called without arguments, 0 is returned.")
4069 #define FUNC_NAME s_scm_i_gcd
4071 while (!scm_is_null (rest
))
4072 { x
= scm_gcd (x
, y
);
4074 rest
= scm_cdr (rest
);
4076 return scm_gcd (x
, y
);
4080 #define s_gcd s_scm_i_gcd
4081 #define g_gcd g_scm_i_gcd
4084 scm_gcd (SCM x
, SCM y
)
4086 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4087 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4089 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4091 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4093 scm_t_inum xx
= SCM_I_INUM (x
);
4094 scm_t_inum yy
= SCM_I_INUM (y
);
4095 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4096 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4098 if (SCM_UNLIKELY (xx
== 0))
4100 else if (SCM_UNLIKELY (yy
== 0))
4105 /* Determine a common factor 2^k */
4106 while (((u
| v
) & 1) == 0)
4112 /* Now, any factor 2^n can be eliminated */
4114 while ((u
& 1) == 0)
4117 while ((v
& 1) == 0)
4119 /* Both u and v are now odd. Subtract the smaller one
4120 from the larger one to produce an even number, remove
4121 more factors of two, and repeat. */
4127 while ((u
& 1) == 0)
4133 while ((v
& 1) == 0)
4139 return (SCM_POSFIXABLE (result
)
4140 ? SCM_I_MAKINUM (result
)
4141 : scm_i_inum2big (result
));
4143 else if (SCM_BIGP (y
))
4148 else if (SCM_REALP (y
) && scm_is_integer (y
))
4149 goto handle_inexacts
;
4151 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4153 else if (SCM_BIGP (x
))
4155 if (SCM_I_INUMP (y
))
4160 yy
= SCM_I_INUM (y
);
4165 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4166 scm_remember_upto_here_1 (x
);
4167 return (SCM_POSFIXABLE (result
)
4168 ? SCM_I_MAKINUM (result
)
4169 : scm_from_unsigned_integer (result
));
4171 else if (SCM_BIGP (y
))
4173 SCM result
= scm_i_mkbig ();
4174 mpz_gcd (SCM_I_BIG_MPZ (result
),
4177 scm_remember_upto_here_2 (x
, y
);
4178 return scm_i_normbig (result
);
4180 else if (SCM_REALP (y
) && scm_is_integer (y
))
4181 goto handle_inexacts
;
4183 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4185 else if (SCM_REALP (x
) && scm_is_integer (x
))
4187 if (SCM_I_INUMP (y
) || SCM_BIGP (y
)
4188 || (SCM_REALP (y
) && scm_is_integer (y
)))
4191 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x
),
4192 scm_inexact_to_exact (y
)));
4195 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4198 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4201 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4202 (SCM x
, SCM y
, SCM rest
),
4203 "Return the least common multiple of the arguments.\n"
4204 "If called without arguments, 1 is returned.")
4205 #define FUNC_NAME s_scm_i_lcm
4207 while (!scm_is_null (rest
))
4208 { x
= scm_lcm (x
, y
);
4210 rest
= scm_cdr (rest
);
4212 return scm_lcm (x
, y
);
4216 #define s_lcm s_scm_i_lcm
4217 #define g_lcm g_scm_i_lcm
4220 scm_lcm (SCM n1
, SCM n2
)
4222 if (SCM_UNLIKELY (SCM_UNBNDP (n2
)))
4223 return SCM_UNBNDP (n1
) ? SCM_INUM1
: scm_abs (n1
);
4225 if (SCM_LIKELY (SCM_I_INUMP (n1
)))
4227 if (SCM_LIKELY (SCM_I_INUMP (n2
)))
4229 SCM d
= scm_gcd (n1
, n2
);
4230 if (scm_is_eq (d
, SCM_INUM0
))
4233 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4235 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4237 /* inum n1, big n2 */
4240 SCM result
= scm_i_mkbig ();
4241 scm_t_inum nn1
= SCM_I_INUM (n1
);
4242 if (nn1
== 0) return SCM_INUM0
;
4243 if (nn1
< 0) nn1
= - nn1
;
4244 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4245 scm_remember_upto_here_1 (n2
);
4249 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4250 goto handle_inexacts
;
4252 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4254 else if (SCM_LIKELY (SCM_BIGP (n1
)))
4257 if (SCM_I_INUMP (n2
))
4262 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4264 SCM result
= scm_i_mkbig ();
4265 mpz_lcm(SCM_I_BIG_MPZ (result
),
4267 SCM_I_BIG_MPZ (n2
));
4268 scm_remember_upto_here_2(n1
, n2
);
4269 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4272 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4273 goto handle_inexacts
;
4275 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4277 else if (SCM_REALP (n1
) && scm_is_integer (n1
))
4279 if (SCM_I_INUMP (n2
) || SCM_BIGP (n2
)
4280 || (SCM_REALP (n2
) && scm_is_integer (n2
)))
4283 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1
),
4284 scm_inexact_to_exact (n2
)));
4287 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4290 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4293 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4298 + + + x (map digit:logand X Y)
4299 + - + x (map digit:logand X (lognot (+ -1 Y)))
4300 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4301 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4306 + + + (map digit:logior X Y)
4307 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4308 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4309 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4314 + + + (map digit:logxor X Y)
4315 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4316 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4317 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4322 + + (any digit:logand X Y)
4323 + - (any digit:logand X (lognot (+ -1 Y)))
4324 - + (any digit:logand (lognot (+ -1 X)) Y)
4329 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4330 (SCM x
, SCM y
, SCM rest
),
4331 "Return the bitwise AND of the integer arguments.\n\n"
4333 "(logand) @result{} -1\n"
4334 "(logand 7) @result{} 7\n"
4335 "(logand #b111 #b011 #b001) @result{} 1\n"
4337 #define FUNC_NAME s_scm_i_logand
4339 while (!scm_is_null (rest
))
4340 { x
= scm_logand (x
, y
);
4342 rest
= scm_cdr (rest
);
4344 return scm_logand (x
, y
);
4348 #define s_scm_logand s_scm_i_logand
4350 SCM
scm_logand (SCM n1
, SCM n2
)
4351 #define FUNC_NAME s_scm_logand
4355 if (SCM_UNBNDP (n2
))
4357 if (SCM_UNBNDP (n1
))
4358 return SCM_I_MAKINUM (-1);
4359 else if (!SCM_NUMBERP (n1
))
4360 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4361 else if (SCM_NUMBERP (n1
))
4364 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4367 if (SCM_I_INUMP (n1
))
4369 nn1
= SCM_I_INUM (n1
);
4370 if (SCM_I_INUMP (n2
))
4372 scm_t_inum nn2
= SCM_I_INUM (n2
);
4373 return SCM_I_MAKINUM (nn1
& nn2
);
4375 else if SCM_BIGP (n2
)
4381 SCM result_z
= scm_i_mkbig ();
4383 mpz_init_set_si (nn1_z
, nn1
);
4384 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4385 scm_remember_upto_here_1 (n2
);
4387 return scm_i_normbig (result_z
);
4391 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4393 else if (SCM_BIGP (n1
))
4395 if (SCM_I_INUMP (n2
))
4398 nn1
= SCM_I_INUM (n1
);
4401 else if (SCM_BIGP (n2
))
4403 SCM result_z
= scm_i_mkbig ();
4404 mpz_and (SCM_I_BIG_MPZ (result_z
),
4406 SCM_I_BIG_MPZ (n2
));
4407 scm_remember_upto_here_2 (n1
, n2
);
4408 return scm_i_normbig (result_z
);
4411 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4414 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4419 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4420 (SCM x
, SCM y
, SCM rest
),
4421 "Return the bitwise OR of the integer arguments.\n\n"
4423 "(logior) @result{} 0\n"
4424 "(logior 7) @result{} 7\n"
4425 "(logior #b000 #b001 #b011) @result{} 3\n"
4427 #define FUNC_NAME s_scm_i_logior
4429 while (!scm_is_null (rest
))
4430 { x
= scm_logior (x
, y
);
4432 rest
= scm_cdr (rest
);
4434 return scm_logior (x
, y
);
4438 #define s_scm_logior s_scm_i_logior
4440 SCM
scm_logior (SCM n1
, SCM n2
)
4441 #define FUNC_NAME s_scm_logior
4445 if (SCM_UNBNDP (n2
))
4447 if (SCM_UNBNDP (n1
))
4449 else if (SCM_NUMBERP (n1
))
4452 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4455 if (SCM_I_INUMP (n1
))
4457 nn1
= SCM_I_INUM (n1
);
4458 if (SCM_I_INUMP (n2
))
4460 long nn2
= SCM_I_INUM (n2
);
4461 return SCM_I_MAKINUM (nn1
| nn2
);
4463 else if (SCM_BIGP (n2
))
4469 SCM result_z
= scm_i_mkbig ();
4471 mpz_init_set_si (nn1_z
, nn1
);
4472 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4473 scm_remember_upto_here_1 (n2
);
4475 return scm_i_normbig (result_z
);
4479 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4481 else if (SCM_BIGP (n1
))
4483 if (SCM_I_INUMP (n2
))
4486 nn1
= SCM_I_INUM (n1
);
4489 else if (SCM_BIGP (n2
))
4491 SCM result_z
= scm_i_mkbig ();
4492 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4494 SCM_I_BIG_MPZ (n2
));
4495 scm_remember_upto_here_2 (n1
, n2
);
4496 return scm_i_normbig (result_z
);
4499 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4502 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4507 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4508 (SCM x
, SCM y
, SCM rest
),
4509 "Return the bitwise XOR of the integer arguments. A bit is\n"
4510 "set in the result if it is set in an odd number of arguments.\n"
4512 "(logxor) @result{} 0\n"
4513 "(logxor 7) @result{} 7\n"
4514 "(logxor #b000 #b001 #b011) @result{} 2\n"
4515 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4517 #define FUNC_NAME s_scm_i_logxor
4519 while (!scm_is_null (rest
))
4520 { x
= scm_logxor (x
, y
);
4522 rest
= scm_cdr (rest
);
4524 return scm_logxor (x
, y
);
4528 #define s_scm_logxor s_scm_i_logxor
4530 SCM
scm_logxor (SCM n1
, SCM n2
)
4531 #define FUNC_NAME s_scm_logxor
4535 if (SCM_UNBNDP (n2
))
4537 if (SCM_UNBNDP (n1
))
4539 else if (SCM_NUMBERP (n1
))
4542 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4545 if (SCM_I_INUMP (n1
))
4547 nn1
= SCM_I_INUM (n1
);
4548 if (SCM_I_INUMP (n2
))
4550 scm_t_inum nn2
= SCM_I_INUM (n2
);
4551 return SCM_I_MAKINUM (nn1
^ nn2
);
4553 else if (SCM_BIGP (n2
))
4557 SCM result_z
= scm_i_mkbig ();
4559 mpz_init_set_si (nn1_z
, nn1
);
4560 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4561 scm_remember_upto_here_1 (n2
);
4563 return scm_i_normbig (result_z
);
4567 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4569 else if (SCM_BIGP (n1
))
4571 if (SCM_I_INUMP (n2
))
4574 nn1
= SCM_I_INUM (n1
);
4577 else if (SCM_BIGP (n2
))
4579 SCM result_z
= scm_i_mkbig ();
4580 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4582 SCM_I_BIG_MPZ (n2
));
4583 scm_remember_upto_here_2 (n1
, n2
);
4584 return scm_i_normbig (result_z
);
4587 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4590 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4595 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4597 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4598 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4599 "without actually calculating the @code{logand}, just testing\n"
4603 "(logtest #b0100 #b1011) @result{} #f\n"
4604 "(logtest #b0100 #b0111) @result{} #t\n"
4606 #define FUNC_NAME s_scm_logtest
4610 if (SCM_I_INUMP (j
))
4612 nj
= SCM_I_INUM (j
);
4613 if (SCM_I_INUMP (k
))
4615 scm_t_inum nk
= SCM_I_INUM (k
);
4616 return scm_from_bool (nj
& nk
);
4618 else if (SCM_BIGP (k
))
4626 mpz_init_set_si (nj_z
, nj
);
4627 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4628 scm_remember_upto_here_1 (k
);
4629 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4635 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4637 else if (SCM_BIGP (j
))
4639 if (SCM_I_INUMP (k
))
4642 nj
= SCM_I_INUM (j
);
4645 else if (SCM_BIGP (k
))
4649 mpz_init (result_z
);
4653 scm_remember_upto_here_2 (j
, k
);
4654 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4655 mpz_clear (result_z
);
4659 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4662 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4667 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4669 "Test whether bit number @var{index} in @var{j} is set.\n"
4670 "@var{index} starts from 0 for the least significant bit.\n"
4673 "(logbit? 0 #b1101) @result{} #t\n"
4674 "(logbit? 1 #b1101) @result{} #f\n"
4675 "(logbit? 2 #b1101) @result{} #t\n"
4676 "(logbit? 3 #b1101) @result{} #t\n"
4677 "(logbit? 4 #b1101) @result{} #f\n"
4679 #define FUNC_NAME s_scm_logbit_p
4681 unsigned long int iindex
;
4682 iindex
= scm_to_ulong (index
);
4684 if (SCM_I_INUMP (j
))
4686 /* bits above what's in an inum follow the sign bit */
4687 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4688 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4690 else if (SCM_BIGP (j
))
4692 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4693 scm_remember_upto_here_1 (j
);
4694 return scm_from_bool (val
);
4697 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4702 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4704 "Return the integer which is the ones-complement of the integer\n"
4708 "(number->string (lognot #b10000000) 2)\n"
4709 " @result{} \"-10000001\"\n"
4710 "(number->string (lognot #b0) 2)\n"
4711 " @result{} \"-1\"\n"
4713 #define FUNC_NAME s_scm_lognot
4715 if (SCM_I_INUMP (n
)) {
4716 /* No overflow here, just need to toggle all the bits making up the inum.
4717 Enhancement: No need to strip the tag and add it back, could just xor
4718 a block of 1 bits, if that worked with the various debug versions of
4720 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4722 } else if (SCM_BIGP (n
)) {
4723 SCM result
= scm_i_mkbig ();
4724 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4725 scm_remember_upto_here_1 (n
);
4729 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4734 /* returns 0 if IN is not an integer. OUT must already be
4737 coerce_to_big (SCM in
, mpz_t out
)
4740 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4741 else if (SCM_I_INUMP (in
))
4742 mpz_set_si (out
, SCM_I_INUM (in
));
4749 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4750 (SCM n
, SCM k
, SCM m
),
4751 "Return @var{n} raised to the integer exponent\n"
4752 "@var{k}, modulo @var{m}.\n"
4755 "(modulo-expt 2 3 5)\n"
4758 #define FUNC_NAME s_scm_modulo_expt
4764 /* There are two classes of error we might encounter --
4765 1) Math errors, which we'll report by calling scm_num_overflow,
4767 2) wrong-type errors, which of course we'll report by calling
4769 We don't report those errors immediately, however; instead we do
4770 some cleanup first. These variables tell us which error (if
4771 any) we should report after cleaning up.
4773 int report_overflow
= 0;
4775 int position_of_wrong_type
= 0;
4776 SCM value_of_wrong_type
= SCM_INUM0
;
4778 SCM result
= SCM_UNDEFINED
;
4784 if (scm_is_eq (m
, SCM_INUM0
))
4786 report_overflow
= 1;
4790 if (!coerce_to_big (n
, n_tmp
))
4792 value_of_wrong_type
= n
;
4793 position_of_wrong_type
= 1;
4797 if (!coerce_to_big (k
, k_tmp
))
4799 value_of_wrong_type
= k
;
4800 position_of_wrong_type
= 2;
4804 if (!coerce_to_big (m
, m_tmp
))
4806 value_of_wrong_type
= m
;
4807 position_of_wrong_type
= 3;
4811 /* if the exponent K is negative, and we simply call mpz_powm, we
4812 will get a divide-by-zero exception when an inverse 1/n mod m
4813 doesn't exist (or is not unique). Since exceptions are hard to
4814 handle, we'll attempt the inversion "by hand" -- that way, we get
4815 a simple failure code, which is easy to handle. */
4817 if (-1 == mpz_sgn (k_tmp
))
4819 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4821 report_overflow
= 1;
4824 mpz_neg (k_tmp
, k_tmp
);
4827 result
= scm_i_mkbig ();
4828 mpz_powm (SCM_I_BIG_MPZ (result
),
4833 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4834 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4841 if (report_overflow
)
4842 scm_num_overflow (FUNC_NAME
);
4844 if (position_of_wrong_type
)
4845 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4846 value_of_wrong_type
);
4848 return scm_i_normbig (result
);
4852 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4854 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4855 "exact integer, @var{n} can be any number.\n"
4857 "Negative @var{k} is supported, and results in\n"
4858 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4859 "@math{@var{n}^0} is 1, as usual, and that\n"
4860 "includes @math{0^0} is 1.\n"
4863 "(integer-expt 2 5) @result{} 32\n"
4864 "(integer-expt -3 3) @result{} -27\n"
4865 "(integer-expt 5 -3) @result{} 1/125\n"
4866 "(integer-expt 0 0) @result{} 1\n"
4868 #define FUNC_NAME s_scm_integer_expt
4871 SCM z_i2
= SCM_BOOL_F
;
4873 SCM acc
= SCM_I_MAKINUM (1L);
4875 /* Specifically refrain from checking the type of the first argument.
4876 This allows us to exponentiate any object that can be multiplied.
4877 If we must raise to a negative power, we must also be able to
4878 take its reciprocal. */
4879 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4880 SCM_WRONG_TYPE_ARG (2, k
);
4882 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4883 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4884 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4885 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4886 /* The next check is necessary only because R6RS specifies different
4887 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4888 we simply skip this case and move on. */
4889 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4891 /* k cannot be 0 at this point, because we
4892 have already checked for that case above */
4893 if (scm_is_true (scm_positive_p (k
)))
4895 else /* return NaN for (0 ^ k) for negative k per R6RS */
4898 else if (SCM_FRACTIONP (n
))
4900 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4901 needless reduction of intermediate products to lowest terms.
4902 If a and b have no common factors, then a^k and b^k have no
4903 common factors. Use 'scm_i_make_ratio_already_reduced' to
4904 construct the final result, so that no gcd computations are
4905 needed to exponentiate a fraction. */
4906 if (scm_is_true (scm_positive_p (k
)))
4907 return scm_i_make_ratio_already_reduced
4908 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4909 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4912 k
= scm_difference (k
, SCM_UNDEFINED
);
4913 return scm_i_make_ratio_already_reduced
4914 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4915 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4919 if (SCM_I_INUMP (k
))
4920 i2
= SCM_I_INUM (k
);
4921 else if (SCM_BIGP (k
))
4923 z_i2
= scm_i_clonebig (k
, 1);
4924 scm_remember_upto_here_1 (k
);
4928 SCM_WRONG_TYPE_ARG (2, k
);
4932 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4934 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4935 n
= scm_divide (n
, SCM_UNDEFINED
);
4939 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4943 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4945 return scm_product (acc
, n
);
4947 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4948 acc
= scm_product (acc
, n
);
4949 n
= scm_product (n
, n
);
4950 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4958 n
= scm_divide (n
, SCM_UNDEFINED
);
4965 return scm_product (acc
, n
);
4967 acc
= scm_product (acc
, n
);
4968 n
= scm_product (n
, n
);
4975 /* Efficiently compute (N * 2^COUNT),
4976 where N is an exact integer, and COUNT > 0. */
4978 left_shift_exact_integer (SCM n
, long count
)
4980 if (SCM_I_INUMP (n
))
4982 scm_t_inum nn
= SCM_I_INUM (n
);
4984 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4985 overflow a non-zero fixnum. For smaller shifts we check the
4986 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4987 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4988 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4992 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4993 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4995 return SCM_I_MAKINUM (nn
<< count
);
4998 SCM result
= scm_i_inum2big (nn
);
4999 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5004 else if (SCM_BIGP (n
))
5006 SCM result
= scm_i_mkbig ();
5007 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5008 scm_remember_upto_here_1 (n
);
5012 scm_syserror ("left_shift_exact_integer");
5015 /* Efficiently compute floor (N / 2^COUNT),
5016 where N is an exact integer and COUNT > 0. */
5018 floor_right_shift_exact_integer (SCM n
, long count
)
5020 if (SCM_I_INUMP (n
))
5022 scm_t_inum nn
= SCM_I_INUM (n
);
5024 if (count
>= SCM_I_FIXNUM_BIT
)
5025 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5027 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5029 else if (SCM_BIGP (n
))
5031 SCM result
= scm_i_mkbig ();
5032 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5034 scm_remember_upto_here_1 (n
);
5035 return scm_i_normbig (result
);
5038 scm_syserror ("floor_right_shift_exact_integer");
5041 /* Efficiently compute round (N / 2^COUNT),
5042 where N is an exact integer and COUNT > 0. */
5044 round_right_shift_exact_integer (SCM n
, long count
)
5046 if (SCM_I_INUMP (n
))
5048 if (count
>= SCM_I_FIXNUM_BIT
)
5052 scm_t_inum nn
= SCM_I_INUM (n
);
5053 scm_t_inum qq
= SCM_SRS (nn
, count
);
5055 if (0 == (nn
& (1L << (count
-1))))
5056 return SCM_I_MAKINUM (qq
); /* round down */
5057 else if (nn
& ((1L << (count
-1)) - 1))
5058 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5060 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5063 else if (SCM_BIGP (n
))
5065 SCM q
= scm_i_mkbig ();
5067 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5068 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5069 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5070 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5071 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5072 scm_remember_upto_here_1 (n
);
5073 return scm_i_normbig (q
);
5076 scm_syserror ("round_right_shift_exact_integer");
5079 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5081 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5082 "@var{n} and @var{count} must be exact integers.\n"
5084 "With @var{n} viewed as an infinite-precision twos-complement\n"
5085 "integer, @code{ash} means a left shift introducing zero bits\n"
5086 "when @var{count} is positive, or a right shift dropping bits\n"
5087 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5090 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5091 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5093 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5094 "(ash -23 -2) @result{} -6\n"
5096 #define FUNC_NAME s_scm_ash
5098 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5100 long bits_to_shift
= scm_to_long (count
);
5102 if (bits_to_shift
> 0)
5103 return left_shift_exact_integer (n
, bits_to_shift
);
5104 else if (SCM_LIKELY (bits_to_shift
< 0))
5105 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5110 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5114 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5116 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5117 "@var{n} and @var{count} must be exact integers.\n"
5119 "With @var{n} viewed as an infinite-precision twos-complement\n"
5120 "integer, @code{round-ash} means a left shift introducing zero\n"
5121 "bits when @var{count} is positive, or a right shift rounding\n"
5122 "to the nearest integer (with ties going to the nearest even\n"
5123 "integer) when @var{count} is negative. This is a rounded\n"
5124 "``arithmetic'' shift.\n"
5127 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5128 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5129 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5130 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5131 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5132 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5134 #define FUNC_NAME s_scm_round_ash
5136 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5138 long bits_to_shift
= scm_to_long (count
);
5140 if (bits_to_shift
> 0)
5141 return left_shift_exact_integer (n
, bits_to_shift
);
5142 else if (SCM_LIKELY (bits_to_shift
< 0))
5143 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5148 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5153 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5154 (SCM n
, SCM start
, SCM end
),
5155 "Return the integer composed of the @var{start} (inclusive)\n"
5156 "through @var{end} (exclusive) bits of @var{n}. The\n"
5157 "@var{start}th bit becomes the 0-th bit in the result.\n"
5160 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5161 " @result{} \"1010\"\n"
5162 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5163 " @result{} \"10110\"\n"
5165 #define FUNC_NAME s_scm_bit_extract
5167 unsigned long int istart
, iend
, bits
;
5168 istart
= scm_to_ulong (start
);
5169 iend
= scm_to_ulong (end
);
5170 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5172 /* how many bits to keep */
5173 bits
= iend
- istart
;
5175 if (SCM_I_INUMP (n
))
5177 scm_t_inum in
= SCM_I_INUM (n
);
5179 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5180 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5181 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5183 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5185 /* Since we emulate two's complement encoded numbers, this
5186 * special case requires us to produce a result that has
5187 * more bits than can be stored in a fixnum.
5189 SCM result
= scm_i_inum2big (in
);
5190 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5195 /* mask down to requisite bits */
5196 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5197 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5199 else if (SCM_BIGP (n
))
5204 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5208 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5209 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5210 such bits into a ulong. */
5211 result
= scm_i_mkbig ();
5212 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5213 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5214 result
= scm_i_normbig (result
);
5216 scm_remember_upto_here_1 (n
);
5220 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5225 static const char scm_logtab
[] = {
5226 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5229 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5231 "Return the number of bits in integer @var{n}. If integer is\n"
5232 "positive, the 1-bits in its binary representation are counted.\n"
5233 "If negative, the 0-bits in its two's-complement binary\n"
5234 "representation are counted. If 0, 0 is returned.\n"
5237 "(logcount #b10101010)\n"
5244 #define FUNC_NAME s_scm_logcount
5246 if (SCM_I_INUMP (n
))
5248 unsigned long c
= 0;
5249 scm_t_inum nn
= SCM_I_INUM (n
);
5254 c
+= scm_logtab
[15 & nn
];
5257 return SCM_I_MAKINUM (c
);
5259 else if (SCM_BIGP (n
))
5261 unsigned long count
;
5262 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5263 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5265 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5266 scm_remember_upto_here_1 (n
);
5267 return SCM_I_MAKINUM (count
);
5270 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5275 static const char scm_ilentab
[] = {
5276 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5280 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5282 "Return the number of bits necessary to represent @var{n}.\n"
5285 "(integer-length #b10101010)\n"
5287 "(integer-length 0)\n"
5289 "(integer-length #b1111)\n"
5292 #define FUNC_NAME s_scm_integer_length
5294 if (SCM_I_INUMP (n
))
5296 unsigned long c
= 0;
5298 scm_t_inum nn
= SCM_I_INUM (n
);
5304 l
= scm_ilentab
[15 & nn
];
5307 return SCM_I_MAKINUM (c
- 4 + l
);
5309 else if (SCM_BIGP (n
))
5311 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5312 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5313 1 too big, so check for that and adjust. */
5314 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5315 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5316 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5317 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5319 scm_remember_upto_here_1 (n
);
5320 return SCM_I_MAKINUM (size
);
5323 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5327 /*** NUMBERS -> STRINGS ***/
5328 #define SCM_MAX_DBL_RADIX 36
5330 /* use this array as a way to generate a single digit */
5331 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5333 static mpz_t dbl_minimum_normal_mantissa
;
5336 idbl2str (double dbl
, char *a
, int radix
)
5340 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5341 /* revert to existing behavior */
5346 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5356 else if (dbl
== 0.0)
5358 if (!double_is_non_negative_zero (dbl
))
5360 strcpy (a
+ ch
, "0.0");
5363 else if (isnan (dbl
))
5365 strcpy (a
, "+nan.0");
5369 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5370 Accurately" by Robert G. Burger and R. Kent Dybvig */
5373 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5374 int f_is_even
, f_is_odd
;
5378 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5379 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5380 if (e
< DBL_MIN_EXP
)
5382 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5387 f_is_even
= !mpz_odd_p (f
);
5388 f_is_odd
= !f_is_even
;
5390 /* Initialize r, s, mplus, and mminus according
5391 to Table 1 from the paper. */
5394 mpz_set_ui (mminus
, 1);
5395 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5396 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5398 mpz_set_ui (mplus
, 1);
5399 mpz_mul_2exp (r
, f
, 1);
5400 mpz_mul_2exp (s
, mminus
, 1 - e
);
5404 mpz_set_ui (mplus
, 2);
5405 mpz_mul_2exp (r
, f
, 2);
5406 mpz_mul_2exp (s
, mminus
, 2 - e
);
5411 mpz_set_ui (mminus
, 1);
5412 mpz_mul_2exp (mminus
, mminus
, e
);
5413 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5415 mpz_set (mplus
, mminus
);
5416 mpz_mul_2exp (r
, f
, 1 + e
);
5421 mpz_mul_2exp (mplus
, mminus
, 1);
5422 mpz_mul_2exp (r
, f
, 2 + e
);
5427 /* Find the smallest k such that:
5428 (r + mplus) / s < radix^k (if f is even)
5429 (r + mplus) / s <= radix^k (if f is odd) */
5431 /* IMPROVE-ME: Make an initial guess to speed this up */
5432 mpz_add (hi
, r
, mplus
);
5434 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5436 mpz_mul_ui (s
, s
, radix
);
5441 mpz_mul_ui (hi
, hi
, radix
);
5442 while (mpz_cmp (hi
, s
) < f_is_odd
)
5444 mpz_mul_ui (r
, r
, radix
);
5445 mpz_mul_ui (mplus
, mplus
, radix
);
5446 mpz_mul_ui (mminus
, mminus
, radix
);
5447 mpz_mul_ui (hi
, hi
, radix
);
5458 /* Use scientific notation */
5466 /* Print leading zeroes */
5469 for (i
= 0; i
> k
; i
--)
5476 int end_1_p
, end_2_p
;
5479 mpz_mul_ui (mplus
, mplus
, radix
);
5480 mpz_mul_ui (mminus
, mminus
, radix
);
5481 mpz_mul_ui (r
, r
, radix
);
5482 mpz_fdiv_qr (digit
, r
, r
, s
);
5483 d
= mpz_get_ui (digit
);
5485 mpz_add (hi
, r
, mplus
);
5486 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5487 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5488 if (end_1_p
|| end_2_p
)
5490 mpz_mul_2exp (r
, r
, 1);
5495 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5497 a
[ch
++] = number_chars
[d
];
5504 a
[ch
++] = number_chars
[d
];
5512 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5514 /* Here we would have to print more than three zeroes
5515 followed by a decimal point and another zero. It
5516 makes more sense to use scientific notation. */
5518 /* Adjust k to what it would have been if we had chosen
5519 scientific notation from the beginning. */
5522 /* k will now be <= 0, with magnitude equal to the number of
5523 digits that we printed which should now be put after the
5526 /* Insert a decimal point */
5527 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5547 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5550 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5557 icmplx2str (double real
, double imag
, char *str
, int radix
)
5562 i
= idbl2str (real
, str
, radix
);
5563 #ifdef HAVE_COPYSIGN
5564 sgn
= copysign (1.0, imag
);
5568 /* Don't output a '+' for negative numbers or for Inf and
5569 NaN. They will provide their own sign. */
5570 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5572 i
+= idbl2str (imag
, &str
[i
], radix
);
5578 iflo2str (SCM flt
, char *str
, int radix
)
5581 if (SCM_REALP (flt
))
5582 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5584 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5589 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5590 characters in the result.
5592 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5594 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5599 return scm_iuint2str (-num
, rad
, p
) + 1;
5602 return scm_iuint2str (num
, rad
, p
);
5605 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5606 characters in the result.
5608 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5610 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5614 scm_t_uintmax n
= num
;
5616 if (rad
< 2 || rad
> 36)
5617 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5619 for (n
/= rad
; n
> 0; n
/= rad
)
5629 p
[i
] = number_chars
[d
];
5634 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5636 "Return a string holding the external representation of the\n"
5637 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5638 "inexact, a radix of 10 will be used.")
5639 #define FUNC_NAME s_scm_number_to_string
5643 if (SCM_UNBNDP (radix
))
5646 base
= scm_to_signed_integer (radix
, 2, 36);
5648 if (SCM_I_INUMP (n
))
5650 char num_buf
[SCM_INTBUFLEN
];
5651 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5652 return scm_from_locale_stringn (num_buf
, length
);
5654 else if (SCM_BIGP (n
))
5656 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5657 size_t len
= strlen (str
);
5658 void (*freefunc
) (void *, size_t);
5660 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5661 scm_remember_upto_here_1 (n
);
5662 ret
= scm_from_latin1_stringn (str
, len
);
5663 freefunc (str
, len
+ 1);
5666 else if (SCM_FRACTIONP (n
))
5668 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5669 scm_from_locale_string ("/"),
5670 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5672 else if (SCM_INEXACTP (n
))
5674 char num_buf
[FLOBUFLEN
];
5675 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5678 SCM_WRONG_TYPE_ARG (1, n
);
5683 /* These print routines used to be stubbed here so that scm_repl.c
5684 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5687 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5689 char num_buf
[FLOBUFLEN
];
5690 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5695 scm_i_print_double (double val
, SCM port
)
5697 char num_buf
[FLOBUFLEN
];
5698 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5702 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5705 char num_buf
[FLOBUFLEN
];
5706 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5711 scm_i_print_complex (double real
, double imag
, SCM port
)
5713 char num_buf
[FLOBUFLEN
];
5714 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5718 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5721 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5722 scm_display (str
, port
);
5723 scm_remember_upto_here_1 (str
);
5728 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5730 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5731 size_t len
= strlen (str
);
5732 void (*freefunc
) (void *, size_t);
5733 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5734 scm_remember_upto_here_1 (exp
);
5735 scm_lfwrite (str
, len
, port
);
5736 freefunc (str
, len
+ 1);
5739 /*** END nums->strs ***/
5742 /*** STRINGS -> NUMBERS ***/
5744 /* The following functions implement the conversion from strings to numbers.
5745 * The implementation somehow follows the grammar for numbers as it is given
5746 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5747 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5748 * points should be noted about the implementation:
5750 * * Each function keeps a local index variable 'idx' that points at the
5751 * current position within the parsed string. The global index is only
5752 * updated if the function could parse the corresponding syntactic unit
5755 * * Similarly, the functions keep track of indicators of inexactness ('#',
5756 * '.' or exponents) using local variables ('hash_seen', 'x').
5758 * * Sequences of digits are parsed into temporary variables holding fixnums.
5759 * Only if these fixnums would overflow, the result variables are updated
5760 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5761 * the temporary variables holding the fixnums are cleared, and the process
5762 * starts over again. If for example fixnums were able to store five decimal
5763 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5764 * and the result was computed as 12345 * 100000 + 67890. In other words,
5765 * only every five digits two bignum operations were performed.
5767 * Notes on the handling of exactness specifiers:
5769 * When parsing non-real complex numbers, we apply exactness specifiers on
5770 * per-component basis, as is done in PLT Scheme. For complex numbers
5771 * written in rectangular form, exactness specifiers are applied to the
5772 * real and imaginary parts before calling scm_make_rectangular. For
5773 * complex numbers written in polar form, exactness specifiers are applied
5774 * to the magnitude and angle before calling scm_make_polar.
5776 * There are two kinds of exactness specifiers: forced and implicit. A
5777 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5778 * the entire number, and applies to both components of a complex number.
5779 * "#e" causes each component to be made exact, and "#i" causes each
5780 * component to be made inexact. If no forced exactness specifier is
5781 * present, then the exactness of each component is determined
5782 * independently by the presence or absence of a decimal point or hash mark
5783 * within that component. If a decimal point or hash mark is present, the
5784 * component is made inexact, otherwise it is made exact.
5786 * After the exactness specifiers have been applied to each component, they
5787 * are passed to either scm_make_rectangular or scm_make_polar to produce
5788 * the final result. Note that this will result in a real number if the
5789 * imaginary part, magnitude, or angle is an exact 0.
5791 * For example, (string->number "#i5.0+0i") does the equivalent of:
5793 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5796 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5798 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5800 /* Caller is responsible for checking that the return value is in range
5801 for the given radix, which should be <= 36. */
5803 char_decimal_value (scm_t_uint32 c
)
5805 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5806 that's certainly above any valid decimal, so we take advantage of
5807 that to elide some tests. */
5808 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5810 /* If that failed, try extended hexadecimals, then. Only accept ascii
5815 if (c
>= (scm_t_uint32
) 'a')
5816 d
= c
- (scm_t_uint32
)'a' + 10U;
5821 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5822 in base RADIX. Upon success, return the unsigned integer and update
5823 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5825 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5826 unsigned int radix
, enum t_exactness
*p_exactness
)
5828 unsigned int idx
= *p_idx
;
5829 unsigned int hash_seen
= 0;
5830 scm_t_bits shift
= 1;
5832 unsigned int digit_value
;
5835 size_t len
= scm_i_string_length (mem
);
5840 c
= scm_i_string_ref (mem
, idx
);
5841 digit_value
= char_decimal_value (c
);
5842 if (digit_value
>= radix
)
5846 result
= SCM_I_MAKINUM (digit_value
);
5849 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5859 digit_value
= char_decimal_value (c
);
5860 /* This check catches non-decimals in addition to out-of-range
5862 if (digit_value
>= radix
)
5867 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5869 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5871 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5878 shift
= shift
* radix
;
5879 add
= add
* radix
+ digit_value
;
5884 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5886 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5890 *p_exactness
= INEXACT
;
5896 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5897 * covers the parts of the rules that start at a potential point. The value
5898 * of the digits up to the point have been parsed by the caller and are given
5899 * in variable result. The content of *p_exactness indicates, whether a hash
5900 * has already been seen in the digits before the point.
5903 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5906 mem2decimal_from_point (SCM result
, SCM mem
,
5907 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5909 unsigned int idx
= *p_idx
;
5910 enum t_exactness x
= *p_exactness
;
5911 size_t len
= scm_i_string_length (mem
);
5916 if (scm_i_string_ref (mem
, idx
) == '.')
5918 scm_t_bits shift
= 1;
5920 unsigned int digit_value
;
5921 SCM big_shift
= SCM_INUM1
;
5926 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5927 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5932 digit_value
= DIGIT2UINT (c
);
5943 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5945 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5946 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5948 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5956 add
= add
* 10 + digit_value
;
5962 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5963 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5964 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5967 result
= scm_divide (result
, big_shift
);
5969 /* We've seen a decimal point, thus the value is implicitly inexact. */
5981 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5983 switch (scm_i_string_ref (mem
, idx
))
5995 c
= scm_i_string_ref (mem
, idx
);
6003 c
= scm_i_string_ref (mem
, idx
);
6012 c
= scm_i_string_ref (mem
, idx
);
6017 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6021 exponent
= DIGIT2UINT (c
);
6024 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6025 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6028 if (exponent
<= SCM_MAXEXP
)
6029 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6035 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6037 size_t exp_len
= idx
- start
;
6038 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6039 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6040 scm_out_of_range ("string->number", exp_num
);
6043 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6045 result
= scm_product (result
, e
);
6047 result
= scm_divide (result
, e
);
6049 /* We've seen an exponent, thus the value is implicitly inexact. */
6067 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6070 mem2ureal (SCM mem
, unsigned int *p_idx
,
6071 unsigned int radix
, enum t_exactness forced_x
,
6072 int allow_inf_or_nan
)
6074 unsigned int idx
= *p_idx
;
6076 size_t len
= scm_i_string_length (mem
);
6078 /* Start off believing that the number will be exact. This changes
6079 to INEXACT if we see a decimal point or a hash. */
6080 enum t_exactness implicit_x
= EXACT
;
6085 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6086 switch (scm_i_string_ref (mem
, idx
))
6089 switch (scm_i_string_ref (mem
, idx
+ 1))
6092 switch (scm_i_string_ref (mem
, idx
+ 2))
6095 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6096 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6104 switch (scm_i_string_ref (mem
, idx
+ 1))
6107 switch (scm_i_string_ref (mem
, idx
+ 2))
6110 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6112 /* Cobble up the fractional part. We might want to
6113 set the NaN's mantissa from it. */
6115 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6118 #if SCM_ENABLE_DEPRECATED == 1
6119 scm_c_issue_deprecation_warning
6120 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6133 if (scm_i_string_ref (mem
, idx
) == '.')
6137 else if (idx
+ 1 == len
)
6139 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6142 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6143 p_idx
, &implicit_x
);
6149 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6150 if (scm_is_false (uinteger
))
6155 else if (scm_i_string_ref (mem
, idx
) == '/')
6163 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6164 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6167 /* both are int/big here, I assume */
6168 result
= scm_i_make_ratio (uinteger
, divisor
);
6170 else if (radix
== 10)
6172 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6173 if (scm_is_false (result
))
6185 if (SCM_INEXACTP (result
))
6186 return scm_inexact_to_exact (result
);
6190 if (SCM_INEXACTP (result
))
6193 return scm_exact_to_inexact (result
);
6195 if (implicit_x
== INEXACT
)
6197 if (SCM_INEXACTP (result
))
6200 return scm_exact_to_inexact (result
);
6206 /* We should never get here */
6207 scm_syserror ("mem2ureal");
6211 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6214 mem2complex (SCM mem
, unsigned int idx
,
6215 unsigned int radix
, enum t_exactness forced_x
)
6220 size_t len
= scm_i_string_length (mem
);
6225 c
= scm_i_string_ref (mem
, idx
);
6240 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6241 if (scm_is_false (ureal
))
6243 /* input must be either +i or -i */
6248 if (scm_i_string_ref (mem
, idx
) == 'i'
6249 || scm_i_string_ref (mem
, idx
) == 'I')
6255 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6262 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6263 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6268 c
= scm_i_string_ref (mem
, idx
);
6272 /* either +<ureal>i or -<ureal>i */
6279 return scm_make_rectangular (SCM_INUM0
, ureal
);
6282 /* polar input: <real>@<real>. */
6293 c
= scm_i_string_ref (mem
, idx
);
6311 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6312 if (scm_is_false (angle
))
6317 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6318 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6320 result
= scm_make_polar (ureal
, angle
);
6325 /* expecting input matching <real>[+-]<ureal>?i */
6332 int sign
= (c
== '+') ? 1 : -1;
6333 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6335 if (scm_is_false (imag
))
6336 imag
= SCM_I_MAKINUM (sign
);
6337 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6338 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6342 if (scm_i_string_ref (mem
, idx
) != 'i'
6343 && scm_i_string_ref (mem
, idx
) != 'I')
6350 return scm_make_rectangular (ureal
, imag
);
6359 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6361 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6364 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6366 unsigned int idx
= 0;
6367 unsigned int radix
= NO_RADIX
;
6368 enum t_exactness forced_x
= NO_EXACTNESS
;
6369 size_t len
= scm_i_string_length (mem
);
6371 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6372 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6374 switch (scm_i_string_ref (mem
, idx
+ 1))
6377 if (radix
!= NO_RADIX
)
6382 if (radix
!= NO_RADIX
)
6387 if (forced_x
!= NO_EXACTNESS
)
6392 if (forced_x
!= NO_EXACTNESS
)
6397 if (radix
!= NO_RADIX
)
6402 if (radix
!= NO_RADIX
)
6412 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6413 if (radix
== NO_RADIX
)
6414 radix
= default_radix
;
6416 return mem2complex (mem
, idx
, radix
, forced_x
);
6420 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6421 unsigned int default_radix
)
6423 SCM str
= scm_from_locale_stringn (mem
, len
);
6425 return scm_i_string_to_number (str
, default_radix
);
6429 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6430 (SCM string
, SCM radix
),
6431 "Return a number of the maximally precise representation\n"
6432 "expressed by the given @var{string}. @var{radix} must be an\n"
6433 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6434 "is a default radix that may be overridden by an explicit radix\n"
6435 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6436 "supplied, then the default radix is 10. If string is not a\n"
6437 "syntactically valid notation for a number, then\n"
6438 "@code{string->number} returns @code{#f}.")
6439 #define FUNC_NAME s_scm_string_to_number
6443 SCM_VALIDATE_STRING (1, string
);
6445 if (SCM_UNBNDP (radix
))
6448 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6450 answer
= scm_i_string_to_number (string
, base
);
6451 scm_remember_upto_here_1 (string
);
6457 /*** END strs->nums ***/
6460 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6462 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6464 #define FUNC_NAME s_scm_number_p
6466 return scm_from_bool (SCM_NUMBERP (x
));
6470 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6472 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6473 "otherwise. Note that the sets of real, rational and integer\n"
6474 "values form subsets of the set of complex numbers, i. e. the\n"
6475 "predicate will also be fulfilled if @var{x} is a real,\n"
6476 "rational or integer number.")
6477 #define FUNC_NAME s_scm_complex_p
6479 /* all numbers are complex. */
6480 return scm_number_p (x
);
6484 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6486 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6487 "otherwise. Note that the set of integer values forms a subset of\n"
6488 "the set of real numbers, i. e. the predicate will also be\n"
6489 "fulfilled if @var{x} is an integer number.")
6490 #define FUNC_NAME s_scm_real_p
6492 return scm_from_bool
6493 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6497 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6499 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6500 "otherwise. Note that the set of integer values forms a subset of\n"
6501 "the set of rational numbers, i. e. the predicate will also be\n"
6502 "fulfilled if @var{x} is an integer number.")
6503 #define FUNC_NAME s_scm_rational_p
6505 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6507 else if (SCM_REALP (x
))
6508 /* due to their limited precision, finite floating point numbers are
6509 rational as well. (finite means neither infinity nor a NaN) */
6510 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6516 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6518 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6520 #define FUNC_NAME s_scm_integer_p
6522 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6524 else if (SCM_REALP (x
))
6526 double val
= SCM_REAL_VALUE (x
);
6527 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6535 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6536 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6537 (SCM x
, SCM y
, SCM rest
),
6538 "Return @code{#t} if all parameters are numerically equal.")
6539 #define FUNC_NAME s_scm_i_num_eq_p
6541 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6543 while (!scm_is_null (rest
))
6545 if (scm_is_false (scm_num_eq_p (x
, y
)))
6549 rest
= scm_cdr (rest
);
6551 return scm_num_eq_p (x
, y
);
6555 scm_num_eq_p (SCM x
, SCM y
)
6558 if (SCM_I_INUMP (x
))
6560 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6561 if (SCM_I_INUMP (y
))
6563 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6564 return scm_from_bool (xx
== yy
);
6566 else if (SCM_BIGP (y
))
6568 else if (SCM_REALP (y
))
6570 /* On a 32-bit system an inum fits a double, we can cast the inum
6571 to a double and compare.
6573 But on a 64-bit system an inum is bigger than a double and
6574 casting it to a double (call that dxx) will round.
6575 Although dxx will not in general be equal to xx, dxx will
6576 always be an integer and within a factor of 2 of xx, so if
6577 dxx==yy, we know that yy is an integer and fits in
6578 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6579 compare with plain xx.
6581 An alternative (for any size system actually) would be to check
6582 yy is an integer (with floor) and is in range of an inum
6583 (compare against appropriate powers of 2) then test
6584 xx==(scm_t_signed_bits)yy. It's just a matter of which
6585 casts/comparisons might be fastest or easiest for the cpu. */
6587 double yy
= SCM_REAL_VALUE (y
);
6588 return scm_from_bool ((double) xx
== yy
6589 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6590 || xx
== (scm_t_signed_bits
) yy
));
6592 else if (SCM_COMPLEXP (y
))
6594 /* see comments with inum/real above */
6595 double ry
= SCM_COMPLEX_REAL (y
);
6596 return scm_from_bool ((double) xx
== ry
6597 && 0.0 == SCM_COMPLEX_IMAG (y
)
6598 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6599 || xx
== (scm_t_signed_bits
) ry
));
6601 else if (SCM_FRACTIONP (y
))
6604 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6606 else if (SCM_BIGP (x
))
6608 if (SCM_I_INUMP (y
))
6610 else if (SCM_BIGP (y
))
6612 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6613 scm_remember_upto_here_2 (x
, y
);
6614 return scm_from_bool (0 == cmp
);
6616 else if (SCM_REALP (y
))
6619 if (isnan (SCM_REAL_VALUE (y
)))
6621 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6622 scm_remember_upto_here_1 (x
);
6623 return scm_from_bool (0 == cmp
);
6625 else if (SCM_COMPLEXP (y
))
6628 if (0.0 != SCM_COMPLEX_IMAG (y
))
6630 if (isnan (SCM_COMPLEX_REAL (y
)))
6632 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6633 scm_remember_upto_here_1 (x
);
6634 return scm_from_bool (0 == cmp
);
6636 else if (SCM_FRACTIONP (y
))
6639 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6641 else if (SCM_REALP (x
))
6643 double xx
= SCM_REAL_VALUE (x
);
6644 if (SCM_I_INUMP (y
))
6646 /* see comments with inum/real above */
6647 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6648 return scm_from_bool (xx
== (double) yy
6649 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6650 || (scm_t_signed_bits
) xx
== yy
));
6652 else if (SCM_BIGP (y
))
6657 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6658 scm_remember_upto_here_1 (y
);
6659 return scm_from_bool (0 == cmp
);
6661 else if (SCM_REALP (y
))
6662 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6663 else if (SCM_COMPLEXP (y
))
6664 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6665 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6666 else if (SCM_FRACTIONP (y
))
6668 if (isnan (xx
) || isinf (xx
))
6670 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6674 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6676 else if (SCM_COMPLEXP (x
))
6678 if (SCM_I_INUMP (y
))
6680 /* see comments with inum/real above */
6681 double rx
= SCM_COMPLEX_REAL (x
);
6682 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6683 return scm_from_bool (rx
== (double) yy
6684 && 0.0 == SCM_COMPLEX_IMAG (x
)
6685 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6686 || (scm_t_signed_bits
) rx
== yy
));
6688 else if (SCM_BIGP (y
))
6691 if (0.0 != SCM_COMPLEX_IMAG (x
))
6693 if (isnan (SCM_COMPLEX_REAL (x
)))
6695 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6696 scm_remember_upto_here_1 (y
);
6697 return scm_from_bool (0 == cmp
);
6699 else if (SCM_REALP (y
))
6700 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6701 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6702 else if (SCM_COMPLEXP (y
))
6703 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6704 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6705 else if (SCM_FRACTIONP (y
))
6708 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6710 xx
= SCM_COMPLEX_REAL (x
);
6711 if (isnan (xx
) || isinf (xx
))
6713 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6717 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6719 else if (SCM_FRACTIONP (x
))
6721 if (SCM_I_INUMP (y
))
6723 else if (SCM_BIGP (y
))
6725 else if (SCM_REALP (y
))
6727 double yy
= SCM_REAL_VALUE (y
);
6728 if (isnan (yy
) || isinf (yy
))
6730 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6733 else if (SCM_COMPLEXP (y
))
6736 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6738 yy
= SCM_COMPLEX_REAL (y
);
6739 if (isnan (yy
) || isinf(yy
))
6741 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6744 else if (SCM_FRACTIONP (y
))
6745 return scm_i_fraction_equalp (x
, y
);
6747 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6750 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6754 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6755 done are good for inums, but for bignums an answer can almost always be
6756 had by just examining a few high bits of the operands, as done by GMP in
6757 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6758 of the float exponent to take into account. */
6760 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6761 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6762 (SCM x
, SCM y
, SCM rest
),
6763 "Return @code{#t} if the list of parameters is monotonically\n"
6765 #define FUNC_NAME s_scm_i_num_less_p
6767 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6769 while (!scm_is_null (rest
))
6771 if (scm_is_false (scm_less_p (x
, y
)))
6775 rest
= scm_cdr (rest
);
6777 return scm_less_p (x
, y
);
6781 scm_less_p (SCM x
, SCM y
)
6784 if (SCM_I_INUMP (x
))
6786 scm_t_inum xx
= SCM_I_INUM (x
);
6787 if (SCM_I_INUMP (y
))
6789 scm_t_inum yy
= SCM_I_INUM (y
);
6790 return scm_from_bool (xx
< yy
);
6792 else if (SCM_BIGP (y
))
6794 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6795 scm_remember_upto_here_1 (y
);
6796 return scm_from_bool (sgn
> 0);
6798 else if (SCM_REALP (y
))
6800 /* We can safely take the ceiling of y without changing the
6801 result of x<y, given that x is an integer. */
6802 double yy
= ceil (SCM_REAL_VALUE (y
));
6804 /* In the following comparisons, it's important that the right
6805 hand side always be a power of 2, so that it can be
6806 losslessly converted to a double even on 64-bit
6808 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6810 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6811 /* The condition above is carefully written to include the
6812 case where yy==NaN. */
6815 /* yy is a finite integer that fits in an inum. */
6816 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6818 else if (SCM_FRACTIONP (y
))
6820 /* "x < a/b" becomes "x*b < a" */
6822 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6823 y
= SCM_FRACTION_NUMERATOR (y
);
6827 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6829 else if (SCM_BIGP (x
))
6831 if (SCM_I_INUMP (y
))
6833 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6834 scm_remember_upto_here_1 (x
);
6835 return scm_from_bool (sgn
< 0);
6837 else if (SCM_BIGP (y
))
6839 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6840 scm_remember_upto_here_2 (x
, y
);
6841 return scm_from_bool (cmp
< 0);
6843 else if (SCM_REALP (y
))
6846 if (isnan (SCM_REAL_VALUE (y
)))
6848 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6849 scm_remember_upto_here_1 (x
);
6850 return scm_from_bool (cmp
< 0);
6852 else if (SCM_FRACTIONP (y
))
6855 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6857 else if (SCM_REALP (x
))
6859 if (SCM_I_INUMP (y
))
6861 /* We can safely take the floor of x without changing the
6862 result of x<y, given that y is an integer. */
6863 double xx
= floor (SCM_REAL_VALUE (x
));
6865 /* In the following comparisons, it's important that the right
6866 hand side always be a power of 2, so that it can be
6867 losslessly converted to a double even on 64-bit
6869 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6871 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6872 /* The condition above is carefully written to include the
6873 case where xx==NaN. */
6876 /* xx is a finite integer that fits in an inum. */
6877 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6879 else if (SCM_BIGP (y
))
6882 if (isnan (SCM_REAL_VALUE (x
)))
6884 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6885 scm_remember_upto_here_1 (y
);
6886 return scm_from_bool (cmp
> 0);
6888 else if (SCM_REALP (y
))
6889 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6890 else if (SCM_FRACTIONP (y
))
6892 double xx
= SCM_REAL_VALUE (x
);
6896 return scm_from_bool (xx
< 0.0);
6897 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6901 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6903 else if (SCM_FRACTIONP (x
))
6905 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6907 /* "a/b < y" becomes "a < y*b" */
6908 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6909 x
= SCM_FRACTION_NUMERATOR (x
);
6912 else if (SCM_REALP (y
))
6914 double yy
= SCM_REAL_VALUE (y
);
6918 return scm_from_bool (0.0 < yy
);
6919 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6922 else if (SCM_FRACTIONP (y
))
6924 /* "a/b < c/d" becomes "a*d < c*b" */
6925 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6926 SCM_FRACTION_DENOMINATOR (y
));
6927 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6928 SCM_FRACTION_DENOMINATOR (x
));
6934 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6937 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6941 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6942 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6943 (SCM x
, SCM y
, SCM rest
),
6944 "Return @code{#t} if the list of parameters is monotonically\n"
6946 #define FUNC_NAME s_scm_i_num_gr_p
6948 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6950 while (!scm_is_null (rest
))
6952 if (scm_is_false (scm_gr_p (x
, y
)))
6956 rest
= scm_cdr (rest
);
6958 return scm_gr_p (x
, y
);
6961 #define FUNC_NAME s_scm_i_num_gr_p
6963 scm_gr_p (SCM x
, SCM y
)
6965 if (!SCM_NUMBERP (x
))
6966 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6967 else if (!SCM_NUMBERP (y
))
6968 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6970 return scm_less_p (y
, x
);
6975 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6976 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6977 (SCM x
, SCM y
, SCM rest
),
6978 "Return @code{#t} if the list of parameters is monotonically\n"
6980 #define FUNC_NAME s_scm_i_num_leq_p
6982 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6984 while (!scm_is_null (rest
))
6986 if (scm_is_false (scm_leq_p (x
, y
)))
6990 rest
= scm_cdr (rest
);
6992 return scm_leq_p (x
, y
);
6995 #define FUNC_NAME s_scm_i_num_leq_p
6997 scm_leq_p (SCM x
, SCM y
)
6999 if (!SCM_NUMBERP (x
))
7000 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7001 else if (!SCM_NUMBERP (y
))
7002 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7003 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7006 return scm_not (scm_less_p (y
, x
));
7011 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7012 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7013 (SCM x
, SCM y
, SCM rest
),
7014 "Return @code{#t} if the list of parameters is monotonically\n"
7016 #define FUNC_NAME s_scm_i_num_geq_p
7018 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7020 while (!scm_is_null (rest
))
7022 if (scm_is_false (scm_geq_p (x
, y
)))
7026 rest
= scm_cdr (rest
);
7028 return scm_geq_p (x
, y
);
7031 #define FUNC_NAME s_scm_i_num_geq_p
7033 scm_geq_p (SCM x
, SCM y
)
7035 if (!SCM_NUMBERP (x
))
7036 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7037 else if (!SCM_NUMBERP (y
))
7038 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7039 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7042 return scm_not (scm_less_p (x
, y
));
7047 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7049 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7051 #define FUNC_NAME s_scm_zero_p
7053 if (SCM_I_INUMP (z
))
7054 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7055 else if (SCM_BIGP (z
))
7057 else if (SCM_REALP (z
))
7058 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7059 else if (SCM_COMPLEXP (z
))
7060 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7061 && SCM_COMPLEX_IMAG (z
) == 0.0);
7062 else if (SCM_FRACTIONP (z
))
7065 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7070 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7072 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7074 #define FUNC_NAME s_scm_positive_p
7076 if (SCM_I_INUMP (x
))
7077 return scm_from_bool (SCM_I_INUM (x
) > 0);
7078 else if (SCM_BIGP (x
))
7080 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7081 scm_remember_upto_here_1 (x
);
7082 return scm_from_bool (sgn
> 0);
7084 else if (SCM_REALP (x
))
7085 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7086 else if (SCM_FRACTIONP (x
))
7087 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7089 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7094 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7096 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7098 #define FUNC_NAME s_scm_negative_p
7100 if (SCM_I_INUMP (x
))
7101 return scm_from_bool (SCM_I_INUM (x
) < 0);
7102 else if (SCM_BIGP (x
))
7104 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7105 scm_remember_upto_here_1 (x
);
7106 return scm_from_bool (sgn
< 0);
7108 else if (SCM_REALP (x
))
7109 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7110 else if (SCM_FRACTIONP (x
))
7111 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7113 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7118 /* scm_min and scm_max return an inexact when either argument is inexact, as
7119 required by r5rs. On that basis, for exact/inexact combinations the
7120 exact is converted to inexact to compare and possibly return. This is
7121 unlike scm_less_p above which takes some trouble to preserve all bits in
7122 its test, such trouble is not required for min and max. */
7124 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7125 (SCM x
, SCM y
, SCM rest
),
7126 "Return the maximum of all parameter values.")
7127 #define FUNC_NAME s_scm_i_max
7129 while (!scm_is_null (rest
))
7130 { x
= scm_max (x
, y
);
7132 rest
= scm_cdr (rest
);
7134 return scm_max (x
, y
);
7138 #define s_max s_scm_i_max
7139 #define g_max g_scm_i_max
7142 scm_max (SCM x
, SCM y
)
7147 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7148 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7151 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7154 if (SCM_I_INUMP (x
))
7156 scm_t_inum xx
= SCM_I_INUM (x
);
7157 if (SCM_I_INUMP (y
))
7159 scm_t_inum yy
= SCM_I_INUM (y
);
7160 return (xx
< yy
) ? y
: x
;
7162 else if (SCM_BIGP (y
))
7164 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7165 scm_remember_upto_here_1 (y
);
7166 return (sgn
< 0) ? x
: y
;
7168 else if (SCM_REALP (y
))
7171 double yyd
= SCM_REAL_VALUE (y
);
7174 return scm_from_double (xxd
);
7175 /* If y is a NaN, then "==" is false and we return the NaN */
7176 else if (SCM_LIKELY (!(xxd
== yyd
)))
7178 /* Handle signed zeroes properly */
7184 else if (SCM_FRACTIONP (y
))
7187 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7190 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7192 else if (SCM_BIGP (x
))
7194 if (SCM_I_INUMP (y
))
7196 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7197 scm_remember_upto_here_1 (x
);
7198 return (sgn
< 0) ? y
: x
;
7200 else if (SCM_BIGP (y
))
7202 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7203 scm_remember_upto_here_2 (x
, y
);
7204 return (cmp
> 0) ? x
: y
;
7206 else if (SCM_REALP (y
))
7208 /* if y==NaN then xx>yy is false, so we return the NaN y */
7211 xx
= scm_i_big2dbl (x
);
7212 yy
= SCM_REAL_VALUE (y
);
7213 return (xx
> yy
? scm_from_double (xx
) : y
);
7215 else if (SCM_FRACTIONP (y
))
7220 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7222 else if (SCM_REALP (x
))
7224 if (SCM_I_INUMP (y
))
7226 scm_t_inum yy
= SCM_I_INUM (y
);
7227 double xxd
= SCM_REAL_VALUE (x
);
7231 return scm_from_double (yyd
);
7232 /* If x is a NaN, then "==" is false and we return the NaN */
7233 else if (SCM_LIKELY (!(xxd
== yyd
)))
7235 /* Handle signed zeroes properly */
7241 else if (SCM_BIGP (y
))
7246 else if (SCM_REALP (y
))
7248 double xx
= SCM_REAL_VALUE (x
);
7249 double yy
= SCM_REAL_VALUE (y
);
7251 /* For purposes of max: nan > +inf.0 > everything else,
7252 per the R6RS errata */
7255 else if (SCM_LIKELY (xx
< yy
))
7257 /* If neither (xx > yy) nor (xx < yy), then
7258 either they're equal or one is a NaN */
7259 else if (SCM_UNLIKELY (xx
!= yy
))
7260 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7261 /* xx == yy, but handle signed zeroes properly */
7262 else if (double_is_non_negative_zero (yy
))
7267 else if (SCM_FRACTIONP (y
))
7269 double yy
= scm_i_fraction2double (y
);
7270 double xx
= SCM_REAL_VALUE (x
);
7271 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7274 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7276 else if (SCM_FRACTIONP (x
))
7278 if (SCM_I_INUMP (y
))
7282 else if (SCM_BIGP (y
))
7286 else if (SCM_REALP (y
))
7288 double xx
= scm_i_fraction2double (x
);
7289 /* if y==NaN then ">" is false, so we return the NaN y */
7290 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7292 else if (SCM_FRACTIONP (y
))
7297 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7300 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7304 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7305 (SCM x
, SCM y
, SCM rest
),
7306 "Return the minimum of all parameter values.")
7307 #define FUNC_NAME s_scm_i_min
7309 while (!scm_is_null (rest
))
7310 { x
= scm_min (x
, y
);
7312 rest
= scm_cdr (rest
);
7314 return scm_min (x
, y
);
7318 #define s_min s_scm_i_min
7319 #define g_min g_scm_i_min
7322 scm_min (SCM x
, SCM y
)
7327 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7328 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7331 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7334 if (SCM_I_INUMP (x
))
7336 scm_t_inum xx
= SCM_I_INUM (x
);
7337 if (SCM_I_INUMP (y
))
7339 scm_t_inum yy
= SCM_I_INUM (y
);
7340 return (xx
< yy
) ? x
: y
;
7342 else if (SCM_BIGP (y
))
7344 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7345 scm_remember_upto_here_1 (y
);
7346 return (sgn
< 0) ? y
: x
;
7348 else if (SCM_REALP (y
))
7351 /* if y==NaN then "<" is false and we return NaN */
7352 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7354 else if (SCM_FRACTIONP (y
))
7357 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7360 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7362 else if (SCM_BIGP (x
))
7364 if (SCM_I_INUMP (y
))
7366 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7367 scm_remember_upto_here_1 (x
);
7368 return (sgn
< 0) ? x
: y
;
7370 else if (SCM_BIGP (y
))
7372 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7373 scm_remember_upto_here_2 (x
, y
);
7374 return (cmp
> 0) ? y
: x
;
7376 else if (SCM_REALP (y
))
7378 /* if y==NaN then xx<yy is false, so we return the NaN y */
7381 xx
= scm_i_big2dbl (x
);
7382 yy
= SCM_REAL_VALUE (y
);
7383 return (xx
< yy
? scm_from_double (xx
) : y
);
7385 else if (SCM_FRACTIONP (y
))
7390 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7392 else if (SCM_REALP (x
))
7394 if (SCM_I_INUMP (y
))
7396 double z
= SCM_I_INUM (y
);
7397 /* if x==NaN then "<" is false and we return NaN */
7398 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7400 else if (SCM_BIGP (y
))
7405 else if (SCM_REALP (y
))
7407 double xx
= SCM_REAL_VALUE (x
);
7408 double yy
= SCM_REAL_VALUE (y
);
7410 /* For purposes of min: nan < -inf.0 < everything else,
7411 per the R6RS errata */
7414 else if (SCM_LIKELY (xx
> yy
))
7416 /* If neither (xx < yy) nor (xx > yy), then
7417 either they're equal or one is a NaN */
7418 else if (SCM_UNLIKELY (xx
!= yy
))
7419 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7420 /* xx == yy, but handle signed zeroes properly */
7421 else if (double_is_non_negative_zero (xx
))
7426 else if (SCM_FRACTIONP (y
))
7428 double yy
= scm_i_fraction2double (y
);
7429 double xx
= SCM_REAL_VALUE (x
);
7430 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7433 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7435 else if (SCM_FRACTIONP (x
))
7437 if (SCM_I_INUMP (y
))
7441 else if (SCM_BIGP (y
))
7445 else if (SCM_REALP (y
))
7447 double xx
= scm_i_fraction2double (x
);
7448 /* if y==NaN then "<" is false, so we return the NaN y */
7449 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7451 else if (SCM_FRACTIONP (y
))
7456 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7459 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7463 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7464 (SCM x
, SCM y
, SCM rest
),
7465 "Return the sum of all parameter values. Return 0 if called without\n"
7467 #define FUNC_NAME s_scm_i_sum
7469 while (!scm_is_null (rest
))
7470 { x
= scm_sum (x
, y
);
7472 rest
= scm_cdr (rest
);
7474 return scm_sum (x
, y
);
7478 #define s_sum s_scm_i_sum
7479 #define g_sum g_scm_i_sum
7482 scm_sum (SCM x
, SCM y
)
7484 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7486 if (SCM_NUMBERP (x
)) return x
;
7487 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7488 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7491 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7493 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7495 scm_t_inum xx
= SCM_I_INUM (x
);
7496 scm_t_inum yy
= SCM_I_INUM (y
);
7497 scm_t_inum z
= xx
+ yy
;
7498 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7500 else if (SCM_BIGP (y
))
7505 else if (SCM_REALP (y
))
7507 scm_t_inum xx
= SCM_I_INUM (x
);
7508 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7510 else if (SCM_COMPLEXP (y
))
7512 scm_t_inum xx
= SCM_I_INUM (x
);
7513 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7514 SCM_COMPLEX_IMAG (y
));
7516 else if (SCM_FRACTIONP (y
))
7517 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7518 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7519 SCM_FRACTION_DENOMINATOR (y
));
7521 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7522 } else if (SCM_BIGP (x
))
7524 if (SCM_I_INUMP (y
))
7529 inum
= SCM_I_INUM (y
);
7532 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7535 SCM result
= scm_i_mkbig ();
7536 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7537 scm_remember_upto_here_1 (x
);
7538 /* we know the result will have to be a bignum */
7541 return scm_i_normbig (result
);
7545 SCM result
= scm_i_mkbig ();
7546 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7547 scm_remember_upto_here_1 (x
);
7548 /* we know the result will have to be a bignum */
7551 return scm_i_normbig (result
);
7554 else if (SCM_BIGP (y
))
7556 SCM result
= scm_i_mkbig ();
7557 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7558 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7559 mpz_add (SCM_I_BIG_MPZ (result
),
7562 scm_remember_upto_here_2 (x
, y
);
7563 /* we know the result will have to be a bignum */
7566 return scm_i_normbig (result
);
7568 else if (SCM_REALP (y
))
7570 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7571 scm_remember_upto_here_1 (x
);
7572 return scm_from_double (result
);
7574 else if (SCM_COMPLEXP (y
))
7576 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7577 + SCM_COMPLEX_REAL (y
));
7578 scm_remember_upto_here_1 (x
);
7579 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7581 else if (SCM_FRACTIONP (y
))
7582 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7583 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7584 SCM_FRACTION_DENOMINATOR (y
));
7586 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7588 else if (SCM_REALP (x
))
7590 if (SCM_I_INUMP (y
))
7591 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7592 else if (SCM_BIGP (y
))
7594 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7595 scm_remember_upto_here_1 (y
);
7596 return scm_from_double (result
);
7598 else if (SCM_REALP (y
))
7599 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7600 else if (SCM_COMPLEXP (y
))
7601 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7602 SCM_COMPLEX_IMAG (y
));
7603 else if (SCM_FRACTIONP (y
))
7604 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7606 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7608 else if (SCM_COMPLEXP (x
))
7610 if (SCM_I_INUMP (y
))
7611 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7612 SCM_COMPLEX_IMAG (x
));
7613 else if (SCM_BIGP (y
))
7615 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7616 + SCM_COMPLEX_REAL (x
));
7617 scm_remember_upto_here_1 (y
);
7618 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7620 else if (SCM_REALP (y
))
7621 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7622 SCM_COMPLEX_IMAG (x
));
7623 else if (SCM_COMPLEXP (y
))
7624 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7625 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7626 else if (SCM_FRACTIONP (y
))
7627 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7628 SCM_COMPLEX_IMAG (x
));
7630 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7632 else if (SCM_FRACTIONP (x
))
7634 if (SCM_I_INUMP (y
))
7635 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7636 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7637 SCM_FRACTION_DENOMINATOR (x
));
7638 else if (SCM_BIGP (y
))
7639 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7640 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7641 SCM_FRACTION_DENOMINATOR (x
));
7642 else if (SCM_REALP (y
))
7643 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7644 else if (SCM_COMPLEXP (y
))
7645 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7646 SCM_COMPLEX_IMAG (y
));
7647 else if (SCM_FRACTIONP (y
))
7648 /* a/b + c/d = (ad + bc) / bd */
7649 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7650 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7651 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7653 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7656 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7660 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7662 "Return @math{@var{x}+1}.")
7663 #define FUNC_NAME s_scm_oneplus
7665 return scm_sum (x
, SCM_INUM1
);
7670 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7671 (SCM x
, SCM y
, SCM rest
),
7672 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7673 "the sum of all but the first argument are subtracted from the first\n"
7675 #define FUNC_NAME s_scm_i_difference
7677 while (!scm_is_null (rest
))
7678 { x
= scm_difference (x
, y
);
7680 rest
= scm_cdr (rest
);
7682 return scm_difference (x
, y
);
7686 #define s_difference s_scm_i_difference
7687 #define g_difference g_scm_i_difference
7690 scm_difference (SCM x
, SCM y
)
7691 #define FUNC_NAME s_difference
7693 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7696 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7698 if (SCM_I_INUMP (x
))
7700 scm_t_inum xx
= -SCM_I_INUM (x
);
7701 if (SCM_FIXABLE (xx
))
7702 return SCM_I_MAKINUM (xx
);
7704 return scm_i_inum2big (xx
);
7706 else if (SCM_BIGP (x
))
7707 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7708 bignum, but negating that gives a fixnum. */
7709 return scm_i_normbig (scm_i_clonebig (x
, 0));
7710 else if (SCM_REALP (x
))
7711 return scm_from_double (-SCM_REAL_VALUE (x
));
7712 else if (SCM_COMPLEXP (x
))
7713 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7714 -SCM_COMPLEX_IMAG (x
));
7715 else if (SCM_FRACTIONP (x
))
7716 return scm_i_make_ratio_already_reduced
7717 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7718 SCM_FRACTION_DENOMINATOR (x
));
7720 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7723 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7725 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7727 scm_t_inum xx
= SCM_I_INUM (x
);
7728 scm_t_inum yy
= SCM_I_INUM (y
);
7729 scm_t_inum z
= xx
- yy
;
7730 if (SCM_FIXABLE (z
))
7731 return SCM_I_MAKINUM (z
);
7733 return scm_i_inum2big (z
);
7735 else if (SCM_BIGP (y
))
7737 /* inum-x - big-y */
7738 scm_t_inum xx
= SCM_I_INUM (x
);
7742 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7743 bignum, but negating that gives a fixnum. */
7744 return scm_i_normbig (scm_i_clonebig (y
, 0));
7748 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7749 SCM result
= scm_i_mkbig ();
7752 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7755 /* x - y == -(y + -x) */
7756 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7757 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7759 scm_remember_upto_here_1 (y
);
7761 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7762 /* we know the result will have to be a bignum */
7765 return scm_i_normbig (result
);
7768 else if (SCM_REALP (y
))
7770 scm_t_inum xx
= SCM_I_INUM (x
);
7773 * We need to handle x == exact 0
7774 * specially because R6RS states that:
7775 * (- 0.0) ==> -0.0 and
7776 * (- 0.0 0.0) ==> 0.0
7777 * and the scheme compiler changes
7778 * (- 0.0) into (- 0 0.0)
7779 * So we need to treat (- 0 0.0) like (- 0.0).
7780 * At the C level, (-x) is different than (0.0 - x).
7781 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7784 return scm_from_double (- SCM_REAL_VALUE (y
));
7786 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7788 else if (SCM_COMPLEXP (y
))
7790 scm_t_inum xx
= SCM_I_INUM (x
);
7792 /* We need to handle x == exact 0 specially.
7793 See the comment above (for SCM_REALP (y)) */
7795 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7796 - SCM_COMPLEX_IMAG (y
));
7798 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7799 - SCM_COMPLEX_IMAG (y
));
7801 else if (SCM_FRACTIONP (y
))
7802 /* a - b/c = (ac - b) / c */
7803 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7804 SCM_FRACTION_NUMERATOR (y
)),
7805 SCM_FRACTION_DENOMINATOR (y
));
7807 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7809 else if (SCM_BIGP (x
))
7811 if (SCM_I_INUMP (y
))
7813 /* big-x - inum-y */
7814 scm_t_inum yy
= SCM_I_INUM (y
);
7815 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7817 scm_remember_upto_here_1 (x
);
7819 return (SCM_FIXABLE (-yy
) ?
7820 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7823 SCM result
= scm_i_mkbig ();
7826 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7828 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7829 scm_remember_upto_here_1 (x
);
7831 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7832 /* we know the result will have to be a bignum */
7835 return scm_i_normbig (result
);
7838 else if (SCM_BIGP (y
))
7840 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7841 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7842 SCM result
= scm_i_mkbig ();
7843 mpz_sub (SCM_I_BIG_MPZ (result
),
7846 scm_remember_upto_here_2 (x
, y
);
7847 /* we know the result will have to be a bignum */
7848 if ((sgn_x
== 1) && (sgn_y
== -1))
7850 if ((sgn_x
== -1) && (sgn_y
== 1))
7852 return scm_i_normbig (result
);
7854 else if (SCM_REALP (y
))
7856 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7857 scm_remember_upto_here_1 (x
);
7858 return scm_from_double (result
);
7860 else if (SCM_COMPLEXP (y
))
7862 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7863 - SCM_COMPLEX_REAL (y
));
7864 scm_remember_upto_here_1 (x
);
7865 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7867 else if (SCM_FRACTIONP (y
))
7868 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7869 SCM_FRACTION_NUMERATOR (y
)),
7870 SCM_FRACTION_DENOMINATOR (y
));
7871 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7873 else if (SCM_REALP (x
))
7875 if (SCM_I_INUMP (y
))
7876 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7877 else if (SCM_BIGP (y
))
7879 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7880 scm_remember_upto_here_1 (x
);
7881 return scm_from_double (result
);
7883 else if (SCM_REALP (y
))
7884 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7885 else if (SCM_COMPLEXP (y
))
7886 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7887 -SCM_COMPLEX_IMAG (y
));
7888 else if (SCM_FRACTIONP (y
))
7889 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7891 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7893 else if (SCM_COMPLEXP (x
))
7895 if (SCM_I_INUMP (y
))
7896 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7897 SCM_COMPLEX_IMAG (x
));
7898 else if (SCM_BIGP (y
))
7900 double real_part
= (SCM_COMPLEX_REAL (x
)
7901 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7902 scm_remember_upto_here_1 (x
);
7903 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7905 else if (SCM_REALP (y
))
7906 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7907 SCM_COMPLEX_IMAG (x
));
7908 else if (SCM_COMPLEXP (y
))
7909 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7910 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7911 else if (SCM_FRACTIONP (y
))
7912 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7913 SCM_COMPLEX_IMAG (x
));
7915 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7917 else if (SCM_FRACTIONP (x
))
7919 if (SCM_I_INUMP (y
))
7920 /* a/b - c = (a - cb) / b */
7921 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7922 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7923 SCM_FRACTION_DENOMINATOR (x
));
7924 else if (SCM_BIGP (y
))
7925 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7926 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7927 SCM_FRACTION_DENOMINATOR (x
));
7928 else if (SCM_REALP (y
))
7929 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7930 else if (SCM_COMPLEXP (y
))
7931 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7932 -SCM_COMPLEX_IMAG (y
));
7933 else if (SCM_FRACTIONP (y
))
7934 /* a/b - c/d = (ad - bc) / bd */
7935 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7936 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7937 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7939 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7942 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7947 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7949 "Return @math{@var{x}-1}.")
7950 #define FUNC_NAME s_scm_oneminus
7952 return scm_difference (x
, SCM_INUM1
);
7957 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7958 (SCM x
, SCM y
, SCM rest
),
7959 "Return the product of all arguments. If called without arguments,\n"
7961 #define FUNC_NAME s_scm_i_product
7963 while (!scm_is_null (rest
))
7964 { x
= scm_product (x
, y
);
7966 rest
= scm_cdr (rest
);
7968 return scm_product (x
, y
);
7972 #define s_product s_scm_i_product
7973 #define g_product g_scm_i_product
7976 scm_product (SCM x
, SCM y
)
7978 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7981 return SCM_I_MAKINUM (1L);
7982 else if (SCM_NUMBERP (x
))
7985 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7988 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7993 xx
= SCM_I_INUM (x
);
7998 /* exact1 is the universal multiplicative identity */
8002 /* exact0 times a fixnum is exact0: optimize this case */
8003 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8005 /* if the other argument is inexact, the result is inexact,
8006 and we must do the multiplication in order to handle
8007 infinities and NaNs properly. */
8008 else if (SCM_REALP (y
))
8009 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
8010 else if (SCM_COMPLEXP (y
))
8011 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8012 0.0 * SCM_COMPLEX_IMAG (y
));
8013 /* we've already handled inexact numbers,
8014 so y must be exact, and we return exact0 */
8015 else if (SCM_NUMP (y
))
8018 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8022 * This case is important for more than just optimization.
8023 * It handles the case of negating
8024 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8025 * which is a bignum that must be changed back into a fixnum.
8026 * Failure to do so will cause the following to return #f:
8027 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8029 return scm_difference(y
, SCM_UNDEFINED
);
8033 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8035 scm_t_inum yy
= SCM_I_INUM (y
);
8036 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8037 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8038 if (SCM_FIXABLE (kk
))
8039 return SCM_I_MAKINUM (kk
);
8041 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8042 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8043 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8044 return SCM_I_MAKINUM (xx
* yy
);
8048 SCM result
= scm_i_inum2big (xx
);
8049 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8050 return scm_i_normbig (result
);
8053 else if (SCM_BIGP (y
))
8055 SCM result
= scm_i_mkbig ();
8056 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8057 scm_remember_upto_here_1 (y
);
8060 else if (SCM_REALP (y
))
8061 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
8062 else if (SCM_COMPLEXP (y
))
8063 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8064 xx
* SCM_COMPLEX_IMAG (y
));
8065 else if (SCM_FRACTIONP (y
))
8066 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8067 SCM_FRACTION_DENOMINATOR (y
));
8069 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8071 else if (SCM_BIGP (x
))
8073 if (SCM_I_INUMP (y
))
8078 else if (SCM_BIGP (y
))
8080 SCM result
= scm_i_mkbig ();
8081 mpz_mul (SCM_I_BIG_MPZ (result
),
8084 scm_remember_upto_here_2 (x
, y
);
8087 else if (SCM_REALP (y
))
8089 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8090 scm_remember_upto_here_1 (x
);
8091 return scm_from_double (result
);
8093 else if (SCM_COMPLEXP (y
))
8095 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8096 scm_remember_upto_here_1 (x
);
8097 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8098 z
* SCM_COMPLEX_IMAG (y
));
8100 else if (SCM_FRACTIONP (y
))
8101 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8102 SCM_FRACTION_DENOMINATOR (y
));
8104 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8106 else if (SCM_REALP (x
))
8108 if (SCM_I_INUMP (y
))
8113 else if (SCM_BIGP (y
))
8115 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8116 scm_remember_upto_here_1 (y
);
8117 return scm_from_double (result
);
8119 else if (SCM_REALP (y
))
8120 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8121 else if (SCM_COMPLEXP (y
))
8122 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8123 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8124 else if (SCM_FRACTIONP (y
))
8125 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8127 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8129 else if (SCM_COMPLEXP (x
))
8131 if (SCM_I_INUMP (y
))
8136 else if (SCM_BIGP (y
))
8138 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8139 scm_remember_upto_here_1 (y
);
8140 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8141 z
* SCM_COMPLEX_IMAG (x
));
8143 else if (SCM_REALP (y
))
8144 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8145 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8146 else if (SCM_COMPLEXP (y
))
8148 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8149 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8150 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8151 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8153 else if (SCM_FRACTIONP (y
))
8155 double yy
= scm_i_fraction2double (y
);
8156 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8157 yy
* SCM_COMPLEX_IMAG (x
));
8160 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8162 else if (SCM_FRACTIONP (x
))
8164 if (SCM_I_INUMP (y
))
8165 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8166 SCM_FRACTION_DENOMINATOR (x
));
8167 else if (SCM_BIGP (y
))
8168 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8169 SCM_FRACTION_DENOMINATOR (x
));
8170 else if (SCM_REALP (y
))
8171 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8172 else if (SCM_COMPLEXP (y
))
8174 double xx
= scm_i_fraction2double (x
);
8175 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8176 xx
* SCM_COMPLEX_IMAG (y
));
8178 else if (SCM_FRACTIONP (y
))
8179 /* a/b * c/d = ac / bd */
8180 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8181 SCM_FRACTION_NUMERATOR (y
)),
8182 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8183 SCM_FRACTION_DENOMINATOR (y
)));
8185 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8188 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8191 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8192 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8193 #define ALLOW_DIVIDE_BY_ZERO
8194 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8197 /* The code below for complex division is adapted from the GNU
8198 libstdc++, which adapted it from f2c's libF77, and is subject to
8201 /****************************************************************
8202 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8204 Permission to use, copy, modify, and distribute this software
8205 and its documentation for any purpose and without fee is hereby
8206 granted, provided that the above copyright notice appear in all
8207 copies and that both that the copyright notice and this
8208 permission notice and warranty disclaimer appear in supporting
8209 documentation, and that the names of AT&T Bell Laboratories or
8210 Bellcore or any of their entities not be used in advertising or
8211 publicity pertaining to distribution of the software without
8212 specific, written prior permission.
8214 AT&T and Bellcore disclaim all warranties with regard to this
8215 software, including all implied warranties of merchantability
8216 and fitness. In no event shall AT&T or Bellcore be liable for
8217 any special, indirect or consequential damages or any damages
8218 whatsoever resulting from loss of use, data or profits, whether
8219 in an action of contract, negligence or other tortious action,
8220 arising out of or in connection with the use or performance of
8222 ****************************************************************/
8224 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8225 (SCM x
, SCM y
, SCM rest
),
8226 "Divide the first argument by the product of the remaining\n"
8227 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8229 #define FUNC_NAME s_scm_i_divide
8231 while (!scm_is_null (rest
))
8232 { x
= scm_divide (x
, y
);
8234 rest
= scm_cdr (rest
);
8236 return scm_divide (x
, y
);
8240 #define s_divide s_scm_i_divide
8241 #define g_divide g_scm_i_divide
8244 scm_divide (SCM x
, SCM y
)
8245 #define FUNC_NAME s_divide
8249 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8252 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8253 else if (SCM_I_INUMP (x
))
8255 scm_t_inum xx
= SCM_I_INUM (x
);
8256 if (xx
== 1 || xx
== -1)
8258 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8260 scm_num_overflow (s_divide
);
8263 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8265 else if (SCM_BIGP (x
))
8266 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8267 else if (SCM_REALP (x
))
8269 double xx
= SCM_REAL_VALUE (x
);
8270 #ifndef ALLOW_DIVIDE_BY_ZERO
8272 scm_num_overflow (s_divide
);
8275 return scm_from_double (1.0 / xx
);
8277 else if (SCM_COMPLEXP (x
))
8279 double r
= SCM_COMPLEX_REAL (x
);
8280 double i
= SCM_COMPLEX_IMAG (x
);
8281 if (fabs(r
) <= fabs(i
))
8284 double d
= i
* (1.0 + t
* t
);
8285 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8290 double d
= r
* (1.0 + t
* t
);
8291 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8294 else if (SCM_FRACTIONP (x
))
8295 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8296 SCM_FRACTION_NUMERATOR (x
));
8298 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8301 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8303 scm_t_inum xx
= SCM_I_INUM (x
);
8304 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8306 scm_t_inum yy
= SCM_I_INUM (y
);
8309 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8310 scm_num_overflow (s_divide
);
8312 return scm_from_double ((double) xx
/ (double) yy
);
8315 else if (xx
% yy
!= 0)
8316 return scm_i_make_ratio (x
, y
);
8319 scm_t_inum z
= xx
/ yy
;
8320 if (SCM_FIXABLE (z
))
8321 return SCM_I_MAKINUM (z
);
8323 return scm_i_inum2big (z
);
8326 else if (SCM_BIGP (y
))
8327 return scm_i_make_ratio (x
, y
);
8328 else if (SCM_REALP (y
))
8330 double yy
= SCM_REAL_VALUE (y
);
8331 #ifndef ALLOW_DIVIDE_BY_ZERO
8333 scm_num_overflow (s_divide
);
8336 /* FIXME: Precision may be lost here due to:
8337 (1) The cast from 'scm_t_inum' to 'double'
8338 (2) Double rounding */
8339 return scm_from_double ((double) xx
/ yy
);
8341 else if (SCM_COMPLEXP (y
))
8344 complex_div
: /* y _must_ be a complex number */
8346 double r
= SCM_COMPLEX_REAL (y
);
8347 double i
= SCM_COMPLEX_IMAG (y
);
8348 if (fabs(r
) <= fabs(i
))
8351 double d
= i
* (1.0 + t
* t
);
8352 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8357 double d
= r
* (1.0 + t
* t
);
8358 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8362 else if (SCM_FRACTIONP (y
))
8363 /* a / b/c = ac / b */
8364 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8365 SCM_FRACTION_NUMERATOR (y
));
8367 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8369 else if (SCM_BIGP (x
))
8371 if (SCM_I_INUMP (y
))
8373 scm_t_inum yy
= SCM_I_INUM (y
);
8376 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8377 scm_num_overflow (s_divide
);
8379 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8380 scm_remember_upto_here_1 (x
);
8381 return (sgn
== 0) ? scm_nan () : scm_inf ();
8388 /* FIXME: HMM, what are the relative performance issues here?
8389 We need to test. Is it faster on average to test
8390 divisible_p, then perform whichever operation, or is it
8391 faster to perform the integer div opportunistically and
8392 switch to real if there's a remainder? For now we take the
8393 middle ground: test, then if divisible, use the faster div
8396 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8397 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8401 SCM result
= scm_i_mkbig ();
8402 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8403 scm_remember_upto_here_1 (x
);
8405 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8406 return scm_i_normbig (result
);
8409 return scm_i_make_ratio (x
, y
);
8412 else if (SCM_BIGP (y
))
8414 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8418 SCM result
= scm_i_mkbig ();
8419 mpz_divexact (SCM_I_BIG_MPZ (result
),
8422 scm_remember_upto_here_2 (x
, y
);
8423 return scm_i_normbig (result
);
8426 return scm_i_make_ratio (x
, y
);
8428 else if (SCM_REALP (y
))
8430 double yy
= SCM_REAL_VALUE (y
);
8431 #ifndef ALLOW_DIVIDE_BY_ZERO
8433 scm_num_overflow (s_divide
);
8436 /* FIXME: Precision may be lost here due to:
8437 (1) scm_i_big2dbl (2) Double rounding */
8438 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8440 else if (SCM_COMPLEXP (y
))
8442 a
= scm_i_big2dbl (x
);
8445 else if (SCM_FRACTIONP (y
))
8446 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8447 SCM_FRACTION_NUMERATOR (y
));
8449 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8451 else if (SCM_REALP (x
))
8453 double rx
= SCM_REAL_VALUE (x
);
8454 if (SCM_I_INUMP (y
))
8456 scm_t_inum yy
= SCM_I_INUM (y
);
8457 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8459 scm_num_overflow (s_divide
);
8462 /* FIXME: Precision may be lost here due to:
8463 (1) The cast from 'scm_t_inum' to 'double'
8464 (2) Double rounding */
8465 return scm_from_double (rx
/ (double) yy
);
8467 else if (SCM_BIGP (y
))
8469 /* FIXME: Precision may be lost here due to:
8470 (1) The conversion from bignum to double
8471 (2) Double rounding */
8472 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8473 scm_remember_upto_here_1 (y
);
8474 return scm_from_double (rx
/ dby
);
8476 else if (SCM_REALP (y
))
8478 double yy
= SCM_REAL_VALUE (y
);
8479 #ifndef ALLOW_DIVIDE_BY_ZERO
8481 scm_num_overflow (s_divide
);
8484 return scm_from_double (rx
/ yy
);
8486 else if (SCM_COMPLEXP (y
))
8491 else if (SCM_FRACTIONP (y
))
8492 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8494 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8496 else if (SCM_COMPLEXP (x
))
8498 double rx
= SCM_COMPLEX_REAL (x
);
8499 double ix
= SCM_COMPLEX_IMAG (x
);
8500 if (SCM_I_INUMP (y
))
8502 scm_t_inum yy
= SCM_I_INUM (y
);
8503 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8505 scm_num_overflow (s_divide
);
8509 /* FIXME: Precision may be lost here due to:
8510 (1) The conversion from 'scm_t_inum' to double
8511 (2) Double rounding */
8513 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8516 else if (SCM_BIGP (y
))
8518 /* FIXME: Precision may be lost here due to:
8519 (1) The conversion from bignum to double
8520 (2) Double rounding */
8521 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8522 scm_remember_upto_here_1 (y
);
8523 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8525 else if (SCM_REALP (y
))
8527 double yy
= SCM_REAL_VALUE (y
);
8528 #ifndef ALLOW_DIVIDE_BY_ZERO
8530 scm_num_overflow (s_divide
);
8533 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8535 else if (SCM_COMPLEXP (y
))
8537 double ry
= SCM_COMPLEX_REAL (y
);
8538 double iy
= SCM_COMPLEX_IMAG (y
);
8539 if (fabs(ry
) <= fabs(iy
))
8542 double d
= iy
* (1.0 + t
* t
);
8543 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8548 double d
= ry
* (1.0 + t
* t
);
8549 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8552 else if (SCM_FRACTIONP (y
))
8554 /* FIXME: Precision may be lost here due to:
8555 (1) The conversion from fraction to double
8556 (2) Double rounding */
8557 double yy
= scm_i_fraction2double (y
);
8558 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8561 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8563 else if (SCM_FRACTIONP (x
))
8565 if (SCM_I_INUMP (y
))
8567 scm_t_inum yy
= SCM_I_INUM (y
);
8568 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8570 scm_num_overflow (s_divide
);
8573 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8574 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8576 else if (SCM_BIGP (y
))
8578 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8579 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8581 else if (SCM_REALP (y
))
8583 double yy
= SCM_REAL_VALUE (y
);
8584 #ifndef ALLOW_DIVIDE_BY_ZERO
8586 scm_num_overflow (s_divide
);
8589 /* FIXME: Precision may be lost here due to:
8590 (1) The conversion from fraction to double
8591 (2) Double rounding */
8592 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8594 else if (SCM_COMPLEXP (y
))
8596 /* FIXME: Precision may be lost here due to:
8597 (1) The conversion from fraction to double
8598 (2) Double rounding */
8599 a
= scm_i_fraction2double (x
);
8602 else if (SCM_FRACTIONP (y
))
8603 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8604 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8606 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8609 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8615 scm_c_truncate (double x
)
8620 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8621 half-way case (ie. when x is an integer plus 0.5) going upwards.
8622 Then half-way cases are identified and adjusted down if the
8623 round-upwards didn't give the desired even integer.
8625 "plus_half == result" identifies a half-way case. If plus_half, which is
8626 x + 0.5, is an integer then x must be an integer plus 0.5.
8628 An odd "result" value is identified with result/2 != floor(result/2).
8629 This is done with plus_half, since that value is ready for use sooner in
8630 a pipelined cpu, and we're already requiring plus_half == result.
8632 Note however that we need to be careful when x is big and already an
8633 integer. In that case "x+0.5" may round to an adjacent integer, causing
8634 us to return such a value, incorrectly. For instance if the hardware is
8635 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8636 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8637 returned. Or if the hardware is in round-upwards mode, then other bigger
8638 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8639 representable value, 2^128+2^76 (or whatever), again incorrect.
8641 These bad roundings of x+0.5 are avoided by testing at the start whether
8642 x is already an integer. If it is then clearly that's the desired result
8643 already. And if it's not then the exponent must be small enough to allow
8644 an 0.5 to be represented, and hence added without a bad rounding. */
8647 scm_c_round (double x
)
8649 double plus_half
, result
;
8654 plus_half
= x
+ 0.5;
8655 result
= floor (plus_half
);
8656 /* Adjust so that the rounding is towards even. */
8657 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8662 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8664 "Round the number @var{x} towards zero.")
8665 #define FUNC_NAME s_scm_truncate_number
8667 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8669 else if (SCM_REALP (x
))
8670 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8671 else if (SCM_FRACTIONP (x
))
8672 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8673 SCM_FRACTION_DENOMINATOR (x
));
8675 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8676 s_scm_truncate_number
);
8680 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8682 "Round the number @var{x} towards the nearest integer. "
8683 "When it is exactly halfway between two integers, "
8684 "round towards the even one.")
8685 #define FUNC_NAME s_scm_round_number
8687 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8689 else if (SCM_REALP (x
))
8690 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8691 else if (SCM_FRACTIONP (x
))
8692 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8693 SCM_FRACTION_DENOMINATOR (x
));
8695 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8696 s_scm_round_number
);
8700 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8702 "Round the number @var{x} towards minus infinity.")
8703 #define FUNC_NAME s_scm_floor
8705 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8707 else if (SCM_REALP (x
))
8708 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8709 else if (SCM_FRACTIONP (x
))
8710 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8711 SCM_FRACTION_DENOMINATOR (x
));
8713 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8717 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8719 "Round the number @var{x} towards infinity.")
8720 #define FUNC_NAME s_scm_ceiling
8722 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8724 else if (SCM_REALP (x
))
8725 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8726 else if (SCM_FRACTIONP (x
))
8727 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8728 SCM_FRACTION_DENOMINATOR (x
));
8730 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8734 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8736 "Return @var{x} raised to the power of @var{y}.")
8737 #define FUNC_NAME s_scm_expt
8739 if (scm_is_integer (y
))
8741 if (scm_is_true (scm_exact_p (y
)))
8742 return scm_integer_expt (x
, y
);
8745 /* Here we handle the case where the exponent is an inexact
8746 integer. We make the exponent exact in order to use
8747 scm_integer_expt, and thus avoid the spurious imaginary
8748 parts that may result from round-off errors in the general
8749 e^(y log x) method below (for example when squaring a large
8750 negative number). In this case, we must return an inexact
8751 result for correctness. We also make the base inexact so
8752 that scm_integer_expt will use fast inexact arithmetic
8753 internally. Note that making the base inexact is not
8754 sufficient to guarantee an inexact result, because
8755 scm_integer_expt will return an exact 1 when the exponent
8756 is 0, even if the base is inexact. */
8757 return scm_exact_to_inexact
8758 (scm_integer_expt (scm_exact_to_inexact (x
),
8759 scm_inexact_to_exact (y
)));
8762 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8764 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8766 else if (scm_is_complex (x
) && scm_is_complex (y
))
8767 return scm_exp (scm_product (scm_log (x
), y
));
8768 else if (scm_is_complex (x
))
8769 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8771 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8775 /* sin/cos/tan/asin/acos/atan
8776 sinh/cosh/tanh/asinh/acosh/atanh
8777 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8778 Written by Jerry D. Hedden, (C) FSF.
8779 See the file `COPYING' for terms applying to this program. */
8781 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8783 "Compute the sine of @var{z}.")
8784 #define FUNC_NAME s_scm_sin
8786 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8787 return z
; /* sin(exact0) = exact0 */
8788 else if (scm_is_real (z
))
8789 return scm_from_double (sin (scm_to_double (z
)));
8790 else if (SCM_COMPLEXP (z
))
8792 x
= SCM_COMPLEX_REAL (z
);
8793 y
= SCM_COMPLEX_IMAG (z
);
8794 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8795 cos (x
) * sinh (y
));
8798 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8802 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8804 "Compute the cosine of @var{z}.")
8805 #define FUNC_NAME s_scm_cos
8807 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8808 return SCM_INUM1
; /* cos(exact0) = exact1 */
8809 else if (scm_is_real (z
))
8810 return scm_from_double (cos (scm_to_double (z
)));
8811 else if (SCM_COMPLEXP (z
))
8813 x
= SCM_COMPLEX_REAL (z
);
8814 y
= SCM_COMPLEX_IMAG (z
);
8815 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8816 -sin (x
) * sinh (y
));
8819 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8823 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8825 "Compute the tangent of @var{z}.")
8826 #define FUNC_NAME s_scm_tan
8828 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8829 return z
; /* tan(exact0) = exact0 */
8830 else if (scm_is_real (z
))
8831 return scm_from_double (tan (scm_to_double (z
)));
8832 else if (SCM_COMPLEXP (z
))
8834 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8835 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8836 w
= cos (x
) + cosh (y
);
8837 #ifndef ALLOW_DIVIDE_BY_ZERO
8839 scm_num_overflow (s_scm_tan
);
8841 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8844 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8848 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8850 "Compute the hyperbolic sine of @var{z}.")
8851 #define FUNC_NAME s_scm_sinh
8853 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8854 return z
; /* sinh(exact0) = exact0 */
8855 else if (scm_is_real (z
))
8856 return scm_from_double (sinh (scm_to_double (z
)));
8857 else if (SCM_COMPLEXP (z
))
8859 x
= SCM_COMPLEX_REAL (z
);
8860 y
= SCM_COMPLEX_IMAG (z
);
8861 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8862 cosh (x
) * sin (y
));
8865 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8869 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8871 "Compute the hyperbolic cosine of @var{z}.")
8872 #define FUNC_NAME s_scm_cosh
8874 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8875 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8876 else if (scm_is_real (z
))
8877 return scm_from_double (cosh (scm_to_double (z
)));
8878 else if (SCM_COMPLEXP (z
))
8880 x
= SCM_COMPLEX_REAL (z
);
8881 y
= SCM_COMPLEX_IMAG (z
);
8882 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8883 sinh (x
) * sin (y
));
8886 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8890 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8892 "Compute the hyperbolic tangent of @var{z}.")
8893 #define FUNC_NAME s_scm_tanh
8895 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8896 return z
; /* tanh(exact0) = exact0 */
8897 else if (scm_is_real (z
))
8898 return scm_from_double (tanh (scm_to_double (z
)));
8899 else if (SCM_COMPLEXP (z
))
8901 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8902 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8903 w
= cosh (x
) + cos (y
);
8904 #ifndef ALLOW_DIVIDE_BY_ZERO
8906 scm_num_overflow (s_scm_tanh
);
8908 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8911 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8915 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8917 "Compute the arc sine of @var{z}.")
8918 #define FUNC_NAME s_scm_asin
8920 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8921 return z
; /* asin(exact0) = exact0 */
8922 else if (scm_is_real (z
))
8924 double w
= scm_to_double (z
);
8925 if (w
>= -1.0 && w
<= 1.0)
8926 return scm_from_double (asin (w
));
8928 return scm_product (scm_c_make_rectangular (0, -1),
8929 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8931 else if (SCM_COMPLEXP (z
))
8933 x
= SCM_COMPLEX_REAL (z
);
8934 y
= SCM_COMPLEX_IMAG (z
);
8935 return scm_product (scm_c_make_rectangular (0, -1),
8936 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8939 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8943 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8945 "Compute the arc cosine of @var{z}.")
8946 #define FUNC_NAME s_scm_acos
8948 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8949 return SCM_INUM0
; /* acos(exact1) = exact0 */
8950 else if (scm_is_real (z
))
8952 double w
= scm_to_double (z
);
8953 if (w
>= -1.0 && w
<= 1.0)
8954 return scm_from_double (acos (w
));
8956 return scm_sum (scm_from_double (acos (0.0)),
8957 scm_product (scm_c_make_rectangular (0, 1),
8958 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8960 else if (SCM_COMPLEXP (z
))
8962 x
= SCM_COMPLEX_REAL (z
);
8963 y
= SCM_COMPLEX_IMAG (z
);
8964 return scm_sum (scm_from_double (acos (0.0)),
8965 scm_product (scm_c_make_rectangular (0, 1),
8966 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8969 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8973 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8975 "With one argument, compute the arc tangent of @var{z}.\n"
8976 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8977 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8978 #define FUNC_NAME s_scm_atan
8982 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8983 return z
; /* atan(exact0) = exact0 */
8984 else if (scm_is_real (z
))
8985 return scm_from_double (atan (scm_to_double (z
)));
8986 else if (SCM_COMPLEXP (z
))
8989 v
= SCM_COMPLEX_REAL (z
);
8990 w
= SCM_COMPLEX_IMAG (z
);
8991 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8992 scm_c_make_rectangular (v
, w
+ 1.0))),
8993 scm_c_make_rectangular (0, 2));
8996 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8998 else if (scm_is_real (z
))
9000 if (scm_is_real (y
))
9001 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9003 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9006 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9010 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9012 "Compute the inverse hyperbolic sine of @var{z}.")
9013 #define FUNC_NAME s_scm_sys_asinh
9015 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9016 return z
; /* asinh(exact0) = exact0 */
9017 else if (scm_is_real (z
))
9018 return scm_from_double (asinh (scm_to_double (z
)));
9019 else if (scm_is_number (z
))
9020 return scm_log (scm_sum (z
,
9021 scm_sqrt (scm_sum (scm_product (z
, z
),
9024 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9028 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9030 "Compute the inverse hyperbolic cosine of @var{z}.")
9031 #define FUNC_NAME s_scm_sys_acosh
9033 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9034 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9035 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9036 return scm_from_double (acosh (scm_to_double (z
)));
9037 else if (scm_is_number (z
))
9038 return scm_log (scm_sum (z
,
9039 scm_sqrt (scm_difference (scm_product (z
, z
),
9042 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9046 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9048 "Compute the inverse hyperbolic tangent of @var{z}.")
9049 #define FUNC_NAME s_scm_sys_atanh
9051 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9052 return z
; /* atanh(exact0) = exact0 */
9053 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9054 return scm_from_double (atanh (scm_to_double (z
)));
9055 else if (scm_is_number (z
))
9056 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9057 scm_difference (SCM_INUM1
, z
))),
9060 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9065 scm_c_make_rectangular (double re
, double im
)
9069 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9071 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9072 SCM_COMPLEX_REAL (z
) = re
;
9073 SCM_COMPLEX_IMAG (z
) = im
;
9077 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9078 (SCM real_part
, SCM imaginary_part
),
9079 "Return a complex number constructed of the given @var{real_part} "
9080 "and @var{imaginary_part} parts.")
9081 #define FUNC_NAME s_scm_make_rectangular
9083 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9084 SCM_ARG1
, FUNC_NAME
, "real");
9085 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9086 SCM_ARG2
, FUNC_NAME
, "real");
9088 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9089 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9092 return scm_c_make_rectangular (scm_to_double (real_part
),
9093 scm_to_double (imaginary_part
));
9098 scm_c_make_polar (double mag
, double ang
)
9102 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9103 use it on Glibc-based systems that have it (it's a GNU extension). See
9104 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9106 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9107 sincos (ang
, &s
, &c
);
9113 /* If s and c are NaNs, this indicates that the angle is a NaN,
9114 infinite, or perhaps simply too large to determine its value
9115 mod 2*pi. However, we know something that the floating-point
9116 implementation doesn't know: We know that s and c are finite.
9117 Therefore, if the magnitude is zero, return a complex zero.
9119 The reason we check for the NaNs instead of using this case
9120 whenever mag == 0.0 is because when the angle is known, we'd
9121 like to return the correct kind of non-real complex zero:
9122 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9123 on which quadrant the angle is in.
9125 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9126 return scm_c_make_rectangular (0.0, 0.0);
9128 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9131 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9133 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9134 #define FUNC_NAME s_scm_make_polar
9136 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9137 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9139 /* If mag is exact0, return exact0 */
9140 if (scm_is_eq (mag
, SCM_INUM0
))
9142 /* Return a real if ang is exact0 */
9143 else if (scm_is_eq (ang
, SCM_INUM0
))
9146 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9151 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9153 "Return the real part of the number @var{z}.")
9154 #define FUNC_NAME s_scm_real_part
9156 if (SCM_COMPLEXP (z
))
9157 return scm_from_double (SCM_COMPLEX_REAL (z
));
9158 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9161 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9166 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9168 "Return the imaginary part of the number @var{z}.")
9169 #define FUNC_NAME s_scm_imag_part
9171 if (SCM_COMPLEXP (z
))
9172 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9173 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9176 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9180 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9182 "Return the numerator of the number @var{z}.")
9183 #define FUNC_NAME s_scm_numerator
9185 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9187 else if (SCM_FRACTIONP (z
))
9188 return SCM_FRACTION_NUMERATOR (z
);
9189 else if (SCM_REALP (z
))
9190 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9192 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9197 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9199 "Return the denominator of the number @var{z}.")
9200 #define FUNC_NAME s_scm_denominator
9202 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9204 else if (SCM_FRACTIONP (z
))
9205 return SCM_FRACTION_DENOMINATOR (z
);
9206 else if (SCM_REALP (z
))
9207 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9209 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9214 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9216 "Return the magnitude of the number @var{z}. This is the same as\n"
9217 "@code{abs} for real arguments, but also allows complex numbers.")
9218 #define FUNC_NAME s_scm_magnitude
9220 if (SCM_I_INUMP (z
))
9222 scm_t_inum zz
= SCM_I_INUM (z
);
9225 else if (SCM_POSFIXABLE (-zz
))
9226 return SCM_I_MAKINUM (-zz
);
9228 return scm_i_inum2big (-zz
);
9230 else if (SCM_BIGP (z
))
9232 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9233 scm_remember_upto_here_1 (z
);
9235 return scm_i_clonebig (z
, 0);
9239 else if (SCM_REALP (z
))
9240 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9241 else if (SCM_COMPLEXP (z
))
9242 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9243 else if (SCM_FRACTIONP (z
))
9245 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9247 return scm_i_make_ratio_already_reduced
9248 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9249 SCM_FRACTION_DENOMINATOR (z
));
9252 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9257 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9259 "Return the angle of the complex number @var{z}.")
9260 #define FUNC_NAME s_scm_angle
9262 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9263 flo0 to save allocating a new flonum with scm_from_double each time.
9264 But if atan2 follows the floating point rounding mode, then the value
9265 is not a constant. Maybe it'd be close enough though. */
9266 if (SCM_I_INUMP (z
))
9268 if (SCM_I_INUM (z
) >= 0)
9271 return scm_from_double (atan2 (0.0, -1.0));
9273 else if (SCM_BIGP (z
))
9275 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9276 scm_remember_upto_here_1 (z
);
9278 return scm_from_double (atan2 (0.0, -1.0));
9282 else if (SCM_REALP (z
))
9284 double x
= SCM_REAL_VALUE (z
);
9285 if (x
> 0.0 || double_is_non_negative_zero (x
))
9288 return scm_from_double (atan2 (0.0, -1.0));
9290 else if (SCM_COMPLEXP (z
))
9291 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9292 else if (SCM_FRACTIONP (z
))
9294 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9296 else return scm_from_double (atan2 (0.0, -1.0));
9299 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9304 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9306 "Convert the number @var{z} to its inexact representation.\n")
9307 #define FUNC_NAME s_scm_exact_to_inexact
9309 if (SCM_I_INUMP (z
))
9310 return scm_from_double ((double) SCM_I_INUM (z
));
9311 else if (SCM_BIGP (z
))
9312 return scm_from_double (scm_i_big2dbl (z
));
9313 else if (SCM_FRACTIONP (z
))
9314 return scm_from_double (scm_i_fraction2double (z
));
9315 else if (SCM_INEXACTP (z
))
9318 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9323 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9325 "Return an exact number that is numerically closest to @var{z}.")
9326 #define FUNC_NAME s_scm_inexact_to_exact
9328 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9335 val
= SCM_REAL_VALUE (z
);
9336 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9337 val
= SCM_COMPLEX_REAL (z
);
9339 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9341 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9342 SCM_OUT_OF_RANGE (1, z
);
9343 else if (val
== 0.0)
9350 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9352 expon
-= DBL_MANT_DIG
;
9355 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9359 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9360 SCM_I_BIG_MPZ (numerator
),
9364 numerator
= scm_i_normbig (numerator
);
9366 return scm_i_make_ratio_already_reduced
9367 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9369 return left_shift_exact_integer (numerator
, expon
);
9377 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9379 "Returns the @emph{simplest} rational number differing\n"
9380 "from @var{x} by no more than @var{eps}.\n"
9382 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9383 "exact result when both its arguments are exact. Thus, you might need\n"
9384 "to use @code{inexact->exact} on the arguments.\n"
9387 "(rationalize (inexact->exact 1.2) 1/100)\n"
9390 #define FUNC_NAME s_scm_rationalize
9392 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9393 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9394 eps
= scm_abs (eps
);
9395 if (scm_is_false (scm_positive_p (eps
)))
9397 /* eps is either zero or a NaN */
9398 if (scm_is_true (scm_nan_p (eps
)))
9400 else if (SCM_INEXACTP (eps
))
9401 return scm_exact_to_inexact (x
);
9405 else if (scm_is_false (scm_finite_p (eps
)))
9407 if (scm_is_true (scm_finite_p (x
)))
9412 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9414 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9415 scm_ceiling (scm_difference (x
, eps
)))))
9417 /* There's an integer within range; we want the one closest to zero */
9418 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9420 /* zero is within range */
9421 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9426 else if (scm_is_true (scm_positive_p (x
)))
9427 return scm_ceiling (scm_difference (x
, eps
));
9429 return scm_floor (scm_sum (x
, eps
));
9433 /* Use continued fractions to find closest ratio. All
9434 arithmetic is done with exact numbers.
9437 SCM ex
= scm_inexact_to_exact (x
);
9438 SCM int_part
= scm_floor (ex
);
9440 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9441 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9445 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9446 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9448 /* We stop after a million iterations just to be absolutely sure
9449 that we don't go into an infinite loop. The process normally
9450 converges after less than a dozen iterations.
9453 while (++i
< 1000000)
9455 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9456 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9457 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9459 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9460 eps
))) /* abs(x-a/b) <= eps */
9462 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9463 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9464 return scm_exact_to_inexact (res
);
9468 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9470 tt
= scm_floor (rx
); /* tt = floor (rx) */
9476 scm_num_overflow (s_scm_rationalize
);
9481 /* conversion functions */
9484 scm_is_integer (SCM val
)
9486 return scm_is_true (scm_integer_p (val
));
9490 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9492 if (SCM_I_INUMP (val
))
9494 scm_t_signed_bits n
= SCM_I_INUM (val
);
9495 return n
>= min
&& n
<= max
;
9497 else if (SCM_BIGP (val
))
9499 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9501 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9503 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9505 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9506 return n
>= min
&& n
<= max
;
9516 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9517 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9520 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9521 SCM_I_BIG_MPZ (val
));
9523 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9535 return n
>= min
&& n
<= max
;
9543 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9545 if (SCM_I_INUMP (val
))
9547 scm_t_signed_bits n
= SCM_I_INUM (val
);
9548 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9550 else if (SCM_BIGP (val
))
9552 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9554 else if (max
<= ULONG_MAX
)
9556 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9558 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9559 return n
>= min
&& n
<= max
;
9569 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9572 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9573 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9576 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9577 SCM_I_BIG_MPZ (val
));
9579 return n
>= min
&& n
<= max
;
9587 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9589 scm_error (scm_out_of_range_key
,
9591 "Value out of range ~S to ~S: ~S",
9592 scm_list_3 (min
, max
, bad_val
),
9593 scm_list_1 (bad_val
));
9596 #define TYPE scm_t_intmax
9597 #define TYPE_MIN min
9598 #define TYPE_MAX max
9599 #define SIZEOF_TYPE 0
9600 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9601 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9602 #include "libguile/conv-integer.i.c"
9604 #define TYPE scm_t_uintmax
9605 #define TYPE_MIN min
9606 #define TYPE_MAX max
9607 #define SIZEOF_TYPE 0
9608 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9609 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9610 #include "libguile/conv-uinteger.i.c"
9612 #define TYPE scm_t_int8
9613 #define TYPE_MIN SCM_T_INT8_MIN
9614 #define TYPE_MAX SCM_T_INT8_MAX
9615 #define SIZEOF_TYPE 1
9616 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9617 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9618 #include "libguile/conv-integer.i.c"
9620 #define TYPE scm_t_uint8
9622 #define TYPE_MAX SCM_T_UINT8_MAX
9623 #define SIZEOF_TYPE 1
9624 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9625 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9626 #include "libguile/conv-uinteger.i.c"
9628 #define TYPE scm_t_int16
9629 #define TYPE_MIN SCM_T_INT16_MIN
9630 #define TYPE_MAX SCM_T_INT16_MAX
9631 #define SIZEOF_TYPE 2
9632 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9633 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9634 #include "libguile/conv-integer.i.c"
9636 #define TYPE scm_t_uint16
9638 #define TYPE_MAX SCM_T_UINT16_MAX
9639 #define SIZEOF_TYPE 2
9640 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9641 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9642 #include "libguile/conv-uinteger.i.c"
9644 #define TYPE scm_t_int32
9645 #define TYPE_MIN SCM_T_INT32_MIN
9646 #define TYPE_MAX SCM_T_INT32_MAX
9647 #define SIZEOF_TYPE 4
9648 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9649 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9650 #include "libguile/conv-integer.i.c"
9652 #define TYPE scm_t_uint32
9654 #define TYPE_MAX SCM_T_UINT32_MAX
9655 #define SIZEOF_TYPE 4
9656 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9657 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9658 #include "libguile/conv-uinteger.i.c"
9660 #define TYPE scm_t_wchar
9661 #define TYPE_MIN (scm_t_int32)-1
9662 #define TYPE_MAX (scm_t_int32)0x10ffff
9663 #define SIZEOF_TYPE 4
9664 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9665 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9666 #include "libguile/conv-integer.i.c"
9668 #define TYPE scm_t_int64
9669 #define TYPE_MIN SCM_T_INT64_MIN
9670 #define TYPE_MAX SCM_T_INT64_MAX
9671 #define SIZEOF_TYPE 8
9672 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9673 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9674 #include "libguile/conv-integer.i.c"
9676 #define TYPE scm_t_uint64
9678 #define TYPE_MAX SCM_T_UINT64_MAX
9679 #define SIZEOF_TYPE 8
9680 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9681 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9682 #include "libguile/conv-uinteger.i.c"
9685 scm_to_mpz (SCM val
, mpz_t rop
)
9687 if (SCM_I_INUMP (val
))
9688 mpz_set_si (rop
, SCM_I_INUM (val
));
9689 else if (SCM_BIGP (val
))
9690 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9692 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9696 scm_from_mpz (mpz_t val
)
9698 return scm_i_mpz2num (val
);
9702 scm_is_real (SCM val
)
9704 return scm_is_true (scm_real_p (val
));
9708 scm_is_rational (SCM val
)
9710 return scm_is_true (scm_rational_p (val
));
9714 scm_to_double (SCM val
)
9716 if (SCM_I_INUMP (val
))
9717 return SCM_I_INUM (val
);
9718 else if (SCM_BIGP (val
))
9719 return scm_i_big2dbl (val
);
9720 else if (SCM_FRACTIONP (val
))
9721 return scm_i_fraction2double (val
);
9722 else if (SCM_REALP (val
))
9723 return SCM_REAL_VALUE (val
);
9725 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9729 scm_from_double (double val
)
9733 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9735 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9736 SCM_REAL_VALUE (z
) = val
;
9741 #if SCM_ENABLE_DEPRECATED == 1
9744 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9746 scm_c_issue_deprecation_warning
9747 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9751 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9755 scm_out_of_range (NULL
, num
);
9758 return scm_to_double (num
);
9762 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9764 scm_c_issue_deprecation_warning
9765 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9769 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9773 scm_out_of_range (NULL
, num
);
9776 return scm_to_double (num
);
9782 scm_is_complex (SCM val
)
9784 return scm_is_true (scm_complex_p (val
));
9788 scm_c_real_part (SCM z
)
9790 if (SCM_COMPLEXP (z
))
9791 return SCM_COMPLEX_REAL (z
);
9794 /* Use the scm_real_part to get proper error checking and
9797 return scm_to_double (scm_real_part (z
));
9802 scm_c_imag_part (SCM z
)
9804 if (SCM_COMPLEXP (z
))
9805 return SCM_COMPLEX_IMAG (z
);
9808 /* Use the scm_imag_part to get proper error checking and
9809 dispatching. The result will almost always be 0.0, but not
9812 return scm_to_double (scm_imag_part (z
));
9817 scm_c_magnitude (SCM z
)
9819 return scm_to_double (scm_magnitude (z
));
9825 return scm_to_double (scm_angle (z
));
9829 scm_is_number (SCM z
)
9831 return scm_is_true (scm_number_p (z
));
9835 /* Returns log(x * 2^shift) */
9837 log_of_shifted_double (double x
, long shift
)
9839 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9841 if (x
> 0.0 || double_is_non_negative_zero (x
))
9842 return scm_from_double (ans
);
9844 return scm_c_make_rectangular (ans
, M_PI
);
9847 /* Returns log(n), for exact integer n */
9849 log_of_exact_integer (SCM n
)
9851 if (SCM_I_INUMP (n
))
9852 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9853 else if (SCM_BIGP (n
))
9856 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9857 return log_of_shifted_double (signif
, expon
);
9860 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9863 /* Returns log(n/d), for exact non-zero integers n and d */
9865 log_of_fraction (SCM n
, SCM d
)
9867 long n_size
= scm_to_long (scm_integer_length (n
));
9868 long d_size
= scm_to_long (scm_integer_length (d
));
9870 if (abs (n_size
- d_size
) > 1)
9871 return (scm_difference (log_of_exact_integer (n
),
9872 log_of_exact_integer (d
)));
9873 else if (scm_is_false (scm_negative_p (n
)))
9874 return scm_from_double
9875 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9877 return scm_c_make_rectangular
9878 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9884 /* In the following functions we dispatch to the real-arg funcs like log()
9885 when we know the arg is real, instead of just handing everything to
9886 clog() for instance. This is in case clog() doesn't optimize for a
9887 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9888 well use it to go straight to the applicable C func. */
9890 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9892 "Return the natural logarithm of @var{z}.")
9893 #define FUNC_NAME s_scm_log
9895 if (SCM_COMPLEXP (z
))
9897 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9898 && defined (SCM_COMPLEX_VALUE)
9899 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9901 double re
= SCM_COMPLEX_REAL (z
);
9902 double im
= SCM_COMPLEX_IMAG (z
);
9903 return scm_c_make_rectangular (log (hypot (re
, im
)),
9907 else if (SCM_REALP (z
))
9908 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9909 else if (SCM_I_INUMP (z
))
9911 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9912 if (scm_is_eq (z
, SCM_INUM0
))
9913 scm_num_overflow (s_scm_log
);
9915 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9917 else if (SCM_BIGP (z
))
9918 return log_of_exact_integer (z
);
9919 else if (SCM_FRACTIONP (z
))
9920 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9921 SCM_FRACTION_DENOMINATOR (z
));
9923 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9928 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9930 "Return the base 10 logarithm of @var{z}.")
9931 #define FUNC_NAME s_scm_log10
9933 if (SCM_COMPLEXP (z
))
9935 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9936 clog() and a multiply by M_LOG10E, rather than the fallback
9937 log10+hypot+atan2.) */
9938 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9939 && defined SCM_COMPLEX_VALUE
9940 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9942 double re
= SCM_COMPLEX_REAL (z
);
9943 double im
= SCM_COMPLEX_IMAG (z
);
9944 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9945 M_LOG10E
* atan2 (im
, re
));
9948 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9950 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9951 if (scm_is_eq (z
, SCM_INUM0
))
9952 scm_num_overflow (s_scm_log10
);
9955 double re
= scm_to_double (z
);
9956 double l
= log10 (fabs (re
));
9957 if (re
> 0.0 || double_is_non_negative_zero (re
))
9958 return scm_from_double (l
);
9960 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9963 else if (SCM_BIGP (z
))
9964 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9965 else if (SCM_FRACTIONP (z
))
9966 return scm_product (flo_log10e
,
9967 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9968 SCM_FRACTION_DENOMINATOR (z
)));
9970 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9975 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9977 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9978 "base of natural logarithms (2.71828@dots{}).")
9979 #define FUNC_NAME s_scm_exp
9981 if (SCM_COMPLEXP (z
))
9983 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9984 && defined (SCM_COMPLEX_VALUE)
9985 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9987 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9988 SCM_COMPLEX_IMAG (z
));
9991 else if (SCM_NUMBERP (z
))
9993 /* When z is a negative bignum the conversion to double overflows,
9994 giving -infinity, but that's ok, the exp is still 0.0. */
9995 return scm_from_double (exp (scm_to_double (z
)));
9998 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10003 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10005 "Return two exact non-negative integers @var{s} and @var{r}\n"
10006 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10007 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10008 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10011 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10013 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10017 scm_exact_integer_sqrt (k
, &s
, &r
);
10018 return scm_values (scm_list_2 (s
, r
));
10023 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10025 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10029 if (SCM_I_INUM (k
) < 0)
10030 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10031 "exact non-negative integer");
10032 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10033 mpz_inits (ss
, rr
, NULL
);
10034 mpz_sqrtrem (ss
, rr
, kk
);
10035 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10036 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10037 mpz_clears (kk
, ss
, rr
, NULL
);
10039 else if (SCM_LIKELY (SCM_BIGP (k
)))
10043 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10044 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10045 "exact non-negative integer");
10046 s
= scm_i_mkbig ();
10047 r
= scm_i_mkbig ();
10048 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10049 scm_remember_upto_here_1 (k
);
10050 *sp
= scm_i_normbig (s
);
10051 *rp
= scm_i_normbig (r
);
10054 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10055 "exact non-negative integer");
10058 /* Return true iff K is a perfect square.
10059 K must be an exact integer. */
10061 exact_integer_is_perfect_square (SCM k
)
10065 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10069 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10070 result
= mpz_perfect_square_p (kk
);
10075 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10076 scm_remember_upto_here_1 (k
);
10081 /* Return the floor of the square root of K.
10082 K must be an exact integer. */
10084 exact_integer_floor_square_root (SCM k
)
10086 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10091 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10093 ss
= mpz_get_ui (kk
);
10095 return SCM_I_MAKINUM (ss
);
10101 s
= scm_i_mkbig ();
10102 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10103 scm_remember_upto_here_1 (k
);
10104 return scm_i_normbig (s
);
10109 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10111 "Return the square root of @var{z}. Of the two possible roots\n"
10112 "(positive and negative), the one with positive real part\n"
10113 "is returned, or if that's zero then a positive imaginary part.\n"
10117 "(sqrt 9.0) @result{} 3.0\n"
10118 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10119 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10120 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10122 #define FUNC_NAME s_scm_sqrt
10124 if (SCM_COMPLEXP (z
))
10126 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10127 && defined SCM_COMPLEX_VALUE
10128 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10130 double re
= SCM_COMPLEX_REAL (z
);
10131 double im
= SCM_COMPLEX_IMAG (z
);
10132 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10133 0.5 * atan2 (im
, re
));
10136 else if (SCM_NUMBERP (z
))
10138 if (SCM_I_INUMP (z
))
10140 scm_t_inum x
= SCM_I_INUM (z
);
10142 if (SCM_LIKELY (x
>= 0))
10144 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10145 || x
< (1L << (DBL_MANT_DIG
- 1))))
10147 double root
= sqrt (x
);
10149 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10150 integer, then the result is exact. */
10151 if (root
== floor (root
))
10152 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10154 return scm_from_double (root
);
10161 mpz_init_set_ui (xx
, x
);
10162 if (mpz_perfect_square_p (xx
))
10165 root
= mpz_get_ui (xx
);
10167 return SCM_I_MAKINUM (root
);
10174 else if (SCM_BIGP (z
))
10176 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10178 SCM root
= scm_i_mkbig ();
10180 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10181 scm_remember_upto_here_1 (z
);
10182 return scm_i_normbig (root
);
10187 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10195 return scm_c_make_rectangular
10196 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10198 return scm_from_double (ldexp (sqrt (signif
), expon
/ 2));
10201 else if (SCM_FRACTIONP (z
))
10203 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10204 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10206 if (exact_integer_is_perfect_square (n
)
10207 && exact_integer_is_perfect_square (d
))
10208 return scm_i_make_ratio_already_reduced
10209 (exact_integer_floor_square_root (n
),
10210 exact_integer_floor_square_root (d
));
10213 double xx
= scm_i_divide2double (n
, d
);
10214 double abs_xx
= fabs (xx
);
10217 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10219 shift
= (scm_to_long (scm_integer_length (n
))
10220 - scm_to_long (scm_integer_length (d
))) / 2;
10222 d
= left_shift_exact_integer (d
, 2 * shift
);
10224 n
= left_shift_exact_integer (n
, -2 * shift
);
10225 xx
= scm_i_divide2double (n
, d
);
10229 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10231 return scm_from_double (ldexp (sqrt (xx
), shift
));
10235 /* Fallback method, when the cases above do not apply. */
10237 double xx
= scm_to_double (z
);
10239 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10241 return scm_from_double (sqrt (xx
));
10245 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10252 scm_init_numbers ()
10254 if (scm_install_gmp_memory_functions
)
10255 mp_set_memory_functions (custom_gmp_malloc
,
10256 custom_gmp_realloc
,
10259 mpz_init_set_si (z_negative_one
, -1);
10261 /* It may be possible to tune the performance of some algorithms by using
10262 * the following constants to avoid the creation of bignums. Please, before
10263 * using these values, remember the two rules of program optimization:
10264 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10265 scm_c_define ("most-positive-fixnum",
10266 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10267 scm_c_define ("most-negative-fixnum",
10268 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10270 scm_add_feature ("complex");
10271 scm_add_feature ("inexact");
10272 flo0
= scm_from_double (0.0);
10273 flo_log10e
= scm_from_double (M_LOG10E
);
10275 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10278 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10279 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10280 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10281 scm_i_divide2double_lo2b
,
10282 DBL_MANT_DIG
+ 1); /* 2 b^p */
10283 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10287 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10288 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10289 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10290 dbl_minimum_normal_mantissa
,
10294 #include "libguile/numbers.x"
10299 c-file-style: "gnu"