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
= SCM_PACK_POINTER (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 return 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 return 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 return 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 return 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 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
954 return 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 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
975 return 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 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
997 return 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 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
1098 scm_i_extract_values_2 (vals
, rp1
, rp2
);
1101 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1103 "Return the integer @var{q} such that\n"
1104 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1105 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1107 "(euclidean-quotient 123 10) @result{} 12\n"
1108 "(euclidean-quotient 123 -10) @result{} -12\n"
1109 "(euclidean-quotient -123 10) @result{} -13\n"
1110 "(euclidean-quotient -123 -10) @result{} 13\n"
1111 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1112 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1114 #define FUNC_NAME s_scm_euclidean_quotient
1116 if (scm_is_false (scm_negative_p (y
)))
1117 return scm_floor_quotient (x
, y
);
1119 return scm_ceiling_quotient (x
, y
);
1123 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1125 "Return the real number @var{r} such that\n"
1126 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1127 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1128 "for some integer @var{q}.\n"
1130 "(euclidean-remainder 123 10) @result{} 3\n"
1131 "(euclidean-remainder 123 -10) @result{} 3\n"
1132 "(euclidean-remainder -123 10) @result{} 7\n"
1133 "(euclidean-remainder -123 -10) @result{} 7\n"
1134 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1135 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1137 #define FUNC_NAME s_scm_euclidean_remainder
1139 if (scm_is_false (scm_negative_p (y
)))
1140 return scm_floor_remainder (x
, y
);
1142 return scm_ceiling_remainder (x
, y
);
1146 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1148 "Return the integer @var{q} and the real number @var{r}\n"
1149 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1150 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1152 "(euclidean/ 123 10) @result{} 12 and 3\n"
1153 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1154 "(euclidean/ -123 10) @result{} -13 and 7\n"
1155 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1156 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1157 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1159 #define FUNC_NAME s_scm_i_euclidean_divide
1161 if (scm_is_false (scm_negative_p (y
)))
1162 return scm_i_floor_divide (x
, y
);
1164 return scm_i_ceiling_divide (x
, y
);
1169 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1171 if (scm_is_false (scm_negative_p (y
)))
1172 return scm_floor_divide (x
, y
, qp
, rp
);
1174 return scm_ceiling_divide (x
, y
, qp
, rp
);
1177 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1178 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1180 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1182 "Return the floor of @math{@var{x} / @var{y}}.\n"
1184 "(floor-quotient 123 10) @result{} 12\n"
1185 "(floor-quotient 123 -10) @result{} -13\n"
1186 "(floor-quotient -123 10) @result{} -13\n"
1187 "(floor-quotient -123 -10) @result{} 12\n"
1188 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1189 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1191 #define FUNC_NAME s_scm_floor_quotient
1193 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1195 scm_t_inum xx
= SCM_I_INUM (x
);
1196 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1198 scm_t_inum yy
= SCM_I_INUM (y
);
1199 scm_t_inum xx1
= xx
;
1201 if (SCM_LIKELY (yy
> 0))
1203 if (SCM_UNLIKELY (xx
< 0))
1206 else if (SCM_UNLIKELY (yy
== 0))
1207 scm_num_overflow (s_scm_floor_quotient
);
1211 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1212 return SCM_I_MAKINUM (qq
);
1214 return scm_i_inum2big (qq
);
1216 else if (SCM_BIGP (y
))
1218 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1219 scm_remember_upto_here_1 (y
);
1221 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1223 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1225 else if (SCM_REALP (y
))
1226 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1227 else if (SCM_FRACTIONP (y
))
1228 return scm_i_exact_rational_floor_quotient (x
, y
);
1230 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1231 s_scm_floor_quotient
);
1233 else if (SCM_BIGP (x
))
1235 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1237 scm_t_inum yy
= SCM_I_INUM (y
);
1238 if (SCM_UNLIKELY (yy
== 0))
1239 scm_num_overflow (s_scm_floor_quotient
);
1240 else if (SCM_UNLIKELY (yy
== 1))
1244 SCM q
= scm_i_mkbig ();
1246 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1249 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1250 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1252 scm_remember_upto_here_1 (x
);
1253 return scm_i_normbig (q
);
1256 else if (SCM_BIGP (y
))
1258 SCM q
= scm_i_mkbig ();
1259 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1262 scm_remember_upto_here_2 (x
, y
);
1263 return scm_i_normbig (q
);
1265 else if (SCM_REALP (y
))
1266 return scm_i_inexact_floor_quotient
1267 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1268 else if (SCM_FRACTIONP (y
))
1269 return scm_i_exact_rational_floor_quotient (x
, y
);
1271 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1272 s_scm_floor_quotient
);
1274 else if (SCM_REALP (x
))
1276 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1277 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1278 return scm_i_inexact_floor_quotient
1279 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1281 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1282 s_scm_floor_quotient
);
1284 else if (SCM_FRACTIONP (x
))
1287 return scm_i_inexact_floor_quotient
1288 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1289 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1290 return scm_i_exact_rational_floor_quotient (x
, y
);
1292 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1293 s_scm_floor_quotient
);
1296 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1297 s_scm_floor_quotient
);
1302 scm_i_inexact_floor_quotient (double x
, double y
)
1304 if (SCM_UNLIKELY (y
== 0))
1305 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1307 return scm_from_double (floor (x
/ y
));
1311 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1313 return scm_floor_quotient
1314 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1315 scm_product (scm_numerator (y
), scm_denominator (x
)));
1318 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1319 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1321 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1323 "Return the real number @var{r} such that\n"
1324 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1325 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1327 "(floor-remainder 123 10) @result{} 3\n"
1328 "(floor-remainder 123 -10) @result{} -7\n"
1329 "(floor-remainder -123 10) @result{} 7\n"
1330 "(floor-remainder -123 -10) @result{} -3\n"
1331 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1332 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1334 #define FUNC_NAME s_scm_floor_remainder
1336 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1338 scm_t_inum xx
= SCM_I_INUM (x
);
1339 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1341 scm_t_inum yy
= SCM_I_INUM (y
);
1342 if (SCM_UNLIKELY (yy
== 0))
1343 scm_num_overflow (s_scm_floor_remainder
);
1346 scm_t_inum rr
= xx
% yy
;
1347 int needs_adjustment
;
1349 if (SCM_LIKELY (yy
> 0))
1350 needs_adjustment
= (rr
< 0);
1352 needs_adjustment
= (rr
> 0);
1354 if (needs_adjustment
)
1356 return SCM_I_MAKINUM (rr
);
1359 else if (SCM_BIGP (y
))
1361 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1362 scm_remember_upto_here_1 (y
);
1367 SCM r
= scm_i_mkbig ();
1368 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1369 scm_remember_upto_here_1 (y
);
1370 return scm_i_normbig (r
);
1379 SCM r
= scm_i_mkbig ();
1380 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1381 scm_remember_upto_here_1 (y
);
1382 return scm_i_normbig (r
);
1385 else if (SCM_REALP (y
))
1386 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1387 else if (SCM_FRACTIONP (y
))
1388 return scm_i_exact_rational_floor_remainder (x
, y
);
1390 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1391 s_scm_floor_remainder
);
1393 else if (SCM_BIGP (x
))
1395 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1397 scm_t_inum yy
= SCM_I_INUM (y
);
1398 if (SCM_UNLIKELY (yy
== 0))
1399 scm_num_overflow (s_scm_floor_remainder
);
1404 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1406 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1407 scm_remember_upto_here_1 (x
);
1408 return SCM_I_MAKINUM (rr
);
1411 else if (SCM_BIGP (y
))
1413 SCM r
= scm_i_mkbig ();
1414 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1417 scm_remember_upto_here_2 (x
, y
);
1418 return scm_i_normbig (r
);
1420 else if (SCM_REALP (y
))
1421 return scm_i_inexact_floor_remainder
1422 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1423 else if (SCM_FRACTIONP (y
))
1424 return scm_i_exact_rational_floor_remainder (x
, y
);
1426 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1427 s_scm_floor_remainder
);
1429 else if (SCM_REALP (x
))
1431 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1432 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1433 return scm_i_inexact_floor_remainder
1434 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1436 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1437 s_scm_floor_remainder
);
1439 else if (SCM_FRACTIONP (x
))
1442 return scm_i_inexact_floor_remainder
1443 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1444 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1445 return scm_i_exact_rational_floor_remainder (x
, y
);
1447 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1448 s_scm_floor_remainder
);
1451 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1452 s_scm_floor_remainder
);
1457 scm_i_inexact_floor_remainder (double x
, double y
)
1459 /* Although it would be more efficient to use fmod here, we can't
1460 because it would in some cases produce results inconsistent with
1461 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1462 close). In particular, when x is very close to a multiple of y,
1463 then r might be either 0.0 or y, but those two cases must
1464 correspond to different choices of q. If r = 0.0 then q must be
1465 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1466 and remainder chooses the other, it would be bad. */
1467 if (SCM_UNLIKELY (y
== 0))
1468 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1470 return scm_from_double (x
- y
* floor (x
/ y
));
1474 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1476 SCM xd
= scm_denominator (x
);
1477 SCM yd
= scm_denominator (y
);
1478 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1479 scm_product (scm_numerator (y
), xd
));
1480 return scm_divide (r1
, scm_product (xd
, yd
));
1484 static void scm_i_inexact_floor_divide (double x
, double y
,
1486 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1489 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1491 "Return the integer @var{q} and the real number @var{r}\n"
1492 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1493 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1495 "(floor/ 123 10) @result{} 12 and 3\n"
1496 "(floor/ 123 -10) @result{} -13 and -7\n"
1497 "(floor/ -123 10) @result{} -13 and 7\n"
1498 "(floor/ -123 -10) @result{} 12 and -3\n"
1499 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1500 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1502 #define FUNC_NAME s_scm_i_floor_divide
1506 scm_floor_divide(x
, y
, &q
, &r
);
1507 return scm_values (scm_list_2 (q
, r
));
1511 #define s_scm_floor_divide s_scm_i_floor_divide
1512 #define g_scm_floor_divide g_scm_i_floor_divide
1515 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1517 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1519 scm_t_inum xx
= SCM_I_INUM (x
);
1520 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1522 scm_t_inum yy
= SCM_I_INUM (y
);
1523 if (SCM_UNLIKELY (yy
== 0))
1524 scm_num_overflow (s_scm_floor_divide
);
1527 scm_t_inum qq
= xx
/ yy
;
1528 scm_t_inum rr
= xx
% yy
;
1529 int needs_adjustment
;
1531 if (SCM_LIKELY (yy
> 0))
1532 needs_adjustment
= (rr
< 0);
1534 needs_adjustment
= (rr
> 0);
1536 if (needs_adjustment
)
1542 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1543 *qp
= SCM_I_MAKINUM (qq
);
1545 *qp
= scm_i_inum2big (qq
);
1546 *rp
= SCM_I_MAKINUM (rr
);
1550 else if (SCM_BIGP (y
))
1552 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1553 scm_remember_upto_here_1 (y
);
1558 SCM r
= scm_i_mkbig ();
1559 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1560 scm_remember_upto_here_1 (y
);
1561 *qp
= SCM_I_MAKINUM (-1);
1562 *rp
= scm_i_normbig (r
);
1577 SCM r
= scm_i_mkbig ();
1578 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1579 scm_remember_upto_here_1 (y
);
1580 *qp
= SCM_I_MAKINUM (-1);
1581 *rp
= scm_i_normbig (r
);
1585 else if (SCM_REALP (y
))
1586 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1587 else if (SCM_FRACTIONP (y
))
1588 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1590 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1591 s_scm_floor_divide
, qp
, rp
);
1593 else if (SCM_BIGP (x
))
1595 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1597 scm_t_inum yy
= SCM_I_INUM (y
);
1598 if (SCM_UNLIKELY (yy
== 0))
1599 scm_num_overflow (s_scm_floor_divide
);
1602 SCM q
= scm_i_mkbig ();
1603 SCM r
= scm_i_mkbig ();
1605 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1606 SCM_I_BIG_MPZ (x
), yy
);
1609 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1610 SCM_I_BIG_MPZ (x
), -yy
);
1611 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1613 scm_remember_upto_here_1 (x
);
1614 *qp
= scm_i_normbig (q
);
1615 *rp
= scm_i_normbig (r
);
1619 else if (SCM_BIGP (y
))
1621 SCM q
= scm_i_mkbig ();
1622 SCM r
= scm_i_mkbig ();
1623 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1624 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1625 scm_remember_upto_here_2 (x
, y
);
1626 *qp
= scm_i_normbig (q
);
1627 *rp
= scm_i_normbig (r
);
1630 else if (SCM_REALP (y
))
1631 return scm_i_inexact_floor_divide
1632 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1633 else if (SCM_FRACTIONP (y
))
1634 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1636 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1637 s_scm_floor_divide
, qp
, rp
);
1639 else if (SCM_REALP (x
))
1641 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1642 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1643 return scm_i_inexact_floor_divide
1644 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1646 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1647 s_scm_floor_divide
, qp
, rp
);
1649 else if (SCM_FRACTIONP (x
))
1652 return scm_i_inexact_floor_divide
1653 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1654 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1655 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1657 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1658 s_scm_floor_divide
, qp
, rp
);
1661 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1662 s_scm_floor_divide
, qp
, rp
);
1666 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1668 if (SCM_UNLIKELY (y
== 0))
1669 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1672 double q
= floor (x
/ y
);
1673 double r
= x
- q
* y
;
1674 *qp
= scm_from_double (q
);
1675 *rp
= scm_from_double (r
);
1680 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1683 SCM xd
= scm_denominator (x
);
1684 SCM yd
= scm_denominator (y
);
1686 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1687 scm_product (scm_numerator (y
), xd
),
1689 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1692 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1693 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1695 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1697 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1699 "(ceiling-quotient 123 10) @result{} 13\n"
1700 "(ceiling-quotient 123 -10) @result{} -12\n"
1701 "(ceiling-quotient -123 10) @result{} -12\n"
1702 "(ceiling-quotient -123 -10) @result{} 13\n"
1703 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1704 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1706 #define FUNC_NAME s_scm_ceiling_quotient
1708 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1710 scm_t_inum xx
= SCM_I_INUM (x
);
1711 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1713 scm_t_inum yy
= SCM_I_INUM (y
);
1714 if (SCM_UNLIKELY (yy
== 0))
1715 scm_num_overflow (s_scm_ceiling_quotient
);
1718 scm_t_inum xx1
= xx
;
1720 if (SCM_LIKELY (yy
> 0))
1722 if (SCM_LIKELY (xx
>= 0))
1728 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1729 return SCM_I_MAKINUM (qq
);
1731 return scm_i_inum2big (qq
);
1734 else if (SCM_BIGP (y
))
1736 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1737 scm_remember_upto_here_1 (y
);
1738 if (SCM_LIKELY (sign
> 0))
1740 if (SCM_LIKELY (xx
> 0))
1742 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1743 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1744 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1746 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1747 scm_remember_upto_here_1 (y
);
1748 return SCM_I_MAKINUM (-1);
1758 else if (SCM_REALP (y
))
1759 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1760 else if (SCM_FRACTIONP (y
))
1761 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1763 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1764 s_scm_ceiling_quotient
);
1766 else if (SCM_BIGP (x
))
1768 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1770 scm_t_inum yy
= SCM_I_INUM (y
);
1771 if (SCM_UNLIKELY (yy
== 0))
1772 scm_num_overflow (s_scm_ceiling_quotient
);
1773 else if (SCM_UNLIKELY (yy
== 1))
1777 SCM q
= scm_i_mkbig ();
1779 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1782 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1783 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1785 scm_remember_upto_here_1 (x
);
1786 return scm_i_normbig (q
);
1789 else if (SCM_BIGP (y
))
1791 SCM q
= scm_i_mkbig ();
1792 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1795 scm_remember_upto_here_2 (x
, y
);
1796 return scm_i_normbig (q
);
1798 else if (SCM_REALP (y
))
1799 return scm_i_inexact_ceiling_quotient
1800 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1801 else if (SCM_FRACTIONP (y
))
1802 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1804 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1805 s_scm_ceiling_quotient
);
1807 else if (SCM_REALP (x
))
1809 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1810 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1811 return scm_i_inexact_ceiling_quotient
1812 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1814 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1815 s_scm_ceiling_quotient
);
1817 else if (SCM_FRACTIONP (x
))
1820 return scm_i_inexact_ceiling_quotient
1821 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1822 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1823 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1825 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1826 s_scm_ceiling_quotient
);
1829 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1830 s_scm_ceiling_quotient
);
1835 scm_i_inexact_ceiling_quotient (double x
, double y
)
1837 if (SCM_UNLIKELY (y
== 0))
1838 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1840 return scm_from_double (ceil (x
/ y
));
1844 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1846 return scm_ceiling_quotient
1847 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1848 scm_product (scm_numerator (y
), scm_denominator (x
)));
1851 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1852 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1854 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1856 "Return the real number @var{r} such that\n"
1857 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1858 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1860 "(ceiling-remainder 123 10) @result{} -7\n"
1861 "(ceiling-remainder 123 -10) @result{} 3\n"
1862 "(ceiling-remainder -123 10) @result{} -3\n"
1863 "(ceiling-remainder -123 -10) @result{} 7\n"
1864 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1865 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1867 #define FUNC_NAME s_scm_ceiling_remainder
1869 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1871 scm_t_inum xx
= SCM_I_INUM (x
);
1872 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1874 scm_t_inum yy
= SCM_I_INUM (y
);
1875 if (SCM_UNLIKELY (yy
== 0))
1876 scm_num_overflow (s_scm_ceiling_remainder
);
1879 scm_t_inum rr
= xx
% yy
;
1880 int needs_adjustment
;
1882 if (SCM_LIKELY (yy
> 0))
1883 needs_adjustment
= (rr
> 0);
1885 needs_adjustment
= (rr
< 0);
1887 if (needs_adjustment
)
1889 return SCM_I_MAKINUM (rr
);
1892 else if (SCM_BIGP (y
))
1894 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1895 scm_remember_upto_here_1 (y
);
1896 if (SCM_LIKELY (sign
> 0))
1898 if (SCM_LIKELY (xx
> 0))
1900 SCM r
= scm_i_mkbig ();
1901 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1902 scm_remember_upto_here_1 (y
);
1903 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1904 return scm_i_normbig (r
);
1906 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1907 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1908 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1910 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1911 scm_remember_upto_here_1 (y
);
1921 SCM r
= scm_i_mkbig ();
1922 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1923 scm_remember_upto_here_1 (y
);
1924 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1925 return scm_i_normbig (r
);
1928 else if (SCM_REALP (y
))
1929 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1930 else if (SCM_FRACTIONP (y
))
1931 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1933 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1934 s_scm_ceiling_remainder
);
1936 else if (SCM_BIGP (x
))
1938 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1940 scm_t_inum yy
= SCM_I_INUM (y
);
1941 if (SCM_UNLIKELY (yy
== 0))
1942 scm_num_overflow (s_scm_ceiling_remainder
);
1947 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1949 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1950 scm_remember_upto_here_1 (x
);
1951 return SCM_I_MAKINUM (rr
);
1954 else if (SCM_BIGP (y
))
1956 SCM r
= scm_i_mkbig ();
1957 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1960 scm_remember_upto_here_2 (x
, y
);
1961 return scm_i_normbig (r
);
1963 else if (SCM_REALP (y
))
1964 return scm_i_inexact_ceiling_remainder
1965 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1966 else if (SCM_FRACTIONP (y
))
1967 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1969 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1970 s_scm_ceiling_remainder
);
1972 else if (SCM_REALP (x
))
1974 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1975 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1976 return scm_i_inexact_ceiling_remainder
1977 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1979 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1980 s_scm_ceiling_remainder
);
1982 else if (SCM_FRACTIONP (x
))
1985 return scm_i_inexact_ceiling_remainder
1986 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1987 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1988 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1990 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1991 s_scm_ceiling_remainder
);
1994 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1995 s_scm_ceiling_remainder
);
2000 scm_i_inexact_ceiling_remainder (double x
, double y
)
2002 /* Although it would be more efficient to use fmod here, we can't
2003 because it would in some cases produce results inconsistent with
2004 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2005 close). In particular, when x is very close to a multiple of y,
2006 then r might be either 0.0 or -y, but those two cases must
2007 correspond to different choices of q. If r = 0.0 then q must be
2008 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2009 and remainder chooses the other, it would be bad. */
2010 if (SCM_UNLIKELY (y
== 0))
2011 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2013 return scm_from_double (x
- y
* ceil (x
/ y
));
2017 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2019 SCM xd
= scm_denominator (x
);
2020 SCM yd
= scm_denominator (y
);
2021 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2022 scm_product (scm_numerator (y
), xd
));
2023 return scm_divide (r1
, scm_product (xd
, yd
));
2026 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2028 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2031 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2033 "Return the integer @var{q} and the real number @var{r}\n"
2034 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2035 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2037 "(ceiling/ 123 10) @result{} 13 and -7\n"
2038 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2039 "(ceiling/ -123 10) @result{} -12 and -3\n"
2040 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2041 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2042 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2044 #define FUNC_NAME s_scm_i_ceiling_divide
2048 scm_ceiling_divide(x
, y
, &q
, &r
);
2049 return scm_values (scm_list_2 (q
, r
));
2053 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2054 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2057 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2059 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2061 scm_t_inum xx
= SCM_I_INUM (x
);
2062 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2064 scm_t_inum yy
= SCM_I_INUM (y
);
2065 if (SCM_UNLIKELY (yy
== 0))
2066 scm_num_overflow (s_scm_ceiling_divide
);
2069 scm_t_inum qq
= xx
/ yy
;
2070 scm_t_inum rr
= xx
% yy
;
2071 int needs_adjustment
;
2073 if (SCM_LIKELY (yy
> 0))
2074 needs_adjustment
= (rr
> 0);
2076 needs_adjustment
= (rr
< 0);
2078 if (needs_adjustment
)
2083 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2084 *qp
= SCM_I_MAKINUM (qq
);
2086 *qp
= scm_i_inum2big (qq
);
2087 *rp
= SCM_I_MAKINUM (rr
);
2091 else if (SCM_BIGP (y
))
2093 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2094 scm_remember_upto_here_1 (y
);
2095 if (SCM_LIKELY (sign
> 0))
2097 if (SCM_LIKELY (xx
> 0))
2099 SCM r
= scm_i_mkbig ();
2100 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2101 scm_remember_upto_here_1 (y
);
2102 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2104 *rp
= scm_i_normbig (r
);
2106 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2107 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2108 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2110 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2111 scm_remember_upto_here_1 (y
);
2112 *qp
= SCM_I_MAKINUM (-1);
2128 SCM r
= scm_i_mkbig ();
2129 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2130 scm_remember_upto_here_1 (y
);
2131 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2133 *rp
= scm_i_normbig (r
);
2137 else if (SCM_REALP (y
))
2138 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2139 else if (SCM_FRACTIONP (y
))
2140 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2142 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2143 s_scm_ceiling_divide
, qp
, rp
);
2145 else if (SCM_BIGP (x
))
2147 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2149 scm_t_inum yy
= SCM_I_INUM (y
);
2150 if (SCM_UNLIKELY (yy
== 0))
2151 scm_num_overflow (s_scm_ceiling_divide
);
2154 SCM q
= scm_i_mkbig ();
2155 SCM r
= scm_i_mkbig ();
2157 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2158 SCM_I_BIG_MPZ (x
), yy
);
2161 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2162 SCM_I_BIG_MPZ (x
), -yy
);
2163 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2165 scm_remember_upto_here_1 (x
);
2166 *qp
= scm_i_normbig (q
);
2167 *rp
= scm_i_normbig (r
);
2171 else if (SCM_BIGP (y
))
2173 SCM q
= scm_i_mkbig ();
2174 SCM r
= scm_i_mkbig ();
2175 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2176 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2177 scm_remember_upto_here_2 (x
, y
);
2178 *qp
= scm_i_normbig (q
);
2179 *rp
= scm_i_normbig (r
);
2182 else if (SCM_REALP (y
))
2183 return scm_i_inexact_ceiling_divide
2184 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2185 else if (SCM_FRACTIONP (y
))
2186 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2188 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2189 s_scm_ceiling_divide
, qp
, rp
);
2191 else if (SCM_REALP (x
))
2193 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2194 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2195 return scm_i_inexact_ceiling_divide
2196 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2198 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2199 s_scm_ceiling_divide
, qp
, rp
);
2201 else if (SCM_FRACTIONP (x
))
2204 return scm_i_inexact_ceiling_divide
2205 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2206 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2207 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2209 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2210 s_scm_ceiling_divide
, qp
, rp
);
2213 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2214 s_scm_ceiling_divide
, qp
, rp
);
2218 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2220 if (SCM_UNLIKELY (y
== 0))
2221 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2224 double q
= ceil (x
/ y
);
2225 double r
= x
- q
* y
;
2226 *qp
= scm_from_double (q
);
2227 *rp
= scm_from_double (r
);
2232 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2235 SCM xd
= scm_denominator (x
);
2236 SCM yd
= scm_denominator (y
);
2238 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2239 scm_product (scm_numerator (y
), xd
),
2241 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2244 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2245 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2247 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2249 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2251 "(truncate-quotient 123 10) @result{} 12\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.2 -63.5) @result{} 1.0\n"
2256 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2258 #define FUNC_NAME s_scm_truncate_quotient
2260 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2262 scm_t_inum xx
= SCM_I_INUM (x
);
2263 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2265 scm_t_inum yy
= SCM_I_INUM (y
);
2266 if (SCM_UNLIKELY (yy
== 0))
2267 scm_num_overflow (s_scm_truncate_quotient
);
2270 scm_t_inum qq
= xx
/ yy
;
2271 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2272 return SCM_I_MAKINUM (qq
);
2274 return scm_i_inum2big (qq
);
2277 else if (SCM_BIGP (y
))
2279 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2280 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2281 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2283 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2284 scm_remember_upto_here_1 (y
);
2285 return SCM_I_MAKINUM (-1);
2290 else if (SCM_REALP (y
))
2291 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2292 else if (SCM_FRACTIONP (y
))
2293 return scm_i_exact_rational_truncate_quotient (x
, y
);
2295 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2296 s_scm_truncate_quotient
);
2298 else if (SCM_BIGP (x
))
2300 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2302 scm_t_inum yy
= SCM_I_INUM (y
);
2303 if (SCM_UNLIKELY (yy
== 0))
2304 scm_num_overflow (s_scm_truncate_quotient
);
2305 else if (SCM_UNLIKELY (yy
== 1))
2309 SCM q
= scm_i_mkbig ();
2311 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2314 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2315 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2317 scm_remember_upto_here_1 (x
);
2318 return scm_i_normbig (q
);
2321 else if (SCM_BIGP (y
))
2323 SCM q
= scm_i_mkbig ();
2324 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2327 scm_remember_upto_here_2 (x
, y
);
2328 return scm_i_normbig (q
);
2330 else if (SCM_REALP (y
))
2331 return scm_i_inexact_truncate_quotient
2332 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2333 else if (SCM_FRACTIONP (y
))
2334 return scm_i_exact_rational_truncate_quotient (x
, y
);
2336 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2337 s_scm_truncate_quotient
);
2339 else if (SCM_REALP (x
))
2341 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2342 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2343 return scm_i_inexact_truncate_quotient
2344 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2346 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2347 s_scm_truncate_quotient
);
2349 else if (SCM_FRACTIONP (x
))
2352 return scm_i_inexact_truncate_quotient
2353 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2354 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2355 return scm_i_exact_rational_truncate_quotient (x
, y
);
2357 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2358 s_scm_truncate_quotient
);
2361 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2362 s_scm_truncate_quotient
);
2367 scm_i_inexact_truncate_quotient (double x
, double y
)
2369 if (SCM_UNLIKELY (y
== 0))
2370 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2372 return scm_from_double (trunc (x
/ y
));
2376 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2378 return scm_truncate_quotient
2379 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2380 scm_product (scm_numerator (y
), scm_denominator (x
)));
2383 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2384 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2386 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2388 "Return the real number @var{r} such that\n"
2389 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2390 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2392 "(truncate-remainder 123 10) @result{} 3\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.2 -63.5) @result{} -59.7\n"
2397 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2399 #define FUNC_NAME s_scm_truncate_remainder
2401 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2403 scm_t_inum xx
= SCM_I_INUM (x
);
2404 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2406 scm_t_inum yy
= SCM_I_INUM (y
);
2407 if (SCM_UNLIKELY (yy
== 0))
2408 scm_num_overflow (s_scm_truncate_remainder
);
2410 return SCM_I_MAKINUM (xx
% yy
);
2412 else if (SCM_BIGP (y
))
2414 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2415 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2416 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2418 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2419 scm_remember_upto_here_1 (y
);
2425 else if (SCM_REALP (y
))
2426 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2427 else if (SCM_FRACTIONP (y
))
2428 return scm_i_exact_rational_truncate_remainder (x
, y
);
2430 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2431 s_scm_truncate_remainder
);
2433 else if (SCM_BIGP (x
))
2435 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2437 scm_t_inum yy
= SCM_I_INUM (y
);
2438 if (SCM_UNLIKELY (yy
== 0))
2439 scm_num_overflow (s_scm_truncate_remainder
);
2442 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2443 (yy
> 0) ? yy
: -yy
)
2444 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2445 scm_remember_upto_here_1 (x
);
2446 return SCM_I_MAKINUM (rr
);
2449 else if (SCM_BIGP (y
))
2451 SCM r
= scm_i_mkbig ();
2452 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2455 scm_remember_upto_here_2 (x
, y
);
2456 return scm_i_normbig (r
);
2458 else if (SCM_REALP (y
))
2459 return scm_i_inexact_truncate_remainder
2460 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2461 else if (SCM_FRACTIONP (y
))
2462 return scm_i_exact_rational_truncate_remainder (x
, y
);
2464 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2465 s_scm_truncate_remainder
);
2467 else if (SCM_REALP (x
))
2469 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2470 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2471 return scm_i_inexact_truncate_remainder
2472 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2474 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2475 s_scm_truncate_remainder
);
2477 else if (SCM_FRACTIONP (x
))
2480 return scm_i_inexact_truncate_remainder
2481 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2482 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2483 return scm_i_exact_rational_truncate_remainder (x
, y
);
2485 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2486 s_scm_truncate_remainder
);
2489 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2490 s_scm_truncate_remainder
);
2495 scm_i_inexact_truncate_remainder (double x
, double y
)
2497 /* Although it would be more efficient to use fmod here, we can't
2498 because it would in some cases produce results inconsistent with
2499 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2500 close). In particular, when x is very close to a multiple of y,
2501 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2502 correspond to different choices of q. If quotient chooses one and
2503 remainder chooses the other, it would be bad. */
2504 if (SCM_UNLIKELY (y
== 0))
2505 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2507 return scm_from_double (x
- y
* trunc (x
/ y
));
2511 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2513 SCM xd
= scm_denominator (x
);
2514 SCM yd
= scm_denominator (y
);
2515 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2516 scm_product (scm_numerator (y
), xd
));
2517 return scm_divide (r1
, scm_product (xd
, yd
));
2521 static void scm_i_inexact_truncate_divide (double x
, double y
,
2523 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2526 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2528 "Return the integer @var{q} and the real number @var{r}\n"
2529 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2530 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2532 "(truncate/ 123 10) @result{} 12 and 3\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.2 -63.5) @result{} 1.0 and -59.7\n"
2537 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2539 #define FUNC_NAME s_scm_i_truncate_divide
2543 scm_truncate_divide(x
, y
, &q
, &r
);
2544 return scm_values (scm_list_2 (q
, r
));
2548 #define s_scm_truncate_divide s_scm_i_truncate_divide
2549 #define g_scm_truncate_divide g_scm_i_truncate_divide
2552 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2554 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2556 scm_t_inum xx
= SCM_I_INUM (x
);
2557 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2559 scm_t_inum yy
= SCM_I_INUM (y
);
2560 if (SCM_UNLIKELY (yy
== 0))
2561 scm_num_overflow (s_scm_truncate_divide
);
2564 scm_t_inum qq
= xx
/ yy
;
2565 scm_t_inum rr
= xx
% yy
;
2566 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2567 *qp
= SCM_I_MAKINUM (qq
);
2569 *qp
= scm_i_inum2big (qq
);
2570 *rp
= SCM_I_MAKINUM (rr
);
2574 else if (SCM_BIGP (y
))
2576 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2577 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2578 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2580 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2581 scm_remember_upto_here_1 (y
);
2582 *qp
= SCM_I_MAKINUM (-1);
2592 else if (SCM_REALP (y
))
2593 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2594 else if (SCM_FRACTIONP (y
))
2595 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2597 return two_valued_wta_dispatch_2
2598 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2599 s_scm_truncate_divide
, qp
, rp
);
2601 else if (SCM_BIGP (x
))
2603 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2605 scm_t_inum yy
= SCM_I_INUM (y
);
2606 if (SCM_UNLIKELY (yy
== 0))
2607 scm_num_overflow (s_scm_truncate_divide
);
2610 SCM q
= scm_i_mkbig ();
2613 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2614 SCM_I_BIG_MPZ (x
), yy
);
2617 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2618 SCM_I_BIG_MPZ (x
), -yy
);
2619 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2621 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2622 scm_remember_upto_here_1 (x
);
2623 *qp
= scm_i_normbig (q
);
2624 *rp
= SCM_I_MAKINUM (rr
);
2628 else if (SCM_BIGP (y
))
2630 SCM q
= scm_i_mkbig ();
2631 SCM r
= scm_i_mkbig ();
2632 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2633 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2634 scm_remember_upto_here_2 (x
, y
);
2635 *qp
= scm_i_normbig (q
);
2636 *rp
= scm_i_normbig (r
);
2638 else if (SCM_REALP (y
))
2639 return scm_i_inexact_truncate_divide
2640 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2641 else if (SCM_FRACTIONP (y
))
2642 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2644 return two_valued_wta_dispatch_2
2645 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2646 s_scm_truncate_divide
, qp
, rp
);
2648 else if (SCM_REALP (x
))
2650 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2651 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2652 return scm_i_inexact_truncate_divide
2653 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2655 return two_valued_wta_dispatch_2
2656 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2657 s_scm_truncate_divide
, qp
, rp
);
2659 else if (SCM_FRACTIONP (x
))
2662 return scm_i_inexact_truncate_divide
2663 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2664 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2665 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2667 return two_valued_wta_dispatch_2
2668 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2669 s_scm_truncate_divide
, qp
, rp
);
2672 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2673 s_scm_truncate_divide
, qp
, rp
);
2677 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2679 if (SCM_UNLIKELY (y
== 0))
2680 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2683 double q
= trunc (x
/ y
);
2684 double r
= x
- q
* y
;
2685 *qp
= scm_from_double (q
);
2686 *rp
= scm_from_double (r
);
2691 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2694 SCM xd
= scm_denominator (x
);
2695 SCM yd
= scm_denominator (y
);
2697 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2698 scm_product (scm_numerator (y
), xd
),
2700 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2703 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2704 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2705 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2707 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2709 "Return the integer @var{q} such that\n"
2710 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2711 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2713 "(centered-quotient 123 10) @result{} 12\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.2 -63.5) @result{} 2.0\n"
2718 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2720 #define FUNC_NAME s_scm_centered_quotient
2722 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2724 scm_t_inum xx
= SCM_I_INUM (x
);
2725 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2727 scm_t_inum yy
= SCM_I_INUM (y
);
2728 if (SCM_UNLIKELY (yy
== 0))
2729 scm_num_overflow (s_scm_centered_quotient
);
2732 scm_t_inum qq
= xx
/ yy
;
2733 scm_t_inum rr
= xx
% yy
;
2734 if (SCM_LIKELY (xx
> 0))
2736 if (SCM_LIKELY (yy
> 0))
2738 if (rr
>= (yy
+ 1) / 2)
2743 if (rr
>= (1 - yy
) / 2)
2749 if (SCM_LIKELY (yy
> 0))
2760 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2761 return SCM_I_MAKINUM (qq
);
2763 return scm_i_inum2big (qq
);
2766 else if (SCM_BIGP (y
))
2768 /* Pass a denormalized bignum version of x (even though it
2769 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2770 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2772 else if (SCM_REALP (y
))
2773 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2774 else if (SCM_FRACTIONP (y
))
2775 return scm_i_exact_rational_centered_quotient (x
, y
);
2777 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2778 s_scm_centered_quotient
);
2780 else if (SCM_BIGP (x
))
2782 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2784 scm_t_inum yy
= SCM_I_INUM (y
);
2785 if (SCM_UNLIKELY (yy
== 0))
2786 scm_num_overflow (s_scm_centered_quotient
);
2787 else if (SCM_UNLIKELY (yy
== 1))
2791 SCM q
= scm_i_mkbig ();
2793 /* Arrange for rr to initially be non-positive,
2794 because that simplifies the test to see
2795 if it is within the needed bounds. */
2798 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2799 SCM_I_BIG_MPZ (x
), yy
);
2800 scm_remember_upto_here_1 (x
);
2802 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2803 SCM_I_BIG_MPZ (q
), 1);
2807 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2808 SCM_I_BIG_MPZ (x
), -yy
);
2809 scm_remember_upto_here_1 (x
);
2810 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2812 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2813 SCM_I_BIG_MPZ (q
), 1);
2815 return scm_i_normbig (q
);
2818 else if (SCM_BIGP (y
))
2819 return scm_i_bigint_centered_quotient (x
, y
);
2820 else if (SCM_REALP (y
))
2821 return scm_i_inexact_centered_quotient
2822 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2823 else if (SCM_FRACTIONP (y
))
2824 return scm_i_exact_rational_centered_quotient (x
, y
);
2826 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2827 s_scm_centered_quotient
);
2829 else if (SCM_REALP (x
))
2831 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2832 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2833 return scm_i_inexact_centered_quotient
2834 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2836 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2837 s_scm_centered_quotient
);
2839 else if (SCM_FRACTIONP (x
))
2842 return scm_i_inexact_centered_quotient
2843 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2844 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2845 return scm_i_exact_rational_centered_quotient (x
, y
);
2847 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2848 s_scm_centered_quotient
);
2851 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2852 s_scm_centered_quotient
);
2857 scm_i_inexact_centered_quotient (double x
, double y
)
2859 if (SCM_LIKELY (y
> 0))
2860 return scm_from_double (floor (x
/y
+ 0.5));
2861 else if (SCM_LIKELY (y
< 0))
2862 return scm_from_double (ceil (x
/y
- 0.5));
2864 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2869 /* Assumes that both x and y are bigints, though
2870 x might be able to fit into a fixnum. */
2872 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2876 /* Note that x might be small enough to fit into a
2877 fixnum, so we must not let it escape into the wild */
2881 /* min_r will eventually become -abs(y)/2 */
2882 min_r
= scm_i_mkbig ();
2883 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2884 SCM_I_BIG_MPZ (y
), 1);
2886 /* Arrange for rr to initially be non-positive,
2887 because that simplifies the test to see
2888 if it is within the needed bounds. */
2889 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2891 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2892 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2893 scm_remember_upto_here_2 (x
, y
);
2894 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2895 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2896 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2897 SCM_I_BIG_MPZ (q
), 1);
2901 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2902 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2903 scm_remember_upto_here_2 (x
, y
);
2904 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2905 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2906 SCM_I_BIG_MPZ (q
), 1);
2908 scm_remember_upto_here_2 (r
, min_r
);
2909 return scm_i_normbig (q
);
2913 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2915 return scm_centered_quotient
2916 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2917 scm_product (scm_numerator (y
), scm_denominator (x
)));
2920 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2921 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2922 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2924 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2926 "Return the real number @var{r} such that\n"
2927 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2928 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2929 "for some integer @var{q}.\n"
2931 "(centered-remainder 123 10) @result{} 3\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.2 -63.5) @result{} 3.8\n"
2936 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2938 #define FUNC_NAME s_scm_centered_remainder
2940 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2942 scm_t_inum xx
= SCM_I_INUM (x
);
2943 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2945 scm_t_inum yy
= SCM_I_INUM (y
);
2946 if (SCM_UNLIKELY (yy
== 0))
2947 scm_num_overflow (s_scm_centered_remainder
);
2950 scm_t_inum rr
= xx
% yy
;
2951 if (SCM_LIKELY (xx
> 0))
2953 if (SCM_LIKELY (yy
> 0))
2955 if (rr
>= (yy
+ 1) / 2)
2960 if (rr
>= (1 - yy
) / 2)
2966 if (SCM_LIKELY (yy
> 0))
2977 return SCM_I_MAKINUM (rr
);
2980 else if (SCM_BIGP (y
))
2982 /* Pass a denormalized bignum version of x (even though it
2983 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2984 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2986 else if (SCM_REALP (y
))
2987 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2988 else if (SCM_FRACTIONP (y
))
2989 return scm_i_exact_rational_centered_remainder (x
, y
);
2991 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2992 s_scm_centered_remainder
);
2994 else if (SCM_BIGP (x
))
2996 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2998 scm_t_inum yy
= SCM_I_INUM (y
);
2999 if (SCM_UNLIKELY (yy
== 0))
3000 scm_num_overflow (s_scm_centered_remainder
);
3004 /* Arrange for rr to initially be non-positive,
3005 because that simplifies the test to see
3006 if it is within the needed bounds. */
3009 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3010 scm_remember_upto_here_1 (x
);
3016 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3017 scm_remember_upto_here_1 (x
);
3021 return SCM_I_MAKINUM (rr
);
3024 else if (SCM_BIGP (y
))
3025 return scm_i_bigint_centered_remainder (x
, y
);
3026 else if (SCM_REALP (y
))
3027 return scm_i_inexact_centered_remainder
3028 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3029 else if (SCM_FRACTIONP (y
))
3030 return scm_i_exact_rational_centered_remainder (x
, y
);
3032 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3033 s_scm_centered_remainder
);
3035 else if (SCM_REALP (x
))
3037 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3038 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3039 return scm_i_inexact_centered_remainder
3040 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3042 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3043 s_scm_centered_remainder
);
3045 else if (SCM_FRACTIONP (x
))
3048 return scm_i_inexact_centered_remainder
3049 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3050 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3051 return scm_i_exact_rational_centered_remainder (x
, y
);
3053 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3054 s_scm_centered_remainder
);
3057 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3058 s_scm_centered_remainder
);
3063 scm_i_inexact_centered_remainder (double x
, double y
)
3067 /* Although it would be more efficient to use fmod here, we can't
3068 because it would in some cases produce results inconsistent with
3069 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3070 close). In particular, when x-y/2 is very close to a multiple of
3071 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3072 two cases must correspond to different choices of q. If quotient
3073 chooses one and remainder chooses the other, it would be bad. */
3074 if (SCM_LIKELY (y
> 0))
3075 q
= floor (x
/y
+ 0.5);
3076 else if (SCM_LIKELY (y
< 0))
3077 q
= ceil (x
/y
- 0.5);
3079 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3082 return scm_from_double (x
- q
* y
);
3085 /* Assumes that both x and y are bigints, though
3086 x might be able to fit into a fixnum. */
3088 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3092 /* Note that x might be small enough to fit into a
3093 fixnum, so we must not let it escape into the wild */
3096 /* min_r will eventually become -abs(y)/2 */
3097 min_r
= scm_i_mkbig ();
3098 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3099 SCM_I_BIG_MPZ (y
), 1);
3101 /* Arrange for rr to initially be non-positive,
3102 because that simplifies the test to see
3103 if it is within the needed bounds. */
3104 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3106 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3107 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3108 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3109 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3110 mpz_add (SCM_I_BIG_MPZ (r
),
3116 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3117 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3118 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3119 mpz_sub (SCM_I_BIG_MPZ (r
),
3123 scm_remember_upto_here_2 (x
, y
);
3124 return scm_i_normbig (r
);
3128 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3130 SCM xd
= scm_denominator (x
);
3131 SCM yd
= scm_denominator (y
);
3132 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3133 scm_product (scm_numerator (y
), xd
));
3134 return scm_divide (r1
, scm_product (xd
, yd
));
3138 static void scm_i_inexact_centered_divide (double x
, double y
,
3140 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3141 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3144 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3146 "Return the integer @var{q} and the real number @var{r}\n"
3147 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3148 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3150 "(centered/ 123 10) @result{} 12 and 3\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.2 -63.5) @result{} 2.0 and 3.8\n"
3155 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3157 #define FUNC_NAME s_scm_i_centered_divide
3161 scm_centered_divide(x
, y
, &q
, &r
);
3162 return scm_values (scm_list_2 (q
, r
));
3166 #define s_scm_centered_divide s_scm_i_centered_divide
3167 #define g_scm_centered_divide g_scm_i_centered_divide
3170 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3172 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3174 scm_t_inum xx
= SCM_I_INUM (x
);
3175 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3177 scm_t_inum yy
= SCM_I_INUM (y
);
3178 if (SCM_UNLIKELY (yy
== 0))
3179 scm_num_overflow (s_scm_centered_divide
);
3182 scm_t_inum qq
= xx
/ yy
;
3183 scm_t_inum rr
= xx
% yy
;
3184 if (SCM_LIKELY (xx
> 0))
3186 if (SCM_LIKELY (yy
> 0))
3188 if (rr
>= (yy
+ 1) / 2)
3193 if (rr
>= (1 - yy
) / 2)
3199 if (SCM_LIKELY (yy
> 0))
3210 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3211 *qp
= SCM_I_MAKINUM (qq
);
3213 *qp
= scm_i_inum2big (qq
);
3214 *rp
= SCM_I_MAKINUM (rr
);
3218 else if (SCM_BIGP (y
))
3220 /* Pass a denormalized bignum version of x (even though it
3221 can fit in a fixnum) to scm_i_bigint_centered_divide */
3222 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3224 else if (SCM_REALP (y
))
3225 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3226 else if (SCM_FRACTIONP (y
))
3227 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3229 return two_valued_wta_dispatch_2
3230 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3231 s_scm_centered_divide
, qp
, rp
);
3233 else if (SCM_BIGP (x
))
3235 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3237 scm_t_inum yy
= SCM_I_INUM (y
);
3238 if (SCM_UNLIKELY (yy
== 0))
3239 scm_num_overflow (s_scm_centered_divide
);
3242 SCM q
= scm_i_mkbig ();
3244 /* Arrange for rr to initially be non-positive,
3245 because that simplifies the test to see
3246 if it is within the needed bounds. */
3249 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3250 SCM_I_BIG_MPZ (x
), yy
);
3251 scm_remember_upto_here_1 (x
);
3254 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3255 SCM_I_BIG_MPZ (q
), 1);
3261 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3262 SCM_I_BIG_MPZ (x
), -yy
);
3263 scm_remember_upto_here_1 (x
);
3264 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3267 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3268 SCM_I_BIG_MPZ (q
), 1);
3272 *qp
= scm_i_normbig (q
);
3273 *rp
= SCM_I_MAKINUM (rr
);
3277 else if (SCM_BIGP (y
))
3278 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3279 else if (SCM_REALP (y
))
3280 return scm_i_inexact_centered_divide
3281 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3282 else if (SCM_FRACTIONP (y
))
3283 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3285 return two_valued_wta_dispatch_2
3286 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3287 s_scm_centered_divide
, qp
, rp
);
3289 else if (SCM_REALP (x
))
3291 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3292 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3293 return scm_i_inexact_centered_divide
3294 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3296 return two_valued_wta_dispatch_2
3297 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3298 s_scm_centered_divide
, qp
, rp
);
3300 else if (SCM_FRACTIONP (x
))
3303 return scm_i_inexact_centered_divide
3304 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3305 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3306 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3308 return two_valued_wta_dispatch_2
3309 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3310 s_scm_centered_divide
, qp
, rp
);
3313 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3314 s_scm_centered_divide
, qp
, rp
);
3318 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3322 if (SCM_LIKELY (y
> 0))
3323 q
= floor (x
/y
+ 0.5);
3324 else if (SCM_LIKELY (y
< 0))
3325 q
= ceil (x
/y
- 0.5);
3327 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3331 *qp
= scm_from_double (q
);
3332 *rp
= scm_from_double (r
);
3335 /* Assumes that both x and y are bigints, though
3336 x might be able to fit into a fixnum. */
3338 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3342 /* Note that x might be small enough to fit into a
3343 fixnum, so we must not let it escape into the wild */
3347 /* min_r will eventually become -abs(y/2) */
3348 min_r
= scm_i_mkbig ();
3349 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3350 SCM_I_BIG_MPZ (y
), 1);
3352 /* Arrange for rr to initially be non-positive,
3353 because that simplifies the test to see
3354 if it is within the needed bounds. */
3355 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3357 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3358 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3359 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3360 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3362 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3363 SCM_I_BIG_MPZ (q
), 1);
3364 mpz_add (SCM_I_BIG_MPZ (r
),
3371 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3372 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3373 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3375 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3376 SCM_I_BIG_MPZ (q
), 1);
3377 mpz_sub (SCM_I_BIG_MPZ (r
),
3382 scm_remember_upto_here_2 (x
, y
);
3383 *qp
= scm_i_normbig (q
);
3384 *rp
= scm_i_normbig (r
);
3388 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3391 SCM xd
= scm_denominator (x
);
3392 SCM yd
= scm_denominator (y
);
3394 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3395 scm_product (scm_numerator (y
), xd
),
3397 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3400 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3401 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3402 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3404 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3406 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3407 "with ties going to the nearest even integer.\n"
3409 "(round-quotient 123 10) @result{} 12\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 125 10) @result{} 12\n"
3414 "(round-quotient 127 10) @result{} 13\n"
3415 "(round-quotient 135 10) @result{} 14\n"
3416 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3417 "(round-quotient 16/3 -10/7) @result{} -4\n"
3419 #define FUNC_NAME s_scm_round_quotient
3421 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3423 scm_t_inum xx
= SCM_I_INUM (x
);
3424 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3426 scm_t_inum yy
= SCM_I_INUM (y
);
3427 if (SCM_UNLIKELY (yy
== 0))
3428 scm_num_overflow (s_scm_round_quotient
);
3431 scm_t_inum qq
= xx
/ yy
;
3432 scm_t_inum rr
= xx
% yy
;
3434 scm_t_inum r2
= 2 * rr
;
3436 if (SCM_LIKELY (yy
< 0))
3456 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3457 return SCM_I_MAKINUM (qq
);
3459 return scm_i_inum2big (qq
);
3462 else if (SCM_BIGP (y
))
3464 /* Pass a denormalized bignum version of x (even though it
3465 can fit in a fixnum) to scm_i_bigint_round_quotient */
3466 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3468 else if (SCM_REALP (y
))
3469 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3470 else if (SCM_FRACTIONP (y
))
3471 return scm_i_exact_rational_round_quotient (x
, y
);
3473 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3474 s_scm_round_quotient
);
3476 else if (SCM_BIGP (x
))
3478 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3480 scm_t_inum yy
= SCM_I_INUM (y
);
3481 if (SCM_UNLIKELY (yy
== 0))
3482 scm_num_overflow (s_scm_round_quotient
);
3483 else if (SCM_UNLIKELY (yy
== 1))
3487 SCM q
= scm_i_mkbig ();
3489 int needs_adjustment
;
3493 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3494 SCM_I_BIG_MPZ (x
), yy
);
3495 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3496 needs_adjustment
= (2*rr
>= yy
);
3498 needs_adjustment
= (2*rr
> yy
);
3502 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3503 SCM_I_BIG_MPZ (x
), -yy
);
3504 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3505 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3506 needs_adjustment
= (2*rr
<= yy
);
3508 needs_adjustment
= (2*rr
< yy
);
3510 scm_remember_upto_here_1 (x
);
3511 if (needs_adjustment
)
3512 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3513 return scm_i_normbig (q
);
3516 else if (SCM_BIGP (y
))
3517 return scm_i_bigint_round_quotient (x
, y
);
3518 else if (SCM_REALP (y
))
3519 return scm_i_inexact_round_quotient
3520 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3521 else if (SCM_FRACTIONP (y
))
3522 return scm_i_exact_rational_round_quotient (x
, y
);
3524 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3525 s_scm_round_quotient
);
3527 else if (SCM_REALP (x
))
3529 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3530 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3531 return scm_i_inexact_round_quotient
3532 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3534 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3535 s_scm_round_quotient
);
3537 else if (SCM_FRACTIONP (x
))
3540 return scm_i_inexact_round_quotient
3541 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3542 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3543 return scm_i_exact_rational_round_quotient (x
, y
);
3545 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3546 s_scm_round_quotient
);
3549 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3550 s_scm_round_quotient
);
3555 scm_i_inexact_round_quotient (double x
, double y
)
3557 if (SCM_UNLIKELY (y
== 0))
3558 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3560 return scm_from_double (scm_c_round (x
/ y
));
3563 /* Assumes that both x and y are bigints, though
3564 x might be able to fit into a fixnum. */
3566 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3569 int cmp
, needs_adjustment
;
3571 /* Note that x might be small enough to fit into a
3572 fixnum, so we must not let it escape into the wild */
3575 r2
= scm_i_mkbig ();
3577 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3578 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3579 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3580 scm_remember_upto_here_2 (x
, r
);
3582 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3583 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3584 needs_adjustment
= (cmp
>= 0);
3586 needs_adjustment
= (cmp
> 0);
3587 scm_remember_upto_here_2 (r2
, y
);
3589 if (needs_adjustment
)
3590 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3592 return scm_i_normbig (q
);
3596 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3598 return scm_round_quotient
3599 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3600 scm_product (scm_numerator (y
), scm_denominator (x
)));
3603 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3604 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3605 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3607 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3609 "Return the real number @var{r} such that\n"
3610 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3611 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3612 "nearest integer, with ties going to the nearest\n"
3615 "(round-remainder 123 10) @result{} 3\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 125 10) @result{} 5\n"
3620 "(round-remainder 127 10) @result{} -3\n"
3621 "(round-remainder 135 10) @result{} -5\n"
3622 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3623 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3625 #define FUNC_NAME s_scm_round_remainder
3627 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3629 scm_t_inum xx
= SCM_I_INUM (x
);
3630 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3632 scm_t_inum yy
= SCM_I_INUM (y
);
3633 if (SCM_UNLIKELY (yy
== 0))
3634 scm_num_overflow (s_scm_round_remainder
);
3637 scm_t_inum qq
= xx
/ yy
;
3638 scm_t_inum rr
= xx
% yy
;
3640 scm_t_inum r2
= 2 * rr
;
3642 if (SCM_LIKELY (yy
< 0))
3662 return SCM_I_MAKINUM (rr
);
3665 else if (SCM_BIGP (y
))
3667 /* Pass a denormalized bignum version of x (even though it
3668 can fit in a fixnum) to scm_i_bigint_round_remainder */
3669 return scm_i_bigint_round_remainder
3670 (scm_i_long2big (xx
), y
);
3672 else if (SCM_REALP (y
))
3673 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3674 else if (SCM_FRACTIONP (y
))
3675 return scm_i_exact_rational_round_remainder (x
, y
);
3677 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3678 s_scm_round_remainder
);
3680 else if (SCM_BIGP (x
))
3682 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3684 scm_t_inum yy
= SCM_I_INUM (y
);
3685 if (SCM_UNLIKELY (yy
== 0))
3686 scm_num_overflow (s_scm_round_remainder
);
3689 SCM q
= scm_i_mkbig ();
3691 int needs_adjustment
;
3695 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3696 SCM_I_BIG_MPZ (x
), yy
);
3697 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3698 needs_adjustment
= (2*rr
>= yy
);
3700 needs_adjustment
= (2*rr
> yy
);
3704 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3705 SCM_I_BIG_MPZ (x
), -yy
);
3706 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3707 needs_adjustment
= (2*rr
<= yy
);
3709 needs_adjustment
= (2*rr
< yy
);
3711 scm_remember_upto_here_2 (x
, q
);
3712 if (needs_adjustment
)
3714 return SCM_I_MAKINUM (rr
);
3717 else if (SCM_BIGP (y
))
3718 return scm_i_bigint_round_remainder (x
, y
);
3719 else if (SCM_REALP (y
))
3720 return scm_i_inexact_round_remainder
3721 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3722 else if (SCM_FRACTIONP (y
))
3723 return scm_i_exact_rational_round_remainder (x
, y
);
3725 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3726 s_scm_round_remainder
);
3728 else if (SCM_REALP (x
))
3730 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3731 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3732 return scm_i_inexact_round_remainder
3733 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3735 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3736 s_scm_round_remainder
);
3738 else if (SCM_FRACTIONP (x
))
3741 return scm_i_inexact_round_remainder
3742 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3743 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3744 return scm_i_exact_rational_round_remainder (x
, y
);
3746 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3747 s_scm_round_remainder
);
3750 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3751 s_scm_round_remainder
);
3756 scm_i_inexact_round_remainder (double x
, double y
)
3758 /* Although it would be more efficient to use fmod here, we can't
3759 because it would in some cases produce results inconsistent with
3760 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3761 close). In particular, when x-y/2 is very close to a multiple of
3762 y, then r might be either -abs(y/2) or abs(y/2), but those two
3763 cases must correspond to different choices of q. If quotient
3764 chooses one and remainder chooses the other, it would be bad. */
3766 if (SCM_UNLIKELY (y
== 0))
3767 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3770 double q
= scm_c_round (x
/ y
);
3771 return scm_from_double (x
- q
* y
);
3775 /* Assumes that both x and y are bigints, though
3776 x might be able to fit into a fixnum. */
3778 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3781 int cmp
, needs_adjustment
;
3783 /* Note that x might be small enough to fit into a
3784 fixnum, so we must not let it escape into the wild */
3787 r2
= scm_i_mkbig ();
3789 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3790 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3791 scm_remember_upto_here_1 (x
);
3792 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3794 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3795 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3796 needs_adjustment
= (cmp
>= 0);
3798 needs_adjustment
= (cmp
> 0);
3799 scm_remember_upto_here_2 (q
, r2
);
3801 if (needs_adjustment
)
3802 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3804 scm_remember_upto_here_1 (y
);
3805 return scm_i_normbig (r
);
3809 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3811 SCM xd
= scm_denominator (x
);
3812 SCM yd
= scm_denominator (y
);
3813 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3814 scm_product (scm_numerator (y
), xd
));
3815 return scm_divide (r1
, scm_product (xd
, yd
));
3819 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3820 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3821 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3823 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3825 "Return the integer @var{q} and the real number @var{r}\n"
3826 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3827 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3828 "nearest integer, with ties going to the nearest even integer.\n"
3830 "(round/ 123 10) @result{} 12 and 3\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/ 125 10) @result{} 12 and 5\n"
3835 "(round/ 127 10) @result{} 13 and -3\n"
3836 "(round/ 135 10) @result{} 14 and -5\n"
3837 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3838 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3840 #define FUNC_NAME s_scm_i_round_divide
3844 scm_round_divide(x
, y
, &q
, &r
);
3845 return scm_values (scm_list_2 (q
, r
));
3849 #define s_scm_round_divide s_scm_i_round_divide
3850 #define g_scm_round_divide g_scm_i_round_divide
3853 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3855 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3857 scm_t_inum xx
= SCM_I_INUM (x
);
3858 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3860 scm_t_inum yy
= SCM_I_INUM (y
);
3861 if (SCM_UNLIKELY (yy
== 0))
3862 scm_num_overflow (s_scm_round_divide
);
3865 scm_t_inum qq
= xx
/ yy
;
3866 scm_t_inum rr
= xx
% yy
;
3868 scm_t_inum r2
= 2 * rr
;
3870 if (SCM_LIKELY (yy
< 0))
3890 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3891 *qp
= SCM_I_MAKINUM (qq
);
3893 *qp
= scm_i_inum2big (qq
);
3894 *rp
= SCM_I_MAKINUM (rr
);
3898 else if (SCM_BIGP (y
))
3900 /* Pass a denormalized bignum version of x (even though it
3901 can fit in a fixnum) to scm_i_bigint_round_divide */
3902 return scm_i_bigint_round_divide
3903 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3905 else if (SCM_REALP (y
))
3906 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3907 else if (SCM_FRACTIONP (y
))
3908 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3910 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3911 s_scm_round_divide
, qp
, rp
);
3913 else if (SCM_BIGP (x
))
3915 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3917 scm_t_inum yy
= SCM_I_INUM (y
);
3918 if (SCM_UNLIKELY (yy
== 0))
3919 scm_num_overflow (s_scm_round_divide
);
3922 SCM q
= scm_i_mkbig ();
3924 int needs_adjustment
;
3928 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3929 SCM_I_BIG_MPZ (x
), yy
);
3930 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3931 needs_adjustment
= (2*rr
>= yy
);
3933 needs_adjustment
= (2*rr
> yy
);
3937 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3938 SCM_I_BIG_MPZ (x
), -yy
);
3939 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3940 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3941 needs_adjustment
= (2*rr
<= yy
);
3943 needs_adjustment
= (2*rr
< yy
);
3945 scm_remember_upto_here_1 (x
);
3946 if (needs_adjustment
)
3948 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3951 *qp
= scm_i_normbig (q
);
3952 *rp
= SCM_I_MAKINUM (rr
);
3956 else if (SCM_BIGP (y
))
3957 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3958 else if (SCM_REALP (y
))
3959 return scm_i_inexact_round_divide
3960 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3961 else if (SCM_FRACTIONP (y
))
3962 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3964 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3965 s_scm_round_divide
, qp
, rp
);
3967 else if (SCM_REALP (x
))
3969 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3970 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3971 return scm_i_inexact_round_divide
3972 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3974 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3975 s_scm_round_divide
, qp
, rp
);
3977 else if (SCM_FRACTIONP (x
))
3980 return scm_i_inexact_round_divide
3981 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3982 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3983 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3985 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3986 s_scm_round_divide
, qp
, rp
);
3989 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3990 s_scm_round_divide
, qp
, rp
);
3994 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3996 if (SCM_UNLIKELY (y
== 0))
3997 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4000 double q
= scm_c_round (x
/ y
);
4001 double r
= x
- q
* y
;
4002 *qp
= scm_from_double (q
);
4003 *rp
= scm_from_double (r
);
4007 /* Assumes that both x and y are bigints, though
4008 x might be able to fit into a fixnum. */
4010 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4013 int cmp
, needs_adjustment
;
4015 /* Note that x might be small enough to fit into a
4016 fixnum, so we must not let it escape into the wild */
4019 r2
= scm_i_mkbig ();
4021 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4022 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4023 scm_remember_upto_here_1 (x
);
4024 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4026 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4027 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4028 needs_adjustment
= (cmp
>= 0);
4030 needs_adjustment
= (cmp
> 0);
4032 if (needs_adjustment
)
4034 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4035 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4038 scm_remember_upto_here_2 (r2
, y
);
4039 *qp
= scm_i_normbig (q
);
4040 *rp
= scm_i_normbig (r
);
4044 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4047 SCM xd
= scm_denominator (x
);
4048 SCM yd
= scm_denominator (y
);
4050 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4051 scm_product (scm_numerator (y
), xd
),
4053 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4057 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4058 (SCM x
, SCM y
, SCM rest
),
4059 "Return the greatest common divisor of all parameter values.\n"
4060 "If called without arguments, 0 is returned.")
4061 #define FUNC_NAME s_scm_i_gcd
4063 while (!scm_is_null (rest
))
4064 { x
= scm_gcd (x
, y
);
4066 rest
= scm_cdr (rest
);
4068 return scm_gcd (x
, y
);
4072 #define s_gcd s_scm_i_gcd
4073 #define g_gcd g_scm_i_gcd
4076 scm_gcd (SCM x
, SCM y
)
4078 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4079 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4081 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4083 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4085 scm_t_inum xx
= SCM_I_INUM (x
);
4086 scm_t_inum yy
= SCM_I_INUM (y
);
4087 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4088 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4090 if (SCM_UNLIKELY (xx
== 0))
4092 else if (SCM_UNLIKELY (yy
== 0))
4097 /* Determine a common factor 2^k */
4098 while (((u
| v
) & 1) == 0)
4104 /* Now, any factor 2^n can be eliminated */
4106 while ((u
& 1) == 0)
4109 while ((v
& 1) == 0)
4111 /* Both u and v are now odd. Subtract the smaller one
4112 from the larger one to produce an even number, remove
4113 more factors of two, and repeat. */
4119 while ((u
& 1) == 0)
4125 while ((v
& 1) == 0)
4131 return (SCM_POSFIXABLE (result
)
4132 ? SCM_I_MAKINUM (result
)
4133 : scm_i_inum2big (result
));
4135 else if (SCM_BIGP (y
))
4141 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4143 else if (SCM_BIGP (x
))
4145 if (SCM_I_INUMP (y
))
4150 yy
= SCM_I_INUM (y
);
4155 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4156 scm_remember_upto_here_1 (x
);
4157 return (SCM_POSFIXABLE (result
)
4158 ? SCM_I_MAKINUM (result
)
4159 : scm_from_unsigned_integer (result
));
4161 else if (SCM_BIGP (y
))
4163 SCM result
= scm_i_mkbig ();
4164 mpz_gcd (SCM_I_BIG_MPZ (result
),
4167 scm_remember_upto_here_2 (x
, y
);
4168 return scm_i_normbig (result
);
4171 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4174 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4177 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4178 (SCM x
, SCM y
, SCM rest
),
4179 "Return the least common multiple of the arguments.\n"
4180 "If called without arguments, 1 is returned.")
4181 #define FUNC_NAME s_scm_i_lcm
4183 while (!scm_is_null (rest
))
4184 { x
= scm_lcm (x
, y
);
4186 rest
= scm_cdr (rest
);
4188 return scm_lcm (x
, y
);
4192 #define s_lcm s_scm_i_lcm
4193 #define g_lcm g_scm_i_lcm
4196 scm_lcm (SCM n1
, SCM n2
)
4198 if (SCM_UNBNDP (n2
))
4200 if (SCM_UNBNDP (n1
))
4201 return SCM_I_MAKINUM (1L);
4202 n2
= SCM_I_MAKINUM (1L);
4205 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
4206 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4208 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
4209 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, 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_unlocked (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_unlocked (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_unlocked (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_unlocked (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_unlocked (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 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6563 else if (SCM_BIGP (x
))
6565 if (SCM_I_INUMP (y
))
6567 else if (SCM_BIGP (y
))
6569 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6570 scm_remember_upto_here_2 (x
, y
);
6571 return scm_from_bool (0 == cmp
);
6573 else if (SCM_REALP (y
))
6576 if (isnan (SCM_REAL_VALUE (y
)))
6578 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6579 scm_remember_upto_here_1 (x
);
6580 return scm_from_bool (0 == cmp
);
6582 else if (SCM_COMPLEXP (y
))
6585 if (0.0 != SCM_COMPLEX_IMAG (y
))
6587 if (isnan (SCM_COMPLEX_REAL (y
)))
6589 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6590 scm_remember_upto_here_1 (x
);
6591 return scm_from_bool (0 == cmp
);
6593 else if (SCM_FRACTIONP (y
))
6596 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6599 else if (SCM_REALP (x
))
6601 double xx
= SCM_REAL_VALUE (x
);
6602 if (SCM_I_INUMP (y
))
6604 /* see comments with inum/real above */
6605 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6606 return scm_from_bool (xx
== (double) yy
6607 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6608 || (scm_t_signed_bits
) xx
== yy
));
6610 else if (SCM_BIGP (y
))
6613 if (isnan (SCM_REAL_VALUE (x
)))
6615 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6616 scm_remember_upto_here_1 (y
);
6617 return scm_from_bool (0 == cmp
);
6619 else if (SCM_REALP (y
))
6620 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6621 else if (SCM_COMPLEXP (y
))
6622 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6623 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6624 else if (SCM_FRACTIONP (y
))
6626 double xx
= SCM_REAL_VALUE (x
);
6630 return scm_from_bool (xx
< 0.0);
6631 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6635 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6638 else if (SCM_COMPLEXP (x
))
6640 if (SCM_I_INUMP (y
))
6641 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6642 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6643 else if (SCM_BIGP (y
))
6646 if (0.0 != SCM_COMPLEX_IMAG (x
))
6648 if (isnan (SCM_COMPLEX_REAL (x
)))
6650 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6651 scm_remember_upto_here_1 (y
);
6652 return scm_from_bool (0 == cmp
);
6654 else if (SCM_REALP (y
))
6655 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6656 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6657 else if (SCM_COMPLEXP (y
))
6658 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6659 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6660 else if (SCM_FRACTIONP (y
))
6663 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6665 xx
= SCM_COMPLEX_REAL (x
);
6669 return scm_from_bool (xx
< 0.0);
6670 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6674 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6677 else if (SCM_FRACTIONP (x
))
6679 if (SCM_I_INUMP (y
))
6681 else if (SCM_BIGP (y
))
6683 else if (SCM_REALP (y
))
6685 double yy
= SCM_REAL_VALUE (y
);
6689 return scm_from_bool (0.0 < yy
);
6690 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6693 else if (SCM_COMPLEXP (y
))
6696 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6698 yy
= SCM_COMPLEX_REAL (y
);
6702 return scm_from_bool (0.0 < yy
);
6703 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6706 else if (SCM_FRACTIONP (y
))
6707 return scm_i_fraction_equalp (x
, y
);
6709 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6713 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6718 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6719 done are good for inums, but for bignums an answer can almost always be
6720 had by just examining a few high bits of the operands, as done by GMP in
6721 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6722 of the float exponent to take into account. */
6724 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6725 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6726 (SCM x
, SCM y
, SCM rest
),
6727 "Return @code{#t} if the list of parameters is monotonically\n"
6729 #define FUNC_NAME s_scm_i_num_less_p
6731 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6733 while (!scm_is_null (rest
))
6735 if (scm_is_false (scm_less_p (x
, y
)))
6739 rest
= scm_cdr (rest
);
6741 return scm_less_p (x
, y
);
6745 scm_less_p (SCM x
, SCM y
)
6748 if (SCM_I_INUMP (x
))
6750 scm_t_inum xx
= SCM_I_INUM (x
);
6751 if (SCM_I_INUMP (y
))
6753 scm_t_inum yy
= SCM_I_INUM (y
);
6754 return scm_from_bool (xx
< yy
);
6756 else if (SCM_BIGP (y
))
6758 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6759 scm_remember_upto_here_1 (y
);
6760 return scm_from_bool (sgn
> 0);
6762 else if (SCM_REALP (y
))
6763 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6764 else if (SCM_FRACTIONP (y
))
6766 /* "x < a/b" becomes "x*b < a" */
6768 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6769 y
= SCM_FRACTION_NUMERATOR (y
);
6773 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6774 s_scm_i_num_less_p
);
6776 else if (SCM_BIGP (x
))
6778 if (SCM_I_INUMP (y
))
6780 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6781 scm_remember_upto_here_1 (x
);
6782 return scm_from_bool (sgn
< 0);
6784 else if (SCM_BIGP (y
))
6786 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6787 scm_remember_upto_here_2 (x
, y
);
6788 return scm_from_bool (cmp
< 0);
6790 else if (SCM_REALP (y
))
6793 if (isnan (SCM_REAL_VALUE (y
)))
6795 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6796 scm_remember_upto_here_1 (x
);
6797 return scm_from_bool (cmp
< 0);
6799 else if (SCM_FRACTIONP (y
))
6802 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6803 s_scm_i_num_less_p
);
6805 else if (SCM_REALP (x
))
6807 if (SCM_I_INUMP (y
))
6808 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6809 else if (SCM_BIGP (y
))
6812 if (isnan (SCM_REAL_VALUE (x
)))
6814 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6815 scm_remember_upto_here_1 (y
);
6816 return scm_from_bool (cmp
> 0);
6818 else if (SCM_REALP (y
))
6819 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6820 else if (SCM_FRACTIONP (y
))
6822 double xx
= SCM_REAL_VALUE (x
);
6826 return scm_from_bool (xx
< 0.0);
6827 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6831 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6832 s_scm_i_num_less_p
);
6834 else if (SCM_FRACTIONP (x
))
6836 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6838 /* "a/b < y" becomes "a < y*b" */
6839 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6840 x
= SCM_FRACTION_NUMERATOR (x
);
6843 else if (SCM_REALP (y
))
6845 double yy
= SCM_REAL_VALUE (y
);
6849 return scm_from_bool (0.0 < yy
);
6850 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6853 else if (SCM_FRACTIONP (y
))
6855 /* "a/b < c/d" becomes "a*d < c*b" */
6856 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6857 SCM_FRACTION_DENOMINATOR (y
));
6858 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6859 SCM_FRACTION_DENOMINATOR (x
));
6865 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6866 s_scm_i_num_less_p
);
6869 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6870 s_scm_i_num_less_p
);
6874 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6875 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6876 (SCM x
, SCM y
, SCM rest
),
6877 "Return @code{#t} if the list of parameters is monotonically\n"
6879 #define FUNC_NAME s_scm_i_num_gr_p
6881 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6883 while (!scm_is_null (rest
))
6885 if (scm_is_false (scm_gr_p (x
, y
)))
6889 rest
= scm_cdr (rest
);
6891 return scm_gr_p (x
, y
);
6894 #define FUNC_NAME s_scm_i_num_gr_p
6896 scm_gr_p (SCM x
, SCM y
)
6898 if (!SCM_NUMBERP (x
))
6899 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6900 else if (!SCM_NUMBERP (y
))
6901 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6903 return scm_less_p (y
, x
);
6908 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6909 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6910 (SCM x
, SCM y
, SCM rest
),
6911 "Return @code{#t} if the list of parameters is monotonically\n"
6913 #define FUNC_NAME s_scm_i_num_leq_p
6915 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6917 while (!scm_is_null (rest
))
6919 if (scm_is_false (scm_leq_p (x
, y
)))
6923 rest
= scm_cdr (rest
);
6925 return scm_leq_p (x
, y
);
6928 #define FUNC_NAME s_scm_i_num_leq_p
6930 scm_leq_p (SCM x
, SCM y
)
6932 if (!SCM_NUMBERP (x
))
6933 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6934 else if (!SCM_NUMBERP (y
))
6935 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6936 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6939 return scm_not (scm_less_p (y
, x
));
6944 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6945 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6946 (SCM x
, SCM y
, SCM rest
),
6947 "Return @code{#t} if the list of parameters is monotonically\n"
6949 #define FUNC_NAME s_scm_i_num_geq_p
6951 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6953 while (!scm_is_null (rest
))
6955 if (scm_is_false (scm_geq_p (x
, y
)))
6959 rest
= scm_cdr (rest
);
6961 return scm_geq_p (x
, y
);
6964 #define FUNC_NAME s_scm_i_num_geq_p
6966 scm_geq_p (SCM x
, SCM y
)
6968 if (!SCM_NUMBERP (x
))
6969 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6970 else if (!SCM_NUMBERP (y
))
6971 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6972 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6975 return scm_not (scm_less_p (x
, y
));
6980 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6982 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6984 #define FUNC_NAME s_scm_zero_p
6986 if (SCM_I_INUMP (z
))
6987 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6988 else if (SCM_BIGP (z
))
6990 else if (SCM_REALP (z
))
6991 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6992 else if (SCM_COMPLEXP (z
))
6993 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6994 && SCM_COMPLEX_IMAG (z
) == 0.0);
6995 else if (SCM_FRACTIONP (z
))
6998 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7003 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7005 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7007 #define FUNC_NAME s_scm_positive_p
7009 if (SCM_I_INUMP (x
))
7010 return scm_from_bool (SCM_I_INUM (x
) > 0);
7011 else if (SCM_BIGP (x
))
7013 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7014 scm_remember_upto_here_1 (x
);
7015 return scm_from_bool (sgn
> 0);
7017 else if (SCM_REALP (x
))
7018 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7019 else if (SCM_FRACTIONP (x
))
7020 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7022 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7027 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7029 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7031 #define FUNC_NAME s_scm_negative_p
7033 if (SCM_I_INUMP (x
))
7034 return scm_from_bool (SCM_I_INUM (x
) < 0);
7035 else if (SCM_BIGP (x
))
7037 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7038 scm_remember_upto_here_1 (x
);
7039 return scm_from_bool (sgn
< 0);
7041 else if (SCM_REALP (x
))
7042 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7043 else if (SCM_FRACTIONP (x
))
7044 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7046 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7051 /* scm_min and scm_max return an inexact when either argument is inexact, as
7052 required by r5rs. On that basis, for exact/inexact combinations the
7053 exact is converted to inexact to compare and possibly return. This is
7054 unlike scm_less_p above which takes some trouble to preserve all bits in
7055 its test, such trouble is not required for min and max. */
7057 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7058 (SCM x
, SCM y
, SCM rest
),
7059 "Return the maximum of all parameter values.")
7060 #define FUNC_NAME s_scm_i_max
7062 while (!scm_is_null (rest
))
7063 { x
= scm_max (x
, y
);
7065 rest
= scm_cdr (rest
);
7067 return scm_max (x
, y
);
7071 #define s_max s_scm_i_max
7072 #define g_max g_scm_i_max
7075 scm_max (SCM x
, SCM y
)
7080 return scm_wta_dispatch_0 (g_max
, s_max
);
7081 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7084 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7087 if (SCM_I_INUMP (x
))
7089 scm_t_inum xx
= SCM_I_INUM (x
);
7090 if (SCM_I_INUMP (y
))
7092 scm_t_inum yy
= SCM_I_INUM (y
);
7093 return (xx
< yy
) ? y
: x
;
7095 else if (SCM_BIGP (y
))
7097 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7098 scm_remember_upto_here_1 (y
);
7099 return (sgn
< 0) ? x
: y
;
7101 else if (SCM_REALP (y
))
7104 double yyd
= SCM_REAL_VALUE (y
);
7107 return scm_from_double (xxd
);
7108 /* If y is a NaN, then "==" is false and we return the NaN */
7109 else if (SCM_LIKELY (!(xxd
== yyd
)))
7111 /* Handle signed zeroes properly */
7117 else if (SCM_FRACTIONP (y
))
7120 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7123 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7125 else if (SCM_BIGP (x
))
7127 if (SCM_I_INUMP (y
))
7129 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7130 scm_remember_upto_here_1 (x
);
7131 return (sgn
< 0) ? y
: x
;
7133 else if (SCM_BIGP (y
))
7135 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7136 scm_remember_upto_here_2 (x
, y
);
7137 return (cmp
> 0) ? x
: y
;
7139 else if (SCM_REALP (y
))
7141 /* if y==NaN then xx>yy is false, so we return the NaN y */
7144 xx
= scm_i_big2dbl (x
);
7145 yy
= SCM_REAL_VALUE (y
);
7146 return (xx
> yy
? scm_from_double (xx
) : y
);
7148 else if (SCM_FRACTIONP (y
))
7153 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7155 else if (SCM_REALP (x
))
7157 if (SCM_I_INUMP (y
))
7159 scm_t_inum yy
= SCM_I_INUM (y
);
7160 double xxd
= SCM_REAL_VALUE (x
);
7164 return scm_from_double (yyd
);
7165 /* If x is a NaN, then "==" is false and we return the NaN */
7166 else if (SCM_LIKELY (!(xxd
== yyd
)))
7168 /* Handle signed zeroes properly */
7174 else if (SCM_BIGP (y
))
7179 else if (SCM_REALP (y
))
7181 double xx
= SCM_REAL_VALUE (x
);
7182 double yy
= SCM_REAL_VALUE (y
);
7184 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7187 else if (SCM_LIKELY (xx
< yy
))
7189 /* If neither (xx > yy) nor (xx < yy), then
7190 either they're equal or one is a NaN */
7191 else if (SCM_UNLIKELY (isnan (xx
)))
7192 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7193 else if (SCM_UNLIKELY (isnan (yy
)))
7194 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7195 /* xx == yy, but handle signed zeroes properly */
7196 else if (double_is_non_negative_zero (yy
))
7201 else if (SCM_FRACTIONP (y
))
7203 double yy
= scm_i_fraction2double (y
);
7204 double xx
= SCM_REAL_VALUE (x
);
7205 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7208 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7210 else if (SCM_FRACTIONP (x
))
7212 if (SCM_I_INUMP (y
))
7216 else if (SCM_BIGP (y
))
7220 else if (SCM_REALP (y
))
7222 double xx
= scm_i_fraction2double (x
);
7223 /* if y==NaN then ">" is false, so we return the NaN y */
7224 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7226 else if (SCM_FRACTIONP (y
))
7231 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7234 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7238 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7239 (SCM x
, SCM y
, SCM rest
),
7240 "Return the minimum of all parameter values.")
7241 #define FUNC_NAME s_scm_i_min
7243 while (!scm_is_null (rest
))
7244 { x
= scm_min (x
, y
);
7246 rest
= scm_cdr (rest
);
7248 return scm_min (x
, y
);
7252 #define s_min s_scm_i_min
7253 #define g_min g_scm_i_min
7256 scm_min (SCM x
, SCM y
)
7261 return scm_wta_dispatch_0 (g_min
, s_min
);
7262 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7265 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7268 if (SCM_I_INUMP (x
))
7270 scm_t_inum xx
= SCM_I_INUM (x
);
7271 if (SCM_I_INUMP (y
))
7273 scm_t_inum yy
= SCM_I_INUM (y
);
7274 return (xx
< yy
) ? x
: y
;
7276 else if (SCM_BIGP (y
))
7278 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7279 scm_remember_upto_here_1 (y
);
7280 return (sgn
< 0) ? y
: x
;
7282 else if (SCM_REALP (y
))
7285 /* if y==NaN then "<" is false and we return NaN */
7286 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7288 else if (SCM_FRACTIONP (y
))
7291 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7294 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7296 else if (SCM_BIGP (x
))
7298 if (SCM_I_INUMP (y
))
7300 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7301 scm_remember_upto_here_1 (x
);
7302 return (sgn
< 0) ? x
: y
;
7304 else if (SCM_BIGP (y
))
7306 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7307 scm_remember_upto_here_2 (x
, y
);
7308 return (cmp
> 0) ? y
: x
;
7310 else if (SCM_REALP (y
))
7312 /* if y==NaN then xx<yy is false, so we return the NaN y */
7315 xx
= scm_i_big2dbl (x
);
7316 yy
= SCM_REAL_VALUE (y
);
7317 return (xx
< yy
? scm_from_double (xx
) : y
);
7319 else if (SCM_FRACTIONP (y
))
7324 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7326 else if (SCM_REALP (x
))
7328 if (SCM_I_INUMP (y
))
7330 double z
= SCM_I_INUM (y
);
7331 /* if x==NaN then "<" is false and we return NaN */
7332 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7334 else if (SCM_BIGP (y
))
7339 else if (SCM_REALP (y
))
7341 double xx
= SCM_REAL_VALUE (x
);
7342 double yy
= SCM_REAL_VALUE (y
);
7344 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7347 else if (SCM_LIKELY (xx
> yy
))
7349 /* If neither (xx < yy) nor (xx > yy), then
7350 either they're equal or one is a NaN */
7351 else if (SCM_UNLIKELY (isnan (xx
)))
7352 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7353 else if (SCM_UNLIKELY (isnan (yy
)))
7354 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7355 /* xx == yy, but handle signed zeroes properly */
7356 else if (double_is_non_negative_zero (xx
))
7361 else if (SCM_FRACTIONP (y
))
7363 double yy
= scm_i_fraction2double (y
);
7364 double xx
= SCM_REAL_VALUE (x
);
7365 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7368 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7370 else if (SCM_FRACTIONP (x
))
7372 if (SCM_I_INUMP (y
))
7376 else if (SCM_BIGP (y
))
7380 else if (SCM_REALP (y
))
7382 double xx
= scm_i_fraction2double (x
);
7383 /* if y==NaN then "<" is false, so we return the NaN y */
7384 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7386 else if (SCM_FRACTIONP (y
))
7391 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7394 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7398 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7399 (SCM x
, SCM y
, SCM rest
),
7400 "Return the sum of all parameter values. Return 0 if called without\n"
7402 #define FUNC_NAME s_scm_i_sum
7404 while (!scm_is_null (rest
))
7405 { x
= scm_sum (x
, y
);
7407 rest
= scm_cdr (rest
);
7409 return scm_sum (x
, y
);
7413 #define s_sum s_scm_i_sum
7414 #define g_sum g_scm_i_sum
7417 scm_sum (SCM x
, SCM y
)
7419 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7421 if (SCM_NUMBERP (x
)) return x
;
7422 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7423 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7426 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7428 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7430 scm_t_inum xx
= SCM_I_INUM (x
);
7431 scm_t_inum yy
= SCM_I_INUM (y
);
7432 scm_t_inum z
= xx
+ yy
;
7433 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7435 else if (SCM_BIGP (y
))
7440 else if (SCM_REALP (y
))
7442 scm_t_inum xx
= SCM_I_INUM (x
);
7443 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7445 else if (SCM_COMPLEXP (y
))
7447 scm_t_inum xx
= SCM_I_INUM (x
);
7448 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7449 SCM_COMPLEX_IMAG (y
));
7451 else if (SCM_FRACTIONP (y
))
7452 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7453 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7454 SCM_FRACTION_DENOMINATOR (y
));
7456 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7457 } else if (SCM_BIGP (x
))
7459 if (SCM_I_INUMP (y
))
7464 inum
= SCM_I_INUM (y
);
7467 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7470 SCM result
= scm_i_mkbig ();
7471 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7472 scm_remember_upto_here_1 (x
);
7473 /* we know the result will have to be a bignum */
7476 return scm_i_normbig (result
);
7480 SCM result
= scm_i_mkbig ();
7481 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7482 scm_remember_upto_here_1 (x
);
7483 /* we know the result will have to be a bignum */
7486 return scm_i_normbig (result
);
7489 else if (SCM_BIGP (y
))
7491 SCM result
= scm_i_mkbig ();
7492 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7493 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7494 mpz_add (SCM_I_BIG_MPZ (result
),
7497 scm_remember_upto_here_2 (x
, y
);
7498 /* we know the result will have to be a bignum */
7501 return scm_i_normbig (result
);
7503 else if (SCM_REALP (y
))
7505 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7506 scm_remember_upto_here_1 (x
);
7507 return scm_from_double (result
);
7509 else if (SCM_COMPLEXP (y
))
7511 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7512 + SCM_COMPLEX_REAL (y
));
7513 scm_remember_upto_here_1 (x
);
7514 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7516 else if (SCM_FRACTIONP (y
))
7517 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7518 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7519 SCM_FRACTION_DENOMINATOR (y
));
7521 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7523 else if (SCM_REALP (x
))
7525 if (SCM_I_INUMP (y
))
7526 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7527 else if (SCM_BIGP (y
))
7529 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7530 scm_remember_upto_here_1 (y
);
7531 return scm_from_double (result
);
7533 else if (SCM_REALP (y
))
7534 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7535 else if (SCM_COMPLEXP (y
))
7536 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7537 SCM_COMPLEX_IMAG (y
));
7538 else if (SCM_FRACTIONP (y
))
7539 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7541 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7543 else if (SCM_COMPLEXP (x
))
7545 if (SCM_I_INUMP (y
))
7546 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7547 SCM_COMPLEX_IMAG (x
));
7548 else if (SCM_BIGP (y
))
7550 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7551 + SCM_COMPLEX_REAL (x
));
7552 scm_remember_upto_here_1 (y
);
7553 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7555 else if (SCM_REALP (y
))
7556 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7557 SCM_COMPLEX_IMAG (x
));
7558 else if (SCM_COMPLEXP (y
))
7559 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7560 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7561 else if (SCM_FRACTIONP (y
))
7562 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7563 SCM_COMPLEX_IMAG (x
));
7565 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7567 else if (SCM_FRACTIONP (x
))
7569 if (SCM_I_INUMP (y
))
7570 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7571 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7572 SCM_FRACTION_DENOMINATOR (x
));
7573 else if (SCM_BIGP (y
))
7574 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7575 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7576 SCM_FRACTION_DENOMINATOR (x
));
7577 else if (SCM_REALP (y
))
7578 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7579 else if (SCM_COMPLEXP (y
))
7580 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7581 SCM_COMPLEX_IMAG (y
));
7582 else if (SCM_FRACTIONP (y
))
7583 /* a/b + c/d = (ad + bc) / bd */
7584 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7585 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7586 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7588 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7591 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7595 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7597 "Return @math{@var{x}+1}.")
7598 #define FUNC_NAME s_scm_oneplus
7600 return scm_sum (x
, SCM_INUM1
);
7605 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7606 (SCM x
, SCM y
, SCM rest
),
7607 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7608 "the sum of all but the first argument are subtracted from the first\n"
7610 #define FUNC_NAME s_scm_i_difference
7612 while (!scm_is_null (rest
))
7613 { x
= scm_difference (x
, y
);
7615 rest
= scm_cdr (rest
);
7617 return scm_difference (x
, y
);
7621 #define s_difference s_scm_i_difference
7622 #define g_difference g_scm_i_difference
7625 scm_difference (SCM x
, SCM y
)
7626 #define FUNC_NAME s_difference
7628 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7631 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7633 if (SCM_I_INUMP (x
))
7635 scm_t_inum xx
= -SCM_I_INUM (x
);
7636 if (SCM_FIXABLE (xx
))
7637 return SCM_I_MAKINUM (xx
);
7639 return scm_i_inum2big (xx
);
7641 else if (SCM_BIGP (x
))
7642 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7643 bignum, but negating that gives a fixnum. */
7644 return scm_i_normbig (scm_i_clonebig (x
, 0));
7645 else if (SCM_REALP (x
))
7646 return scm_from_double (-SCM_REAL_VALUE (x
));
7647 else if (SCM_COMPLEXP (x
))
7648 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7649 -SCM_COMPLEX_IMAG (x
));
7650 else if (SCM_FRACTIONP (x
))
7651 return scm_i_make_ratio_already_reduced
7652 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7653 SCM_FRACTION_DENOMINATOR (x
));
7655 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7658 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7660 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7662 scm_t_inum xx
= SCM_I_INUM (x
);
7663 scm_t_inum yy
= SCM_I_INUM (y
);
7664 scm_t_inum z
= xx
- yy
;
7665 if (SCM_FIXABLE (z
))
7666 return SCM_I_MAKINUM (z
);
7668 return scm_i_inum2big (z
);
7670 else if (SCM_BIGP (y
))
7672 /* inum-x - big-y */
7673 scm_t_inum xx
= SCM_I_INUM (x
);
7677 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7678 bignum, but negating that gives a fixnum. */
7679 return scm_i_normbig (scm_i_clonebig (y
, 0));
7683 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7684 SCM result
= scm_i_mkbig ();
7687 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7690 /* x - y == -(y + -x) */
7691 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7692 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7694 scm_remember_upto_here_1 (y
);
7696 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7697 /* we know the result will have to be a bignum */
7700 return scm_i_normbig (result
);
7703 else if (SCM_REALP (y
))
7705 scm_t_inum xx
= SCM_I_INUM (x
);
7708 * We need to handle x == exact 0
7709 * specially because R6RS states that:
7710 * (- 0.0) ==> -0.0 and
7711 * (- 0.0 0.0) ==> 0.0
7712 * and the scheme compiler changes
7713 * (- 0.0) into (- 0 0.0)
7714 * So we need to treat (- 0 0.0) like (- 0.0).
7715 * At the C level, (-x) is different than (0.0 - x).
7716 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7719 return scm_from_double (- SCM_REAL_VALUE (y
));
7721 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7723 else if (SCM_COMPLEXP (y
))
7725 scm_t_inum xx
= SCM_I_INUM (x
);
7727 /* We need to handle x == exact 0 specially.
7728 See the comment above (for SCM_REALP (y)) */
7730 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7731 - SCM_COMPLEX_IMAG (y
));
7733 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7734 - SCM_COMPLEX_IMAG (y
));
7736 else if (SCM_FRACTIONP (y
))
7737 /* a - b/c = (ac - b) / c */
7738 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7739 SCM_FRACTION_NUMERATOR (y
)),
7740 SCM_FRACTION_DENOMINATOR (y
));
7742 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7744 else if (SCM_BIGP (x
))
7746 if (SCM_I_INUMP (y
))
7748 /* big-x - inum-y */
7749 scm_t_inum yy
= SCM_I_INUM (y
);
7750 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7752 scm_remember_upto_here_1 (x
);
7754 return (SCM_FIXABLE (-yy
) ?
7755 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7758 SCM result
= scm_i_mkbig ();
7761 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7763 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7764 scm_remember_upto_here_1 (x
);
7766 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7767 /* we know the result will have to be a bignum */
7770 return scm_i_normbig (result
);
7773 else if (SCM_BIGP (y
))
7775 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7776 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7777 SCM result
= scm_i_mkbig ();
7778 mpz_sub (SCM_I_BIG_MPZ (result
),
7781 scm_remember_upto_here_2 (x
, y
);
7782 /* we know the result will have to be a bignum */
7783 if ((sgn_x
== 1) && (sgn_y
== -1))
7785 if ((sgn_x
== -1) && (sgn_y
== 1))
7787 return scm_i_normbig (result
);
7789 else if (SCM_REALP (y
))
7791 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7792 scm_remember_upto_here_1 (x
);
7793 return scm_from_double (result
);
7795 else if (SCM_COMPLEXP (y
))
7797 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7798 - SCM_COMPLEX_REAL (y
));
7799 scm_remember_upto_here_1 (x
);
7800 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7802 else if (SCM_FRACTIONP (y
))
7803 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7804 SCM_FRACTION_NUMERATOR (y
)),
7805 SCM_FRACTION_DENOMINATOR (y
));
7807 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7809 else if (SCM_REALP (x
))
7811 if (SCM_I_INUMP (y
))
7812 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7813 else if (SCM_BIGP (y
))
7815 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7816 scm_remember_upto_here_1 (x
);
7817 return scm_from_double (result
);
7819 else if (SCM_REALP (y
))
7820 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7821 else if (SCM_COMPLEXP (y
))
7822 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7823 -SCM_COMPLEX_IMAG (y
));
7824 else if (SCM_FRACTIONP (y
))
7825 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7827 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7829 else if (SCM_COMPLEXP (x
))
7831 if (SCM_I_INUMP (y
))
7832 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7833 SCM_COMPLEX_IMAG (x
));
7834 else if (SCM_BIGP (y
))
7836 double real_part
= (SCM_COMPLEX_REAL (x
)
7837 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7838 scm_remember_upto_here_1 (x
);
7839 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7841 else if (SCM_REALP (y
))
7842 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7843 SCM_COMPLEX_IMAG (x
));
7844 else if (SCM_COMPLEXP (y
))
7845 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7846 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7847 else if (SCM_FRACTIONP (y
))
7848 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7849 SCM_COMPLEX_IMAG (x
));
7851 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7853 else if (SCM_FRACTIONP (x
))
7855 if (SCM_I_INUMP (y
))
7856 /* a/b - c = (a - cb) / b */
7857 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7858 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7859 SCM_FRACTION_DENOMINATOR (x
));
7860 else if (SCM_BIGP (y
))
7861 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7862 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7863 SCM_FRACTION_DENOMINATOR (x
));
7864 else if (SCM_REALP (y
))
7865 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7866 else if (SCM_COMPLEXP (y
))
7867 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7868 -SCM_COMPLEX_IMAG (y
));
7869 else if (SCM_FRACTIONP (y
))
7870 /* a/b - c/d = (ad - bc) / bd */
7871 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7872 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7873 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7875 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7878 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7883 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7885 "Return @math{@var{x}-1}.")
7886 #define FUNC_NAME s_scm_oneminus
7888 return scm_difference (x
, SCM_INUM1
);
7893 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7894 (SCM x
, SCM y
, SCM rest
),
7895 "Return the product of all arguments. If called without arguments,\n"
7897 #define FUNC_NAME s_scm_i_product
7899 while (!scm_is_null (rest
))
7900 { x
= scm_product (x
, y
);
7902 rest
= scm_cdr (rest
);
7904 return scm_product (x
, y
);
7908 #define s_product s_scm_i_product
7909 #define g_product g_scm_i_product
7912 scm_product (SCM x
, SCM y
)
7914 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7917 return SCM_I_MAKINUM (1L);
7918 else if (SCM_NUMBERP (x
))
7921 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7924 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7929 xx
= SCM_I_INUM (x
);
7934 /* exact1 is the universal multiplicative identity */
7938 /* exact0 times a fixnum is exact0: optimize this case */
7939 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7941 /* if the other argument is inexact, the result is inexact,
7942 and we must do the multiplication in order to handle
7943 infinities and NaNs properly. */
7944 else if (SCM_REALP (y
))
7945 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7946 else if (SCM_COMPLEXP (y
))
7947 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7948 0.0 * SCM_COMPLEX_IMAG (y
));
7949 /* we've already handled inexact numbers,
7950 so y must be exact, and we return exact0 */
7951 else if (SCM_NUMP (y
))
7954 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7958 * This case is important for more than just optimization.
7959 * It handles the case of negating
7960 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7961 * which is a bignum that must be changed back into a fixnum.
7962 * Failure to do so will cause the following to return #f:
7963 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7965 return scm_difference(y
, SCM_UNDEFINED
);
7969 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7971 scm_t_inum yy
= SCM_I_INUM (y
);
7972 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7973 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7974 if (SCM_FIXABLE (kk
))
7975 return SCM_I_MAKINUM (kk
);
7977 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7978 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7979 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7980 return SCM_I_MAKINUM (xx
* yy
);
7984 SCM result
= scm_i_inum2big (xx
);
7985 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7986 return scm_i_normbig (result
);
7989 else if (SCM_BIGP (y
))
7991 SCM result
= scm_i_mkbig ();
7992 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7993 scm_remember_upto_here_1 (y
);
7996 else if (SCM_REALP (y
))
7997 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7998 else if (SCM_COMPLEXP (y
))
7999 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8000 xx
* SCM_COMPLEX_IMAG (y
));
8001 else if (SCM_FRACTIONP (y
))
8002 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8003 SCM_FRACTION_DENOMINATOR (y
));
8005 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8007 else if (SCM_BIGP (x
))
8009 if (SCM_I_INUMP (y
))
8014 else if (SCM_BIGP (y
))
8016 SCM result
= scm_i_mkbig ();
8017 mpz_mul (SCM_I_BIG_MPZ (result
),
8020 scm_remember_upto_here_2 (x
, y
);
8023 else if (SCM_REALP (y
))
8025 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8026 scm_remember_upto_here_1 (x
);
8027 return scm_from_double (result
);
8029 else if (SCM_COMPLEXP (y
))
8031 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8032 scm_remember_upto_here_1 (x
);
8033 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8034 z
* SCM_COMPLEX_IMAG (y
));
8036 else if (SCM_FRACTIONP (y
))
8037 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8038 SCM_FRACTION_DENOMINATOR (y
));
8040 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8042 else if (SCM_REALP (x
))
8044 if (SCM_I_INUMP (y
))
8049 else if (SCM_BIGP (y
))
8051 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8052 scm_remember_upto_here_1 (y
);
8053 return scm_from_double (result
);
8055 else if (SCM_REALP (y
))
8056 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8057 else if (SCM_COMPLEXP (y
))
8058 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8059 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8060 else if (SCM_FRACTIONP (y
))
8061 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8063 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8065 else if (SCM_COMPLEXP (x
))
8067 if (SCM_I_INUMP (y
))
8072 else if (SCM_BIGP (y
))
8074 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8075 scm_remember_upto_here_1 (y
);
8076 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8077 z
* SCM_COMPLEX_IMAG (x
));
8079 else if (SCM_REALP (y
))
8080 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8081 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8082 else if (SCM_COMPLEXP (y
))
8084 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8085 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8086 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8087 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8089 else if (SCM_FRACTIONP (y
))
8091 double yy
= scm_i_fraction2double (y
);
8092 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8093 yy
* SCM_COMPLEX_IMAG (x
));
8096 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8098 else if (SCM_FRACTIONP (x
))
8100 if (SCM_I_INUMP (y
))
8101 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8102 SCM_FRACTION_DENOMINATOR (x
));
8103 else if (SCM_BIGP (y
))
8104 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8105 SCM_FRACTION_DENOMINATOR (x
));
8106 else if (SCM_REALP (y
))
8107 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8108 else if (SCM_COMPLEXP (y
))
8110 double xx
= scm_i_fraction2double (x
);
8111 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8112 xx
* SCM_COMPLEX_IMAG (y
));
8114 else if (SCM_FRACTIONP (y
))
8115 /* a/b * c/d = ac / bd */
8116 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8117 SCM_FRACTION_NUMERATOR (y
)),
8118 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8119 SCM_FRACTION_DENOMINATOR (y
)));
8121 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8124 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8127 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8128 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8129 #define ALLOW_DIVIDE_BY_ZERO
8130 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8133 /* The code below for complex division is adapted from the GNU
8134 libstdc++, which adapted it from f2c's libF77, and is subject to
8137 /****************************************************************
8138 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8140 Permission to use, copy, modify, and distribute this software
8141 and its documentation for any purpose and without fee is hereby
8142 granted, provided that the above copyright notice appear in all
8143 copies and that both that the copyright notice and this
8144 permission notice and warranty disclaimer appear in supporting
8145 documentation, and that the names of AT&T Bell Laboratories or
8146 Bellcore or any of their entities not be used in advertising or
8147 publicity pertaining to distribution of the software without
8148 specific, written prior permission.
8150 AT&T and Bellcore disclaim all warranties with regard to this
8151 software, including all implied warranties of merchantability
8152 and fitness. In no event shall AT&T or Bellcore be liable for
8153 any special, indirect or consequential damages or any damages
8154 whatsoever resulting from loss of use, data or profits, whether
8155 in an action of contract, negligence or other tortious action,
8156 arising out of or in connection with the use or performance of
8158 ****************************************************************/
8160 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8161 (SCM x
, SCM y
, SCM rest
),
8162 "Divide the first argument by the product of the remaining\n"
8163 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8165 #define FUNC_NAME s_scm_i_divide
8167 while (!scm_is_null (rest
))
8168 { x
= scm_divide (x
, y
);
8170 rest
= scm_cdr (rest
);
8172 return scm_divide (x
, y
);
8176 #define s_divide s_scm_i_divide
8177 #define g_divide g_scm_i_divide
8180 scm_divide (SCM x
, SCM y
)
8181 #define FUNC_NAME s_divide
8185 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8188 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8189 else if (SCM_I_INUMP (x
))
8191 scm_t_inum xx
= SCM_I_INUM (x
);
8192 if (xx
== 1 || xx
== -1)
8194 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8196 scm_num_overflow (s_divide
);
8199 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8201 else if (SCM_BIGP (x
))
8202 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8203 else if (SCM_REALP (x
))
8205 double xx
= SCM_REAL_VALUE (x
);
8206 #ifndef ALLOW_DIVIDE_BY_ZERO
8208 scm_num_overflow (s_divide
);
8211 return scm_from_double (1.0 / xx
);
8213 else if (SCM_COMPLEXP (x
))
8215 double r
= SCM_COMPLEX_REAL (x
);
8216 double i
= SCM_COMPLEX_IMAG (x
);
8217 if (fabs(r
) <= fabs(i
))
8220 double d
= i
* (1.0 + t
* t
);
8221 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8226 double d
= r
* (1.0 + t
* t
);
8227 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8230 else if (SCM_FRACTIONP (x
))
8231 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8232 SCM_FRACTION_NUMERATOR (x
));
8234 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8237 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8239 scm_t_inum xx
= SCM_I_INUM (x
);
8240 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8242 scm_t_inum yy
= SCM_I_INUM (y
);
8245 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8246 scm_num_overflow (s_divide
);
8248 return scm_from_double ((double) xx
/ (double) yy
);
8251 else if (xx
% yy
!= 0)
8252 return scm_i_make_ratio (x
, y
);
8255 scm_t_inum z
= xx
/ yy
;
8256 if (SCM_FIXABLE (z
))
8257 return SCM_I_MAKINUM (z
);
8259 return scm_i_inum2big (z
);
8262 else if (SCM_BIGP (y
))
8263 return scm_i_make_ratio (x
, y
);
8264 else if (SCM_REALP (y
))
8266 double yy
= SCM_REAL_VALUE (y
);
8267 #ifndef ALLOW_DIVIDE_BY_ZERO
8269 scm_num_overflow (s_divide
);
8272 /* FIXME: Precision may be lost here due to:
8273 (1) The cast from 'scm_t_inum' to 'double'
8274 (2) Double rounding */
8275 return scm_from_double ((double) xx
/ yy
);
8277 else if (SCM_COMPLEXP (y
))
8280 complex_div
: /* y _must_ be a complex number */
8282 double r
= SCM_COMPLEX_REAL (y
);
8283 double i
= SCM_COMPLEX_IMAG (y
);
8284 if (fabs(r
) <= fabs(i
))
8287 double d
= i
* (1.0 + t
* t
);
8288 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8293 double d
= r
* (1.0 + t
* t
);
8294 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8298 else if (SCM_FRACTIONP (y
))
8299 /* a / b/c = ac / b */
8300 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8301 SCM_FRACTION_NUMERATOR (y
));
8303 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8305 else if (SCM_BIGP (x
))
8307 if (SCM_I_INUMP (y
))
8309 scm_t_inum yy
= SCM_I_INUM (y
);
8312 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8313 scm_num_overflow (s_divide
);
8315 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8316 scm_remember_upto_here_1 (x
);
8317 return (sgn
== 0) ? scm_nan () : scm_inf ();
8324 /* FIXME: HMM, what are the relative performance issues here?
8325 We need to test. Is it faster on average to test
8326 divisible_p, then perform whichever operation, or is it
8327 faster to perform the integer div opportunistically and
8328 switch to real if there's a remainder? For now we take the
8329 middle ground: test, then if divisible, use the faster div
8332 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8333 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8337 SCM result
= scm_i_mkbig ();
8338 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8339 scm_remember_upto_here_1 (x
);
8341 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8342 return scm_i_normbig (result
);
8345 return scm_i_make_ratio (x
, y
);
8348 else if (SCM_BIGP (y
))
8350 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8354 SCM result
= scm_i_mkbig ();
8355 mpz_divexact (SCM_I_BIG_MPZ (result
),
8358 scm_remember_upto_here_2 (x
, y
);
8359 return scm_i_normbig (result
);
8362 return scm_i_make_ratio (x
, y
);
8364 else if (SCM_REALP (y
))
8366 double yy
= SCM_REAL_VALUE (y
);
8367 #ifndef ALLOW_DIVIDE_BY_ZERO
8369 scm_num_overflow (s_divide
);
8372 /* FIXME: Precision may be lost here due to:
8373 (1) scm_i_big2dbl (2) Double rounding */
8374 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8376 else if (SCM_COMPLEXP (y
))
8378 a
= scm_i_big2dbl (x
);
8381 else if (SCM_FRACTIONP (y
))
8382 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8383 SCM_FRACTION_NUMERATOR (y
));
8385 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8387 else if (SCM_REALP (x
))
8389 double rx
= SCM_REAL_VALUE (x
);
8390 if (SCM_I_INUMP (y
))
8392 scm_t_inum yy
= SCM_I_INUM (y
);
8393 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8395 scm_num_overflow (s_divide
);
8398 /* FIXME: Precision may be lost here due to:
8399 (1) The cast from 'scm_t_inum' to 'double'
8400 (2) Double rounding */
8401 return scm_from_double (rx
/ (double) yy
);
8403 else if (SCM_BIGP (y
))
8405 /* FIXME: Precision may be lost here due to:
8406 (1) The conversion from bignum to double
8407 (2) Double rounding */
8408 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8409 scm_remember_upto_here_1 (y
);
8410 return scm_from_double (rx
/ dby
);
8412 else if (SCM_REALP (y
))
8414 double yy
= SCM_REAL_VALUE (y
);
8415 #ifndef ALLOW_DIVIDE_BY_ZERO
8417 scm_num_overflow (s_divide
);
8420 return scm_from_double (rx
/ yy
);
8422 else if (SCM_COMPLEXP (y
))
8427 else if (SCM_FRACTIONP (y
))
8428 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8430 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8432 else if (SCM_COMPLEXP (x
))
8434 double rx
= SCM_COMPLEX_REAL (x
);
8435 double ix
= SCM_COMPLEX_IMAG (x
);
8436 if (SCM_I_INUMP (y
))
8438 scm_t_inum yy
= SCM_I_INUM (y
);
8439 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8441 scm_num_overflow (s_divide
);
8445 /* FIXME: Precision may be lost here due to:
8446 (1) The conversion from 'scm_t_inum' to double
8447 (2) Double rounding */
8449 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8452 else if (SCM_BIGP (y
))
8454 /* FIXME: Precision may be lost here due to:
8455 (1) The conversion from bignum to double
8456 (2) Double rounding */
8457 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8458 scm_remember_upto_here_1 (y
);
8459 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8461 else if (SCM_REALP (y
))
8463 double yy
= SCM_REAL_VALUE (y
);
8464 #ifndef ALLOW_DIVIDE_BY_ZERO
8466 scm_num_overflow (s_divide
);
8469 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8471 else if (SCM_COMPLEXP (y
))
8473 double ry
= SCM_COMPLEX_REAL (y
);
8474 double iy
= SCM_COMPLEX_IMAG (y
);
8475 if (fabs(ry
) <= fabs(iy
))
8478 double d
= iy
* (1.0 + t
* t
);
8479 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8484 double d
= ry
* (1.0 + t
* t
);
8485 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8488 else if (SCM_FRACTIONP (y
))
8490 /* FIXME: Precision may be lost here due to:
8491 (1) The conversion from fraction to double
8492 (2) Double rounding */
8493 double yy
= scm_i_fraction2double (y
);
8494 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8497 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8499 else if (SCM_FRACTIONP (x
))
8501 if (SCM_I_INUMP (y
))
8503 scm_t_inum yy
= SCM_I_INUM (y
);
8504 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8506 scm_num_overflow (s_divide
);
8509 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8510 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8512 else if (SCM_BIGP (y
))
8514 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8515 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8517 else if (SCM_REALP (y
))
8519 double yy
= SCM_REAL_VALUE (y
);
8520 #ifndef ALLOW_DIVIDE_BY_ZERO
8522 scm_num_overflow (s_divide
);
8525 /* FIXME: Precision may be lost here due to:
8526 (1) The conversion from fraction to double
8527 (2) Double rounding */
8528 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8530 else if (SCM_COMPLEXP (y
))
8532 /* FIXME: Precision may be lost here due to:
8533 (1) The conversion from fraction to double
8534 (2) Double rounding */
8535 a
= scm_i_fraction2double (x
);
8538 else if (SCM_FRACTIONP (y
))
8539 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8540 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8542 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8545 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8551 scm_c_truncate (double x
)
8556 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8557 half-way case (ie. when x is an integer plus 0.5) going upwards.
8558 Then half-way cases are identified and adjusted down if the
8559 round-upwards didn't give the desired even integer.
8561 "plus_half == result" identifies a half-way case. If plus_half, which is
8562 x + 0.5, is an integer then x must be an integer plus 0.5.
8564 An odd "result" value is identified with result/2 != floor(result/2).
8565 This is done with plus_half, since that value is ready for use sooner in
8566 a pipelined cpu, and we're already requiring plus_half == result.
8568 Note however that we need to be careful when x is big and already an
8569 integer. In that case "x+0.5" may round to an adjacent integer, causing
8570 us to return such a value, incorrectly. For instance if the hardware is
8571 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8572 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8573 returned. Or if the hardware is in round-upwards mode, then other bigger
8574 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8575 representable value, 2^128+2^76 (or whatever), again incorrect.
8577 These bad roundings of x+0.5 are avoided by testing at the start whether
8578 x is already an integer. If it is then clearly that's the desired result
8579 already. And if it's not then the exponent must be small enough to allow
8580 an 0.5 to be represented, and hence added without a bad rounding. */
8583 scm_c_round (double x
)
8585 double plus_half
, result
;
8590 plus_half
= x
+ 0.5;
8591 result
= floor (plus_half
);
8592 /* Adjust so that the rounding is towards even. */
8593 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8598 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8600 "Round the number @var{x} towards zero.")
8601 #define FUNC_NAME s_scm_truncate_number
8603 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8605 else if (SCM_REALP (x
))
8606 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8607 else if (SCM_FRACTIONP (x
))
8608 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8609 SCM_FRACTION_DENOMINATOR (x
));
8611 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8612 s_scm_truncate_number
);
8616 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8618 "Round the number @var{x} towards the nearest integer. "
8619 "When it is exactly halfway between two integers, "
8620 "round towards the even one.")
8621 #define FUNC_NAME s_scm_round_number
8623 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8625 else if (SCM_REALP (x
))
8626 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8627 else if (SCM_FRACTIONP (x
))
8628 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8629 SCM_FRACTION_DENOMINATOR (x
));
8631 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8632 s_scm_round_number
);
8636 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8638 "Round the number @var{x} towards minus infinity.")
8639 #define FUNC_NAME s_scm_floor
8641 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8643 else if (SCM_REALP (x
))
8644 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8645 else if (SCM_FRACTIONP (x
))
8646 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8647 SCM_FRACTION_DENOMINATOR (x
));
8649 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8653 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8655 "Round the number @var{x} towards infinity.")
8656 #define FUNC_NAME s_scm_ceiling
8658 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8660 else if (SCM_REALP (x
))
8661 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8662 else if (SCM_FRACTIONP (x
))
8663 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8664 SCM_FRACTION_DENOMINATOR (x
));
8666 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8670 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8672 "Return @var{x} raised to the power of @var{y}.")
8673 #define FUNC_NAME s_scm_expt
8675 if (scm_is_integer (y
))
8677 if (scm_is_true (scm_exact_p (y
)))
8678 return scm_integer_expt (x
, y
);
8681 /* Here we handle the case where the exponent is an inexact
8682 integer. We make the exponent exact in order to use
8683 scm_integer_expt, and thus avoid the spurious imaginary
8684 parts that may result from round-off errors in the general
8685 e^(y log x) method below (for example when squaring a large
8686 negative number). In this case, we must return an inexact
8687 result for correctness. We also make the base inexact so
8688 that scm_integer_expt will use fast inexact arithmetic
8689 internally. Note that making the base inexact is not
8690 sufficient to guarantee an inexact result, because
8691 scm_integer_expt will return an exact 1 when the exponent
8692 is 0, even if the base is inexact. */
8693 return scm_exact_to_inexact
8694 (scm_integer_expt (scm_exact_to_inexact (x
),
8695 scm_inexact_to_exact (y
)));
8698 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8700 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8702 else if (scm_is_complex (x
) && scm_is_complex (y
))
8703 return scm_exp (scm_product (scm_log (x
), y
));
8704 else if (scm_is_complex (x
))
8705 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8707 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8711 /* sin/cos/tan/asin/acos/atan
8712 sinh/cosh/tanh/asinh/acosh/atanh
8713 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8714 Written by Jerry D. Hedden, (C) FSF.
8715 See the file `COPYING' for terms applying to this program. */
8717 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8719 "Compute the sine of @var{z}.")
8720 #define FUNC_NAME s_scm_sin
8722 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8723 return z
; /* sin(exact0) = exact0 */
8724 else if (scm_is_real (z
))
8725 return scm_from_double (sin (scm_to_double (z
)));
8726 else if (SCM_COMPLEXP (z
))
8728 x
= SCM_COMPLEX_REAL (z
);
8729 y
= SCM_COMPLEX_IMAG (z
);
8730 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8731 cos (x
) * sinh (y
));
8734 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8738 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8740 "Compute the cosine of @var{z}.")
8741 #define FUNC_NAME s_scm_cos
8743 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8744 return SCM_INUM1
; /* cos(exact0) = exact1 */
8745 else if (scm_is_real (z
))
8746 return scm_from_double (cos (scm_to_double (z
)));
8747 else if (SCM_COMPLEXP (z
))
8749 x
= SCM_COMPLEX_REAL (z
);
8750 y
= SCM_COMPLEX_IMAG (z
);
8751 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8752 -sin (x
) * sinh (y
));
8755 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8759 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8761 "Compute the tangent of @var{z}.")
8762 #define FUNC_NAME s_scm_tan
8764 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8765 return z
; /* tan(exact0) = exact0 */
8766 else if (scm_is_real (z
))
8767 return scm_from_double (tan (scm_to_double (z
)));
8768 else if (SCM_COMPLEXP (z
))
8770 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8771 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8772 w
= cos (x
) + cosh (y
);
8773 #ifndef ALLOW_DIVIDE_BY_ZERO
8775 scm_num_overflow (s_scm_tan
);
8777 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8780 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8784 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8786 "Compute the hyperbolic sine of @var{z}.")
8787 #define FUNC_NAME s_scm_sinh
8789 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8790 return z
; /* sinh(exact0) = exact0 */
8791 else if (scm_is_real (z
))
8792 return scm_from_double (sinh (scm_to_double (z
)));
8793 else if (SCM_COMPLEXP (z
))
8795 x
= SCM_COMPLEX_REAL (z
);
8796 y
= SCM_COMPLEX_IMAG (z
);
8797 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8798 cosh (x
) * sin (y
));
8801 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8805 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8807 "Compute the hyperbolic cosine of @var{z}.")
8808 #define FUNC_NAME s_scm_cosh
8810 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8811 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8812 else if (scm_is_real (z
))
8813 return scm_from_double (cosh (scm_to_double (z
)));
8814 else if (SCM_COMPLEXP (z
))
8816 x
= SCM_COMPLEX_REAL (z
);
8817 y
= SCM_COMPLEX_IMAG (z
);
8818 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8819 sinh (x
) * sin (y
));
8822 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8826 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8828 "Compute the hyperbolic tangent of @var{z}.")
8829 #define FUNC_NAME s_scm_tanh
8831 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8832 return z
; /* tanh(exact0) = exact0 */
8833 else if (scm_is_real (z
))
8834 return scm_from_double (tanh (scm_to_double (z
)));
8835 else if (SCM_COMPLEXP (z
))
8837 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8838 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8839 w
= cosh (x
) + cos (y
);
8840 #ifndef ALLOW_DIVIDE_BY_ZERO
8842 scm_num_overflow (s_scm_tanh
);
8844 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8847 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8851 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8853 "Compute the arc sine of @var{z}.")
8854 #define FUNC_NAME s_scm_asin
8856 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8857 return z
; /* asin(exact0) = exact0 */
8858 else if (scm_is_real (z
))
8860 double w
= scm_to_double (z
);
8861 if (w
>= -1.0 && w
<= 1.0)
8862 return scm_from_double (asin (w
));
8864 return scm_product (scm_c_make_rectangular (0, -1),
8865 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8867 else if (SCM_COMPLEXP (z
))
8869 x
= SCM_COMPLEX_REAL (z
);
8870 y
= SCM_COMPLEX_IMAG (z
);
8871 return scm_product (scm_c_make_rectangular (0, -1),
8872 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8875 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8879 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8881 "Compute the arc cosine of @var{z}.")
8882 #define FUNC_NAME s_scm_acos
8884 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8885 return SCM_INUM0
; /* acos(exact1) = exact0 */
8886 else if (scm_is_real (z
))
8888 double w
= scm_to_double (z
);
8889 if (w
>= -1.0 && w
<= 1.0)
8890 return scm_from_double (acos (w
));
8892 return scm_sum (scm_from_double (acos (0.0)),
8893 scm_product (scm_c_make_rectangular (0, 1),
8894 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8896 else if (SCM_COMPLEXP (z
))
8898 x
= SCM_COMPLEX_REAL (z
);
8899 y
= SCM_COMPLEX_IMAG (z
);
8900 return scm_sum (scm_from_double (acos (0.0)),
8901 scm_product (scm_c_make_rectangular (0, 1),
8902 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8905 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8909 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8911 "With one argument, compute the arc tangent of @var{z}.\n"
8912 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8913 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8914 #define FUNC_NAME s_scm_atan
8918 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8919 return z
; /* atan(exact0) = exact0 */
8920 else if (scm_is_real (z
))
8921 return scm_from_double (atan (scm_to_double (z
)));
8922 else if (SCM_COMPLEXP (z
))
8925 v
= SCM_COMPLEX_REAL (z
);
8926 w
= SCM_COMPLEX_IMAG (z
);
8927 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8928 scm_c_make_rectangular (v
, w
+ 1.0))),
8929 scm_c_make_rectangular (0, 2));
8932 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8934 else if (scm_is_real (z
))
8936 if (scm_is_real (y
))
8937 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8939 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8942 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8946 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8948 "Compute the inverse hyperbolic sine of @var{z}.")
8949 #define FUNC_NAME s_scm_sys_asinh
8951 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8952 return z
; /* asinh(exact0) = exact0 */
8953 else if (scm_is_real (z
))
8954 return scm_from_double (asinh (scm_to_double (z
)));
8955 else if (scm_is_number (z
))
8956 return scm_log (scm_sum (z
,
8957 scm_sqrt (scm_sum (scm_product (z
, z
),
8960 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8964 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8966 "Compute the inverse hyperbolic cosine of @var{z}.")
8967 #define FUNC_NAME s_scm_sys_acosh
8969 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8970 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8971 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8972 return scm_from_double (acosh (scm_to_double (z
)));
8973 else if (scm_is_number (z
))
8974 return scm_log (scm_sum (z
,
8975 scm_sqrt (scm_difference (scm_product (z
, z
),
8978 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8982 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8984 "Compute the inverse hyperbolic tangent of @var{z}.")
8985 #define FUNC_NAME s_scm_sys_atanh
8987 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8988 return z
; /* atanh(exact0) = exact0 */
8989 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8990 return scm_from_double (atanh (scm_to_double (z
)));
8991 else if (scm_is_number (z
))
8992 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8993 scm_difference (SCM_INUM1
, z
))),
8996 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9001 scm_c_make_rectangular (double re
, double im
)
9005 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9007 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9008 SCM_COMPLEX_REAL (z
) = re
;
9009 SCM_COMPLEX_IMAG (z
) = im
;
9013 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9014 (SCM real_part
, SCM imaginary_part
),
9015 "Return a complex number constructed of the given @var{real_part} "
9016 "and @var{imaginary_part} parts.")
9017 #define FUNC_NAME s_scm_make_rectangular
9019 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9020 SCM_ARG1
, FUNC_NAME
, "real");
9021 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9022 SCM_ARG2
, FUNC_NAME
, "real");
9024 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9025 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9028 return scm_c_make_rectangular (scm_to_double (real_part
),
9029 scm_to_double (imaginary_part
));
9034 scm_c_make_polar (double mag
, double ang
)
9038 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9039 use it on Glibc-based systems that have it (it's a GNU extension). See
9040 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9042 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9043 sincos (ang
, &s
, &c
);
9049 /* If s and c are NaNs, this indicates that the angle is a NaN,
9050 infinite, or perhaps simply too large to determine its value
9051 mod 2*pi. However, we know something that the floating-point
9052 implementation doesn't know: We know that s and c are finite.
9053 Therefore, if the magnitude is zero, return a complex zero.
9055 The reason we check for the NaNs instead of using this case
9056 whenever mag == 0.0 is because when the angle is known, we'd
9057 like to return the correct kind of non-real complex zero:
9058 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9059 on which quadrant the angle is in.
9061 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9062 return scm_c_make_rectangular (0.0, 0.0);
9064 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9067 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9069 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9070 #define FUNC_NAME s_scm_make_polar
9072 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9073 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9075 /* If mag is exact0, return exact0 */
9076 if (scm_is_eq (mag
, SCM_INUM0
))
9078 /* Return a real if ang is exact0 */
9079 else if (scm_is_eq (ang
, SCM_INUM0
))
9082 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9087 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9089 "Return the real part of the number @var{z}.")
9090 #define FUNC_NAME s_scm_real_part
9092 if (SCM_COMPLEXP (z
))
9093 return scm_from_double (SCM_COMPLEX_REAL (z
));
9094 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9097 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9102 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9104 "Return the imaginary part of the number @var{z}.")
9105 #define FUNC_NAME s_scm_imag_part
9107 if (SCM_COMPLEXP (z
))
9108 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9109 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9112 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9116 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9118 "Return the numerator of the number @var{z}.")
9119 #define FUNC_NAME s_scm_numerator
9121 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9123 else if (SCM_FRACTIONP (z
))
9124 return SCM_FRACTION_NUMERATOR (z
);
9125 else if (SCM_REALP (z
))
9126 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9128 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9133 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9135 "Return the denominator of the number @var{z}.")
9136 #define FUNC_NAME s_scm_denominator
9138 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9140 else if (SCM_FRACTIONP (z
))
9141 return SCM_FRACTION_DENOMINATOR (z
);
9142 else if (SCM_REALP (z
))
9143 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9145 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9151 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9153 "Return the magnitude of the number @var{z}. This is the same as\n"
9154 "@code{abs} for real arguments, but also allows complex numbers.")
9155 #define FUNC_NAME s_scm_magnitude
9157 if (SCM_I_INUMP (z
))
9159 scm_t_inum zz
= SCM_I_INUM (z
);
9162 else if (SCM_POSFIXABLE (-zz
))
9163 return SCM_I_MAKINUM (-zz
);
9165 return scm_i_inum2big (-zz
);
9167 else if (SCM_BIGP (z
))
9169 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9170 scm_remember_upto_here_1 (z
);
9172 return scm_i_clonebig (z
, 0);
9176 else if (SCM_REALP (z
))
9177 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9178 else if (SCM_COMPLEXP (z
))
9179 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9180 else if (SCM_FRACTIONP (z
))
9182 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9184 return scm_i_make_ratio_already_reduced
9185 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9186 SCM_FRACTION_DENOMINATOR (z
));
9189 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9195 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9197 "Return the angle of the complex number @var{z}.")
9198 #define FUNC_NAME s_scm_angle
9200 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9201 flo0 to save allocating a new flonum with scm_from_double each time.
9202 But if atan2 follows the floating point rounding mode, then the value
9203 is not a constant. Maybe it'd be close enough though. */
9204 if (SCM_I_INUMP (z
))
9206 if (SCM_I_INUM (z
) >= 0)
9209 return scm_from_double (atan2 (0.0, -1.0));
9211 else if (SCM_BIGP (z
))
9213 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9214 scm_remember_upto_here_1 (z
);
9216 return scm_from_double (atan2 (0.0, -1.0));
9220 else if (SCM_REALP (z
))
9222 double x
= SCM_REAL_VALUE (z
);
9223 if (x
> 0.0 || double_is_non_negative_zero (x
))
9226 return scm_from_double (atan2 (0.0, -1.0));
9228 else if (SCM_COMPLEXP (z
))
9229 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9230 else if (SCM_FRACTIONP (z
))
9232 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9234 else return scm_from_double (atan2 (0.0, -1.0));
9237 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9242 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9244 "Convert the number @var{z} to its inexact representation.\n")
9245 #define FUNC_NAME s_scm_exact_to_inexact
9247 if (SCM_I_INUMP (z
))
9248 return scm_from_double ((double) SCM_I_INUM (z
));
9249 else if (SCM_BIGP (z
))
9250 return scm_from_double (scm_i_big2dbl (z
));
9251 else if (SCM_FRACTIONP (z
))
9252 return scm_from_double (scm_i_fraction2double (z
));
9253 else if (SCM_INEXACTP (z
))
9256 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9257 s_scm_exact_to_inexact
);
9262 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9264 "Return an exact number that is numerically closest to @var{z}.")
9265 #define FUNC_NAME s_scm_inexact_to_exact
9267 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9274 val
= SCM_REAL_VALUE (z
);
9275 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9276 val
= SCM_COMPLEX_REAL (z
);
9278 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9279 s_scm_inexact_to_exact
);
9281 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9282 SCM_OUT_OF_RANGE (1, z
);
9283 else if (val
== 0.0)
9290 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9292 expon
-= DBL_MANT_DIG
;
9295 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9299 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9300 SCM_I_BIG_MPZ (numerator
),
9304 numerator
= scm_i_normbig (numerator
);
9306 return scm_i_make_ratio_already_reduced
9307 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9309 return left_shift_exact_integer (numerator
, expon
);
9317 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9319 "Returns the @emph{simplest} rational number differing\n"
9320 "from @var{x} by no more than @var{eps}.\n"
9322 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9323 "exact result when both its arguments are exact. Thus, you might need\n"
9324 "to use @code{inexact->exact} on the arguments.\n"
9327 "(rationalize (inexact->exact 1.2) 1/100)\n"
9330 #define FUNC_NAME s_scm_rationalize
9332 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9333 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9334 eps
= scm_abs (eps
);
9335 if (scm_is_false (scm_positive_p (eps
)))
9337 /* eps is either zero or a NaN */
9338 if (scm_is_true (scm_nan_p (eps
)))
9340 else if (SCM_INEXACTP (eps
))
9341 return scm_exact_to_inexact (x
);
9345 else if (scm_is_false (scm_finite_p (eps
)))
9347 if (scm_is_true (scm_finite_p (x
)))
9352 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9354 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9355 scm_ceiling (scm_difference (x
, eps
)))))
9357 /* There's an integer within range; we want the one closest to zero */
9358 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9360 /* zero is within range */
9361 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9366 else if (scm_is_true (scm_positive_p (x
)))
9367 return scm_ceiling (scm_difference (x
, eps
));
9369 return scm_floor (scm_sum (x
, eps
));
9373 /* Use continued fractions to find closest ratio. All
9374 arithmetic is done with exact numbers.
9377 SCM ex
= scm_inexact_to_exact (x
);
9378 SCM int_part
= scm_floor (ex
);
9380 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9381 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9385 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9386 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9388 /* We stop after a million iterations just to be absolutely sure
9389 that we don't go into an infinite loop. The process normally
9390 converges after less than a dozen iterations.
9393 while (++i
< 1000000)
9395 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9396 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9397 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9399 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9400 eps
))) /* abs(x-a/b) <= eps */
9402 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9403 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9404 return scm_exact_to_inexact (res
);
9408 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9410 tt
= scm_floor (rx
); /* tt = floor (rx) */
9416 scm_num_overflow (s_scm_rationalize
);
9421 /* conversion functions */
9424 scm_is_integer (SCM val
)
9426 return scm_is_true (scm_integer_p (val
));
9430 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9432 if (SCM_I_INUMP (val
))
9434 scm_t_signed_bits n
= SCM_I_INUM (val
);
9435 return n
>= min
&& n
<= max
;
9437 else if (SCM_BIGP (val
))
9439 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9441 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9443 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9445 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9446 return n
>= min
&& n
<= max
;
9456 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9457 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9460 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9461 SCM_I_BIG_MPZ (val
));
9463 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9475 return n
>= min
&& n
<= max
;
9483 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9485 if (SCM_I_INUMP (val
))
9487 scm_t_signed_bits n
= SCM_I_INUM (val
);
9488 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9490 else if (SCM_BIGP (val
))
9492 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9494 else if (max
<= ULONG_MAX
)
9496 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9498 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9499 return n
>= min
&& n
<= max
;
9509 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9512 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9513 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9516 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9517 SCM_I_BIG_MPZ (val
));
9519 return n
>= min
&& n
<= max
;
9527 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9529 scm_error (scm_out_of_range_key
,
9531 "Value out of range ~S to ~S: ~S",
9532 scm_list_3 (min
, max
, bad_val
),
9533 scm_list_1 (bad_val
));
9536 #define TYPE scm_t_intmax
9537 #define TYPE_MIN min
9538 #define TYPE_MAX max
9539 #define SIZEOF_TYPE 0
9540 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9541 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9542 #include "libguile/conv-integer.i.c"
9544 #define TYPE scm_t_uintmax
9545 #define TYPE_MIN min
9546 #define TYPE_MAX max
9547 #define SIZEOF_TYPE 0
9548 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9549 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9550 #include "libguile/conv-uinteger.i.c"
9552 #define TYPE scm_t_int8
9553 #define TYPE_MIN SCM_T_INT8_MIN
9554 #define TYPE_MAX SCM_T_INT8_MAX
9555 #define SIZEOF_TYPE 1
9556 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9557 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9558 #include "libguile/conv-integer.i.c"
9560 #define TYPE scm_t_uint8
9562 #define TYPE_MAX SCM_T_UINT8_MAX
9563 #define SIZEOF_TYPE 1
9564 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9565 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9566 #include "libguile/conv-uinteger.i.c"
9568 #define TYPE scm_t_int16
9569 #define TYPE_MIN SCM_T_INT16_MIN
9570 #define TYPE_MAX SCM_T_INT16_MAX
9571 #define SIZEOF_TYPE 2
9572 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9573 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9574 #include "libguile/conv-integer.i.c"
9576 #define TYPE scm_t_uint16
9578 #define TYPE_MAX SCM_T_UINT16_MAX
9579 #define SIZEOF_TYPE 2
9580 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9581 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9582 #include "libguile/conv-uinteger.i.c"
9584 #define TYPE scm_t_int32
9585 #define TYPE_MIN SCM_T_INT32_MIN
9586 #define TYPE_MAX SCM_T_INT32_MAX
9587 #define SIZEOF_TYPE 4
9588 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9589 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9590 #include "libguile/conv-integer.i.c"
9592 #define TYPE scm_t_uint32
9594 #define TYPE_MAX SCM_T_UINT32_MAX
9595 #define SIZEOF_TYPE 4
9596 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9597 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9598 #include "libguile/conv-uinteger.i.c"
9600 #define TYPE scm_t_wchar
9601 #define TYPE_MIN (scm_t_int32)-1
9602 #define TYPE_MAX (scm_t_int32)0x10ffff
9603 #define SIZEOF_TYPE 4
9604 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9605 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9606 #include "libguile/conv-integer.i.c"
9608 #define TYPE scm_t_int64
9609 #define TYPE_MIN SCM_T_INT64_MIN
9610 #define TYPE_MAX SCM_T_INT64_MAX
9611 #define SIZEOF_TYPE 8
9612 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9613 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9614 #include "libguile/conv-integer.i.c"
9616 #define TYPE scm_t_uint64
9618 #define TYPE_MAX SCM_T_UINT64_MAX
9619 #define SIZEOF_TYPE 8
9620 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9621 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9622 #include "libguile/conv-uinteger.i.c"
9625 scm_to_mpz (SCM val
, mpz_t rop
)
9627 if (SCM_I_INUMP (val
))
9628 mpz_set_si (rop
, SCM_I_INUM (val
));
9629 else if (SCM_BIGP (val
))
9630 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9632 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9636 scm_from_mpz (mpz_t val
)
9638 return scm_i_mpz2num (val
);
9642 scm_is_real (SCM val
)
9644 return scm_is_true (scm_real_p (val
));
9648 scm_is_rational (SCM val
)
9650 return scm_is_true (scm_rational_p (val
));
9654 scm_to_double (SCM val
)
9656 if (SCM_I_INUMP (val
))
9657 return SCM_I_INUM (val
);
9658 else if (SCM_BIGP (val
))
9659 return scm_i_big2dbl (val
);
9660 else if (SCM_FRACTIONP (val
))
9661 return scm_i_fraction2double (val
);
9662 else if (SCM_REALP (val
))
9663 return SCM_REAL_VALUE (val
);
9665 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9669 scm_from_double (double val
)
9673 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9675 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9676 SCM_REAL_VALUE (z
) = val
;
9682 scm_is_complex (SCM val
)
9684 return scm_is_true (scm_complex_p (val
));
9688 scm_c_real_part (SCM z
)
9690 if (SCM_COMPLEXP (z
))
9691 return SCM_COMPLEX_REAL (z
);
9694 /* Use the scm_real_part to get proper error checking and
9697 return scm_to_double (scm_real_part (z
));
9702 scm_c_imag_part (SCM z
)
9704 if (SCM_COMPLEXP (z
))
9705 return SCM_COMPLEX_IMAG (z
);
9708 /* Use the scm_imag_part to get proper error checking and
9709 dispatching. The result will almost always be 0.0, but not
9712 return scm_to_double (scm_imag_part (z
));
9717 scm_c_magnitude (SCM z
)
9719 return scm_to_double (scm_magnitude (z
));
9725 return scm_to_double (scm_angle (z
));
9729 scm_is_number (SCM z
)
9731 return scm_is_true (scm_number_p (z
));
9735 /* Returns log(x * 2^shift) */
9737 log_of_shifted_double (double x
, long shift
)
9739 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9741 if (x
> 0.0 || double_is_non_negative_zero (x
))
9742 return scm_from_double (ans
);
9744 return scm_c_make_rectangular (ans
, M_PI
);
9747 /* Returns log(n), for exact integer n */
9749 log_of_exact_integer (SCM n
)
9751 if (SCM_I_INUMP (n
))
9752 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9753 else if (SCM_BIGP (n
))
9756 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9757 return log_of_shifted_double (signif
, expon
);
9760 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9763 /* Returns log(n/d), for exact non-zero integers n and d */
9765 log_of_fraction (SCM n
, SCM d
)
9767 long n_size
= scm_to_long (scm_integer_length (n
));
9768 long d_size
= scm_to_long (scm_integer_length (d
));
9770 if (abs (n_size
- d_size
) > 1)
9771 return (scm_difference (log_of_exact_integer (n
),
9772 log_of_exact_integer (d
)));
9773 else if (scm_is_false (scm_negative_p (n
)))
9774 return scm_from_double
9775 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9777 return scm_c_make_rectangular
9778 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9784 /* In the following functions we dispatch to the real-arg funcs like log()
9785 when we know the arg is real, instead of just handing everything to
9786 clog() for instance. This is in case clog() doesn't optimize for a
9787 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9788 well use it to go straight to the applicable C func. */
9790 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9792 "Return the natural logarithm of @var{z}.")
9793 #define FUNC_NAME s_scm_log
9795 if (SCM_COMPLEXP (z
))
9797 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9798 && defined (SCM_COMPLEX_VALUE)
9799 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9801 double re
= SCM_COMPLEX_REAL (z
);
9802 double im
= SCM_COMPLEX_IMAG (z
);
9803 return scm_c_make_rectangular (log (hypot (re
, im
)),
9807 else if (SCM_REALP (z
))
9808 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9809 else if (SCM_I_INUMP (z
))
9811 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9812 if (scm_is_eq (z
, SCM_INUM0
))
9813 scm_num_overflow (s_scm_log
);
9815 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9817 else if (SCM_BIGP (z
))
9818 return log_of_exact_integer (z
);
9819 else if (SCM_FRACTIONP (z
))
9820 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9821 SCM_FRACTION_DENOMINATOR (z
));
9823 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9828 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9830 "Return the base 10 logarithm of @var{z}.")
9831 #define FUNC_NAME s_scm_log10
9833 if (SCM_COMPLEXP (z
))
9835 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9836 clog() and a multiply by M_LOG10E, rather than the fallback
9837 log10+hypot+atan2.) */
9838 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9839 && defined SCM_COMPLEX_VALUE
9840 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9842 double re
= SCM_COMPLEX_REAL (z
);
9843 double im
= SCM_COMPLEX_IMAG (z
);
9844 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9845 M_LOG10E
* atan2 (im
, re
));
9848 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9850 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9851 if (scm_is_eq (z
, SCM_INUM0
))
9852 scm_num_overflow (s_scm_log10
);
9855 double re
= scm_to_double (z
);
9856 double l
= log10 (fabs (re
));
9857 if (re
> 0.0 || double_is_non_negative_zero (re
))
9858 return scm_from_double (l
);
9860 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9863 else if (SCM_BIGP (z
))
9864 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9865 else if (SCM_FRACTIONP (z
))
9866 return scm_product (flo_log10e
,
9867 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9868 SCM_FRACTION_DENOMINATOR (z
)));
9870 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9875 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9877 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9878 "base of natural logarithms (2.71828@dots{}).")
9879 #define FUNC_NAME s_scm_exp
9881 if (SCM_COMPLEXP (z
))
9883 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9884 && defined (SCM_COMPLEX_VALUE)
9885 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9887 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9888 SCM_COMPLEX_IMAG (z
));
9891 else if (SCM_NUMBERP (z
))
9893 /* When z is a negative bignum the conversion to double overflows,
9894 giving -infinity, but that's ok, the exp is still 0.0. */
9895 return scm_from_double (exp (scm_to_double (z
)));
9898 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9903 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9905 "Return two exact non-negative integers @var{s} and @var{r}\n"
9906 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9907 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9908 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9911 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9913 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9917 scm_exact_integer_sqrt (k
, &s
, &r
);
9918 return scm_values (scm_list_2 (s
, r
));
9923 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9925 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9929 if (SCM_I_INUM (k
) < 0)
9930 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9931 "exact non-negative integer");
9932 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
9933 mpz_inits (ss
, rr
, NULL
);
9934 mpz_sqrtrem (ss
, rr
, kk
);
9935 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
9936 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
9937 mpz_clears (kk
, ss
, rr
, NULL
);
9939 else if (SCM_LIKELY (SCM_BIGP (k
)))
9943 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9944 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9945 "exact non-negative integer");
9948 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9949 scm_remember_upto_here_1 (k
);
9950 *sp
= scm_i_normbig (s
);
9951 *rp
= scm_i_normbig (r
);
9954 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9955 "exact non-negative integer");
9958 /* Return true iff K is a perfect square.
9959 K must be an exact integer. */
9961 exact_integer_is_perfect_square (SCM k
)
9965 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9969 mpz_init_set_si (kk
, SCM_I_INUM (k
));
9970 result
= mpz_perfect_square_p (kk
);
9975 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
9976 scm_remember_upto_here_1 (k
);
9981 /* Return the floor of the square root of K.
9982 K must be an exact integer. */
9984 exact_integer_floor_square_root (SCM k
)
9986 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9991 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
9993 ss
= mpz_get_ui (kk
);
9995 return SCM_I_MAKINUM (ss
);
10001 s
= scm_i_mkbig ();
10002 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10003 scm_remember_upto_here_1 (k
);
10004 return scm_i_normbig (s
);
10009 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10011 "Return the square root of @var{z}. Of the two possible roots\n"
10012 "(positive and negative), the one with positive real part\n"
10013 "is returned, or if that's zero then a positive imaginary part.\n"
10017 "(sqrt 9.0) @result{} 3.0\n"
10018 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10019 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10020 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10022 #define FUNC_NAME s_scm_sqrt
10024 if (SCM_COMPLEXP (z
))
10026 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10027 && defined SCM_COMPLEX_VALUE
10028 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10030 double re
= SCM_COMPLEX_REAL (z
);
10031 double im
= SCM_COMPLEX_IMAG (z
);
10032 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10033 0.5 * atan2 (im
, re
));
10036 else if (SCM_NUMBERP (z
))
10038 if (SCM_I_INUMP (z
))
10040 scm_t_inum x
= SCM_I_INUM (z
);
10042 if (SCM_LIKELY (x
>= 0))
10044 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10045 || x
< (1L << (DBL_MANT_DIG
- 1))))
10047 double root
= sqrt (x
);
10049 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10050 integer, then the result is exact. */
10051 if (root
== floor (root
))
10052 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10054 return scm_from_double (root
);
10061 mpz_init_set_ui (xx
, x
);
10062 if (mpz_perfect_square_p (xx
))
10065 root
= mpz_get_ui (xx
);
10067 return SCM_I_MAKINUM (root
);
10074 else if (SCM_BIGP (z
))
10076 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10078 SCM root
= scm_i_mkbig ();
10080 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10081 scm_remember_upto_here_1 (z
);
10082 return scm_i_normbig (root
);
10087 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10095 return scm_c_make_rectangular
10096 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10098 return scm_from_double (ldexp (sqrt (signif
), expon
/ 2));
10101 else if (SCM_FRACTIONP (z
))
10103 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10104 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10106 if (exact_integer_is_perfect_square (n
)
10107 && exact_integer_is_perfect_square (d
))
10108 return scm_i_make_ratio_already_reduced
10109 (exact_integer_floor_square_root (n
),
10110 exact_integer_floor_square_root (d
));
10113 double xx
= scm_i_divide2double (n
, d
);
10114 double abs_xx
= fabs (xx
);
10117 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10119 shift
= (scm_to_long (scm_integer_length (n
))
10120 - scm_to_long (scm_integer_length (d
))) / 2;
10122 d
= left_shift_exact_integer (d
, 2 * shift
);
10124 n
= left_shift_exact_integer (n
, -2 * shift
);
10125 xx
= scm_i_divide2double (n
, d
);
10129 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10131 return scm_from_double (ldexp (sqrt (xx
), shift
));
10135 /* Fallback method, when the cases above do not apply. */
10137 double xx
= scm_to_double (z
);
10139 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10141 return scm_from_double (sqrt (xx
));
10145 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10152 scm_init_numbers ()
10154 if (scm_install_gmp_memory_functions
)
10155 mp_set_memory_functions (custom_gmp_malloc
,
10156 custom_gmp_realloc
,
10159 mpz_init_set_si (z_negative_one
, -1);
10161 /* It may be possible to tune the performance of some algorithms by using
10162 * the following constants to avoid the creation of bignums. Please, before
10163 * using these values, remember the two rules of program optimization:
10164 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10165 scm_c_define ("most-positive-fixnum",
10166 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10167 scm_c_define ("most-negative-fixnum",
10168 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10170 scm_add_feature ("complex");
10171 scm_add_feature ("inexact");
10172 flo0
= scm_from_double (0.0);
10173 flo_log10e
= scm_from_double (M_LOG10E
);
10175 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10178 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10179 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10180 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10181 scm_i_divide2double_lo2b
,
10182 DBL_MANT_DIG
+ 1); /* 2 b^p */
10183 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10187 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10188 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10189 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10190 dbl_minimum_normal_mantissa
,
10194 #include "libguile/numbers.x"
10199 c-file-style: "gnu"