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))
104 #if ! HAVE_DECL_MPZ_INITS
106 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
108 #define VARARG_MPZ_ITERATOR(func) \
110 func ## s (mpz_t x, ...) \
118 x = va_arg (ap, mpz_ptr); \
123 VARARG_MPZ_ITERATOR (mpz_init
)
124 VARARG_MPZ_ITERATOR (mpz_clear
)
131 Wonder if this might be faster for some of our code? A switch on
132 the numtag would jump directly to the right case, and the
133 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
135 #define SCM_I_NUMTAG_NOTNUM 0
136 #define SCM_I_NUMTAG_INUM 1
137 #define SCM_I_NUMTAG_BIG scm_tc16_big
138 #define SCM_I_NUMTAG_REAL scm_tc16_real
139 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
140 #define SCM_I_NUMTAG(x) \
141 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
142 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
143 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
144 : SCM_I_NUMTAG_NOTNUM)))
146 /* the macro above will not work as is with fractions */
149 /* Default to 1, because as we used to hard-code `free' as the
150 deallocator, we know that overriding these functions with
151 instrumented `malloc' / `free' is OK. */
152 int scm_install_gmp_memory_functions
= 1;
154 static SCM exactly_one_half
;
155 static SCM flo_log10e
;
157 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
159 /* FLOBUFLEN is the maximum number of characters neccessary for the
160 * printed or scm_string representation of an inexact number.
162 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
165 #if !defined (HAVE_ASINH)
166 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
168 #if !defined (HAVE_ACOSH)
169 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
171 #if !defined (HAVE_ATANH)
172 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
175 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
176 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
177 in March 2006), mpz_cmp_d now handles infinities properly. */
179 #define xmpz_cmp_d(z, d) \
180 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
182 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
186 #if defined (GUILE_I)
187 #if defined HAVE_COMPLEX_DOUBLE
189 /* For an SCM object Z which is a complex number (ie. satisfies
190 SCM_COMPLEXP), return its value as a C level "complex double". */
191 #define SCM_COMPLEX_VALUE(z) \
192 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
194 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
196 /* Convert a C "complex double" to an SCM value. */
198 scm_from_complex_double (complex double z
)
200 return scm_c_make_rectangular (creal (z
), cimag (z
));
203 #endif /* HAVE_COMPLEX_DOUBLE */
208 static mpz_t z_negative_one
;
212 /* Clear the `mpz_t' embedded in bignum PTR. */
214 finalize_bignum (void *ptr
, void *data
)
218 bignum
= PTR2SCM (ptr
);
219 mpz_clear (SCM_I_BIG_MPZ (bignum
));
222 /* The next three functions (custom_libgmp_*) are passed to
223 mp_set_memory_functions (in GMP) so that memory used by the digits
224 themselves is known to the garbage collector. This is needed so
225 that GC will be run at appropriate times. Otherwise, a program which
226 creates many large bignums would malloc a huge amount of memory
227 before the GC runs. */
229 custom_gmp_malloc (size_t alloc_size
)
231 return scm_malloc (alloc_size
);
235 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
237 return scm_realloc (old_ptr
, new_size
);
241 custom_gmp_free (void *ptr
, size_t size
)
247 /* Return a new uninitialized bignum. */
253 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
254 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
258 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
267 /* Return a newly created bignum. */
268 SCM z
= make_bignum ();
269 mpz_init (SCM_I_BIG_MPZ (z
));
274 scm_i_inum2big (scm_t_inum x
)
276 /* Return a newly created bignum initialized to X. */
277 SCM z
= make_bignum ();
278 #if SIZEOF_VOID_P == SIZEOF_LONG
279 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
281 /* Note that in this case, you'll also have to check all mpz_*_ui and
282 mpz_*_si invocations in Guile. */
283 #error creation of mpz not implemented for this inum size
289 scm_i_long2big (long x
)
291 /* Return a newly created bignum initialized to X. */
292 SCM z
= make_bignum ();
293 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
298 scm_i_ulong2big (unsigned long x
)
300 /* Return a newly created bignum initialized to X. */
301 SCM z
= make_bignum ();
302 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
307 scm_i_clonebig (SCM src_big
, int same_sign_p
)
309 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
310 SCM z
= make_bignum ();
311 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
313 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
318 scm_i_bigcmp (SCM x
, SCM y
)
320 /* Return neg if x < y, pos if x > y, and 0 if x == y */
321 /* presume we already know x and y are bignums */
322 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
323 scm_remember_upto_here_2 (x
, y
);
328 scm_i_dbl2big (double d
)
330 /* results are only defined if d is an integer */
331 SCM z
= make_bignum ();
332 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
336 /* Convert a integer in double representation to a SCM number. */
339 scm_i_dbl2num (double u
)
341 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
342 powers of 2, so there's no rounding when making "double" values
343 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
344 get rounded on a 64-bit machine, hence the "+1".
346 The use of floor() to force to an integer value ensures we get a
347 "numerically closest" value without depending on how a
348 double->long cast or how mpz_set_d will round. For reference,
349 double->long probably follows the hardware rounding mode,
350 mpz_set_d truncates towards zero. */
352 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
353 representable as a double? */
355 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
356 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
357 return SCM_I_MAKINUM ((scm_t_inum
) u
);
359 return scm_i_dbl2big (u
);
362 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
364 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
365 bignum b into a normalized significand and exponent such that
366 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
367 The return value is the significand rounded to the closest
368 representable double, and the exponent is placed into *expon_p.
369 If b is zero, then the returned exponent and significand are both
373 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
375 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
378 if (bits
> DBL_MANT_DIG
)
380 shift
= bits
- DBL_MANT_DIG
;
381 b
= round_right_shift_exact_integer (b
, shift
);
385 double signif
= frexp (SCM_I_INUM (b
), &expon
);
386 *expon_p
= expon
+ shift
;
393 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
394 scm_remember_upto_here_1 (b
);
395 *expon_p
= expon
+ shift
;
400 /* scm_i_big2dbl() rounds to the closest representable double,
401 in accordance with R5RS exact->inexact. */
403 scm_i_big2dbl (SCM b
)
406 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
407 return ldexp (signif
, expon
);
411 scm_i_normbig (SCM b
)
413 /* convert a big back to a fixnum if it'll fit */
414 /* presume b is a bignum */
415 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
417 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
418 if (SCM_FIXABLE (val
))
419 b
= SCM_I_MAKINUM (val
);
424 static SCM_C_INLINE_KEYWORD SCM
425 scm_i_mpz2num (mpz_t b
)
427 /* convert a mpz number to a SCM number. */
428 if (mpz_fits_slong_p (b
))
430 scm_t_inum val
= mpz_get_si (b
);
431 if (SCM_FIXABLE (val
))
432 return SCM_I_MAKINUM (val
);
436 SCM z
= make_bignum ();
437 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
442 /* Make the ratio NUMERATOR/DENOMINATOR, where:
443 1. NUMERATOR and DENOMINATOR are exact integers
444 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
446 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
448 /* Flip signs so that the denominator is positive. */
449 if (scm_is_false (scm_positive_p (denominator
)))
451 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
452 scm_num_overflow ("make-ratio");
455 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
456 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
460 /* Check for the integer case */
461 if (scm_is_eq (denominator
, SCM_INUM1
))
464 return scm_double_cell (scm_tc16_fraction
,
465 SCM_UNPACK (numerator
),
466 SCM_UNPACK (denominator
), 0);
469 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
471 /* Make the ratio NUMERATOR/DENOMINATOR */
473 scm_i_make_ratio (SCM numerator
, SCM denominator
)
474 #define FUNC_NAME "make-ratio"
476 /* Make sure the arguments are proper */
477 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
478 SCM_WRONG_TYPE_ARG (1, numerator
);
479 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
480 SCM_WRONG_TYPE_ARG (2, denominator
);
483 SCM the_gcd
= scm_gcd (numerator
, denominator
);
484 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
486 /* Reduce to lowest terms */
487 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
488 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
490 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
495 static mpz_t scm_i_divide2double_lo2b
;
497 /* Return the double that is closest to the exact rational N/D, with
498 ties rounded toward even mantissas. N and D must be exact
501 scm_i_divide2double (SCM n
, SCM d
)
504 mpz_t nn
, dd
, lo
, hi
, x
;
507 if (SCM_LIKELY (SCM_I_INUMP (d
)))
509 if (SCM_LIKELY (SCM_I_INUMP (n
)
510 && (SCM_I_FIXNUM_BIT
-1 <= DBL_MANT_DIG
511 || (SCM_I_INUM (n
) < (1L << DBL_MANT_DIG
)
512 && SCM_I_INUM (d
) < (1L << DBL_MANT_DIG
)))))
513 /* If both N and D can be losslessly converted to doubles, then
514 we can rely on IEEE floating point to do proper rounding much
515 faster than we can. */
516 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
518 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
520 if (scm_is_true (scm_positive_p (n
)))
522 else if (scm_is_true (scm_negative_p (n
)))
528 mpz_init_set_si (dd
, SCM_I_INUM (d
));
531 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
534 mpz_init_set_si (nn
, SCM_I_INUM (n
));
536 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
538 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
542 /* Now we need to find the value of e such that:
545 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
546 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
547 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
550 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
551 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
552 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
554 where: p = DBL_MANT_DIG
555 b = FLT_RADIX (here assumed to be 2)
557 After rounding, the mantissa must be an integer between b^{p-1} and
558 (b^p - 1), except for subnormal numbers. In the inequations [1A]
559 and [1B], the middle expression represents the mantissa *before*
560 rounding, and therefore is bounded by the range of values that will
561 round to a floating-point number with the exponent e. The upper
562 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
563 ties will round up to the next power of b. The lower bound is
564 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
565 this power of b. Here we subtract 1/2b instead of 1/2 because it
566 is in the range of the next smaller exponent, where the
567 representable numbers are closer together by a factor of b.
569 Inequations [2A] and [2B] are derived from [1A] and [1B] by
570 multiplying by 2b, and in [3A] and [3B] we multiply by the
571 denominator of the middle value to obtain integer expressions.
573 In the code below, we refer to the three expressions in [3A] or
574 [3B] as lo, x, and hi. If the number is normalizable, we will
575 achieve the goal: lo <= x < hi */
577 /* Make an initial guess for e */
578 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
579 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
580 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
582 /* Compute the initial values of lo, x, and hi
583 based on the initial guess of e */
584 mpz_inits (lo
, hi
, x
, NULL
);
585 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
586 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
588 mpz_mul_2exp (lo
, lo
, e
);
589 mpz_mul_2exp (hi
, lo
, 1);
591 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
592 (but without making e less then the minimum exponent) */
593 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
595 mpz_mul_2exp (x
, x
, 1);
598 while (mpz_cmp (x
, hi
) >= 0)
600 /* If we ever used lo's value again,
601 we would need to double lo here. */
602 mpz_mul_2exp (hi
, hi
, 1);
606 /* Now compute the rounded mantissa:
607 n / b^e d (if e >= 0)
608 n b^-e / d (if e <= 0) */
614 mpz_mul_2exp (nn
, nn
, -e
);
616 mpz_mul_2exp (dd
, dd
, e
);
618 /* mpz does not directly support rounded right
619 shifts, so we have to do it the hard way.
620 For efficiency, we reuse lo and hi.
621 hi == quotient, lo == remainder */
622 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
624 /* The fractional part of the unrounded mantissa would be
625 remainder/dividend, i.e. lo/dd. So we have a tie if
626 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
627 integer expression 2*lo = dd. Here we do that comparison
628 to decide whether to round up or down. */
629 mpz_mul_2exp (lo
, lo
, 1);
630 cmp
= mpz_cmp (lo
, dd
);
631 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
632 mpz_add_ui (hi
, hi
, 1);
634 result
= ldexp (mpz_get_d (hi
), e
);
638 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
644 scm_i_fraction2double (SCM z
)
646 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
647 SCM_FRACTION_DENOMINATOR (z
));
651 double_is_non_negative_zero (double x
)
653 static double zero
= 0.0;
655 return !memcmp (&x
, &zero
, sizeof(double));
658 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
660 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
662 #define FUNC_NAME s_scm_exact_p
664 if (SCM_INEXACTP (x
))
666 else if (SCM_NUMBERP (x
))
669 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
674 scm_is_exact (SCM val
)
676 return scm_is_true (scm_exact_p (val
));
679 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
681 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
683 #define FUNC_NAME s_scm_inexact_p
685 if (SCM_INEXACTP (x
))
687 else if (SCM_NUMBERP (x
))
690 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
695 scm_is_inexact (SCM val
)
697 return scm_is_true (scm_inexact_p (val
));
700 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
702 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
704 #define FUNC_NAME s_scm_odd_p
708 scm_t_inum val
= SCM_I_INUM (n
);
709 return scm_from_bool ((val
& 1L) != 0);
711 else if (SCM_BIGP (n
))
713 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
714 scm_remember_upto_here_1 (n
);
715 return scm_from_bool (odd_p
);
717 else if (SCM_REALP (n
))
719 double val
= SCM_REAL_VALUE (n
);
720 if (DOUBLE_IS_FINITE (val
))
722 double rem
= fabs (fmod (val
, 2.0));
729 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
734 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
736 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
738 #define FUNC_NAME s_scm_even_p
742 scm_t_inum val
= SCM_I_INUM (n
);
743 return scm_from_bool ((val
& 1L) == 0);
745 else if (SCM_BIGP (n
))
747 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
748 scm_remember_upto_here_1 (n
);
749 return scm_from_bool (even_p
);
751 else if (SCM_REALP (n
))
753 double val
= SCM_REAL_VALUE (n
);
754 if (DOUBLE_IS_FINITE (val
))
756 double rem
= fabs (fmod (val
, 2.0));
763 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
767 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
769 "Return @code{#t} if the real number @var{x} is neither\n"
770 "infinite nor a NaN, @code{#f} otherwise.")
771 #define FUNC_NAME s_scm_finite_p
774 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
775 else if (scm_is_real (x
))
778 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
782 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
784 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
785 "@samp{-inf.0}. Otherwise return @code{#f}.")
786 #define FUNC_NAME s_scm_inf_p
789 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
790 else if (scm_is_real (x
))
793 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
797 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
799 "Return @code{#t} if the real number @var{x} is a NaN,\n"
800 "or @code{#f} otherwise.")
801 #define FUNC_NAME s_scm_nan_p
804 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
805 else if (scm_is_real (x
))
808 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
812 /* Guile's idea of infinity. */
813 static double guile_Inf
;
815 /* Guile's idea of not a number. */
816 static double guile_NaN
;
819 guile_ieee_init (void)
821 /* Some version of gcc on some old version of Linux used to crash when
822 trying to make Inf and NaN. */
825 /* C99 INFINITY, when available.
826 FIXME: The standard allows for INFINITY to be something that overflows
827 at compile time. We ought to have a configure test to check for that
828 before trying to use it. (But in practice we believe this is not a
829 problem on any system guile is likely to target.) */
830 guile_Inf
= INFINITY
;
831 #elif defined HAVE_DINFINITY
833 extern unsigned int DINFINITY
[2];
834 guile_Inf
= (*((double *) (DINFINITY
)));
841 if (guile_Inf
== tmp
)
848 /* C99 NAN, when available */
850 #elif defined HAVE_DQNAN
853 extern unsigned int DQNAN
[2];
854 guile_NaN
= (*((double *)(DQNAN
)));
857 guile_NaN
= guile_Inf
/ guile_Inf
;
861 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
864 #define FUNC_NAME s_scm_inf
866 static int initialized
= 0;
872 return scm_from_double (guile_Inf
);
876 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
879 #define FUNC_NAME s_scm_nan
881 static int initialized
= 0;
887 return scm_from_double (guile_NaN
);
892 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
894 "Return the absolute value of @var{x}.")
895 #define FUNC_NAME s_scm_abs
899 scm_t_inum xx
= SCM_I_INUM (x
);
902 else if (SCM_POSFIXABLE (-xx
))
903 return SCM_I_MAKINUM (-xx
);
905 return scm_i_inum2big (-xx
);
907 else if (SCM_LIKELY (SCM_REALP (x
)))
909 double xx
= SCM_REAL_VALUE (x
);
910 /* If x is a NaN then xx<0 is false so we return x unchanged */
912 return scm_from_double (-xx
);
913 /* Handle signed zeroes properly */
914 else if (SCM_UNLIKELY (xx
== 0.0))
919 else if (SCM_BIGP (x
))
921 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
923 return scm_i_clonebig (x
, 0);
927 else if (SCM_FRACTIONP (x
))
929 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
931 return scm_i_make_ratio_already_reduced
932 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
933 SCM_FRACTION_DENOMINATOR (x
));
936 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
941 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
943 "Return the quotient of the numbers @var{x} and @var{y}.")
944 #define FUNC_NAME s_scm_quotient
946 if (SCM_LIKELY (scm_is_integer (x
)))
948 if (SCM_LIKELY (scm_is_integer (y
)))
949 return scm_truncate_quotient (x
, y
);
951 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
954 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
958 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
960 "Return the remainder of the numbers @var{x} and @var{y}.\n"
962 "(remainder 13 4) @result{} 1\n"
963 "(remainder -13 4) @result{} -1\n"
965 #define FUNC_NAME s_scm_remainder
967 if (SCM_LIKELY (scm_is_integer (x
)))
969 if (SCM_LIKELY (scm_is_integer (y
)))
970 return scm_truncate_remainder (x
, y
);
972 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
975 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
980 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
982 "Return the modulo of the numbers @var{x} and @var{y}.\n"
984 "(modulo 13 4) @result{} 1\n"
985 "(modulo -13 4) @result{} 3\n"
987 #define FUNC_NAME s_scm_modulo
989 if (SCM_LIKELY (scm_is_integer (x
)))
991 if (SCM_LIKELY (scm_is_integer (y
)))
992 return scm_floor_remainder (x
, y
);
994 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
997 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1001 /* Return the exact integer q such that n = q*d, for exact integers n
1002 and d, where d is known in advance to divide n evenly (with zero
1003 remainder). For large integers, this can be computed more
1004 efficiently than when the remainder is unknown. */
1006 scm_exact_integer_quotient (SCM n
, SCM d
)
1007 #define FUNC_NAME "exact-integer-quotient"
1009 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1011 scm_t_inum nn
= SCM_I_INUM (n
);
1012 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1014 scm_t_inum dd
= SCM_I_INUM (d
);
1015 if (SCM_UNLIKELY (dd
== 0))
1016 scm_num_overflow ("exact-integer-quotient");
1019 scm_t_inum qq
= nn
/ dd
;
1020 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1021 return SCM_I_MAKINUM (qq
);
1023 return scm_i_inum2big (qq
);
1026 else if (SCM_LIKELY (SCM_BIGP (d
)))
1028 /* n is an inum and d is a bignum. Given that d is known to
1029 divide n evenly, there are only two possibilities: n is 0,
1030 or else n is fixnum-min and d is abs(fixnum-min). */
1034 return SCM_I_MAKINUM (-1);
1037 SCM_WRONG_TYPE_ARG (2, d
);
1039 else if (SCM_LIKELY (SCM_BIGP (n
)))
1041 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1043 scm_t_inum dd
= SCM_I_INUM (d
);
1044 if (SCM_UNLIKELY (dd
== 0))
1045 scm_num_overflow ("exact-integer-quotient");
1046 else if (SCM_UNLIKELY (dd
== 1))
1050 SCM q
= scm_i_mkbig ();
1052 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1055 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1056 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1058 scm_remember_upto_here_1 (n
);
1059 return scm_i_normbig (q
);
1062 else if (SCM_LIKELY (SCM_BIGP (d
)))
1064 SCM q
= scm_i_mkbig ();
1065 mpz_divexact (SCM_I_BIG_MPZ (q
),
1068 scm_remember_upto_here_2 (n
, d
);
1069 return scm_i_normbig (q
);
1072 SCM_WRONG_TYPE_ARG (2, d
);
1075 SCM_WRONG_TYPE_ARG (1, n
);
1079 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1080 two-valued functions. It is called from primitive generics that take
1081 two arguments and return two values, when the core procedure is
1082 unable to handle the given argument types. If there are GOOPS
1083 methods for this primitive generic, it dispatches to GOOPS and, if
1084 successful, expects two values to be returned, which are placed in
1085 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1086 wrong-type-arg exception.
1088 FIXME: This obviously belongs somewhere else, but until we decide on
1089 the right API, it is here as a static function, because it is needed
1090 by the *_divide functions below.
1093 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1094 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1096 if (SCM_UNPACK (gf
))
1097 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
1099 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1102 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1104 "Return the integer @var{q} such that\n"
1105 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1106 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1108 "(euclidean-quotient 123 10) @result{} 12\n"
1109 "(euclidean-quotient 123 -10) @result{} -12\n"
1110 "(euclidean-quotient -123 10) @result{} -13\n"
1111 "(euclidean-quotient -123 -10) @result{} 13\n"
1112 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1113 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1115 #define FUNC_NAME s_scm_euclidean_quotient
1117 if (scm_is_false (scm_negative_p (y
)))
1118 return scm_floor_quotient (x
, y
);
1120 return scm_ceiling_quotient (x
, y
);
1124 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1126 "Return the real number @var{r} such that\n"
1127 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1128 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1129 "for some integer @var{q}.\n"
1131 "(euclidean-remainder 123 10) @result{} 3\n"
1132 "(euclidean-remainder 123 -10) @result{} 3\n"
1133 "(euclidean-remainder -123 10) @result{} 7\n"
1134 "(euclidean-remainder -123 -10) @result{} 7\n"
1135 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1136 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1138 #define FUNC_NAME s_scm_euclidean_remainder
1140 if (scm_is_false (scm_negative_p (y
)))
1141 return scm_floor_remainder (x
, y
);
1143 return scm_ceiling_remainder (x
, y
);
1147 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1149 "Return the integer @var{q} and the real number @var{r}\n"
1150 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1151 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1153 "(euclidean/ 123 10) @result{} 12 and 3\n"
1154 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1155 "(euclidean/ -123 10) @result{} -13 and 7\n"
1156 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1157 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1158 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1160 #define FUNC_NAME s_scm_i_euclidean_divide
1162 if (scm_is_false (scm_negative_p (y
)))
1163 return scm_i_floor_divide (x
, y
);
1165 return scm_i_ceiling_divide (x
, y
);
1170 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1172 if (scm_is_false (scm_negative_p (y
)))
1173 return scm_floor_divide (x
, y
, qp
, rp
);
1175 return scm_ceiling_divide (x
, y
, qp
, rp
);
1178 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1179 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1181 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1183 "Return the floor of @math{@var{x} / @var{y}}.\n"
1185 "(floor-quotient 123 10) @result{} 12\n"
1186 "(floor-quotient 123 -10) @result{} -13\n"
1187 "(floor-quotient -123 10) @result{} -13\n"
1188 "(floor-quotient -123 -10) @result{} 12\n"
1189 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1190 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1192 #define FUNC_NAME s_scm_floor_quotient
1194 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1196 scm_t_inum xx
= SCM_I_INUM (x
);
1197 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1199 scm_t_inum yy
= SCM_I_INUM (y
);
1200 scm_t_inum xx1
= xx
;
1202 if (SCM_LIKELY (yy
> 0))
1204 if (SCM_UNLIKELY (xx
< 0))
1207 else if (SCM_UNLIKELY (yy
== 0))
1208 scm_num_overflow (s_scm_floor_quotient
);
1212 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1213 return SCM_I_MAKINUM (qq
);
1215 return scm_i_inum2big (qq
);
1217 else if (SCM_BIGP (y
))
1219 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1220 scm_remember_upto_here_1 (y
);
1222 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1224 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1226 else if (SCM_REALP (y
))
1227 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1228 else if (SCM_FRACTIONP (y
))
1229 return scm_i_exact_rational_floor_quotient (x
, y
);
1231 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1232 s_scm_floor_quotient
);
1234 else if (SCM_BIGP (x
))
1236 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1238 scm_t_inum yy
= SCM_I_INUM (y
);
1239 if (SCM_UNLIKELY (yy
== 0))
1240 scm_num_overflow (s_scm_floor_quotient
);
1241 else if (SCM_UNLIKELY (yy
== 1))
1245 SCM q
= scm_i_mkbig ();
1247 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1250 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1251 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1253 scm_remember_upto_here_1 (x
);
1254 return scm_i_normbig (q
);
1257 else if (SCM_BIGP (y
))
1259 SCM q
= scm_i_mkbig ();
1260 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1263 scm_remember_upto_here_2 (x
, y
);
1264 return scm_i_normbig (q
);
1266 else if (SCM_REALP (y
))
1267 return scm_i_inexact_floor_quotient
1268 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1269 else if (SCM_FRACTIONP (y
))
1270 return scm_i_exact_rational_floor_quotient (x
, y
);
1272 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1273 s_scm_floor_quotient
);
1275 else if (SCM_REALP (x
))
1277 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1278 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1279 return scm_i_inexact_floor_quotient
1280 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1282 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1283 s_scm_floor_quotient
);
1285 else if (SCM_FRACTIONP (x
))
1288 return scm_i_inexact_floor_quotient
1289 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1290 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1291 return scm_i_exact_rational_floor_quotient (x
, y
);
1293 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1294 s_scm_floor_quotient
);
1297 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1298 s_scm_floor_quotient
);
1303 scm_i_inexact_floor_quotient (double x
, double y
)
1305 if (SCM_UNLIKELY (y
== 0))
1306 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1308 return scm_from_double (floor (x
/ y
));
1312 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1314 return scm_floor_quotient
1315 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1316 scm_product (scm_numerator (y
), scm_denominator (x
)));
1319 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1320 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1322 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1324 "Return the real number @var{r} such that\n"
1325 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1326 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1328 "(floor-remainder 123 10) @result{} 3\n"
1329 "(floor-remainder 123 -10) @result{} -7\n"
1330 "(floor-remainder -123 10) @result{} 7\n"
1331 "(floor-remainder -123 -10) @result{} -3\n"
1332 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1333 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1335 #define FUNC_NAME s_scm_floor_remainder
1337 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1339 scm_t_inum xx
= SCM_I_INUM (x
);
1340 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1342 scm_t_inum yy
= SCM_I_INUM (y
);
1343 if (SCM_UNLIKELY (yy
== 0))
1344 scm_num_overflow (s_scm_floor_remainder
);
1347 scm_t_inum rr
= xx
% yy
;
1348 int needs_adjustment
;
1350 if (SCM_LIKELY (yy
> 0))
1351 needs_adjustment
= (rr
< 0);
1353 needs_adjustment
= (rr
> 0);
1355 if (needs_adjustment
)
1357 return SCM_I_MAKINUM (rr
);
1360 else if (SCM_BIGP (y
))
1362 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1363 scm_remember_upto_here_1 (y
);
1368 SCM r
= scm_i_mkbig ();
1369 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1370 scm_remember_upto_here_1 (y
);
1371 return scm_i_normbig (r
);
1380 SCM r
= scm_i_mkbig ();
1381 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1382 scm_remember_upto_here_1 (y
);
1383 return scm_i_normbig (r
);
1386 else if (SCM_REALP (y
))
1387 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1388 else if (SCM_FRACTIONP (y
))
1389 return scm_i_exact_rational_floor_remainder (x
, y
);
1391 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1392 s_scm_floor_remainder
);
1394 else if (SCM_BIGP (x
))
1396 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1398 scm_t_inum yy
= SCM_I_INUM (y
);
1399 if (SCM_UNLIKELY (yy
== 0))
1400 scm_num_overflow (s_scm_floor_remainder
);
1405 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1407 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1408 scm_remember_upto_here_1 (x
);
1409 return SCM_I_MAKINUM (rr
);
1412 else if (SCM_BIGP (y
))
1414 SCM r
= scm_i_mkbig ();
1415 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1418 scm_remember_upto_here_2 (x
, y
);
1419 return scm_i_normbig (r
);
1421 else if (SCM_REALP (y
))
1422 return scm_i_inexact_floor_remainder
1423 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1424 else if (SCM_FRACTIONP (y
))
1425 return scm_i_exact_rational_floor_remainder (x
, y
);
1427 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1428 s_scm_floor_remainder
);
1430 else if (SCM_REALP (x
))
1432 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1433 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1434 return scm_i_inexact_floor_remainder
1435 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1437 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1438 s_scm_floor_remainder
);
1440 else if (SCM_FRACTIONP (x
))
1443 return scm_i_inexact_floor_remainder
1444 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1445 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1446 return scm_i_exact_rational_floor_remainder (x
, y
);
1448 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1449 s_scm_floor_remainder
);
1452 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1453 s_scm_floor_remainder
);
1458 scm_i_inexact_floor_remainder (double x
, double y
)
1460 /* Although it would be more efficient to use fmod here, we can't
1461 because it would in some cases produce results inconsistent with
1462 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1463 close). In particular, when x is very close to a multiple of y,
1464 then r might be either 0.0 or y, but those two cases must
1465 correspond to different choices of q. If r = 0.0 then q must be
1466 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1467 and remainder chooses the other, it would be bad. */
1468 if (SCM_UNLIKELY (y
== 0))
1469 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1471 return scm_from_double (x
- y
* floor (x
/ y
));
1475 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1477 SCM xd
= scm_denominator (x
);
1478 SCM yd
= scm_denominator (y
);
1479 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1480 scm_product (scm_numerator (y
), xd
));
1481 return scm_divide (r1
, scm_product (xd
, yd
));
1485 static void scm_i_inexact_floor_divide (double x
, double y
,
1487 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1490 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1492 "Return the integer @var{q} and the real number @var{r}\n"
1493 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1494 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1496 "(floor/ 123 10) @result{} 12 and 3\n"
1497 "(floor/ 123 -10) @result{} -13 and -7\n"
1498 "(floor/ -123 10) @result{} -13 and 7\n"
1499 "(floor/ -123 -10) @result{} 12 and -3\n"
1500 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1501 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1503 #define FUNC_NAME s_scm_i_floor_divide
1507 scm_floor_divide(x
, y
, &q
, &r
);
1508 return scm_values (scm_list_2 (q
, r
));
1512 #define s_scm_floor_divide s_scm_i_floor_divide
1513 #define g_scm_floor_divide g_scm_i_floor_divide
1516 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1518 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1520 scm_t_inum xx
= SCM_I_INUM (x
);
1521 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1523 scm_t_inum yy
= SCM_I_INUM (y
);
1524 if (SCM_UNLIKELY (yy
== 0))
1525 scm_num_overflow (s_scm_floor_divide
);
1528 scm_t_inum qq
= xx
/ yy
;
1529 scm_t_inum rr
= xx
% yy
;
1530 int needs_adjustment
;
1532 if (SCM_LIKELY (yy
> 0))
1533 needs_adjustment
= (rr
< 0);
1535 needs_adjustment
= (rr
> 0);
1537 if (needs_adjustment
)
1543 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1544 *qp
= SCM_I_MAKINUM (qq
);
1546 *qp
= scm_i_inum2big (qq
);
1547 *rp
= SCM_I_MAKINUM (rr
);
1551 else if (SCM_BIGP (y
))
1553 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1554 scm_remember_upto_here_1 (y
);
1559 SCM r
= scm_i_mkbig ();
1560 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1561 scm_remember_upto_here_1 (y
);
1562 *qp
= SCM_I_MAKINUM (-1);
1563 *rp
= scm_i_normbig (r
);
1578 SCM r
= scm_i_mkbig ();
1579 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1580 scm_remember_upto_here_1 (y
);
1581 *qp
= SCM_I_MAKINUM (-1);
1582 *rp
= scm_i_normbig (r
);
1586 else if (SCM_REALP (y
))
1587 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1588 else if (SCM_FRACTIONP (y
))
1589 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1591 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1592 s_scm_floor_divide
, qp
, rp
);
1594 else if (SCM_BIGP (x
))
1596 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1598 scm_t_inum yy
= SCM_I_INUM (y
);
1599 if (SCM_UNLIKELY (yy
== 0))
1600 scm_num_overflow (s_scm_floor_divide
);
1603 SCM q
= scm_i_mkbig ();
1604 SCM r
= scm_i_mkbig ();
1606 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1607 SCM_I_BIG_MPZ (x
), yy
);
1610 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1611 SCM_I_BIG_MPZ (x
), -yy
);
1612 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1614 scm_remember_upto_here_1 (x
);
1615 *qp
= scm_i_normbig (q
);
1616 *rp
= scm_i_normbig (r
);
1620 else if (SCM_BIGP (y
))
1622 SCM q
= scm_i_mkbig ();
1623 SCM r
= scm_i_mkbig ();
1624 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1625 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1626 scm_remember_upto_here_2 (x
, y
);
1627 *qp
= scm_i_normbig (q
);
1628 *rp
= scm_i_normbig (r
);
1631 else if (SCM_REALP (y
))
1632 return scm_i_inexact_floor_divide
1633 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1634 else if (SCM_FRACTIONP (y
))
1635 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1637 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1638 s_scm_floor_divide
, qp
, rp
);
1640 else if (SCM_REALP (x
))
1642 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1643 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1644 return scm_i_inexact_floor_divide
1645 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1647 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1648 s_scm_floor_divide
, qp
, rp
);
1650 else if (SCM_FRACTIONP (x
))
1653 return scm_i_inexact_floor_divide
1654 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1655 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1656 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1658 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1659 s_scm_floor_divide
, qp
, rp
);
1662 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1663 s_scm_floor_divide
, qp
, rp
);
1667 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1669 if (SCM_UNLIKELY (y
== 0))
1670 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1673 double q
= floor (x
/ y
);
1674 double r
= x
- q
* y
;
1675 *qp
= scm_from_double (q
);
1676 *rp
= scm_from_double (r
);
1681 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1684 SCM xd
= scm_denominator (x
);
1685 SCM yd
= scm_denominator (y
);
1687 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1688 scm_product (scm_numerator (y
), xd
),
1690 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1693 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1694 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1696 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1698 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1700 "(ceiling-quotient 123 10) @result{} 13\n"
1701 "(ceiling-quotient 123 -10) @result{} -12\n"
1702 "(ceiling-quotient -123 10) @result{} -12\n"
1703 "(ceiling-quotient -123 -10) @result{} 13\n"
1704 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1705 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1707 #define FUNC_NAME s_scm_ceiling_quotient
1709 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1711 scm_t_inum xx
= SCM_I_INUM (x
);
1712 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1714 scm_t_inum yy
= SCM_I_INUM (y
);
1715 if (SCM_UNLIKELY (yy
== 0))
1716 scm_num_overflow (s_scm_ceiling_quotient
);
1719 scm_t_inum xx1
= xx
;
1721 if (SCM_LIKELY (yy
> 0))
1723 if (SCM_LIKELY (xx
>= 0))
1729 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1730 return SCM_I_MAKINUM (qq
);
1732 return scm_i_inum2big (qq
);
1735 else if (SCM_BIGP (y
))
1737 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1738 scm_remember_upto_here_1 (y
);
1739 if (SCM_LIKELY (sign
> 0))
1741 if (SCM_LIKELY (xx
> 0))
1743 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1744 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1745 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1747 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1748 scm_remember_upto_here_1 (y
);
1749 return SCM_I_MAKINUM (-1);
1759 else if (SCM_REALP (y
))
1760 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1761 else if (SCM_FRACTIONP (y
))
1762 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1764 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1765 s_scm_ceiling_quotient
);
1767 else if (SCM_BIGP (x
))
1769 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1771 scm_t_inum yy
= SCM_I_INUM (y
);
1772 if (SCM_UNLIKELY (yy
== 0))
1773 scm_num_overflow (s_scm_ceiling_quotient
);
1774 else if (SCM_UNLIKELY (yy
== 1))
1778 SCM q
= scm_i_mkbig ();
1780 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1783 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1784 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1786 scm_remember_upto_here_1 (x
);
1787 return scm_i_normbig (q
);
1790 else if (SCM_BIGP (y
))
1792 SCM q
= scm_i_mkbig ();
1793 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1796 scm_remember_upto_here_2 (x
, y
);
1797 return scm_i_normbig (q
);
1799 else if (SCM_REALP (y
))
1800 return scm_i_inexact_ceiling_quotient
1801 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1802 else if (SCM_FRACTIONP (y
))
1803 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1805 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1806 s_scm_ceiling_quotient
);
1808 else if (SCM_REALP (x
))
1810 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1811 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1812 return scm_i_inexact_ceiling_quotient
1813 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1815 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1816 s_scm_ceiling_quotient
);
1818 else if (SCM_FRACTIONP (x
))
1821 return scm_i_inexact_ceiling_quotient
1822 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1823 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1824 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1826 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1827 s_scm_ceiling_quotient
);
1830 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1831 s_scm_ceiling_quotient
);
1836 scm_i_inexact_ceiling_quotient (double x
, double y
)
1838 if (SCM_UNLIKELY (y
== 0))
1839 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1841 return scm_from_double (ceil (x
/ y
));
1845 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1847 return scm_ceiling_quotient
1848 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1849 scm_product (scm_numerator (y
), scm_denominator (x
)));
1852 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1853 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1855 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1857 "Return the real number @var{r} such that\n"
1858 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1859 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1861 "(ceiling-remainder 123 10) @result{} -7\n"
1862 "(ceiling-remainder 123 -10) @result{} 3\n"
1863 "(ceiling-remainder -123 10) @result{} -3\n"
1864 "(ceiling-remainder -123 -10) @result{} 7\n"
1865 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1866 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1868 #define FUNC_NAME s_scm_ceiling_remainder
1870 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1872 scm_t_inum xx
= SCM_I_INUM (x
);
1873 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1875 scm_t_inum yy
= SCM_I_INUM (y
);
1876 if (SCM_UNLIKELY (yy
== 0))
1877 scm_num_overflow (s_scm_ceiling_remainder
);
1880 scm_t_inum rr
= xx
% yy
;
1881 int needs_adjustment
;
1883 if (SCM_LIKELY (yy
> 0))
1884 needs_adjustment
= (rr
> 0);
1886 needs_adjustment
= (rr
< 0);
1888 if (needs_adjustment
)
1890 return SCM_I_MAKINUM (rr
);
1893 else if (SCM_BIGP (y
))
1895 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1896 scm_remember_upto_here_1 (y
);
1897 if (SCM_LIKELY (sign
> 0))
1899 if (SCM_LIKELY (xx
> 0))
1901 SCM r
= scm_i_mkbig ();
1902 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1903 scm_remember_upto_here_1 (y
);
1904 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1905 return scm_i_normbig (r
);
1907 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1908 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1909 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1911 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1912 scm_remember_upto_here_1 (y
);
1922 SCM r
= scm_i_mkbig ();
1923 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1924 scm_remember_upto_here_1 (y
);
1925 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1926 return scm_i_normbig (r
);
1929 else if (SCM_REALP (y
))
1930 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1931 else if (SCM_FRACTIONP (y
))
1932 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1934 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1935 s_scm_ceiling_remainder
);
1937 else if (SCM_BIGP (x
))
1939 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1941 scm_t_inum yy
= SCM_I_INUM (y
);
1942 if (SCM_UNLIKELY (yy
== 0))
1943 scm_num_overflow (s_scm_ceiling_remainder
);
1948 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1950 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1951 scm_remember_upto_here_1 (x
);
1952 return SCM_I_MAKINUM (rr
);
1955 else if (SCM_BIGP (y
))
1957 SCM r
= scm_i_mkbig ();
1958 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1961 scm_remember_upto_here_2 (x
, y
);
1962 return scm_i_normbig (r
);
1964 else if (SCM_REALP (y
))
1965 return scm_i_inexact_ceiling_remainder
1966 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1967 else if (SCM_FRACTIONP (y
))
1968 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1970 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1971 s_scm_ceiling_remainder
);
1973 else if (SCM_REALP (x
))
1975 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1976 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1977 return scm_i_inexact_ceiling_remainder
1978 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1980 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1981 s_scm_ceiling_remainder
);
1983 else if (SCM_FRACTIONP (x
))
1986 return scm_i_inexact_ceiling_remainder
1987 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1988 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1989 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1991 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1992 s_scm_ceiling_remainder
);
1995 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1996 s_scm_ceiling_remainder
);
2001 scm_i_inexact_ceiling_remainder (double x
, double y
)
2003 /* Although it would be more efficient to use fmod here, we can't
2004 because it would in some cases produce results inconsistent with
2005 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2006 close). In particular, when x is very close to a multiple of y,
2007 then r might be either 0.0 or -y, but those two cases must
2008 correspond to different choices of q. If r = 0.0 then q must be
2009 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2010 and remainder chooses the other, it would be bad. */
2011 if (SCM_UNLIKELY (y
== 0))
2012 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2014 return scm_from_double (x
- y
* ceil (x
/ y
));
2018 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2020 SCM xd
= scm_denominator (x
);
2021 SCM yd
= scm_denominator (y
);
2022 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2023 scm_product (scm_numerator (y
), xd
));
2024 return scm_divide (r1
, scm_product (xd
, yd
));
2027 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2029 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2032 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2034 "Return the integer @var{q} and the real number @var{r}\n"
2035 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2036 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2038 "(ceiling/ 123 10) @result{} 13 and -7\n"
2039 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2040 "(ceiling/ -123 10) @result{} -12 and -3\n"
2041 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2042 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2043 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2045 #define FUNC_NAME s_scm_i_ceiling_divide
2049 scm_ceiling_divide(x
, y
, &q
, &r
);
2050 return scm_values (scm_list_2 (q
, r
));
2054 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2055 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2058 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2060 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2062 scm_t_inum xx
= SCM_I_INUM (x
);
2063 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2065 scm_t_inum yy
= SCM_I_INUM (y
);
2066 if (SCM_UNLIKELY (yy
== 0))
2067 scm_num_overflow (s_scm_ceiling_divide
);
2070 scm_t_inum qq
= xx
/ yy
;
2071 scm_t_inum rr
= xx
% yy
;
2072 int needs_adjustment
;
2074 if (SCM_LIKELY (yy
> 0))
2075 needs_adjustment
= (rr
> 0);
2077 needs_adjustment
= (rr
< 0);
2079 if (needs_adjustment
)
2084 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2085 *qp
= SCM_I_MAKINUM (qq
);
2087 *qp
= scm_i_inum2big (qq
);
2088 *rp
= SCM_I_MAKINUM (rr
);
2092 else if (SCM_BIGP (y
))
2094 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2095 scm_remember_upto_here_1 (y
);
2096 if (SCM_LIKELY (sign
> 0))
2098 if (SCM_LIKELY (xx
> 0))
2100 SCM r
= scm_i_mkbig ();
2101 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2102 scm_remember_upto_here_1 (y
);
2103 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2105 *rp
= scm_i_normbig (r
);
2107 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2108 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2109 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2111 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2112 scm_remember_upto_here_1 (y
);
2113 *qp
= SCM_I_MAKINUM (-1);
2129 SCM r
= scm_i_mkbig ();
2130 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2131 scm_remember_upto_here_1 (y
);
2132 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2134 *rp
= scm_i_normbig (r
);
2138 else if (SCM_REALP (y
))
2139 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2140 else if (SCM_FRACTIONP (y
))
2141 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2143 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2144 s_scm_ceiling_divide
, qp
, rp
);
2146 else if (SCM_BIGP (x
))
2148 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2150 scm_t_inum yy
= SCM_I_INUM (y
);
2151 if (SCM_UNLIKELY (yy
== 0))
2152 scm_num_overflow (s_scm_ceiling_divide
);
2155 SCM q
= scm_i_mkbig ();
2156 SCM r
= scm_i_mkbig ();
2158 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2159 SCM_I_BIG_MPZ (x
), yy
);
2162 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2163 SCM_I_BIG_MPZ (x
), -yy
);
2164 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2166 scm_remember_upto_here_1 (x
);
2167 *qp
= scm_i_normbig (q
);
2168 *rp
= scm_i_normbig (r
);
2172 else if (SCM_BIGP (y
))
2174 SCM q
= scm_i_mkbig ();
2175 SCM r
= scm_i_mkbig ();
2176 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2177 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2178 scm_remember_upto_here_2 (x
, y
);
2179 *qp
= scm_i_normbig (q
);
2180 *rp
= scm_i_normbig (r
);
2183 else if (SCM_REALP (y
))
2184 return scm_i_inexact_ceiling_divide
2185 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2186 else if (SCM_FRACTIONP (y
))
2187 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2189 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2190 s_scm_ceiling_divide
, qp
, rp
);
2192 else if (SCM_REALP (x
))
2194 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2195 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2196 return scm_i_inexact_ceiling_divide
2197 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2199 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2200 s_scm_ceiling_divide
, qp
, rp
);
2202 else if (SCM_FRACTIONP (x
))
2205 return scm_i_inexact_ceiling_divide
2206 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2207 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2208 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2210 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2211 s_scm_ceiling_divide
, qp
, rp
);
2214 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2215 s_scm_ceiling_divide
, qp
, rp
);
2219 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2221 if (SCM_UNLIKELY (y
== 0))
2222 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2225 double q
= ceil (x
/ y
);
2226 double r
= x
- q
* y
;
2227 *qp
= scm_from_double (q
);
2228 *rp
= scm_from_double (r
);
2233 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2236 SCM xd
= scm_denominator (x
);
2237 SCM yd
= scm_denominator (y
);
2239 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2240 scm_product (scm_numerator (y
), xd
),
2242 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2245 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2246 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2248 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2250 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2252 "(truncate-quotient 123 10) @result{} 12\n"
2253 "(truncate-quotient 123 -10) @result{} -12\n"
2254 "(truncate-quotient -123 10) @result{} -12\n"
2255 "(truncate-quotient -123 -10) @result{} 12\n"
2256 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2257 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2259 #define FUNC_NAME s_scm_truncate_quotient
2261 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2263 scm_t_inum xx
= SCM_I_INUM (x
);
2264 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2266 scm_t_inum yy
= SCM_I_INUM (y
);
2267 if (SCM_UNLIKELY (yy
== 0))
2268 scm_num_overflow (s_scm_truncate_quotient
);
2271 scm_t_inum qq
= xx
/ yy
;
2272 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2273 return SCM_I_MAKINUM (qq
);
2275 return scm_i_inum2big (qq
);
2278 else if (SCM_BIGP (y
))
2280 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2281 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2282 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2284 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2285 scm_remember_upto_here_1 (y
);
2286 return SCM_I_MAKINUM (-1);
2291 else if (SCM_REALP (y
))
2292 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2293 else if (SCM_FRACTIONP (y
))
2294 return scm_i_exact_rational_truncate_quotient (x
, y
);
2296 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2297 s_scm_truncate_quotient
);
2299 else if (SCM_BIGP (x
))
2301 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2303 scm_t_inum yy
= SCM_I_INUM (y
);
2304 if (SCM_UNLIKELY (yy
== 0))
2305 scm_num_overflow (s_scm_truncate_quotient
);
2306 else if (SCM_UNLIKELY (yy
== 1))
2310 SCM q
= scm_i_mkbig ();
2312 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2315 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2316 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2318 scm_remember_upto_here_1 (x
);
2319 return scm_i_normbig (q
);
2322 else if (SCM_BIGP (y
))
2324 SCM q
= scm_i_mkbig ();
2325 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2328 scm_remember_upto_here_2 (x
, y
);
2329 return scm_i_normbig (q
);
2331 else if (SCM_REALP (y
))
2332 return scm_i_inexact_truncate_quotient
2333 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2334 else if (SCM_FRACTIONP (y
))
2335 return scm_i_exact_rational_truncate_quotient (x
, y
);
2337 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2338 s_scm_truncate_quotient
);
2340 else if (SCM_REALP (x
))
2342 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2343 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2344 return scm_i_inexact_truncate_quotient
2345 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2347 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2348 s_scm_truncate_quotient
);
2350 else if (SCM_FRACTIONP (x
))
2353 return scm_i_inexact_truncate_quotient
2354 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2355 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2356 return scm_i_exact_rational_truncate_quotient (x
, y
);
2358 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2359 s_scm_truncate_quotient
);
2362 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2363 s_scm_truncate_quotient
);
2368 scm_i_inexact_truncate_quotient (double x
, double y
)
2370 if (SCM_UNLIKELY (y
== 0))
2371 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2373 return scm_from_double (trunc (x
/ y
));
2377 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2379 return scm_truncate_quotient
2380 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2381 scm_product (scm_numerator (y
), scm_denominator (x
)));
2384 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2385 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2387 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2389 "Return the real number @var{r} such that\n"
2390 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2391 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2393 "(truncate-remainder 123 10) @result{} 3\n"
2394 "(truncate-remainder 123 -10) @result{} 3\n"
2395 "(truncate-remainder -123 10) @result{} -3\n"
2396 "(truncate-remainder -123 -10) @result{} -3\n"
2397 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2398 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2400 #define FUNC_NAME s_scm_truncate_remainder
2402 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2404 scm_t_inum xx
= SCM_I_INUM (x
);
2405 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2407 scm_t_inum yy
= SCM_I_INUM (y
);
2408 if (SCM_UNLIKELY (yy
== 0))
2409 scm_num_overflow (s_scm_truncate_remainder
);
2411 return SCM_I_MAKINUM (xx
% yy
);
2413 else if (SCM_BIGP (y
))
2415 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2416 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2417 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2419 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2420 scm_remember_upto_here_1 (y
);
2426 else if (SCM_REALP (y
))
2427 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2428 else if (SCM_FRACTIONP (y
))
2429 return scm_i_exact_rational_truncate_remainder (x
, y
);
2431 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2432 s_scm_truncate_remainder
);
2434 else if (SCM_BIGP (x
))
2436 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2438 scm_t_inum yy
= SCM_I_INUM (y
);
2439 if (SCM_UNLIKELY (yy
== 0))
2440 scm_num_overflow (s_scm_truncate_remainder
);
2443 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2444 (yy
> 0) ? yy
: -yy
)
2445 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2446 scm_remember_upto_here_1 (x
);
2447 return SCM_I_MAKINUM (rr
);
2450 else if (SCM_BIGP (y
))
2452 SCM r
= scm_i_mkbig ();
2453 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2456 scm_remember_upto_here_2 (x
, y
);
2457 return scm_i_normbig (r
);
2459 else if (SCM_REALP (y
))
2460 return scm_i_inexact_truncate_remainder
2461 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2462 else if (SCM_FRACTIONP (y
))
2463 return scm_i_exact_rational_truncate_remainder (x
, y
);
2465 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2466 s_scm_truncate_remainder
);
2468 else if (SCM_REALP (x
))
2470 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2471 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2472 return scm_i_inexact_truncate_remainder
2473 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2475 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2476 s_scm_truncate_remainder
);
2478 else if (SCM_FRACTIONP (x
))
2481 return scm_i_inexact_truncate_remainder
2482 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2483 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2484 return scm_i_exact_rational_truncate_remainder (x
, y
);
2486 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2487 s_scm_truncate_remainder
);
2490 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2491 s_scm_truncate_remainder
);
2496 scm_i_inexact_truncate_remainder (double x
, double y
)
2498 /* Although it would be more efficient to use fmod here, we can't
2499 because it would in some cases produce results inconsistent with
2500 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2501 close). In particular, when x is very close to a multiple of y,
2502 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2503 correspond to different choices of q. If quotient chooses one and
2504 remainder chooses the other, it would be bad. */
2505 if (SCM_UNLIKELY (y
== 0))
2506 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2508 return scm_from_double (x
- y
* trunc (x
/ y
));
2512 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2514 SCM xd
= scm_denominator (x
);
2515 SCM yd
= scm_denominator (y
);
2516 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2517 scm_product (scm_numerator (y
), xd
));
2518 return scm_divide (r1
, scm_product (xd
, yd
));
2522 static void scm_i_inexact_truncate_divide (double x
, double y
,
2524 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2527 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2529 "Return the integer @var{q} and the real number @var{r}\n"
2530 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2531 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2533 "(truncate/ 123 10) @result{} 12 and 3\n"
2534 "(truncate/ 123 -10) @result{} -12 and 3\n"
2535 "(truncate/ -123 10) @result{} -12 and -3\n"
2536 "(truncate/ -123 -10) @result{} 12 and -3\n"
2537 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2538 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2540 #define FUNC_NAME s_scm_i_truncate_divide
2544 scm_truncate_divide(x
, y
, &q
, &r
);
2545 return scm_values (scm_list_2 (q
, r
));
2549 #define s_scm_truncate_divide s_scm_i_truncate_divide
2550 #define g_scm_truncate_divide g_scm_i_truncate_divide
2553 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2555 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2557 scm_t_inum xx
= SCM_I_INUM (x
);
2558 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2560 scm_t_inum yy
= SCM_I_INUM (y
);
2561 if (SCM_UNLIKELY (yy
== 0))
2562 scm_num_overflow (s_scm_truncate_divide
);
2565 scm_t_inum qq
= xx
/ yy
;
2566 scm_t_inum rr
= xx
% yy
;
2567 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2568 *qp
= SCM_I_MAKINUM (qq
);
2570 *qp
= scm_i_inum2big (qq
);
2571 *rp
= SCM_I_MAKINUM (rr
);
2575 else if (SCM_BIGP (y
))
2577 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2578 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2579 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2581 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2582 scm_remember_upto_here_1 (y
);
2583 *qp
= SCM_I_MAKINUM (-1);
2593 else if (SCM_REALP (y
))
2594 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2595 else if (SCM_FRACTIONP (y
))
2596 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2598 return two_valued_wta_dispatch_2
2599 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2600 s_scm_truncate_divide
, qp
, rp
);
2602 else if (SCM_BIGP (x
))
2604 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2606 scm_t_inum yy
= SCM_I_INUM (y
);
2607 if (SCM_UNLIKELY (yy
== 0))
2608 scm_num_overflow (s_scm_truncate_divide
);
2611 SCM q
= scm_i_mkbig ();
2614 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2615 SCM_I_BIG_MPZ (x
), yy
);
2618 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2619 SCM_I_BIG_MPZ (x
), -yy
);
2620 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2622 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2623 scm_remember_upto_here_1 (x
);
2624 *qp
= scm_i_normbig (q
);
2625 *rp
= SCM_I_MAKINUM (rr
);
2629 else if (SCM_BIGP (y
))
2631 SCM q
= scm_i_mkbig ();
2632 SCM r
= scm_i_mkbig ();
2633 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2634 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2635 scm_remember_upto_here_2 (x
, y
);
2636 *qp
= scm_i_normbig (q
);
2637 *rp
= scm_i_normbig (r
);
2639 else if (SCM_REALP (y
))
2640 return scm_i_inexact_truncate_divide
2641 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2642 else if (SCM_FRACTIONP (y
))
2643 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2645 return two_valued_wta_dispatch_2
2646 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2647 s_scm_truncate_divide
, qp
, rp
);
2649 else if (SCM_REALP (x
))
2651 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2652 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2653 return scm_i_inexact_truncate_divide
2654 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2656 return two_valued_wta_dispatch_2
2657 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2658 s_scm_truncate_divide
, qp
, rp
);
2660 else if (SCM_FRACTIONP (x
))
2663 return scm_i_inexact_truncate_divide
2664 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2665 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2666 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2668 return two_valued_wta_dispatch_2
2669 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2670 s_scm_truncate_divide
, qp
, rp
);
2673 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2674 s_scm_truncate_divide
, qp
, rp
);
2678 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2680 if (SCM_UNLIKELY (y
== 0))
2681 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2684 double q
= trunc (x
/ y
);
2685 double r
= x
- q
* y
;
2686 *qp
= scm_from_double (q
);
2687 *rp
= scm_from_double (r
);
2692 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2695 SCM xd
= scm_denominator (x
);
2696 SCM yd
= scm_denominator (y
);
2698 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2699 scm_product (scm_numerator (y
), xd
),
2701 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2704 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2705 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2706 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2708 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2710 "Return the integer @var{q} such that\n"
2711 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2712 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2714 "(centered-quotient 123 10) @result{} 12\n"
2715 "(centered-quotient 123 -10) @result{} -12\n"
2716 "(centered-quotient -123 10) @result{} -12\n"
2717 "(centered-quotient -123 -10) @result{} 12\n"
2718 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2719 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2721 #define FUNC_NAME s_scm_centered_quotient
2723 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2725 scm_t_inum xx
= SCM_I_INUM (x
);
2726 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2728 scm_t_inum yy
= SCM_I_INUM (y
);
2729 if (SCM_UNLIKELY (yy
== 0))
2730 scm_num_overflow (s_scm_centered_quotient
);
2733 scm_t_inum qq
= xx
/ yy
;
2734 scm_t_inum rr
= xx
% yy
;
2735 if (SCM_LIKELY (xx
> 0))
2737 if (SCM_LIKELY (yy
> 0))
2739 if (rr
>= (yy
+ 1) / 2)
2744 if (rr
>= (1 - yy
) / 2)
2750 if (SCM_LIKELY (yy
> 0))
2761 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2762 return SCM_I_MAKINUM (qq
);
2764 return scm_i_inum2big (qq
);
2767 else if (SCM_BIGP (y
))
2769 /* Pass a denormalized bignum version of x (even though it
2770 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2771 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2773 else if (SCM_REALP (y
))
2774 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2775 else if (SCM_FRACTIONP (y
))
2776 return scm_i_exact_rational_centered_quotient (x
, y
);
2778 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2779 s_scm_centered_quotient
);
2781 else if (SCM_BIGP (x
))
2783 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2785 scm_t_inum yy
= SCM_I_INUM (y
);
2786 if (SCM_UNLIKELY (yy
== 0))
2787 scm_num_overflow (s_scm_centered_quotient
);
2788 else if (SCM_UNLIKELY (yy
== 1))
2792 SCM q
= scm_i_mkbig ();
2794 /* Arrange for rr to initially be non-positive,
2795 because that simplifies the test to see
2796 if it is within the needed bounds. */
2799 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2800 SCM_I_BIG_MPZ (x
), yy
);
2801 scm_remember_upto_here_1 (x
);
2803 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2804 SCM_I_BIG_MPZ (q
), 1);
2808 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2809 SCM_I_BIG_MPZ (x
), -yy
);
2810 scm_remember_upto_here_1 (x
);
2811 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2813 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2814 SCM_I_BIG_MPZ (q
), 1);
2816 return scm_i_normbig (q
);
2819 else if (SCM_BIGP (y
))
2820 return scm_i_bigint_centered_quotient (x
, y
);
2821 else if (SCM_REALP (y
))
2822 return scm_i_inexact_centered_quotient
2823 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2824 else if (SCM_FRACTIONP (y
))
2825 return scm_i_exact_rational_centered_quotient (x
, y
);
2827 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2828 s_scm_centered_quotient
);
2830 else if (SCM_REALP (x
))
2832 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2833 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2834 return scm_i_inexact_centered_quotient
2835 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2837 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2838 s_scm_centered_quotient
);
2840 else if (SCM_FRACTIONP (x
))
2843 return scm_i_inexact_centered_quotient
2844 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2845 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2846 return scm_i_exact_rational_centered_quotient (x
, y
);
2848 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2849 s_scm_centered_quotient
);
2852 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2853 s_scm_centered_quotient
);
2858 scm_i_inexact_centered_quotient (double x
, double y
)
2860 if (SCM_LIKELY (y
> 0))
2861 return scm_from_double (floor (x
/y
+ 0.5));
2862 else if (SCM_LIKELY (y
< 0))
2863 return scm_from_double (ceil (x
/y
- 0.5));
2865 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2870 /* Assumes that both x and y are bigints, though
2871 x might be able to fit into a fixnum. */
2873 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2877 /* Note that x might be small enough to fit into a
2878 fixnum, so we must not let it escape into the wild */
2882 /* min_r will eventually become -abs(y)/2 */
2883 min_r
= scm_i_mkbig ();
2884 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2885 SCM_I_BIG_MPZ (y
), 1);
2887 /* Arrange for rr to initially be non-positive,
2888 because that simplifies the test to see
2889 if it is within the needed bounds. */
2890 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2892 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2893 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2894 scm_remember_upto_here_2 (x
, y
);
2895 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2896 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2897 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2898 SCM_I_BIG_MPZ (q
), 1);
2902 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2903 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2904 scm_remember_upto_here_2 (x
, y
);
2905 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2906 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2907 SCM_I_BIG_MPZ (q
), 1);
2909 scm_remember_upto_here_2 (r
, min_r
);
2910 return scm_i_normbig (q
);
2914 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2916 return scm_centered_quotient
2917 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2918 scm_product (scm_numerator (y
), scm_denominator (x
)));
2921 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2922 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2923 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2925 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2927 "Return the real number @var{r} such that\n"
2928 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2929 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2930 "for some integer @var{q}.\n"
2932 "(centered-remainder 123 10) @result{} 3\n"
2933 "(centered-remainder 123 -10) @result{} 3\n"
2934 "(centered-remainder -123 10) @result{} -3\n"
2935 "(centered-remainder -123 -10) @result{} -3\n"
2936 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2937 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2939 #define FUNC_NAME s_scm_centered_remainder
2941 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2943 scm_t_inum xx
= SCM_I_INUM (x
);
2944 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2946 scm_t_inum yy
= SCM_I_INUM (y
);
2947 if (SCM_UNLIKELY (yy
== 0))
2948 scm_num_overflow (s_scm_centered_remainder
);
2951 scm_t_inum rr
= xx
% yy
;
2952 if (SCM_LIKELY (xx
> 0))
2954 if (SCM_LIKELY (yy
> 0))
2956 if (rr
>= (yy
+ 1) / 2)
2961 if (rr
>= (1 - yy
) / 2)
2967 if (SCM_LIKELY (yy
> 0))
2978 return SCM_I_MAKINUM (rr
);
2981 else if (SCM_BIGP (y
))
2983 /* Pass a denormalized bignum version of x (even though it
2984 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2985 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2987 else if (SCM_REALP (y
))
2988 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2989 else if (SCM_FRACTIONP (y
))
2990 return scm_i_exact_rational_centered_remainder (x
, y
);
2992 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2993 s_scm_centered_remainder
);
2995 else if (SCM_BIGP (x
))
2997 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2999 scm_t_inum yy
= SCM_I_INUM (y
);
3000 if (SCM_UNLIKELY (yy
== 0))
3001 scm_num_overflow (s_scm_centered_remainder
);
3005 /* Arrange for rr to initially be non-positive,
3006 because that simplifies the test to see
3007 if it is within the needed bounds. */
3010 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3011 scm_remember_upto_here_1 (x
);
3017 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3018 scm_remember_upto_here_1 (x
);
3022 return SCM_I_MAKINUM (rr
);
3025 else if (SCM_BIGP (y
))
3026 return scm_i_bigint_centered_remainder (x
, y
);
3027 else if (SCM_REALP (y
))
3028 return scm_i_inexact_centered_remainder
3029 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3030 else if (SCM_FRACTIONP (y
))
3031 return scm_i_exact_rational_centered_remainder (x
, y
);
3033 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3034 s_scm_centered_remainder
);
3036 else if (SCM_REALP (x
))
3038 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3039 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3040 return scm_i_inexact_centered_remainder
3041 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3043 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3044 s_scm_centered_remainder
);
3046 else if (SCM_FRACTIONP (x
))
3049 return scm_i_inexact_centered_remainder
3050 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3051 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3052 return scm_i_exact_rational_centered_remainder (x
, y
);
3054 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3055 s_scm_centered_remainder
);
3058 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3059 s_scm_centered_remainder
);
3064 scm_i_inexact_centered_remainder (double x
, double y
)
3068 /* Although it would be more efficient to use fmod here, we can't
3069 because it would in some cases produce results inconsistent with
3070 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3071 close). In particular, when x-y/2 is very close to a multiple of
3072 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3073 two cases must correspond to different choices of q. If quotient
3074 chooses one and remainder chooses the other, it would be bad. */
3075 if (SCM_LIKELY (y
> 0))
3076 q
= floor (x
/y
+ 0.5);
3077 else if (SCM_LIKELY (y
< 0))
3078 q
= ceil (x
/y
- 0.5);
3080 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3083 return scm_from_double (x
- q
* y
);
3086 /* Assumes that both x and y are bigints, though
3087 x might be able to fit into a fixnum. */
3089 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3093 /* Note that x might be small enough to fit into a
3094 fixnum, so we must not let it escape into the wild */
3097 /* min_r will eventually become -abs(y)/2 */
3098 min_r
= scm_i_mkbig ();
3099 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3100 SCM_I_BIG_MPZ (y
), 1);
3102 /* Arrange for rr to initially be non-positive,
3103 because that simplifies the test to see
3104 if it is within the needed bounds. */
3105 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3107 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3108 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3109 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3110 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3111 mpz_add (SCM_I_BIG_MPZ (r
),
3117 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3118 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3119 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3120 mpz_sub (SCM_I_BIG_MPZ (r
),
3124 scm_remember_upto_here_2 (x
, y
);
3125 return scm_i_normbig (r
);
3129 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3131 SCM xd
= scm_denominator (x
);
3132 SCM yd
= scm_denominator (y
);
3133 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3134 scm_product (scm_numerator (y
), xd
));
3135 return scm_divide (r1
, scm_product (xd
, yd
));
3139 static void scm_i_inexact_centered_divide (double x
, double y
,
3141 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3142 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3145 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3147 "Return the integer @var{q} and the real number @var{r}\n"
3148 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3149 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3151 "(centered/ 123 10) @result{} 12 and 3\n"
3152 "(centered/ 123 -10) @result{} -12 and 3\n"
3153 "(centered/ -123 10) @result{} -12 and -3\n"
3154 "(centered/ -123 -10) @result{} 12 and -3\n"
3155 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3156 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3158 #define FUNC_NAME s_scm_i_centered_divide
3162 scm_centered_divide(x
, y
, &q
, &r
);
3163 return scm_values (scm_list_2 (q
, r
));
3167 #define s_scm_centered_divide s_scm_i_centered_divide
3168 #define g_scm_centered_divide g_scm_i_centered_divide
3171 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3173 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3175 scm_t_inum xx
= SCM_I_INUM (x
);
3176 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3178 scm_t_inum yy
= SCM_I_INUM (y
);
3179 if (SCM_UNLIKELY (yy
== 0))
3180 scm_num_overflow (s_scm_centered_divide
);
3183 scm_t_inum qq
= xx
/ yy
;
3184 scm_t_inum rr
= xx
% yy
;
3185 if (SCM_LIKELY (xx
> 0))
3187 if (SCM_LIKELY (yy
> 0))
3189 if (rr
>= (yy
+ 1) / 2)
3194 if (rr
>= (1 - yy
) / 2)
3200 if (SCM_LIKELY (yy
> 0))
3211 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3212 *qp
= SCM_I_MAKINUM (qq
);
3214 *qp
= scm_i_inum2big (qq
);
3215 *rp
= SCM_I_MAKINUM (rr
);
3219 else if (SCM_BIGP (y
))
3221 /* Pass a denormalized bignum version of x (even though it
3222 can fit in a fixnum) to scm_i_bigint_centered_divide */
3223 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3225 else if (SCM_REALP (y
))
3226 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3227 else if (SCM_FRACTIONP (y
))
3228 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3230 return two_valued_wta_dispatch_2
3231 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3232 s_scm_centered_divide
, qp
, rp
);
3234 else if (SCM_BIGP (x
))
3236 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3238 scm_t_inum yy
= SCM_I_INUM (y
);
3239 if (SCM_UNLIKELY (yy
== 0))
3240 scm_num_overflow (s_scm_centered_divide
);
3243 SCM q
= scm_i_mkbig ();
3245 /* Arrange for rr to initially be non-positive,
3246 because that simplifies the test to see
3247 if it is within the needed bounds. */
3250 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3251 SCM_I_BIG_MPZ (x
), yy
);
3252 scm_remember_upto_here_1 (x
);
3255 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3256 SCM_I_BIG_MPZ (q
), 1);
3262 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3263 SCM_I_BIG_MPZ (x
), -yy
);
3264 scm_remember_upto_here_1 (x
);
3265 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3268 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3269 SCM_I_BIG_MPZ (q
), 1);
3273 *qp
= scm_i_normbig (q
);
3274 *rp
= SCM_I_MAKINUM (rr
);
3278 else if (SCM_BIGP (y
))
3279 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3280 else if (SCM_REALP (y
))
3281 return scm_i_inexact_centered_divide
3282 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3283 else if (SCM_FRACTIONP (y
))
3284 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3286 return two_valued_wta_dispatch_2
3287 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3288 s_scm_centered_divide
, qp
, rp
);
3290 else if (SCM_REALP (x
))
3292 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3293 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3294 return scm_i_inexact_centered_divide
3295 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3297 return two_valued_wta_dispatch_2
3298 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3299 s_scm_centered_divide
, qp
, rp
);
3301 else if (SCM_FRACTIONP (x
))
3304 return scm_i_inexact_centered_divide
3305 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3306 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3307 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3309 return two_valued_wta_dispatch_2
3310 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3311 s_scm_centered_divide
, qp
, rp
);
3314 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3315 s_scm_centered_divide
, qp
, rp
);
3319 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3323 if (SCM_LIKELY (y
> 0))
3324 q
= floor (x
/y
+ 0.5);
3325 else if (SCM_LIKELY (y
< 0))
3326 q
= ceil (x
/y
- 0.5);
3328 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3332 *qp
= scm_from_double (q
);
3333 *rp
= scm_from_double (r
);
3336 /* Assumes that both x and y are bigints, though
3337 x might be able to fit into a fixnum. */
3339 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3343 /* Note that x might be small enough to fit into a
3344 fixnum, so we must not let it escape into the wild */
3348 /* min_r will eventually become -abs(y/2) */
3349 min_r
= scm_i_mkbig ();
3350 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3351 SCM_I_BIG_MPZ (y
), 1);
3353 /* Arrange for rr to initially be non-positive,
3354 because that simplifies the test to see
3355 if it is within the needed bounds. */
3356 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3358 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3359 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3360 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3361 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3363 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3364 SCM_I_BIG_MPZ (q
), 1);
3365 mpz_add (SCM_I_BIG_MPZ (r
),
3372 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3373 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3374 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3376 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3377 SCM_I_BIG_MPZ (q
), 1);
3378 mpz_sub (SCM_I_BIG_MPZ (r
),
3383 scm_remember_upto_here_2 (x
, y
);
3384 *qp
= scm_i_normbig (q
);
3385 *rp
= scm_i_normbig (r
);
3389 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3392 SCM xd
= scm_denominator (x
);
3393 SCM yd
= scm_denominator (y
);
3395 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3396 scm_product (scm_numerator (y
), xd
),
3398 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3401 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3402 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3403 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3405 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3407 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3408 "with ties going to the nearest even integer.\n"
3410 "(round-quotient 123 10) @result{} 12\n"
3411 "(round-quotient 123 -10) @result{} -12\n"
3412 "(round-quotient -123 10) @result{} -12\n"
3413 "(round-quotient -123 -10) @result{} 12\n"
3414 "(round-quotient 125 10) @result{} 12\n"
3415 "(round-quotient 127 10) @result{} 13\n"
3416 "(round-quotient 135 10) @result{} 14\n"
3417 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3418 "(round-quotient 16/3 -10/7) @result{} -4\n"
3420 #define FUNC_NAME s_scm_round_quotient
3422 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3424 scm_t_inum xx
= SCM_I_INUM (x
);
3425 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3427 scm_t_inum yy
= SCM_I_INUM (y
);
3428 if (SCM_UNLIKELY (yy
== 0))
3429 scm_num_overflow (s_scm_round_quotient
);
3432 scm_t_inum qq
= xx
/ yy
;
3433 scm_t_inum rr
= xx
% yy
;
3435 scm_t_inum r2
= 2 * rr
;
3437 if (SCM_LIKELY (yy
< 0))
3457 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3458 return SCM_I_MAKINUM (qq
);
3460 return scm_i_inum2big (qq
);
3463 else if (SCM_BIGP (y
))
3465 /* Pass a denormalized bignum version of x (even though it
3466 can fit in a fixnum) to scm_i_bigint_round_quotient */
3467 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3469 else if (SCM_REALP (y
))
3470 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3471 else if (SCM_FRACTIONP (y
))
3472 return scm_i_exact_rational_round_quotient (x
, y
);
3474 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3475 s_scm_round_quotient
);
3477 else if (SCM_BIGP (x
))
3479 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3481 scm_t_inum yy
= SCM_I_INUM (y
);
3482 if (SCM_UNLIKELY (yy
== 0))
3483 scm_num_overflow (s_scm_round_quotient
);
3484 else if (SCM_UNLIKELY (yy
== 1))
3488 SCM q
= scm_i_mkbig ();
3490 int needs_adjustment
;
3494 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3495 SCM_I_BIG_MPZ (x
), yy
);
3496 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3497 needs_adjustment
= (2*rr
>= yy
);
3499 needs_adjustment
= (2*rr
> yy
);
3503 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3504 SCM_I_BIG_MPZ (x
), -yy
);
3505 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3506 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3507 needs_adjustment
= (2*rr
<= yy
);
3509 needs_adjustment
= (2*rr
< yy
);
3511 scm_remember_upto_here_1 (x
);
3512 if (needs_adjustment
)
3513 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3514 return scm_i_normbig (q
);
3517 else if (SCM_BIGP (y
))
3518 return scm_i_bigint_round_quotient (x
, y
);
3519 else if (SCM_REALP (y
))
3520 return scm_i_inexact_round_quotient
3521 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3522 else if (SCM_FRACTIONP (y
))
3523 return scm_i_exact_rational_round_quotient (x
, y
);
3525 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3526 s_scm_round_quotient
);
3528 else if (SCM_REALP (x
))
3530 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3531 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3532 return scm_i_inexact_round_quotient
3533 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3535 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3536 s_scm_round_quotient
);
3538 else if (SCM_FRACTIONP (x
))
3541 return scm_i_inexact_round_quotient
3542 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3543 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3544 return scm_i_exact_rational_round_quotient (x
, y
);
3546 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3547 s_scm_round_quotient
);
3550 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3551 s_scm_round_quotient
);
3556 scm_i_inexact_round_quotient (double x
, double y
)
3558 if (SCM_UNLIKELY (y
== 0))
3559 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3561 return scm_from_double (scm_c_round (x
/ y
));
3564 /* Assumes that both x and y are bigints, though
3565 x might be able to fit into a fixnum. */
3567 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3570 int cmp
, needs_adjustment
;
3572 /* Note that x might be small enough to fit into a
3573 fixnum, so we must not let it escape into the wild */
3576 r2
= scm_i_mkbig ();
3578 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3579 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3580 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3581 scm_remember_upto_here_2 (x
, r
);
3583 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3584 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3585 needs_adjustment
= (cmp
>= 0);
3587 needs_adjustment
= (cmp
> 0);
3588 scm_remember_upto_here_2 (r2
, y
);
3590 if (needs_adjustment
)
3591 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3593 return scm_i_normbig (q
);
3597 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3599 return scm_round_quotient
3600 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3601 scm_product (scm_numerator (y
), scm_denominator (x
)));
3604 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3605 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3606 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3608 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3610 "Return the real number @var{r} such that\n"
3611 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3612 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3613 "nearest integer, with ties going to the nearest\n"
3616 "(round-remainder 123 10) @result{} 3\n"
3617 "(round-remainder 123 -10) @result{} 3\n"
3618 "(round-remainder -123 10) @result{} -3\n"
3619 "(round-remainder -123 -10) @result{} -3\n"
3620 "(round-remainder 125 10) @result{} 5\n"
3621 "(round-remainder 127 10) @result{} -3\n"
3622 "(round-remainder 135 10) @result{} -5\n"
3623 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3624 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3626 #define FUNC_NAME s_scm_round_remainder
3628 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3630 scm_t_inum xx
= SCM_I_INUM (x
);
3631 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3633 scm_t_inum yy
= SCM_I_INUM (y
);
3634 if (SCM_UNLIKELY (yy
== 0))
3635 scm_num_overflow (s_scm_round_remainder
);
3638 scm_t_inum qq
= xx
/ yy
;
3639 scm_t_inum rr
= xx
% yy
;
3641 scm_t_inum r2
= 2 * rr
;
3643 if (SCM_LIKELY (yy
< 0))
3663 return SCM_I_MAKINUM (rr
);
3666 else if (SCM_BIGP (y
))
3668 /* Pass a denormalized bignum version of x (even though it
3669 can fit in a fixnum) to scm_i_bigint_round_remainder */
3670 return scm_i_bigint_round_remainder
3671 (scm_i_long2big (xx
), y
);
3673 else if (SCM_REALP (y
))
3674 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3675 else if (SCM_FRACTIONP (y
))
3676 return scm_i_exact_rational_round_remainder (x
, y
);
3678 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3679 s_scm_round_remainder
);
3681 else if (SCM_BIGP (x
))
3683 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3685 scm_t_inum yy
= SCM_I_INUM (y
);
3686 if (SCM_UNLIKELY (yy
== 0))
3687 scm_num_overflow (s_scm_round_remainder
);
3690 SCM q
= scm_i_mkbig ();
3692 int needs_adjustment
;
3696 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3697 SCM_I_BIG_MPZ (x
), yy
);
3698 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3699 needs_adjustment
= (2*rr
>= yy
);
3701 needs_adjustment
= (2*rr
> yy
);
3705 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3706 SCM_I_BIG_MPZ (x
), -yy
);
3707 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3708 needs_adjustment
= (2*rr
<= yy
);
3710 needs_adjustment
= (2*rr
< yy
);
3712 scm_remember_upto_here_2 (x
, q
);
3713 if (needs_adjustment
)
3715 return SCM_I_MAKINUM (rr
);
3718 else if (SCM_BIGP (y
))
3719 return scm_i_bigint_round_remainder (x
, y
);
3720 else if (SCM_REALP (y
))
3721 return scm_i_inexact_round_remainder
3722 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3723 else if (SCM_FRACTIONP (y
))
3724 return scm_i_exact_rational_round_remainder (x
, y
);
3726 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3727 s_scm_round_remainder
);
3729 else if (SCM_REALP (x
))
3731 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3732 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3733 return scm_i_inexact_round_remainder
3734 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3736 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3737 s_scm_round_remainder
);
3739 else if (SCM_FRACTIONP (x
))
3742 return scm_i_inexact_round_remainder
3743 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3744 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3745 return scm_i_exact_rational_round_remainder (x
, y
);
3747 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3748 s_scm_round_remainder
);
3751 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3752 s_scm_round_remainder
);
3757 scm_i_inexact_round_remainder (double x
, double y
)
3759 /* Although it would be more efficient to use fmod here, we can't
3760 because it would in some cases produce results inconsistent with
3761 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3762 close). In particular, when x-y/2 is very close to a multiple of
3763 y, then r might be either -abs(y/2) or abs(y/2), but those two
3764 cases must correspond to different choices of q. If quotient
3765 chooses one and remainder chooses the other, it would be bad. */
3767 if (SCM_UNLIKELY (y
== 0))
3768 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3771 double q
= scm_c_round (x
/ y
);
3772 return scm_from_double (x
- q
* y
);
3776 /* Assumes that both x and y are bigints, though
3777 x might be able to fit into a fixnum. */
3779 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3782 int cmp
, needs_adjustment
;
3784 /* Note that x might be small enough to fit into a
3785 fixnum, so we must not let it escape into the wild */
3788 r2
= scm_i_mkbig ();
3790 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3791 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3792 scm_remember_upto_here_1 (x
);
3793 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3795 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3796 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3797 needs_adjustment
= (cmp
>= 0);
3799 needs_adjustment
= (cmp
> 0);
3800 scm_remember_upto_here_2 (q
, r2
);
3802 if (needs_adjustment
)
3803 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3805 scm_remember_upto_here_1 (y
);
3806 return scm_i_normbig (r
);
3810 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3812 SCM xd
= scm_denominator (x
);
3813 SCM yd
= scm_denominator (y
);
3814 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3815 scm_product (scm_numerator (y
), xd
));
3816 return scm_divide (r1
, scm_product (xd
, yd
));
3820 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3821 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3822 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3824 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3826 "Return the integer @var{q} and the real number @var{r}\n"
3827 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3828 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3829 "nearest integer, with ties going to the nearest even integer.\n"
3831 "(round/ 123 10) @result{} 12 and 3\n"
3832 "(round/ 123 -10) @result{} -12 and 3\n"
3833 "(round/ -123 10) @result{} -12 and -3\n"
3834 "(round/ -123 -10) @result{} 12 and -3\n"
3835 "(round/ 125 10) @result{} 12 and 5\n"
3836 "(round/ 127 10) @result{} 13 and -3\n"
3837 "(round/ 135 10) @result{} 14 and -5\n"
3838 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3839 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3841 #define FUNC_NAME s_scm_i_round_divide
3845 scm_round_divide(x
, y
, &q
, &r
);
3846 return scm_values (scm_list_2 (q
, r
));
3850 #define s_scm_round_divide s_scm_i_round_divide
3851 #define g_scm_round_divide g_scm_i_round_divide
3854 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3856 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3858 scm_t_inum xx
= SCM_I_INUM (x
);
3859 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3861 scm_t_inum yy
= SCM_I_INUM (y
);
3862 if (SCM_UNLIKELY (yy
== 0))
3863 scm_num_overflow (s_scm_round_divide
);
3866 scm_t_inum qq
= xx
/ yy
;
3867 scm_t_inum rr
= xx
% yy
;
3869 scm_t_inum r2
= 2 * rr
;
3871 if (SCM_LIKELY (yy
< 0))
3891 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3892 *qp
= SCM_I_MAKINUM (qq
);
3894 *qp
= scm_i_inum2big (qq
);
3895 *rp
= SCM_I_MAKINUM (rr
);
3899 else if (SCM_BIGP (y
))
3901 /* Pass a denormalized bignum version of x (even though it
3902 can fit in a fixnum) to scm_i_bigint_round_divide */
3903 return scm_i_bigint_round_divide
3904 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3906 else if (SCM_REALP (y
))
3907 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3908 else if (SCM_FRACTIONP (y
))
3909 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3911 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3912 s_scm_round_divide
, qp
, rp
);
3914 else if (SCM_BIGP (x
))
3916 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3918 scm_t_inum yy
= SCM_I_INUM (y
);
3919 if (SCM_UNLIKELY (yy
== 0))
3920 scm_num_overflow (s_scm_round_divide
);
3923 SCM q
= scm_i_mkbig ();
3925 int needs_adjustment
;
3929 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3930 SCM_I_BIG_MPZ (x
), yy
);
3931 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3932 needs_adjustment
= (2*rr
>= yy
);
3934 needs_adjustment
= (2*rr
> yy
);
3938 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3939 SCM_I_BIG_MPZ (x
), -yy
);
3940 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3941 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3942 needs_adjustment
= (2*rr
<= yy
);
3944 needs_adjustment
= (2*rr
< yy
);
3946 scm_remember_upto_here_1 (x
);
3947 if (needs_adjustment
)
3949 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3952 *qp
= scm_i_normbig (q
);
3953 *rp
= SCM_I_MAKINUM (rr
);
3957 else if (SCM_BIGP (y
))
3958 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3959 else if (SCM_REALP (y
))
3960 return scm_i_inexact_round_divide
3961 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3962 else if (SCM_FRACTIONP (y
))
3963 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3965 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3966 s_scm_round_divide
, qp
, rp
);
3968 else if (SCM_REALP (x
))
3970 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3971 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3972 return scm_i_inexact_round_divide
3973 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3975 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3976 s_scm_round_divide
, qp
, rp
);
3978 else if (SCM_FRACTIONP (x
))
3981 return scm_i_inexact_round_divide
3982 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3983 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3984 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3986 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3987 s_scm_round_divide
, qp
, rp
);
3990 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3991 s_scm_round_divide
, qp
, rp
);
3995 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3997 if (SCM_UNLIKELY (y
== 0))
3998 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4001 double q
= scm_c_round (x
/ y
);
4002 double r
= x
- q
* y
;
4003 *qp
= scm_from_double (q
);
4004 *rp
= scm_from_double (r
);
4008 /* Assumes that both x and y are bigints, though
4009 x might be able to fit into a fixnum. */
4011 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4014 int cmp
, needs_adjustment
;
4016 /* Note that x might be small enough to fit into a
4017 fixnum, so we must not let it escape into the wild */
4020 r2
= scm_i_mkbig ();
4022 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4023 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4024 scm_remember_upto_here_1 (x
);
4025 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4027 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4028 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4029 needs_adjustment
= (cmp
>= 0);
4031 needs_adjustment
= (cmp
> 0);
4033 if (needs_adjustment
)
4035 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4036 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4039 scm_remember_upto_here_2 (r2
, y
);
4040 *qp
= scm_i_normbig (q
);
4041 *rp
= scm_i_normbig (r
);
4045 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4048 SCM xd
= scm_denominator (x
);
4049 SCM yd
= scm_denominator (y
);
4051 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4052 scm_product (scm_numerator (y
), xd
),
4054 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4058 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4059 (SCM x
, SCM y
, SCM rest
),
4060 "Return the greatest common divisor of all parameter values.\n"
4061 "If called without arguments, 0 is returned.")
4062 #define FUNC_NAME s_scm_i_gcd
4064 while (!scm_is_null (rest
))
4065 { x
= scm_gcd (x
, y
);
4067 rest
= scm_cdr (rest
);
4069 return scm_gcd (x
, y
);
4073 #define s_gcd s_scm_i_gcd
4074 #define g_gcd g_scm_i_gcd
4077 scm_gcd (SCM x
, SCM y
)
4079 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4080 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4082 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4084 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4086 scm_t_inum xx
= SCM_I_INUM (x
);
4087 scm_t_inum yy
= SCM_I_INUM (y
);
4088 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4089 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4091 if (SCM_UNLIKELY (xx
== 0))
4093 else if (SCM_UNLIKELY (yy
== 0))
4098 /* Determine a common factor 2^k */
4099 while (((u
| v
) & 1) == 0)
4105 /* Now, any factor 2^n can be eliminated */
4107 while ((u
& 1) == 0)
4110 while ((v
& 1) == 0)
4112 /* Both u and v are now odd. Subtract the smaller one
4113 from the larger one to produce an even number, remove
4114 more factors of two, and repeat. */
4120 while ((u
& 1) == 0)
4126 while ((v
& 1) == 0)
4132 return (SCM_POSFIXABLE (result
)
4133 ? SCM_I_MAKINUM (result
)
4134 : scm_i_inum2big (result
));
4136 else if (SCM_BIGP (y
))
4142 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4144 else if (SCM_BIGP (x
))
4146 if (SCM_I_INUMP (y
))
4151 yy
= SCM_I_INUM (y
);
4156 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4157 scm_remember_upto_here_1 (x
);
4158 return (SCM_POSFIXABLE (result
)
4159 ? SCM_I_MAKINUM (result
)
4160 : scm_from_unsigned_integer (result
));
4162 else if (SCM_BIGP (y
))
4164 SCM result
= scm_i_mkbig ();
4165 mpz_gcd (SCM_I_BIG_MPZ (result
),
4168 scm_remember_upto_here_2 (x
, y
);
4169 return scm_i_normbig (result
);
4172 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4175 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4178 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4179 (SCM x
, SCM y
, SCM rest
),
4180 "Return the least common multiple of the arguments.\n"
4181 "If called without arguments, 1 is returned.")
4182 #define FUNC_NAME s_scm_i_lcm
4184 while (!scm_is_null (rest
))
4185 { x
= scm_lcm (x
, y
);
4187 rest
= scm_cdr (rest
);
4189 return scm_lcm (x
, y
);
4193 #define s_lcm s_scm_i_lcm
4194 #define g_lcm g_scm_i_lcm
4197 scm_lcm (SCM n1
, SCM n2
)
4199 if (SCM_UNBNDP (n2
))
4201 if (SCM_UNBNDP (n1
))
4202 return SCM_I_MAKINUM (1L);
4203 n2
= SCM_I_MAKINUM (1L);
4206 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4207 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4208 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4209 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4211 if (SCM_I_INUMP (n1
))
4213 if (SCM_I_INUMP (n2
))
4215 SCM d
= scm_gcd (n1
, n2
);
4216 if (scm_is_eq (d
, SCM_INUM0
))
4219 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4223 /* inum n1, big n2 */
4226 SCM result
= scm_i_mkbig ();
4227 scm_t_inum nn1
= SCM_I_INUM (n1
);
4228 if (nn1
== 0) return SCM_INUM0
;
4229 if (nn1
< 0) nn1
= - nn1
;
4230 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4231 scm_remember_upto_here_1 (n2
);
4239 if (SCM_I_INUMP (n2
))
4246 SCM result
= scm_i_mkbig ();
4247 mpz_lcm(SCM_I_BIG_MPZ (result
),
4249 SCM_I_BIG_MPZ (n2
));
4250 scm_remember_upto_here_2(n1
, n2
);
4251 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4257 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4262 + + + x (map digit:logand X Y)
4263 + - + x (map digit:logand X (lognot (+ -1 Y)))
4264 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4265 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4270 + + + (map digit:logior X Y)
4271 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4272 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4273 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4278 + + + (map digit:logxor X Y)
4279 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4280 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4281 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4286 + + (any digit:logand X Y)
4287 + - (any digit:logand X (lognot (+ -1 Y)))
4288 - + (any digit:logand (lognot (+ -1 X)) Y)
4293 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4294 (SCM x
, SCM y
, SCM rest
),
4295 "Return the bitwise AND of the integer arguments.\n\n"
4297 "(logand) @result{} -1\n"
4298 "(logand 7) @result{} 7\n"
4299 "(logand #b111 #b011 #b001) @result{} 1\n"
4301 #define FUNC_NAME s_scm_i_logand
4303 while (!scm_is_null (rest
))
4304 { x
= scm_logand (x
, y
);
4306 rest
= scm_cdr (rest
);
4308 return scm_logand (x
, y
);
4312 #define s_scm_logand s_scm_i_logand
4314 SCM
scm_logand (SCM n1
, SCM n2
)
4315 #define FUNC_NAME s_scm_logand
4319 if (SCM_UNBNDP (n2
))
4321 if (SCM_UNBNDP (n1
))
4322 return SCM_I_MAKINUM (-1);
4323 else if (!SCM_NUMBERP (n1
))
4324 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4325 else if (SCM_NUMBERP (n1
))
4328 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4331 if (SCM_I_INUMP (n1
))
4333 nn1
= SCM_I_INUM (n1
);
4334 if (SCM_I_INUMP (n2
))
4336 scm_t_inum nn2
= SCM_I_INUM (n2
);
4337 return SCM_I_MAKINUM (nn1
& nn2
);
4339 else if SCM_BIGP (n2
)
4345 SCM result_z
= scm_i_mkbig ();
4347 mpz_init_set_si (nn1_z
, nn1
);
4348 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4349 scm_remember_upto_here_1 (n2
);
4351 return scm_i_normbig (result_z
);
4355 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4357 else if (SCM_BIGP (n1
))
4359 if (SCM_I_INUMP (n2
))
4362 nn1
= SCM_I_INUM (n1
);
4365 else if (SCM_BIGP (n2
))
4367 SCM result_z
= scm_i_mkbig ();
4368 mpz_and (SCM_I_BIG_MPZ (result_z
),
4370 SCM_I_BIG_MPZ (n2
));
4371 scm_remember_upto_here_2 (n1
, n2
);
4372 return scm_i_normbig (result_z
);
4375 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4378 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4383 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4384 (SCM x
, SCM y
, SCM rest
),
4385 "Return the bitwise OR of the integer arguments.\n\n"
4387 "(logior) @result{} 0\n"
4388 "(logior 7) @result{} 7\n"
4389 "(logior #b000 #b001 #b011) @result{} 3\n"
4391 #define FUNC_NAME s_scm_i_logior
4393 while (!scm_is_null (rest
))
4394 { x
= scm_logior (x
, y
);
4396 rest
= scm_cdr (rest
);
4398 return scm_logior (x
, y
);
4402 #define s_scm_logior s_scm_i_logior
4404 SCM
scm_logior (SCM n1
, SCM n2
)
4405 #define FUNC_NAME s_scm_logior
4409 if (SCM_UNBNDP (n2
))
4411 if (SCM_UNBNDP (n1
))
4413 else if (SCM_NUMBERP (n1
))
4416 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4419 if (SCM_I_INUMP (n1
))
4421 nn1
= SCM_I_INUM (n1
);
4422 if (SCM_I_INUMP (n2
))
4424 long nn2
= SCM_I_INUM (n2
);
4425 return SCM_I_MAKINUM (nn1
| nn2
);
4427 else if (SCM_BIGP (n2
))
4433 SCM result_z
= scm_i_mkbig ();
4435 mpz_init_set_si (nn1_z
, nn1
);
4436 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4437 scm_remember_upto_here_1 (n2
);
4439 return scm_i_normbig (result_z
);
4443 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4445 else if (SCM_BIGP (n1
))
4447 if (SCM_I_INUMP (n2
))
4450 nn1
= SCM_I_INUM (n1
);
4453 else if (SCM_BIGP (n2
))
4455 SCM result_z
= scm_i_mkbig ();
4456 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4458 SCM_I_BIG_MPZ (n2
));
4459 scm_remember_upto_here_2 (n1
, n2
);
4460 return scm_i_normbig (result_z
);
4463 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4466 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4471 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4472 (SCM x
, SCM y
, SCM rest
),
4473 "Return the bitwise XOR of the integer arguments. A bit is\n"
4474 "set in the result if it is set in an odd number of arguments.\n"
4476 "(logxor) @result{} 0\n"
4477 "(logxor 7) @result{} 7\n"
4478 "(logxor #b000 #b001 #b011) @result{} 2\n"
4479 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4481 #define FUNC_NAME s_scm_i_logxor
4483 while (!scm_is_null (rest
))
4484 { x
= scm_logxor (x
, y
);
4486 rest
= scm_cdr (rest
);
4488 return scm_logxor (x
, y
);
4492 #define s_scm_logxor s_scm_i_logxor
4494 SCM
scm_logxor (SCM n1
, SCM n2
)
4495 #define FUNC_NAME s_scm_logxor
4499 if (SCM_UNBNDP (n2
))
4501 if (SCM_UNBNDP (n1
))
4503 else if (SCM_NUMBERP (n1
))
4506 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4509 if (SCM_I_INUMP (n1
))
4511 nn1
= SCM_I_INUM (n1
);
4512 if (SCM_I_INUMP (n2
))
4514 scm_t_inum nn2
= SCM_I_INUM (n2
);
4515 return SCM_I_MAKINUM (nn1
^ nn2
);
4517 else if (SCM_BIGP (n2
))
4521 SCM result_z
= scm_i_mkbig ();
4523 mpz_init_set_si (nn1_z
, nn1
);
4524 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4525 scm_remember_upto_here_1 (n2
);
4527 return scm_i_normbig (result_z
);
4531 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4533 else if (SCM_BIGP (n1
))
4535 if (SCM_I_INUMP (n2
))
4538 nn1
= SCM_I_INUM (n1
);
4541 else if (SCM_BIGP (n2
))
4543 SCM result_z
= scm_i_mkbig ();
4544 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4546 SCM_I_BIG_MPZ (n2
));
4547 scm_remember_upto_here_2 (n1
, n2
);
4548 return scm_i_normbig (result_z
);
4551 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4554 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4559 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4561 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4562 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4563 "without actually calculating the @code{logand}, just testing\n"
4567 "(logtest #b0100 #b1011) @result{} #f\n"
4568 "(logtest #b0100 #b0111) @result{} #t\n"
4570 #define FUNC_NAME s_scm_logtest
4574 if (SCM_I_INUMP (j
))
4576 nj
= SCM_I_INUM (j
);
4577 if (SCM_I_INUMP (k
))
4579 scm_t_inum nk
= SCM_I_INUM (k
);
4580 return scm_from_bool (nj
& nk
);
4582 else if (SCM_BIGP (k
))
4590 mpz_init_set_si (nj_z
, nj
);
4591 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4592 scm_remember_upto_here_1 (k
);
4593 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4599 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4601 else if (SCM_BIGP (j
))
4603 if (SCM_I_INUMP (k
))
4606 nj
= SCM_I_INUM (j
);
4609 else if (SCM_BIGP (k
))
4613 mpz_init (result_z
);
4617 scm_remember_upto_here_2 (j
, k
);
4618 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4619 mpz_clear (result_z
);
4623 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4626 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4631 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4633 "Test whether bit number @var{index} in @var{j} is set.\n"
4634 "@var{index} starts from 0 for the least significant bit.\n"
4637 "(logbit? 0 #b1101) @result{} #t\n"
4638 "(logbit? 1 #b1101) @result{} #f\n"
4639 "(logbit? 2 #b1101) @result{} #t\n"
4640 "(logbit? 3 #b1101) @result{} #t\n"
4641 "(logbit? 4 #b1101) @result{} #f\n"
4643 #define FUNC_NAME s_scm_logbit_p
4645 unsigned long int iindex
;
4646 iindex
= scm_to_ulong (index
);
4648 if (SCM_I_INUMP (j
))
4650 /* bits above what's in an inum follow the sign bit */
4651 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4652 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4654 else if (SCM_BIGP (j
))
4656 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4657 scm_remember_upto_here_1 (j
);
4658 return scm_from_bool (val
);
4661 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4666 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4668 "Return the integer which is the ones-complement of the integer\n"
4672 "(number->string (lognot #b10000000) 2)\n"
4673 " @result{} \"-10000001\"\n"
4674 "(number->string (lognot #b0) 2)\n"
4675 " @result{} \"-1\"\n"
4677 #define FUNC_NAME s_scm_lognot
4679 if (SCM_I_INUMP (n
)) {
4680 /* No overflow here, just need to toggle all the bits making up the inum.
4681 Enhancement: No need to strip the tag and add it back, could just xor
4682 a block of 1 bits, if that worked with the various debug versions of
4684 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4686 } else if (SCM_BIGP (n
)) {
4687 SCM result
= scm_i_mkbig ();
4688 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4689 scm_remember_upto_here_1 (n
);
4693 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4698 /* returns 0 if IN is not an integer. OUT must already be
4701 coerce_to_big (SCM in
, mpz_t out
)
4704 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4705 else if (SCM_I_INUMP (in
))
4706 mpz_set_si (out
, SCM_I_INUM (in
));
4713 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4714 (SCM n
, SCM k
, SCM m
),
4715 "Return @var{n} raised to the integer exponent\n"
4716 "@var{k}, modulo @var{m}.\n"
4719 "(modulo-expt 2 3 5)\n"
4722 #define FUNC_NAME s_scm_modulo_expt
4728 /* There are two classes of error we might encounter --
4729 1) Math errors, which we'll report by calling scm_num_overflow,
4731 2) wrong-type errors, which of course we'll report by calling
4733 We don't report those errors immediately, however; instead we do
4734 some cleanup first. These variables tell us which error (if
4735 any) we should report after cleaning up.
4737 int report_overflow
= 0;
4739 int position_of_wrong_type
= 0;
4740 SCM value_of_wrong_type
= SCM_INUM0
;
4742 SCM result
= SCM_UNDEFINED
;
4748 if (scm_is_eq (m
, SCM_INUM0
))
4750 report_overflow
= 1;
4754 if (!coerce_to_big (n
, n_tmp
))
4756 value_of_wrong_type
= n
;
4757 position_of_wrong_type
= 1;
4761 if (!coerce_to_big (k
, k_tmp
))
4763 value_of_wrong_type
= k
;
4764 position_of_wrong_type
= 2;
4768 if (!coerce_to_big (m
, m_tmp
))
4770 value_of_wrong_type
= m
;
4771 position_of_wrong_type
= 3;
4775 /* if the exponent K is negative, and we simply call mpz_powm, we
4776 will get a divide-by-zero exception when an inverse 1/n mod m
4777 doesn't exist (or is not unique). Since exceptions are hard to
4778 handle, we'll attempt the inversion "by hand" -- that way, we get
4779 a simple failure code, which is easy to handle. */
4781 if (-1 == mpz_sgn (k_tmp
))
4783 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4785 report_overflow
= 1;
4788 mpz_neg (k_tmp
, k_tmp
);
4791 result
= scm_i_mkbig ();
4792 mpz_powm (SCM_I_BIG_MPZ (result
),
4797 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4798 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4805 if (report_overflow
)
4806 scm_num_overflow (FUNC_NAME
);
4808 if (position_of_wrong_type
)
4809 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4810 value_of_wrong_type
);
4812 return scm_i_normbig (result
);
4816 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4818 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4819 "exact integer, @var{n} can be any number.\n"
4821 "Negative @var{k} is supported, and results in\n"
4822 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4823 "@math{@var{n}^0} is 1, as usual, and that\n"
4824 "includes @math{0^0} is 1.\n"
4827 "(integer-expt 2 5) @result{} 32\n"
4828 "(integer-expt -3 3) @result{} -27\n"
4829 "(integer-expt 5 -3) @result{} 1/125\n"
4830 "(integer-expt 0 0) @result{} 1\n"
4832 #define FUNC_NAME s_scm_integer_expt
4835 SCM z_i2
= SCM_BOOL_F
;
4837 SCM acc
= SCM_I_MAKINUM (1L);
4839 /* Specifically refrain from checking the type of the first argument.
4840 This allows us to exponentiate any object that can be multiplied.
4841 If we must raise to a negative power, we must also be able to
4842 take its reciprocal. */
4843 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4844 SCM_WRONG_TYPE_ARG (2, k
);
4846 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4847 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4848 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4849 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4850 /* The next check is necessary only because R6RS specifies different
4851 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4852 we simply skip this case and move on. */
4853 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4855 /* k cannot be 0 at this point, because we
4856 have already checked for that case above */
4857 if (scm_is_true (scm_positive_p (k
)))
4859 else /* return NaN for (0 ^ k) for negative k per R6RS */
4862 else if (SCM_FRACTIONP (n
))
4864 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4865 needless reduction of intermediate products to lowest terms.
4866 If a and b have no common factors, then a^k and b^k have no
4867 common factors. Use 'scm_i_make_ratio_already_reduced' to
4868 construct the final result, so that no gcd computations are
4869 needed to exponentiate a fraction. */
4870 if (scm_is_true (scm_positive_p (k
)))
4871 return scm_i_make_ratio_already_reduced
4872 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4873 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4876 k
= scm_difference (k
, SCM_UNDEFINED
);
4877 return scm_i_make_ratio_already_reduced
4878 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4879 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4883 if (SCM_I_INUMP (k
))
4884 i2
= SCM_I_INUM (k
);
4885 else if (SCM_BIGP (k
))
4887 z_i2
= scm_i_clonebig (k
, 1);
4888 scm_remember_upto_here_1 (k
);
4892 SCM_WRONG_TYPE_ARG (2, k
);
4896 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4898 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4899 n
= scm_divide (n
, SCM_UNDEFINED
);
4903 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4907 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4909 return scm_product (acc
, n
);
4911 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4912 acc
= scm_product (acc
, n
);
4913 n
= scm_product (n
, n
);
4914 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4922 n
= scm_divide (n
, SCM_UNDEFINED
);
4929 return scm_product (acc
, n
);
4931 acc
= scm_product (acc
, n
);
4932 n
= scm_product (n
, n
);
4939 /* Efficiently compute (N * 2^COUNT),
4940 where N is an exact integer, and COUNT > 0. */
4942 left_shift_exact_integer (SCM n
, long count
)
4944 if (SCM_I_INUMP (n
))
4946 scm_t_inum nn
= SCM_I_INUM (n
);
4948 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4949 overflow a non-zero fixnum. For smaller shifts we check the
4950 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4951 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4952 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4956 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4957 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4959 return SCM_I_MAKINUM (nn
<< count
);
4962 SCM result
= scm_i_inum2big (nn
);
4963 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4968 else if (SCM_BIGP (n
))
4970 SCM result
= scm_i_mkbig ();
4971 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
4972 scm_remember_upto_here_1 (n
);
4976 scm_syserror ("left_shift_exact_integer");
4979 /* Efficiently compute floor (N / 2^COUNT),
4980 where N is an exact integer and COUNT > 0. */
4982 floor_right_shift_exact_integer (SCM n
, long count
)
4984 if (SCM_I_INUMP (n
))
4986 scm_t_inum nn
= SCM_I_INUM (n
);
4988 if (count
>= SCM_I_FIXNUM_BIT
)
4989 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
4991 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
4993 else if (SCM_BIGP (n
))
4995 SCM result
= scm_i_mkbig ();
4996 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4998 scm_remember_upto_here_1 (n
);
4999 return scm_i_normbig (result
);
5002 scm_syserror ("floor_right_shift_exact_integer");
5005 /* Efficiently compute round (N / 2^COUNT),
5006 where N is an exact integer and COUNT > 0. */
5008 round_right_shift_exact_integer (SCM n
, long count
)
5010 if (SCM_I_INUMP (n
))
5012 if (count
>= SCM_I_FIXNUM_BIT
)
5016 scm_t_inum nn
= SCM_I_INUM (n
);
5017 scm_t_inum qq
= SCM_SRS (nn
, count
);
5019 if (0 == (nn
& (1L << (count
-1))))
5020 return SCM_I_MAKINUM (qq
); /* round down */
5021 else if (nn
& ((1L << (count
-1)) - 1))
5022 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5024 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5027 else if (SCM_BIGP (n
))
5029 SCM q
= scm_i_mkbig ();
5031 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5032 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5033 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5034 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5035 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5036 scm_remember_upto_here_1 (n
);
5037 return scm_i_normbig (q
);
5040 scm_syserror ("round_right_shift_exact_integer");
5043 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5045 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5046 "@var{n} and @var{count} must be exact integers.\n"
5048 "With @var{n} viewed as an infinite-precision twos-complement\n"
5049 "integer, @code{ash} means a left shift introducing zero bits\n"
5050 "when @var{count} is positive, or a right shift dropping bits\n"
5051 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5054 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5055 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5057 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5058 "(ash -23 -2) @result{} -6\n"
5060 #define FUNC_NAME s_scm_ash
5062 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5064 long bits_to_shift
= scm_to_long (count
);
5066 if (bits_to_shift
> 0)
5067 return left_shift_exact_integer (n
, bits_to_shift
);
5068 else if (SCM_LIKELY (bits_to_shift
< 0))
5069 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5074 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5078 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5080 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5081 "@var{n} and @var{count} must be exact integers.\n"
5083 "With @var{n} viewed as an infinite-precision twos-complement\n"
5084 "integer, @code{round-ash} means a left shift introducing zero\n"
5085 "bits when @var{count} is positive, or a right shift rounding\n"
5086 "to the nearest integer (with ties going to the nearest even\n"
5087 "integer) when @var{count} is negative. This is a rounded\n"
5088 "``arithmetic'' shift.\n"
5091 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5092 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5093 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5094 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5095 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5096 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5098 #define FUNC_NAME s_scm_round_ash
5100 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5102 long bits_to_shift
= scm_to_long (count
);
5104 if (bits_to_shift
> 0)
5105 return left_shift_exact_integer (n
, bits_to_shift
);
5106 else if (SCM_LIKELY (bits_to_shift
< 0))
5107 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5112 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5117 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5118 (SCM n
, SCM start
, SCM end
),
5119 "Return the integer composed of the @var{start} (inclusive)\n"
5120 "through @var{end} (exclusive) bits of @var{n}. The\n"
5121 "@var{start}th bit becomes the 0-th bit in the result.\n"
5124 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5125 " @result{} \"1010\"\n"
5126 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5127 " @result{} \"10110\"\n"
5129 #define FUNC_NAME s_scm_bit_extract
5131 unsigned long int istart
, iend
, bits
;
5132 istart
= scm_to_ulong (start
);
5133 iend
= scm_to_ulong (end
);
5134 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5136 /* how many bits to keep */
5137 bits
= iend
- istart
;
5139 if (SCM_I_INUMP (n
))
5141 scm_t_inum in
= SCM_I_INUM (n
);
5143 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5144 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5145 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5147 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5149 /* Since we emulate two's complement encoded numbers, this
5150 * special case requires us to produce a result that has
5151 * more bits than can be stored in a fixnum.
5153 SCM result
= scm_i_inum2big (in
);
5154 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5159 /* mask down to requisite bits */
5160 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5161 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5163 else if (SCM_BIGP (n
))
5168 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5172 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5173 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5174 such bits into a ulong. */
5175 result
= scm_i_mkbig ();
5176 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5177 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5178 result
= scm_i_normbig (result
);
5180 scm_remember_upto_here_1 (n
);
5184 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5189 static const char scm_logtab
[] = {
5190 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5193 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5195 "Return the number of bits in integer @var{n}. If integer is\n"
5196 "positive, the 1-bits in its binary representation are counted.\n"
5197 "If negative, the 0-bits in its two's-complement binary\n"
5198 "representation are counted. If 0, 0 is returned.\n"
5201 "(logcount #b10101010)\n"
5208 #define FUNC_NAME s_scm_logcount
5210 if (SCM_I_INUMP (n
))
5212 unsigned long c
= 0;
5213 scm_t_inum nn
= SCM_I_INUM (n
);
5218 c
+= scm_logtab
[15 & nn
];
5221 return SCM_I_MAKINUM (c
);
5223 else if (SCM_BIGP (n
))
5225 unsigned long count
;
5226 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5227 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5229 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5230 scm_remember_upto_here_1 (n
);
5231 return SCM_I_MAKINUM (count
);
5234 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5239 static const char scm_ilentab
[] = {
5240 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5244 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5246 "Return the number of bits necessary to represent @var{n}.\n"
5249 "(integer-length #b10101010)\n"
5251 "(integer-length 0)\n"
5253 "(integer-length #b1111)\n"
5256 #define FUNC_NAME s_scm_integer_length
5258 if (SCM_I_INUMP (n
))
5260 unsigned long c
= 0;
5262 scm_t_inum nn
= SCM_I_INUM (n
);
5268 l
= scm_ilentab
[15 & nn
];
5271 return SCM_I_MAKINUM (c
- 4 + l
);
5273 else if (SCM_BIGP (n
))
5275 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5276 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5277 1 too big, so check for that and adjust. */
5278 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5279 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5280 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5281 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5283 scm_remember_upto_here_1 (n
);
5284 return SCM_I_MAKINUM (size
);
5287 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5291 /*** NUMBERS -> STRINGS ***/
5292 #define SCM_MAX_DBL_RADIX 36
5294 /* use this array as a way to generate a single digit */
5295 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5297 static mpz_t dbl_minimum_normal_mantissa
;
5300 idbl2str (double dbl
, char *a
, int radix
)
5304 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5305 /* revert to existing behavior */
5310 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5320 else if (dbl
== 0.0)
5322 if (!double_is_non_negative_zero (dbl
))
5324 strcpy (a
+ ch
, "0.0");
5327 else if (isnan (dbl
))
5329 strcpy (a
, "+nan.0");
5333 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5334 Accurately" by Robert G. Burger and R. Kent Dybvig */
5337 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5338 int f_is_even
, f_is_odd
;
5342 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5343 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5344 if (e
< DBL_MIN_EXP
)
5346 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5351 f_is_even
= !mpz_odd_p (f
);
5352 f_is_odd
= !f_is_even
;
5354 /* Initialize r, s, mplus, and mminus according
5355 to Table 1 from the paper. */
5358 mpz_set_ui (mminus
, 1);
5359 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5360 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5362 mpz_set_ui (mplus
, 1);
5363 mpz_mul_2exp (r
, f
, 1);
5364 mpz_mul_2exp (s
, mminus
, 1 - e
);
5368 mpz_set_ui (mplus
, 2);
5369 mpz_mul_2exp (r
, f
, 2);
5370 mpz_mul_2exp (s
, mminus
, 2 - e
);
5375 mpz_set_ui (mminus
, 1);
5376 mpz_mul_2exp (mminus
, mminus
, e
);
5377 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5379 mpz_set (mplus
, mminus
);
5380 mpz_mul_2exp (r
, f
, 1 + e
);
5385 mpz_mul_2exp (mplus
, mminus
, 1);
5386 mpz_mul_2exp (r
, f
, 2 + e
);
5391 /* Find the smallest k such that:
5392 (r + mplus) / s < radix^k (if f is even)
5393 (r + mplus) / s <= radix^k (if f is odd) */
5395 /* IMPROVE-ME: Make an initial guess to speed this up */
5396 mpz_add (hi
, r
, mplus
);
5398 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5400 mpz_mul_ui (s
, s
, radix
);
5405 mpz_mul_ui (hi
, hi
, radix
);
5406 while (mpz_cmp (hi
, s
) < f_is_odd
)
5408 mpz_mul_ui (r
, r
, radix
);
5409 mpz_mul_ui (mplus
, mplus
, radix
);
5410 mpz_mul_ui (mminus
, mminus
, radix
);
5411 mpz_mul_ui (hi
, hi
, radix
);
5422 /* Use scientific notation */
5430 /* Print leading zeroes */
5433 for (i
= 0; i
> k
; i
--)
5440 int end_1_p
, end_2_p
;
5443 mpz_mul_ui (mplus
, mplus
, radix
);
5444 mpz_mul_ui (mminus
, mminus
, radix
);
5445 mpz_mul_ui (r
, r
, radix
);
5446 mpz_fdiv_qr (digit
, r
, r
, s
);
5447 d
= mpz_get_ui (digit
);
5449 mpz_add (hi
, r
, mplus
);
5450 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5451 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5452 if (end_1_p
|| end_2_p
)
5454 mpz_mul_2exp (r
, r
, 1);
5459 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5461 a
[ch
++] = number_chars
[d
];
5468 a
[ch
++] = number_chars
[d
];
5476 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5478 /* Here we would have to print more than three zeroes
5479 followed by a decimal point and another zero. It
5480 makes more sense to use scientific notation. */
5482 /* Adjust k to what it would have been if we had chosen
5483 scientific notation from the beginning. */
5486 /* k will now be <= 0, with magnitude equal to the number of
5487 digits that we printed which should now be put after the
5490 /* Insert a decimal point */
5491 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5511 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5514 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5521 icmplx2str (double real
, double imag
, char *str
, int radix
)
5526 i
= idbl2str (real
, str
, radix
);
5527 #ifdef HAVE_COPYSIGN
5528 sgn
= copysign (1.0, imag
);
5532 /* Don't output a '+' for negative numbers or for Inf and
5533 NaN. They will provide their own sign. */
5534 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5536 i
+= idbl2str (imag
, &str
[i
], radix
);
5542 iflo2str (SCM flt
, char *str
, int radix
)
5545 if (SCM_REALP (flt
))
5546 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5548 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5553 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5554 characters in the result.
5556 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5558 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5563 return scm_iuint2str (-num
, rad
, p
) + 1;
5566 return scm_iuint2str (num
, rad
, p
);
5569 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5570 characters in the result.
5572 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5574 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5578 scm_t_uintmax n
= num
;
5580 if (rad
< 2 || rad
> 36)
5581 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5583 for (n
/= rad
; n
> 0; n
/= rad
)
5593 p
[i
] = number_chars
[d
];
5598 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5600 "Return a string holding the external representation of the\n"
5601 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5602 "inexact, a radix of 10 will be used.")
5603 #define FUNC_NAME s_scm_number_to_string
5607 if (SCM_UNBNDP (radix
))
5610 base
= scm_to_signed_integer (radix
, 2, 36);
5612 if (SCM_I_INUMP (n
))
5614 char num_buf
[SCM_INTBUFLEN
];
5615 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5616 return scm_from_locale_stringn (num_buf
, length
);
5618 else if (SCM_BIGP (n
))
5620 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5621 size_t len
= strlen (str
);
5622 void (*freefunc
) (void *, size_t);
5624 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5625 scm_remember_upto_here_1 (n
);
5626 ret
= scm_from_latin1_stringn (str
, len
);
5627 freefunc (str
, len
+ 1);
5630 else if (SCM_FRACTIONP (n
))
5632 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5633 scm_from_locale_string ("/"),
5634 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5636 else if (SCM_INEXACTP (n
))
5638 char num_buf
[FLOBUFLEN
];
5639 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5642 SCM_WRONG_TYPE_ARG (1, n
);
5647 /* These print routines used to be stubbed here so that scm_repl.c
5648 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5651 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5653 char num_buf
[FLOBUFLEN
];
5654 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5659 scm_i_print_double (double val
, SCM port
)
5661 char num_buf
[FLOBUFLEN
];
5662 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5666 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5669 char num_buf
[FLOBUFLEN
];
5670 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5675 scm_i_print_complex (double real
, double imag
, SCM port
)
5677 char num_buf
[FLOBUFLEN
];
5678 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5682 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5685 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5686 scm_display (str
, port
);
5687 scm_remember_upto_here_1 (str
);
5692 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5694 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5695 size_t len
= strlen (str
);
5696 void (*freefunc
) (void *, size_t);
5697 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5698 scm_remember_upto_here_1 (exp
);
5699 scm_lfwrite (str
, len
, port
);
5700 freefunc (str
, len
+ 1);
5703 /*** END nums->strs ***/
5706 /*** STRINGS -> NUMBERS ***/
5708 /* The following functions implement the conversion from strings to numbers.
5709 * The implementation somehow follows the grammar for numbers as it is given
5710 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5711 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5712 * points should be noted about the implementation:
5714 * * Each function keeps a local index variable 'idx' that points at the
5715 * current position within the parsed string. The global index is only
5716 * updated if the function could parse the corresponding syntactic unit
5719 * * Similarly, the functions keep track of indicators of inexactness ('#',
5720 * '.' or exponents) using local variables ('hash_seen', 'x').
5722 * * Sequences of digits are parsed into temporary variables holding fixnums.
5723 * Only if these fixnums would overflow, the result variables are updated
5724 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5725 * the temporary variables holding the fixnums are cleared, and the process
5726 * starts over again. If for example fixnums were able to store five decimal
5727 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5728 * and the result was computed as 12345 * 100000 + 67890. In other words,
5729 * only every five digits two bignum operations were performed.
5731 * Notes on the handling of exactness specifiers:
5733 * When parsing non-real complex numbers, we apply exactness specifiers on
5734 * per-component basis, as is done in PLT Scheme. For complex numbers
5735 * written in rectangular form, exactness specifiers are applied to the
5736 * real and imaginary parts before calling scm_make_rectangular. For
5737 * complex numbers written in polar form, exactness specifiers are applied
5738 * to the magnitude and angle before calling scm_make_polar.
5740 * There are two kinds of exactness specifiers: forced and implicit. A
5741 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5742 * the entire number, and applies to both components of a complex number.
5743 * "#e" causes each component to be made exact, and "#i" causes each
5744 * component to be made inexact. If no forced exactness specifier is
5745 * present, then the exactness of each component is determined
5746 * independently by the presence or absence of a decimal point or hash mark
5747 * within that component. If a decimal point or hash mark is present, the
5748 * component is made inexact, otherwise it is made exact.
5750 * After the exactness specifiers have been applied to each component, they
5751 * are passed to either scm_make_rectangular or scm_make_polar to produce
5752 * the final result. Note that this will result in a real number if the
5753 * imaginary part, magnitude, or angle is an exact 0.
5755 * For example, (string->number "#i5.0+0i") does the equivalent of:
5757 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5760 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5762 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5764 /* Caller is responsible for checking that the return value is in range
5765 for the given radix, which should be <= 36. */
5767 char_decimal_value (scm_t_uint32 c
)
5769 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5770 that's certainly above any valid decimal, so we take advantage of
5771 that to elide some tests. */
5772 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5774 /* If that failed, try extended hexadecimals, then. Only accept ascii
5779 if (c
>= (scm_t_uint32
) 'a')
5780 d
= c
- (scm_t_uint32
)'a' + 10U;
5785 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5786 in base RADIX. Upon success, return the unsigned integer and update
5787 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5789 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5790 unsigned int radix
, enum t_exactness
*p_exactness
)
5792 unsigned int idx
= *p_idx
;
5793 unsigned int hash_seen
= 0;
5794 scm_t_bits shift
= 1;
5796 unsigned int digit_value
;
5799 size_t len
= scm_i_string_length (mem
);
5804 c
= scm_i_string_ref (mem
, idx
);
5805 digit_value
= char_decimal_value (c
);
5806 if (digit_value
>= radix
)
5810 result
= SCM_I_MAKINUM (digit_value
);
5813 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5823 digit_value
= char_decimal_value (c
);
5824 /* This check catches non-decimals in addition to out-of-range
5826 if (digit_value
>= radix
)
5831 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5833 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5835 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5842 shift
= shift
* radix
;
5843 add
= add
* radix
+ digit_value
;
5848 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5850 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5854 *p_exactness
= INEXACT
;
5860 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5861 * covers the parts of the rules that start at a potential point. The value
5862 * of the digits up to the point have been parsed by the caller and are given
5863 * in variable result. The content of *p_exactness indicates, whether a hash
5864 * has already been seen in the digits before the point.
5867 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5870 mem2decimal_from_point (SCM result
, SCM mem
,
5871 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5873 unsigned int idx
= *p_idx
;
5874 enum t_exactness x
= *p_exactness
;
5875 size_t len
= scm_i_string_length (mem
);
5880 if (scm_i_string_ref (mem
, idx
) == '.')
5882 scm_t_bits shift
= 1;
5884 unsigned int digit_value
;
5885 SCM big_shift
= SCM_INUM1
;
5890 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5891 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5896 digit_value
= DIGIT2UINT (c
);
5907 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5909 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5910 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5912 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5920 add
= add
* 10 + digit_value
;
5926 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5927 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5928 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5931 result
= scm_divide (result
, big_shift
);
5933 /* We've seen a decimal point, thus the value is implicitly inexact. */
5945 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5947 switch (scm_i_string_ref (mem
, idx
))
5959 c
= scm_i_string_ref (mem
, idx
);
5967 c
= scm_i_string_ref (mem
, idx
);
5976 c
= scm_i_string_ref (mem
, idx
);
5981 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5985 exponent
= DIGIT2UINT (c
);
5988 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5989 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5992 if (exponent
<= SCM_MAXEXP
)
5993 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5999 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6001 size_t exp_len
= idx
- start
;
6002 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6003 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6004 scm_out_of_range ("string->number", exp_num
);
6007 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6009 result
= scm_product (result
, e
);
6011 result
= scm_divide (result
, e
);
6013 /* We've seen an exponent, thus the value is implicitly inexact. */
6031 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6034 mem2ureal (SCM mem
, unsigned int *p_idx
,
6035 unsigned int radix
, enum t_exactness forced_x
,
6036 int allow_inf_or_nan
)
6038 unsigned int idx
= *p_idx
;
6040 size_t len
= scm_i_string_length (mem
);
6042 /* Start off believing that the number will be exact. This changes
6043 to INEXACT if we see a decimal point or a hash. */
6044 enum t_exactness implicit_x
= EXACT
;
6049 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6050 switch (scm_i_string_ref (mem
, idx
))
6053 switch (scm_i_string_ref (mem
, idx
+ 1))
6056 switch (scm_i_string_ref (mem
, idx
+ 2))
6059 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6060 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6068 switch (scm_i_string_ref (mem
, idx
+ 1))
6071 switch (scm_i_string_ref (mem
, idx
+ 2))
6074 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6076 /* Cobble up the fractional part. We might want to
6077 set the NaN's mantissa from it. */
6079 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6082 #if SCM_ENABLE_DEPRECATED == 1
6083 scm_c_issue_deprecation_warning
6084 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6097 if (scm_i_string_ref (mem
, idx
) == '.')
6101 else if (idx
+ 1 == len
)
6103 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6106 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6107 p_idx
, &implicit_x
);
6113 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6114 if (scm_is_false (uinteger
))
6119 else if (scm_i_string_ref (mem
, idx
) == '/')
6127 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6128 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6131 /* both are int/big here, I assume */
6132 result
= scm_i_make_ratio (uinteger
, divisor
);
6134 else if (radix
== 10)
6136 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6137 if (scm_is_false (result
))
6149 if (SCM_INEXACTP (result
))
6150 return scm_inexact_to_exact (result
);
6154 if (SCM_INEXACTP (result
))
6157 return scm_exact_to_inexact (result
);
6159 if (implicit_x
== INEXACT
)
6161 if (SCM_INEXACTP (result
))
6164 return scm_exact_to_inexact (result
);
6170 /* We should never get here */
6171 scm_syserror ("mem2ureal");
6175 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6178 mem2complex (SCM mem
, unsigned int idx
,
6179 unsigned int radix
, enum t_exactness forced_x
)
6184 size_t len
= scm_i_string_length (mem
);
6189 c
= scm_i_string_ref (mem
, idx
);
6204 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6205 if (scm_is_false (ureal
))
6207 /* input must be either +i or -i */
6212 if (scm_i_string_ref (mem
, idx
) == 'i'
6213 || scm_i_string_ref (mem
, idx
) == 'I')
6219 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6226 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6227 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6232 c
= scm_i_string_ref (mem
, idx
);
6236 /* either +<ureal>i or -<ureal>i */
6243 return scm_make_rectangular (SCM_INUM0
, ureal
);
6246 /* polar input: <real>@<real>. */
6257 c
= scm_i_string_ref (mem
, idx
);
6275 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6276 if (scm_is_false (angle
))
6281 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6282 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6284 result
= scm_make_polar (ureal
, angle
);
6289 /* expecting input matching <real>[+-]<ureal>?i */
6296 int sign
= (c
== '+') ? 1 : -1;
6297 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6299 if (scm_is_false (imag
))
6300 imag
= SCM_I_MAKINUM (sign
);
6301 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6302 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6306 if (scm_i_string_ref (mem
, idx
) != 'i'
6307 && scm_i_string_ref (mem
, idx
) != 'I')
6314 return scm_make_rectangular (ureal
, imag
);
6323 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6325 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6328 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6330 unsigned int idx
= 0;
6331 unsigned int radix
= NO_RADIX
;
6332 enum t_exactness forced_x
= NO_EXACTNESS
;
6333 size_t len
= scm_i_string_length (mem
);
6335 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6336 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6338 switch (scm_i_string_ref (mem
, idx
+ 1))
6341 if (radix
!= NO_RADIX
)
6346 if (radix
!= NO_RADIX
)
6351 if (forced_x
!= NO_EXACTNESS
)
6356 if (forced_x
!= NO_EXACTNESS
)
6361 if (radix
!= NO_RADIX
)
6366 if (radix
!= NO_RADIX
)
6376 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6377 if (radix
== NO_RADIX
)
6378 radix
= default_radix
;
6380 return mem2complex (mem
, idx
, radix
, forced_x
);
6384 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6385 unsigned int default_radix
)
6387 SCM str
= scm_from_locale_stringn (mem
, len
);
6389 return scm_i_string_to_number (str
, default_radix
);
6393 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6394 (SCM string
, SCM radix
),
6395 "Return a number of the maximally precise representation\n"
6396 "expressed by the given @var{string}. @var{radix} must be an\n"
6397 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6398 "is a default radix that may be overridden by an explicit radix\n"
6399 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6400 "supplied, then the default radix is 10. If string is not a\n"
6401 "syntactically valid notation for a number, then\n"
6402 "@code{string->number} returns @code{#f}.")
6403 #define FUNC_NAME s_scm_string_to_number
6407 SCM_VALIDATE_STRING (1, string
);
6409 if (SCM_UNBNDP (radix
))
6412 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6414 answer
= scm_i_string_to_number (string
, base
);
6415 scm_remember_upto_here_1 (string
);
6421 /*** END strs->nums ***/
6424 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6426 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6428 #define FUNC_NAME s_scm_number_p
6430 return scm_from_bool (SCM_NUMBERP (x
));
6434 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6436 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6437 "otherwise. Note that the sets of real, rational and integer\n"
6438 "values form subsets of the set of complex numbers, i. e. the\n"
6439 "predicate will also be fulfilled if @var{x} is a real,\n"
6440 "rational or integer number.")
6441 #define FUNC_NAME s_scm_complex_p
6443 /* all numbers are complex. */
6444 return scm_number_p (x
);
6448 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6450 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6451 "otherwise. Note that the set of integer values forms a subset of\n"
6452 "the set of real numbers, i. e. the predicate will also be\n"
6453 "fulfilled if @var{x} is an integer number.")
6454 #define FUNC_NAME s_scm_real_p
6456 return scm_from_bool
6457 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6461 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6463 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6464 "otherwise. Note that the set of integer values forms a subset of\n"
6465 "the set of rational numbers, i. e. the predicate will also be\n"
6466 "fulfilled if @var{x} is an integer number.")
6467 #define FUNC_NAME s_scm_rational_p
6469 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6471 else if (SCM_REALP (x
))
6472 /* due to their limited precision, finite floating point numbers are
6473 rational as well. (finite means neither infinity nor a NaN) */
6474 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6480 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6482 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6484 #define FUNC_NAME s_scm_integer_p
6486 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6488 else if (SCM_REALP (x
))
6490 double val
= SCM_REAL_VALUE (x
);
6491 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6499 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6500 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6501 (SCM x
, SCM y
, SCM rest
),
6502 "Return @code{#t} if all parameters are numerically equal.")
6503 #define FUNC_NAME s_scm_i_num_eq_p
6505 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6507 while (!scm_is_null (rest
))
6509 if (scm_is_false (scm_num_eq_p (x
, y
)))
6513 rest
= scm_cdr (rest
);
6515 return scm_num_eq_p (x
, y
);
6519 scm_num_eq_p (SCM x
, SCM y
)
6522 if (SCM_I_INUMP (x
))
6524 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6525 if (SCM_I_INUMP (y
))
6527 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6528 return scm_from_bool (xx
== yy
);
6530 else if (SCM_BIGP (y
))
6532 else if (SCM_REALP (y
))
6534 /* On a 32-bit system an inum fits a double, we can cast the inum
6535 to a double and compare.
6537 But on a 64-bit system an inum is bigger than a double and
6538 casting it to a double (call that dxx) will round. dxx is at
6539 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6540 an integer and fits a long. So we cast yy to a long and
6541 compare with plain xx.
6543 An alternative (for any size system actually) would be to check
6544 yy is an integer (with floor) and is in range of an inum
6545 (compare against appropriate powers of 2) then test
6546 xx==(scm_t_signed_bits)yy. It's just a matter of which
6547 casts/comparisons might be fastest or easiest for the cpu. */
6549 double yy
= SCM_REAL_VALUE (y
);
6550 return scm_from_bool ((double) xx
== yy
6551 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6552 || xx
== (scm_t_signed_bits
) yy
));
6554 else if (SCM_COMPLEXP (y
))
6555 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6556 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6557 else if (SCM_FRACTIONP (y
))
6560 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6562 else if (SCM_BIGP (x
))
6564 if (SCM_I_INUMP (y
))
6566 else if (SCM_BIGP (y
))
6568 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6569 scm_remember_upto_here_2 (x
, y
);
6570 return scm_from_bool (0 == cmp
);
6572 else if (SCM_REALP (y
))
6575 if (isnan (SCM_REAL_VALUE (y
)))
6577 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6578 scm_remember_upto_here_1 (x
);
6579 return scm_from_bool (0 == cmp
);
6581 else if (SCM_COMPLEXP (y
))
6584 if (0.0 != SCM_COMPLEX_IMAG (y
))
6586 if (isnan (SCM_COMPLEX_REAL (y
)))
6588 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6589 scm_remember_upto_here_1 (x
);
6590 return scm_from_bool (0 == cmp
);
6592 else if (SCM_FRACTIONP (y
))
6595 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6597 else if (SCM_REALP (x
))
6599 double xx
= SCM_REAL_VALUE (x
);
6600 if (SCM_I_INUMP (y
))
6602 /* see comments with inum/real above */
6603 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6604 return scm_from_bool (xx
== (double) yy
6605 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6606 || (scm_t_signed_bits
) xx
== yy
));
6608 else if (SCM_BIGP (y
))
6611 if (isnan (SCM_REAL_VALUE (x
)))
6613 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6614 scm_remember_upto_here_1 (y
);
6615 return scm_from_bool (0 == cmp
);
6617 else if (SCM_REALP (y
))
6618 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6619 else if (SCM_COMPLEXP (y
))
6620 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6621 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6622 else if (SCM_FRACTIONP (y
))
6624 double xx
= SCM_REAL_VALUE (x
);
6628 return scm_from_bool (xx
< 0.0);
6629 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6633 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6635 else if (SCM_COMPLEXP (x
))
6637 if (SCM_I_INUMP (y
))
6638 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6639 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6640 else if (SCM_BIGP (y
))
6643 if (0.0 != SCM_COMPLEX_IMAG (x
))
6645 if (isnan (SCM_COMPLEX_REAL (x
)))
6647 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6648 scm_remember_upto_here_1 (y
);
6649 return scm_from_bool (0 == cmp
);
6651 else if (SCM_REALP (y
))
6652 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6653 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6654 else if (SCM_COMPLEXP (y
))
6655 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6656 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6657 else if (SCM_FRACTIONP (y
))
6660 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6662 xx
= SCM_COMPLEX_REAL (x
);
6666 return scm_from_bool (xx
< 0.0);
6667 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6671 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6673 else if (SCM_FRACTIONP (x
))
6675 if (SCM_I_INUMP (y
))
6677 else if (SCM_BIGP (y
))
6679 else if (SCM_REALP (y
))
6681 double yy
= SCM_REAL_VALUE (y
);
6685 return scm_from_bool (0.0 < yy
);
6686 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6689 else if (SCM_COMPLEXP (y
))
6692 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6694 yy
= SCM_COMPLEX_REAL (y
);
6698 return scm_from_bool (0.0 < yy
);
6699 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6702 else if (SCM_FRACTIONP (y
))
6703 return scm_i_fraction_equalp (x
, y
);
6705 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6708 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6712 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6713 done are good for inums, but for bignums an answer can almost always be
6714 had by just examining a few high bits of the operands, as done by GMP in
6715 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6716 of the float exponent to take into account. */
6718 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6719 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6720 (SCM x
, SCM y
, SCM rest
),
6721 "Return @code{#t} if the list of parameters is monotonically\n"
6723 #define FUNC_NAME s_scm_i_num_less_p
6725 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6727 while (!scm_is_null (rest
))
6729 if (scm_is_false (scm_less_p (x
, y
)))
6733 rest
= scm_cdr (rest
);
6735 return scm_less_p (x
, y
);
6739 scm_less_p (SCM x
, SCM y
)
6742 if (SCM_I_INUMP (x
))
6744 scm_t_inum xx
= SCM_I_INUM (x
);
6745 if (SCM_I_INUMP (y
))
6747 scm_t_inum yy
= SCM_I_INUM (y
);
6748 return scm_from_bool (xx
< yy
);
6750 else if (SCM_BIGP (y
))
6752 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6753 scm_remember_upto_here_1 (y
);
6754 return scm_from_bool (sgn
> 0);
6756 else if (SCM_REALP (y
))
6757 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6758 else if (SCM_FRACTIONP (y
))
6760 /* "x < a/b" becomes "x*b < a" */
6762 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6763 y
= SCM_FRACTION_NUMERATOR (y
);
6767 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6769 else if (SCM_BIGP (x
))
6771 if (SCM_I_INUMP (y
))
6773 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6774 scm_remember_upto_here_1 (x
);
6775 return scm_from_bool (sgn
< 0);
6777 else if (SCM_BIGP (y
))
6779 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6780 scm_remember_upto_here_2 (x
, y
);
6781 return scm_from_bool (cmp
< 0);
6783 else if (SCM_REALP (y
))
6786 if (isnan (SCM_REAL_VALUE (y
)))
6788 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6789 scm_remember_upto_here_1 (x
);
6790 return scm_from_bool (cmp
< 0);
6792 else if (SCM_FRACTIONP (y
))
6795 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6797 else if (SCM_REALP (x
))
6799 if (SCM_I_INUMP (y
))
6800 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6801 else if (SCM_BIGP (y
))
6804 if (isnan (SCM_REAL_VALUE (x
)))
6806 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6807 scm_remember_upto_here_1 (y
);
6808 return scm_from_bool (cmp
> 0);
6810 else if (SCM_REALP (y
))
6811 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6812 else if (SCM_FRACTIONP (y
))
6814 double xx
= SCM_REAL_VALUE (x
);
6818 return scm_from_bool (xx
< 0.0);
6819 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6823 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6825 else if (SCM_FRACTIONP (x
))
6827 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6829 /* "a/b < y" becomes "a < y*b" */
6830 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6831 x
= SCM_FRACTION_NUMERATOR (x
);
6834 else if (SCM_REALP (y
))
6836 double yy
= SCM_REAL_VALUE (y
);
6840 return scm_from_bool (0.0 < yy
);
6841 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6844 else if (SCM_FRACTIONP (y
))
6846 /* "a/b < c/d" becomes "a*d < c*b" */
6847 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6848 SCM_FRACTION_DENOMINATOR (y
));
6849 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6850 SCM_FRACTION_DENOMINATOR (x
));
6856 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6859 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6863 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6864 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6865 (SCM x
, SCM y
, SCM rest
),
6866 "Return @code{#t} if the list of parameters is monotonically\n"
6868 #define FUNC_NAME s_scm_i_num_gr_p
6870 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6872 while (!scm_is_null (rest
))
6874 if (scm_is_false (scm_gr_p (x
, y
)))
6878 rest
= scm_cdr (rest
);
6880 return scm_gr_p (x
, y
);
6883 #define FUNC_NAME s_scm_i_num_gr_p
6885 scm_gr_p (SCM x
, SCM y
)
6887 if (!SCM_NUMBERP (x
))
6888 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6889 else if (!SCM_NUMBERP (y
))
6890 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6892 return scm_less_p (y
, x
);
6897 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6898 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6899 (SCM x
, SCM y
, SCM rest
),
6900 "Return @code{#t} if the list of parameters is monotonically\n"
6902 #define FUNC_NAME s_scm_i_num_leq_p
6904 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6906 while (!scm_is_null (rest
))
6908 if (scm_is_false (scm_leq_p (x
, y
)))
6912 rest
= scm_cdr (rest
);
6914 return scm_leq_p (x
, y
);
6917 #define FUNC_NAME s_scm_i_num_leq_p
6919 scm_leq_p (SCM x
, SCM y
)
6921 if (!SCM_NUMBERP (x
))
6922 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6923 else if (!SCM_NUMBERP (y
))
6924 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6925 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6928 return scm_not (scm_less_p (y
, x
));
6933 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6934 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6935 (SCM x
, SCM y
, SCM rest
),
6936 "Return @code{#t} if the list of parameters is monotonically\n"
6938 #define FUNC_NAME s_scm_i_num_geq_p
6940 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6942 while (!scm_is_null (rest
))
6944 if (scm_is_false (scm_geq_p (x
, y
)))
6948 rest
= scm_cdr (rest
);
6950 return scm_geq_p (x
, y
);
6953 #define FUNC_NAME s_scm_i_num_geq_p
6955 scm_geq_p (SCM x
, SCM y
)
6957 if (!SCM_NUMBERP (x
))
6958 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6959 else if (!SCM_NUMBERP (y
))
6960 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6961 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6964 return scm_not (scm_less_p (x
, y
));
6969 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6971 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6973 #define FUNC_NAME s_scm_zero_p
6975 if (SCM_I_INUMP (z
))
6976 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6977 else if (SCM_BIGP (z
))
6979 else if (SCM_REALP (z
))
6980 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6981 else if (SCM_COMPLEXP (z
))
6982 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6983 && SCM_COMPLEX_IMAG (z
) == 0.0);
6984 else if (SCM_FRACTIONP (z
))
6987 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6992 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6994 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6996 #define FUNC_NAME s_scm_positive_p
6998 if (SCM_I_INUMP (x
))
6999 return scm_from_bool (SCM_I_INUM (x
) > 0);
7000 else if (SCM_BIGP (x
))
7002 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7003 scm_remember_upto_here_1 (x
);
7004 return scm_from_bool (sgn
> 0);
7006 else if (SCM_REALP (x
))
7007 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7008 else if (SCM_FRACTIONP (x
))
7009 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7011 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7016 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7018 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7020 #define FUNC_NAME s_scm_negative_p
7022 if (SCM_I_INUMP (x
))
7023 return scm_from_bool (SCM_I_INUM (x
) < 0);
7024 else if (SCM_BIGP (x
))
7026 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7027 scm_remember_upto_here_1 (x
);
7028 return scm_from_bool (sgn
< 0);
7030 else if (SCM_REALP (x
))
7031 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7032 else if (SCM_FRACTIONP (x
))
7033 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7035 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7040 /* scm_min and scm_max return an inexact when either argument is inexact, as
7041 required by r5rs. On that basis, for exact/inexact combinations the
7042 exact is converted to inexact to compare and possibly return. This is
7043 unlike scm_less_p above which takes some trouble to preserve all bits in
7044 its test, such trouble is not required for min and max. */
7046 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7047 (SCM x
, SCM y
, SCM rest
),
7048 "Return the maximum of all parameter values.")
7049 #define FUNC_NAME s_scm_i_max
7051 while (!scm_is_null (rest
))
7052 { x
= scm_max (x
, y
);
7054 rest
= scm_cdr (rest
);
7056 return scm_max (x
, y
);
7060 #define s_max s_scm_i_max
7061 #define g_max g_scm_i_max
7064 scm_max (SCM x
, SCM y
)
7069 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7070 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7073 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7076 if (SCM_I_INUMP (x
))
7078 scm_t_inum xx
= SCM_I_INUM (x
);
7079 if (SCM_I_INUMP (y
))
7081 scm_t_inum yy
= SCM_I_INUM (y
);
7082 return (xx
< yy
) ? y
: x
;
7084 else if (SCM_BIGP (y
))
7086 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7087 scm_remember_upto_here_1 (y
);
7088 return (sgn
< 0) ? x
: y
;
7090 else if (SCM_REALP (y
))
7093 double yyd
= SCM_REAL_VALUE (y
);
7096 return scm_from_double (xxd
);
7097 /* If y is a NaN, then "==" is false and we return the NaN */
7098 else if (SCM_LIKELY (!(xxd
== yyd
)))
7100 /* Handle signed zeroes properly */
7106 else if (SCM_FRACTIONP (y
))
7109 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7112 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7114 else if (SCM_BIGP (x
))
7116 if (SCM_I_INUMP (y
))
7118 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7119 scm_remember_upto_here_1 (x
);
7120 return (sgn
< 0) ? y
: x
;
7122 else if (SCM_BIGP (y
))
7124 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7125 scm_remember_upto_here_2 (x
, y
);
7126 return (cmp
> 0) ? x
: y
;
7128 else if (SCM_REALP (y
))
7130 /* if y==NaN then xx>yy is false, so we return the NaN y */
7133 xx
= scm_i_big2dbl (x
);
7134 yy
= SCM_REAL_VALUE (y
);
7135 return (xx
> yy
? scm_from_double (xx
) : y
);
7137 else if (SCM_FRACTIONP (y
))
7142 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7144 else if (SCM_REALP (x
))
7146 if (SCM_I_INUMP (y
))
7148 scm_t_inum yy
= SCM_I_INUM (y
);
7149 double xxd
= SCM_REAL_VALUE (x
);
7153 return scm_from_double (yyd
);
7154 /* If x is a NaN, then "==" is false and we return the NaN */
7155 else if (SCM_LIKELY (!(xxd
== yyd
)))
7157 /* Handle signed zeroes properly */
7163 else if (SCM_BIGP (y
))
7168 else if (SCM_REALP (y
))
7170 double xx
= SCM_REAL_VALUE (x
);
7171 double yy
= SCM_REAL_VALUE (y
);
7173 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7176 else if (SCM_LIKELY (xx
< yy
))
7178 /* If neither (xx > yy) nor (xx < yy), then
7179 either they're equal or one is a NaN */
7180 else if (SCM_UNLIKELY (isnan (xx
)))
7181 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7182 else if (SCM_UNLIKELY (isnan (yy
)))
7183 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7184 /* xx == yy, but handle signed zeroes properly */
7185 else if (double_is_non_negative_zero (yy
))
7190 else if (SCM_FRACTIONP (y
))
7192 double yy
= scm_i_fraction2double (y
);
7193 double xx
= SCM_REAL_VALUE (x
);
7194 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7197 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7199 else if (SCM_FRACTIONP (x
))
7201 if (SCM_I_INUMP (y
))
7205 else if (SCM_BIGP (y
))
7209 else if (SCM_REALP (y
))
7211 double xx
= scm_i_fraction2double (x
);
7212 /* if y==NaN then ">" is false, so we return the NaN y */
7213 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7215 else if (SCM_FRACTIONP (y
))
7220 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7223 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7227 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7228 (SCM x
, SCM y
, SCM rest
),
7229 "Return the minimum of all parameter values.")
7230 #define FUNC_NAME s_scm_i_min
7232 while (!scm_is_null (rest
))
7233 { x
= scm_min (x
, y
);
7235 rest
= scm_cdr (rest
);
7237 return scm_min (x
, y
);
7241 #define s_min s_scm_i_min
7242 #define g_min g_scm_i_min
7245 scm_min (SCM x
, SCM y
)
7250 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7251 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7254 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7257 if (SCM_I_INUMP (x
))
7259 scm_t_inum xx
= SCM_I_INUM (x
);
7260 if (SCM_I_INUMP (y
))
7262 scm_t_inum yy
= SCM_I_INUM (y
);
7263 return (xx
< yy
) ? x
: y
;
7265 else if (SCM_BIGP (y
))
7267 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7268 scm_remember_upto_here_1 (y
);
7269 return (sgn
< 0) ? y
: x
;
7271 else if (SCM_REALP (y
))
7274 /* if y==NaN then "<" is false and we return NaN */
7275 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7277 else if (SCM_FRACTIONP (y
))
7280 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7283 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7285 else if (SCM_BIGP (x
))
7287 if (SCM_I_INUMP (y
))
7289 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7290 scm_remember_upto_here_1 (x
);
7291 return (sgn
< 0) ? x
: y
;
7293 else if (SCM_BIGP (y
))
7295 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7296 scm_remember_upto_here_2 (x
, y
);
7297 return (cmp
> 0) ? y
: x
;
7299 else if (SCM_REALP (y
))
7301 /* if y==NaN then xx<yy is false, so we return the NaN y */
7304 xx
= scm_i_big2dbl (x
);
7305 yy
= SCM_REAL_VALUE (y
);
7306 return (xx
< yy
? scm_from_double (xx
) : y
);
7308 else if (SCM_FRACTIONP (y
))
7313 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7315 else if (SCM_REALP (x
))
7317 if (SCM_I_INUMP (y
))
7319 double z
= SCM_I_INUM (y
);
7320 /* if x==NaN then "<" is false and we return NaN */
7321 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7323 else if (SCM_BIGP (y
))
7328 else if (SCM_REALP (y
))
7330 double xx
= SCM_REAL_VALUE (x
);
7331 double yy
= SCM_REAL_VALUE (y
);
7333 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7336 else if (SCM_LIKELY (xx
> yy
))
7338 /* If neither (xx < yy) nor (xx > yy), then
7339 either they're equal or one is a NaN */
7340 else if (SCM_UNLIKELY (isnan (xx
)))
7341 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7342 else if (SCM_UNLIKELY (isnan (yy
)))
7343 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7344 /* xx == yy, but handle signed zeroes properly */
7345 else if (double_is_non_negative_zero (xx
))
7350 else if (SCM_FRACTIONP (y
))
7352 double yy
= scm_i_fraction2double (y
);
7353 double xx
= SCM_REAL_VALUE (x
);
7354 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7357 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7359 else if (SCM_FRACTIONP (x
))
7361 if (SCM_I_INUMP (y
))
7365 else if (SCM_BIGP (y
))
7369 else if (SCM_REALP (y
))
7371 double xx
= scm_i_fraction2double (x
);
7372 /* if y==NaN then "<" is false, so we return the NaN y */
7373 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7375 else if (SCM_FRACTIONP (y
))
7380 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7383 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7387 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7388 (SCM x
, SCM y
, SCM rest
),
7389 "Return the sum of all parameter values. Return 0 if called without\n"
7391 #define FUNC_NAME s_scm_i_sum
7393 while (!scm_is_null (rest
))
7394 { x
= scm_sum (x
, y
);
7396 rest
= scm_cdr (rest
);
7398 return scm_sum (x
, y
);
7402 #define s_sum s_scm_i_sum
7403 #define g_sum g_scm_i_sum
7406 scm_sum (SCM x
, SCM y
)
7408 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7410 if (SCM_NUMBERP (x
)) return x
;
7411 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7412 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7415 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7417 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7419 scm_t_inum xx
= SCM_I_INUM (x
);
7420 scm_t_inum yy
= SCM_I_INUM (y
);
7421 scm_t_inum z
= xx
+ yy
;
7422 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7424 else if (SCM_BIGP (y
))
7429 else if (SCM_REALP (y
))
7431 scm_t_inum xx
= SCM_I_INUM (x
);
7432 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7434 else if (SCM_COMPLEXP (y
))
7436 scm_t_inum xx
= SCM_I_INUM (x
);
7437 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7438 SCM_COMPLEX_IMAG (y
));
7440 else if (SCM_FRACTIONP (y
))
7441 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7442 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7443 SCM_FRACTION_DENOMINATOR (y
));
7445 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7446 } else if (SCM_BIGP (x
))
7448 if (SCM_I_INUMP (y
))
7453 inum
= SCM_I_INUM (y
);
7456 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7459 SCM result
= scm_i_mkbig ();
7460 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7461 scm_remember_upto_here_1 (x
);
7462 /* we know the result will have to be a bignum */
7465 return scm_i_normbig (result
);
7469 SCM result
= scm_i_mkbig ();
7470 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7471 scm_remember_upto_here_1 (x
);
7472 /* we know the result will have to be a bignum */
7475 return scm_i_normbig (result
);
7478 else if (SCM_BIGP (y
))
7480 SCM result
= scm_i_mkbig ();
7481 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7482 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7483 mpz_add (SCM_I_BIG_MPZ (result
),
7486 scm_remember_upto_here_2 (x
, y
);
7487 /* we know the result will have to be a bignum */
7490 return scm_i_normbig (result
);
7492 else if (SCM_REALP (y
))
7494 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7495 scm_remember_upto_here_1 (x
);
7496 return scm_from_double (result
);
7498 else if (SCM_COMPLEXP (y
))
7500 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7501 + SCM_COMPLEX_REAL (y
));
7502 scm_remember_upto_here_1 (x
);
7503 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7505 else if (SCM_FRACTIONP (y
))
7506 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7507 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7508 SCM_FRACTION_DENOMINATOR (y
));
7510 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7512 else if (SCM_REALP (x
))
7514 if (SCM_I_INUMP (y
))
7515 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7516 else if (SCM_BIGP (y
))
7518 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7519 scm_remember_upto_here_1 (y
);
7520 return scm_from_double (result
);
7522 else if (SCM_REALP (y
))
7523 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7524 else if (SCM_COMPLEXP (y
))
7525 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7526 SCM_COMPLEX_IMAG (y
));
7527 else if (SCM_FRACTIONP (y
))
7528 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7530 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7532 else if (SCM_COMPLEXP (x
))
7534 if (SCM_I_INUMP (y
))
7535 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7536 SCM_COMPLEX_IMAG (x
));
7537 else if (SCM_BIGP (y
))
7539 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7540 + SCM_COMPLEX_REAL (x
));
7541 scm_remember_upto_here_1 (y
);
7542 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7544 else if (SCM_REALP (y
))
7545 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7546 SCM_COMPLEX_IMAG (x
));
7547 else if (SCM_COMPLEXP (y
))
7548 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7549 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7550 else if (SCM_FRACTIONP (y
))
7551 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7552 SCM_COMPLEX_IMAG (x
));
7554 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7556 else if (SCM_FRACTIONP (x
))
7558 if (SCM_I_INUMP (y
))
7559 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7560 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7561 SCM_FRACTION_DENOMINATOR (x
));
7562 else if (SCM_BIGP (y
))
7563 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7564 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7565 SCM_FRACTION_DENOMINATOR (x
));
7566 else if (SCM_REALP (y
))
7567 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7568 else if (SCM_COMPLEXP (y
))
7569 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7570 SCM_COMPLEX_IMAG (y
));
7571 else if (SCM_FRACTIONP (y
))
7572 /* a/b + c/d = (ad + bc) / bd */
7573 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7574 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7575 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7577 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7580 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7584 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7586 "Return @math{@var{x}+1}.")
7587 #define FUNC_NAME s_scm_oneplus
7589 return scm_sum (x
, SCM_INUM1
);
7594 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7595 (SCM x
, SCM y
, SCM rest
),
7596 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7597 "the sum of all but the first argument are subtracted from the first\n"
7599 #define FUNC_NAME s_scm_i_difference
7601 while (!scm_is_null (rest
))
7602 { x
= scm_difference (x
, y
);
7604 rest
= scm_cdr (rest
);
7606 return scm_difference (x
, y
);
7610 #define s_difference s_scm_i_difference
7611 #define g_difference g_scm_i_difference
7614 scm_difference (SCM x
, SCM y
)
7615 #define FUNC_NAME s_difference
7617 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7620 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7622 if (SCM_I_INUMP (x
))
7624 scm_t_inum xx
= -SCM_I_INUM (x
);
7625 if (SCM_FIXABLE (xx
))
7626 return SCM_I_MAKINUM (xx
);
7628 return scm_i_inum2big (xx
);
7630 else if (SCM_BIGP (x
))
7631 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7632 bignum, but negating that gives a fixnum. */
7633 return scm_i_normbig (scm_i_clonebig (x
, 0));
7634 else if (SCM_REALP (x
))
7635 return scm_from_double (-SCM_REAL_VALUE (x
));
7636 else if (SCM_COMPLEXP (x
))
7637 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7638 -SCM_COMPLEX_IMAG (x
));
7639 else if (SCM_FRACTIONP (x
))
7640 return scm_i_make_ratio_already_reduced
7641 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7642 SCM_FRACTION_DENOMINATOR (x
));
7644 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7647 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7649 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7651 scm_t_inum xx
= SCM_I_INUM (x
);
7652 scm_t_inum yy
= SCM_I_INUM (y
);
7653 scm_t_inum z
= xx
- yy
;
7654 if (SCM_FIXABLE (z
))
7655 return SCM_I_MAKINUM (z
);
7657 return scm_i_inum2big (z
);
7659 else if (SCM_BIGP (y
))
7661 /* inum-x - big-y */
7662 scm_t_inum xx
= SCM_I_INUM (x
);
7666 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7667 bignum, but negating that gives a fixnum. */
7668 return scm_i_normbig (scm_i_clonebig (y
, 0));
7672 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7673 SCM result
= scm_i_mkbig ();
7676 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7679 /* x - y == -(y + -x) */
7680 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7681 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7683 scm_remember_upto_here_1 (y
);
7685 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7686 /* we know the result will have to be a bignum */
7689 return scm_i_normbig (result
);
7692 else if (SCM_REALP (y
))
7694 scm_t_inum xx
= SCM_I_INUM (x
);
7697 * We need to handle x == exact 0
7698 * specially because R6RS states that:
7699 * (- 0.0) ==> -0.0 and
7700 * (- 0.0 0.0) ==> 0.0
7701 * and the scheme compiler changes
7702 * (- 0.0) into (- 0 0.0)
7703 * So we need to treat (- 0 0.0) like (- 0.0).
7704 * At the C level, (-x) is different than (0.0 - x).
7705 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7708 return scm_from_double (- SCM_REAL_VALUE (y
));
7710 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7712 else if (SCM_COMPLEXP (y
))
7714 scm_t_inum xx
= SCM_I_INUM (x
);
7716 /* We need to handle x == exact 0 specially.
7717 See the comment above (for SCM_REALP (y)) */
7719 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7720 - SCM_COMPLEX_IMAG (y
));
7722 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7723 - SCM_COMPLEX_IMAG (y
));
7725 else if (SCM_FRACTIONP (y
))
7726 /* a - b/c = (ac - b) / c */
7727 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7728 SCM_FRACTION_NUMERATOR (y
)),
7729 SCM_FRACTION_DENOMINATOR (y
));
7731 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7733 else if (SCM_BIGP (x
))
7735 if (SCM_I_INUMP (y
))
7737 /* big-x - inum-y */
7738 scm_t_inum yy
= SCM_I_INUM (y
);
7739 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7741 scm_remember_upto_here_1 (x
);
7743 return (SCM_FIXABLE (-yy
) ?
7744 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7747 SCM result
= scm_i_mkbig ();
7750 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7752 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7753 scm_remember_upto_here_1 (x
);
7755 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7756 /* we know the result will have to be a bignum */
7759 return scm_i_normbig (result
);
7762 else if (SCM_BIGP (y
))
7764 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7765 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7766 SCM result
= scm_i_mkbig ();
7767 mpz_sub (SCM_I_BIG_MPZ (result
),
7770 scm_remember_upto_here_2 (x
, y
);
7771 /* we know the result will have to be a bignum */
7772 if ((sgn_x
== 1) && (sgn_y
== -1))
7774 if ((sgn_x
== -1) && (sgn_y
== 1))
7776 return scm_i_normbig (result
);
7778 else if (SCM_REALP (y
))
7780 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7781 scm_remember_upto_here_1 (x
);
7782 return scm_from_double (result
);
7784 else if (SCM_COMPLEXP (y
))
7786 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7787 - SCM_COMPLEX_REAL (y
));
7788 scm_remember_upto_here_1 (x
);
7789 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7791 else if (SCM_FRACTIONP (y
))
7792 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7793 SCM_FRACTION_NUMERATOR (y
)),
7794 SCM_FRACTION_DENOMINATOR (y
));
7795 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7797 else if (SCM_REALP (x
))
7799 if (SCM_I_INUMP (y
))
7800 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7801 else if (SCM_BIGP (y
))
7803 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7804 scm_remember_upto_here_1 (x
);
7805 return scm_from_double (result
);
7807 else if (SCM_REALP (y
))
7808 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7809 else if (SCM_COMPLEXP (y
))
7810 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7811 -SCM_COMPLEX_IMAG (y
));
7812 else if (SCM_FRACTIONP (y
))
7813 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7815 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7817 else if (SCM_COMPLEXP (x
))
7819 if (SCM_I_INUMP (y
))
7820 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7821 SCM_COMPLEX_IMAG (x
));
7822 else if (SCM_BIGP (y
))
7824 double real_part
= (SCM_COMPLEX_REAL (x
)
7825 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7826 scm_remember_upto_here_1 (x
);
7827 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7829 else if (SCM_REALP (y
))
7830 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7831 SCM_COMPLEX_IMAG (x
));
7832 else if (SCM_COMPLEXP (y
))
7833 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7834 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7835 else if (SCM_FRACTIONP (y
))
7836 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7837 SCM_COMPLEX_IMAG (x
));
7839 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7841 else if (SCM_FRACTIONP (x
))
7843 if (SCM_I_INUMP (y
))
7844 /* a/b - c = (a - cb) / b */
7845 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7846 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7847 SCM_FRACTION_DENOMINATOR (x
));
7848 else if (SCM_BIGP (y
))
7849 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7850 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7851 SCM_FRACTION_DENOMINATOR (x
));
7852 else if (SCM_REALP (y
))
7853 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7854 else if (SCM_COMPLEXP (y
))
7855 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7856 -SCM_COMPLEX_IMAG (y
));
7857 else if (SCM_FRACTIONP (y
))
7858 /* a/b - c/d = (ad - bc) / bd */
7859 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7860 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7861 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7863 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7866 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7871 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7873 "Return @math{@var{x}-1}.")
7874 #define FUNC_NAME s_scm_oneminus
7876 return scm_difference (x
, SCM_INUM1
);
7881 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7882 (SCM x
, SCM y
, SCM rest
),
7883 "Return the product of all arguments. If called without arguments,\n"
7885 #define FUNC_NAME s_scm_i_product
7887 while (!scm_is_null (rest
))
7888 { x
= scm_product (x
, y
);
7890 rest
= scm_cdr (rest
);
7892 return scm_product (x
, y
);
7896 #define s_product s_scm_i_product
7897 #define g_product g_scm_i_product
7900 scm_product (SCM x
, SCM y
)
7902 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7905 return SCM_I_MAKINUM (1L);
7906 else if (SCM_NUMBERP (x
))
7909 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7912 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7917 xx
= SCM_I_INUM (x
);
7922 /* exact1 is the universal multiplicative identity */
7926 /* exact0 times a fixnum is exact0: optimize this case */
7927 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7929 /* if the other argument is inexact, the result is inexact,
7930 and we must do the multiplication in order to handle
7931 infinities and NaNs properly. */
7932 else if (SCM_REALP (y
))
7933 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7934 else if (SCM_COMPLEXP (y
))
7935 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7936 0.0 * SCM_COMPLEX_IMAG (y
));
7937 /* we've already handled inexact numbers,
7938 so y must be exact, and we return exact0 */
7939 else if (SCM_NUMP (y
))
7942 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7946 * This case is important for more than just optimization.
7947 * It handles the case of negating
7948 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7949 * which is a bignum that must be changed back into a fixnum.
7950 * Failure to do so will cause the following to return #f:
7951 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7953 return scm_difference(y
, SCM_UNDEFINED
);
7957 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7959 scm_t_inum yy
= SCM_I_INUM (y
);
7960 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7961 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7962 if (SCM_FIXABLE (kk
))
7963 return SCM_I_MAKINUM (kk
);
7965 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7966 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7967 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7968 return SCM_I_MAKINUM (xx
* yy
);
7972 SCM result
= scm_i_inum2big (xx
);
7973 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7974 return scm_i_normbig (result
);
7977 else if (SCM_BIGP (y
))
7979 SCM result
= scm_i_mkbig ();
7980 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7981 scm_remember_upto_here_1 (y
);
7984 else if (SCM_REALP (y
))
7985 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7986 else if (SCM_COMPLEXP (y
))
7987 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7988 xx
* SCM_COMPLEX_IMAG (y
));
7989 else if (SCM_FRACTIONP (y
))
7990 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7991 SCM_FRACTION_DENOMINATOR (y
));
7993 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7995 else if (SCM_BIGP (x
))
7997 if (SCM_I_INUMP (y
))
8002 else if (SCM_BIGP (y
))
8004 SCM result
= scm_i_mkbig ();
8005 mpz_mul (SCM_I_BIG_MPZ (result
),
8008 scm_remember_upto_here_2 (x
, y
);
8011 else if (SCM_REALP (y
))
8013 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8014 scm_remember_upto_here_1 (x
);
8015 return scm_from_double (result
);
8017 else if (SCM_COMPLEXP (y
))
8019 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8020 scm_remember_upto_here_1 (x
);
8021 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8022 z
* SCM_COMPLEX_IMAG (y
));
8024 else if (SCM_FRACTIONP (y
))
8025 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8026 SCM_FRACTION_DENOMINATOR (y
));
8028 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8030 else if (SCM_REALP (x
))
8032 if (SCM_I_INUMP (y
))
8037 else if (SCM_BIGP (y
))
8039 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8040 scm_remember_upto_here_1 (y
);
8041 return scm_from_double (result
);
8043 else if (SCM_REALP (y
))
8044 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8045 else if (SCM_COMPLEXP (y
))
8046 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8047 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8048 else if (SCM_FRACTIONP (y
))
8049 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8051 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8053 else if (SCM_COMPLEXP (x
))
8055 if (SCM_I_INUMP (y
))
8060 else if (SCM_BIGP (y
))
8062 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8063 scm_remember_upto_here_1 (y
);
8064 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8065 z
* SCM_COMPLEX_IMAG (x
));
8067 else if (SCM_REALP (y
))
8068 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8069 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8070 else if (SCM_COMPLEXP (y
))
8072 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8073 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8074 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8075 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8077 else if (SCM_FRACTIONP (y
))
8079 double yy
= scm_i_fraction2double (y
);
8080 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8081 yy
* SCM_COMPLEX_IMAG (x
));
8084 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8086 else if (SCM_FRACTIONP (x
))
8088 if (SCM_I_INUMP (y
))
8089 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8090 SCM_FRACTION_DENOMINATOR (x
));
8091 else if (SCM_BIGP (y
))
8092 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8093 SCM_FRACTION_DENOMINATOR (x
));
8094 else if (SCM_REALP (y
))
8095 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8096 else if (SCM_COMPLEXP (y
))
8098 double xx
= scm_i_fraction2double (x
);
8099 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8100 xx
* SCM_COMPLEX_IMAG (y
));
8102 else if (SCM_FRACTIONP (y
))
8103 /* a/b * c/d = ac / bd */
8104 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8105 SCM_FRACTION_NUMERATOR (y
)),
8106 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8107 SCM_FRACTION_DENOMINATOR (y
)));
8109 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8112 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8115 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8116 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8117 #define ALLOW_DIVIDE_BY_ZERO
8118 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8121 /* The code below for complex division is adapted from the GNU
8122 libstdc++, which adapted it from f2c's libF77, and is subject to
8125 /****************************************************************
8126 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8128 Permission to use, copy, modify, and distribute this software
8129 and its documentation for any purpose and without fee is hereby
8130 granted, provided that the above copyright notice appear in all
8131 copies and that both that the copyright notice and this
8132 permission notice and warranty disclaimer appear in supporting
8133 documentation, and that the names of AT&T Bell Laboratories or
8134 Bellcore or any of their entities not be used in advertising or
8135 publicity pertaining to distribution of the software without
8136 specific, written prior permission.
8138 AT&T and Bellcore disclaim all warranties with regard to this
8139 software, including all implied warranties of merchantability
8140 and fitness. In no event shall AT&T or Bellcore be liable for
8141 any special, indirect or consequential damages or any damages
8142 whatsoever resulting from loss of use, data or profits, whether
8143 in an action of contract, negligence or other tortious action,
8144 arising out of or in connection with the use or performance of
8146 ****************************************************************/
8148 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8149 (SCM x
, SCM y
, SCM rest
),
8150 "Divide the first argument by the product of the remaining\n"
8151 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8153 #define FUNC_NAME s_scm_i_divide
8155 while (!scm_is_null (rest
))
8156 { x
= scm_divide (x
, y
);
8158 rest
= scm_cdr (rest
);
8160 return scm_divide (x
, y
);
8164 #define s_divide s_scm_i_divide
8165 #define g_divide g_scm_i_divide
8168 scm_divide (SCM x
, SCM y
)
8169 #define FUNC_NAME s_divide
8173 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8176 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8177 else if (SCM_I_INUMP (x
))
8179 scm_t_inum xx
= SCM_I_INUM (x
);
8180 if (xx
== 1 || xx
== -1)
8182 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8184 scm_num_overflow (s_divide
);
8187 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8189 else if (SCM_BIGP (x
))
8190 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8191 else if (SCM_REALP (x
))
8193 double xx
= SCM_REAL_VALUE (x
);
8194 #ifndef ALLOW_DIVIDE_BY_ZERO
8196 scm_num_overflow (s_divide
);
8199 return scm_from_double (1.0 / xx
);
8201 else if (SCM_COMPLEXP (x
))
8203 double r
= SCM_COMPLEX_REAL (x
);
8204 double i
= SCM_COMPLEX_IMAG (x
);
8205 if (fabs(r
) <= fabs(i
))
8208 double d
= i
* (1.0 + t
* t
);
8209 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8214 double d
= r
* (1.0 + t
* t
);
8215 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8218 else if (SCM_FRACTIONP (x
))
8219 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8220 SCM_FRACTION_NUMERATOR (x
));
8222 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8225 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8227 scm_t_inum xx
= SCM_I_INUM (x
);
8228 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8230 scm_t_inum yy
= SCM_I_INUM (y
);
8233 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8234 scm_num_overflow (s_divide
);
8236 return scm_from_double ((double) xx
/ (double) yy
);
8239 else if (xx
% yy
!= 0)
8240 return scm_i_make_ratio (x
, y
);
8243 scm_t_inum z
= xx
/ yy
;
8244 if (SCM_FIXABLE (z
))
8245 return SCM_I_MAKINUM (z
);
8247 return scm_i_inum2big (z
);
8250 else if (SCM_BIGP (y
))
8251 return scm_i_make_ratio (x
, y
);
8252 else if (SCM_REALP (y
))
8254 double yy
= SCM_REAL_VALUE (y
);
8255 #ifndef ALLOW_DIVIDE_BY_ZERO
8257 scm_num_overflow (s_divide
);
8260 /* FIXME: Precision may be lost here due to:
8261 (1) The cast from 'scm_t_inum' to 'double'
8262 (2) Double rounding */
8263 return scm_from_double ((double) xx
/ yy
);
8265 else if (SCM_COMPLEXP (y
))
8268 complex_div
: /* y _must_ be a complex number */
8270 double r
= SCM_COMPLEX_REAL (y
);
8271 double i
= SCM_COMPLEX_IMAG (y
);
8272 if (fabs(r
) <= fabs(i
))
8275 double d
= i
* (1.0 + t
* t
);
8276 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8281 double d
= r
* (1.0 + t
* t
);
8282 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8286 else if (SCM_FRACTIONP (y
))
8287 /* a / b/c = ac / b */
8288 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8289 SCM_FRACTION_NUMERATOR (y
));
8291 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8293 else if (SCM_BIGP (x
))
8295 if (SCM_I_INUMP (y
))
8297 scm_t_inum yy
= SCM_I_INUM (y
);
8300 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8301 scm_num_overflow (s_divide
);
8303 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8304 scm_remember_upto_here_1 (x
);
8305 return (sgn
== 0) ? scm_nan () : scm_inf ();
8312 /* FIXME: HMM, what are the relative performance issues here?
8313 We need to test. Is it faster on average to test
8314 divisible_p, then perform whichever operation, or is it
8315 faster to perform the integer div opportunistically and
8316 switch to real if there's a remainder? For now we take the
8317 middle ground: test, then if divisible, use the faster div
8320 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8321 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8325 SCM result
= scm_i_mkbig ();
8326 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8327 scm_remember_upto_here_1 (x
);
8329 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8330 return scm_i_normbig (result
);
8333 return scm_i_make_ratio (x
, y
);
8336 else if (SCM_BIGP (y
))
8338 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8342 SCM result
= scm_i_mkbig ();
8343 mpz_divexact (SCM_I_BIG_MPZ (result
),
8346 scm_remember_upto_here_2 (x
, y
);
8347 return scm_i_normbig (result
);
8350 return scm_i_make_ratio (x
, y
);
8352 else if (SCM_REALP (y
))
8354 double yy
= SCM_REAL_VALUE (y
);
8355 #ifndef ALLOW_DIVIDE_BY_ZERO
8357 scm_num_overflow (s_divide
);
8360 /* FIXME: Precision may be lost here due to:
8361 (1) scm_i_big2dbl (2) Double rounding */
8362 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8364 else if (SCM_COMPLEXP (y
))
8366 a
= scm_i_big2dbl (x
);
8369 else if (SCM_FRACTIONP (y
))
8370 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8371 SCM_FRACTION_NUMERATOR (y
));
8373 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8375 else if (SCM_REALP (x
))
8377 double rx
= SCM_REAL_VALUE (x
);
8378 if (SCM_I_INUMP (y
))
8380 scm_t_inum yy
= SCM_I_INUM (y
);
8381 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8383 scm_num_overflow (s_divide
);
8386 /* FIXME: Precision may be lost here due to:
8387 (1) The cast from 'scm_t_inum' to 'double'
8388 (2) Double rounding */
8389 return scm_from_double (rx
/ (double) yy
);
8391 else if (SCM_BIGP (y
))
8393 /* FIXME: Precision may be lost here due to:
8394 (1) The conversion from bignum to double
8395 (2) Double rounding */
8396 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8397 scm_remember_upto_here_1 (y
);
8398 return scm_from_double (rx
/ dby
);
8400 else if (SCM_REALP (y
))
8402 double yy
= SCM_REAL_VALUE (y
);
8403 #ifndef ALLOW_DIVIDE_BY_ZERO
8405 scm_num_overflow (s_divide
);
8408 return scm_from_double (rx
/ yy
);
8410 else if (SCM_COMPLEXP (y
))
8415 else if (SCM_FRACTIONP (y
))
8416 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8418 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8420 else if (SCM_COMPLEXP (x
))
8422 double rx
= SCM_COMPLEX_REAL (x
);
8423 double ix
= SCM_COMPLEX_IMAG (x
);
8424 if (SCM_I_INUMP (y
))
8426 scm_t_inum yy
= SCM_I_INUM (y
);
8427 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8429 scm_num_overflow (s_divide
);
8433 /* FIXME: Precision may be lost here due to:
8434 (1) The conversion from 'scm_t_inum' to double
8435 (2) Double rounding */
8437 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8440 else if (SCM_BIGP (y
))
8442 /* FIXME: Precision may be lost here due to:
8443 (1) The conversion from bignum to double
8444 (2) Double rounding */
8445 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8446 scm_remember_upto_here_1 (y
);
8447 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8449 else if (SCM_REALP (y
))
8451 double yy
= SCM_REAL_VALUE (y
);
8452 #ifndef ALLOW_DIVIDE_BY_ZERO
8454 scm_num_overflow (s_divide
);
8457 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8459 else if (SCM_COMPLEXP (y
))
8461 double ry
= SCM_COMPLEX_REAL (y
);
8462 double iy
= SCM_COMPLEX_IMAG (y
);
8463 if (fabs(ry
) <= fabs(iy
))
8466 double d
= iy
* (1.0 + t
* t
);
8467 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8472 double d
= ry
* (1.0 + t
* t
);
8473 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8476 else if (SCM_FRACTIONP (y
))
8478 /* FIXME: Precision may be lost here due to:
8479 (1) The conversion from fraction to double
8480 (2) Double rounding */
8481 double yy
= scm_i_fraction2double (y
);
8482 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8485 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8487 else if (SCM_FRACTIONP (x
))
8489 if (SCM_I_INUMP (y
))
8491 scm_t_inum yy
= SCM_I_INUM (y
);
8492 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8494 scm_num_overflow (s_divide
);
8497 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8498 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8500 else if (SCM_BIGP (y
))
8502 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8503 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8505 else if (SCM_REALP (y
))
8507 double yy
= SCM_REAL_VALUE (y
);
8508 #ifndef ALLOW_DIVIDE_BY_ZERO
8510 scm_num_overflow (s_divide
);
8513 /* FIXME: Precision may be lost here due to:
8514 (1) The conversion from fraction to double
8515 (2) Double rounding */
8516 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8518 else if (SCM_COMPLEXP (y
))
8520 /* FIXME: Precision may be lost here due to:
8521 (1) The conversion from fraction to double
8522 (2) Double rounding */
8523 a
= scm_i_fraction2double (x
);
8526 else if (SCM_FRACTIONP (y
))
8527 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8528 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8530 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8533 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8539 scm_c_truncate (double x
)
8544 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8545 half-way case (ie. when x is an integer plus 0.5) going upwards.
8546 Then half-way cases are identified and adjusted down if the
8547 round-upwards didn't give the desired even integer.
8549 "plus_half == result" identifies a half-way case. If plus_half, which is
8550 x + 0.5, is an integer then x must be an integer plus 0.5.
8552 An odd "result" value is identified with result/2 != floor(result/2).
8553 This is done with plus_half, since that value is ready for use sooner in
8554 a pipelined cpu, and we're already requiring plus_half == result.
8556 Note however that we need to be careful when x is big and already an
8557 integer. In that case "x+0.5" may round to an adjacent integer, causing
8558 us to return such a value, incorrectly. For instance if the hardware is
8559 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8560 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8561 returned. Or if the hardware is in round-upwards mode, then other bigger
8562 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8563 representable value, 2^128+2^76 (or whatever), again incorrect.
8565 These bad roundings of x+0.5 are avoided by testing at the start whether
8566 x is already an integer. If it is then clearly that's the desired result
8567 already. And if it's not then the exponent must be small enough to allow
8568 an 0.5 to be represented, and hence added without a bad rounding. */
8571 scm_c_round (double x
)
8573 double plus_half
, result
;
8578 plus_half
= x
+ 0.5;
8579 result
= floor (plus_half
);
8580 /* Adjust so that the rounding is towards even. */
8581 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8586 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8588 "Round the number @var{x} towards zero.")
8589 #define FUNC_NAME s_scm_truncate_number
8591 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8593 else if (SCM_REALP (x
))
8594 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8595 else if (SCM_FRACTIONP (x
))
8596 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8597 SCM_FRACTION_DENOMINATOR (x
));
8599 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8600 s_scm_truncate_number
);
8604 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8606 "Round the number @var{x} towards the nearest integer. "
8607 "When it is exactly halfway between two integers, "
8608 "round towards the even one.")
8609 #define FUNC_NAME s_scm_round_number
8611 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8613 else if (SCM_REALP (x
))
8614 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8615 else if (SCM_FRACTIONP (x
))
8616 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8617 SCM_FRACTION_DENOMINATOR (x
));
8619 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8620 s_scm_round_number
);
8624 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8626 "Round the number @var{x} towards minus infinity.")
8627 #define FUNC_NAME s_scm_floor
8629 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8631 else if (SCM_REALP (x
))
8632 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8633 else if (SCM_FRACTIONP (x
))
8634 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8635 SCM_FRACTION_DENOMINATOR (x
));
8637 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8641 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8643 "Round the number @var{x} towards infinity.")
8644 #define FUNC_NAME s_scm_ceiling
8646 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8648 else if (SCM_REALP (x
))
8649 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8650 else if (SCM_FRACTIONP (x
))
8651 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8652 SCM_FRACTION_DENOMINATOR (x
));
8654 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8658 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8660 "Return @var{x} raised to the power of @var{y}.")
8661 #define FUNC_NAME s_scm_expt
8663 if (scm_is_integer (y
))
8665 if (scm_is_true (scm_exact_p (y
)))
8666 return scm_integer_expt (x
, y
);
8669 /* Here we handle the case where the exponent is an inexact
8670 integer. We make the exponent exact in order to use
8671 scm_integer_expt, and thus avoid the spurious imaginary
8672 parts that may result from round-off errors in the general
8673 e^(y log x) method below (for example when squaring a large
8674 negative number). In this case, we must return an inexact
8675 result for correctness. We also make the base inexact so
8676 that scm_integer_expt will use fast inexact arithmetic
8677 internally. Note that making the base inexact is not
8678 sufficient to guarantee an inexact result, because
8679 scm_integer_expt will return an exact 1 when the exponent
8680 is 0, even if the base is inexact. */
8681 return scm_exact_to_inexact
8682 (scm_integer_expt (scm_exact_to_inexact (x
),
8683 scm_inexact_to_exact (y
)));
8686 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8688 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8690 else if (scm_is_complex (x
) && scm_is_complex (y
))
8691 return scm_exp (scm_product (scm_log (x
), y
));
8692 else if (scm_is_complex (x
))
8693 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8695 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8699 /* sin/cos/tan/asin/acos/atan
8700 sinh/cosh/tanh/asinh/acosh/atanh
8701 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8702 Written by Jerry D. Hedden, (C) FSF.
8703 See the file `COPYING' for terms applying to this program. */
8705 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8707 "Compute the sine of @var{z}.")
8708 #define FUNC_NAME s_scm_sin
8710 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8711 return z
; /* sin(exact0) = exact0 */
8712 else if (scm_is_real (z
))
8713 return scm_from_double (sin (scm_to_double (z
)));
8714 else if (SCM_COMPLEXP (z
))
8716 x
= SCM_COMPLEX_REAL (z
);
8717 y
= SCM_COMPLEX_IMAG (z
);
8718 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8719 cos (x
) * sinh (y
));
8722 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8726 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8728 "Compute the cosine of @var{z}.")
8729 #define FUNC_NAME s_scm_cos
8731 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8732 return SCM_INUM1
; /* cos(exact0) = exact1 */
8733 else if (scm_is_real (z
))
8734 return scm_from_double (cos (scm_to_double (z
)));
8735 else if (SCM_COMPLEXP (z
))
8737 x
= SCM_COMPLEX_REAL (z
);
8738 y
= SCM_COMPLEX_IMAG (z
);
8739 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8740 -sin (x
) * sinh (y
));
8743 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8747 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8749 "Compute the tangent of @var{z}.")
8750 #define FUNC_NAME s_scm_tan
8752 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8753 return z
; /* tan(exact0) = exact0 */
8754 else if (scm_is_real (z
))
8755 return scm_from_double (tan (scm_to_double (z
)));
8756 else if (SCM_COMPLEXP (z
))
8758 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8759 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8760 w
= cos (x
) + cosh (y
);
8761 #ifndef ALLOW_DIVIDE_BY_ZERO
8763 scm_num_overflow (s_scm_tan
);
8765 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8768 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8772 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8774 "Compute the hyperbolic sine of @var{z}.")
8775 #define FUNC_NAME s_scm_sinh
8777 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8778 return z
; /* sinh(exact0) = exact0 */
8779 else if (scm_is_real (z
))
8780 return scm_from_double (sinh (scm_to_double (z
)));
8781 else if (SCM_COMPLEXP (z
))
8783 x
= SCM_COMPLEX_REAL (z
);
8784 y
= SCM_COMPLEX_IMAG (z
);
8785 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8786 cosh (x
) * sin (y
));
8789 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8793 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8795 "Compute the hyperbolic cosine of @var{z}.")
8796 #define FUNC_NAME s_scm_cosh
8798 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8799 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8800 else if (scm_is_real (z
))
8801 return scm_from_double (cosh (scm_to_double (z
)));
8802 else if (SCM_COMPLEXP (z
))
8804 x
= SCM_COMPLEX_REAL (z
);
8805 y
= SCM_COMPLEX_IMAG (z
);
8806 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8807 sinh (x
) * sin (y
));
8810 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8814 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8816 "Compute the hyperbolic tangent of @var{z}.")
8817 #define FUNC_NAME s_scm_tanh
8819 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8820 return z
; /* tanh(exact0) = exact0 */
8821 else if (scm_is_real (z
))
8822 return scm_from_double (tanh (scm_to_double (z
)));
8823 else if (SCM_COMPLEXP (z
))
8825 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8826 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8827 w
= cosh (x
) + cos (y
);
8828 #ifndef ALLOW_DIVIDE_BY_ZERO
8830 scm_num_overflow (s_scm_tanh
);
8832 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8835 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8839 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8841 "Compute the arc sine of @var{z}.")
8842 #define FUNC_NAME s_scm_asin
8844 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8845 return z
; /* asin(exact0) = exact0 */
8846 else if (scm_is_real (z
))
8848 double w
= scm_to_double (z
);
8849 if (w
>= -1.0 && w
<= 1.0)
8850 return scm_from_double (asin (w
));
8852 return scm_product (scm_c_make_rectangular (0, -1),
8853 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8855 else if (SCM_COMPLEXP (z
))
8857 x
= SCM_COMPLEX_REAL (z
);
8858 y
= SCM_COMPLEX_IMAG (z
);
8859 return scm_product (scm_c_make_rectangular (0, -1),
8860 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8863 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8867 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8869 "Compute the arc cosine of @var{z}.")
8870 #define FUNC_NAME s_scm_acos
8872 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8873 return SCM_INUM0
; /* acos(exact1) = exact0 */
8874 else if (scm_is_real (z
))
8876 double w
= scm_to_double (z
);
8877 if (w
>= -1.0 && w
<= 1.0)
8878 return scm_from_double (acos (w
));
8880 return scm_sum (scm_from_double (acos (0.0)),
8881 scm_product (scm_c_make_rectangular (0, 1),
8882 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8884 else if (SCM_COMPLEXP (z
))
8886 x
= SCM_COMPLEX_REAL (z
);
8887 y
= SCM_COMPLEX_IMAG (z
);
8888 return scm_sum (scm_from_double (acos (0.0)),
8889 scm_product (scm_c_make_rectangular (0, 1),
8890 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8893 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8897 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8899 "With one argument, compute the arc tangent of @var{z}.\n"
8900 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8901 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8902 #define FUNC_NAME s_scm_atan
8906 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8907 return z
; /* atan(exact0) = exact0 */
8908 else if (scm_is_real (z
))
8909 return scm_from_double (atan (scm_to_double (z
)));
8910 else if (SCM_COMPLEXP (z
))
8913 v
= SCM_COMPLEX_REAL (z
);
8914 w
= SCM_COMPLEX_IMAG (z
);
8915 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8916 scm_c_make_rectangular (v
, w
+ 1.0))),
8917 scm_c_make_rectangular (0, 2));
8920 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8922 else if (scm_is_real (z
))
8924 if (scm_is_real (y
))
8925 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8927 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8930 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8934 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8936 "Compute the inverse hyperbolic sine of @var{z}.")
8937 #define FUNC_NAME s_scm_sys_asinh
8939 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8940 return z
; /* asinh(exact0) = exact0 */
8941 else if (scm_is_real (z
))
8942 return scm_from_double (asinh (scm_to_double (z
)));
8943 else if (scm_is_number (z
))
8944 return scm_log (scm_sum (z
,
8945 scm_sqrt (scm_sum (scm_product (z
, z
),
8948 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8952 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8954 "Compute the inverse hyperbolic cosine of @var{z}.")
8955 #define FUNC_NAME s_scm_sys_acosh
8957 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8958 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8959 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8960 return scm_from_double (acosh (scm_to_double (z
)));
8961 else if (scm_is_number (z
))
8962 return scm_log (scm_sum (z
,
8963 scm_sqrt (scm_difference (scm_product (z
, z
),
8966 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8970 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8972 "Compute the inverse hyperbolic tangent of @var{z}.")
8973 #define FUNC_NAME s_scm_sys_atanh
8975 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8976 return z
; /* atanh(exact0) = exact0 */
8977 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8978 return scm_from_double (atanh (scm_to_double (z
)));
8979 else if (scm_is_number (z
))
8980 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8981 scm_difference (SCM_INUM1
, z
))),
8984 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8989 scm_c_make_rectangular (double re
, double im
)
8993 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8995 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8996 SCM_COMPLEX_REAL (z
) = re
;
8997 SCM_COMPLEX_IMAG (z
) = im
;
9001 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9002 (SCM real_part
, SCM imaginary_part
),
9003 "Return a complex number constructed of the given @var{real_part} "
9004 "and @var{imaginary_part} parts.")
9005 #define FUNC_NAME s_scm_make_rectangular
9007 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9008 SCM_ARG1
, FUNC_NAME
, "real");
9009 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9010 SCM_ARG2
, FUNC_NAME
, "real");
9012 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9013 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9016 return scm_c_make_rectangular (scm_to_double (real_part
),
9017 scm_to_double (imaginary_part
));
9022 scm_c_make_polar (double mag
, double ang
)
9026 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9027 use it on Glibc-based systems that have it (it's a GNU extension). See
9028 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9030 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9031 sincos (ang
, &s
, &c
);
9037 /* If s and c are NaNs, this indicates that the angle is a NaN,
9038 infinite, or perhaps simply too large to determine its value
9039 mod 2*pi. However, we know something that the floating-point
9040 implementation doesn't know: We know that s and c are finite.
9041 Therefore, if the magnitude is zero, return a complex zero.
9043 The reason we check for the NaNs instead of using this case
9044 whenever mag == 0.0 is because when the angle is known, we'd
9045 like to return the correct kind of non-real complex zero:
9046 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9047 on which quadrant the angle is in.
9049 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9050 return scm_c_make_rectangular (0.0, 0.0);
9052 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9055 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9057 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9058 #define FUNC_NAME s_scm_make_polar
9060 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9061 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9063 /* If mag is exact0, return exact0 */
9064 if (scm_is_eq (mag
, SCM_INUM0
))
9066 /* Return a real if ang is exact0 */
9067 else if (scm_is_eq (ang
, SCM_INUM0
))
9070 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9075 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9077 "Return the real part of the number @var{z}.")
9078 #define FUNC_NAME s_scm_real_part
9080 if (SCM_COMPLEXP (z
))
9081 return scm_from_double (SCM_COMPLEX_REAL (z
));
9082 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9085 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9090 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9092 "Return the imaginary part of the number @var{z}.")
9093 #define FUNC_NAME s_scm_imag_part
9095 if (SCM_COMPLEXP (z
))
9096 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9097 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9100 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9104 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9106 "Return the numerator of the number @var{z}.")
9107 #define FUNC_NAME s_scm_numerator
9109 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9111 else if (SCM_FRACTIONP (z
))
9112 return SCM_FRACTION_NUMERATOR (z
);
9113 else if (SCM_REALP (z
))
9114 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9116 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9121 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9123 "Return the denominator of the number @var{z}.")
9124 #define FUNC_NAME s_scm_denominator
9126 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9128 else if (SCM_FRACTIONP (z
))
9129 return SCM_FRACTION_DENOMINATOR (z
);
9130 else if (SCM_REALP (z
))
9131 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9133 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9138 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9140 "Return the magnitude of the number @var{z}. This is the same as\n"
9141 "@code{abs} for real arguments, but also allows complex numbers.")
9142 #define FUNC_NAME s_scm_magnitude
9144 if (SCM_I_INUMP (z
))
9146 scm_t_inum zz
= SCM_I_INUM (z
);
9149 else if (SCM_POSFIXABLE (-zz
))
9150 return SCM_I_MAKINUM (-zz
);
9152 return scm_i_inum2big (-zz
);
9154 else if (SCM_BIGP (z
))
9156 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9157 scm_remember_upto_here_1 (z
);
9159 return scm_i_clonebig (z
, 0);
9163 else if (SCM_REALP (z
))
9164 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9165 else if (SCM_COMPLEXP (z
))
9166 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9167 else if (SCM_FRACTIONP (z
))
9169 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9171 return scm_i_make_ratio_already_reduced
9172 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9173 SCM_FRACTION_DENOMINATOR (z
));
9176 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9181 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9183 "Return the angle of the complex number @var{z}.")
9184 #define FUNC_NAME s_scm_angle
9186 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9187 flo0 to save allocating a new flonum with scm_from_double each time.
9188 But if atan2 follows the floating point rounding mode, then the value
9189 is not a constant. Maybe it'd be close enough though. */
9190 if (SCM_I_INUMP (z
))
9192 if (SCM_I_INUM (z
) >= 0)
9195 return scm_from_double (atan2 (0.0, -1.0));
9197 else if (SCM_BIGP (z
))
9199 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9200 scm_remember_upto_here_1 (z
);
9202 return scm_from_double (atan2 (0.0, -1.0));
9206 else if (SCM_REALP (z
))
9208 double x
= SCM_REAL_VALUE (z
);
9209 if (x
> 0.0 || double_is_non_negative_zero (x
))
9212 return scm_from_double (atan2 (0.0, -1.0));
9214 else if (SCM_COMPLEXP (z
))
9215 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9216 else if (SCM_FRACTIONP (z
))
9218 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9220 else return scm_from_double (atan2 (0.0, -1.0));
9223 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9228 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9230 "Convert the number @var{z} to its inexact representation.\n")
9231 #define FUNC_NAME s_scm_exact_to_inexact
9233 if (SCM_I_INUMP (z
))
9234 return scm_from_double ((double) SCM_I_INUM (z
));
9235 else if (SCM_BIGP (z
))
9236 return scm_from_double (scm_i_big2dbl (z
));
9237 else if (SCM_FRACTIONP (z
))
9238 return scm_from_double (scm_i_fraction2double (z
));
9239 else if (SCM_INEXACTP (z
))
9242 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9247 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9249 "Return an exact number that is numerically closest to @var{z}.")
9250 #define FUNC_NAME s_scm_inexact_to_exact
9252 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9259 val
= SCM_REAL_VALUE (z
);
9260 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9261 val
= SCM_COMPLEX_REAL (z
);
9263 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9265 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9266 SCM_OUT_OF_RANGE (1, z
);
9267 else if (val
== 0.0)
9274 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9276 expon
-= DBL_MANT_DIG
;
9279 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9283 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9284 SCM_I_BIG_MPZ (numerator
),
9288 numerator
= scm_i_normbig (numerator
);
9290 return scm_i_make_ratio_already_reduced
9291 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9293 return left_shift_exact_integer (numerator
, expon
);
9301 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9303 "Returns the @emph{simplest} rational number differing\n"
9304 "from @var{x} by no more than @var{eps}.\n"
9306 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9307 "exact result when both its arguments are exact. Thus, you might need\n"
9308 "to use @code{inexact->exact} on the arguments.\n"
9311 "(rationalize (inexact->exact 1.2) 1/100)\n"
9314 #define FUNC_NAME s_scm_rationalize
9316 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9317 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9318 eps
= scm_abs (eps
);
9319 if (scm_is_false (scm_positive_p (eps
)))
9321 /* eps is either zero or a NaN */
9322 if (scm_is_true (scm_nan_p (eps
)))
9324 else if (SCM_INEXACTP (eps
))
9325 return scm_exact_to_inexact (x
);
9329 else if (scm_is_false (scm_finite_p (eps
)))
9331 if (scm_is_true (scm_finite_p (x
)))
9336 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9338 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9339 scm_ceiling (scm_difference (x
, eps
)))))
9341 /* There's an integer within range; we want the one closest to zero */
9342 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9344 /* zero is within range */
9345 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9350 else if (scm_is_true (scm_positive_p (x
)))
9351 return scm_ceiling (scm_difference (x
, eps
));
9353 return scm_floor (scm_sum (x
, eps
));
9357 /* Use continued fractions to find closest ratio. All
9358 arithmetic is done with exact numbers.
9361 SCM ex
= scm_inexact_to_exact (x
);
9362 SCM int_part
= scm_floor (ex
);
9364 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9365 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9369 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9370 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9372 /* We stop after a million iterations just to be absolutely sure
9373 that we don't go into an infinite loop. The process normally
9374 converges after less than a dozen iterations.
9377 while (++i
< 1000000)
9379 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9380 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9381 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9383 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9384 eps
))) /* abs(x-a/b) <= eps */
9386 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9387 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9388 return scm_exact_to_inexact (res
);
9392 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9394 tt
= scm_floor (rx
); /* tt = floor (rx) */
9400 scm_num_overflow (s_scm_rationalize
);
9405 /* conversion functions */
9408 scm_is_integer (SCM val
)
9410 return scm_is_true (scm_integer_p (val
));
9414 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9416 if (SCM_I_INUMP (val
))
9418 scm_t_signed_bits n
= SCM_I_INUM (val
);
9419 return n
>= min
&& n
<= max
;
9421 else if (SCM_BIGP (val
))
9423 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9425 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9427 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9429 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9430 return n
>= min
&& n
<= max
;
9440 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9441 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9444 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9445 SCM_I_BIG_MPZ (val
));
9447 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9459 return n
>= min
&& n
<= max
;
9467 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9469 if (SCM_I_INUMP (val
))
9471 scm_t_signed_bits n
= SCM_I_INUM (val
);
9472 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9474 else if (SCM_BIGP (val
))
9476 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9478 else if (max
<= ULONG_MAX
)
9480 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9482 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9483 return n
>= min
&& n
<= max
;
9493 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9496 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9497 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9500 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9501 SCM_I_BIG_MPZ (val
));
9503 return n
>= min
&& n
<= max
;
9511 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9513 scm_error (scm_out_of_range_key
,
9515 "Value out of range ~S to ~S: ~S",
9516 scm_list_3 (min
, max
, bad_val
),
9517 scm_list_1 (bad_val
));
9520 #define TYPE scm_t_intmax
9521 #define TYPE_MIN min
9522 #define TYPE_MAX max
9523 #define SIZEOF_TYPE 0
9524 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9525 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9526 #include "libguile/conv-integer.i.c"
9528 #define TYPE scm_t_uintmax
9529 #define TYPE_MIN min
9530 #define TYPE_MAX max
9531 #define SIZEOF_TYPE 0
9532 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9533 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9534 #include "libguile/conv-uinteger.i.c"
9536 #define TYPE scm_t_int8
9537 #define TYPE_MIN SCM_T_INT8_MIN
9538 #define TYPE_MAX SCM_T_INT8_MAX
9539 #define SIZEOF_TYPE 1
9540 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9541 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9542 #include "libguile/conv-integer.i.c"
9544 #define TYPE scm_t_uint8
9546 #define TYPE_MAX SCM_T_UINT8_MAX
9547 #define SIZEOF_TYPE 1
9548 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9549 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9550 #include "libguile/conv-uinteger.i.c"
9552 #define TYPE scm_t_int16
9553 #define TYPE_MIN SCM_T_INT16_MIN
9554 #define TYPE_MAX SCM_T_INT16_MAX
9555 #define SIZEOF_TYPE 2
9556 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9557 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9558 #include "libguile/conv-integer.i.c"
9560 #define TYPE scm_t_uint16
9562 #define TYPE_MAX SCM_T_UINT16_MAX
9563 #define SIZEOF_TYPE 2
9564 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9565 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9566 #include "libguile/conv-uinteger.i.c"
9568 #define TYPE scm_t_int32
9569 #define TYPE_MIN SCM_T_INT32_MIN
9570 #define TYPE_MAX SCM_T_INT32_MAX
9571 #define SIZEOF_TYPE 4
9572 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9573 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9574 #include "libguile/conv-integer.i.c"
9576 #define TYPE scm_t_uint32
9578 #define TYPE_MAX SCM_T_UINT32_MAX
9579 #define SIZEOF_TYPE 4
9580 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9581 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9582 #include "libguile/conv-uinteger.i.c"
9584 #define TYPE scm_t_wchar
9585 #define TYPE_MIN (scm_t_int32)-1
9586 #define TYPE_MAX (scm_t_int32)0x10ffff
9587 #define SIZEOF_TYPE 4
9588 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9589 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9590 #include "libguile/conv-integer.i.c"
9592 #define TYPE scm_t_int64
9593 #define TYPE_MIN SCM_T_INT64_MIN
9594 #define TYPE_MAX SCM_T_INT64_MAX
9595 #define SIZEOF_TYPE 8
9596 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9597 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9598 #include "libguile/conv-integer.i.c"
9600 #define TYPE scm_t_uint64
9602 #define TYPE_MAX SCM_T_UINT64_MAX
9603 #define SIZEOF_TYPE 8
9604 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9605 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9606 #include "libguile/conv-uinteger.i.c"
9609 scm_to_mpz (SCM val
, mpz_t rop
)
9611 if (SCM_I_INUMP (val
))
9612 mpz_set_si (rop
, SCM_I_INUM (val
));
9613 else if (SCM_BIGP (val
))
9614 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9616 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9620 scm_from_mpz (mpz_t val
)
9622 return scm_i_mpz2num (val
);
9626 scm_is_real (SCM val
)
9628 return scm_is_true (scm_real_p (val
));
9632 scm_is_rational (SCM val
)
9634 return scm_is_true (scm_rational_p (val
));
9638 scm_to_double (SCM val
)
9640 if (SCM_I_INUMP (val
))
9641 return SCM_I_INUM (val
);
9642 else if (SCM_BIGP (val
))
9643 return scm_i_big2dbl (val
);
9644 else if (SCM_FRACTIONP (val
))
9645 return scm_i_fraction2double (val
);
9646 else if (SCM_REALP (val
))
9647 return SCM_REAL_VALUE (val
);
9649 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9653 scm_from_double (double val
)
9657 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9659 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9660 SCM_REAL_VALUE (z
) = val
;
9665 #if SCM_ENABLE_DEPRECATED == 1
9668 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9670 scm_c_issue_deprecation_warning
9671 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9675 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9679 scm_out_of_range (NULL
, num
);
9682 return scm_to_double (num
);
9686 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9688 scm_c_issue_deprecation_warning
9689 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9693 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9697 scm_out_of_range (NULL
, num
);
9700 return scm_to_double (num
);
9706 scm_is_complex (SCM val
)
9708 return scm_is_true (scm_complex_p (val
));
9712 scm_c_real_part (SCM z
)
9714 if (SCM_COMPLEXP (z
))
9715 return SCM_COMPLEX_REAL (z
);
9718 /* Use the scm_real_part to get proper error checking and
9721 return scm_to_double (scm_real_part (z
));
9726 scm_c_imag_part (SCM z
)
9728 if (SCM_COMPLEXP (z
))
9729 return SCM_COMPLEX_IMAG (z
);
9732 /* Use the scm_imag_part to get proper error checking and
9733 dispatching. The result will almost always be 0.0, but not
9736 return scm_to_double (scm_imag_part (z
));
9741 scm_c_magnitude (SCM z
)
9743 return scm_to_double (scm_magnitude (z
));
9749 return scm_to_double (scm_angle (z
));
9753 scm_is_number (SCM z
)
9755 return scm_is_true (scm_number_p (z
));
9759 /* Returns log(x * 2^shift) */
9761 log_of_shifted_double (double x
, long shift
)
9763 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9765 if (x
> 0.0 || double_is_non_negative_zero (x
))
9766 return scm_from_double (ans
);
9768 return scm_c_make_rectangular (ans
, M_PI
);
9771 /* Returns log(n), for exact integer n */
9773 log_of_exact_integer (SCM n
)
9775 if (SCM_I_INUMP (n
))
9776 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9777 else if (SCM_BIGP (n
))
9780 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9781 return log_of_shifted_double (signif
, expon
);
9784 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9787 /* Returns log(n/d), for exact non-zero integers n and d */
9789 log_of_fraction (SCM n
, SCM d
)
9791 long n_size
= scm_to_long (scm_integer_length (n
));
9792 long d_size
= scm_to_long (scm_integer_length (d
));
9794 if (abs (n_size
- d_size
) > 1)
9795 return (scm_difference (log_of_exact_integer (n
),
9796 log_of_exact_integer (d
)));
9797 else if (scm_is_false (scm_negative_p (n
)))
9798 return scm_from_double
9799 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9801 return scm_c_make_rectangular
9802 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9808 /* In the following functions we dispatch to the real-arg funcs like log()
9809 when we know the arg is real, instead of just handing everything to
9810 clog() for instance. This is in case clog() doesn't optimize for a
9811 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9812 well use it to go straight to the applicable C func. */
9814 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9816 "Return the natural logarithm of @var{z}.")
9817 #define FUNC_NAME s_scm_log
9819 if (SCM_COMPLEXP (z
))
9821 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9822 && defined (SCM_COMPLEX_VALUE)
9823 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9825 double re
= SCM_COMPLEX_REAL (z
);
9826 double im
= SCM_COMPLEX_IMAG (z
);
9827 return scm_c_make_rectangular (log (hypot (re
, im
)),
9831 else if (SCM_REALP (z
))
9832 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9833 else if (SCM_I_INUMP (z
))
9835 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9836 if (scm_is_eq (z
, SCM_INUM0
))
9837 scm_num_overflow (s_scm_log
);
9839 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9841 else if (SCM_BIGP (z
))
9842 return log_of_exact_integer (z
);
9843 else if (SCM_FRACTIONP (z
))
9844 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9845 SCM_FRACTION_DENOMINATOR (z
));
9847 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9852 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9854 "Return the base 10 logarithm of @var{z}.")
9855 #define FUNC_NAME s_scm_log10
9857 if (SCM_COMPLEXP (z
))
9859 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9860 clog() and a multiply by M_LOG10E, rather than the fallback
9861 log10+hypot+atan2.) */
9862 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9863 && defined SCM_COMPLEX_VALUE
9864 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9866 double re
= SCM_COMPLEX_REAL (z
);
9867 double im
= SCM_COMPLEX_IMAG (z
);
9868 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9869 M_LOG10E
* atan2 (im
, re
));
9872 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9874 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9875 if (scm_is_eq (z
, SCM_INUM0
))
9876 scm_num_overflow (s_scm_log10
);
9879 double re
= scm_to_double (z
);
9880 double l
= log10 (fabs (re
));
9881 if (re
> 0.0 || double_is_non_negative_zero (re
))
9882 return scm_from_double (l
);
9884 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9887 else if (SCM_BIGP (z
))
9888 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9889 else if (SCM_FRACTIONP (z
))
9890 return scm_product (flo_log10e
,
9891 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9892 SCM_FRACTION_DENOMINATOR (z
)));
9894 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9899 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9901 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9902 "base of natural logarithms (2.71828@dots{}).")
9903 #define FUNC_NAME s_scm_exp
9905 if (SCM_COMPLEXP (z
))
9907 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9908 && defined (SCM_COMPLEX_VALUE)
9909 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9911 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9912 SCM_COMPLEX_IMAG (z
));
9915 else if (SCM_NUMBERP (z
))
9917 /* When z is a negative bignum the conversion to double overflows,
9918 giving -infinity, but that's ok, the exp is still 0.0. */
9919 return scm_from_double (exp (scm_to_double (z
)));
9922 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9927 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9929 "Return two exact non-negative integers @var{s} and @var{r}\n"
9930 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9931 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9932 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9935 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9937 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9941 scm_exact_integer_sqrt (k
, &s
, &r
);
9942 return scm_values (scm_list_2 (s
, r
));
9947 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9949 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9953 if (SCM_I_INUM (k
) < 0)
9954 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9955 "exact non-negative integer");
9956 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
9957 mpz_inits (ss
, rr
, NULL
);
9958 mpz_sqrtrem (ss
, rr
, kk
);
9959 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
9960 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
9961 mpz_clears (kk
, ss
, rr
, NULL
);
9963 else if (SCM_LIKELY (SCM_BIGP (k
)))
9967 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9968 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9969 "exact non-negative integer");
9972 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9973 scm_remember_upto_here_1 (k
);
9974 *sp
= scm_i_normbig (s
);
9975 *rp
= scm_i_normbig (r
);
9978 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9979 "exact non-negative integer");
9982 /* Return true iff K is a perfect square.
9983 K must be an exact integer. */
9985 exact_integer_is_perfect_square (SCM k
)
9989 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9993 mpz_init_set_si (kk
, SCM_I_INUM (k
));
9994 result
= mpz_perfect_square_p (kk
);
9999 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10000 scm_remember_upto_here_1 (k
);
10005 /* Return the floor of the square root of K.
10006 K must be an exact integer. */
10008 exact_integer_floor_square_root (SCM k
)
10010 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10015 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10017 ss
= mpz_get_ui (kk
);
10019 return SCM_I_MAKINUM (ss
);
10025 s
= scm_i_mkbig ();
10026 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10027 scm_remember_upto_here_1 (k
);
10028 return scm_i_normbig (s
);
10033 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10035 "Return the square root of @var{z}. Of the two possible roots\n"
10036 "(positive and negative), the one with positive real part\n"
10037 "is returned, or if that's zero then a positive imaginary part.\n"
10041 "(sqrt 9.0) @result{} 3.0\n"
10042 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10043 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10044 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10046 #define FUNC_NAME s_scm_sqrt
10048 if (SCM_COMPLEXP (z
))
10050 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10051 && defined SCM_COMPLEX_VALUE
10052 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10054 double re
= SCM_COMPLEX_REAL (z
);
10055 double im
= SCM_COMPLEX_IMAG (z
);
10056 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10057 0.5 * atan2 (im
, re
));
10060 else if (SCM_NUMBERP (z
))
10062 if (SCM_I_INUMP (z
))
10064 scm_t_inum x
= SCM_I_INUM (z
);
10066 if (SCM_LIKELY (x
>= 0))
10068 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10069 || x
< (1L << (DBL_MANT_DIG
- 1))))
10071 double root
= sqrt (x
);
10073 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10074 integer, then the result is exact. */
10075 if (root
== floor (root
))
10076 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10078 return scm_from_double (root
);
10085 mpz_init_set_ui (xx
, x
);
10086 if (mpz_perfect_square_p (xx
))
10089 root
= mpz_get_ui (xx
);
10091 return SCM_I_MAKINUM (root
);
10098 else if (SCM_BIGP (z
))
10100 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10102 SCM root
= scm_i_mkbig ();
10104 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10105 scm_remember_upto_here_1 (z
);
10106 return scm_i_normbig (root
);
10111 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10119 return scm_c_make_rectangular
10120 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10122 return scm_from_double (ldexp (sqrt (signif
), expon
/ 2));
10125 else if (SCM_FRACTIONP (z
))
10127 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10128 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10130 if (exact_integer_is_perfect_square (n
)
10131 && exact_integer_is_perfect_square (d
))
10132 return scm_i_make_ratio_already_reduced
10133 (exact_integer_floor_square_root (n
),
10134 exact_integer_floor_square_root (d
));
10137 double xx
= scm_i_divide2double (n
, d
);
10138 double abs_xx
= fabs (xx
);
10141 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10143 shift
= (scm_to_long (scm_integer_length (n
))
10144 - scm_to_long (scm_integer_length (d
))) / 2;
10146 d
= left_shift_exact_integer (d
, 2 * shift
);
10148 n
= left_shift_exact_integer (n
, -2 * shift
);
10149 xx
= scm_i_divide2double (n
, d
);
10153 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10155 return scm_from_double (ldexp (sqrt (xx
), shift
));
10159 /* Fallback method, when the cases above do not apply. */
10161 double xx
= scm_to_double (z
);
10163 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10165 return scm_from_double (sqrt (xx
));
10169 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10176 scm_init_numbers ()
10178 if (scm_install_gmp_memory_functions
)
10179 mp_set_memory_functions (custom_gmp_malloc
,
10180 custom_gmp_realloc
,
10183 mpz_init_set_si (z_negative_one
, -1);
10185 /* It may be possible to tune the performance of some algorithms by using
10186 * the following constants to avoid the creation of bignums. Please, before
10187 * using these values, remember the two rules of program optimization:
10188 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10189 scm_c_define ("most-positive-fixnum",
10190 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10191 scm_c_define ("most-negative-fixnum",
10192 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10194 scm_add_feature ("complex");
10195 scm_add_feature ("inexact");
10196 flo0
= scm_from_double (0.0);
10197 flo_log10e
= scm_from_double (M_LOG10E
);
10199 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10202 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10203 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10204 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10205 scm_i_divide2double_lo2b
,
10206 DBL_MANT_DIG
+ 1); /* 2 b^p */
10207 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10211 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10212 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10213 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10214 dbl_minimum_normal_mantissa
,
10218 #include "libguile/numbers.x"
10223 c-file-style: "gnu"