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. dxx is at
6546 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6547 an integer and fits a long. So we cast yy to a long and
6548 compare with plain xx.
6550 An alternative (for any size system actually) would be to check
6551 yy is an integer (with floor) and is in range of an inum
6552 (compare against appropriate powers of 2) then test
6553 xx==(scm_t_signed_bits)yy. It's just a matter of which
6554 casts/comparisons might be fastest or easiest for the cpu. */
6556 double yy
= SCM_REAL_VALUE (y
);
6557 return scm_from_bool ((double) xx
== yy
6558 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6559 || xx
== (scm_t_signed_bits
) yy
));
6561 else if (SCM_COMPLEXP (y
))
6562 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6563 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6564 else if (SCM_FRACTIONP (y
))
6567 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6569 else if (SCM_BIGP (x
))
6571 if (SCM_I_INUMP (y
))
6573 else if (SCM_BIGP (y
))
6575 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6576 scm_remember_upto_here_2 (x
, y
);
6577 return scm_from_bool (0 == cmp
);
6579 else if (SCM_REALP (y
))
6582 if (isnan (SCM_REAL_VALUE (y
)))
6584 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6585 scm_remember_upto_here_1 (x
);
6586 return scm_from_bool (0 == cmp
);
6588 else if (SCM_COMPLEXP (y
))
6591 if (0.0 != SCM_COMPLEX_IMAG (y
))
6593 if (isnan (SCM_COMPLEX_REAL (y
)))
6595 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6596 scm_remember_upto_here_1 (x
);
6597 return scm_from_bool (0 == cmp
);
6599 else if (SCM_FRACTIONP (y
))
6602 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6604 else if (SCM_REALP (x
))
6606 double xx
= SCM_REAL_VALUE (x
);
6607 if (SCM_I_INUMP (y
))
6609 /* see comments with inum/real above */
6610 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6611 return scm_from_bool (xx
== (double) yy
6612 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6613 || (scm_t_signed_bits
) xx
== yy
));
6615 else if (SCM_BIGP (y
))
6618 if (isnan (SCM_REAL_VALUE (x
)))
6620 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6621 scm_remember_upto_here_1 (y
);
6622 return scm_from_bool (0 == cmp
);
6624 else if (SCM_REALP (y
))
6625 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6626 else if (SCM_COMPLEXP (y
))
6627 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6628 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6629 else if (SCM_FRACTIONP (y
))
6631 double xx
= SCM_REAL_VALUE (x
);
6635 return scm_from_bool (xx
< 0.0);
6636 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6640 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6642 else if (SCM_COMPLEXP (x
))
6644 if (SCM_I_INUMP (y
))
6645 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6646 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6647 else if (SCM_BIGP (y
))
6650 if (0.0 != SCM_COMPLEX_IMAG (x
))
6652 if (isnan (SCM_COMPLEX_REAL (x
)))
6654 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6655 scm_remember_upto_here_1 (y
);
6656 return scm_from_bool (0 == cmp
);
6658 else if (SCM_REALP (y
))
6659 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6660 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6661 else if (SCM_COMPLEXP (y
))
6662 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6663 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6664 else if (SCM_FRACTIONP (y
))
6667 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6669 xx
= SCM_COMPLEX_REAL (x
);
6673 return scm_from_bool (xx
< 0.0);
6674 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6678 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6680 else if (SCM_FRACTIONP (x
))
6682 if (SCM_I_INUMP (y
))
6684 else if (SCM_BIGP (y
))
6686 else if (SCM_REALP (y
))
6688 double yy
= SCM_REAL_VALUE (y
);
6692 return scm_from_bool (0.0 < yy
);
6693 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6696 else if (SCM_COMPLEXP (y
))
6699 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6701 yy
= SCM_COMPLEX_REAL (y
);
6705 return scm_from_bool (0.0 < yy
);
6706 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6709 else if (SCM_FRACTIONP (y
))
6710 return scm_i_fraction_equalp (x
, y
);
6712 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6715 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6719 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6720 done are good for inums, but for bignums an answer can almost always be
6721 had by just examining a few high bits of the operands, as done by GMP in
6722 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6723 of the float exponent to take into account. */
6725 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6726 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6727 (SCM x
, SCM y
, SCM rest
),
6728 "Return @code{#t} if the list of parameters is monotonically\n"
6730 #define FUNC_NAME s_scm_i_num_less_p
6732 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6734 while (!scm_is_null (rest
))
6736 if (scm_is_false (scm_less_p (x
, y
)))
6740 rest
= scm_cdr (rest
);
6742 return scm_less_p (x
, y
);
6746 scm_less_p (SCM x
, SCM y
)
6749 if (SCM_I_INUMP (x
))
6751 scm_t_inum xx
= SCM_I_INUM (x
);
6752 if (SCM_I_INUMP (y
))
6754 scm_t_inum yy
= SCM_I_INUM (y
);
6755 return scm_from_bool (xx
< yy
);
6757 else if (SCM_BIGP (y
))
6759 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6760 scm_remember_upto_here_1 (y
);
6761 return scm_from_bool (sgn
> 0);
6763 else if (SCM_REALP (y
))
6764 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6765 else if (SCM_FRACTIONP (y
))
6767 /* "x < a/b" becomes "x*b < a" */
6769 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6770 y
= SCM_FRACTION_NUMERATOR (y
);
6774 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6776 else if (SCM_BIGP (x
))
6778 if (SCM_I_INUMP (y
))
6780 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6781 scm_remember_upto_here_1 (x
);
6782 return scm_from_bool (sgn
< 0);
6784 else if (SCM_BIGP (y
))
6786 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6787 scm_remember_upto_here_2 (x
, y
);
6788 return scm_from_bool (cmp
< 0);
6790 else if (SCM_REALP (y
))
6793 if (isnan (SCM_REAL_VALUE (y
)))
6795 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6796 scm_remember_upto_here_1 (x
);
6797 return scm_from_bool (cmp
< 0);
6799 else if (SCM_FRACTIONP (y
))
6802 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6804 else if (SCM_REALP (x
))
6806 if (SCM_I_INUMP (y
))
6807 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6808 else if (SCM_BIGP (y
))
6811 if (isnan (SCM_REAL_VALUE (x
)))
6813 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6814 scm_remember_upto_here_1 (y
);
6815 return scm_from_bool (cmp
> 0);
6817 else if (SCM_REALP (y
))
6818 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6819 else if (SCM_FRACTIONP (y
))
6821 double xx
= SCM_REAL_VALUE (x
);
6825 return scm_from_bool (xx
< 0.0);
6826 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6830 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6832 else if (SCM_FRACTIONP (x
))
6834 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6836 /* "a/b < y" becomes "a < y*b" */
6837 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6838 x
= SCM_FRACTION_NUMERATOR (x
);
6841 else if (SCM_REALP (y
))
6843 double yy
= SCM_REAL_VALUE (y
);
6847 return scm_from_bool (0.0 < yy
);
6848 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6851 else if (SCM_FRACTIONP (y
))
6853 /* "a/b < c/d" becomes "a*d < c*b" */
6854 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6855 SCM_FRACTION_DENOMINATOR (y
));
6856 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6857 SCM_FRACTION_DENOMINATOR (x
));
6863 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6866 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6870 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6871 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6872 (SCM x
, SCM y
, SCM rest
),
6873 "Return @code{#t} if the list of parameters is monotonically\n"
6875 #define FUNC_NAME s_scm_i_num_gr_p
6877 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6879 while (!scm_is_null (rest
))
6881 if (scm_is_false (scm_gr_p (x
, y
)))
6885 rest
= scm_cdr (rest
);
6887 return scm_gr_p (x
, y
);
6890 #define FUNC_NAME s_scm_i_num_gr_p
6892 scm_gr_p (SCM x
, SCM y
)
6894 if (!SCM_NUMBERP (x
))
6895 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6896 else if (!SCM_NUMBERP (y
))
6897 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6899 return scm_less_p (y
, x
);
6904 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6905 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6906 (SCM x
, SCM y
, SCM rest
),
6907 "Return @code{#t} if the list of parameters is monotonically\n"
6909 #define FUNC_NAME s_scm_i_num_leq_p
6911 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6913 while (!scm_is_null (rest
))
6915 if (scm_is_false (scm_leq_p (x
, y
)))
6919 rest
= scm_cdr (rest
);
6921 return scm_leq_p (x
, y
);
6924 #define FUNC_NAME s_scm_i_num_leq_p
6926 scm_leq_p (SCM x
, SCM y
)
6928 if (!SCM_NUMBERP (x
))
6929 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6930 else if (!SCM_NUMBERP (y
))
6931 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6932 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6935 return scm_not (scm_less_p (y
, x
));
6940 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6941 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6942 (SCM x
, SCM y
, SCM rest
),
6943 "Return @code{#t} if the list of parameters is monotonically\n"
6945 #define FUNC_NAME s_scm_i_num_geq_p
6947 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6949 while (!scm_is_null (rest
))
6951 if (scm_is_false (scm_geq_p (x
, y
)))
6955 rest
= scm_cdr (rest
);
6957 return scm_geq_p (x
, y
);
6960 #define FUNC_NAME s_scm_i_num_geq_p
6962 scm_geq_p (SCM x
, SCM y
)
6964 if (!SCM_NUMBERP (x
))
6965 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6966 else if (!SCM_NUMBERP (y
))
6967 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6968 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6971 return scm_not (scm_less_p (x
, y
));
6976 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6978 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6980 #define FUNC_NAME s_scm_zero_p
6982 if (SCM_I_INUMP (z
))
6983 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6984 else if (SCM_BIGP (z
))
6986 else if (SCM_REALP (z
))
6987 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6988 else if (SCM_COMPLEXP (z
))
6989 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6990 && SCM_COMPLEX_IMAG (z
) == 0.0);
6991 else if (SCM_FRACTIONP (z
))
6994 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6999 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7001 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7003 #define FUNC_NAME s_scm_positive_p
7005 if (SCM_I_INUMP (x
))
7006 return scm_from_bool (SCM_I_INUM (x
) > 0);
7007 else if (SCM_BIGP (x
))
7009 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7010 scm_remember_upto_here_1 (x
);
7011 return scm_from_bool (sgn
> 0);
7013 else if (SCM_REALP (x
))
7014 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7015 else if (SCM_FRACTIONP (x
))
7016 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7018 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7023 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7025 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7027 #define FUNC_NAME s_scm_negative_p
7029 if (SCM_I_INUMP (x
))
7030 return scm_from_bool (SCM_I_INUM (x
) < 0);
7031 else if (SCM_BIGP (x
))
7033 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7034 scm_remember_upto_here_1 (x
);
7035 return scm_from_bool (sgn
< 0);
7037 else if (SCM_REALP (x
))
7038 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7039 else if (SCM_FRACTIONP (x
))
7040 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7042 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7047 /* scm_min and scm_max return an inexact when either argument is inexact, as
7048 required by r5rs. On that basis, for exact/inexact combinations the
7049 exact is converted to inexact to compare and possibly return. This is
7050 unlike scm_less_p above which takes some trouble to preserve all bits in
7051 its test, such trouble is not required for min and max. */
7053 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7054 (SCM x
, SCM y
, SCM rest
),
7055 "Return the maximum of all parameter values.")
7056 #define FUNC_NAME s_scm_i_max
7058 while (!scm_is_null (rest
))
7059 { x
= scm_max (x
, y
);
7061 rest
= scm_cdr (rest
);
7063 return scm_max (x
, y
);
7067 #define s_max s_scm_i_max
7068 #define g_max g_scm_i_max
7071 scm_max (SCM x
, SCM y
)
7076 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7077 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7080 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7083 if (SCM_I_INUMP (x
))
7085 scm_t_inum xx
= SCM_I_INUM (x
);
7086 if (SCM_I_INUMP (y
))
7088 scm_t_inum yy
= SCM_I_INUM (y
);
7089 return (xx
< yy
) ? y
: x
;
7091 else if (SCM_BIGP (y
))
7093 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7094 scm_remember_upto_here_1 (y
);
7095 return (sgn
< 0) ? x
: y
;
7097 else if (SCM_REALP (y
))
7100 double yyd
= SCM_REAL_VALUE (y
);
7103 return scm_from_double (xxd
);
7104 /* If y is a NaN, then "==" is false and we return the NaN */
7105 else if (SCM_LIKELY (!(xxd
== yyd
)))
7107 /* Handle signed zeroes properly */
7113 else if (SCM_FRACTIONP (y
))
7116 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7119 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7121 else if (SCM_BIGP (x
))
7123 if (SCM_I_INUMP (y
))
7125 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7126 scm_remember_upto_here_1 (x
);
7127 return (sgn
< 0) ? y
: x
;
7129 else if (SCM_BIGP (y
))
7131 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7132 scm_remember_upto_here_2 (x
, y
);
7133 return (cmp
> 0) ? x
: y
;
7135 else if (SCM_REALP (y
))
7137 /* if y==NaN then xx>yy is false, so we return the NaN y */
7140 xx
= scm_i_big2dbl (x
);
7141 yy
= SCM_REAL_VALUE (y
);
7142 return (xx
> yy
? scm_from_double (xx
) : y
);
7144 else if (SCM_FRACTIONP (y
))
7149 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7151 else if (SCM_REALP (x
))
7153 if (SCM_I_INUMP (y
))
7155 scm_t_inum yy
= SCM_I_INUM (y
);
7156 double xxd
= SCM_REAL_VALUE (x
);
7160 return scm_from_double (yyd
);
7161 /* If x is a NaN, then "==" is false and we return the NaN */
7162 else if (SCM_LIKELY (!(xxd
== yyd
)))
7164 /* Handle signed zeroes properly */
7170 else if (SCM_BIGP (y
))
7175 else if (SCM_REALP (y
))
7177 double xx
= SCM_REAL_VALUE (x
);
7178 double yy
= SCM_REAL_VALUE (y
);
7180 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7183 else if (SCM_LIKELY (xx
< yy
))
7185 /* If neither (xx > yy) nor (xx < yy), then
7186 either they're equal or one is a NaN */
7187 else if (SCM_UNLIKELY (isnan (xx
)))
7188 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7189 else if (SCM_UNLIKELY (isnan (yy
)))
7190 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7191 /* xx == yy, but handle signed zeroes properly */
7192 else if (double_is_non_negative_zero (yy
))
7197 else if (SCM_FRACTIONP (y
))
7199 double yy
= scm_i_fraction2double (y
);
7200 double xx
= SCM_REAL_VALUE (x
);
7201 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7204 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7206 else if (SCM_FRACTIONP (x
))
7208 if (SCM_I_INUMP (y
))
7212 else if (SCM_BIGP (y
))
7216 else if (SCM_REALP (y
))
7218 double xx
= scm_i_fraction2double (x
);
7219 /* if y==NaN then ">" is false, so we return the NaN y */
7220 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7222 else if (SCM_FRACTIONP (y
))
7227 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7230 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7234 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7235 (SCM x
, SCM y
, SCM rest
),
7236 "Return the minimum of all parameter values.")
7237 #define FUNC_NAME s_scm_i_min
7239 while (!scm_is_null (rest
))
7240 { x
= scm_min (x
, y
);
7242 rest
= scm_cdr (rest
);
7244 return scm_min (x
, y
);
7248 #define s_min s_scm_i_min
7249 #define g_min g_scm_i_min
7252 scm_min (SCM x
, SCM y
)
7257 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7258 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7261 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7264 if (SCM_I_INUMP (x
))
7266 scm_t_inum xx
= SCM_I_INUM (x
);
7267 if (SCM_I_INUMP (y
))
7269 scm_t_inum yy
= SCM_I_INUM (y
);
7270 return (xx
< yy
) ? x
: y
;
7272 else if (SCM_BIGP (y
))
7274 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7275 scm_remember_upto_here_1 (y
);
7276 return (sgn
< 0) ? y
: x
;
7278 else if (SCM_REALP (y
))
7281 /* if y==NaN then "<" is false and we return NaN */
7282 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7284 else if (SCM_FRACTIONP (y
))
7287 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7290 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7292 else if (SCM_BIGP (x
))
7294 if (SCM_I_INUMP (y
))
7296 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7297 scm_remember_upto_here_1 (x
);
7298 return (sgn
< 0) ? x
: y
;
7300 else if (SCM_BIGP (y
))
7302 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7303 scm_remember_upto_here_2 (x
, y
);
7304 return (cmp
> 0) ? y
: x
;
7306 else if (SCM_REALP (y
))
7308 /* if y==NaN then xx<yy is false, so we return the NaN y */
7311 xx
= scm_i_big2dbl (x
);
7312 yy
= SCM_REAL_VALUE (y
);
7313 return (xx
< yy
? scm_from_double (xx
) : y
);
7315 else if (SCM_FRACTIONP (y
))
7320 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7322 else if (SCM_REALP (x
))
7324 if (SCM_I_INUMP (y
))
7326 double z
= SCM_I_INUM (y
);
7327 /* if x==NaN then "<" is false and we return NaN */
7328 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7330 else if (SCM_BIGP (y
))
7335 else if (SCM_REALP (y
))
7337 double xx
= SCM_REAL_VALUE (x
);
7338 double yy
= SCM_REAL_VALUE (y
);
7340 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7343 else if (SCM_LIKELY (xx
> yy
))
7345 /* If neither (xx < yy) nor (xx > yy), then
7346 either they're equal or one is a NaN */
7347 else if (SCM_UNLIKELY (isnan (xx
)))
7348 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7349 else if (SCM_UNLIKELY (isnan (yy
)))
7350 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7351 /* xx == yy, but handle signed zeroes properly */
7352 else if (double_is_non_negative_zero (xx
))
7357 else if (SCM_FRACTIONP (y
))
7359 double yy
= scm_i_fraction2double (y
);
7360 double xx
= SCM_REAL_VALUE (x
);
7361 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7364 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7366 else if (SCM_FRACTIONP (x
))
7368 if (SCM_I_INUMP (y
))
7372 else if (SCM_BIGP (y
))
7376 else if (SCM_REALP (y
))
7378 double xx
= scm_i_fraction2double (x
);
7379 /* if y==NaN then "<" is false, so we return the NaN y */
7380 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7382 else if (SCM_FRACTIONP (y
))
7387 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7390 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7394 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7395 (SCM x
, SCM y
, SCM rest
),
7396 "Return the sum of all parameter values. Return 0 if called without\n"
7398 #define FUNC_NAME s_scm_i_sum
7400 while (!scm_is_null (rest
))
7401 { x
= scm_sum (x
, y
);
7403 rest
= scm_cdr (rest
);
7405 return scm_sum (x
, y
);
7409 #define s_sum s_scm_i_sum
7410 #define g_sum g_scm_i_sum
7413 scm_sum (SCM x
, SCM y
)
7415 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7417 if (SCM_NUMBERP (x
)) return x
;
7418 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7419 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7422 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7424 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7426 scm_t_inum xx
= SCM_I_INUM (x
);
7427 scm_t_inum yy
= SCM_I_INUM (y
);
7428 scm_t_inum z
= xx
+ yy
;
7429 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7431 else if (SCM_BIGP (y
))
7436 else if (SCM_REALP (y
))
7438 scm_t_inum xx
= SCM_I_INUM (x
);
7439 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7441 else if (SCM_COMPLEXP (y
))
7443 scm_t_inum xx
= SCM_I_INUM (x
);
7444 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7445 SCM_COMPLEX_IMAG (y
));
7447 else if (SCM_FRACTIONP (y
))
7448 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7449 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7450 SCM_FRACTION_DENOMINATOR (y
));
7452 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7453 } else if (SCM_BIGP (x
))
7455 if (SCM_I_INUMP (y
))
7460 inum
= SCM_I_INUM (y
);
7463 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7466 SCM result
= scm_i_mkbig ();
7467 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7468 scm_remember_upto_here_1 (x
);
7469 /* we know the result will have to be a bignum */
7472 return scm_i_normbig (result
);
7476 SCM result
= scm_i_mkbig ();
7477 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7478 scm_remember_upto_here_1 (x
);
7479 /* we know the result will have to be a bignum */
7482 return scm_i_normbig (result
);
7485 else if (SCM_BIGP (y
))
7487 SCM result
= scm_i_mkbig ();
7488 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7489 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7490 mpz_add (SCM_I_BIG_MPZ (result
),
7493 scm_remember_upto_here_2 (x
, y
);
7494 /* we know the result will have to be a bignum */
7497 return scm_i_normbig (result
);
7499 else if (SCM_REALP (y
))
7501 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7502 scm_remember_upto_here_1 (x
);
7503 return scm_from_double (result
);
7505 else if (SCM_COMPLEXP (y
))
7507 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7508 + SCM_COMPLEX_REAL (y
));
7509 scm_remember_upto_here_1 (x
);
7510 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7512 else if (SCM_FRACTIONP (y
))
7513 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7514 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7515 SCM_FRACTION_DENOMINATOR (y
));
7517 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7519 else if (SCM_REALP (x
))
7521 if (SCM_I_INUMP (y
))
7522 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7523 else if (SCM_BIGP (y
))
7525 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7526 scm_remember_upto_here_1 (y
);
7527 return scm_from_double (result
);
7529 else if (SCM_REALP (y
))
7530 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7531 else if (SCM_COMPLEXP (y
))
7532 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7533 SCM_COMPLEX_IMAG (y
));
7534 else if (SCM_FRACTIONP (y
))
7535 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7537 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7539 else if (SCM_COMPLEXP (x
))
7541 if (SCM_I_INUMP (y
))
7542 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7543 SCM_COMPLEX_IMAG (x
));
7544 else if (SCM_BIGP (y
))
7546 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7547 + SCM_COMPLEX_REAL (x
));
7548 scm_remember_upto_here_1 (y
);
7549 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7551 else if (SCM_REALP (y
))
7552 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7553 SCM_COMPLEX_IMAG (x
));
7554 else if (SCM_COMPLEXP (y
))
7555 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7556 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7557 else if (SCM_FRACTIONP (y
))
7558 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7559 SCM_COMPLEX_IMAG (x
));
7561 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7563 else if (SCM_FRACTIONP (x
))
7565 if (SCM_I_INUMP (y
))
7566 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7567 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7568 SCM_FRACTION_DENOMINATOR (x
));
7569 else if (SCM_BIGP (y
))
7570 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7571 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7572 SCM_FRACTION_DENOMINATOR (x
));
7573 else if (SCM_REALP (y
))
7574 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7575 else if (SCM_COMPLEXP (y
))
7576 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7577 SCM_COMPLEX_IMAG (y
));
7578 else if (SCM_FRACTIONP (y
))
7579 /* a/b + c/d = (ad + bc) / bd */
7580 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7581 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7582 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7584 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7587 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7591 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7593 "Return @math{@var{x}+1}.")
7594 #define FUNC_NAME s_scm_oneplus
7596 return scm_sum (x
, SCM_INUM1
);
7601 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7602 (SCM x
, SCM y
, SCM rest
),
7603 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7604 "the sum of all but the first argument are subtracted from the first\n"
7606 #define FUNC_NAME s_scm_i_difference
7608 while (!scm_is_null (rest
))
7609 { x
= scm_difference (x
, y
);
7611 rest
= scm_cdr (rest
);
7613 return scm_difference (x
, y
);
7617 #define s_difference s_scm_i_difference
7618 #define g_difference g_scm_i_difference
7621 scm_difference (SCM x
, SCM y
)
7622 #define FUNC_NAME s_difference
7624 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7627 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7629 if (SCM_I_INUMP (x
))
7631 scm_t_inum xx
= -SCM_I_INUM (x
);
7632 if (SCM_FIXABLE (xx
))
7633 return SCM_I_MAKINUM (xx
);
7635 return scm_i_inum2big (xx
);
7637 else if (SCM_BIGP (x
))
7638 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7639 bignum, but negating that gives a fixnum. */
7640 return scm_i_normbig (scm_i_clonebig (x
, 0));
7641 else if (SCM_REALP (x
))
7642 return scm_from_double (-SCM_REAL_VALUE (x
));
7643 else if (SCM_COMPLEXP (x
))
7644 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7645 -SCM_COMPLEX_IMAG (x
));
7646 else if (SCM_FRACTIONP (x
))
7647 return scm_i_make_ratio_already_reduced
7648 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7649 SCM_FRACTION_DENOMINATOR (x
));
7651 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7654 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7656 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7658 scm_t_inum xx
= SCM_I_INUM (x
);
7659 scm_t_inum yy
= SCM_I_INUM (y
);
7660 scm_t_inum z
= xx
- yy
;
7661 if (SCM_FIXABLE (z
))
7662 return SCM_I_MAKINUM (z
);
7664 return scm_i_inum2big (z
);
7666 else if (SCM_BIGP (y
))
7668 /* inum-x - big-y */
7669 scm_t_inum xx
= SCM_I_INUM (x
);
7673 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7674 bignum, but negating that gives a fixnum. */
7675 return scm_i_normbig (scm_i_clonebig (y
, 0));
7679 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7680 SCM result
= scm_i_mkbig ();
7683 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7686 /* x - y == -(y + -x) */
7687 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7688 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7690 scm_remember_upto_here_1 (y
);
7692 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7693 /* we know the result will have to be a bignum */
7696 return scm_i_normbig (result
);
7699 else if (SCM_REALP (y
))
7701 scm_t_inum xx
= SCM_I_INUM (x
);
7704 * We need to handle x == exact 0
7705 * specially because R6RS states that:
7706 * (- 0.0) ==> -0.0 and
7707 * (- 0.0 0.0) ==> 0.0
7708 * and the scheme compiler changes
7709 * (- 0.0) into (- 0 0.0)
7710 * So we need to treat (- 0 0.0) like (- 0.0).
7711 * At the C level, (-x) is different than (0.0 - x).
7712 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7715 return scm_from_double (- SCM_REAL_VALUE (y
));
7717 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7719 else if (SCM_COMPLEXP (y
))
7721 scm_t_inum xx
= SCM_I_INUM (x
);
7723 /* We need to handle x == exact 0 specially.
7724 See the comment above (for SCM_REALP (y)) */
7726 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7727 - SCM_COMPLEX_IMAG (y
));
7729 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7730 - SCM_COMPLEX_IMAG (y
));
7732 else if (SCM_FRACTIONP (y
))
7733 /* a - b/c = (ac - b) / c */
7734 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7735 SCM_FRACTION_NUMERATOR (y
)),
7736 SCM_FRACTION_DENOMINATOR (y
));
7738 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7740 else if (SCM_BIGP (x
))
7742 if (SCM_I_INUMP (y
))
7744 /* big-x - inum-y */
7745 scm_t_inum yy
= SCM_I_INUM (y
);
7746 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7748 scm_remember_upto_here_1 (x
);
7750 return (SCM_FIXABLE (-yy
) ?
7751 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7754 SCM result
= scm_i_mkbig ();
7757 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7759 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7760 scm_remember_upto_here_1 (x
);
7762 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7763 /* we know the result will have to be a bignum */
7766 return scm_i_normbig (result
);
7769 else if (SCM_BIGP (y
))
7771 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7772 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7773 SCM result
= scm_i_mkbig ();
7774 mpz_sub (SCM_I_BIG_MPZ (result
),
7777 scm_remember_upto_here_2 (x
, y
);
7778 /* we know the result will have to be a bignum */
7779 if ((sgn_x
== 1) && (sgn_y
== -1))
7781 if ((sgn_x
== -1) && (sgn_y
== 1))
7783 return scm_i_normbig (result
);
7785 else if (SCM_REALP (y
))
7787 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7788 scm_remember_upto_here_1 (x
);
7789 return scm_from_double (result
);
7791 else if (SCM_COMPLEXP (y
))
7793 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7794 - SCM_COMPLEX_REAL (y
));
7795 scm_remember_upto_here_1 (x
);
7796 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7798 else if (SCM_FRACTIONP (y
))
7799 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7800 SCM_FRACTION_NUMERATOR (y
)),
7801 SCM_FRACTION_DENOMINATOR (y
));
7802 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7804 else if (SCM_REALP (x
))
7806 if (SCM_I_INUMP (y
))
7807 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7808 else if (SCM_BIGP (y
))
7810 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7811 scm_remember_upto_here_1 (x
);
7812 return scm_from_double (result
);
7814 else if (SCM_REALP (y
))
7815 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7816 else if (SCM_COMPLEXP (y
))
7817 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7818 -SCM_COMPLEX_IMAG (y
));
7819 else if (SCM_FRACTIONP (y
))
7820 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7822 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7824 else if (SCM_COMPLEXP (x
))
7826 if (SCM_I_INUMP (y
))
7827 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7828 SCM_COMPLEX_IMAG (x
));
7829 else if (SCM_BIGP (y
))
7831 double real_part
= (SCM_COMPLEX_REAL (x
)
7832 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7833 scm_remember_upto_here_1 (x
);
7834 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7836 else if (SCM_REALP (y
))
7837 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7838 SCM_COMPLEX_IMAG (x
));
7839 else if (SCM_COMPLEXP (y
))
7840 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7841 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7842 else if (SCM_FRACTIONP (y
))
7843 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7844 SCM_COMPLEX_IMAG (x
));
7846 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7848 else if (SCM_FRACTIONP (x
))
7850 if (SCM_I_INUMP (y
))
7851 /* a/b - c = (a - cb) / b */
7852 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7853 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7854 SCM_FRACTION_DENOMINATOR (x
));
7855 else if (SCM_BIGP (y
))
7856 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7857 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7858 SCM_FRACTION_DENOMINATOR (x
));
7859 else if (SCM_REALP (y
))
7860 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7861 else if (SCM_COMPLEXP (y
))
7862 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7863 -SCM_COMPLEX_IMAG (y
));
7864 else if (SCM_FRACTIONP (y
))
7865 /* a/b - c/d = (ad - bc) / bd */
7866 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7867 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7868 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7870 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7873 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7878 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7880 "Return @math{@var{x}-1}.")
7881 #define FUNC_NAME s_scm_oneminus
7883 return scm_difference (x
, SCM_INUM1
);
7888 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7889 (SCM x
, SCM y
, SCM rest
),
7890 "Return the product of all arguments. If called without arguments,\n"
7892 #define FUNC_NAME s_scm_i_product
7894 while (!scm_is_null (rest
))
7895 { x
= scm_product (x
, y
);
7897 rest
= scm_cdr (rest
);
7899 return scm_product (x
, y
);
7903 #define s_product s_scm_i_product
7904 #define g_product g_scm_i_product
7907 scm_product (SCM x
, SCM y
)
7909 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7912 return SCM_I_MAKINUM (1L);
7913 else if (SCM_NUMBERP (x
))
7916 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7919 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7924 xx
= SCM_I_INUM (x
);
7929 /* exact1 is the universal multiplicative identity */
7933 /* exact0 times a fixnum is exact0: optimize this case */
7934 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7936 /* if the other argument is inexact, the result is inexact,
7937 and we must do the multiplication in order to handle
7938 infinities and NaNs properly. */
7939 else if (SCM_REALP (y
))
7940 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7941 else if (SCM_COMPLEXP (y
))
7942 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7943 0.0 * SCM_COMPLEX_IMAG (y
));
7944 /* we've already handled inexact numbers,
7945 so y must be exact, and we return exact0 */
7946 else if (SCM_NUMP (y
))
7949 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7953 * This case is important for more than just optimization.
7954 * It handles the case of negating
7955 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7956 * which is a bignum that must be changed back into a fixnum.
7957 * Failure to do so will cause the following to return #f:
7958 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7960 return scm_difference(y
, SCM_UNDEFINED
);
7964 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7966 scm_t_inum yy
= SCM_I_INUM (y
);
7967 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7968 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7969 if (SCM_FIXABLE (kk
))
7970 return SCM_I_MAKINUM (kk
);
7972 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7973 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7974 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7975 return SCM_I_MAKINUM (xx
* yy
);
7979 SCM result
= scm_i_inum2big (xx
);
7980 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7981 return scm_i_normbig (result
);
7984 else if (SCM_BIGP (y
))
7986 SCM result
= scm_i_mkbig ();
7987 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7988 scm_remember_upto_here_1 (y
);
7991 else if (SCM_REALP (y
))
7992 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7993 else if (SCM_COMPLEXP (y
))
7994 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7995 xx
* SCM_COMPLEX_IMAG (y
));
7996 else if (SCM_FRACTIONP (y
))
7997 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7998 SCM_FRACTION_DENOMINATOR (y
));
8000 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8002 else if (SCM_BIGP (x
))
8004 if (SCM_I_INUMP (y
))
8009 else if (SCM_BIGP (y
))
8011 SCM result
= scm_i_mkbig ();
8012 mpz_mul (SCM_I_BIG_MPZ (result
),
8015 scm_remember_upto_here_2 (x
, y
);
8018 else if (SCM_REALP (y
))
8020 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8021 scm_remember_upto_here_1 (x
);
8022 return scm_from_double (result
);
8024 else if (SCM_COMPLEXP (y
))
8026 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8027 scm_remember_upto_here_1 (x
);
8028 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8029 z
* SCM_COMPLEX_IMAG (y
));
8031 else if (SCM_FRACTIONP (y
))
8032 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8033 SCM_FRACTION_DENOMINATOR (y
));
8035 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8037 else if (SCM_REALP (x
))
8039 if (SCM_I_INUMP (y
))
8044 else if (SCM_BIGP (y
))
8046 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8047 scm_remember_upto_here_1 (y
);
8048 return scm_from_double (result
);
8050 else if (SCM_REALP (y
))
8051 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8052 else if (SCM_COMPLEXP (y
))
8053 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8054 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8055 else if (SCM_FRACTIONP (y
))
8056 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8058 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8060 else if (SCM_COMPLEXP (x
))
8062 if (SCM_I_INUMP (y
))
8067 else if (SCM_BIGP (y
))
8069 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8070 scm_remember_upto_here_1 (y
);
8071 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8072 z
* SCM_COMPLEX_IMAG (x
));
8074 else if (SCM_REALP (y
))
8075 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8076 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8077 else if (SCM_COMPLEXP (y
))
8079 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8080 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8081 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8082 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8084 else if (SCM_FRACTIONP (y
))
8086 double yy
= scm_i_fraction2double (y
);
8087 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8088 yy
* SCM_COMPLEX_IMAG (x
));
8091 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8093 else if (SCM_FRACTIONP (x
))
8095 if (SCM_I_INUMP (y
))
8096 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8097 SCM_FRACTION_DENOMINATOR (x
));
8098 else if (SCM_BIGP (y
))
8099 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8100 SCM_FRACTION_DENOMINATOR (x
));
8101 else if (SCM_REALP (y
))
8102 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8103 else if (SCM_COMPLEXP (y
))
8105 double xx
= scm_i_fraction2double (x
);
8106 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8107 xx
* SCM_COMPLEX_IMAG (y
));
8109 else if (SCM_FRACTIONP (y
))
8110 /* a/b * c/d = ac / bd */
8111 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8112 SCM_FRACTION_NUMERATOR (y
)),
8113 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8114 SCM_FRACTION_DENOMINATOR (y
)));
8116 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8119 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8122 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8123 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8124 #define ALLOW_DIVIDE_BY_ZERO
8125 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8128 /* The code below for complex division is adapted from the GNU
8129 libstdc++, which adapted it from f2c's libF77, and is subject to
8132 /****************************************************************
8133 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8135 Permission to use, copy, modify, and distribute this software
8136 and its documentation for any purpose and without fee is hereby
8137 granted, provided that the above copyright notice appear in all
8138 copies and that both that the copyright notice and this
8139 permission notice and warranty disclaimer appear in supporting
8140 documentation, and that the names of AT&T Bell Laboratories or
8141 Bellcore or any of their entities not be used in advertising or
8142 publicity pertaining to distribution of the software without
8143 specific, written prior permission.
8145 AT&T and Bellcore disclaim all warranties with regard to this
8146 software, including all implied warranties of merchantability
8147 and fitness. In no event shall AT&T or Bellcore be liable for
8148 any special, indirect or consequential damages or any damages
8149 whatsoever resulting from loss of use, data or profits, whether
8150 in an action of contract, negligence or other tortious action,
8151 arising out of or in connection with the use or performance of
8153 ****************************************************************/
8155 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8156 (SCM x
, SCM y
, SCM rest
),
8157 "Divide the first argument by the product of the remaining\n"
8158 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8160 #define FUNC_NAME s_scm_i_divide
8162 while (!scm_is_null (rest
))
8163 { x
= scm_divide (x
, y
);
8165 rest
= scm_cdr (rest
);
8167 return scm_divide (x
, y
);
8171 #define s_divide s_scm_i_divide
8172 #define g_divide g_scm_i_divide
8175 scm_divide (SCM x
, SCM y
)
8176 #define FUNC_NAME s_divide
8180 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8183 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8184 else if (SCM_I_INUMP (x
))
8186 scm_t_inum xx
= SCM_I_INUM (x
);
8187 if (xx
== 1 || xx
== -1)
8189 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8191 scm_num_overflow (s_divide
);
8194 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8196 else if (SCM_BIGP (x
))
8197 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8198 else if (SCM_REALP (x
))
8200 double xx
= SCM_REAL_VALUE (x
);
8201 #ifndef ALLOW_DIVIDE_BY_ZERO
8203 scm_num_overflow (s_divide
);
8206 return scm_from_double (1.0 / xx
);
8208 else if (SCM_COMPLEXP (x
))
8210 double r
= SCM_COMPLEX_REAL (x
);
8211 double i
= SCM_COMPLEX_IMAG (x
);
8212 if (fabs(r
) <= fabs(i
))
8215 double d
= i
* (1.0 + t
* t
);
8216 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8221 double d
= r
* (1.0 + t
* t
);
8222 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8225 else if (SCM_FRACTIONP (x
))
8226 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8227 SCM_FRACTION_NUMERATOR (x
));
8229 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8232 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8234 scm_t_inum xx
= SCM_I_INUM (x
);
8235 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8237 scm_t_inum yy
= SCM_I_INUM (y
);
8240 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8241 scm_num_overflow (s_divide
);
8243 return scm_from_double ((double) xx
/ (double) yy
);
8246 else if (xx
% yy
!= 0)
8247 return scm_i_make_ratio (x
, y
);
8250 scm_t_inum z
= xx
/ yy
;
8251 if (SCM_FIXABLE (z
))
8252 return SCM_I_MAKINUM (z
);
8254 return scm_i_inum2big (z
);
8257 else if (SCM_BIGP (y
))
8258 return scm_i_make_ratio (x
, y
);
8259 else if (SCM_REALP (y
))
8261 double yy
= SCM_REAL_VALUE (y
);
8262 #ifndef ALLOW_DIVIDE_BY_ZERO
8264 scm_num_overflow (s_divide
);
8267 /* FIXME: Precision may be lost here due to:
8268 (1) The cast from 'scm_t_inum' to 'double'
8269 (2) Double rounding */
8270 return scm_from_double ((double) xx
/ yy
);
8272 else if (SCM_COMPLEXP (y
))
8275 complex_div
: /* y _must_ be a complex number */
8277 double r
= SCM_COMPLEX_REAL (y
);
8278 double i
= SCM_COMPLEX_IMAG (y
);
8279 if (fabs(r
) <= fabs(i
))
8282 double d
= i
* (1.0 + t
* t
);
8283 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8288 double d
= r
* (1.0 + t
* t
);
8289 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8293 else if (SCM_FRACTIONP (y
))
8294 /* a / b/c = ac / b */
8295 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8296 SCM_FRACTION_NUMERATOR (y
));
8298 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8300 else if (SCM_BIGP (x
))
8302 if (SCM_I_INUMP (y
))
8304 scm_t_inum yy
= SCM_I_INUM (y
);
8307 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8308 scm_num_overflow (s_divide
);
8310 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8311 scm_remember_upto_here_1 (x
);
8312 return (sgn
== 0) ? scm_nan () : scm_inf ();
8319 /* FIXME: HMM, what are the relative performance issues here?
8320 We need to test. Is it faster on average to test
8321 divisible_p, then perform whichever operation, or is it
8322 faster to perform the integer div opportunistically and
8323 switch to real if there's a remainder? For now we take the
8324 middle ground: test, then if divisible, use the faster div
8327 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8328 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8332 SCM result
= scm_i_mkbig ();
8333 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8334 scm_remember_upto_here_1 (x
);
8336 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8337 return scm_i_normbig (result
);
8340 return scm_i_make_ratio (x
, y
);
8343 else if (SCM_BIGP (y
))
8345 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8349 SCM result
= scm_i_mkbig ();
8350 mpz_divexact (SCM_I_BIG_MPZ (result
),
8353 scm_remember_upto_here_2 (x
, y
);
8354 return scm_i_normbig (result
);
8357 return scm_i_make_ratio (x
, y
);
8359 else if (SCM_REALP (y
))
8361 double yy
= SCM_REAL_VALUE (y
);
8362 #ifndef ALLOW_DIVIDE_BY_ZERO
8364 scm_num_overflow (s_divide
);
8367 /* FIXME: Precision may be lost here due to:
8368 (1) scm_i_big2dbl (2) Double rounding */
8369 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8371 else if (SCM_COMPLEXP (y
))
8373 a
= scm_i_big2dbl (x
);
8376 else if (SCM_FRACTIONP (y
))
8377 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8378 SCM_FRACTION_NUMERATOR (y
));
8380 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8382 else if (SCM_REALP (x
))
8384 double rx
= SCM_REAL_VALUE (x
);
8385 if (SCM_I_INUMP (y
))
8387 scm_t_inum yy
= SCM_I_INUM (y
);
8388 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8390 scm_num_overflow (s_divide
);
8393 /* FIXME: Precision may be lost here due to:
8394 (1) The cast from 'scm_t_inum' to 'double'
8395 (2) Double rounding */
8396 return scm_from_double (rx
/ (double) yy
);
8398 else if (SCM_BIGP (y
))
8400 /* FIXME: Precision may be lost here due to:
8401 (1) The conversion from bignum to double
8402 (2) Double rounding */
8403 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8404 scm_remember_upto_here_1 (y
);
8405 return scm_from_double (rx
/ dby
);
8407 else if (SCM_REALP (y
))
8409 double yy
= SCM_REAL_VALUE (y
);
8410 #ifndef ALLOW_DIVIDE_BY_ZERO
8412 scm_num_overflow (s_divide
);
8415 return scm_from_double (rx
/ yy
);
8417 else if (SCM_COMPLEXP (y
))
8422 else if (SCM_FRACTIONP (y
))
8423 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8425 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8427 else if (SCM_COMPLEXP (x
))
8429 double rx
= SCM_COMPLEX_REAL (x
);
8430 double ix
= SCM_COMPLEX_IMAG (x
);
8431 if (SCM_I_INUMP (y
))
8433 scm_t_inum yy
= SCM_I_INUM (y
);
8434 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8436 scm_num_overflow (s_divide
);
8440 /* FIXME: Precision may be lost here due to:
8441 (1) The conversion from 'scm_t_inum' to double
8442 (2) Double rounding */
8444 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8447 else if (SCM_BIGP (y
))
8449 /* FIXME: Precision may be lost here due to:
8450 (1) The conversion from bignum to double
8451 (2) Double rounding */
8452 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8453 scm_remember_upto_here_1 (y
);
8454 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8456 else if (SCM_REALP (y
))
8458 double yy
= SCM_REAL_VALUE (y
);
8459 #ifndef ALLOW_DIVIDE_BY_ZERO
8461 scm_num_overflow (s_divide
);
8464 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8466 else if (SCM_COMPLEXP (y
))
8468 double ry
= SCM_COMPLEX_REAL (y
);
8469 double iy
= SCM_COMPLEX_IMAG (y
);
8470 if (fabs(ry
) <= fabs(iy
))
8473 double d
= iy
* (1.0 + t
* t
);
8474 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8479 double d
= ry
* (1.0 + t
* t
);
8480 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8483 else if (SCM_FRACTIONP (y
))
8485 /* FIXME: Precision may be lost here due to:
8486 (1) The conversion from fraction to double
8487 (2) Double rounding */
8488 double yy
= scm_i_fraction2double (y
);
8489 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8492 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8494 else if (SCM_FRACTIONP (x
))
8496 if (SCM_I_INUMP (y
))
8498 scm_t_inum yy
= SCM_I_INUM (y
);
8499 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8501 scm_num_overflow (s_divide
);
8504 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8505 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8507 else if (SCM_BIGP (y
))
8509 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8510 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8512 else if (SCM_REALP (y
))
8514 double yy
= SCM_REAL_VALUE (y
);
8515 #ifndef ALLOW_DIVIDE_BY_ZERO
8517 scm_num_overflow (s_divide
);
8520 /* FIXME: Precision may be lost here due to:
8521 (1) The conversion from fraction to double
8522 (2) Double rounding */
8523 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8525 else if (SCM_COMPLEXP (y
))
8527 /* FIXME: Precision may be lost here due to:
8528 (1) The conversion from fraction to double
8529 (2) Double rounding */
8530 a
= scm_i_fraction2double (x
);
8533 else if (SCM_FRACTIONP (y
))
8534 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8535 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8537 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8540 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8546 scm_c_truncate (double x
)
8551 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8552 half-way case (ie. when x is an integer plus 0.5) going upwards.
8553 Then half-way cases are identified and adjusted down if the
8554 round-upwards didn't give the desired even integer.
8556 "plus_half == result" identifies a half-way case. If plus_half, which is
8557 x + 0.5, is an integer then x must be an integer plus 0.5.
8559 An odd "result" value is identified with result/2 != floor(result/2).
8560 This is done with plus_half, since that value is ready for use sooner in
8561 a pipelined cpu, and we're already requiring plus_half == result.
8563 Note however that we need to be careful when x is big and already an
8564 integer. In that case "x+0.5" may round to an adjacent integer, causing
8565 us to return such a value, incorrectly. For instance if the hardware is
8566 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8567 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8568 returned. Or if the hardware is in round-upwards mode, then other bigger
8569 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8570 representable value, 2^128+2^76 (or whatever), again incorrect.
8572 These bad roundings of x+0.5 are avoided by testing at the start whether
8573 x is already an integer. If it is then clearly that's the desired result
8574 already. And if it's not then the exponent must be small enough to allow
8575 an 0.5 to be represented, and hence added without a bad rounding. */
8578 scm_c_round (double x
)
8580 double plus_half
, result
;
8585 plus_half
= x
+ 0.5;
8586 result
= floor (plus_half
);
8587 /* Adjust so that the rounding is towards even. */
8588 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8593 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8595 "Round the number @var{x} towards zero.")
8596 #define FUNC_NAME s_scm_truncate_number
8598 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8600 else if (SCM_REALP (x
))
8601 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8602 else if (SCM_FRACTIONP (x
))
8603 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8604 SCM_FRACTION_DENOMINATOR (x
));
8606 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8607 s_scm_truncate_number
);
8611 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8613 "Round the number @var{x} towards the nearest integer. "
8614 "When it is exactly halfway between two integers, "
8615 "round towards the even one.")
8616 #define FUNC_NAME s_scm_round_number
8618 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8620 else if (SCM_REALP (x
))
8621 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8622 else if (SCM_FRACTIONP (x
))
8623 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8624 SCM_FRACTION_DENOMINATOR (x
));
8626 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8627 s_scm_round_number
);
8631 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8633 "Round the number @var{x} towards minus infinity.")
8634 #define FUNC_NAME s_scm_floor
8636 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8638 else if (SCM_REALP (x
))
8639 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8640 else if (SCM_FRACTIONP (x
))
8641 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8642 SCM_FRACTION_DENOMINATOR (x
));
8644 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8648 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8650 "Round the number @var{x} towards infinity.")
8651 #define FUNC_NAME s_scm_ceiling
8653 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8655 else if (SCM_REALP (x
))
8656 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8657 else if (SCM_FRACTIONP (x
))
8658 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8659 SCM_FRACTION_DENOMINATOR (x
));
8661 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8665 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8667 "Return @var{x} raised to the power of @var{y}.")
8668 #define FUNC_NAME s_scm_expt
8670 if (scm_is_integer (y
))
8672 if (scm_is_true (scm_exact_p (y
)))
8673 return scm_integer_expt (x
, y
);
8676 /* Here we handle the case where the exponent is an inexact
8677 integer. We make the exponent exact in order to use
8678 scm_integer_expt, and thus avoid the spurious imaginary
8679 parts that may result from round-off errors in the general
8680 e^(y log x) method below (for example when squaring a large
8681 negative number). In this case, we must return an inexact
8682 result for correctness. We also make the base inexact so
8683 that scm_integer_expt will use fast inexact arithmetic
8684 internally. Note that making the base inexact is not
8685 sufficient to guarantee an inexact result, because
8686 scm_integer_expt will return an exact 1 when the exponent
8687 is 0, even if the base is inexact. */
8688 return scm_exact_to_inexact
8689 (scm_integer_expt (scm_exact_to_inexact (x
),
8690 scm_inexact_to_exact (y
)));
8693 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8695 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8697 else if (scm_is_complex (x
) && scm_is_complex (y
))
8698 return scm_exp (scm_product (scm_log (x
), y
));
8699 else if (scm_is_complex (x
))
8700 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8702 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8706 /* sin/cos/tan/asin/acos/atan
8707 sinh/cosh/tanh/asinh/acosh/atanh
8708 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8709 Written by Jerry D. Hedden, (C) FSF.
8710 See the file `COPYING' for terms applying to this program. */
8712 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8714 "Compute the sine of @var{z}.")
8715 #define FUNC_NAME s_scm_sin
8717 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8718 return z
; /* sin(exact0) = exact0 */
8719 else if (scm_is_real (z
))
8720 return scm_from_double (sin (scm_to_double (z
)));
8721 else if (SCM_COMPLEXP (z
))
8723 x
= SCM_COMPLEX_REAL (z
);
8724 y
= SCM_COMPLEX_IMAG (z
);
8725 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8726 cos (x
) * sinh (y
));
8729 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8733 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8735 "Compute the cosine of @var{z}.")
8736 #define FUNC_NAME s_scm_cos
8738 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8739 return SCM_INUM1
; /* cos(exact0) = exact1 */
8740 else if (scm_is_real (z
))
8741 return scm_from_double (cos (scm_to_double (z
)));
8742 else if (SCM_COMPLEXP (z
))
8744 x
= SCM_COMPLEX_REAL (z
);
8745 y
= SCM_COMPLEX_IMAG (z
);
8746 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8747 -sin (x
) * sinh (y
));
8750 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8754 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8756 "Compute the tangent of @var{z}.")
8757 #define FUNC_NAME s_scm_tan
8759 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8760 return z
; /* tan(exact0) = exact0 */
8761 else if (scm_is_real (z
))
8762 return scm_from_double (tan (scm_to_double (z
)));
8763 else if (SCM_COMPLEXP (z
))
8765 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8766 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8767 w
= cos (x
) + cosh (y
);
8768 #ifndef ALLOW_DIVIDE_BY_ZERO
8770 scm_num_overflow (s_scm_tan
);
8772 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8775 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8779 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8781 "Compute the hyperbolic sine of @var{z}.")
8782 #define FUNC_NAME s_scm_sinh
8784 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8785 return z
; /* sinh(exact0) = exact0 */
8786 else if (scm_is_real (z
))
8787 return scm_from_double (sinh (scm_to_double (z
)));
8788 else if (SCM_COMPLEXP (z
))
8790 x
= SCM_COMPLEX_REAL (z
);
8791 y
= SCM_COMPLEX_IMAG (z
);
8792 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8793 cosh (x
) * sin (y
));
8796 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8800 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8802 "Compute the hyperbolic cosine of @var{z}.")
8803 #define FUNC_NAME s_scm_cosh
8805 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8806 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8807 else if (scm_is_real (z
))
8808 return scm_from_double (cosh (scm_to_double (z
)));
8809 else if (SCM_COMPLEXP (z
))
8811 x
= SCM_COMPLEX_REAL (z
);
8812 y
= SCM_COMPLEX_IMAG (z
);
8813 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8814 sinh (x
) * sin (y
));
8817 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8821 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8823 "Compute the hyperbolic tangent of @var{z}.")
8824 #define FUNC_NAME s_scm_tanh
8826 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8827 return z
; /* tanh(exact0) = exact0 */
8828 else if (scm_is_real (z
))
8829 return scm_from_double (tanh (scm_to_double (z
)));
8830 else if (SCM_COMPLEXP (z
))
8832 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8833 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8834 w
= cosh (x
) + cos (y
);
8835 #ifndef ALLOW_DIVIDE_BY_ZERO
8837 scm_num_overflow (s_scm_tanh
);
8839 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8842 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8846 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8848 "Compute the arc sine of @var{z}.")
8849 #define FUNC_NAME s_scm_asin
8851 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8852 return z
; /* asin(exact0) = exact0 */
8853 else if (scm_is_real (z
))
8855 double w
= scm_to_double (z
);
8856 if (w
>= -1.0 && w
<= 1.0)
8857 return scm_from_double (asin (w
));
8859 return scm_product (scm_c_make_rectangular (0, -1),
8860 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8862 else if (SCM_COMPLEXP (z
))
8864 x
= SCM_COMPLEX_REAL (z
);
8865 y
= SCM_COMPLEX_IMAG (z
);
8866 return scm_product (scm_c_make_rectangular (0, -1),
8867 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8870 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8874 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8876 "Compute the arc cosine of @var{z}.")
8877 #define FUNC_NAME s_scm_acos
8879 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8880 return SCM_INUM0
; /* acos(exact1) = exact0 */
8881 else if (scm_is_real (z
))
8883 double w
= scm_to_double (z
);
8884 if (w
>= -1.0 && w
<= 1.0)
8885 return scm_from_double (acos (w
));
8887 return scm_sum (scm_from_double (acos (0.0)),
8888 scm_product (scm_c_make_rectangular (0, 1),
8889 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8891 else if (SCM_COMPLEXP (z
))
8893 x
= SCM_COMPLEX_REAL (z
);
8894 y
= SCM_COMPLEX_IMAG (z
);
8895 return scm_sum (scm_from_double (acos (0.0)),
8896 scm_product (scm_c_make_rectangular (0, 1),
8897 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8900 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8904 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8906 "With one argument, compute the arc tangent of @var{z}.\n"
8907 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8908 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8909 #define FUNC_NAME s_scm_atan
8913 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8914 return z
; /* atan(exact0) = exact0 */
8915 else if (scm_is_real (z
))
8916 return scm_from_double (atan (scm_to_double (z
)));
8917 else if (SCM_COMPLEXP (z
))
8920 v
= SCM_COMPLEX_REAL (z
);
8921 w
= SCM_COMPLEX_IMAG (z
);
8922 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8923 scm_c_make_rectangular (v
, w
+ 1.0))),
8924 scm_c_make_rectangular (0, 2));
8927 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8929 else if (scm_is_real (z
))
8931 if (scm_is_real (y
))
8932 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8934 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8937 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8941 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8943 "Compute the inverse hyperbolic sine of @var{z}.")
8944 #define FUNC_NAME s_scm_sys_asinh
8946 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8947 return z
; /* asinh(exact0) = exact0 */
8948 else if (scm_is_real (z
))
8949 return scm_from_double (asinh (scm_to_double (z
)));
8950 else if (scm_is_number (z
))
8951 return scm_log (scm_sum (z
,
8952 scm_sqrt (scm_sum (scm_product (z
, z
),
8955 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8959 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8961 "Compute the inverse hyperbolic cosine of @var{z}.")
8962 #define FUNC_NAME s_scm_sys_acosh
8964 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8965 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8966 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8967 return scm_from_double (acosh (scm_to_double (z
)));
8968 else if (scm_is_number (z
))
8969 return scm_log (scm_sum (z
,
8970 scm_sqrt (scm_difference (scm_product (z
, z
),
8973 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8977 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8979 "Compute the inverse hyperbolic tangent of @var{z}.")
8980 #define FUNC_NAME s_scm_sys_atanh
8982 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8983 return z
; /* atanh(exact0) = exact0 */
8984 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8985 return scm_from_double (atanh (scm_to_double (z
)));
8986 else if (scm_is_number (z
))
8987 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8988 scm_difference (SCM_INUM1
, z
))),
8991 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8996 scm_c_make_rectangular (double re
, double im
)
9000 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9002 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9003 SCM_COMPLEX_REAL (z
) = re
;
9004 SCM_COMPLEX_IMAG (z
) = im
;
9008 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9009 (SCM real_part
, SCM imaginary_part
),
9010 "Return a complex number constructed of the given @var{real_part} "
9011 "and @var{imaginary_part} parts.")
9012 #define FUNC_NAME s_scm_make_rectangular
9014 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9015 SCM_ARG1
, FUNC_NAME
, "real");
9016 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9017 SCM_ARG2
, FUNC_NAME
, "real");
9019 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9020 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9023 return scm_c_make_rectangular (scm_to_double (real_part
),
9024 scm_to_double (imaginary_part
));
9029 scm_c_make_polar (double mag
, double ang
)
9033 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9034 use it on Glibc-based systems that have it (it's a GNU extension). See
9035 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9037 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9038 sincos (ang
, &s
, &c
);
9044 /* If s and c are NaNs, this indicates that the angle is a NaN,
9045 infinite, or perhaps simply too large to determine its value
9046 mod 2*pi. However, we know something that the floating-point
9047 implementation doesn't know: We know that s and c are finite.
9048 Therefore, if the magnitude is zero, return a complex zero.
9050 The reason we check for the NaNs instead of using this case
9051 whenever mag == 0.0 is because when the angle is known, we'd
9052 like to return the correct kind of non-real complex zero:
9053 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9054 on which quadrant the angle is in.
9056 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9057 return scm_c_make_rectangular (0.0, 0.0);
9059 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9062 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9064 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9065 #define FUNC_NAME s_scm_make_polar
9067 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9068 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9070 /* If mag is exact0, return exact0 */
9071 if (scm_is_eq (mag
, SCM_INUM0
))
9073 /* Return a real if ang is exact0 */
9074 else if (scm_is_eq (ang
, SCM_INUM0
))
9077 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9082 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9084 "Return the real part of the number @var{z}.")
9085 #define FUNC_NAME s_scm_real_part
9087 if (SCM_COMPLEXP (z
))
9088 return scm_from_double (SCM_COMPLEX_REAL (z
));
9089 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9092 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9097 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9099 "Return the imaginary part of the number @var{z}.")
9100 #define FUNC_NAME s_scm_imag_part
9102 if (SCM_COMPLEXP (z
))
9103 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9104 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9107 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9111 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9113 "Return the numerator of the number @var{z}.")
9114 #define FUNC_NAME s_scm_numerator
9116 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9118 else if (SCM_FRACTIONP (z
))
9119 return SCM_FRACTION_NUMERATOR (z
);
9120 else if (SCM_REALP (z
))
9121 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9123 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9128 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9130 "Return the denominator of the number @var{z}.")
9131 #define FUNC_NAME s_scm_denominator
9133 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9135 else if (SCM_FRACTIONP (z
))
9136 return SCM_FRACTION_DENOMINATOR (z
);
9137 else if (SCM_REALP (z
))
9138 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9140 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9145 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9147 "Return the magnitude of the number @var{z}. This is the same as\n"
9148 "@code{abs} for real arguments, but also allows complex numbers.")
9149 #define FUNC_NAME s_scm_magnitude
9151 if (SCM_I_INUMP (z
))
9153 scm_t_inum zz
= SCM_I_INUM (z
);
9156 else if (SCM_POSFIXABLE (-zz
))
9157 return SCM_I_MAKINUM (-zz
);
9159 return scm_i_inum2big (-zz
);
9161 else if (SCM_BIGP (z
))
9163 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9164 scm_remember_upto_here_1 (z
);
9166 return scm_i_clonebig (z
, 0);
9170 else if (SCM_REALP (z
))
9171 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9172 else if (SCM_COMPLEXP (z
))
9173 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9174 else if (SCM_FRACTIONP (z
))
9176 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9178 return scm_i_make_ratio_already_reduced
9179 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9180 SCM_FRACTION_DENOMINATOR (z
));
9183 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9188 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9190 "Return the angle of the complex number @var{z}.")
9191 #define FUNC_NAME s_scm_angle
9193 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9194 flo0 to save allocating a new flonum with scm_from_double each time.
9195 But if atan2 follows the floating point rounding mode, then the value
9196 is not a constant. Maybe it'd be close enough though. */
9197 if (SCM_I_INUMP (z
))
9199 if (SCM_I_INUM (z
) >= 0)
9202 return scm_from_double (atan2 (0.0, -1.0));
9204 else if (SCM_BIGP (z
))
9206 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9207 scm_remember_upto_here_1 (z
);
9209 return scm_from_double (atan2 (0.0, -1.0));
9213 else if (SCM_REALP (z
))
9215 double x
= SCM_REAL_VALUE (z
);
9216 if (x
> 0.0 || double_is_non_negative_zero (x
))
9219 return scm_from_double (atan2 (0.0, -1.0));
9221 else if (SCM_COMPLEXP (z
))
9222 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9223 else if (SCM_FRACTIONP (z
))
9225 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9227 else return scm_from_double (atan2 (0.0, -1.0));
9230 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9235 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9237 "Convert the number @var{z} to its inexact representation.\n")
9238 #define FUNC_NAME s_scm_exact_to_inexact
9240 if (SCM_I_INUMP (z
))
9241 return scm_from_double ((double) SCM_I_INUM (z
));
9242 else if (SCM_BIGP (z
))
9243 return scm_from_double (scm_i_big2dbl (z
));
9244 else if (SCM_FRACTIONP (z
))
9245 return scm_from_double (scm_i_fraction2double (z
));
9246 else if (SCM_INEXACTP (z
))
9249 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9254 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9256 "Return an exact number that is numerically closest to @var{z}.")
9257 #define FUNC_NAME s_scm_inexact_to_exact
9259 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9266 val
= SCM_REAL_VALUE (z
);
9267 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9268 val
= SCM_COMPLEX_REAL (z
);
9270 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9272 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9273 SCM_OUT_OF_RANGE (1, z
);
9274 else if (val
== 0.0)
9281 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9283 expon
-= DBL_MANT_DIG
;
9286 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9290 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9291 SCM_I_BIG_MPZ (numerator
),
9295 numerator
= scm_i_normbig (numerator
);
9297 return scm_i_make_ratio_already_reduced
9298 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9300 return left_shift_exact_integer (numerator
, expon
);
9308 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9310 "Returns the @emph{simplest} rational number differing\n"
9311 "from @var{x} by no more than @var{eps}.\n"
9313 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9314 "exact result when both its arguments are exact. Thus, you might need\n"
9315 "to use @code{inexact->exact} on the arguments.\n"
9318 "(rationalize (inexact->exact 1.2) 1/100)\n"
9321 #define FUNC_NAME s_scm_rationalize
9323 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9324 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9325 eps
= scm_abs (eps
);
9326 if (scm_is_false (scm_positive_p (eps
)))
9328 /* eps is either zero or a NaN */
9329 if (scm_is_true (scm_nan_p (eps
)))
9331 else if (SCM_INEXACTP (eps
))
9332 return scm_exact_to_inexact (x
);
9336 else if (scm_is_false (scm_finite_p (eps
)))
9338 if (scm_is_true (scm_finite_p (x
)))
9343 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9345 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9346 scm_ceiling (scm_difference (x
, eps
)))))
9348 /* There's an integer within range; we want the one closest to zero */
9349 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9351 /* zero is within range */
9352 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9357 else if (scm_is_true (scm_positive_p (x
)))
9358 return scm_ceiling (scm_difference (x
, eps
));
9360 return scm_floor (scm_sum (x
, eps
));
9364 /* Use continued fractions to find closest ratio. All
9365 arithmetic is done with exact numbers.
9368 SCM ex
= scm_inexact_to_exact (x
);
9369 SCM int_part
= scm_floor (ex
);
9371 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9372 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9376 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9377 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9379 /* We stop after a million iterations just to be absolutely sure
9380 that we don't go into an infinite loop. The process normally
9381 converges after less than a dozen iterations.
9384 while (++i
< 1000000)
9386 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9387 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9388 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9390 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9391 eps
))) /* abs(x-a/b) <= eps */
9393 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9394 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9395 return scm_exact_to_inexact (res
);
9399 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9401 tt
= scm_floor (rx
); /* tt = floor (rx) */
9407 scm_num_overflow (s_scm_rationalize
);
9412 /* conversion functions */
9415 scm_is_integer (SCM val
)
9417 return scm_is_true (scm_integer_p (val
));
9421 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9423 if (SCM_I_INUMP (val
))
9425 scm_t_signed_bits n
= SCM_I_INUM (val
);
9426 return n
>= min
&& n
<= max
;
9428 else if (SCM_BIGP (val
))
9430 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9432 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9434 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9436 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9437 return n
>= min
&& n
<= max
;
9447 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9448 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9451 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9452 SCM_I_BIG_MPZ (val
));
9454 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9466 return n
>= min
&& n
<= max
;
9474 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9476 if (SCM_I_INUMP (val
))
9478 scm_t_signed_bits n
= SCM_I_INUM (val
);
9479 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9481 else if (SCM_BIGP (val
))
9483 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9485 else if (max
<= ULONG_MAX
)
9487 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9489 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9490 return n
>= min
&& n
<= max
;
9500 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9503 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9504 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9507 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9508 SCM_I_BIG_MPZ (val
));
9510 return n
>= min
&& n
<= max
;
9518 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9520 scm_error (scm_out_of_range_key
,
9522 "Value out of range ~S to ~S: ~S",
9523 scm_list_3 (min
, max
, bad_val
),
9524 scm_list_1 (bad_val
));
9527 #define TYPE scm_t_intmax
9528 #define TYPE_MIN min
9529 #define TYPE_MAX max
9530 #define SIZEOF_TYPE 0
9531 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9532 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9533 #include "libguile/conv-integer.i.c"
9535 #define TYPE scm_t_uintmax
9536 #define TYPE_MIN min
9537 #define TYPE_MAX max
9538 #define SIZEOF_TYPE 0
9539 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9540 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9541 #include "libguile/conv-uinteger.i.c"
9543 #define TYPE scm_t_int8
9544 #define TYPE_MIN SCM_T_INT8_MIN
9545 #define TYPE_MAX SCM_T_INT8_MAX
9546 #define SIZEOF_TYPE 1
9547 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9548 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9549 #include "libguile/conv-integer.i.c"
9551 #define TYPE scm_t_uint8
9553 #define TYPE_MAX SCM_T_UINT8_MAX
9554 #define SIZEOF_TYPE 1
9555 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9556 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9557 #include "libguile/conv-uinteger.i.c"
9559 #define TYPE scm_t_int16
9560 #define TYPE_MIN SCM_T_INT16_MIN
9561 #define TYPE_MAX SCM_T_INT16_MAX
9562 #define SIZEOF_TYPE 2
9563 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9564 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9565 #include "libguile/conv-integer.i.c"
9567 #define TYPE scm_t_uint16
9569 #define TYPE_MAX SCM_T_UINT16_MAX
9570 #define SIZEOF_TYPE 2
9571 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9572 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9573 #include "libguile/conv-uinteger.i.c"
9575 #define TYPE scm_t_int32
9576 #define TYPE_MIN SCM_T_INT32_MIN
9577 #define TYPE_MAX SCM_T_INT32_MAX
9578 #define SIZEOF_TYPE 4
9579 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9580 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9581 #include "libguile/conv-integer.i.c"
9583 #define TYPE scm_t_uint32
9585 #define TYPE_MAX SCM_T_UINT32_MAX
9586 #define SIZEOF_TYPE 4
9587 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9588 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9589 #include "libguile/conv-uinteger.i.c"
9591 #define TYPE scm_t_wchar
9592 #define TYPE_MIN (scm_t_int32)-1
9593 #define TYPE_MAX (scm_t_int32)0x10ffff
9594 #define SIZEOF_TYPE 4
9595 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9596 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9597 #include "libguile/conv-integer.i.c"
9599 #define TYPE scm_t_int64
9600 #define TYPE_MIN SCM_T_INT64_MIN
9601 #define TYPE_MAX SCM_T_INT64_MAX
9602 #define SIZEOF_TYPE 8
9603 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9604 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9605 #include "libguile/conv-integer.i.c"
9607 #define TYPE scm_t_uint64
9609 #define TYPE_MAX SCM_T_UINT64_MAX
9610 #define SIZEOF_TYPE 8
9611 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9612 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9613 #include "libguile/conv-uinteger.i.c"
9616 scm_to_mpz (SCM val
, mpz_t rop
)
9618 if (SCM_I_INUMP (val
))
9619 mpz_set_si (rop
, SCM_I_INUM (val
));
9620 else if (SCM_BIGP (val
))
9621 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9623 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9627 scm_from_mpz (mpz_t val
)
9629 return scm_i_mpz2num (val
);
9633 scm_is_real (SCM val
)
9635 return scm_is_true (scm_real_p (val
));
9639 scm_is_rational (SCM val
)
9641 return scm_is_true (scm_rational_p (val
));
9645 scm_to_double (SCM val
)
9647 if (SCM_I_INUMP (val
))
9648 return SCM_I_INUM (val
);
9649 else if (SCM_BIGP (val
))
9650 return scm_i_big2dbl (val
);
9651 else if (SCM_FRACTIONP (val
))
9652 return scm_i_fraction2double (val
);
9653 else if (SCM_REALP (val
))
9654 return SCM_REAL_VALUE (val
);
9656 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9660 scm_from_double (double val
)
9664 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9666 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9667 SCM_REAL_VALUE (z
) = val
;
9672 #if SCM_ENABLE_DEPRECATED == 1
9675 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9677 scm_c_issue_deprecation_warning
9678 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9682 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9686 scm_out_of_range (NULL
, num
);
9689 return scm_to_double (num
);
9693 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9695 scm_c_issue_deprecation_warning
9696 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9700 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9704 scm_out_of_range (NULL
, num
);
9707 return scm_to_double (num
);
9713 scm_is_complex (SCM val
)
9715 return scm_is_true (scm_complex_p (val
));
9719 scm_c_real_part (SCM z
)
9721 if (SCM_COMPLEXP (z
))
9722 return SCM_COMPLEX_REAL (z
);
9725 /* Use the scm_real_part to get proper error checking and
9728 return scm_to_double (scm_real_part (z
));
9733 scm_c_imag_part (SCM z
)
9735 if (SCM_COMPLEXP (z
))
9736 return SCM_COMPLEX_IMAG (z
);
9739 /* Use the scm_imag_part to get proper error checking and
9740 dispatching. The result will almost always be 0.0, but not
9743 return scm_to_double (scm_imag_part (z
));
9748 scm_c_magnitude (SCM z
)
9750 return scm_to_double (scm_magnitude (z
));
9756 return scm_to_double (scm_angle (z
));
9760 scm_is_number (SCM z
)
9762 return scm_is_true (scm_number_p (z
));
9766 /* Returns log(x * 2^shift) */
9768 log_of_shifted_double (double x
, long shift
)
9770 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9772 if (x
> 0.0 || double_is_non_negative_zero (x
))
9773 return scm_from_double (ans
);
9775 return scm_c_make_rectangular (ans
, M_PI
);
9778 /* Returns log(n), for exact integer n */
9780 log_of_exact_integer (SCM n
)
9782 if (SCM_I_INUMP (n
))
9783 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9784 else if (SCM_BIGP (n
))
9787 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9788 return log_of_shifted_double (signif
, expon
);
9791 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9794 /* Returns log(n/d), for exact non-zero integers n and d */
9796 log_of_fraction (SCM n
, SCM d
)
9798 long n_size
= scm_to_long (scm_integer_length (n
));
9799 long d_size
= scm_to_long (scm_integer_length (d
));
9801 if (abs (n_size
- d_size
) > 1)
9802 return (scm_difference (log_of_exact_integer (n
),
9803 log_of_exact_integer (d
)));
9804 else if (scm_is_false (scm_negative_p (n
)))
9805 return scm_from_double
9806 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9808 return scm_c_make_rectangular
9809 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9815 /* In the following functions we dispatch to the real-arg funcs like log()
9816 when we know the arg is real, instead of just handing everything to
9817 clog() for instance. This is in case clog() doesn't optimize for a
9818 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9819 well use it to go straight to the applicable C func. */
9821 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9823 "Return the natural logarithm of @var{z}.")
9824 #define FUNC_NAME s_scm_log
9826 if (SCM_COMPLEXP (z
))
9828 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9829 && defined (SCM_COMPLEX_VALUE)
9830 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9832 double re
= SCM_COMPLEX_REAL (z
);
9833 double im
= SCM_COMPLEX_IMAG (z
);
9834 return scm_c_make_rectangular (log (hypot (re
, im
)),
9838 else if (SCM_REALP (z
))
9839 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9840 else if (SCM_I_INUMP (z
))
9842 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9843 if (scm_is_eq (z
, SCM_INUM0
))
9844 scm_num_overflow (s_scm_log
);
9846 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9848 else if (SCM_BIGP (z
))
9849 return log_of_exact_integer (z
);
9850 else if (SCM_FRACTIONP (z
))
9851 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9852 SCM_FRACTION_DENOMINATOR (z
));
9854 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9859 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9861 "Return the base 10 logarithm of @var{z}.")
9862 #define FUNC_NAME s_scm_log10
9864 if (SCM_COMPLEXP (z
))
9866 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9867 clog() and a multiply by M_LOG10E, rather than the fallback
9868 log10+hypot+atan2.) */
9869 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9870 && defined SCM_COMPLEX_VALUE
9871 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9873 double re
= SCM_COMPLEX_REAL (z
);
9874 double im
= SCM_COMPLEX_IMAG (z
);
9875 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9876 M_LOG10E
* atan2 (im
, re
));
9879 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9881 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9882 if (scm_is_eq (z
, SCM_INUM0
))
9883 scm_num_overflow (s_scm_log10
);
9886 double re
= scm_to_double (z
);
9887 double l
= log10 (fabs (re
));
9888 if (re
> 0.0 || double_is_non_negative_zero (re
))
9889 return scm_from_double (l
);
9891 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9894 else if (SCM_BIGP (z
))
9895 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9896 else if (SCM_FRACTIONP (z
))
9897 return scm_product (flo_log10e
,
9898 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9899 SCM_FRACTION_DENOMINATOR (z
)));
9901 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9906 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9908 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9909 "base of natural logarithms (2.71828@dots{}).")
9910 #define FUNC_NAME s_scm_exp
9912 if (SCM_COMPLEXP (z
))
9914 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9915 && defined (SCM_COMPLEX_VALUE)
9916 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9918 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9919 SCM_COMPLEX_IMAG (z
));
9922 else if (SCM_NUMBERP (z
))
9924 /* When z is a negative bignum the conversion to double overflows,
9925 giving -infinity, but that's ok, the exp is still 0.0. */
9926 return scm_from_double (exp (scm_to_double (z
)));
9929 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9934 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9936 "Return two exact non-negative integers @var{s} and @var{r}\n"
9937 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9938 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9939 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9942 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9944 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9948 scm_exact_integer_sqrt (k
, &s
, &r
);
9949 return scm_values (scm_list_2 (s
, r
));
9954 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9956 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9960 if (SCM_I_INUM (k
) < 0)
9961 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9962 "exact non-negative integer");
9963 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
9964 mpz_inits (ss
, rr
, NULL
);
9965 mpz_sqrtrem (ss
, rr
, kk
);
9966 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
9967 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
9968 mpz_clears (kk
, ss
, rr
, NULL
);
9970 else if (SCM_LIKELY (SCM_BIGP (k
)))
9974 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9975 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9976 "exact non-negative integer");
9979 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9980 scm_remember_upto_here_1 (k
);
9981 *sp
= scm_i_normbig (s
);
9982 *rp
= scm_i_normbig (r
);
9985 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9986 "exact non-negative integer");
9989 /* Return true iff K is a perfect square.
9990 K must be an exact integer. */
9992 exact_integer_is_perfect_square (SCM k
)
9996 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10000 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10001 result
= mpz_perfect_square_p (kk
);
10006 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10007 scm_remember_upto_here_1 (k
);
10012 /* Return the floor of the square root of K.
10013 K must be an exact integer. */
10015 exact_integer_floor_square_root (SCM k
)
10017 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10022 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10024 ss
= mpz_get_ui (kk
);
10026 return SCM_I_MAKINUM (ss
);
10032 s
= scm_i_mkbig ();
10033 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10034 scm_remember_upto_here_1 (k
);
10035 return scm_i_normbig (s
);
10040 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10042 "Return the square root of @var{z}. Of the two possible roots\n"
10043 "(positive and negative), the one with positive real part\n"
10044 "is returned, or if that's zero then a positive imaginary part.\n"
10048 "(sqrt 9.0) @result{} 3.0\n"
10049 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10050 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10051 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10053 #define FUNC_NAME s_scm_sqrt
10055 if (SCM_COMPLEXP (z
))
10057 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10058 && defined SCM_COMPLEX_VALUE
10059 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10061 double re
= SCM_COMPLEX_REAL (z
);
10062 double im
= SCM_COMPLEX_IMAG (z
);
10063 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10064 0.5 * atan2 (im
, re
));
10067 else if (SCM_NUMBERP (z
))
10069 if (SCM_I_INUMP (z
))
10071 scm_t_inum x
= SCM_I_INUM (z
);
10073 if (SCM_LIKELY (x
>= 0))
10075 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10076 || x
< (1L << (DBL_MANT_DIG
- 1))))
10078 double root
= sqrt (x
);
10080 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10081 integer, then the result is exact. */
10082 if (root
== floor (root
))
10083 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10085 return scm_from_double (root
);
10092 mpz_init_set_ui (xx
, x
);
10093 if (mpz_perfect_square_p (xx
))
10096 root
= mpz_get_ui (xx
);
10098 return SCM_I_MAKINUM (root
);
10105 else if (SCM_BIGP (z
))
10107 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10109 SCM root
= scm_i_mkbig ();
10111 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10112 scm_remember_upto_here_1 (z
);
10113 return scm_i_normbig (root
);
10118 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10126 return scm_c_make_rectangular
10127 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10129 return scm_from_double (ldexp (sqrt (signif
), expon
/ 2));
10132 else if (SCM_FRACTIONP (z
))
10134 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10135 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10137 if (exact_integer_is_perfect_square (n
)
10138 && exact_integer_is_perfect_square (d
))
10139 return scm_i_make_ratio_already_reduced
10140 (exact_integer_floor_square_root (n
),
10141 exact_integer_floor_square_root (d
));
10144 double xx
= scm_i_divide2double (n
, d
);
10145 double abs_xx
= fabs (xx
);
10148 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10150 shift
= (scm_to_long (scm_integer_length (n
))
10151 - scm_to_long (scm_integer_length (d
))) / 2;
10153 d
= left_shift_exact_integer (d
, 2 * shift
);
10155 n
= left_shift_exact_integer (n
, -2 * shift
);
10156 xx
= scm_i_divide2double (n
, d
);
10160 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10162 return scm_from_double (ldexp (sqrt (xx
), shift
));
10166 /* Fallback method, when the cases above do not apply. */
10168 double xx
= scm_to_double (z
);
10170 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10172 return scm_from_double (sqrt (xx
));
10176 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10183 scm_init_numbers ()
10185 if (scm_install_gmp_memory_functions
)
10186 mp_set_memory_functions (custom_gmp_malloc
,
10187 custom_gmp_realloc
,
10190 mpz_init_set_si (z_negative_one
, -1);
10192 /* It may be possible to tune the performance of some algorithms by using
10193 * the following constants to avoid the creation of bignums. Please, before
10194 * using these values, remember the two rules of program optimization:
10195 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10196 scm_c_define ("most-positive-fixnum",
10197 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10198 scm_c_define ("most-negative-fixnum",
10199 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10201 scm_add_feature ("complex");
10202 scm_add_feature ("inexact");
10203 flo0
= scm_from_double (0.0);
10204 flo_log10e
= scm_from_double (M_LOG10E
);
10206 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10209 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10210 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10211 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10212 scm_i_divide2double_lo2b
,
10213 DBL_MANT_DIG
+ 1); /* 2 b^p */
10214 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10218 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10219 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10220 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10221 dbl_minimum_normal_mantissa
,
10225 #include "libguile/numbers.x"
10230 c-file-style: "gnu"