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
))
4149 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4151 else if (SCM_BIGP (x
))
4153 if (SCM_I_INUMP (y
))
4158 yy
= SCM_I_INUM (y
);
4163 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4164 scm_remember_upto_here_1 (x
);
4165 return (SCM_POSFIXABLE (result
)
4166 ? SCM_I_MAKINUM (result
)
4167 : scm_from_unsigned_integer (result
));
4169 else if (SCM_BIGP (y
))
4171 SCM result
= scm_i_mkbig ();
4172 mpz_gcd (SCM_I_BIG_MPZ (result
),
4175 scm_remember_upto_here_2 (x
, y
);
4176 return scm_i_normbig (result
);
4179 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4182 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4185 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4186 (SCM x
, SCM y
, SCM rest
),
4187 "Return the least common multiple of the arguments.\n"
4188 "If called without arguments, 1 is returned.")
4189 #define FUNC_NAME s_scm_i_lcm
4191 while (!scm_is_null (rest
))
4192 { x
= scm_lcm (x
, y
);
4194 rest
= scm_cdr (rest
);
4196 return scm_lcm (x
, y
);
4200 #define s_lcm s_scm_i_lcm
4201 #define g_lcm g_scm_i_lcm
4204 scm_lcm (SCM n1
, SCM n2
)
4206 if (SCM_UNBNDP (n2
))
4208 if (SCM_UNBNDP (n1
))
4209 return SCM_I_MAKINUM (1L);
4210 n2
= SCM_I_MAKINUM (1L);
4213 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4214 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4215 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4216 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4218 if (SCM_I_INUMP (n1
))
4220 if (SCM_I_INUMP (n2
))
4222 SCM d
= scm_gcd (n1
, n2
);
4223 if (scm_is_eq (d
, SCM_INUM0
))
4226 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4230 /* inum n1, big n2 */
4233 SCM result
= scm_i_mkbig ();
4234 scm_t_inum nn1
= SCM_I_INUM (n1
);
4235 if (nn1
== 0) return SCM_INUM0
;
4236 if (nn1
< 0) nn1
= - nn1
;
4237 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4238 scm_remember_upto_here_1 (n2
);
4246 if (SCM_I_INUMP (n2
))
4253 SCM result
= scm_i_mkbig ();
4254 mpz_lcm(SCM_I_BIG_MPZ (result
),
4256 SCM_I_BIG_MPZ (n2
));
4257 scm_remember_upto_here_2(n1
, n2
);
4258 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4264 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4269 + + + x (map digit:logand X Y)
4270 + - + x (map digit:logand X (lognot (+ -1 Y)))
4271 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4272 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4277 + + + (map digit:logior X Y)
4278 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4279 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4280 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4285 + + + (map digit:logxor X Y)
4286 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4287 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4288 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4293 + + (any digit:logand X Y)
4294 + - (any digit:logand X (lognot (+ -1 Y)))
4295 - + (any digit:logand (lognot (+ -1 X)) Y)
4300 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4301 (SCM x
, SCM y
, SCM rest
),
4302 "Return the bitwise AND of the integer arguments.\n\n"
4304 "(logand) @result{} -1\n"
4305 "(logand 7) @result{} 7\n"
4306 "(logand #b111 #b011 #b001) @result{} 1\n"
4308 #define FUNC_NAME s_scm_i_logand
4310 while (!scm_is_null (rest
))
4311 { x
= scm_logand (x
, y
);
4313 rest
= scm_cdr (rest
);
4315 return scm_logand (x
, y
);
4319 #define s_scm_logand s_scm_i_logand
4321 SCM
scm_logand (SCM n1
, SCM n2
)
4322 #define FUNC_NAME s_scm_logand
4326 if (SCM_UNBNDP (n2
))
4328 if (SCM_UNBNDP (n1
))
4329 return SCM_I_MAKINUM (-1);
4330 else if (!SCM_NUMBERP (n1
))
4331 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4332 else if (SCM_NUMBERP (n1
))
4335 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4338 if (SCM_I_INUMP (n1
))
4340 nn1
= SCM_I_INUM (n1
);
4341 if (SCM_I_INUMP (n2
))
4343 scm_t_inum nn2
= SCM_I_INUM (n2
);
4344 return SCM_I_MAKINUM (nn1
& nn2
);
4346 else if SCM_BIGP (n2
)
4352 SCM result_z
= scm_i_mkbig ();
4354 mpz_init_set_si (nn1_z
, nn1
);
4355 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4356 scm_remember_upto_here_1 (n2
);
4358 return scm_i_normbig (result_z
);
4362 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4364 else if (SCM_BIGP (n1
))
4366 if (SCM_I_INUMP (n2
))
4369 nn1
= SCM_I_INUM (n1
);
4372 else if (SCM_BIGP (n2
))
4374 SCM result_z
= scm_i_mkbig ();
4375 mpz_and (SCM_I_BIG_MPZ (result_z
),
4377 SCM_I_BIG_MPZ (n2
));
4378 scm_remember_upto_here_2 (n1
, n2
);
4379 return scm_i_normbig (result_z
);
4382 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4385 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4390 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4391 (SCM x
, SCM y
, SCM rest
),
4392 "Return the bitwise OR of the integer arguments.\n\n"
4394 "(logior) @result{} 0\n"
4395 "(logior 7) @result{} 7\n"
4396 "(logior #b000 #b001 #b011) @result{} 3\n"
4398 #define FUNC_NAME s_scm_i_logior
4400 while (!scm_is_null (rest
))
4401 { x
= scm_logior (x
, y
);
4403 rest
= scm_cdr (rest
);
4405 return scm_logior (x
, y
);
4409 #define s_scm_logior s_scm_i_logior
4411 SCM
scm_logior (SCM n1
, SCM n2
)
4412 #define FUNC_NAME s_scm_logior
4416 if (SCM_UNBNDP (n2
))
4418 if (SCM_UNBNDP (n1
))
4420 else if (SCM_NUMBERP (n1
))
4423 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4426 if (SCM_I_INUMP (n1
))
4428 nn1
= SCM_I_INUM (n1
);
4429 if (SCM_I_INUMP (n2
))
4431 long nn2
= SCM_I_INUM (n2
);
4432 return SCM_I_MAKINUM (nn1
| nn2
);
4434 else if (SCM_BIGP (n2
))
4440 SCM result_z
= scm_i_mkbig ();
4442 mpz_init_set_si (nn1_z
, nn1
);
4443 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4444 scm_remember_upto_here_1 (n2
);
4446 return scm_i_normbig (result_z
);
4450 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4452 else if (SCM_BIGP (n1
))
4454 if (SCM_I_INUMP (n2
))
4457 nn1
= SCM_I_INUM (n1
);
4460 else if (SCM_BIGP (n2
))
4462 SCM result_z
= scm_i_mkbig ();
4463 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4465 SCM_I_BIG_MPZ (n2
));
4466 scm_remember_upto_here_2 (n1
, n2
);
4467 return scm_i_normbig (result_z
);
4470 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4473 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4478 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4479 (SCM x
, SCM y
, SCM rest
),
4480 "Return the bitwise XOR of the integer arguments. A bit is\n"
4481 "set in the result if it is set in an odd number of arguments.\n"
4483 "(logxor) @result{} 0\n"
4484 "(logxor 7) @result{} 7\n"
4485 "(logxor #b000 #b001 #b011) @result{} 2\n"
4486 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4488 #define FUNC_NAME s_scm_i_logxor
4490 while (!scm_is_null (rest
))
4491 { x
= scm_logxor (x
, y
);
4493 rest
= scm_cdr (rest
);
4495 return scm_logxor (x
, y
);
4499 #define s_scm_logxor s_scm_i_logxor
4501 SCM
scm_logxor (SCM n1
, SCM n2
)
4502 #define FUNC_NAME s_scm_logxor
4506 if (SCM_UNBNDP (n2
))
4508 if (SCM_UNBNDP (n1
))
4510 else if (SCM_NUMBERP (n1
))
4513 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4516 if (SCM_I_INUMP (n1
))
4518 nn1
= SCM_I_INUM (n1
);
4519 if (SCM_I_INUMP (n2
))
4521 scm_t_inum nn2
= SCM_I_INUM (n2
);
4522 return SCM_I_MAKINUM (nn1
^ nn2
);
4524 else if (SCM_BIGP (n2
))
4528 SCM result_z
= scm_i_mkbig ();
4530 mpz_init_set_si (nn1_z
, nn1
);
4531 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4532 scm_remember_upto_here_1 (n2
);
4534 return scm_i_normbig (result_z
);
4538 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4540 else if (SCM_BIGP (n1
))
4542 if (SCM_I_INUMP (n2
))
4545 nn1
= SCM_I_INUM (n1
);
4548 else if (SCM_BIGP (n2
))
4550 SCM result_z
= scm_i_mkbig ();
4551 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4553 SCM_I_BIG_MPZ (n2
));
4554 scm_remember_upto_here_2 (n1
, n2
);
4555 return scm_i_normbig (result_z
);
4558 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4561 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4566 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4568 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4569 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4570 "without actually calculating the @code{logand}, just testing\n"
4574 "(logtest #b0100 #b1011) @result{} #f\n"
4575 "(logtest #b0100 #b0111) @result{} #t\n"
4577 #define FUNC_NAME s_scm_logtest
4581 if (SCM_I_INUMP (j
))
4583 nj
= SCM_I_INUM (j
);
4584 if (SCM_I_INUMP (k
))
4586 scm_t_inum nk
= SCM_I_INUM (k
);
4587 return scm_from_bool (nj
& nk
);
4589 else if (SCM_BIGP (k
))
4597 mpz_init_set_si (nj_z
, nj
);
4598 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4599 scm_remember_upto_here_1 (k
);
4600 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4606 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4608 else if (SCM_BIGP (j
))
4610 if (SCM_I_INUMP (k
))
4613 nj
= SCM_I_INUM (j
);
4616 else if (SCM_BIGP (k
))
4620 mpz_init (result_z
);
4624 scm_remember_upto_here_2 (j
, k
);
4625 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4626 mpz_clear (result_z
);
4630 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4633 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4638 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4640 "Test whether bit number @var{index} in @var{j} is set.\n"
4641 "@var{index} starts from 0 for the least significant bit.\n"
4644 "(logbit? 0 #b1101) @result{} #t\n"
4645 "(logbit? 1 #b1101) @result{} #f\n"
4646 "(logbit? 2 #b1101) @result{} #t\n"
4647 "(logbit? 3 #b1101) @result{} #t\n"
4648 "(logbit? 4 #b1101) @result{} #f\n"
4650 #define FUNC_NAME s_scm_logbit_p
4652 unsigned long int iindex
;
4653 iindex
= scm_to_ulong (index
);
4655 if (SCM_I_INUMP (j
))
4657 /* bits above what's in an inum follow the sign bit */
4658 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4659 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4661 else if (SCM_BIGP (j
))
4663 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4664 scm_remember_upto_here_1 (j
);
4665 return scm_from_bool (val
);
4668 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4673 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4675 "Return the integer which is the ones-complement of the integer\n"
4679 "(number->string (lognot #b10000000) 2)\n"
4680 " @result{} \"-10000001\"\n"
4681 "(number->string (lognot #b0) 2)\n"
4682 " @result{} \"-1\"\n"
4684 #define FUNC_NAME s_scm_lognot
4686 if (SCM_I_INUMP (n
)) {
4687 /* No overflow here, just need to toggle all the bits making up the inum.
4688 Enhancement: No need to strip the tag and add it back, could just xor
4689 a block of 1 bits, if that worked with the various debug versions of
4691 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4693 } else if (SCM_BIGP (n
)) {
4694 SCM result
= scm_i_mkbig ();
4695 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4696 scm_remember_upto_here_1 (n
);
4700 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4705 /* returns 0 if IN is not an integer. OUT must already be
4708 coerce_to_big (SCM in
, mpz_t out
)
4711 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4712 else if (SCM_I_INUMP (in
))
4713 mpz_set_si (out
, SCM_I_INUM (in
));
4720 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4721 (SCM n
, SCM k
, SCM m
),
4722 "Return @var{n} raised to the integer exponent\n"
4723 "@var{k}, modulo @var{m}.\n"
4726 "(modulo-expt 2 3 5)\n"
4729 #define FUNC_NAME s_scm_modulo_expt
4735 /* There are two classes of error we might encounter --
4736 1) Math errors, which we'll report by calling scm_num_overflow,
4738 2) wrong-type errors, which of course we'll report by calling
4740 We don't report those errors immediately, however; instead we do
4741 some cleanup first. These variables tell us which error (if
4742 any) we should report after cleaning up.
4744 int report_overflow
= 0;
4746 int position_of_wrong_type
= 0;
4747 SCM value_of_wrong_type
= SCM_INUM0
;
4749 SCM result
= SCM_UNDEFINED
;
4755 if (scm_is_eq (m
, SCM_INUM0
))
4757 report_overflow
= 1;
4761 if (!coerce_to_big (n
, n_tmp
))
4763 value_of_wrong_type
= n
;
4764 position_of_wrong_type
= 1;
4768 if (!coerce_to_big (k
, k_tmp
))
4770 value_of_wrong_type
= k
;
4771 position_of_wrong_type
= 2;
4775 if (!coerce_to_big (m
, m_tmp
))
4777 value_of_wrong_type
= m
;
4778 position_of_wrong_type
= 3;
4782 /* if the exponent K is negative, and we simply call mpz_powm, we
4783 will get a divide-by-zero exception when an inverse 1/n mod m
4784 doesn't exist (or is not unique). Since exceptions are hard to
4785 handle, we'll attempt the inversion "by hand" -- that way, we get
4786 a simple failure code, which is easy to handle. */
4788 if (-1 == mpz_sgn (k_tmp
))
4790 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4792 report_overflow
= 1;
4795 mpz_neg (k_tmp
, k_tmp
);
4798 result
= scm_i_mkbig ();
4799 mpz_powm (SCM_I_BIG_MPZ (result
),
4804 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4805 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4812 if (report_overflow
)
4813 scm_num_overflow (FUNC_NAME
);
4815 if (position_of_wrong_type
)
4816 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4817 value_of_wrong_type
);
4819 return scm_i_normbig (result
);
4823 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4825 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4826 "exact integer, @var{n} can be any number.\n"
4828 "Negative @var{k} is supported, and results in\n"
4829 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4830 "@math{@var{n}^0} is 1, as usual, and that\n"
4831 "includes @math{0^0} is 1.\n"
4834 "(integer-expt 2 5) @result{} 32\n"
4835 "(integer-expt -3 3) @result{} -27\n"
4836 "(integer-expt 5 -3) @result{} 1/125\n"
4837 "(integer-expt 0 0) @result{} 1\n"
4839 #define FUNC_NAME s_scm_integer_expt
4842 SCM z_i2
= SCM_BOOL_F
;
4844 SCM acc
= SCM_I_MAKINUM (1L);
4846 /* Specifically refrain from checking the type of the first argument.
4847 This allows us to exponentiate any object that can be multiplied.
4848 If we must raise to a negative power, we must also be able to
4849 take its reciprocal. */
4850 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4851 SCM_WRONG_TYPE_ARG (2, k
);
4853 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4854 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4855 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4856 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4857 /* The next check is necessary only because R6RS specifies different
4858 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4859 we simply skip this case and move on. */
4860 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4862 /* k cannot be 0 at this point, because we
4863 have already checked for that case above */
4864 if (scm_is_true (scm_positive_p (k
)))
4866 else /* return NaN for (0 ^ k) for negative k per R6RS */
4869 else if (SCM_FRACTIONP (n
))
4871 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4872 needless reduction of intermediate products to lowest terms.
4873 If a and b have no common factors, then a^k and b^k have no
4874 common factors. Use 'scm_i_make_ratio_already_reduced' to
4875 construct the final result, so that no gcd computations are
4876 needed to exponentiate a fraction. */
4877 if (scm_is_true (scm_positive_p (k
)))
4878 return scm_i_make_ratio_already_reduced
4879 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4880 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4883 k
= scm_difference (k
, SCM_UNDEFINED
);
4884 return scm_i_make_ratio_already_reduced
4885 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4886 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4890 if (SCM_I_INUMP (k
))
4891 i2
= SCM_I_INUM (k
);
4892 else if (SCM_BIGP (k
))
4894 z_i2
= scm_i_clonebig (k
, 1);
4895 scm_remember_upto_here_1 (k
);
4899 SCM_WRONG_TYPE_ARG (2, k
);
4903 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4905 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4906 n
= scm_divide (n
, SCM_UNDEFINED
);
4910 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4914 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4916 return scm_product (acc
, n
);
4918 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4919 acc
= scm_product (acc
, n
);
4920 n
= scm_product (n
, n
);
4921 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4929 n
= scm_divide (n
, SCM_UNDEFINED
);
4936 return scm_product (acc
, n
);
4938 acc
= scm_product (acc
, n
);
4939 n
= scm_product (n
, n
);
4946 /* Efficiently compute (N * 2^COUNT),
4947 where N is an exact integer, and COUNT > 0. */
4949 left_shift_exact_integer (SCM n
, long count
)
4951 if (SCM_I_INUMP (n
))
4953 scm_t_inum nn
= SCM_I_INUM (n
);
4955 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4956 overflow a non-zero fixnum. For smaller shifts we check the
4957 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4958 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4959 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4963 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4964 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4966 return SCM_I_MAKINUM (nn
<< count
);
4969 SCM result
= scm_i_inum2big (nn
);
4970 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4975 else if (SCM_BIGP (n
))
4977 SCM result
= scm_i_mkbig ();
4978 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
4979 scm_remember_upto_here_1 (n
);
4983 scm_syserror ("left_shift_exact_integer");
4986 /* Efficiently compute floor (N / 2^COUNT),
4987 where N is an exact integer and COUNT > 0. */
4989 floor_right_shift_exact_integer (SCM n
, long count
)
4991 if (SCM_I_INUMP (n
))
4993 scm_t_inum nn
= SCM_I_INUM (n
);
4995 if (count
>= SCM_I_FIXNUM_BIT
)
4996 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
4998 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5000 else if (SCM_BIGP (n
))
5002 SCM result
= scm_i_mkbig ();
5003 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5005 scm_remember_upto_here_1 (n
);
5006 return scm_i_normbig (result
);
5009 scm_syserror ("floor_right_shift_exact_integer");
5012 /* Efficiently compute round (N / 2^COUNT),
5013 where N is an exact integer and COUNT > 0. */
5015 round_right_shift_exact_integer (SCM n
, long count
)
5017 if (SCM_I_INUMP (n
))
5019 if (count
>= SCM_I_FIXNUM_BIT
)
5023 scm_t_inum nn
= SCM_I_INUM (n
);
5024 scm_t_inum qq
= SCM_SRS (nn
, count
);
5026 if (0 == (nn
& (1L << (count
-1))))
5027 return SCM_I_MAKINUM (qq
); /* round down */
5028 else if (nn
& ((1L << (count
-1)) - 1))
5029 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5031 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5034 else if (SCM_BIGP (n
))
5036 SCM q
= scm_i_mkbig ();
5038 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5039 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5040 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5041 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5042 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5043 scm_remember_upto_here_1 (n
);
5044 return scm_i_normbig (q
);
5047 scm_syserror ("round_right_shift_exact_integer");
5050 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5052 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5053 "@var{n} and @var{count} must be exact integers.\n"
5055 "With @var{n} viewed as an infinite-precision twos-complement\n"
5056 "integer, @code{ash} means a left shift introducing zero bits\n"
5057 "when @var{count} is positive, or a right shift dropping bits\n"
5058 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5061 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5062 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5064 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5065 "(ash -23 -2) @result{} -6\n"
5067 #define FUNC_NAME s_scm_ash
5069 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5071 long bits_to_shift
= scm_to_long (count
);
5073 if (bits_to_shift
> 0)
5074 return left_shift_exact_integer (n
, bits_to_shift
);
5075 else if (SCM_LIKELY (bits_to_shift
< 0))
5076 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5081 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5085 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5087 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5088 "@var{n} and @var{count} must be exact integers.\n"
5090 "With @var{n} viewed as an infinite-precision twos-complement\n"
5091 "integer, @code{round-ash} means a left shift introducing zero\n"
5092 "bits when @var{count} is positive, or a right shift rounding\n"
5093 "to the nearest integer (with ties going to the nearest even\n"
5094 "integer) when @var{count} is negative. This is a rounded\n"
5095 "``arithmetic'' shift.\n"
5098 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5099 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5100 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5101 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5102 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5103 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5105 #define FUNC_NAME s_scm_round_ash
5107 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5109 long bits_to_shift
= scm_to_long (count
);
5111 if (bits_to_shift
> 0)
5112 return left_shift_exact_integer (n
, bits_to_shift
);
5113 else if (SCM_LIKELY (bits_to_shift
< 0))
5114 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5119 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5124 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5125 (SCM n
, SCM start
, SCM end
),
5126 "Return the integer composed of the @var{start} (inclusive)\n"
5127 "through @var{end} (exclusive) bits of @var{n}. The\n"
5128 "@var{start}th bit becomes the 0-th bit in the result.\n"
5131 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5132 " @result{} \"1010\"\n"
5133 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5134 " @result{} \"10110\"\n"
5136 #define FUNC_NAME s_scm_bit_extract
5138 unsigned long int istart
, iend
, bits
;
5139 istart
= scm_to_ulong (start
);
5140 iend
= scm_to_ulong (end
);
5141 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5143 /* how many bits to keep */
5144 bits
= iend
- istart
;
5146 if (SCM_I_INUMP (n
))
5148 scm_t_inum in
= SCM_I_INUM (n
);
5150 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5151 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5152 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5154 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5156 /* Since we emulate two's complement encoded numbers, this
5157 * special case requires us to produce a result that has
5158 * more bits than can be stored in a fixnum.
5160 SCM result
= scm_i_inum2big (in
);
5161 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5166 /* mask down to requisite bits */
5167 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5168 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5170 else if (SCM_BIGP (n
))
5175 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5179 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5180 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5181 such bits into a ulong. */
5182 result
= scm_i_mkbig ();
5183 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5184 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5185 result
= scm_i_normbig (result
);
5187 scm_remember_upto_here_1 (n
);
5191 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5196 static const char scm_logtab
[] = {
5197 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5200 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5202 "Return the number of bits in integer @var{n}. If integer is\n"
5203 "positive, the 1-bits in its binary representation are counted.\n"
5204 "If negative, the 0-bits in its two's-complement binary\n"
5205 "representation are counted. If 0, 0 is returned.\n"
5208 "(logcount #b10101010)\n"
5215 #define FUNC_NAME s_scm_logcount
5217 if (SCM_I_INUMP (n
))
5219 unsigned long c
= 0;
5220 scm_t_inum nn
= SCM_I_INUM (n
);
5225 c
+= scm_logtab
[15 & nn
];
5228 return SCM_I_MAKINUM (c
);
5230 else if (SCM_BIGP (n
))
5232 unsigned long count
;
5233 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5234 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5236 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5237 scm_remember_upto_here_1 (n
);
5238 return SCM_I_MAKINUM (count
);
5241 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5246 static const char scm_ilentab
[] = {
5247 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5251 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5253 "Return the number of bits necessary to represent @var{n}.\n"
5256 "(integer-length #b10101010)\n"
5258 "(integer-length 0)\n"
5260 "(integer-length #b1111)\n"
5263 #define FUNC_NAME s_scm_integer_length
5265 if (SCM_I_INUMP (n
))
5267 unsigned long c
= 0;
5269 scm_t_inum nn
= SCM_I_INUM (n
);
5275 l
= scm_ilentab
[15 & nn
];
5278 return SCM_I_MAKINUM (c
- 4 + l
);
5280 else if (SCM_BIGP (n
))
5282 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5283 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5284 1 too big, so check for that and adjust. */
5285 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5286 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5287 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5288 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5290 scm_remember_upto_here_1 (n
);
5291 return SCM_I_MAKINUM (size
);
5294 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5298 /*** NUMBERS -> STRINGS ***/
5299 #define SCM_MAX_DBL_RADIX 36
5301 /* use this array as a way to generate a single digit */
5302 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5304 static mpz_t dbl_minimum_normal_mantissa
;
5307 idbl2str (double dbl
, char *a
, int radix
)
5311 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5312 /* revert to existing behavior */
5317 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5327 else if (dbl
== 0.0)
5329 if (!double_is_non_negative_zero (dbl
))
5331 strcpy (a
+ ch
, "0.0");
5334 else if (isnan (dbl
))
5336 strcpy (a
, "+nan.0");
5340 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5341 Accurately" by Robert G. Burger and R. Kent Dybvig */
5344 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5345 int f_is_even
, f_is_odd
;
5349 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5350 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5351 if (e
< DBL_MIN_EXP
)
5353 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5358 f_is_even
= !mpz_odd_p (f
);
5359 f_is_odd
= !f_is_even
;
5361 /* Initialize r, s, mplus, and mminus according
5362 to Table 1 from the paper. */
5365 mpz_set_ui (mminus
, 1);
5366 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5367 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5369 mpz_set_ui (mplus
, 1);
5370 mpz_mul_2exp (r
, f
, 1);
5371 mpz_mul_2exp (s
, mminus
, 1 - e
);
5375 mpz_set_ui (mplus
, 2);
5376 mpz_mul_2exp (r
, f
, 2);
5377 mpz_mul_2exp (s
, mminus
, 2 - e
);
5382 mpz_set_ui (mminus
, 1);
5383 mpz_mul_2exp (mminus
, mminus
, e
);
5384 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5386 mpz_set (mplus
, mminus
);
5387 mpz_mul_2exp (r
, f
, 1 + e
);
5392 mpz_mul_2exp (mplus
, mminus
, 1);
5393 mpz_mul_2exp (r
, f
, 2 + e
);
5398 /* Find the smallest k such that:
5399 (r + mplus) / s < radix^k (if f is even)
5400 (r + mplus) / s <= radix^k (if f is odd) */
5402 /* IMPROVE-ME: Make an initial guess to speed this up */
5403 mpz_add (hi
, r
, mplus
);
5405 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5407 mpz_mul_ui (s
, s
, radix
);
5412 mpz_mul_ui (hi
, hi
, radix
);
5413 while (mpz_cmp (hi
, s
) < f_is_odd
)
5415 mpz_mul_ui (r
, r
, radix
);
5416 mpz_mul_ui (mplus
, mplus
, radix
);
5417 mpz_mul_ui (mminus
, mminus
, radix
);
5418 mpz_mul_ui (hi
, hi
, radix
);
5429 /* Use scientific notation */
5437 /* Print leading zeroes */
5440 for (i
= 0; i
> k
; i
--)
5447 int end_1_p
, end_2_p
;
5450 mpz_mul_ui (mplus
, mplus
, radix
);
5451 mpz_mul_ui (mminus
, mminus
, radix
);
5452 mpz_mul_ui (r
, r
, radix
);
5453 mpz_fdiv_qr (digit
, r
, r
, s
);
5454 d
= mpz_get_ui (digit
);
5456 mpz_add (hi
, r
, mplus
);
5457 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5458 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5459 if (end_1_p
|| end_2_p
)
5461 mpz_mul_2exp (r
, r
, 1);
5466 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5468 a
[ch
++] = number_chars
[d
];
5475 a
[ch
++] = number_chars
[d
];
5483 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5485 /* Here we would have to print more than three zeroes
5486 followed by a decimal point and another zero. It
5487 makes more sense to use scientific notation. */
5489 /* Adjust k to what it would have been if we had chosen
5490 scientific notation from the beginning. */
5493 /* k will now be <= 0, with magnitude equal to the number of
5494 digits that we printed which should now be put after the
5497 /* Insert a decimal point */
5498 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5518 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5521 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5528 icmplx2str (double real
, double imag
, char *str
, int radix
)
5533 i
= idbl2str (real
, str
, radix
);
5534 #ifdef HAVE_COPYSIGN
5535 sgn
= copysign (1.0, imag
);
5539 /* Don't output a '+' for negative numbers or for Inf and
5540 NaN. They will provide their own sign. */
5541 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5543 i
+= idbl2str (imag
, &str
[i
], radix
);
5549 iflo2str (SCM flt
, char *str
, int radix
)
5552 if (SCM_REALP (flt
))
5553 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5555 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5560 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5561 characters in the result.
5563 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5565 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5570 return scm_iuint2str (-num
, rad
, p
) + 1;
5573 return scm_iuint2str (num
, rad
, p
);
5576 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5577 characters in the result.
5579 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5581 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5585 scm_t_uintmax n
= num
;
5587 if (rad
< 2 || rad
> 36)
5588 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5590 for (n
/= rad
; n
> 0; n
/= rad
)
5600 p
[i
] = number_chars
[d
];
5605 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5607 "Return a string holding the external representation of the\n"
5608 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5609 "inexact, a radix of 10 will be used.")
5610 #define FUNC_NAME s_scm_number_to_string
5614 if (SCM_UNBNDP (radix
))
5617 base
= scm_to_signed_integer (radix
, 2, 36);
5619 if (SCM_I_INUMP (n
))
5621 char num_buf
[SCM_INTBUFLEN
];
5622 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5623 return scm_from_locale_stringn (num_buf
, length
);
5625 else if (SCM_BIGP (n
))
5627 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5628 size_t len
= strlen (str
);
5629 void (*freefunc
) (void *, size_t);
5631 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5632 scm_remember_upto_here_1 (n
);
5633 ret
= scm_from_latin1_stringn (str
, len
);
5634 freefunc (str
, len
+ 1);
5637 else if (SCM_FRACTIONP (n
))
5639 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5640 scm_from_locale_string ("/"),
5641 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5643 else if (SCM_INEXACTP (n
))
5645 char num_buf
[FLOBUFLEN
];
5646 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5649 SCM_WRONG_TYPE_ARG (1, n
);
5654 /* These print routines used to be stubbed here so that scm_repl.c
5655 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5658 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5660 char num_buf
[FLOBUFLEN
];
5661 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5666 scm_i_print_double (double val
, SCM port
)
5668 char num_buf
[FLOBUFLEN
];
5669 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5673 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5676 char num_buf
[FLOBUFLEN
];
5677 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5682 scm_i_print_complex (double real
, double imag
, SCM port
)
5684 char num_buf
[FLOBUFLEN
];
5685 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5689 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5692 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5693 scm_display (str
, port
);
5694 scm_remember_upto_here_1 (str
);
5699 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5701 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5702 size_t len
= strlen (str
);
5703 void (*freefunc
) (void *, size_t);
5704 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5705 scm_remember_upto_here_1 (exp
);
5706 scm_lfwrite (str
, len
, port
);
5707 freefunc (str
, len
+ 1);
5710 /*** END nums->strs ***/
5713 /*** STRINGS -> NUMBERS ***/
5715 /* The following functions implement the conversion from strings to numbers.
5716 * The implementation somehow follows the grammar for numbers as it is given
5717 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5718 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5719 * points should be noted about the implementation:
5721 * * Each function keeps a local index variable 'idx' that points at the
5722 * current position within the parsed string. The global index is only
5723 * updated if the function could parse the corresponding syntactic unit
5726 * * Similarly, the functions keep track of indicators of inexactness ('#',
5727 * '.' or exponents) using local variables ('hash_seen', 'x').
5729 * * Sequences of digits are parsed into temporary variables holding fixnums.
5730 * Only if these fixnums would overflow, the result variables are updated
5731 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5732 * the temporary variables holding the fixnums are cleared, and the process
5733 * starts over again. If for example fixnums were able to store five decimal
5734 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5735 * and the result was computed as 12345 * 100000 + 67890. In other words,
5736 * only every five digits two bignum operations were performed.
5738 * Notes on the handling of exactness specifiers:
5740 * When parsing non-real complex numbers, we apply exactness specifiers on
5741 * per-component basis, as is done in PLT Scheme. For complex numbers
5742 * written in rectangular form, exactness specifiers are applied to the
5743 * real and imaginary parts before calling scm_make_rectangular. For
5744 * complex numbers written in polar form, exactness specifiers are applied
5745 * to the magnitude and angle before calling scm_make_polar.
5747 * There are two kinds of exactness specifiers: forced and implicit. A
5748 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5749 * the entire number, and applies to both components of a complex number.
5750 * "#e" causes each component to be made exact, and "#i" causes each
5751 * component to be made inexact. If no forced exactness specifier is
5752 * present, then the exactness of each component is determined
5753 * independently by the presence or absence of a decimal point or hash mark
5754 * within that component. If a decimal point or hash mark is present, the
5755 * component is made inexact, otherwise it is made exact.
5757 * After the exactness specifiers have been applied to each component, they
5758 * are passed to either scm_make_rectangular or scm_make_polar to produce
5759 * the final result. Note that this will result in a real number if the
5760 * imaginary part, magnitude, or angle is an exact 0.
5762 * For example, (string->number "#i5.0+0i") does the equivalent of:
5764 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5767 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5769 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5771 /* Caller is responsible for checking that the return value is in range
5772 for the given radix, which should be <= 36. */
5774 char_decimal_value (scm_t_uint32 c
)
5776 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5777 that's certainly above any valid decimal, so we take advantage of
5778 that to elide some tests. */
5779 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5781 /* If that failed, try extended hexadecimals, then. Only accept ascii
5786 if (c
>= (scm_t_uint32
) 'a')
5787 d
= c
- (scm_t_uint32
)'a' + 10U;
5792 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5793 in base RADIX. Upon success, return the unsigned integer and update
5794 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5796 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5797 unsigned int radix
, enum t_exactness
*p_exactness
)
5799 unsigned int idx
= *p_idx
;
5800 unsigned int hash_seen
= 0;
5801 scm_t_bits shift
= 1;
5803 unsigned int digit_value
;
5806 size_t len
= scm_i_string_length (mem
);
5811 c
= scm_i_string_ref (mem
, idx
);
5812 digit_value
= char_decimal_value (c
);
5813 if (digit_value
>= radix
)
5817 result
= SCM_I_MAKINUM (digit_value
);
5820 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5830 digit_value
= char_decimal_value (c
);
5831 /* This check catches non-decimals in addition to out-of-range
5833 if (digit_value
>= radix
)
5838 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5840 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5842 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5849 shift
= shift
* radix
;
5850 add
= add
* radix
+ digit_value
;
5855 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5857 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5861 *p_exactness
= INEXACT
;
5867 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5868 * covers the parts of the rules that start at a potential point. The value
5869 * of the digits up to the point have been parsed by the caller and are given
5870 * in variable result. The content of *p_exactness indicates, whether a hash
5871 * has already been seen in the digits before the point.
5874 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5877 mem2decimal_from_point (SCM result
, SCM mem
,
5878 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5880 unsigned int idx
= *p_idx
;
5881 enum t_exactness x
= *p_exactness
;
5882 size_t len
= scm_i_string_length (mem
);
5887 if (scm_i_string_ref (mem
, idx
) == '.')
5889 scm_t_bits shift
= 1;
5891 unsigned int digit_value
;
5892 SCM big_shift
= SCM_INUM1
;
5897 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5898 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5903 digit_value
= DIGIT2UINT (c
);
5914 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5916 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5917 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5919 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5927 add
= add
* 10 + digit_value
;
5933 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5934 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5935 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5938 result
= scm_divide (result
, big_shift
);
5940 /* We've seen a decimal point, thus the value is implicitly inexact. */
5952 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5954 switch (scm_i_string_ref (mem
, idx
))
5966 c
= scm_i_string_ref (mem
, idx
);
5974 c
= scm_i_string_ref (mem
, idx
);
5983 c
= scm_i_string_ref (mem
, idx
);
5988 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5992 exponent
= DIGIT2UINT (c
);
5995 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5996 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5999 if (exponent
<= SCM_MAXEXP
)
6000 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6006 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6008 size_t exp_len
= idx
- start
;
6009 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6010 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6011 scm_out_of_range ("string->number", exp_num
);
6014 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6016 result
= scm_product (result
, e
);
6018 result
= scm_divide (result
, e
);
6020 /* We've seen an exponent, thus the value is implicitly inexact. */
6038 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6041 mem2ureal (SCM mem
, unsigned int *p_idx
,
6042 unsigned int radix
, enum t_exactness forced_x
,
6043 int allow_inf_or_nan
)
6045 unsigned int idx
= *p_idx
;
6047 size_t len
= scm_i_string_length (mem
);
6049 /* Start off believing that the number will be exact. This changes
6050 to INEXACT if we see a decimal point or a hash. */
6051 enum t_exactness implicit_x
= EXACT
;
6056 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6057 switch (scm_i_string_ref (mem
, idx
))
6060 switch (scm_i_string_ref (mem
, idx
+ 1))
6063 switch (scm_i_string_ref (mem
, idx
+ 2))
6066 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6067 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6075 switch (scm_i_string_ref (mem
, idx
+ 1))
6078 switch (scm_i_string_ref (mem
, idx
+ 2))
6081 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6083 /* Cobble up the fractional part. We might want to
6084 set the NaN's mantissa from it. */
6086 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6089 #if SCM_ENABLE_DEPRECATED == 1
6090 scm_c_issue_deprecation_warning
6091 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6104 if (scm_i_string_ref (mem
, idx
) == '.')
6108 else if (idx
+ 1 == len
)
6110 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6113 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6114 p_idx
, &implicit_x
);
6120 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6121 if (scm_is_false (uinteger
))
6126 else if (scm_i_string_ref (mem
, idx
) == '/')
6134 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6135 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6138 /* both are int/big here, I assume */
6139 result
= scm_i_make_ratio (uinteger
, divisor
);
6141 else if (radix
== 10)
6143 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6144 if (scm_is_false (result
))
6156 if (SCM_INEXACTP (result
))
6157 return scm_inexact_to_exact (result
);
6161 if (SCM_INEXACTP (result
))
6164 return scm_exact_to_inexact (result
);
6166 if (implicit_x
== INEXACT
)
6168 if (SCM_INEXACTP (result
))
6171 return scm_exact_to_inexact (result
);
6177 /* We should never get here */
6178 scm_syserror ("mem2ureal");
6182 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6185 mem2complex (SCM mem
, unsigned int idx
,
6186 unsigned int radix
, enum t_exactness forced_x
)
6191 size_t len
= scm_i_string_length (mem
);
6196 c
= scm_i_string_ref (mem
, idx
);
6211 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6212 if (scm_is_false (ureal
))
6214 /* input must be either +i or -i */
6219 if (scm_i_string_ref (mem
, idx
) == 'i'
6220 || scm_i_string_ref (mem
, idx
) == 'I')
6226 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6233 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6234 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6239 c
= scm_i_string_ref (mem
, idx
);
6243 /* either +<ureal>i or -<ureal>i */
6250 return scm_make_rectangular (SCM_INUM0
, ureal
);
6253 /* polar input: <real>@<real>. */
6264 c
= scm_i_string_ref (mem
, idx
);
6282 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6283 if (scm_is_false (angle
))
6288 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6289 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6291 result
= scm_make_polar (ureal
, angle
);
6296 /* expecting input matching <real>[+-]<ureal>?i */
6303 int sign
= (c
== '+') ? 1 : -1;
6304 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6306 if (scm_is_false (imag
))
6307 imag
= SCM_I_MAKINUM (sign
);
6308 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6309 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6313 if (scm_i_string_ref (mem
, idx
) != 'i'
6314 && scm_i_string_ref (mem
, idx
) != 'I')
6321 return scm_make_rectangular (ureal
, imag
);
6330 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6332 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6335 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6337 unsigned int idx
= 0;
6338 unsigned int radix
= NO_RADIX
;
6339 enum t_exactness forced_x
= NO_EXACTNESS
;
6340 size_t len
= scm_i_string_length (mem
);
6342 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6343 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6345 switch (scm_i_string_ref (mem
, idx
+ 1))
6348 if (radix
!= NO_RADIX
)
6353 if (radix
!= NO_RADIX
)
6358 if (forced_x
!= NO_EXACTNESS
)
6363 if (forced_x
!= NO_EXACTNESS
)
6368 if (radix
!= NO_RADIX
)
6373 if (radix
!= NO_RADIX
)
6383 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6384 if (radix
== NO_RADIX
)
6385 radix
= default_radix
;
6387 return mem2complex (mem
, idx
, radix
, forced_x
);
6391 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6392 unsigned int default_radix
)
6394 SCM str
= scm_from_locale_stringn (mem
, len
);
6396 return scm_i_string_to_number (str
, default_radix
);
6400 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6401 (SCM string
, SCM radix
),
6402 "Return a number of the maximally precise representation\n"
6403 "expressed by the given @var{string}. @var{radix} must be an\n"
6404 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6405 "is a default radix that may be overridden by an explicit radix\n"
6406 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6407 "supplied, then the default radix is 10. If string is not a\n"
6408 "syntactically valid notation for a number, then\n"
6409 "@code{string->number} returns @code{#f}.")
6410 #define FUNC_NAME s_scm_string_to_number
6414 SCM_VALIDATE_STRING (1, string
);
6416 if (SCM_UNBNDP (radix
))
6419 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6421 answer
= scm_i_string_to_number (string
, base
);
6422 scm_remember_upto_here_1 (string
);
6428 /*** END strs->nums ***/
6431 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6433 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6435 #define FUNC_NAME s_scm_number_p
6437 return scm_from_bool (SCM_NUMBERP (x
));
6441 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6443 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6444 "otherwise. Note that the sets of real, rational and integer\n"
6445 "values form subsets of the set of complex numbers, i. e. the\n"
6446 "predicate will also be fulfilled if @var{x} is a real,\n"
6447 "rational or integer number.")
6448 #define FUNC_NAME s_scm_complex_p
6450 /* all numbers are complex. */
6451 return scm_number_p (x
);
6455 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6457 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6458 "otherwise. Note that the set of integer values forms a subset of\n"
6459 "the set of real numbers, i. e. the predicate will also be\n"
6460 "fulfilled if @var{x} is an integer number.")
6461 #define FUNC_NAME s_scm_real_p
6463 return scm_from_bool
6464 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6468 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6470 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6471 "otherwise. Note that the set of integer values forms a subset of\n"
6472 "the set of rational numbers, i. e. the predicate will also be\n"
6473 "fulfilled if @var{x} is an integer number.")
6474 #define FUNC_NAME s_scm_rational_p
6476 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6478 else if (SCM_REALP (x
))
6479 /* due to their limited precision, finite floating point numbers are
6480 rational as well. (finite means neither infinity nor a NaN) */
6481 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6487 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6489 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6491 #define FUNC_NAME s_scm_integer_p
6493 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6495 else if (SCM_REALP (x
))
6497 double val
= SCM_REAL_VALUE (x
);
6498 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6506 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6507 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6508 (SCM x
, SCM y
, SCM rest
),
6509 "Return @code{#t} if all parameters are numerically equal.")
6510 #define FUNC_NAME s_scm_i_num_eq_p
6512 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6514 while (!scm_is_null (rest
))
6516 if (scm_is_false (scm_num_eq_p (x
, y
)))
6520 rest
= scm_cdr (rest
);
6522 return scm_num_eq_p (x
, y
);
6526 scm_num_eq_p (SCM x
, SCM y
)
6529 if (SCM_I_INUMP (x
))
6531 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6532 if (SCM_I_INUMP (y
))
6534 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6535 return scm_from_bool (xx
== yy
);
6537 else if (SCM_BIGP (y
))
6539 else if (SCM_REALP (y
))
6541 /* On a 32-bit system an inum fits a double, we can cast the inum
6542 to a double and compare.
6544 But on a 64-bit system an inum is bigger than a double and
6545 casting it to a double (call that dxx) will round.
6546 Although dxx will not in general be equal to xx, dxx will
6547 always be an integer and within a factor of 2 of xx, so if
6548 dxx==yy, we know that yy is an integer and fits in
6549 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6550 compare with plain xx.
6552 An alternative (for any size system actually) would be to check
6553 yy is an integer (with floor) and is in range of an inum
6554 (compare against appropriate powers of 2) then test
6555 xx==(scm_t_signed_bits)yy. It's just a matter of which
6556 casts/comparisons might be fastest or easiest for the cpu. */
6558 double yy
= SCM_REAL_VALUE (y
);
6559 return scm_from_bool ((double) xx
== yy
6560 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6561 || xx
== (scm_t_signed_bits
) yy
));
6563 else if (SCM_COMPLEXP (y
))
6565 /* see comments with inum/real above */
6566 double ry
= SCM_COMPLEX_REAL (y
);
6567 return scm_from_bool ((double) xx
== ry
6568 && 0.0 == SCM_COMPLEX_IMAG (y
)
6569 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6570 || xx
== (scm_t_signed_bits
) ry
));
6572 else if (SCM_FRACTIONP (y
))
6575 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6577 else if (SCM_BIGP (x
))
6579 if (SCM_I_INUMP (y
))
6581 else if (SCM_BIGP (y
))
6583 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6584 scm_remember_upto_here_2 (x
, y
);
6585 return scm_from_bool (0 == cmp
);
6587 else if (SCM_REALP (y
))
6590 if (isnan (SCM_REAL_VALUE (y
)))
6592 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6593 scm_remember_upto_here_1 (x
);
6594 return scm_from_bool (0 == cmp
);
6596 else if (SCM_COMPLEXP (y
))
6599 if (0.0 != SCM_COMPLEX_IMAG (y
))
6601 if (isnan (SCM_COMPLEX_REAL (y
)))
6603 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6604 scm_remember_upto_here_1 (x
);
6605 return scm_from_bool (0 == cmp
);
6607 else if (SCM_FRACTIONP (y
))
6610 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6612 else if (SCM_REALP (x
))
6614 double xx
= SCM_REAL_VALUE (x
);
6615 if (SCM_I_INUMP (y
))
6617 /* see comments with inum/real above */
6618 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6619 return scm_from_bool (xx
== (double) yy
6620 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6621 || (scm_t_signed_bits
) xx
== yy
));
6623 else if (SCM_BIGP (y
))
6628 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6629 scm_remember_upto_here_1 (y
);
6630 return scm_from_bool (0 == cmp
);
6632 else if (SCM_REALP (y
))
6633 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6634 else if (SCM_COMPLEXP (y
))
6635 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6636 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6637 else if (SCM_FRACTIONP (y
))
6639 if (isnan (xx
) || isinf (xx
))
6641 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6645 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6647 else if (SCM_COMPLEXP (x
))
6649 if (SCM_I_INUMP (y
))
6651 /* see comments with inum/real above */
6652 double rx
= SCM_COMPLEX_REAL (x
);
6653 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6654 return scm_from_bool (rx
== (double) yy
6655 && 0.0 == SCM_COMPLEX_IMAG (x
)
6656 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6657 || (scm_t_signed_bits
) rx
== yy
));
6659 else if (SCM_BIGP (y
))
6662 if (0.0 != SCM_COMPLEX_IMAG (x
))
6664 if (isnan (SCM_COMPLEX_REAL (x
)))
6666 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6667 scm_remember_upto_here_1 (y
);
6668 return scm_from_bool (0 == cmp
);
6670 else if (SCM_REALP (y
))
6671 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6672 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6673 else if (SCM_COMPLEXP (y
))
6674 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6675 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6676 else if (SCM_FRACTIONP (y
))
6679 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6681 xx
= SCM_COMPLEX_REAL (x
);
6682 if (isnan (xx
) || isinf (xx
))
6684 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6688 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6690 else if (SCM_FRACTIONP (x
))
6692 if (SCM_I_INUMP (y
))
6694 else if (SCM_BIGP (y
))
6696 else if (SCM_REALP (y
))
6698 double yy
= SCM_REAL_VALUE (y
);
6699 if (isnan (yy
) || isinf (yy
))
6701 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6704 else if (SCM_COMPLEXP (y
))
6707 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6709 yy
= SCM_COMPLEX_REAL (y
);
6710 if (isnan (yy
) || isinf(yy
))
6712 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6715 else if (SCM_FRACTIONP (y
))
6716 return scm_i_fraction_equalp (x
, y
);
6718 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6721 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6725 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6726 done are good for inums, but for bignums an answer can almost always be
6727 had by just examining a few high bits of the operands, as done by GMP in
6728 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6729 of the float exponent to take into account. */
6731 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6732 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6733 (SCM x
, SCM y
, SCM rest
),
6734 "Return @code{#t} if the list of parameters is monotonically\n"
6736 #define FUNC_NAME s_scm_i_num_less_p
6738 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6740 while (!scm_is_null (rest
))
6742 if (scm_is_false (scm_less_p (x
, y
)))
6746 rest
= scm_cdr (rest
);
6748 return scm_less_p (x
, y
);
6752 scm_less_p (SCM x
, SCM y
)
6755 if (SCM_I_INUMP (x
))
6757 scm_t_inum xx
= SCM_I_INUM (x
);
6758 if (SCM_I_INUMP (y
))
6760 scm_t_inum yy
= SCM_I_INUM (y
);
6761 return scm_from_bool (xx
< yy
);
6763 else if (SCM_BIGP (y
))
6765 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6766 scm_remember_upto_here_1 (y
);
6767 return scm_from_bool (sgn
> 0);
6769 else if (SCM_REALP (y
))
6771 /* We can safely take the ceiling of y without changing the
6772 result of x<y, given that x is an integer. */
6773 double yy
= ceil (SCM_REAL_VALUE (y
));
6775 /* In the following comparisons, it's important that the right
6776 hand side always be a power of 2, so that it can be
6777 losslessly converted to a double even on 64-bit
6779 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6781 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6782 /* The condition above is carefully written to include the
6783 case where yy==NaN. */
6786 /* yy is a finite integer that fits in an inum. */
6787 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6789 else if (SCM_FRACTIONP (y
))
6791 /* "x < a/b" becomes "x*b < a" */
6793 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6794 y
= SCM_FRACTION_NUMERATOR (y
);
6798 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6800 else if (SCM_BIGP (x
))
6802 if (SCM_I_INUMP (y
))
6804 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6805 scm_remember_upto_here_1 (x
);
6806 return scm_from_bool (sgn
< 0);
6808 else if (SCM_BIGP (y
))
6810 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6811 scm_remember_upto_here_2 (x
, y
);
6812 return scm_from_bool (cmp
< 0);
6814 else if (SCM_REALP (y
))
6817 if (isnan (SCM_REAL_VALUE (y
)))
6819 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6820 scm_remember_upto_here_1 (x
);
6821 return scm_from_bool (cmp
< 0);
6823 else if (SCM_FRACTIONP (y
))
6826 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6828 else if (SCM_REALP (x
))
6830 if (SCM_I_INUMP (y
))
6832 /* We can safely take the floor of x without changing the
6833 result of x<y, given that y is an integer. */
6834 double xx
= floor (SCM_REAL_VALUE (x
));
6836 /* In the following comparisons, it's important that the right
6837 hand side always be a power of 2, so that it can be
6838 losslessly converted to a double even on 64-bit
6840 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6842 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6843 /* The condition above is carefully written to include the
6844 case where xx==NaN. */
6847 /* xx is a finite integer that fits in an inum. */
6848 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6850 else if (SCM_BIGP (y
))
6853 if (isnan (SCM_REAL_VALUE (x
)))
6855 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6856 scm_remember_upto_here_1 (y
);
6857 return scm_from_bool (cmp
> 0);
6859 else if (SCM_REALP (y
))
6860 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6861 else if (SCM_FRACTIONP (y
))
6863 double xx
= SCM_REAL_VALUE (x
);
6867 return scm_from_bool (xx
< 0.0);
6868 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6872 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6874 else if (SCM_FRACTIONP (x
))
6876 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6878 /* "a/b < y" becomes "a < y*b" */
6879 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6880 x
= SCM_FRACTION_NUMERATOR (x
);
6883 else if (SCM_REALP (y
))
6885 double yy
= SCM_REAL_VALUE (y
);
6889 return scm_from_bool (0.0 < yy
);
6890 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6893 else if (SCM_FRACTIONP (y
))
6895 /* "a/b < c/d" becomes "a*d < c*b" */
6896 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6897 SCM_FRACTION_DENOMINATOR (y
));
6898 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6899 SCM_FRACTION_DENOMINATOR (x
));
6905 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6908 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6912 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6913 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6914 (SCM x
, SCM y
, SCM rest
),
6915 "Return @code{#t} if the list of parameters is monotonically\n"
6917 #define FUNC_NAME s_scm_i_num_gr_p
6919 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6921 while (!scm_is_null (rest
))
6923 if (scm_is_false (scm_gr_p (x
, y
)))
6927 rest
= scm_cdr (rest
);
6929 return scm_gr_p (x
, y
);
6932 #define FUNC_NAME s_scm_i_num_gr_p
6934 scm_gr_p (SCM x
, SCM y
)
6936 if (!SCM_NUMBERP (x
))
6937 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6938 else if (!SCM_NUMBERP (y
))
6939 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6941 return scm_less_p (y
, x
);
6946 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6947 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6948 (SCM x
, SCM y
, SCM rest
),
6949 "Return @code{#t} if the list of parameters is monotonically\n"
6951 #define FUNC_NAME s_scm_i_num_leq_p
6953 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6955 while (!scm_is_null (rest
))
6957 if (scm_is_false (scm_leq_p (x
, y
)))
6961 rest
= scm_cdr (rest
);
6963 return scm_leq_p (x
, y
);
6966 #define FUNC_NAME s_scm_i_num_leq_p
6968 scm_leq_p (SCM x
, SCM y
)
6970 if (!SCM_NUMBERP (x
))
6971 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6972 else if (!SCM_NUMBERP (y
))
6973 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6974 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6977 return scm_not (scm_less_p (y
, x
));
6982 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6983 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6984 (SCM x
, SCM y
, SCM rest
),
6985 "Return @code{#t} if the list of parameters is monotonically\n"
6987 #define FUNC_NAME s_scm_i_num_geq_p
6989 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6991 while (!scm_is_null (rest
))
6993 if (scm_is_false (scm_geq_p (x
, y
)))
6997 rest
= scm_cdr (rest
);
6999 return scm_geq_p (x
, y
);
7002 #define FUNC_NAME s_scm_i_num_geq_p
7004 scm_geq_p (SCM x
, SCM y
)
7006 if (!SCM_NUMBERP (x
))
7007 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7008 else if (!SCM_NUMBERP (y
))
7009 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7010 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7013 return scm_not (scm_less_p (x
, y
));
7018 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7020 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7022 #define FUNC_NAME s_scm_zero_p
7024 if (SCM_I_INUMP (z
))
7025 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7026 else if (SCM_BIGP (z
))
7028 else if (SCM_REALP (z
))
7029 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7030 else if (SCM_COMPLEXP (z
))
7031 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7032 && SCM_COMPLEX_IMAG (z
) == 0.0);
7033 else if (SCM_FRACTIONP (z
))
7036 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7041 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7043 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7045 #define FUNC_NAME s_scm_positive_p
7047 if (SCM_I_INUMP (x
))
7048 return scm_from_bool (SCM_I_INUM (x
) > 0);
7049 else if (SCM_BIGP (x
))
7051 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7052 scm_remember_upto_here_1 (x
);
7053 return scm_from_bool (sgn
> 0);
7055 else if (SCM_REALP (x
))
7056 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7057 else if (SCM_FRACTIONP (x
))
7058 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7060 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7065 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7067 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7069 #define FUNC_NAME s_scm_negative_p
7071 if (SCM_I_INUMP (x
))
7072 return scm_from_bool (SCM_I_INUM (x
) < 0);
7073 else if (SCM_BIGP (x
))
7075 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7076 scm_remember_upto_here_1 (x
);
7077 return scm_from_bool (sgn
< 0);
7079 else if (SCM_REALP (x
))
7080 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7081 else if (SCM_FRACTIONP (x
))
7082 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7084 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7089 /* scm_min and scm_max return an inexact when either argument is inexact, as
7090 required by r5rs. On that basis, for exact/inexact combinations the
7091 exact is converted to inexact to compare and possibly return. This is
7092 unlike scm_less_p above which takes some trouble to preserve all bits in
7093 its test, such trouble is not required for min and max. */
7095 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7096 (SCM x
, SCM y
, SCM rest
),
7097 "Return the maximum of all parameter values.")
7098 #define FUNC_NAME s_scm_i_max
7100 while (!scm_is_null (rest
))
7101 { x
= scm_max (x
, y
);
7103 rest
= scm_cdr (rest
);
7105 return scm_max (x
, y
);
7109 #define s_max s_scm_i_max
7110 #define g_max g_scm_i_max
7113 scm_max (SCM x
, SCM y
)
7118 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7119 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7122 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7125 if (SCM_I_INUMP (x
))
7127 scm_t_inum xx
= SCM_I_INUM (x
);
7128 if (SCM_I_INUMP (y
))
7130 scm_t_inum yy
= SCM_I_INUM (y
);
7131 return (xx
< yy
) ? y
: x
;
7133 else if (SCM_BIGP (y
))
7135 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7136 scm_remember_upto_here_1 (y
);
7137 return (sgn
< 0) ? x
: y
;
7139 else if (SCM_REALP (y
))
7142 double yyd
= SCM_REAL_VALUE (y
);
7145 return scm_from_double (xxd
);
7146 /* If y is a NaN, then "==" is false and we return the NaN */
7147 else if (SCM_LIKELY (!(xxd
== yyd
)))
7149 /* Handle signed zeroes properly */
7155 else if (SCM_FRACTIONP (y
))
7158 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7161 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7163 else if (SCM_BIGP (x
))
7165 if (SCM_I_INUMP (y
))
7167 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7168 scm_remember_upto_here_1 (x
);
7169 return (sgn
< 0) ? y
: x
;
7171 else if (SCM_BIGP (y
))
7173 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7174 scm_remember_upto_here_2 (x
, y
);
7175 return (cmp
> 0) ? x
: y
;
7177 else if (SCM_REALP (y
))
7179 /* if y==NaN then xx>yy is false, so we return the NaN y */
7182 xx
= scm_i_big2dbl (x
);
7183 yy
= SCM_REAL_VALUE (y
);
7184 return (xx
> yy
? scm_from_double (xx
) : y
);
7186 else if (SCM_FRACTIONP (y
))
7191 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7193 else if (SCM_REALP (x
))
7195 if (SCM_I_INUMP (y
))
7197 scm_t_inum yy
= SCM_I_INUM (y
);
7198 double xxd
= SCM_REAL_VALUE (x
);
7202 return scm_from_double (yyd
);
7203 /* If x is a NaN, then "==" is false and we return the NaN */
7204 else if (SCM_LIKELY (!(xxd
== yyd
)))
7206 /* Handle signed zeroes properly */
7212 else if (SCM_BIGP (y
))
7217 else if (SCM_REALP (y
))
7219 double xx
= SCM_REAL_VALUE (x
);
7220 double yy
= SCM_REAL_VALUE (y
);
7222 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7225 else if (SCM_LIKELY (xx
< yy
))
7227 /* If neither (xx > yy) nor (xx < yy), then
7228 either they're equal or one is a NaN */
7229 else if (SCM_UNLIKELY (isnan (xx
)))
7230 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7231 else if (SCM_UNLIKELY (isnan (yy
)))
7232 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7233 /* xx == yy, but handle signed zeroes properly */
7234 else if (double_is_non_negative_zero (yy
))
7239 else if (SCM_FRACTIONP (y
))
7241 double yy
= scm_i_fraction2double (y
);
7242 double xx
= SCM_REAL_VALUE (x
);
7243 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7246 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7248 else if (SCM_FRACTIONP (x
))
7250 if (SCM_I_INUMP (y
))
7254 else if (SCM_BIGP (y
))
7258 else if (SCM_REALP (y
))
7260 double xx
= scm_i_fraction2double (x
);
7261 /* if y==NaN then ">" is false, so we return the NaN y */
7262 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7264 else if (SCM_FRACTIONP (y
))
7269 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7272 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7276 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7277 (SCM x
, SCM y
, SCM rest
),
7278 "Return the minimum of all parameter values.")
7279 #define FUNC_NAME s_scm_i_min
7281 while (!scm_is_null (rest
))
7282 { x
= scm_min (x
, y
);
7284 rest
= scm_cdr (rest
);
7286 return scm_min (x
, y
);
7290 #define s_min s_scm_i_min
7291 #define g_min g_scm_i_min
7294 scm_min (SCM x
, SCM y
)
7299 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7300 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7303 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7306 if (SCM_I_INUMP (x
))
7308 scm_t_inum xx
= SCM_I_INUM (x
);
7309 if (SCM_I_INUMP (y
))
7311 scm_t_inum yy
= SCM_I_INUM (y
);
7312 return (xx
< yy
) ? x
: y
;
7314 else if (SCM_BIGP (y
))
7316 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7317 scm_remember_upto_here_1 (y
);
7318 return (sgn
< 0) ? y
: x
;
7320 else if (SCM_REALP (y
))
7323 /* if y==NaN then "<" is false and we return NaN */
7324 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7326 else if (SCM_FRACTIONP (y
))
7329 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7332 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7334 else if (SCM_BIGP (x
))
7336 if (SCM_I_INUMP (y
))
7338 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7339 scm_remember_upto_here_1 (x
);
7340 return (sgn
< 0) ? x
: y
;
7342 else if (SCM_BIGP (y
))
7344 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7345 scm_remember_upto_here_2 (x
, y
);
7346 return (cmp
> 0) ? y
: x
;
7348 else if (SCM_REALP (y
))
7350 /* if y==NaN then xx<yy is false, so we return the NaN y */
7353 xx
= scm_i_big2dbl (x
);
7354 yy
= SCM_REAL_VALUE (y
);
7355 return (xx
< yy
? scm_from_double (xx
) : y
);
7357 else if (SCM_FRACTIONP (y
))
7362 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7364 else if (SCM_REALP (x
))
7366 if (SCM_I_INUMP (y
))
7368 double z
= SCM_I_INUM (y
);
7369 /* if x==NaN then "<" is false and we return NaN */
7370 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7372 else if (SCM_BIGP (y
))
7377 else if (SCM_REALP (y
))
7379 double xx
= SCM_REAL_VALUE (x
);
7380 double yy
= SCM_REAL_VALUE (y
);
7382 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7385 else if (SCM_LIKELY (xx
> yy
))
7387 /* If neither (xx < yy) nor (xx > yy), then
7388 either they're equal or one is a NaN */
7389 else if (SCM_UNLIKELY (isnan (xx
)))
7390 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7391 else if (SCM_UNLIKELY (isnan (yy
)))
7392 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7393 /* xx == yy, but handle signed zeroes properly */
7394 else if (double_is_non_negative_zero (xx
))
7399 else if (SCM_FRACTIONP (y
))
7401 double yy
= scm_i_fraction2double (y
);
7402 double xx
= SCM_REAL_VALUE (x
);
7403 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7406 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7408 else if (SCM_FRACTIONP (x
))
7410 if (SCM_I_INUMP (y
))
7414 else if (SCM_BIGP (y
))
7418 else if (SCM_REALP (y
))
7420 double xx
= scm_i_fraction2double (x
);
7421 /* if y==NaN then "<" is false, so we return the NaN y */
7422 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7424 else if (SCM_FRACTIONP (y
))
7429 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7432 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7436 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7437 (SCM x
, SCM y
, SCM rest
),
7438 "Return the sum of all parameter values. Return 0 if called without\n"
7440 #define FUNC_NAME s_scm_i_sum
7442 while (!scm_is_null (rest
))
7443 { x
= scm_sum (x
, y
);
7445 rest
= scm_cdr (rest
);
7447 return scm_sum (x
, y
);
7451 #define s_sum s_scm_i_sum
7452 #define g_sum g_scm_i_sum
7455 scm_sum (SCM x
, SCM y
)
7457 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7459 if (SCM_NUMBERP (x
)) return x
;
7460 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7461 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7464 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7466 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7468 scm_t_inum xx
= SCM_I_INUM (x
);
7469 scm_t_inum yy
= SCM_I_INUM (y
);
7470 scm_t_inum z
= xx
+ yy
;
7471 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7473 else if (SCM_BIGP (y
))
7478 else if (SCM_REALP (y
))
7480 scm_t_inum xx
= SCM_I_INUM (x
);
7481 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7483 else if (SCM_COMPLEXP (y
))
7485 scm_t_inum xx
= SCM_I_INUM (x
);
7486 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7487 SCM_COMPLEX_IMAG (y
));
7489 else if (SCM_FRACTIONP (y
))
7490 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7491 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7492 SCM_FRACTION_DENOMINATOR (y
));
7494 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7495 } else if (SCM_BIGP (x
))
7497 if (SCM_I_INUMP (y
))
7502 inum
= SCM_I_INUM (y
);
7505 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7508 SCM result
= scm_i_mkbig ();
7509 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7510 scm_remember_upto_here_1 (x
);
7511 /* we know the result will have to be a bignum */
7514 return scm_i_normbig (result
);
7518 SCM result
= scm_i_mkbig ();
7519 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7520 scm_remember_upto_here_1 (x
);
7521 /* we know the result will have to be a bignum */
7524 return scm_i_normbig (result
);
7527 else if (SCM_BIGP (y
))
7529 SCM result
= scm_i_mkbig ();
7530 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7531 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7532 mpz_add (SCM_I_BIG_MPZ (result
),
7535 scm_remember_upto_here_2 (x
, y
);
7536 /* we know the result will have to be a bignum */
7539 return scm_i_normbig (result
);
7541 else if (SCM_REALP (y
))
7543 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7544 scm_remember_upto_here_1 (x
);
7545 return scm_from_double (result
);
7547 else if (SCM_COMPLEXP (y
))
7549 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7550 + SCM_COMPLEX_REAL (y
));
7551 scm_remember_upto_here_1 (x
);
7552 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7554 else if (SCM_FRACTIONP (y
))
7555 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7556 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7557 SCM_FRACTION_DENOMINATOR (y
));
7559 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7561 else if (SCM_REALP (x
))
7563 if (SCM_I_INUMP (y
))
7564 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7565 else if (SCM_BIGP (y
))
7567 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7568 scm_remember_upto_here_1 (y
);
7569 return scm_from_double (result
);
7571 else if (SCM_REALP (y
))
7572 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7573 else if (SCM_COMPLEXP (y
))
7574 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7575 SCM_COMPLEX_IMAG (y
));
7576 else if (SCM_FRACTIONP (y
))
7577 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7579 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7581 else if (SCM_COMPLEXP (x
))
7583 if (SCM_I_INUMP (y
))
7584 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7585 SCM_COMPLEX_IMAG (x
));
7586 else if (SCM_BIGP (y
))
7588 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7589 + SCM_COMPLEX_REAL (x
));
7590 scm_remember_upto_here_1 (y
);
7591 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7593 else if (SCM_REALP (y
))
7594 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7595 SCM_COMPLEX_IMAG (x
));
7596 else if (SCM_COMPLEXP (y
))
7597 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7598 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7599 else if (SCM_FRACTIONP (y
))
7600 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7601 SCM_COMPLEX_IMAG (x
));
7603 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7605 else if (SCM_FRACTIONP (x
))
7607 if (SCM_I_INUMP (y
))
7608 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7609 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7610 SCM_FRACTION_DENOMINATOR (x
));
7611 else if (SCM_BIGP (y
))
7612 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7613 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7614 SCM_FRACTION_DENOMINATOR (x
));
7615 else if (SCM_REALP (y
))
7616 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7617 else if (SCM_COMPLEXP (y
))
7618 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7619 SCM_COMPLEX_IMAG (y
));
7620 else if (SCM_FRACTIONP (y
))
7621 /* a/b + c/d = (ad + bc) / bd */
7622 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7623 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7624 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7626 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7629 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7633 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7635 "Return @math{@var{x}+1}.")
7636 #define FUNC_NAME s_scm_oneplus
7638 return scm_sum (x
, SCM_INUM1
);
7643 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7644 (SCM x
, SCM y
, SCM rest
),
7645 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7646 "the sum of all but the first argument are subtracted from the first\n"
7648 #define FUNC_NAME s_scm_i_difference
7650 while (!scm_is_null (rest
))
7651 { x
= scm_difference (x
, y
);
7653 rest
= scm_cdr (rest
);
7655 return scm_difference (x
, y
);
7659 #define s_difference s_scm_i_difference
7660 #define g_difference g_scm_i_difference
7663 scm_difference (SCM x
, SCM y
)
7664 #define FUNC_NAME s_difference
7666 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7669 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7671 if (SCM_I_INUMP (x
))
7673 scm_t_inum xx
= -SCM_I_INUM (x
);
7674 if (SCM_FIXABLE (xx
))
7675 return SCM_I_MAKINUM (xx
);
7677 return scm_i_inum2big (xx
);
7679 else if (SCM_BIGP (x
))
7680 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7681 bignum, but negating that gives a fixnum. */
7682 return scm_i_normbig (scm_i_clonebig (x
, 0));
7683 else if (SCM_REALP (x
))
7684 return scm_from_double (-SCM_REAL_VALUE (x
));
7685 else if (SCM_COMPLEXP (x
))
7686 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7687 -SCM_COMPLEX_IMAG (x
));
7688 else if (SCM_FRACTIONP (x
))
7689 return scm_i_make_ratio_already_reduced
7690 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7691 SCM_FRACTION_DENOMINATOR (x
));
7693 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7696 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7698 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7700 scm_t_inum xx
= SCM_I_INUM (x
);
7701 scm_t_inum yy
= SCM_I_INUM (y
);
7702 scm_t_inum z
= xx
- yy
;
7703 if (SCM_FIXABLE (z
))
7704 return SCM_I_MAKINUM (z
);
7706 return scm_i_inum2big (z
);
7708 else if (SCM_BIGP (y
))
7710 /* inum-x - big-y */
7711 scm_t_inum xx
= SCM_I_INUM (x
);
7715 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7716 bignum, but negating that gives a fixnum. */
7717 return scm_i_normbig (scm_i_clonebig (y
, 0));
7721 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7722 SCM result
= scm_i_mkbig ();
7725 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7728 /* x - y == -(y + -x) */
7729 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7730 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7732 scm_remember_upto_here_1 (y
);
7734 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7735 /* we know the result will have to be a bignum */
7738 return scm_i_normbig (result
);
7741 else if (SCM_REALP (y
))
7743 scm_t_inum xx
= SCM_I_INUM (x
);
7746 * We need to handle x == exact 0
7747 * specially because R6RS states that:
7748 * (- 0.0) ==> -0.0 and
7749 * (- 0.0 0.0) ==> 0.0
7750 * and the scheme compiler changes
7751 * (- 0.0) into (- 0 0.0)
7752 * So we need to treat (- 0 0.0) like (- 0.0).
7753 * At the C level, (-x) is different than (0.0 - x).
7754 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7757 return scm_from_double (- SCM_REAL_VALUE (y
));
7759 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7761 else if (SCM_COMPLEXP (y
))
7763 scm_t_inum xx
= SCM_I_INUM (x
);
7765 /* We need to handle x == exact 0 specially.
7766 See the comment above (for SCM_REALP (y)) */
7768 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7769 - SCM_COMPLEX_IMAG (y
));
7771 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7772 - SCM_COMPLEX_IMAG (y
));
7774 else if (SCM_FRACTIONP (y
))
7775 /* a - b/c = (ac - b) / c */
7776 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7777 SCM_FRACTION_NUMERATOR (y
)),
7778 SCM_FRACTION_DENOMINATOR (y
));
7780 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7782 else if (SCM_BIGP (x
))
7784 if (SCM_I_INUMP (y
))
7786 /* big-x - inum-y */
7787 scm_t_inum yy
= SCM_I_INUM (y
);
7788 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7790 scm_remember_upto_here_1 (x
);
7792 return (SCM_FIXABLE (-yy
) ?
7793 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7796 SCM result
= scm_i_mkbig ();
7799 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7801 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7802 scm_remember_upto_here_1 (x
);
7804 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7805 /* we know the result will have to be a bignum */
7808 return scm_i_normbig (result
);
7811 else if (SCM_BIGP (y
))
7813 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7814 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7815 SCM result
= scm_i_mkbig ();
7816 mpz_sub (SCM_I_BIG_MPZ (result
),
7819 scm_remember_upto_here_2 (x
, y
);
7820 /* we know the result will have to be a bignum */
7821 if ((sgn_x
== 1) && (sgn_y
== -1))
7823 if ((sgn_x
== -1) && (sgn_y
== 1))
7825 return scm_i_normbig (result
);
7827 else if (SCM_REALP (y
))
7829 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7830 scm_remember_upto_here_1 (x
);
7831 return scm_from_double (result
);
7833 else if (SCM_COMPLEXP (y
))
7835 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7836 - SCM_COMPLEX_REAL (y
));
7837 scm_remember_upto_here_1 (x
);
7838 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7840 else if (SCM_FRACTIONP (y
))
7841 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7842 SCM_FRACTION_NUMERATOR (y
)),
7843 SCM_FRACTION_DENOMINATOR (y
));
7844 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7846 else if (SCM_REALP (x
))
7848 if (SCM_I_INUMP (y
))
7849 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7850 else if (SCM_BIGP (y
))
7852 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7853 scm_remember_upto_here_1 (x
);
7854 return scm_from_double (result
);
7856 else if (SCM_REALP (y
))
7857 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7858 else if (SCM_COMPLEXP (y
))
7859 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7860 -SCM_COMPLEX_IMAG (y
));
7861 else if (SCM_FRACTIONP (y
))
7862 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7864 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7866 else if (SCM_COMPLEXP (x
))
7868 if (SCM_I_INUMP (y
))
7869 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7870 SCM_COMPLEX_IMAG (x
));
7871 else if (SCM_BIGP (y
))
7873 double real_part
= (SCM_COMPLEX_REAL (x
)
7874 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7875 scm_remember_upto_here_1 (x
);
7876 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7878 else if (SCM_REALP (y
))
7879 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7880 SCM_COMPLEX_IMAG (x
));
7881 else if (SCM_COMPLEXP (y
))
7882 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7883 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7884 else if (SCM_FRACTIONP (y
))
7885 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7886 SCM_COMPLEX_IMAG (x
));
7888 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7890 else if (SCM_FRACTIONP (x
))
7892 if (SCM_I_INUMP (y
))
7893 /* a/b - c = (a - cb) / b */
7894 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7895 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7896 SCM_FRACTION_DENOMINATOR (x
));
7897 else if (SCM_BIGP (y
))
7898 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7899 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7900 SCM_FRACTION_DENOMINATOR (x
));
7901 else if (SCM_REALP (y
))
7902 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7903 else if (SCM_COMPLEXP (y
))
7904 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7905 -SCM_COMPLEX_IMAG (y
));
7906 else if (SCM_FRACTIONP (y
))
7907 /* a/b - c/d = (ad - bc) / bd */
7908 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7909 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7910 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7912 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7915 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7920 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7922 "Return @math{@var{x}-1}.")
7923 #define FUNC_NAME s_scm_oneminus
7925 return scm_difference (x
, SCM_INUM1
);
7930 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7931 (SCM x
, SCM y
, SCM rest
),
7932 "Return the product of all arguments. If called without arguments,\n"
7934 #define FUNC_NAME s_scm_i_product
7936 while (!scm_is_null (rest
))
7937 { x
= scm_product (x
, y
);
7939 rest
= scm_cdr (rest
);
7941 return scm_product (x
, y
);
7945 #define s_product s_scm_i_product
7946 #define g_product g_scm_i_product
7949 scm_product (SCM x
, SCM y
)
7951 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7954 return SCM_I_MAKINUM (1L);
7955 else if (SCM_NUMBERP (x
))
7958 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7961 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7966 xx
= SCM_I_INUM (x
);
7971 /* exact1 is the universal multiplicative identity */
7975 /* exact0 times a fixnum is exact0: optimize this case */
7976 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7978 /* if the other argument is inexact, the result is inexact,
7979 and we must do the multiplication in order to handle
7980 infinities and NaNs properly. */
7981 else if (SCM_REALP (y
))
7982 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7983 else if (SCM_COMPLEXP (y
))
7984 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7985 0.0 * SCM_COMPLEX_IMAG (y
));
7986 /* we've already handled inexact numbers,
7987 so y must be exact, and we return exact0 */
7988 else if (SCM_NUMP (y
))
7991 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7995 * This case is important for more than just optimization.
7996 * It handles the case of negating
7997 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7998 * which is a bignum that must be changed back into a fixnum.
7999 * Failure to do so will cause the following to return #f:
8000 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8002 return scm_difference(y
, SCM_UNDEFINED
);
8006 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8008 scm_t_inum yy
= SCM_I_INUM (y
);
8009 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8010 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8011 if (SCM_FIXABLE (kk
))
8012 return SCM_I_MAKINUM (kk
);
8014 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8015 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8016 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8017 return SCM_I_MAKINUM (xx
* yy
);
8021 SCM result
= scm_i_inum2big (xx
);
8022 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8023 return scm_i_normbig (result
);
8026 else if (SCM_BIGP (y
))
8028 SCM result
= scm_i_mkbig ();
8029 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8030 scm_remember_upto_here_1 (y
);
8033 else if (SCM_REALP (y
))
8034 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
8035 else if (SCM_COMPLEXP (y
))
8036 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8037 xx
* SCM_COMPLEX_IMAG (y
));
8038 else if (SCM_FRACTIONP (y
))
8039 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8040 SCM_FRACTION_DENOMINATOR (y
));
8042 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8044 else if (SCM_BIGP (x
))
8046 if (SCM_I_INUMP (y
))
8051 else if (SCM_BIGP (y
))
8053 SCM result
= scm_i_mkbig ();
8054 mpz_mul (SCM_I_BIG_MPZ (result
),
8057 scm_remember_upto_here_2 (x
, y
);
8060 else if (SCM_REALP (y
))
8062 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8063 scm_remember_upto_here_1 (x
);
8064 return scm_from_double (result
);
8066 else if (SCM_COMPLEXP (y
))
8068 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8069 scm_remember_upto_here_1 (x
);
8070 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8071 z
* SCM_COMPLEX_IMAG (y
));
8073 else if (SCM_FRACTIONP (y
))
8074 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8075 SCM_FRACTION_DENOMINATOR (y
));
8077 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8079 else if (SCM_REALP (x
))
8081 if (SCM_I_INUMP (y
))
8086 else if (SCM_BIGP (y
))
8088 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8089 scm_remember_upto_here_1 (y
);
8090 return scm_from_double (result
);
8092 else if (SCM_REALP (y
))
8093 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8094 else if (SCM_COMPLEXP (y
))
8095 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8096 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8097 else if (SCM_FRACTIONP (y
))
8098 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8100 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8102 else if (SCM_COMPLEXP (x
))
8104 if (SCM_I_INUMP (y
))
8109 else if (SCM_BIGP (y
))
8111 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8112 scm_remember_upto_here_1 (y
);
8113 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8114 z
* SCM_COMPLEX_IMAG (x
));
8116 else if (SCM_REALP (y
))
8117 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8118 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8119 else if (SCM_COMPLEXP (y
))
8121 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8122 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8123 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8124 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8126 else if (SCM_FRACTIONP (y
))
8128 double yy
= scm_i_fraction2double (y
);
8129 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8130 yy
* SCM_COMPLEX_IMAG (x
));
8133 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8135 else if (SCM_FRACTIONP (x
))
8137 if (SCM_I_INUMP (y
))
8138 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8139 SCM_FRACTION_DENOMINATOR (x
));
8140 else if (SCM_BIGP (y
))
8141 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8142 SCM_FRACTION_DENOMINATOR (x
));
8143 else if (SCM_REALP (y
))
8144 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8145 else if (SCM_COMPLEXP (y
))
8147 double xx
= scm_i_fraction2double (x
);
8148 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8149 xx
* SCM_COMPLEX_IMAG (y
));
8151 else if (SCM_FRACTIONP (y
))
8152 /* a/b * c/d = ac / bd */
8153 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8154 SCM_FRACTION_NUMERATOR (y
)),
8155 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8156 SCM_FRACTION_DENOMINATOR (y
)));
8158 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8161 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8164 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8165 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8166 #define ALLOW_DIVIDE_BY_ZERO
8167 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8170 /* The code below for complex division is adapted from the GNU
8171 libstdc++, which adapted it from f2c's libF77, and is subject to
8174 /****************************************************************
8175 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8177 Permission to use, copy, modify, and distribute this software
8178 and its documentation for any purpose and without fee is hereby
8179 granted, provided that the above copyright notice appear in all
8180 copies and that both that the copyright notice and this
8181 permission notice and warranty disclaimer appear in supporting
8182 documentation, and that the names of AT&T Bell Laboratories or
8183 Bellcore or any of their entities not be used in advertising or
8184 publicity pertaining to distribution of the software without
8185 specific, written prior permission.
8187 AT&T and Bellcore disclaim all warranties with regard to this
8188 software, including all implied warranties of merchantability
8189 and fitness. In no event shall AT&T or Bellcore be liable for
8190 any special, indirect or consequential damages or any damages
8191 whatsoever resulting from loss of use, data or profits, whether
8192 in an action of contract, negligence or other tortious action,
8193 arising out of or in connection with the use or performance of
8195 ****************************************************************/
8197 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8198 (SCM x
, SCM y
, SCM rest
),
8199 "Divide the first argument by the product of the remaining\n"
8200 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8202 #define FUNC_NAME s_scm_i_divide
8204 while (!scm_is_null (rest
))
8205 { x
= scm_divide (x
, y
);
8207 rest
= scm_cdr (rest
);
8209 return scm_divide (x
, y
);
8213 #define s_divide s_scm_i_divide
8214 #define g_divide g_scm_i_divide
8217 scm_divide (SCM x
, SCM y
)
8218 #define FUNC_NAME s_divide
8222 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8225 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8226 else if (SCM_I_INUMP (x
))
8228 scm_t_inum xx
= SCM_I_INUM (x
);
8229 if (xx
== 1 || xx
== -1)
8231 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8233 scm_num_overflow (s_divide
);
8236 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8238 else if (SCM_BIGP (x
))
8239 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8240 else if (SCM_REALP (x
))
8242 double xx
= SCM_REAL_VALUE (x
);
8243 #ifndef ALLOW_DIVIDE_BY_ZERO
8245 scm_num_overflow (s_divide
);
8248 return scm_from_double (1.0 / xx
);
8250 else if (SCM_COMPLEXP (x
))
8252 double r
= SCM_COMPLEX_REAL (x
);
8253 double i
= SCM_COMPLEX_IMAG (x
);
8254 if (fabs(r
) <= fabs(i
))
8257 double d
= i
* (1.0 + t
* t
);
8258 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8263 double d
= r
* (1.0 + t
* t
);
8264 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8267 else if (SCM_FRACTIONP (x
))
8268 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8269 SCM_FRACTION_NUMERATOR (x
));
8271 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8274 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8276 scm_t_inum xx
= SCM_I_INUM (x
);
8277 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8279 scm_t_inum yy
= SCM_I_INUM (y
);
8282 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8283 scm_num_overflow (s_divide
);
8285 return scm_from_double ((double) xx
/ (double) yy
);
8288 else if (xx
% yy
!= 0)
8289 return scm_i_make_ratio (x
, y
);
8292 scm_t_inum z
= xx
/ yy
;
8293 if (SCM_FIXABLE (z
))
8294 return SCM_I_MAKINUM (z
);
8296 return scm_i_inum2big (z
);
8299 else if (SCM_BIGP (y
))
8300 return scm_i_make_ratio (x
, y
);
8301 else if (SCM_REALP (y
))
8303 double yy
= SCM_REAL_VALUE (y
);
8304 #ifndef ALLOW_DIVIDE_BY_ZERO
8306 scm_num_overflow (s_divide
);
8309 /* FIXME: Precision may be lost here due to:
8310 (1) The cast from 'scm_t_inum' to 'double'
8311 (2) Double rounding */
8312 return scm_from_double ((double) xx
/ yy
);
8314 else if (SCM_COMPLEXP (y
))
8317 complex_div
: /* y _must_ be a complex number */
8319 double r
= SCM_COMPLEX_REAL (y
);
8320 double i
= SCM_COMPLEX_IMAG (y
);
8321 if (fabs(r
) <= fabs(i
))
8324 double d
= i
* (1.0 + t
* t
);
8325 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8330 double d
= r
* (1.0 + t
* t
);
8331 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8335 else if (SCM_FRACTIONP (y
))
8336 /* a / b/c = ac / b */
8337 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8338 SCM_FRACTION_NUMERATOR (y
));
8340 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8342 else if (SCM_BIGP (x
))
8344 if (SCM_I_INUMP (y
))
8346 scm_t_inum yy
= SCM_I_INUM (y
);
8349 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8350 scm_num_overflow (s_divide
);
8352 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8353 scm_remember_upto_here_1 (x
);
8354 return (sgn
== 0) ? scm_nan () : scm_inf ();
8361 /* FIXME: HMM, what are the relative performance issues here?
8362 We need to test. Is it faster on average to test
8363 divisible_p, then perform whichever operation, or is it
8364 faster to perform the integer div opportunistically and
8365 switch to real if there's a remainder? For now we take the
8366 middle ground: test, then if divisible, use the faster div
8369 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8370 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8374 SCM result
= scm_i_mkbig ();
8375 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8376 scm_remember_upto_here_1 (x
);
8378 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8379 return scm_i_normbig (result
);
8382 return scm_i_make_ratio (x
, y
);
8385 else if (SCM_BIGP (y
))
8387 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8391 SCM result
= scm_i_mkbig ();
8392 mpz_divexact (SCM_I_BIG_MPZ (result
),
8395 scm_remember_upto_here_2 (x
, y
);
8396 return scm_i_normbig (result
);
8399 return scm_i_make_ratio (x
, y
);
8401 else if (SCM_REALP (y
))
8403 double yy
= SCM_REAL_VALUE (y
);
8404 #ifndef ALLOW_DIVIDE_BY_ZERO
8406 scm_num_overflow (s_divide
);
8409 /* FIXME: Precision may be lost here due to:
8410 (1) scm_i_big2dbl (2) Double rounding */
8411 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8413 else if (SCM_COMPLEXP (y
))
8415 a
= scm_i_big2dbl (x
);
8418 else if (SCM_FRACTIONP (y
))
8419 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8420 SCM_FRACTION_NUMERATOR (y
));
8422 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8424 else if (SCM_REALP (x
))
8426 double rx
= SCM_REAL_VALUE (x
);
8427 if (SCM_I_INUMP (y
))
8429 scm_t_inum yy
= SCM_I_INUM (y
);
8430 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8432 scm_num_overflow (s_divide
);
8435 /* FIXME: Precision may be lost here due to:
8436 (1) The cast from 'scm_t_inum' to 'double'
8437 (2) Double rounding */
8438 return scm_from_double (rx
/ (double) yy
);
8440 else if (SCM_BIGP (y
))
8442 /* FIXME: Precision may be lost here due to:
8443 (1) The conversion from bignum to double
8444 (2) Double rounding */
8445 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8446 scm_remember_upto_here_1 (y
);
8447 return scm_from_double (rx
/ dby
);
8449 else if (SCM_REALP (y
))
8451 double yy
= SCM_REAL_VALUE (y
);
8452 #ifndef ALLOW_DIVIDE_BY_ZERO
8454 scm_num_overflow (s_divide
);
8457 return scm_from_double (rx
/ yy
);
8459 else if (SCM_COMPLEXP (y
))
8464 else if (SCM_FRACTIONP (y
))
8465 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8467 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8469 else if (SCM_COMPLEXP (x
))
8471 double rx
= SCM_COMPLEX_REAL (x
);
8472 double ix
= SCM_COMPLEX_IMAG (x
);
8473 if (SCM_I_INUMP (y
))
8475 scm_t_inum yy
= SCM_I_INUM (y
);
8476 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8478 scm_num_overflow (s_divide
);
8482 /* FIXME: Precision may be lost here due to:
8483 (1) The conversion from 'scm_t_inum' to double
8484 (2) Double rounding */
8486 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8489 else if (SCM_BIGP (y
))
8491 /* FIXME: Precision may be lost here due to:
8492 (1) The conversion from bignum to double
8493 (2) Double rounding */
8494 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8495 scm_remember_upto_here_1 (y
);
8496 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8498 else if (SCM_REALP (y
))
8500 double yy
= SCM_REAL_VALUE (y
);
8501 #ifndef ALLOW_DIVIDE_BY_ZERO
8503 scm_num_overflow (s_divide
);
8506 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8508 else if (SCM_COMPLEXP (y
))
8510 double ry
= SCM_COMPLEX_REAL (y
);
8511 double iy
= SCM_COMPLEX_IMAG (y
);
8512 if (fabs(ry
) <= fabs(iy
))
8515 double d
= iy
* (1.0 + t
* t
);
8516 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8521 double d
= ry
* (1.0 + t
* t
);
8522 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8525 else if (SCM_FRACTIONP (y
))
8527 /* FIXME: Precision may be lost here due to:
8528 (1) The conversion from fraction to double
8529 (2) Double rounding */
8530 double yy
= scm_i_fraction2double (y
);
8531 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8534 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8536 else if (SCM_FRACTIONP (x
))
8538 if (SCM_I_INUMP (y
))
8540 scm_t_inum yy
= SCM_I_INUM (y
);
8541 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8543 scm_num_overflow (s_divide
);
8546 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8547 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8549 else if (SCM_BIGP (y
))
8551 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8552 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8554 else if (SCM_REALP (y
))
8556 double yy
= SCM_REAL_VALUE (y
);
8557 #ifndef ALLOW_DIVIDE_BY_ZERO
8559 scm_num_overflow (s_divide
);
8562 /* FIXME: Precision may be lost here due to:
8563 (1) The conversion from fraction to double
8564 (2) Double rounding */
8565 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8567 else if (SCM_COMPLEXP (y
))
8569 /* FIXME: Precision may be lost here due to:
8570 (1) The conversion from fraction to double
8571 (2) Double rounding */
8572 a
= scm_i_fraction2double (x
);
8575 else if (SCM_FRACTIONP (y
))
8576 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8577 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8579 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8582 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8588 scm_c_truncate (double x
)
8593 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8594 half-way case (ie. when x is an integer plus 0.5) going upwards.
8595 Then half-way cases are identified and adjusted down if the
8596 round-upwards didn't give the desired even integer.
8598 "plus_half == result" identifies a half-way case. If plus_half, which is
8599 x + 0.5, is an integer then x must be an integer plus 0.5.
8601 An odd "result" value is identified with result/2 != floor(result/2).
8602 This is done with plus_half, since that value is ready for use sooner in
8603 a pipelined cpu, and we're already requiring plus_half == result.
8605 Note however that we need to be careful when x is big and already an
8606 integer. In that case "x+0.5" may round to an adjacent integer, causing
8607 us to return such a value, incorrectly. For instance if the hardware is
8608 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8609 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8610 returned. Or if the hardware is in round-upwards mode, then other bigger
8611 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8612 representable value, 2^128+2^76 (or whatever), again incorrect.
8614 These bad roundings of x+0.5 are avoided by testing at the start whether
8615 x is already an integer. If it is then clearly that's the desired result
8616 already. And if it's not then the exponent must be small enough to allow
8617 an 0.5 to be represented, and hence added without a bad rounding. */
8620 scm_c_round (double x
)
8622 double plus_half
, result
;
8627 plus_half
= x
+ 0.5;
8628 result
= floor (plus_half
);
8629 /* Adjust so that the rounding is towards even. */
8630 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8635 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8637 "Round the number @var{x} towards zero.")
8638 #define FUNC_NAME s_scm_truncate_number
8640 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8642 else if (SCM_REALP (x
))
8643 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8644 else if (SCM_FRACTIONP (x
))
8645 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8646 SCM_FRACTION_DENOMINATOR (x
));
8648 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8649 s_scm_truncate_number
);
8653 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8655 "Round the number @var{x} towards the nearest integer. "
8656 "When it is exactly halfway between two integers, "
8657 "round towards the even one.")
8658 #define FUNC_NAME s_scm_round_number
8660 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8662 else if (SCM_REALP (x
))
8663 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8664 else if (SCM_FRACTIONP (x
))
8665 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8666 SCM_FRACTION_DENOMINATOR (x
));
8668 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8669 s_scm_round_number
);
8673 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8675 "Round the number @var{x} towards minus infinity.")
8676 #define FUNC_NAME s_scm_floor
8678 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8680 else if (SCM_REALP (x
))
8681 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8682 else if (SCM_FRACTIONP (x
))
8683 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8684 SCM_FRACTION_DENOMINATOR (x
));
8686 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8690 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8692 "Round the number @var{x} towards infinity.")
8693 #define FUNC_NAME s_scm_ceiling
8695 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8697 else if (SCM_REALP (x
))
8698 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8699 else if (SCM_FRACTIONP (x
))
8700 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8701 SCM_FRACTION_DENOMINATOR (x
));
8703 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8707 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8709 "Return @var{x} raised to the power of @var{y}.")
8710 #define FUNC_NAME s_scm_expt
8712 if (scm_is_integer (y
))
8714 if (scm_is_true (scm_exact_p (y
)))
8715 return scm_integer_expt (x
, y
);
8718 /* Here we handle the case where the exponent is an inexact
8719 integer. We make the exponent exact in order to use
8720 scm_integer_expt, and thus avoid the spurious imaginary
8721 parts that may result from round-off errors in the general
8722 e^(y log x) method below (for example when squaring a large
8723 negative number). In this case, we must return an inexact
8724 result for correctness. We also make the base inexact so
8725 that scm_integer_expt will use fast inexact arithmetic
8726 internally. Note that making the base inexact is not
8727 sufficient to guarantee an inexact result, because
8728 scm_integer_expt will return an exact 1 when the exponent
8729 is 0, even if the base is inexact. */
8730 return scm_exact_to_inexact
8731 (scm_integer_expt (scm_exact_to_inexact (x
),
8732 scm_inexact_to_exact (y
)));
8735 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8737 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8739 else if (scm_is_complex (x
) && scm_is_complex (y
))
8740 return scm_exp (scm_product (scm_log (x
), y
));
8741 else if (scm_is_complex (x
))
8742 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8744 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8748 /* sin/cos/tan/asin/acos/atan
8749 sinh/cosh/tanh/asinh/acosh/atanh
8750 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8751 Written by Jerry D. Hedden, (C) FSF.
8752 See the file `COPYING' for terms applying to this program. */
8754 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8756 "Compute the sine of @var{z}.")
8757 #define FUNC_NAME s_scm_sin
8759 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8760 return z
; /* sin(exact0) = exact0 */
8761 else if (scm_is_real (z
))
8762 return scm_from_double (sin (scm_to_double (z
)));
8763 else if (SCM_COMPLEXP (z
))
8765 x
= SCM_COMPLEX_REAL (z
);
8766 y
= SCM_COMPLEX_IMAG (z
);
8767 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8768 cos (x
) * sinh (y
));
8771 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8775 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8777 "Compute the cosine of @var{z}.")
8778 #define FUNC_NAME s_scm_cos
8780 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8781 return SCM_INUM1
; /* cos(exact0) = exact1 */
8782 else if (scm_is_real (z
))
8783 return scm_from_double (cos (scm_to_double (z
)));
8784 else if (SCM_COMPLEXP (z
))
8786 x
= SCM_COMPLEX_REAL (z
);
8787 y
= SCM_COMPLEX_IMAG (z
);
8788 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8789 -sin (x
) * sinh (y
));
8792 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8796 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8798 "Compute the tangent of @var{z}.")
8799 #define FUNC_NAME s_scm_tan
8801 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8802 return z
; /* tan(exact0) = exact0 */
8803 else if (scm_is_real (z
))
8804 return scm_from_double (tan (scm_to_double (z
)));
8805 else if (SCM_COMPLEXP (z
))
8807 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8808 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8809 w
= cos (x
) + cosh (y
);
8810 #ifndef ALLOW_DIVIDE_BY_ZERO
8812 scm_num_overflow (s_scm_tan
);
8814 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8817 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8821 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8823 "Compute the hyperbolic sine of @var{z}.")
8824 #define FUNC_NAME s_scm_sinh
8826 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8827 return z
; /* sinh(exact0) = exact0 */
8828 else if (scm_is_real (z
))
8829 return scm_from_double (sinh (scm_to_double (z
)));
8830 else if (SCM_COMPLEXP (z
))
8832 x
= SCM_COMPLEX_REAL (z
);
8833 y
= SCM_COMPLEX_IMAG (z
);
8834 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8835 cosh (x
) * sin (y
));
8838 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8842 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8844 "Compute the hyperbolic cosine of @var{z}.")
8845 #define FUNC_NAME s_scm_cosh
8847 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8848 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8849 else if (scm_is_real (z
))
8850 return scm_from_double (cosh (scm_to_double (z
)));
8851 else if (SCM_COMPLEXP (z
))
8853 x
= SCM_COMPLEX_REAL (z
);
8854 y
= SCM_COMPLEX_IMAG (z
);
8855 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8856 sinh (x
) * sin (y
));
8859 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8863 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8865 "Compute the hyperbolic tangent of @var{z}.")
8866 #define FUNC_NAME s_scm_tanh
8868 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8869 return z
; /* tanh(exact0) = exact0 */
8870 else if (scm_is_real (z
))
8871 return scm_from_double (tanh (scm_to_double (z
)));
8872 else if (SCM_COMPLEXP (z
))
8874 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8875 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8876 w
= cosh (x
) + cos (y
);
8877 #ifndef ALLOW_DIVIDE_BY_ZERO
8879 scm_num_overflow (s_scm_tanh
);
8881 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8884 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8888 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8890 "Compute the arc sine of @var{z}.")
8891 #define FUNC_NAME s_scm_asin
8893 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8894 return z
; /* asin(exact0) = exact0 */
8895 else if (scm_is_real (z
))
8897 double w
= scm_to_double (z
);
8898 if (w
>= -1.0 && w
<= 1.0)
8899 return scm_from_double (asin (w
));
8901 return scm_product (scm_c_make_rectangular (0, -1),
8902 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8904 else if (SCM_COMPLEXP (z
))
8906 x
= SCM_COMPLEX_REAL (z
);
8907 y
= SCM_COMPLEX_IMAG (z
);
8908 return scm_product (scm_c_make_rectangular (0, -1),
8909 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8912 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8916 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8918 "Compute the arc cosine of @var{z}.")
8919 #define FUNC_NAME s_scm_acos
8921 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8922 return SCM_INUM0
; /* acos(exact1) = exact0 */
8923 else if (scm_is_real (z
))
8925 double w
= scm_to_double (z
);
8926 if (w
>= -1.0 && w
<= 1.0)
8927 return scm_from_double (acos (w
));
8929 return scm_sum (scm_from_double (acos (0.0)),
8930 scm_product (scm_c_make_rectangular (0, 1),
8931 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8933 else if (SCM_COMPLEXP (z
))
8935 x
= SCM_COMPLEX_REAL (z
);
8936 y
= SCM_COMPLEX_IMAG (z
);
8937 return scm_sum (scm_from_double (acos (0.0)),
8938 scm_product (scm_c_make_rectangular (0, 1),
8939 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8942 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8946 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8948 "With one argument, compute the arc tangent of @var{z}.\n"
8949 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8950 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8951 #define FUNC_NAME s_scm_atan
8955 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8956 return z
; /* atan(exact0) = exact0 */
8957 else if (scm_is_real (z
))
8958 return scm_from_double (atan (scm_to_double (z
)));
8959 else if (SCM_COMPLEXP (z
))
8962 v
= SCM_COMPLEX_REAL (z
);
8963 w
= SCM_COMPLEX_IMAG (z
);
8964 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8965 scm_c_make_rectangular (v
, w
+ 1.0))),
8966 scm_c_make_rectangular (0, 2));
8969 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8971 else if (scm_is_real (z
))
8973 if (scm_is_real (y
))
8974 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8976 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8979 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8983 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8985 "Compute the inverse hyperbolic sine of @var{z}.")
8986 #define FUNC_NAME s_scm_sys_asinh
8988 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8989 return z
; /* asinh(exact0) = exact0 */
8990 else if (scm_is_real (z
))
8991 return scm_from_double (asinh (scm_to_double (z
)));
8992 else if (scm_is_number (z
))
8993 return scm_log (scm_sum (z
,
8994 scm_sqrt (scm_sum (scm_product (z
, z
),
8997 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9001 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9003 "Compute the inverse hyperbolic cosine of @var{z}.")
9004 #define FUNC_NAME s_scm_sys_acosh
9006 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9007 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9008 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9009 return scm_from_double (acosh (scm_to_double (z
)));
9010 else if (scm_is_number (z
))
9011 return scm_log (scm_sum (z
,
9012 scm_sqrt (scm_difference (scm_product (z
, z
),
9015 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9019 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9021 "Compute the inverse hyperbolic tangent of @var{z}.")
9022 #define FUNC_NAME s_scm_sys_atanh
9024 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9025 return z
; /* atanh(exact0) = exact0 */
9026 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9027 return scm_from_double (atanh (scm_to_double (z
)));
9028 else if (scm_is_number (z
))
9029 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9030 scm_difference (SCM_INUM1
, z
))),
9033 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9038 scm_c_make_rectangular (double re
, double im
)
9042 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9044 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9045 SCM_COMPLEX_REAL (z
) = re
;
9046 SCM_COMPLEX_IMAG (z
) = im
;
9050 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9051 (SCM real_part
, SCM imaginary_part
),
9052 "Return a complex number constructed of the given @var{real_part} "
9053 "and @var{imaginary_part} parts.")
9054 #define FUNC_NAME s_scm_make_rectangular
9056 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9057 SCM_ARG1
, FUNC_NAME
, "real");
9058 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9059 SCM_ARG2
, FUNC_NAME
, "real");
9061 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9062 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9065 return scm_c_make_rectangular (scm_to_double (real_part
),
9066 scm_to_double (imaginary_part
));
9071 scm_c_make_polar (double mag
, double ang
)
9075 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9076 use it on Glibc-based systems that have it (it's a GNU extension). See
9077 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9079 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9080 sincos (ang
, &s
, &c
);
9086 /* If s and c are NaNs, this indicates that the angle is a NaN,
9087 infinite, or perhaps simply too large to determine its value
9088 mod 2*pi. However, we know something that the floating-point
9089 implementation doesn't know: We know that s and c are finite.
9090 Therefore, if the magnitude is zero, return a complex zero.
9092 The reason we check for the NaNs instead of using this case
9093 whenever mag == 0.0 is because when the angle is known, we'd
9094 like to return the correct kind of non-real complex zero:
9095 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9096 on which quadrant the angle is in.
9098 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9099 return scm_c_make_rectangular (0.0, 0.0);
9101 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9104 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9106 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9107 #define FUNC_NAME s_scm_make_polar
9109 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9110 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9112 /* If mag is exact0, return exact0 */
9113 if (scm_is_eq (mag
, SCM_INUM0
))
9115 /* Return a real if ang is exact0 */
9116 else if (scm_is_eq (ang
, SCM_INUM0
))
9119 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9124 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9126 "Return the real part of the number @var{z}.")
9127 #define FUNC_NAME s_scm_real_part
9129 if (SCM_COMPLEXP (z
))
9130 return scm_from_double (SCM_COMPLEX_REAL (z
));
9131 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9134 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9139 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9141 "Return the imaginary part of the number @var{z}.")
9142 #define FUNC_NAME s_scm_imag_part
9144 if (SCM_COMPLEXP (z
))
9145 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9146 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9149 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9153 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9155 "Return the numerator of the number @var{z}.")
9156 #define FUNC_NAME s_scm_numerator
9158 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9160 else if (SCM_FRACTIONP (z
))
9161 return SCM_FRACTION_NUMERATOR (z
);
9162 else if (SCM_REALP (z
))
9163 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9165 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9170 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9172 "Return the denominator of the number @var{z}.")
9173 #define FUNC_NAME s_scm_denominator
9175 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9177 else if (SCM_FRACTIONP (z
))
9178 return SCM_FRACTION_DENOMINATOR (z
);
9179 else if (SCM_REALP (z
))
9180 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9182 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9187 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9189 "Return the magnitude of the number @var{z}. This is the same as\n"
9190 "@code{abs} for real arguments, but also allows complex numbers.")
9191 #define FUNC_NAME s_scm_magnitude
9193 if (SCM_I_INUMP (z
))
9195 scm_t_inum zz
= SCM_I_INUM (z
);
9198 else if (SCM_POSFIXABLE (-zz
))
9199 return SCM_I_MAKINUM (-zz
);
9201 return scm_i_inum2big (-zz
);
9203 else if (SCM_BIGP (z
))
9205 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9206 scm_remember_upto_here_1 (z
);
9208 return scm_i_clonebig (z
, 0);
9212 else if (SCM_REALP (z
))
9213 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9214 else if (SCM_COMPLEXP (z
))
9215 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9216 else if (SCM_FRACTIONP (z
))
9218 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9220 return scm_i_make_ratio_already_reduced
9221 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9222 SCM_FRACTION_DENOMINATOR (z
));
9225 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9230 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9232 "Return the angle of the complex number @var{z}.")
9233 #define FUNC_NAME s_scm_angle
9235 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9236 flo0 to save allocating a new flonum with scm_from_double each time.
9237 But if atan2 follows the floating point rounding mode, then the value
9238 is not a constant. Maybe it'd be close enough though. */
9239 if (SCM_I_INUMP (z
))
9241 if (SCM_I_INUM (z
) >= 0)
9244 return scm_from_double (atan2 (0.0, -1.0));
9246 else if (SCM_BIGP (z
))
9248 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9249 scm_remember_upto_here_1 (z
);
9251 return scm_from_double (atan2 (0.0, -1.0));
9255 else if (SCM_REALP (z
))
9257 double x
= SCM_REAL_VALUE (z
);
9258 if (x
> 0.0 || double_is_non_negative_zero (x
))
9261 return scm_from_double (atan2 (0.0, -1.0));
9263 else if (SCM_COMPLEXP (z
))
9264 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9265 else if (SCM_FRACTIONP (z
))
9267 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9269 else return scm_from_double (atan2 (0.0, -1.0));
9272 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9277 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9279 "Convert the number @var{z} to its inexact representation.\n")
9280 #define FUNC_NAME s_scm_exact_to_inexact
9282 if (SCM_I_INUMP (z
))
9283 return scm_from_double ((double) SCM_I_INUM (z
));
9284 else if (SCM_BIGP (z
))
9285 return scm_from_double (scm_i_big2dbl (z
));
9286 else if (SCM_FRACTIONP (z
))
9287 return scm_from_double (scm_i_fraction2double (z
));
9288 else if (SCM_INEXACTP (z
))
9291 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9296 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9298 "Return an exact number that is numerically closest to @var{z}.")
9299 #define FUNC_NAME s_scm_inexact_to_exact
9301 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9308 val
= SCM_REAL_VALUE (z
);
9309 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9310 val
= SCM_COMPLEX_REAL (z
);
9312 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9314 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9315 SCM_OUT_OF_RANGE (1, z
);
9316 else if (val
== 0.0)
9323 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9325 expon
-= DBL_MANT_DIG
;
9328 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9332 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9333 SCM_I_BIG_MPZ (numerator
),
9337 numerator
= scm_i_normbig (numerator
);
9339 return scm_i_make_ratio_already_reduced
9340 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9342 return left_shift_exact_integer (numerator
, expon
);
9350 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9352 "Returns the @emph{simplest} rational number differing\n"
9353 "from @var{x} by no more than @var{eps}.\n"
9355 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9356 "exact result when both its arguments are exact. Thus, you might need\n"
9357 "to use @code{inexact->exact} on the arguments.\n"
9360 "(rationalize (inexact->exact 1.2) 1/100)\n"
9363 #define FUNC_NAME s_scm_rationalize
9365 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9366 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9367 eps
= scm_abs (eps
);
9368 if (scm_is_false (scm_positive_p (eps
)))
9370 /* eps is either zero or a NaN */
9371 if (scm_is_true (scm_nan_p (eps
)))
9373 else if (SCM_INEXACTP (eps
))
9374 return scm_exact_to_inexact (x
);
9378 else if (scm_is_false (scm_finite_p (eps
)))
9380 if (scm_is_true (scm_finite_p (x
)))
9385 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9387 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9388 scm_ceiling (scm_difference (x
, eps
)))))
9390 /* There's an integer within range; we want the one closest to zero */
9391 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9393 /* zero is within range */
9394 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9399 else if (scm_is_true (scm_positive_p (x
)))
9400 return scm_ceiling (scm_difference (x
, eps
));
9402 return scm_floor (scm_sum (x
, eps
));
9406 /* Use continued fractions to find closest ratio. All
9407 arithmetic is done with exact numbers.
9410 SCM ex
= scm_inexact_to_exact (x
);
9411 SCM int_part
= scm_floor (ex
);
9413 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9414 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9418 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9419 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9421 /* We stop after a million iterations just to be absolutely sure
9422 that we don't go into an infinite loop. The process normally
9423 converges after less than a dozen iterations.
9426 while (++i
< 1000000)
9428 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9429 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9430 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9432 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9433 eps
))) /* abs(x-a/b) <= eps */
9435 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9436 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9437 return scm_exact_to_inexact (res
);
9441 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9443 tt
= scm_floor (rx
); /* tt = floor (rx) */
9449 scm_num_overflow (s_scm_rationalize
);
9454 /* conversion functions */
9457 scm_is_integer (SCM val
)
9459 return scm_is_true (scm_integer_p (val
));
9463 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9465 if (SCM_I_INUMP (val
))
9467 scm_t_signed_bits n
= SCM_I_INUM (val
);
9468 return n
>= min
&& n
<= max
;
9470 else if (SCM_BIGP (val
))
9472 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9474 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9476 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9478 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9479 return n
>= min
&& n
<= max
;
9489 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9490 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9493 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9494 SCM_I_BIG_MPZ (val
));
9496 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9508 return n
>= min
&& n
<= max
;
9516 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9518 if (SCM_I_INUMP (val
))
9520 scm_t_signed_bits n
= SCM_I_INUM (val
);
9521 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9523 else if (SCM_BIGP (val
))
9525 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9527 else if (max
<= ULONG_MAX
)
9529 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9531 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9532 return n
>= min
&& n
<= max
;
9542 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9545 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9546 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9549 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9550 SCM_I_BIG_MPZ (val
));
9552 return n
>= min
&& n
<= max
;
9560 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9562 scm_error (scm_out_of_range_key
,
9564 "Value out of range ~S to ~S: ~S",
9565 scm_list_3 (min
, max
, bad_val
),
9566 scm_list_1 (bad_val
));
9569 #define TYPE scm_t_intmax
9570 #define TYPE_MIN min
9571 #define TYPE_MAX max
9572 #define SIZEOF_TYPE 0
9573 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9574 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9575 #include "libguile/conv-integer.i.c"
9577 #define TYPE scm_t_uintmax
9578 #define TYPE_MIN min
9579 #define TYPE_MAX max
9580 #define SIZEOF_TYPE 0
9581 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9582 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9583 #include "libguile/conv-uinteger.i.c"
9585 #define TYPE scm_t_int8
9586 #define TYPE_MIN SCM_T_INT8_MIN
9587 #define TYPE_MAX SCM_T_INT8_MAX
9588 #define SIZEOF_TYPE 1
9589 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9590 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9591 #include "libguile/conv-integer.i.c"
9593 #define TYPE scm_t_uint8
9595 #define TYPE_MAX SCM_T_UINT8_MAX
9596 #define SIZEOF_TYPE 1
9597 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9598 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9599 #include "libguile/conv-uinteger.i.c"
9601 #define TYPE scm_t_int16
9602 #define TYPE_MIN SCM_T_INT16_MIN
9603 #define TYPE_MAX SCM_T_INT16_MAX
9604 #define SIZEOF_TYPE 2
9605 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9606 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9607 #include "libguile/conv-integer.i.c"
9609 #define TYPE scm_t_uint16
9611 #define TYPE_MAX SCM_T_UINT16_MAX
9612 #define SIZEOF_TYPE 2
9613 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9614 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9615 #include "libguile/conv-uinteger.i.c"
9617 #define TYPE scm_t_int32
9618 #define TYPE_MIN SCM_T_INT32_MIN
9619 #define TYPE_MAX SCM_T_INT32_MAX
9620 #define SIZEOF_TYPE 4
9621 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9622 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9623 #include "libguile/conv-integer.i.c"
9625 #define TYPE scm_t_uint32
9627 #define TYPE_MAX SCM_T_UINT32_MAX
9628 #define SIZEOF_TYPE 4
9629 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9630 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9631 #include "libguile/conv-uinteger.i.c"
9633 #define TYPE scm_t_wchar
9634 #define TYPE_MIN (scm_t_int32)-1
9635 #define TYPE_MAX (scm_t_int32)0x10ffff
9636 #define SIZEOF_TYPE 4
9637 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9638 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9639 #include "libguile/conv-integer.i.c"
9641 #define TYPE scm_t_int64
9642 #define TYPE_MIN SCM_T_INT64_MIN
9643 #define TYPE_MAX SCM_T_INT64_MAX
9644 #define SIZEOF_TYPE 8
9645 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9646 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9647 #include "libguile/conv-integer.i.c"
9649 #define TYPE scm_t_uint64
9651 #define TYPE_MAX SCM_T_UINT64_MAX
9652 #define SIZEOF_TYPE 8
9653 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9654 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9655 #include "libguile/conv-uinteger.i.c"
9658 scm_to_mpz (SCM val
, mpz_t rop
)
9660 if (SCM_I_INUMP (val
))
9661 mpz_set_si (rop
, SCM_I_INUM (val
));
9662 else if (SCM_BIGP (val
))
9663 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9665 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9669 scm_from_mpz (mpz_t val
)
9671 return scm_i_mpz2num (val
);
9675 scm_is_real (SCM val
)
9677 return scm_is_true (scm_real_p (val
));
9681 scm_is_rational (SCM val
)
9683 return scm_is_true (scm_rational_p (val
));
9687 scm_to_double (SCM val
)
9689 if (SCM_I_INUMP (val
))
9690 return SCM_I_INUM (val
);
9691 else if (SCM_BIGP (val
))
9692 return scm_i_big2dbl (val
);
9693 else if (SCM_FRACTIONP (val
))
9694 return scm_i_fraction2double (val
);
9695 else if (SCM_REALP (val
))
9696 return SCM_REAL_VALUE (val
);
9698 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9702 scm_from_double (double val
)
9706 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9708 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9709 SCM_REAL_VALUE (z
) = val
;
9714 #if SCM_ENABLE_DEPRECATED == 1
9717 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9719 scm_c_issue_deprecation_warning
9720 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9724 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9728 scm_out_of_range (NULL
, num
);
9731 return scm_to_double (num
);
9735 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9737 scm_c_issue_deprecation_warning
9738 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9742 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9746 scm_out_of_range (NULL
, num
);
9749 return scm_to_double (num
);
9755 scm_is_complex (SCM val
)
9757 return scm_is_true (scm_complex_p (val
));
9761 scm_c_real_part (SCM z
)
9763 if (SCM_COMPLEXP (z
))
9764 return SCM_COMPLEX_REAL (z
);
9767 /* Use the scm_real_part to get proper error checking and
9770 return scm_to_double (scm_real_part (z
));
9775 scm_c_imag_part (SCM z
)
9777 if (SCM_COMPLEXP (z
))
9778 return SCM_COMPLEX_IMAG (z
);
9781 /* Use the scm_imag_part to get proper error checking and
9782 dispatching. The result will almost always be 0.0, but not
9785 return scm_to_double (scm_imag_part (z
));
9790 scm_c_magnitude (SCM z
)
9792 return scm_to_double (scm_magnitude (z
));
9798 return scm_to_double (scm_angle (z
));
9802 scm_is_number (SCM z
)
9804 return scm_is_true (scm_number_p (z
));
9808 /* Returns log(x * 2^shift) */
9810 log_of_shifted_double (double x
, long shift
)
9812 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9814 if (x
> 0.0 || double_is_non_negative_zero (x
))
9815 return scm_from_double (ans
);
9817 return scm_c_make_rectangular (ans
, M_PI
);
9820 /* Returns log(n), for exact integer n */
9822 log_of_exact_integer (SCM n
)
9824 if (SCM_I_INUMP (n
))
9825 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9826 else if (SCM_BIGP (n
))
9829 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9830 return log_of_shifted_double (signif
, expon
);
9833 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9836 /* Returns log(n/d), for exact non-zero integers n and d */
9838 log_of_fraction (SCM n
, SCM d
)
9840 long n_size
= scm_to_long (scm_integer_length (n
));
9841 long d_size
= scm_to_long (scm_integer_length (d
));
9843 if (abs (n_size
- d_size
) > 1)
9844 return (scm_difference (log_of_exact_integer (n
),
9845 log_of_exact_integer (d
)));
9846 else if (scm_is_false (scm_negative_p (n
)))
9847 return scm_from_double
9848 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9850 return scm_c_make_rectangular
9851 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9857 /* In the following functions we dispatch to the real-arg funcs like log()
9858 when we know the arg is real, instead of just handing everything to
9859 clog() for instance. This is in case clog() doesn't optimize for a
9860 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9861 well use it to go straight to the applicable C func. */
9863 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9865 "Return the natural logarithm of @var{z}.")
9866 #define FUNC_NAME s_scm_log
9868 if (SCM_COMPLEXP (z
))
9870 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9871 && defined (SCM_COMPLEX_VALUE)
9872 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9874 double re
= SCM_COMPLEX_REAL (z
);
9875 double im
= SCM_COMPLEX_IMAG (z
);
9876 return scm_c_make_rectangular (log (hypot (re
, im
)),
9880 else if (SCM_REALP (z
))
9881 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9882 else if (SCM_I_INUMP (z
))
9884 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9885 if (scm_is_eq (z
, SCM_INUM0
))
9886 scm_num_overflow (s_scm_log
);
9888 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9890 else if (SCM_BIGP (z
))
9891 return log_of_exact_integer (z
);
9892 else if (SCM_FRACTIONP (z
))
9893 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9894 SCM_FRACTION_DENOMINATOR (z
));
9896 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9901 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9903 "Return the base 10 logarithm of @var{z}.")
9904 #define FUNC_NAME s_scm_log10
9906 if (SCM_COMPLEXP (z
))
9908 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9909 clog() and a multiply by M_LOG10E, rather than the fallback
9910 log10+hypot+atan2.) */
9911 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9912 && defined SCM_COMPLEX_VALUE
9913 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9915 double re
= SCM_COMPLEX_REAL (z
);
9916 double im
= SCM_COMPLEX_IMAG (z
);
9917 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9918 M_LOG10E
* atan2 (im
, re
));
9921 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9923 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9924 if (scm_is_eq (z
, SCM_INUM0
))
9925 scm_num_overflow (s_scm_log10
);
9928 double re
= scm_to_double (z
);
9929 double l
= log10 (fabs (re
));
9930 if (re
> 0.0 || double_is_non_negative_zero (re
))
9931 return scm_from_double (l
);
9933 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9936 else if (SCM_BIGP (z
))
9937 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9938 else if (SCM_FRACTIONP (z
))
9939 return scm_product (flo_log10e
,
9940 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9941 SCM_FRACTION_DENOMINATOR (z
)));
9943 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9948 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9950 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9951 "base of natural logarithms (2.71828@dots{}).")
9952 #define FUNC_NAME s_scm_exp
9954 if (SCM_COMPLEXP (z
))
9956 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9957 && defined (SCM_COMPLEX_VALUE)
9958 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9960 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9961 SCM_COMPLEX_IMAG (z
));
9964 else if (SCM_NUMBERP (z
))
9966 /* When z is a negative bignum the conversion to double overflows,
9967 giving -infinity, but that's ok, the exp is still 0.0. */
9968 return scm_from_double (exp (scm_to_double (z
)));
9971 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9976 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9978 "Return two exact non-negative integers @var{s} and @var{r}\n"
9979 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9980 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9981 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9984 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9986 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9990 scm_exact_integer_sqrt (k
, &s
, &r
);
9991 return scm_values (scm_list_2 (s
, r
));
9996 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9998 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10002 if (SCM_I_INUM (k
) < 0)
10003 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10004 "exact non-negative integer");
10005 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10006 mpz_inits (ss
, rr
, NULL
);
10007 mpz_sqrtrem (ss
, rr
, kk
);
10008 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10009 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10010 mpz_clears (kk
, ss
, rr
, NULL
);
10012 else if (SCM_LIKELY (SCM_BIGP (k
)))
10016 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10017 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10018 "exact non-negative integer");
10019 s
= scm_i_mkbig ();
10020 r
= scm_i_mkbig ();
10021 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10022 scm_remember_upto_here_1 (k
);
10023 *sp
= scm_i_normbig (s
);
10024 *rp
= scm_i_normbig (r
);
10027 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10028 "exact non-negative integer");
10031 /* Return true iff K is a perfect square.
10032 K must be an exact integer. */
10034 exact_integer_is_perfect_square (SCM k
)
10038 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10042 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10043 result
= mpz_perfect_square_p (kk
);
10048 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10049 scm_remember_upto_here_1 (k
);
10054 /* Return the floor of the square root of K.
10055 K must be an exact integer. */
10057 exact_integer_floor_square_root (SCM k
)
10059 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10064 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10066 ss
= mpz_get_ui (kk
);
10068 return SCM_I_MAKINUM (ss
);
10074 s
= scm_i_mkbig ();
10075 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10076 scm_remember_upto_here_1 (k
);
10077 return scm_i_normbig (s
);
10082 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10084 "Return the square root of @var{z}. Of the two possible roots\n"
10085 "(positive and negative), the one with positive real part\n"
10086 "is returned, or if that's zero then a positive imaginary part.\n"
10090 "(sqrt 9.0) @result{} 3.0\n"
10091 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10092 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10093 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10095 #define FUNC_NAME s_scm_sqrt
10097 if (SCM_COMPLEXP (z
))
10099 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10100 && defined SCM_COMPLEX_VALUE
10101 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10103 double re
= SCM_COMPLEX_REAL (z
);
10104 double im
= SCM_COMPLEX_IMAG (z
);
10105 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10106 0.5 * atan2 (im
, re
));
10109 else if (SCM_NUMBERP (z
))
10111 if (SCM_I_INUMP (z
))
10113 scm_t_inum x
= SCM_I_INUM (z
);
10115 if (SCM_LIKELY (x
>= 0))
10117 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10118 || x
< (1L << (DBL_MANT_DIG
- 1))))
10120 double root
= sqrt (x
);
10122 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10123 integer, then the result is exact. */
10124 if (root
== floor (root
))
10125 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10127 return scm_from_double (root
);
10134 mpz_init_set_ui (xx
, x
);
10135 if (mpz_perfect_square_p (xx
))
10138 root
= mpz_get_ui (xx
);
10140 return SCM_I_MAKINUM (root
);
10147 else if (SCM_BIGP (z
))
10149 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10151 SCM root
= scm_i_mkbig ();
10153 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10154 scm_remember_upto_here_1 (z
);
10155 return scm_i_normbig (root
);
10160 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10168 return scm_c_make_rectangular
10169 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10171 return scm_from_double (ldexp (sqrt (signif
), expon
/ 2));
10174 else if (SCM_FRACTIONP (z
))
10176 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10177 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10179 if (exact_integer_is_perfect_square (n
)
10180 && exact_integer_is_perfect_square (d
))
10181 return scm_i_make_ratio_already_reduced
10182 (exact_integer_floor_square_root (n
),
10183 exact_integer_floor_square_root (d
));
10186 double xx
= scm_i_divide2double (n
, d
);
10187 double abs_xx
= fabs (xx
);
10190 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10192 shift
= (scm_to_long (scm_integer_length (n
))
10193 - scm_to_long (scm_integer_length (d
))) / 2;
10195 d
= left_shift_exact_integer (d
, 2 * shift
);
10197 n
= left_shift_exact_integer (n
, -2 * shift
);
10198 xx
= scm_i_divide2double (n
, d
);
10202 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10204 return scm_from_double (ldexp (sqrt (xx
), shift
));
10208 /* Fallback method, when the cases above do not apply. */
10210 double xx
= scm_to_double (z
);
10212 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10214 return scm_from_double (sqrt (xx
));
10218 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10225 scm_init_numbers ()
10227 if (scm_install_gmp_memory_functions
)
10228 mp_set_memory_functions (custom_gmp_malloc
,
10229 custom_gmp_realloc
,
10232 mpz_init_set_si (z_negative_one
, -1);
10234 /* It may be possible to tune the performance of some algorithms by using
10235 * the following constants to avoid the creation of bignums. Please, before
10236 * using these values, remember the two rules of program optimization:
10237 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10238 scm_c_define ("most-positive-fixnum",
10239 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10240 scm_c_define ("most-negative-fixnum",
10241 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10243 scm_add_feature ("complex");
10244 scm_add_feature ("inexact");
10245 flo0
= scm_from_double (0.0);
10246 flo_log10e
= scm_from_double (M_LOG10E
);
10248 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10251 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10252 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10253 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10254 scm_i_divide2double_lo2b
,
10255 DBL_MANT_DIG
+ 1); /* 2 b^p */
10256 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10260 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10261 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10262 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10263 dbl_minimum_normal_mantissa
,
10267 #include "libguile/numbers.x"
10272 c-file-style: "gnu"