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.
64 #include "libguile/_scm.h"
65 #include "libguile/feature.h"
66 #include "libguile/ports.h"
67 #include "libguile/root.h"
68 #include "libguile/smob.h"
69 #include "libguile/strings.h"
70 #include "libguile/bdw-gc.h"
72 #include "libguile/validate.h"
73 #include "libguile/numbers.h"
74 #include "libguile/deprecation.h"
76 #include "libguile/eq.h"
78 /* values per glibc, if not already defined */
80 #define M_LOG10E 0.43429448190325182765
83 #define M_LN2 0.69314718055994530942
86 #define M_PI 3.14159265358979323846
89 /* FIXME: We assume that FLT_RADIX is 2 */
90 verify (FLT_RADIX
== 2);
92 typedef scm_t_signed_bits scm_t_inum
;
93 #define scm_from_inum(x) (scm_from_signed_integer (x))
95 /* Test an inum to see if it can be converted to a double without loss
96 of precision. Note that this will sometimes return 0 even when 1
97 could have been returned, e.g. for large powers of 2. It is designed
98 to be a fast check to optimize common cases. */
99 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
100 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
101 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
103 #if ! HAVE_DECL_MPZ_INITS
105 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
107 #define VARARG_MPZ_ITERATOR(func) \
109 func ## s (mpz_t x, ...) \
117 x = va_arg (ap, mpz_ptr); \
122 VARARG_MPZ_ITERATOR (mpz_init
)
123 VARARG_MPZ_ITERATOR (mpz_clear
)
130 Wonder if this might be faster for some of our code? A switch on
131 the numtag would jump directly to the right case, and the
132 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
134 #define SCM_I_NUMTAG_NOTNUM 0
135 #define SCM_I_NUMTAG_INUM 1
136 #define SCM_I_NUMTAG_BIG scm_tc16_big
137 #define SCM_I_NUMTAG_REAL scm_tc16_real
138 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
139 #define SCM_I_NUMTAG(x) \
140 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
141 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
142 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
143 : SCM_I_NUMTAG_NOTNUM)))
145 /* the macro above will not work as is with fractions */
148 /* Default to 1, because as we used to hard-code `free' as the
149 deallocator, we know that overriding these functions with
150 instrumented `malloc' / `free' is OK. */
151 int scm_install_gmp_memory_functions
= 1;
153 static SCM exactly_one_half
;
154 static SCM flo_log10e
;
156 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
158 /* FLOBUFLEN is the maximum number of characters neccessary for the
159 * printed or scm_string representation of an inexact number.
161 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
164 #if !defined (HAVE_ASINH)
165 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
167 #if !defined (HAVE_ACOSH)
168 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
170 #if !defined (HAVE_ATANH)
171 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
174 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
175 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
176 in March 2006), mpz_cmp_d now handles infinities properly. */
178 #define xmpz_cmp_d(z, d) \
179 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
181 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
185 #if defined (GUILE_I)
186 #if defined HAVE_COMPLEX_DOUBLE
188 /* For an SCM object Z which is a complex number (ie. satisfies
189 SCM_COMPLEXP), return its value as a C level "complex double". */
190 #define SCM_COMPLEX_VALUE(z) \
191 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
193 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
195 /* Convert a C "complex double" to an SCM value. */
197 scm_from_complex_double (complex double z
)
199 return scm_c_make_rectangular (creal (z
), cimag (z
));
202 #endif /* HAVE_COMPLEX_DOUBLE */
207 static mpz_t z_negative_one
;
211 /* Clear the `mpz_t' embedded in bignum PTR. */
213 finalize_bignum (void *ptr
, void *data
)
217 bignum
= SCM_PACK_POINTER (ptr
);
218 mpz_clear (SCM_I_BIG_MPZ (bignum
));
221 /* The next three functions (custom_libgmp_*) are passed to
222 mp_set_memory_functions (in GMP) so that memory used by the digits
223 themselves is known to the garbage collector. This is needed so
224 that GC will be run at appropriate times. Otherwise, a program which
225 creates many large bignums would malloc a huge amount of memory
226 before the GC runs. */
228 custom_gmp_malloc (size_t alloc_size
)
230 return scm_malloc (alloc_size
);
234 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
236 return scm_realloc (old_ptr
, new_size
);
240 custom_gmp_free (void *ptr
, size_t size
)
246 /* Return a new uninitialized bignum. */
252 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
253 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
257 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
266 /* Return a newly created bignum. */
267 SCM z
= make_bignum ();
268 mpz_init (SCM_I_BIG_MPZ (z
));
273 scm_i_inum2big (scm_t_inum x
)
275 /* Return a newly created bignum initialized to X. */
276 SCM z
= make_bignum ();
277 #if SIZEOF_VOID_P == SIZEOF_LONG
278 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
280 /* Note that in this case, you'll also have to check all mpz_*_ui and
281 mpz_*_si invocations in Guile. */
282 #error creation of mpz not implemented for this inum size
288 scm_i_long2big (long x
)
290 /* Return a newly created bignum initialized to X. */
291 SCM z
= make_bignum ();
292 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
297 scm_i_ulong2big (unsigned long x
)
299 /* Return a newly created bignum initialized to X. */
300 SCM z
= make_bignum ();
301 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
306 scm_i_clonebig (SCM src_big
, int same_sign_p
)
308 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
309 SCM z
= make_bignum ();
310 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
312 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
317 scm_i_bigcmp (SCM x
, SCM y
)
319 /* Return neg if x < y, pos if x > y, and 0 if x == y */
320 /* presume we already know x and y are bignums */
321 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
322 scm_remember_upto_here_2 (x
, y
);
327 scm_i_dbl2big (double d
)
329 /* results are only defined if d is an integer */
330 SCM z
= make_bignum ();
331 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
335 /* Convert a integer in double representation to a SCM number. */
338 scm_i_dbl2num (double u
)
340 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
341 powers of 2, so there's no rounding when making "double" values
342 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
343 get rounded on a 64-bit machine, hence the "+1".
345 The use of floor() to force to an integer value ensures we get a
346 "numerically closest" value without depending on how a
347 double->long cast or how mpz_set_d will round. For reference,
348 double->long probably follows the hardware rounding mode,
349 mpz_set_d truncates towards zero. */
351 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
352 representable as a double? */
354 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
355 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
356 return SCM_I_MAKINUM ((scm_t_inum
) u
);
358 return scm_i_dbl2big (u
);
361 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
363 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
364 bignum b into a normalized significand and exponent such that
365 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
366 The return value is the significand rounded to the closest
367 representable double, and the exponent is placed into *expon_p.
368 If b is zero, then the returned exponent and significand are both
372 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
374 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
377 if (bits
> DBL_MANT_DIG
)
379 shift
= bits
- DBL_MANT_DIG
;
380 b
= round_right_shift_exact_integer (b
, shift
);
384 double signif
= frexp (SCM_I_INUM (b
), &expon
);
385 *expon_p
= expon
+ shift
;
392 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
393 scm_remember_upto_here_1 (b
);
394 *expon_p
= expon
+ shift
;
399 /* scm_i_big2dbl() rounds to the closest representable double,
400 in accordance with R5RS exact->inexact. */
402 scm_i_big2dbl (SCM b
)
405 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
406 return ldexp (signif
, expon
);
410 scm_i_normbig (SCM b
)
412 /* convert a big back to a fixnum if it'll fit */
413 /* presume b is a bignum */
414 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
416 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
417 if (SCM_FIXABLE (val
))
418 b
= SCM_I_MAKINUM (val
);
423 static SCM_C_INLINE_KEYWORD SCM
424 scm_i_mpz2num (mpz_t b
)
426 /* convert a mpz number to a SCM number. */
427 if (mpz_fits_slong_p (b
))
429 scm_t_inum val
= mpz_get_si (b
);
430 if (SCM_FIXABLE (val
))
431 return SCM_I_MAKINUM (val
);
435 SCM z
= make_bignum ();
436 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
441 /* Make the ratio NUMERATOR/DENOMINATOR, where:
442 1. NUMERATOR and DENOMINATOR are exact integers
443 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
445 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
447 /* Flip signs so that the denominator is positive. */
448 if (scm_is_false (scm_positive_p (denominator
)))
450 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
451 scm_num_overflow ("make-ratio");
454 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
455 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
459 /* Check for the integer case */
460 if (scm_is_eq (denominator
, SCM_INUM1
))
463 return scm_double_cell (scm_tc16_fraction
,
464 SCM_UNPACK (numerator
),
465 SCM_UNPACK (denominator
), 0);
468 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
470 /* Make the ratio NUMERATOR/DENOMINATOR */
472 scm_i_make_ratio (SCM numerator
, SCM denominator
)
473 #define FUNC_NAME "make-ratio"
475 /* Make sure the arguments are proper */
476 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
477 SCM_WRONG_TYPE_ARG (1, numerator
);
478 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
479 SCM_WRONG_TYPE_ARG (2, denominator
);
482 SCM the_gcd
= scm_gcd (numerator
, denominator
);
483 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
485 /* Reduce to lowest terms */
486 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
487 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
489 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
494 static mpz_t scm_i_divide2double_lo2b
;
496 /* Return the double that is closest to the exact rational N/D, with
497 ties rounded toward even mantissas. N and D must be exact
500 scm_i_divide2double (SCM n
, SCM d
)
503 mpz_t nn
, dd
, lo
, hi
, x
;
506 if (SCM_LIKELY (SCM_I_INUMP (d
)))
510 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n
))
511 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d
))))
512 /* If both N and D can be losslessly converted to doubles, then
513 we can rely on IEEE floating point to do proper rounding much
514 faster than we can. */
515 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
517 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
519 if (scm_is_true (scm_positive_p (n
)))
521 else if (scm_is_true (scm_negative_p (n
)))
527 mpz_init_set_si (dd
, SCM_I_INUM (d
));
530 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
533 mpz_init_set_si (nn
, SCM_I_INUM (n
));
535 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
537 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
541 /* Now we need to find the value of e such that:
544 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
545 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
546 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
549 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
550 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
551 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
553 where: p = DBL_MANT_DIG
554 b = FLT_RADIX (here assumed to be 2)
556 After rounding, the mantissa must be an integer between b^{p-1} and
557 (b^p - 1), except for subnormal numbers. In the inequations [1A]
558 and [1B], the middle expression represents the mantissa *before*
559 rounding, and therefore is bounded by the range of values that will
560 round to a floating-point number with the exponent e. The upper
561 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
562 ties will round up to the next power of b. The lower bound is
563 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
564 this power of b. Here we subtract 1/2b instead of 1/2 because it
565 is in the range of the next smaller exponent, where the
566 representable numbers are closer together by a factor of b.
568 Inequations [2A] and [2B] are derived from [1A] and [1B] by
569 multiplying by 2b, and in [3A] and [3B] we multiply by the
570 denominator of the middle value to obtain integer expressions.
572 In the code below, we refer to the three expressions in [3A] or
573 [3B] as lo, x, and hi. If the number is normalizable, we will
574 achieve the goal: lo <= x < hi */
576 /* Make an initial guess for e */
577 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
578 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
579 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
581 /* Compute the initial values of lo, x, and hi
582 based on the initial guess of e */
583 mpz_inits (lo
, hi
, x
, NULL
);
584 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
585 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
587 mpz_mul_2exp (lo
, lo
, e
);
588 mpz_mul_2exp (hi
, lo
, 1);
590 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
591 (but without making e less then the minimum exponent) */
592 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
594 mpz_mul_2exp (x
, x
, 1);
597 while (mpz_cmp (x
, hi
) >= 0)
599 /* If we ever used lo's value again,
600 we would need to double lo here. */
601 mpz_mul_2exp (hi
, hi
, 1);
605 /* Now compute the rounded mantissa:
606 n / b^e d (if e >= 0)
607 n b^-e / d (if e <= 0) */
613 mpz_mul_2exp (nn
, nn
, -e
);
615 mpz_mul_2exp (dd
, dd
, e
);
617 /* mpz does not directly support rounded right
618 shifts, so we have to do it the hard way.
619 For efficiency, we reuse lo and hi.
620 hi == quotient, lo == remainder */
621 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
623 /* The fractional part of the unrounded mantissa would be
624 remainder/dividend, i.e. lo/dd. So we have a tie if
625 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
626 integer expression 2*lo = dd. Here we do that comparison
627 to decide whether to round up or down. */
628 mpz_mul_2exp (lo
, lo
, 1);
629 cmp
= mpz_cmp (lo
, dd
);
630 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
631 mpz_add_ui (hi
, hi
, 1);
633 result
= ldexp (mpz_get_d (hi
), e
);
637 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
643 scm_i_fraction2double (SCM z
)
645 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
646 SCM_FRACTION_DENOMINATOR (z
));
650 scm_i_from_double (double val
)
654 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
656 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
657 SCM_REAL_VALUE (z
) = val
;
662 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
664 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
666 #define FUNC_NAME s_scm_exact_p
668 if (SCM_INEXACTP (x
))
670 else if (SCM_NUMBERP (x
))
673 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
678 scm_is_exact (SCM val
)
680 return scm_is_true (scm_exact_p (val
));
683 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
685 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
687 #define FUNC_NAME s_scm_inexact_p
689 if (SCM_INEXACTP (x
))
691 else if (SCM_NUMBERP (x
))
694 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
699 scm_is_inexact (SCM val
)
701 return scm_is_true (scm_inexact_p (val
));
704 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
706 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
708 #define FUNC_NAME s_scm_odd_p
712 scm_t_inum val
= SCM_I_INUM (n
);
713 return scm_from_bool ((val
& 1L) != 0);
715 else if (SCM_BIGP (n
))
717 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
718 scm_remember_upto_here_1 (n
);
719 return scm_from_bool (odd_p
);
721 else if (SCM_REALP (n
))
723 double val
= SCM_REAL_VALUE (n
);
726 double rem
= fabs (fmod (val
, 2.0));
733 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
738 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
740 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
742 #define FUNC_NAME s_scm_even_p
746 scm_t_inum val
= SCM_I_INUM (n
);
747 return scm_from_bool ((val
& 1L) == 0);
749 else if (SCM_BIGP (n
))
751 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
752 scm_remember_upto_here_1 (n
);
753 return scm_from_bool (even_p
);
755 else if (SCM_REALP (n
))
757 double val
= SCM_REAL_VALUE (n
);
760 double rem
= fabs (fmod (val
, 2.0));
767 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
771 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
773 "Return @code{#t} if the real number @var{x} is neither\n"
774 "infinite nor a NaN, @code{#f} otherwise.")
775 #define FUNC_NAME s_scm_finite_p
778 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
779 else if (scm_is_real (x
))
782 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
786 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
788 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
789 "@samp{-inf.0}. Otherwise return @code{#f}.")
790 #define FUNC_NAME s_scm_inf_p
793 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
794 else if (scm_is_real (x
))
797 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
801 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
803 "Return @code{#t} if the real number @var{x} is a NaN,\n"
804 "or @code{#f} otherwise.")
805 #define FUNC_NAME s_scm_nan_p
808 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
809 else if (scm_is_real (x
))
812 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
816 /* Guile's idea of infinity. */
817 static double guile_Inf
;
819 /* Guile's idea of not a number. */
820 static double guile_NaN
;
823 guile_ieee_init (void)
825 /* Some version of gcc on some old version of Linux used to crash when
826 trying to make Inf and NaN. */
829 /* C99 INFINITY, when available.
830 FIXME: The standard allows for INFINITY to be something that overflows
831 at compile time. We ought to have a configure test to check for that
832 before trying to use it. (But in practice we believe this is not a
833 problem on any system guile is likely to target.) */
834 guile_Inf
= INFINITY
;
835 #elif defined HAVE_DINFINITY
837 extern unsigned int DINFINITY
[2];
838 guile_Inf
= (*((double *) (DINFINITY
)));
845 if (guile_Inf
== tmp
)
852 /* C99 NAN, when available */
854 #elif defined HAVE_DQNAN
857 extern unsigned int DQNAN
[2];
858 guile_NaN
= (*((double *)(DQNAN
)));
861 guile_NaN
= guile_Inf
/ guile_Inf
;
865 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
868 #define FUNC_NAME s_scm_inf
870 static int initialized
= 0;
876 return scm_i_from_double (guile_Inf
);
880 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
883 #define FUNC_NAME s_scm_nan
885 static int initialized
= 0;
891 return scm_i_from_double (guile_NaN
);
896 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
898 "Return the absolute value of @var{x}.")
899 #define FUNC_NAME s_scm_abs
903 scm_t_inum xx
= SCM_I_INUM (x
);
906 else if (SCM_POSFIXABLE (-xx
))
907 return SCM_I_MAKINUM (-xx
);
909 return scm_i_inum2big (-xx
);
911 else if (SCM_LIKELY (SCM_REALP (x
)))
913 double xx
= SCM_REAL_VALUE (x
);
914 /* If x is a NaN then xx<0 is false so we return x unchanged */
916 return scm_i_from_double (-xx
);
917 /* Handle signed zeroes properly */
918 else if (SCM_UNLIKELY (xx
== 0.0))
923 else if (SCM_BIGP (x
))
925 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
927 return scm_i_clonebig (x
, 0);
931 else if (SCM_FRACTIONP (x
))
933 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
935 return scm_i_make_ratio_already_reduced
936 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
937 SCM_FRACTION_DENOMINATOR (x
));
940 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
945 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
947 "Return the quotient of the numbers @var{x} and @var{y}.")
948 #define FUNC_NAME s_scm_quotient
950 if (SCM_LIKELY (scm_is_integer (x
)))
952 if (SCM_LIKELY (scm_is_integer (y
)))
953 return scm_truncate_quotient (x
, y
);
955 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
958 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
962 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
964 "Return the remainder of the numbers @var{x} and @var{y}.\n"
966 "(remainder 13 4) @result{} 1\n"
967 "(remainder -13 4) @result{} -1\n"
969 #define FUNC_NAME s_scm_remainder
971 if (SCM_LIKELY (scm_is_integer (x
)))
973 if (SCM_LIKELY (scm_is_integer (y
)))
974 return scm_truncate_remainder (x
, y
);
976 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
979 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
984 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
986 "Return the modulo of the numbers @var{x} and @var{y}.\n"
988 "(modulo 13 4) @result{} 1\n"
989 "(modulo -13 4) @result{} 3\n"
991 #define FUNC_NAME s_scm_modulo
993 if (SCM_LIKELY (scm_is_integer (x
)))
995 if (SCM_LIKELY (scm_is_integer (y
)))
996 return scm_floor_remainder (x
, y
);
998 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
1001 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1005 /* Return the exact integer q such that n = q*d, for exact integers n
1006 and d, where d is known in advance to divide n evenly (with zero
1007 remainder). For large integers, this can be computed more
1008 efficiently than when the remainder is unknown. */
1010 scm_exact_integer_quotient (SCM n
, SCM d
)
1011 #define FUNC_NAME "exact-integer-quotient"
1013 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1015 scm_t_inum nn
= SCM_I_INUM (n
);
1016 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1018 scm_t_inum dd
= SCM_I_INUM (d
);
1019 if (SCM_UNLIKELY (dd
== 0))
1020 scm_num_overflow ("exact-integer-quotient");
1023 scm_t_inum qq
= nn
/ dd
;
1024 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1025 return SCM_I_MAKINUM (qq
);
1027 return scm_i_inum2big (qq
);
1030 else if (SCM_LIKELY (SCM_BIGP (d
)))
1032 /* n is an inum and d is a bignum. Given that d is known to
1033 divide n evenly, there are only two possibilities: n is 0,
1034 or else n is fixnum-min and d is abs(fixnum-min). */
1038 return SCM_I_MAKINUM (-1);
1041 SCM_WRONG_TYPE_ARG (2, d
);
1043 else if (SCM_LIKELY (SCM_BIGP (n
)))
1045 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1047 scm_t_inum dd
= SCM_I_INUM (d
);
1048 if (SCM_UNLIKELY (dd
== 0))
1049 scm_num_overflow ("exact-integer-quotient");
1050 else if (SCM_UNLIKELY (dd
== 1))
1054 SCM q
= scm_i_mkbig ();
1056 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1059 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1060 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1062 scm_remember_upto_here_1 (n
);
1063 return scm_i_normbig (q
);
1066 else if (SCM_LIKELY (SCM_BIGP (d
)))
1068 SCM q
= scm_i_mkbig ();
1069 mpz_divexact (SCM_I_BIG_MPZ (q
),
1072 scm_remember_upto_here_2 (n
, d
);
1073 return scm_i_normbig (q
);
1076 SCM_WRONG_TYPE_ARG (2, d
);
1079 SCM_WRONG_TYPE_ARG (1, n
);
1083 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1084 two-valued functions. It is called from primitive generics that take
1085 two arguments and return two values, when the core procedure is
1086 unable to handle the given argument types. If there are GOOPS
1087 methods for this primitive generic, it dispatches to GOOPS and, if
1088 successful, expects two values to be returned, which are placed in
1089 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1090 wrong-type-arg exception.
1092 FIXME: This obviously belongs somewhere else, but until we decide on
1093 the right API, it is here as a static function, because it is needed
1094 by the *_divide functions below.
1097 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1098 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1100 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
1102 scm_i_extract_values_2 (vals
, rp1
, rp2
);
1105 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1107 "Return the integer @var{q} such that\n"
1108 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1109 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1111 "(euclidean-quotient 123 10) @result{} 12\n"
1112 "(euclidean-quotient 123 -10) @result{} -12\n"
1113 "(euclidean-quotient -123 10) @result{} -13\n"
1114 "(euclidean-quotient -123 -10) @result{} 13\n"
1115 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1116 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1118 #define FUNC_NAME s_scm_euclidean_quotient
1120 if (scm_is_false (scm_negative_p (y
)))
1121 return scm_floor_quotient (x
, y
);
1123 return scm_ceiling_quotient (x
, y
);
1127 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1129 "Return the real number @var{r} such that\n"
1130 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1131 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1132 "for some integer @var{q}.\n"
1134 "(euclidean-remainder 123 10) @result{} 3\n"
1135 "(euclidean-remainder 123 -10) @result{} 3\n"
1136 "(euclidean-remainder -123 10) @result{} 7\n"
1137 "(euclidean-remainder -123 -10) @result{} 7\n"
1138 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1139 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1141 #define FUNC_NAME s_scm_euclidean_remainder
1143 if (scm_is_false (scm_negative_p (y
)))
1144 return scm_floor_remainder (x
, y
);
1146 return scm_ceiling_remainder (x
, y
);
1150 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1152 "Return the integer @var{q} and the real number @var{r}\n"
1153 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1154 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1156 "(euclidean/ 123 10) @result{} 12 and 3\n"
1157 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1158 "(euclidean/ -123 10) @result{} -13 and 7\n"
1159 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1160 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1161 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1163 #define FUNC_NAME s_scm_i_euclidean_divide
1165 if (scm_is_false (scm_negative_p (y
)))
1166 return scm_i_floor_divide (x
, y
);
1168 return scm_i_ceiling_divide (x
, y
);
1173 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1175 if (scm_is_false (scm_negative_p (y
)))
1176 return scm_floor_divide (x
, y
, qp
, rp
);
1178 return scm_ceiling_divide (x
, y
, qp
, rp
);
1181 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1182 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1184 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1186 "Return the floor of @math{@var{x} / @var{y}}.\n"
1188 "(floor-quotient 123 10) @result{} 12\n"
1189 "(floor-quotient 123 -10) @result{} -13\n"
1190 "(floor-quotient -123 10) @result{} -13\n"
1191 "(floor-quotient -123 -10) @result{} 12\n"
1192 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1193 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1195 #define FUNC_NAME s_scm_floor_quotient
1197 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1199 scm_t_inum xx
= SCM_I_INUM (x
);
1200 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1202 scm_t_inum yy
= SCM_I_INUM (y
);
1203 scm_t_inum xx1
= xx
;
1205 if (SCM_LIKELY (yy
> 0))
1207 if (SCM_UNLIKELY (xx
< 0))
1210 else if (SCM_UNLIKELY (yy
== 0))
1211 scm_num_overflow (s_scm_floor_quotient
);
1215 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1216 return SCM_I_MAKINUM (qq
);
1218 return scm_i_inum2big (qq
);
1220 else if (SCM_BIGP (y
))
1222 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1223 scm_remember_upto_here_1 (y
);
1225 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1227 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1229 else if (SCM_REALP (y
))
1230 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1231 else if (SCM_FRACTIONP (y
))
1232 return scm_i_exact_rational_floor_quotient (x
, y
);
1234 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1235 s_scm_floor_quotient
);
1237 else if (SCM_BIGP (x
))
1239 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1241 scm_t_inum yy
= SCM_I_INUM (y
);
1242 if (SCM_UNLIKELY (yy
== 0))
1243 scm_num_overflow (s_scm_floor_quotient
);
1244 else if (SCM_UNLIKELY (yy
== 1))
1248 SCM q
= scm_i_mkbig ();
1250 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1253 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1254 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1256 scm_remember_upto_here_1 (x
);
1257 return scm_i_normbig (q
);
1260 else if (SCM_BIGP (y
))
1262 SCM q
= scm_i_mkbig ();
1263 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1266 scm_remember_upto_here_2 (x
, y
);
1267 return scm_i_normbig (q
);
1269 else if (SCM_REALP (y
))
1270 return scm_i_inexact_floor_quotient
1271 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1272 else if (SCM_FRACTIONP (y
))
1273 return scm_i_exact_rational_floor_quotient (x
, y
);
1275 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1276 s_scm_floor_quotient
);
1278 else if (SCM_REALP (x
))
1280 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1281 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1282 return scm_i_inexact_floor_quotient
1283 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1285 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1286 s_scm_floor_quotient
);
1288 else if (SCM_FRACTIONP (x
))
1291 return scm_i_inexact_floor_quotient
1292 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1293 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1294 return scm_i_exact_rational_floor_quotient (x
, y
);
1296 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1297 s_scm_floor_quotient
);
1300 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1301 s_scm_floor_quotient
);
1306 scm_i_inexact_floor_quotient (double x
, double y
)
1308 if (SCM_UNLIKELY (y
== 0))
1309 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1311 return scm_i_from_double (floor (x
/ y
));
1315 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1317 return scm_floor_quotient
1318 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1319 scm_product (scm_numerator (y
), scm_denominator (x
)));
1322 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1323 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1325 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1327 "Return the real number @var{r} such that\n"
1328 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1329 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1331 "(floor-remainder 123 10) @result{} 3\n"
1332 "(floor-remainder 123 -10) @result{} -7\n"
1333 "(floor-remainder -123 10) @result{} 7\n"
1334 "(floor-remainder -123 -10) @result{} -3\n"
1335 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1336 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1338 #define FUNC_NAME s_scm_floor_remainder
1340 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1342 scm_t_inum xx
= SCM_I_INUM (x
);
1343 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1345 scm_t_inum yy
= SCM_I_INUM (y
);
1346 if (SCM_UNLIKELY (yy
== 0))
1347 scm_num_overflow (s_scm_floor_remainder
);
1350 scm_t_inum rr
= xx
% yy
;
1351 int needs_adjustment
;
1353 if (SCM_LIKELY (yy
> 0))
1354 needs_adjustment
= (rr
< 0);
1356 needs_adjustment
= (rr
> 0);
1358 if (needs_adjustment
)
1360 return SCM_I_MAKINUM (rr
);
1363 else if (SCM_BIGP (y
))
1365 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1366 scm_remember_upto_here_1 (y
);
1371 SCM r
= scm_i_mkbig ();
1372 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1373 scm_remember_upto_here_1 (y
);
1374 return scm_i_normbig (r
);
1383 SCM r
= scm_i_mkbig ();
1384 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1385 scm_remember_upto_here_1 (y
);
1386 return scm_i_normbig (r
);
1389 else if (SCM_REALP (y
))
1390 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1391 else if (SCM_FRACTIONP (y
))
1392 return scm_i_exact_rational_floor_remainder (x
, y
);
1394 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1395 s_scm_floor_remainder
);
1397 else if (SCM_BIGP (x
))
1399 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1401 scm_t_inum yy
= SCM_I_INUM (y
);
1402 if (SCM_UNLIKELY (yy
== 0))
1403 scm_num_overflow (s_scm_floor_remainder
);
1408 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1410 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1411 scm_remember_upto_here_1 (x
);
1412 return SCM_I_MAKINUM (rr
);
1415 else if (SCM_BIGP (y
))
1417 SCM r
= scm_i_mkbig ();
1418 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1421 scm_remember_upto_here_2 (x
, y
);
1422 return scm_i_normbig (r
);
1424 else if (SCM_REALP (y
))
1425 return scm_i_inexact_floor_remainder
1426 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1427 else if (SCM_FRACTIONP (y
))
1428 return scm_i_exact_rational_floor_remainder (x
, y
);
1430 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1431 s_scm_floor_remainder
);
1433 else if (SCM_REALP (x
))
1435 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1436 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1437 return scm_i_inexact_floor_remainder
1438 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1440 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1441 s_scm_floor_remainder
);
1443 else if (SCM_FRACTIONP (x
))
1446 return scm_i_inexact_floor_remainder
1447 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1448 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1449 return scm_i_exact_rational_floor_remainder (x
, y
);
1451 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1452 s_scm_floor_remainder
);
1455 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1456 s_scm_floor_remainder
);
1461 scm_i_inexact_floor_remainder (double x
, double y
)
1463 /* Although it would be more efficient to use fmod here, we can't
1464 because it would in some cases produce results inconsistent with
1465 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1466 close). In particular, when x is very close to a multiple of y,
1467 then r might be either 0.0 or y, but those two cases must
1468 correspond to different choices of q. If r = 0.0 then q must be
1469 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1470 and remainder chooses the other, it would be bad. */
1471 if (SCM_UNLIKELY (y
== 0))
1472 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1474 return scm_i_from_double (x
- y
* floor (x
/ y
));
1478 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1480 SCM xd
= scm_denominator (x
);
1481 SCM yd
= scm_denominator (y
);
1482 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1483 scm_product (scm_numerator (y
), xd
));
1484 return scm_divide (r1
, scm_product (xd
, yd
));
1488 static void scm_i_inexact_floor_divide (double x
, double y
,
1490 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1493 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1495 "Return the integer @var{q} and the real number @var{r}\n"
1496 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1497 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1499 "(floor/ 123 10) @result{} 12 and 3\n"
1500 "(floor/ 123 -10) @result{} -13 and -7\n"
1501 "(floor/ -123 10) @result{} -13 and 7\n"
1502 "(floor/ -123 -10) @result{} 12 and -3\n"
1503 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1504 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1506 #define FUNC_NAME s_scm_i_floor_divide
1510 scm_floor_divide(x
, y
, &q
, &r
);
1511 return scm_values (scm_list_2 (q
, r
));
1515 #define s_scm_floor_divide s_scm_i_floor_divide
1516 #define g_scm_floor_divide g_scm_i_floor_divide
1519 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1521 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1523 scm_t_inum xx
= SCM_I_INUM (x
);
1524 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1526 scm_t_inum yy
= SCM_I_INUM (y
);
1527 if (SCM_UNLIKELY (yy
== 0))
1528 scm_num_overflow (s_scm_floor_divide
);
1531 scm_t_inum qq
= xx
/ yy
;
1532 scm_t_inum rr
= xx
% yy
;
1533 int needs_adjustment
;
1535 if (SCM_LIKELY (yy
> 0))
1536 needs_adjustment
= (rr
< 0);
1538 needs_adjustment
= (rr
> 0);
1540 if (needs_adjustment
)
1546 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1547 *qp
= SCM_I_MAKINUM (qq
);
1549 *qp
= scm_i_inum2big (qq
);
1550 *rp
= SCM_I_MAKINUM (rr
);
1554 else if (SCM_BIGP (y
))
1556 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1557 scm_remember_upto_here_1 (y
);
1562 SCM r
= scm_i_mkbig ();
1563 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1564 scm_remember_upto_here_1 (y
);
1565 *qp
= SCM_I_MAKINUM (-1);
1566 *rp
= scm_i_normbig (r
);
1581 SCM r
= scm_i_mkbig ();
1582 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1583 scm_remember_upto_here_1 (y
);
1584 *qp
= SCM_I_MAKINUM (-1);
1585 *rp
= scm_i_normbig (r
);
1589 else if (SCM_REALP (y
))
1590 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1591 else if (SCM_FRACTIONP (y
))
1592 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1594 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1595 s_scm_floor_divide
, qp
, rp
);
1597 else if (SCM_BIGP (x
))
1599 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1601 scm_t_inum yy
= SCM_I_INUM (y
);
1602 if (SCM_UNLIKELY (yy
== 0))
1603 scm_num_overflow (s_scm_floor_divide
);
1606 SCM q
= scm_i_mkbig ();
1607 SCM r
= scm_i_mkbig ();
1609 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1610 SCM_I_BIG_MPZ (x
), yy
);
1613 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1614 SCM_I_BIG_MPZ (x
), -yy
);
1615 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1617 scm_remember_upto_here_1 (x
);
1618 *qp
= scm_i_normbig (q
);
1619 *rp
= scm_i_normbig (r
);
1623 else if (SCM_BIGP (y
))
1625 SCM q
= scm_i_mkbig ();
1626 SCM r
= scm_i_mkbig ();
1627 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1628 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1629 scm_remember_upto_here_2 (x
, y
);
1630 *qp
= scm_i_normbig (q
);
1631 *rp
= scm_i_normbig (r
);
1634 else if (SCM_REALP (y
))
1635 return scm_i_inexact_floor_divide
1636 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1637 else if (SCM_FRACTIONP (y
))
1638 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1640 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1641 s_scm_floor_divide
, qp
, rp
);
1643 else if (SCM_REALP (x
))
1645 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1646 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1647 return scm_i_inexact_floor_divide
1648 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1650 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1651 s_scm_floor_divide
, qp
, rp
);
1653 else if (SCM_FRACTIONP (x
))
1656 return scm_i_inexact_floor_divide
1657 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1658 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1659 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1661 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1662 s_scm_floor_divide
, qp
, rp
);
1665 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1666 s_scm_floor_divide
, qp
, rp
);
1670 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1672 if (SCM_UNLIKELY (y
== 0))
1673 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1676 double q
= floor (x
/ y
);
1677 double r
= x
- q
* y
;
1678 *qp
= scm_i_from_double (q
);
1679 *rp
= scm_i_from_double (r
);
1684 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1687 SCM xd
= scm_denominator (x
);
1688 SCM yd
= scm_denominator (y
);
1690 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1691 scm_product (scm_numerator (y
), xd
),
1693 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1696 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1697 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1699 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1701 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1703 "(ceiling-quotient 123 10) @result{} 13\n"
1704 "(ceiling-quotient 123 -10) @result{} -12\n"
1705 "(ceiling-quotient -123 10) @result{} -12\n"
1706 "(ceiling-quotient -123 -10) @result{} 13\n"
1707 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1708 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1710 #define FUNC_NAME s_scm_ceiling_quotient
1712 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1714 scm_t_inum xx
= SCM_I_INUM (x
);
1715 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1717 scm_t_inum yy
= SCM_I_INUM (y
);
1718 if (SCM_UNLIKELY (yy
== 0))
1719 scm_num_overflow (s_scm_ceiling_quotient
);
1722 scm_t_inum xx1
= xx
;
1724 if (SCM_LIKELY (yy
> 0))
1726 if (SCM_LIKELY (xx
>= 0))
1732 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1733 return SCM_I_MAKINUM (qq
);
1735 return scm_i_inum2big (qq
);
1738 else if (SCM_BIGP (y
))
1740 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1741 scm_remember_upto_here_1 (y
);
1742 if (SCM_LIKELY (sign
> 0))
1744 if (SCM_LIKELY (xx
> 0))
1746 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1747 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1748 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1750 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1751 scm_remember_upto_here_1 (y
);
1752 return SCM_I_MAKINUM (-1);
1762 else if (SCM_REALP (y
))
1763 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1764 else if (SCM_FRACTIONP (y
))
1765 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1767 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1768 s_scm_ceiling_quotient
);
1770 else if (SCM_BIGP (x
))
1772 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1774 scm_t_inum yy
= SCM_I_INUM (y
);
1775 if (SCM_UNLIKELY (yy
== 0))
1776 scm_num_overflow (s_scm_ceiling_quotient
);
1777 else if (SCM_UNLIKELY (yy
== 1))
1781 SCM q
= scm_i_mkbig ();
1783 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1786 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1787 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1789 scm_remember_upto_here_1 (x
);
1790 return scm_i_normbig (q
);
1793 else if (SCM_BIGP (y
))
1795 SCM q
= scm_i_mkbig ();
1796 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1799 scm_remember_upto_here_2 (x
, y
);
1800 return scm_i_normbig (q
);
1802 else if (SCM_REALP (y
))
1803 return scm_i_inexact_ceiling_quotient
1804 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1805 else if (SCM_FRACTIONP (y
))
1806 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1808 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1809 s_scm_ceiling_quotient
);
1811 else if (SCM_REALP (x
))
1813 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1814 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1815 return scm_i_inexact_ceiling_quotient
1816 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1818 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1819 s_scm_ceiling_quotient
);
1821 else if (SCM_FRACTIONP (x
))
1824 return scm_i_inexact_ceiling_quotient
1825 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1826 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1827 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1829 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1830 s_scm_ceiling_quotient
);
1833 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1834 s_scm_ceiling_quotient
);
1839 scm_i_inexact_ceiling_quotient (double x
, double y
)
1841 if (SCM_UNLIKELY (y
== 0))
1842 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1844 return scm_i_from_double (ceil (x
/ y
));
1848 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1850 return scm_ceiling_quotient
1851 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1852 scm_product (scm_numerator (y
), scm_denominator (x
)));
1855 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1856 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1858 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1860 "Return the real number @var{r} such that\n"
1861 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1862 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1864 "(ceiling-remainder 123 10) @result{} -7\n"
1865 "(ceiling-remainder 123 -10) @result{} 3\n"
1866 "(ceiling-remainder -123 10) @result{} -3\n"
1867 "(ceiling-remainder -123 -10) @result{} 7\n"
1868 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1869 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1871 #define FUNC_NAME s_scm_ceiling_remainder
1873 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1875 scm_t_inum xx
= SCM_I_INUM (x
);
1876 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1878 scm_t_inum yy
= SCM_I_INUM (y
);
1879 if (SCM_UNLIKELY (yy
== 0))
1880 scm_num_overflow (s_scm_ceiling_remainder
);
1883 scm_t_inum rr
= xx
% yy
;
1884 int needs_adjustment
;
1886 if (SCM_LIKELY (yy
> 0))
1887 needs_adjustment
= (rr
> 0);
1889 needs_adjustment
= (rr
< 0);
1891 if (needs_adjustment
)
1893 return SCM_I_MAKINUM (rr
);
1896 else if (SCM_BIGP (y
))
1898 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1899 scm_remember_upto_here_1 (y
);
1900 if (SCM_LIKELY (sign
> 0))
1902 if (SCM_LIKELY (xx
> 0))
1904 SCM r
= scm_i_mkbig ();
1905 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1906 scm_remember_upto_here_1 (y
);
1907 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1908 return scm_i_normbig (r
);
1910 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1911 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1912 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1914 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1915 scm_remember_upto_here_1 (y
);
1925 SCM r
= scm_i_mkbig ();
1926 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1927 scm_remember_upto_here_1 (y
);
1928 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1929 return scm_i_normbig (r
);
1932 else if (SCM_REALP (y
))
1933 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1934 else if (SCM_FRACTIONP (y
))
1935 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1937 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1938 s_scm_ceiling_remainder
);
1940 else if (SCM_BIGP (x
))
1942 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1944 scm_t_inum yy
= SCM_I_INUM (y
);
1945 if (SCM_UNLIKELY (yy
== 0))
1946 scm_num_overflow (s_scm_ceiling_remainder
);
1951 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1953 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1954 scm_remember_upto_here_1 (x
);
1955 return SCM_I_MAKINUM (rr
);
1958 else if (SCM_BIGP (y
))
1960 SCM r
= scm_i_mkbig ();
1961 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1964 scm_remember_upto_here_2 (x
, y
);
1965 return scm_i_normbig (r
);
1967 else if (SCM_REALP (y
))
1968 return scm_i_inexact_ceiling_remainder
1969 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1970 else if (SCM_FRACTIONP (y
))
1971 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1973 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1974 s_scm_ceiling_remainder
);
1976 else if (SCM_REALP (x
))
1978 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1979 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1980 return scm_i_inexact_ceiling_remainder
1981 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1983 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1984 s_scm_ceiling_remainder
);
1986 else if (SCM_FRACTIONP (x
))
1989 return scm_i_inexact_ceiling_remainder
1990 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1991 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1992 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1994 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1995 s_scm_ceiling_remainder
);
1998 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1999 s_scm_ceiling_remainder
);
2004 scm_i_inexact_ceiling_remainder (double x
, double y
)
2006 /* Although it would be more efficient to use fmod here, we can't
2007 because it would in some cases produce results inconsistent with
2008 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2009 close). In particular, when x is very close to a multiple of y,
2010 then r might be either 0.0 or -y, but those two cases must
2011 correspond to different choices of q. If r = 0.0 then q must be
2012 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2013 and remainder chooses the other, it would be bad. */
2014 if (SCM_UNLIKELY (y
== 0))
2015 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2017 return scm_i_from_double (x
- y
* ceil (x
/ y
));
2021 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2023 SCM xd
= scm_denominator (x
);
2024 SCM yd
= scm_denominator (y
);
2025 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2026 scm_product (scm_numerator (y
), xd
));
2027 return scm_divide (r1
, scm_product (xd
, yd
));
2030 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2032 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2035 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2037 "Return the integer @var{q} and the real number @var{r}\n"
2038 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2039 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2041 "(ceiling/ 123 10) @result{} 13 and -7\n"
2042 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2043 "(ceiling/ -123 10) @result{} -12 and -3\n"
2044 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2045 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2046 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2048 #define FUNC_NAME s_scm_i_ceiling_divide
2052 scm_ceiling_divide(x
, y
, &q
, &r
);
2053 return scm_values (scm_list_2 (q
, r
));
2057 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2058 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2061 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2063 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2065 scm_t_inum xx
= SCM_I_INUM (x
);
2066 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2068 scm_t_inum yy
= SCM_I_INUM (y
);
2069 if (SCM_UNLIKELY (yy
== 0))
2070 scm_num_overflow (s_scm_ceiling_divide
);
2073 scm_t_inum qq
= xx
/ yy
;
2074 scm_t_inum rr
= xx
% yy
;
2075 int needs_adjustment
;
2077 if (SCM_LIKELY (yy
> 0))
2078 needs_adjustment
= (rr
> 0);
2080 needs_adjustment
= (rr
< 0);
2082 if (needs_adjustment
)
2087 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2088 *qp
= SCM_I_MAKINUM (qq
);
2090 *qp
= scm_i_inum2big (qq
);
2091 *rp
= SCM_I_MAKINUM (rr
);
2095 else if (SCM_BIGP (y
))
2097 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2098 scm_remember_upto_here_1 (y
);
2099 if (SCM_LIKELY (sign
> 0))
2101 if (SCM_LIKELY (xx
> 0))
2103 SCM r
= scm_i_mkbig ();
2104 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2105 scm_remember_upto_here_1 (y
);
2106 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2108 *rp
= scm_i_normbig (r
);
2110 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2111 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2112 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2114 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2115 scm_remember_upto_here_1 (y
);
2116 *qp
= SCM_I_MAKINUM (-1);
2132 SCM r
= scm_i_mkbig ();
2133 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2134 scm_remember_upto_here_1 (y
);
2135 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2137 *rp
= scm_i_normbig (r
);
2141 else if (SCM_REALP (y
))
2142 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2143 else if (SCM_FRACTIONP (y
))
2144 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2146 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2147 s_scm_ceiling_divide
, qp
, rp
);
2149 else if (SCM_BIGP (x
))
2151 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2153 scm_t_inum yy
= SCM_I_INUM (y
);
2154 if (SCM_UNLIKELY (yy
== 0))
2155 scm_num_overflow (s_scm_ceiling_divide
);
2158 SCM q
= scm_i_mkbig ();
2159 SCM r
= scm_i_mkbig ();
2161 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2162 SCM_I_BIG_MPZ (x
), yy
);
2165 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2166 SCM_I_BIG_MPZ (x
), -yy
);
2167 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2169 scm_remember_upto_here_1 (x
);
2170 *qp
= scm_i_normbig (q
);
2171 *rp
= scm_i_normbig (r
);
2175 else if (SCM_BIGP (y
))
2177 SCM q
= scm_i_mkbig ();
2178 SCM r
= scm_i_mkbig ();
2179 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2180 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2181 scm_remember_upto_here_2 (x
, y
);
2182 *qp
= scm_i_normbig (q
);
2183 *rp
= scm_i_normbig (r
);
2186 else if (SCM_REALP (y
))
2187 return scm_i_inexact_ceiling_divide
2188 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2189 else if (SCM_FRACTIONP (y
))
2190 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2192 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2193 s_scm_ceiling_divide
, qp
, rp
);
2195 else if (SCM_REALP (x
))
2197 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2198 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2199 return scm_i_inexact_ceiling_divide
2200 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2202 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2203 s_scm_ceiling_divide
, qp
, rp
);
2205 else if (SCM_FRACTIONP (x
))
2208 return scm_i_inexact_ceiling_divide
2209 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2210 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2211 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2213 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2214 s_scm_ceiling_divide
, qp
, rp
);
2217 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2218 s_scm_ceiling_divide
, qp
, rp
);
2222 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2224 if (SCM_UNLIKELY (y
== 0))
2225 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2228 double q
= ceil (x
/ y
);
2229 double r
= x
- q
* y
;
2230 *qp
= scm_i_from_double (q
);
2231 *rp
= scm_i_from_double (r
);
2236 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2239 SCM xd
= scm_denominator (x
);
2240 SCM yd
= scm_denominator (y
);
2242 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2243 scm_product (scm_numerator (y
), xd
),
2245 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2248 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2249 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2251 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2253 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2255 "(truncate-quotient 123 10) @result{} 12\n"
2256 "(truncate-quotient 123 -10) @result{} -12\n"
2257 "(truncate-quotient -123 10) @result{} -12\n"
2258 "(truncate-quotient -123 -10) @result{} 12\n"
2259 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2260 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2262 #define FUNC_NAME s_scm_truncate_quotient
2264 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2266 scm_t_inum xx
= SCM_I_INUM (x
);
2267 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2269 scm_t_inum yy
= SCM_I_INUM (y
);
2270 if (SCM_UNLIKELY (yy
== 0))
2271 scm_num_overflow (s_scm_truncate_quotient
);
2274 scm_t_inum qq
= xx
/ yy
;
2275 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2276 return SCM_I_MAKINUM (qq
);
2278 return scm_i_inum2big (qq
);
2281 else if (SCM_BIGP (y
))
2283 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2284 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2285 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2287 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2288 scm_remember_upto_here_1 (y
);
2289 return SCM_I_MAKINUM (-1);
2294 else if (SCM_REALP (y
))
2295 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2296 else if (SCM_FRACTIONP (y
))
2297 return scm_i_exact_rational_truncate_quotient (x
, y
);
2299 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2300 s_scm_truncate_quotient
);
2302 else if (SCM_BIGP (x
))
2304 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2306 scm_t_inum yy
= SCM_I_INUM (y
);
2307 if (SCM_UNLIKELY (yy
== 0))
2308 scm_num_overflow (s_scm_truncate_quotient
);
2309 else if (SCM_UNLIKELY (yy
== 1))
2313 SCM q
= scm_i_mkbig ();
2315 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2318 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2319 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2321 scm_remember_upto_here_1 (x
);
2322 return scm_i_normbig (q
);
2325 else if (SCM_BIGP (y
))
2327 SCM q
= scm_i_mkbig ();
2328 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2331 scm_remember_upto_here_2 (x
, y
);
2332 return scm_i_normbig (q
);
2334 else if (SCM_REALP (y
))
2335 return scm_i_inexact_truncate_quotient
2336 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2337 else if (SCM_FRACTIONP (y
))
2338 return scm_i_exact_rational_truncate_quotient (x
, y
);
2340 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2341 s_scm_truncate_quotient
);
2343 else if (SCM_REALP (x
))
2345 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2346 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2347 return scm_i_inexact_truncate_quotient
2348 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2350 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2351 s_scm_truncate_quotient
);
2353 else if (SCM_FRACTIONP (x
))
2356 return scm_i_inexact_truncate_quotient
2357 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2358 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2359 return scm_i_exact_rational_truncate_quotient (x
, y
);
2361 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2362 s_scm_truncate_quotient
);
2365 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2366 s_scm_truncate_quotient
);
2371 scm_i_inexact_truncate_quotient (double x
, double y
)
2373 if (SCM_UNLIKELY (y
== 0))
2374 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2376 return scm_i_from_double (trunc (x
/ y
));
2380 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2382 return scm_truncate_quotient
2383 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2384 scm_product (scm_numerator (y
), scm_denominator (x
)));
2387 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2388 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2390 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2392 "Return the real number @var{r} such that\n"
2393 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2394 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2396 "(truncate-remainder 123 10) @result{} 3\n"
2397 "(truncate-remainder 123 -10) @result{} 3\n"
2398 "(truncate-remainder -123 10) @result{} -3\n"
2399 "(truncate-remainder -123 -10) @result{} -3\n"
2400 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2401 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2403 #define FUNC_NAME s_scm_truncate_remainder
2405 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2407 scm_t_inum xx
= SCM_I_INUM (x
);
2408 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2410 scm_t_inum yy
= SCM_I_INUM (y
);
2411 if (SCM_UNLIKELY (yy
== 0))
2412 scm_num_overflow (s_scm_truncate_remainder
);
2414 return SCM_I_MAKINUM (xx
% yy
);
2416 else if (SCM_BIGP (y
))
2418 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2419 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2420 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2422 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2423 scm_remember_upto_here_1 (y
);
2429 else if (SCM_REALP (y
))
2430 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2431 else if (SCM_FRACTIONP (y
))
2432 return scm_i_exact_rational_truncate_remainder (x
, y
);
2434 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2435 s_scm_truncate_remainder
);
2437 else if (SCM_BIGP (x
))
2439 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2441 scm_t_inum yy
= SCM_I_INUM (y
);
2442 if (SCM_UNLIKELY (yy
== 0))
2443 scm_num_overflow (s_scm_truncate_remainder
);
2446 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2447 (yy
> 0) ? yy
: -yy
)
2448 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2449 scm_remember_upto_here_1 (x
);
2450 return SCM_I_MAKINUM (rr
);
2453 else if (SCM_BIGP (y
))
2455 SCM r
= scm_i_mkbig ();
2456 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2459 scm_remember_upto_here_2 (x
, y
);
2460 return scm_i_normbig (r
);
2462 else if (SCM_REALP (y
))
2463 return scm_i_inexact_truncate_remainder
2464 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2465 else if (SCM_FRACTIONP (y
))
2466 return scm_i_exact_rational_truncate_remainder (x
, y
);
2468 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2469 s_scm_truncate_remainder
);
2471 else if (SCM_REALP (x
))
2473 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2474 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2475 return scm_i_inexact_truncate_remainder
2476 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2478 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2479 s_scm_truncate_remainder
);
2481 else if (SCM_FRACTIONP (x
))
2484 return scm_i_inexact_truncate_remainder
2485 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2486 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2487 return scm_i_exact_rational_truncate_remainder (x
, y
);
2489 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2490 s_scm_truncate_remainder
);
2493 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2494 s_scm_truncate_remainder
);
2499 scm_i_inexact_truncate_remainder (double x
, double y
)
2501 /* Although it would be more efficient to use fmod here, we can't
2502 because it would in some cases produce results inconsistent with
2503 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2504 close). In particular, when x is very close to a multiple of y,
2505 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2506 correspond to different choices of q. If quotient chooses one and
2507 remainder chooses the other, it would be bad. */
2508 if (SCM_UNLIKELY (y
== 0))
2509 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2511 return scm_i_from_double (x
- y
* trunc (x
/ y
));
2515 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2517 SCM xd
= scm_denominator (x
);
2518 SCM yd
= scm_denominator (y
);
2519 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2520 scm_product (scm_numerator (y
), xd
));
2521 return scm_divide (r1
, scm_product (xd
, yd
));
2525 static void scm_i_inexact_truncate_divide (double x
, double y
,
2527 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2530 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2532 "Return the integer @var{q} and the real number @var{r}\n"
2533 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2534 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2536 "(truncate/ 123 10) @result{} 12 and 3\n"
2537 "(truncate/ 123 -10) @result{} -12 and 3\n"
2538 "(truncate/ -123 10) @result{} -12 and -3\n"
2539 "(truncate/ -123 -10) @result{} 12 and -3\n"
2540 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2541 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2543 #define FUNC_NAME s_scm_i_truncate_divide
2547 scm_truncate_divide(x
, y
, &q
, &r
);
2548 return scm_values (scm_list_2 (q
, r
));
2552 #define s_scm_truncate_divide s_scm_i_truncate_divide
2553 #define g_scm_truncate_divide g_scm_i_truncate_divide
2556 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2558 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2560 scm_t_inum xx
= SCM_I_INUM (x
);
2561 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2563 scm_t_inum yy
= SCM_I_INUM (y
);
2564 if (SCM_UNLIKELY (yy
== 0))
2565 scm_num_overflow (s_scm_truncate_divide
);
2568 scm_t_inum qq
= xx
/ yy
;
2569 scm_t_inum rr
= xx
% yy
;
2570 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2571 *qp
= SCM_I_MAKINUM (qq
);
2573 *qp
= scm_i_inum2big (qq
);
2574 *rp
= SCM_I_MAKINUM (rr
);
2578 else if (SCM_BIGP (y
))
2580 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2581 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2582 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2584 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2585 scm_remember_upto_here_1 (y
);
2586 *qp
= SCM_I_MAKINUM (-1);
2596 else if (SCM_REALP (y
))
2597 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2598 else if (SCM_FRACTIONP (y
))
2599 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2601 return two_valued_wta_dispatch_2
2602 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2603 s_scm_truncate_divide
, qp
, rp
);
2605 else if (SCM_BIGP (x
))
2607 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2609 scm_t_inum yy
= SCM_I_INUM (y
);
2610 if (SCM_UNLIKELY (yy
== 0))
2611 scm_num_overflow (s_scm_truncate_divide
);
2614 SCM q
= scm_i_mkbig ();
2617 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2618 SCM_I_BIG_MPZ (x
), yy
);
2621 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2622 SCM_I_BIG_MPZ (x
), -yy
);
2623 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2625 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2626 scm_remember_upto_here_1 (x
);
2627 *qp
= scm_i_normbig (q
);
2628 *rp
= SCM_I_MAKINUM (rr
);
2632 else if (SCM_BIGP (y
))
2634 SCM q
= scm_i_mkbig ();
2635 SCM r
= scm_i_mkbig ();
2636 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2637 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2638 scm_remember_upto_here_2 (x
, y
);
2639 *qp
= scm_i_normbig (q
);
2640 *rp
= scm_i_normbig (r
);
2642 else if (SCM_REALP (y
))
2643 return scm_i_inexact_truncate_divide
2644 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2645 else if (SCM_FRACTIONP (y
))
2646 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2648 return two_valued_wta_dispatch_2
2649 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2650 s_scm_truncate_divide
, qp
, rp
);
2652 else if (SCM_REALP (x
))
2654 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2655 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2656 return scm_i_inexact_truncate_divide
2657 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2659 return two_valued_wta_dispatch_2
2660 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2661 s_scm_truncate_divide
, qp
, rp
);
2663 else if (SCM_FRACTIONP (x
))
2666 return scm_i_inexact_truncate_divide
2667 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2668 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2669 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2671 return two_valued_wta_dispatch_2
2672 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2673 s_scm_truncate_divide
, qp
, rp
);
2676 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2677 s_scm_truncate_divide
, qp
, rp
);
2681 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2683 if (SCM_UNLIKELY (y
== 0))
2684 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2687 double q
= trunc (x
/ y
);
2688 double r
= x
- q
* y
;
2689 *qp
= scm_i_from_double (q
);
2690 *rp
= scm_i_from_double (r
);
2695 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2698 SCM xd
= scm_denominator (x
);
2699 SCM yd
= scm_denominator (y
);
2701 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2702 scm_product (scm_numerator (y
), xd
),
2704 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2707 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2708 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2709 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2711 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2713 "Return the integer @var{q} such that\n"
2714 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2715 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2717 "(centered-quotient 123 10) @result{} 12\n"
2718 "(centered-quotient 123 -10) @result{} -12\n"
2719 "(centered-quotient -123 10) @result{} -12\n"
2720 "(centered-quotient -123 -10) @result{} 12\n"
2721 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2722 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2724 #define FUNC_NAME s_scm_centered_quotient
2726 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2728 scm_t_inum xx
= SCM_I_INUM (x
);
2729 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2731 scm_t_inum yy
= SCM_I_INUM (y
);
2732 if (SCM_UNLIKELY (yy
== 0))
2733 scm_num_overflow (s_scm_centered_quotient
);
2736 scm_t_inum qq
= xx
/ yy
;
2737 scm_t_inum rr
= xx
% yy
;
2738 if (SCM_LIKELY (xx
> 0))
2740 if (SCM_LIKELY (yy
> 0))
2742 if (rr
>= (yy
+ 1) / 2)
2747 if (rr
>= (1 - yy
) / 2)
2753 if (SCM_LIKELY (yy
> 0))
2764 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2765 return SCM_I_MAKINUM (qq
);
2767 return scm_i_inum2big (qq
);
2770 else if (SCM_BIGP (y
))
2772 /* Pass a denormalized bignum version of x (even though it
2773 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2774 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2776 else if (SCM_REALP (y
))
2777 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2778 else if (SCM_FRACTIONP (y
))
2779 return scm_i_exact_rational_centered_quotient (x
, y
);
2781 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2782 s_scm_centered_quotient
);
2784 else if (SCM_BIGP (x
))
2786 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2788 scm_t_inum yy
= SCM_I_INUM (y
);
2789 if (SCM_UNLIKELY (yy
== 0))
2790 scm_num_overflow (s_scm_centered_quotient
);
2791 else if (SCM_UNLIKELY (yy
== 1))
2795 SCM q
= scm_i_mkbig ();
2797 /* Arrange for rr to initially be non-positive,
2798 because that simplifies the test to see
2799 if it is within the needed bounds. */
2802 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2803 SCM_I_BIG_MPZ (x
), yy
);
2804 scm_remember_upto_here_1 (x
);
2806 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2807 SCM_I_BIG_MPZ (q
), 1);
2811 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2812 SCM_I_BIG_MPZ (x
), -yy
);
2813 scm_remember_upto_here_1 (x
);
2814 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2816 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2817 SCM_I_BIG_MPZ (q
), 1);
2819 return scm_i_normbig (q
);
2822 else if (SCM_BIGP (y
))
2823 return scm_i_bigint_centered_quotient (x
, y
);
2824 else if (SCM_REALP (y
))
2825 return scm_i_inexact_centered_quotient
2826 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2827 else if (SCM_FRACTIONP (y
))
2828 return scm_i_exact_rational_centered_quotient (x
, y
);
2830 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2831 s_scm_centered_quotient
);
2833 else if (SCM_REALP (x
))
2835 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2836 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2837 return scm_i_inexact_centered_quotient
2838 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2840 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2841 s_scm_centered_quotient
);
2843 else if (SCM_FRACTIONP (x
))
2846 return scm_i_inexact_centered_quotient
2847 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2848 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2849 return scm_i_exact_rational_centered_quotient (x
, y
);
2851 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2852 s_scm_centered_quotient
);
2855 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2856 s_scm_centered_quotient
);
2861 scm_i_inexact_centered_quotient (double x
, double y
)
2863 if (SCM_LIKELY (y
> 0))
2864 return scm_i_from_double (floor (x
/y
+ 0.5));
2865 else if (SCM_LIKELY (y
< 0))
2866 return scm_i_from_double (ceil (x
/y
- 0.5));
2868 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2873 /* Assumes that both x and y are bigints, though
2874 x might be able to fit into a fixnum. */
2876 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2880 /* Note that x might be small enough to fit into a
2881 fixnum, so we must not let it escape into the wild */
2885 /* min_r will eventually become -abs(y)/2 */
2886 min_r
= scm_i_mkbig ();
2887 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2888 SCM_I_BIG_MPZ (y
), 1);
2890 /* Arrange for rr to initially be non-positive,
2891 because that simplifies the test to see
2892 if it is within the needed bounds. */
2893 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2895 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2896 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2897 scm_remember_upto_here_2 (x
, y
);
2898 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2899 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2900 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2901 SCM_I_BIG_MPZ (q
), 1);
2905 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2906 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2907 scm_remember_upto_here_2 (x
, y
);
2908 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2909 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2910 SCM_I_BIG_MPZ (q
), 1);
2912 scm_remember_upto_here_2 (r
, min_r
);
2913 return scm_i_normbig (q
);
2917 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2919 return scm_centered_quotient
2920 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2921 scm_product (scm_numerator (y
), scm_denominator (x
)));
2924 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2925 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2926 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2928 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2930 "Return the real number @var{r} such that\n"
2931 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2932 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2933 "for some integer @var{q}.\n"
2935 "(centered-remainder 123 10) @result{} 3\n"
2936 "(centered-remainder 123 -10) @result{} 3\n"
2937 "(centered-remainder -123 10) @result{} -3\n"
2938 "(centered-remainder -123 -10) @result{} -3\n"
2939 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2940 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2942 #define FUNC_NAME s_scm_centered_remainder
2944 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2946 scm_t_inum xx
= SCM_I_INUM (x
);
2947 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2949 scm_t_inum yy
= SCM_I_INUM (y
);
2950 if (SCM_UNLIKELY (yy
== 0))
2951 scm_num_overflow (s_scm_centered_remainder
);
2954 scm_t_inum rr
= xx
% yy
;
2955 if (SCM_LIKELY (xx
> 0))
2957 if (SCM_LIKELY (yy
> 0))
2959 if (rr
>= (yy
+ 1) / 2)
2964 if (rr
>= (1 - yy
) / 2)
2970 if (SCM_LIKELY (yy
> 0))
2981 return SCM_I_MAKINUM (rr
);
2984 else if (SCM_BIGP (y
))
2986 /* Pass a denormalized bignum version of x (even though it
2987 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2988 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2990 else if (SCM_REALP (y
))
2991 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2992 else if (SCM_FRACTIONP (y
))
2993 return scm_i_exact_rational_centered_remainder (x
, y
);
2995 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2996 s_scm_centered_remainder
);
2998 else if (SCM_BIGP (x
))
3000 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3002 scm_t_inum yy
= SCM_I_INUM (y
);
3003 if (SCM_UNLIKELY (yy
== 0))
3004 scm_num_overflow (s_scm_centered_remainder
);
3008 /* Arrange for rr to initially be non-positive,
3009 because that simplifies the test to see
3010 if it is within the needed bounds. */
3013 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3014 scm_remember_upto_here_1 (x
);
3020 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3021 scm_remember_upto_here_1 (x
);
3025 return SCM_I_MAKINUM (rr
);
3028 else if (SCM_BIGP (y
))
3029 return scm_i_bigint_centered_remainder (x
, y
);
3030 else if (SCM_REALP (y
))
3031 return scm_i_inexact_centered_remainder
3032 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3033 else if (SCM_FRACTIONP (y
))
3034 return scm_i_exact_rational_centered_remainder (x
, y
);
3036 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3037 s_scm_centered_remainder
);
3039 else if (SCM_REALP (x
))
3041 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3042 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3043 return scm_i_inexact_centered_remainder
3044 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3046 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3047 s_scm_centered_remainder
);
3049 else if (SCM_FRACTIONP (x
))
3052 return scm_i_inexact_centered_remainder
3053 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3054 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3055 return scm_i_exact_rational_centered_remainder (x
, y
);
3057 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3058 s_scm_centered_remainder
);
3061 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3062 s_scm_centered_remainder
);
3067 scm_i_inexact_centered_remainder (double x
, double y
)
3071 /* Although it would be more efficient to use fmod here, we can't
3072 because it would in some cases produce results inconsistent with
3073 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3074 close). In particular, when x-y/2 is very close to a multiple of
3075 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3076 two cases must correspond to different choices of q. If quotient
3077 chooses one and remainder chooses the other, it would be bad. */
3078 if (SCM_LIKELY (y
> 0))
3079 q
= floor (x
/y
+ 0.5);
3080 else if (SCM_LIKELY (y
< 0))
3081 q
= ceil (x
/y
- 0.5);
3083 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3086 return scm_i_from_double (x
- q
* y
);
3089 /* Assumes that both x and y are bigints, though
3090 x might be able to fit into a fixnum. */
3092 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3096 /* Note that x might be small enough to fit into a
3097 fixnum, so we must not let it escape into the wild */
3100 /* min_r will eventually become -abs(y)/2 */
3101 min_r
= scm_i_mkbig ();
3102 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3103 SCM_I_BIG_MPZ (y
), 1);
3105 /* Arrange for rr to initially be non-positive,
3106 because that simplifies the test to see
3107 if it is within the needed bounds. */
3108 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3110 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3111 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3112 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3113 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3114 mpz_add (SCM_I_BIG_MPZ (r
),
3120 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3121 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3122 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3123 mpz_sub (SCM_I_BIG_MPZ (r
),
3127 scm_remember_upto_here_2 (x
, y
);
3128 return scm_i_normbig (r
);
3132 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3134 SCM xd
= scm_denominator (x
);
3135 SCM yd
= scm_denominator (y
);
3136 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3137 scm_product (scm_numerator (y
), xd
));
3138 return scm_divide (r1
, scm_product (xd
, yd
));
3142 static void scm_i_inexact_centered_divide (double x
, double y
,
3144 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3145 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3148 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3150 "Return the integer @var{q} and the real number @var{r}\n"
3151 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3152 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3154 "(centered/ 123 10) @result{} 12 and 3\n"
3155 "(centered/ 123 -10) @result{} -12 and 3\n"
3156 "(centered/ -123 10) @result{} -12 and -3\n"
3157 "(centered/ -123 -10) @result{} 12 and -3\n"
3158 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3159 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3161 #define FUNC_NAME s_scm_i_centered_divide
3165 scm_centered_divide(x
, y
, &q
, &r
);
3166 return scm_values (scm_list_2 (q
, r
));
3170 #define s_scm_centered_divide s_scm_i_centered_divide
3171 #define g_scm_centered_divide g_scm_i_centered_divide
3174 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3176 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3178 scm_t_inum xx
= SCM_I_INUM (x
);
3179 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3181 scm_t_inum yy
= SCM_I_INUM (y
);
3182 if (SCM_UNLIKELY (yy
== 0))
3183 scm_num_overflow (s_scm_centered_divide
);
3186 scm_t_inum qq
= xx
/ yy
;
3187 scm_t_inum rr
= xx
% yy
;
3188 if (SCM_LIKELY (xx
> 0))
3190 if (SCM_LIKELY (yy
> 0))
3192 if (rr
>= (yy
+ 1) / 2)
3197 if (rr
>= (1 - yy
) / 2)
3203 if (SCM_LIKELY (yy
> 0))
3214 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3215 *qp
= SCM_I_MAKINUM (qq
);
3217 *qp
= scm_i_inum2big (qq
);
3218 *rp
= SCM_I_MAKINUM (rr
);
3222 else if (SCM_BIGP (y
))
3224 /* Pass a denormalized bignum version of x (even though it
3225 can fit in a fixnum) to scm_i_bigint_centered_divide */
3226 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3228 else if (SCM_REALP (y
))
3229 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3230 else if (SCM_FRACTIONP (y
))
3231 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3233 return two_valued_wta_dispatch_2
3234 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3235 s_scm_centered_divide
, qp
, rp
);
3237 else if (SCM_BIGP (x
))
3239 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3241 scm_t_inum yy
= SCM_I_INUM (y
);
3242 if (SCM_UNLIKELY (yy
== 0))
3243 scm_num_overflow (s_scm_centered_divide
);
3246 SCM q
= scm_i_mkbig ();
3248 /* Arrange for rr to initially be non-positive,
3249 because that simplifies the test to see
3250 if it is within the needed bounds. */
3253 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3254 SCM_I_BIG_MPZ (x
), yy
);
3255 scm_remember_upto_here_1 (x
);
3258 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3259 SCM_I_BIG_MPZ (q
), 1);
3265 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3266 SCM_I_BIG_MPZ (x
), -yy
);
3267 scm_remember_upto_here_1 (x
);
3268 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3271 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3272 SCM_I_BIG_MPZ (q
), 1);
3276 *qp
= scm_i_normbig (q
);
3277 *rp
= SCM_I_MAKINUM (rr
);
3281 else if (SCM_BIGP (y
))
3282 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3283 else if (SCM_REALP (y
))
3284 return scm_i_inexact_centered_divide
3285 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3286 else if (SCM_FRACTIONP (y
))
3287 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3289 return two_valued_wta_dispatch_2
3290 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3291 s_scm_centered_divide
, qp
, rp
);
3293 else if (SCM_REALP (x
))
3295 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3296 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3297 return scm_i_inexact_centered_divide
3298 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3300 return two_valued_wta_dispatch_2
3301 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3302 s_scm_centered_divide
, qp
, rp
);
3304 else if (SCM_FRACTIONP (x
))
3307 return scm_i_inexact_centered_divide
3308 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3309 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3310 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3312 return two_valued_wta_dispatch_2
3313 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3314 s_scm_centered_divide
, qp
, rp
);
3317 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3318 s_scm_centered_divide
, qp
, rp
);
3322 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3326 if (SCM_LIKELY (y
> 0))
3327 q
= floor (x
/y
+ 0.5);
3328 else if (SCM_LIKELY (y
< 0))
3329 q
= ceil (x
/y
- 0.5);
3331 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3335 *qp
= scm_i_from_double (q
);
3336 *rp
= scm_i_from_double (r
);
3339 /* Assumes that both x and y are bigints, though
3340 x might be able to fit into a fixnum. */
3342 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3346 /* Note that x might be small enough to fit into a
3347 fixnum, so we must not let it escape into the wild */
3351 /* min_r will eventually become -abs(y/2) */
3352 min_r
= scm_i_mkbig ();
3353 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3354 SCM_I_BIG_MPZ (y
), 1);
3356 /* Arrange for rr to initially be non-positive,
3357 because that simplifies the test to see
3358 if it is within the needed bounds. */
3359 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3361 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3362 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3363 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3364 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3366 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3367 SCM_I_BIG_MPZ (q
), 1);
3368 mpz_add (SCM_I_BIG_MPZ (r
),
3375 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3376 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3377 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3379 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3380 SCM_I_BIG_MPZ (q
), 1);
3381 mpz_sub (SCM_I_BIG_MPZ (r
),
3386 scm_remember_upto_here_2 (x
, y
);
3387 *qp
= scm_i_normbig (q
);
3388 *rp
= scm_i_normbig (r
);
3392 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3395 SCM xd
= scm_denominator (x
);
3396 SCM yd
= scm_denominator (y
);
3398 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3399 scm_product (scm_numerator (y
), xd
),
3401 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3404 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3405 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3406 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3408 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3410 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3411 "with ties going to the nearest even integer.\n"
3413 "(round-quotient 123 10) @result{} 12\n"
3414 "(round-quotient 123 -10) @result{} -12\n"
3415 "(round-quotient -123 10) @result{} -12\n"
3416 "(round-quotient -123 -10) @result{} 12\n"
3417 "(round-quotient 125 10) @result{} 12\n"
3418 "(round-quotient 127 10) @result{} 13\n"
3419 "(round-quotient 135 10) @result{} 14\n"
3420 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3421 "(round-quotient 16/3 -10/7) @result{} -4\n"
3423 #define FUNC_NAME s_scm_round_quotient
3425 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3427 scm_t_inum xx
= SCM_I_INUM (x
);
3428 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3430 scm_t_inum yy
= SCM_I_INUM (y
);
3431 if (SCM_UNLIKELY (yy
== 0))
3432 scm_num_overflow (s_scm_round_quotient
);
3435 scm_t_inum qq
= xx
/ yy
;
3436 scm_t_inum rr
= xx
% yy
;
3438 scm_t_inum r2
= 2 * rr
;
3440 if (SCM_LIKELY (yy
< 0))
3460 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3461 return SCM_I_MAKINUM (qq
);
3463 return scm_i_inum2big (qq
);
3466 else if (SCM_BIGP (y
))
3468 /* Pass a denormalized bignum version of x (even though it
3469 can fit in a fixnum) to scm_i_bigint_round_quotient */
3470 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3472 else if (SCM_REALP (y
))
3473 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3474 else if (SCM_FRACTIONP (y
))
3475 return scm_i_exact_rational_round_quotient (x
, y
);
3477 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3478 s_scm_round_quotient
);
3480 else if (SCM_BIGP (x
))
3482 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3484 scm_t_inum yy
= SCM_I_INUM (y
);
3485 if (SCM_UNLIKELY (yy
== 0))
3486 scm_num_overflow (s_scm_round_quotient
);
3487 else if (SCM_UNLIKELY (yy
== 1))
3491 SCM q
= scm_i_mkbig ();
3493 int needs_adjustment
;
3497 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3498 SCM_I_BIG_MPZ (x
), yy
);
3499 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3500 needs_adjustment
= (2*rr
>= yy
);
3502 needs_adjustment
= (2*rr
> yy
);
3506 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3507 SCM_I_BIG_MPZ (x
), -yy
);
3508 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3509 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3510 needs_adjustment
= (2*rr
<= yy
);
3512 needs_adjustment
= (2*rr
< yy
);
3514 scm_remember_upto_here_1 (x
);
3515 if (needs_adjustment
)
3516 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3517 return scm_i_normbig (q
);
3520 else if (SCM_BIGP (y
))
3521 return scm_i_bigint_round_quotient (x
, y
);
3522 else if (SCM_REALP (y
))
3523 return scm_i_inexact_round_quotient
3524 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3525 else if (SCM_FRACTIONP (y
))
3526 return scm_i_exact_rational_round_quotient (x
, y
);
3528 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3529 s_scm_round_quotient
);
3531 else if (SCM_REALP (x
))
3533 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3534 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3535 return scm_i_inexact_round_quotient
3536 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3538 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3539 s_scm_round_quotient
);
3541 else if (SCM_FRACTIONP (x
))
3544 return scm_i_inexact_round_quotient
3545 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3546 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3547 return scm_i_exact_rational_round_quotient (x
, y
);
3549 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3550 s_scm_round_quotient
);
3553 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3554 s_scm_round_quotient
);
3559 scm_i_inexact_round_quotient (double x
, double y
)
3561 if (SCM_UNLIKELY (y
== 0))
3562 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3564 return scm_i_from_double (scm_c_round (x
/ y
));
3567 /* Assumes that both x and y are bigints, though
3568 x might be able to fit into a fixnum. */
3570 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3573 int cmp
, needs_adjustment
;
3575 /* Note that x might be small enough to fit into a
3576 fixnum, so we must not let it escape into the wild */
3579 r2
= scm_i_mkbig ();
3581 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3582 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3583 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3584 scm_remember_upto_here_2 (x
, r
);
3586 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3587 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3588 needs_adjustment
= (cmp
>= 0);
3590 needs_adjustment
= (cmp
> 0);
3591 scm_remember_upto_here_2 (r2
, y
);
3593 if (needs_adjustment
)
3594 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3596 return scm_i_normbig (q
);
3600 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3602 return scm_round_quotient
3603 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3604 scm_product (scm_numerator (y
), scm_denominator (x
)));
3607 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3608 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3609 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3611 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3613 "Return the real number @var{r} such that\n"
3614 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3615 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3616 "nearest integer, with ties going to the nearest\n"
3619 "(round-remainder 123 10) @result{} 3\n"
3620 "(round-remainder 123 -10) @result{} 3\n"
3621 "(round-remainder -123 10) @result{} -3\n"
3622 "(round-remainder -123 -10) @result{} -3\n"
3623 "(round-remainder 125 10) @result{} 5\n"
3624 "(round-remainder 127 10) @result{} -3\n"
3625 "(round-remainder 135 10) @result{} -5\n"
3626 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3627 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3629 #define FUNC_NAME s_scm_round_remainder
3631 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3633 scm_t_inum xx
= SCM_I_INUM (x
);
3634 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3636 scm_t_inum yy
= SCM_I_INUM (y
);
3637 if (SCM_UNLIKELY (yy
== 0))
3638 scm_num_overflow (s_scm_round_remainder
);
3641 scm_t_inum qq
= xx
/ yy
;
3642 scm_t_inum rr
= xx
% yy
;
3644 scm_t_inum r2
= 2 * rr
;
3646 if (SCM_LIKELY (yy
< 0))
3666 return SCM_I_MAKINUM (rr
);
3669 else if (SCM_BIGP (y
))
3671 /* Pass a denormalized bignum version of x (even though it
3672 can fit in a fixnum) to scm_i_bigint_round_remainder */
3673 return scm_i_bigint_round_remainder
3674 (scm_i_long2big (xx
), y
);
3676 else if (SCM_REALP (y
))
3677 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3678 else if (SCM_FRACTIONP (y
))
3679 return scm_i_exact_rational_round_remainder (x
, y
);
3681 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3682 s_scm_round_remainder
);
3684 else if (SCM_BIGP (x
))
3686 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3688 scm_t_inum yy
= SCM_I_INUM (y
);
3689 if (SCM_UNLIKELY (yy
== 0))
3690 scm_num_overflow (s_scm_round_remainder
);
3693 SCM q
= scm_i_mkbig ();
3695 int needs_adjustment
;
3699 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3700 SCM_I_BIG_MPZ (x
), yy
);
3701 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3702 needs_adjustment
= (2*rr
>= yy
);
3704 needs_adjustment
= (2*rr
> yy
);
3708 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3709 SCM_I_BIG_MPZ (x
), -yy
);
3710 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3711 needs_adjustment
= (2*rr
<= yy
);
3713 needs_adjustment
= (2*rr
< yy
);
3715 scm_remember_upto_here_2 (x
, q
);
3716 if (needs_adjustment
)
3718 return SCM_I_MAKINUM (rr
);
3721 else if (SCM_BIGP (y
))
3722 return scm_i_bigint_round_remainder (x
, y
);
3723 else if (SCM_REALP (y
))
3724 return scm_i_inexact_round_remainder
3725 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3726 else if (SCM_FRACTIONP (y
))
3727 return scm_i_exact_rational_round_remainder (x
, y
);
3729 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3730 s_scm_round_remainder
);
3732 else if (SCM_REALP (x
))
3734 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3735 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3736 return scm_i_inexact_round_remainder
3737 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3739 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3740 s_scm_round_remainder
);
3742 else if (SCM_FRACTIONP (x
))
3745 return scm_i_inexact_round_remainder
3746 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3747 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3748 return scm_i_exact_rational_round_remainder (x
, y
);
3750 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3751 s_scm_round_remainder
);
3754 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3755 s_scm_round_remainder
);
3760 scm_i_inexact_round_remainder (double x
, double y
)
3762 /* Although it would be more efficient to use fmod here, we can't
3763 because it would in some cases produce results inconsistent with
3764 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3765 close). In particular, when x-y/2 is very close to a multiple of
3766 y, then r might be either -abs(y/2) or abs(y/2), but those two
3767 cases must correspond to different choices of q. If quotient
3768 chooses one and remainder chooses the other, it would be bad. */
3770 if (SCM_UNLIKELY (y
== 0))
3771 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3774 double q
= scm_c_round (x
/ y
);
3775 return scm_i_from_double (x
- q
* y
);
3779 /* Assumes that both x and y are bigints, though
3780 x might be able to fit into a fixnum. */
3782 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3785 int cmp
, needs_adjustment
;
3787 /* Note that x might be small enough to fit into a
3788 fixnum, so we must not let it escape into the wild */
3791 r2
= scm_i_mkbig ();
3793 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3794 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3795 scm_remember_upto_here_1 (x
);
3796 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3798 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3799 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3800 needs_adjustment
= (cmp
>= 0);
3802 needs_adjustment
= (cmp
> 0);
3803 scm_remember_upto_here_2 (q
, r2
);
3805 if (needs_adjustment
)
3806 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3808 scm_remember_upto_here_1 (y
);
3809 return scm_i_normbig (r
);
3813 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3815 SCM xd
= scm_denominator (x
);
3816 SCM yd
= scm_denominator (y
);
3817 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3818 scm_product (scm_numerator (y
), xd
));
3819 return scm_divide (r1
, scm_product (xd
, yd
));
3823 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3824 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3825 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3827 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3829 "Return the integer @var{q} and the real number @var{r}\n"
3830 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3831 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3832 "nearest integer, with ties going to the nearest even integer.\n"
3834 "(round/ 123 10) @result{} 12 and 3\n"
3835 "(round/ 123 -10) @result{} -12 and 3\n"
3836 "(round/ -123 10) @result{} -12 and -3\n"
3837 "(round/ -123 -10) @result{} 12 and -3\n"
3838 "(round/ 125 10) @result{} 12 and 5\n"
3839 "(round/ 127 10) @result{} 13 and -3\n"
3840 "(round/ 135 10) @result{} 14 and -5\n"
3841 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3842 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3844 #define FUNC_NAME s_scm_i_round_divide
3848 scm_round_divide(x
, y
, &q
, &r
);
3849 return scm_values (scm_list_2 (q
, r
));
3853 #define s_scm_round_divide s_scm_i_round_divide
3854 #define g_scm_round_divide g_scm_i_round_divide
3857 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3859 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3861 scm_t_inum xx
= SCM_I_INUM (x
);
3862 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3864 scm_t_inum yy
= SCM_I_INUM (y
);
3865 if (SCM_UNLIKELY (yy
== 0))
3866 scm_num_overflow (s_scm_round_divide
);
3869 scm_t_inum qq
= xx
/ yy
;
3870 scm_t_inum rr
= xx
% yy
;
3872 scm_t_inum r2
= 2 * rr
;
3874 if (SCM_LIKELY (yy
< 0))
3894 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3895 *qp
= SCM_I_MAKINUM (qq
);
3897 *qp
= scm_i_inum2big (qq
);
3898 *rp
= SCM_I_MAKINUM (rr
);
3902 else if (SCM_BIGP (y
))
3904 /* Pass a denormalized bignum version of x (even though it
3905 can fit in a fixnum) to scm_i_bigint_round_divide */
3906 return scm_i_bigint_round_divide
3907 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3909 else if (SCM_REALP (y
))
3910 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3911 else if (SCM_FRACTIONP (y
))
3912 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3914 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3915 s_scm_round_divide
, qp
, rp
);
3917 else if (SCM_BIGP (x
))
3919 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3921 scm_t_inum yy
= SCM_I_INUM (y
);
3922 if (SCM_UNLIKELY (yy
== 0))
3923 scm_num_overflow (s_scm_round_divide
);
3926 SCM q
= scm_i_mkbig ();
3928 int needs_adjustment
;
3932 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3933 SCM_I_BIG_MPZ (x
), yy
);
3934 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3935 needs_adjustment
= (2*rr
>= yy
);
3937 needs_adjustment
= (2*rr
> yy
);
3941 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3942 SCM_I_BIG_MPZ (x
), -yy
);
3943 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3944 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3945 needs_adjustment
= (2*rr
<= yy
);
3947 needs_adjustment
= (2*rr
< yy
);
3949 scm_remember_upto_here_1 (x
);
3950 if (needs_adjustment
)
3952 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3955 *qp
= scm_i_normbig (q
);
3956 *rp
= SCM_I_MAKINUM (rr
);
3960 else if (SCM_BIGP (y
))
3961 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3962 else if (SCM_REALP (y
))
3963 return scm_i_inexact_round_divide
3964 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3965 else if (SCM_FRACTIONP (y
))
3966 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3968 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3969 s_scm_round_divide
, qp
, rp
);
3971 else if (SCM_REALP (x
))
3973 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3974 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3975 return scm_i_inexact_round_divide
3976 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3978 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3979 s_scm_round_divide
, qp
, rp
);
3981 else if (SCM_FRACTIONP (x
))
3984 return scm_i_inexact_round_divide
3985 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3986 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3987 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3989 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3990 s_scm_round_divide
, qp
, rp
);
3993 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3994 s_scm_round_divide
, qp
, rp
);
3998 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
4000 if (SCM_UNLIKELY (y
== 0))
4001 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4004 double q
= scm_c_round (x
/ y
);
4005 double r
= x
- q
* y
;
4006 *qp
= scm_i_from_double (q
);
4007 *rp
= scm_i_from_double (r
);
4011 /* Assumes that both x and y are bigints, though
4012 x might be able to fit into a fixnum. */
4014 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4017 int cmp
, needs_adjustment
;
4019 /* Note that x might be small enough to fit into a
4020 fixnum, so we must not let it escape into the wild */
4023 r2
= scm_i_mkbig ();
4025 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4026 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4027 scm_remember_upto_here_1 (x
);
4028 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4030 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4031 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4032 needs_adjustment
= (cmp
>= 0);
4034 needs_adjustment
= (cmp
> 0);
4036 if (needs_adjustment
)
4038 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4039 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4042 scm_remember_upto_here_2 (r2
, y
);
4043 *qp
= scm_i_normbig (q
);
4044 *rp
= scm_i_normbig (r
);
4048 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4051 SCM xd
= scm_denominator (x
);
4052 SCM yd
= scm_denominator (y
);
4054 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4055 scm_product (scm_numerator (y
), xd
),
4057 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4061 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4062 (SCM x
, SCM y
, SCM rest
),
4063 "Return the greatest common divisor of all parameter values.\n"
4064 "If called without arguments, 0 is returned.")
4065 #define FUNC_NAME s_scm_i_gcd
4067 while (!scm_is_null (rest
))
4068 { x
= scm_gcd (x
, y
);
4070 rest
= scm_cdr (rest
);
4072 return scm_gcd (x
, y
);
4076 #define s_gcd s_scm_i_gcd
4077 #define g_gcd g_scm_i_gcd
4080 scm_gcd (SCM x
, SCM y
)
4082 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4083 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4085 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4087 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4089 scm_t_inum xx
= SCM_I_INUM (x
);
4090 scm_t_inum yy
= SCM_I_INUM (y
);
4091 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4092 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4094 if (SCM_UNLIKELY (xx
== 0))
4096 else if (SCM_UNLIKELY (yy
== 0))
4101 /* Determine a common factor 2^k */
4102 while (((u
| v
) & 1) == 0)
4108 /* Now, any factor 2^n can be eliminated */
4110 while ((u
& 1) == 0)
4113 while ((v
& 1) == 0)
4115 /* Both u and v are now odd. Subtract the smaller one
4116 from the larger one to produce an even number, remove
4117 more factors of two, and repeat. */
4123 while ((u
& 1) == 0)
4129 while ((v
& 1) == 0)
4135 return (SCM_POSFIXABLE (result
)
4136 ? SCM_I_MAKINUM (result
)
4137 : scm_i_inum2big (result
));
4139 else if (SCM_BIGP (y
))
4144 else if (SCM_REALP (y
) && scm_is_integer (y
))
4145 goto handle_inexacts
;
4147 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4149 else if (SCM_BIGP (x
))
4151 if (SCM_I_INUMP (y
))
4156 yy
= SCM_I_INUM (y
);
4161 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4162 scm_remember_upto_here_1 (x
);
4163 return (SCM_POSFIXABLE (result
)
4164 ? SCM_I_MAKINUM (result
)
4165 : scm_from_unsigned_integer (result
));
4167 else if (SCM_BIGP (y
))
4169 SCM result
= scm_i_mkbig ();
4170 mpz_gcd (SCM_I_BIG_MPZ (result
),
4173 scm_remember_upto_here_2 (x
, y
);
4174 return scm_i_normbig (result
);
4176 else if (SCM_REALP (y
) && scm_is_integer (y
))
4177 goto handle_inexacts
;
4179 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4181 else if (SCM_REALP (x
) && scm_is_integer (x
))
4183 if (SCM_I_INUMP (y
) || SCM_BIGP (y
)
4184 || (SCM_REALP (y
) && scm_is_integer (y
)))
4187 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x
),
4188 scm_inexact_to_exact (y
)));
4191 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4194 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4197 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4198 (SCM x
, SCM y
, SCM rest
),
4199 "Return the least common multiple of the arguments.\n"
4200 "If called without arguments, 1 is returned.")
4201 #define FUNC_NAME s_scm_i_lcm
4203 while (!scm_is_null (rest
))
4204 { x
= scm_lcm (x
, y
);
4206 rest
= scm_cdr (rest
);
4208 return scm_lcm (x
, y
);
4212 #define s_lcm s_scm_i_lcm
4213 #define g_lcm g_scm_i_lcm
4216 scm_lcm (SCM n1
, SCM n2
)
4218 if (SCM_UNLIKELY (SCM_UNBNDP (n2
)))
4219 return SCM_UNBNDP (n1
) ? SCM_INUM1
: scm_abs (n1
);
4221 if (SCM_LIKELY (SCM_I_INUMP (n1
)))
4223 if (SCM_LIKELY (SCM_I_INUMP (n2
)))
4225 SCM d
= scm_gcd (n1
, n2
);
4226 if (scm_is_eq (d
, SCM_INUM0
))
4229 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4231 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4233 /* inum n1, big n2 */
4236 SCM result
= scm_i_mkbig ();
4237 scm_t_inum nn1
= SCM_I_INUM (n1
);
4238 if (nn1
== 0) return SCM_INUM0
;
4239 if (nn1
< 0) nn1
= - nn1
;
4240 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4241 scm_remember_upto_here_1 (n2
);
4245 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4246 goto handle_inexacts
;
4248 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4250 else if (SCM_LIKELY (SCM_BIGP (n1
)))
4253 if (SCM_I_INUMP (n2
))
4258 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4260 SCM result
= scm_i_mkbig ();
4261 mpz_lcm(SCM_I_BIG_MPZ (result
),
4263 SCM_I_BIG_MPZ (n2
));
4264 scm_remember_upto_here_2(n1
, n2
);
4265 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4268 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4269 goto handle_inexacts
;
4271 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4273 else if (SCM_REALP (n1
) && scm_is_integer (n1
))
4275 if (SCM_I_INUMP (n2
) || SCM_BIGP (n2
)
4276 || (SCM_REALP (n2
) && scm_is_integer (n2
)))
4279 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1
),
4280 scm_inexact_to_exact (n2
)));
4283 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4286 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4289 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4294 + + + x (map digit:logand X Y)
4295 + - + x (map digit:logand X (lognot (+ -1 Y)))
4296 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4297 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4302 + + + (map digit:logior X Y)
4303 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4304 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4305 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4310 + + + (map digit:logxor X Y)
4311 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4312 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4313 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4318 + + (any digit:logand X Y)
4319 + - (any digit:logand X (lognot (+ -1 Y)))
4320 - + (any digit:logand (lognot (+ -1 X)) Y)
4325 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4326 (SCM x
, SCM y
, SCM rest
),
4327 "Return the bitwise AND of the integer arguments.\n\n"
4329 "(logand) @result{} -1\n"
4330 "(logand 7) @result{} 7\n"
4331 "(logand #b111 #b011 #b001) @result{} 1\n"
4333 #define FUNC_NAME s_scm_i_logand
4335 while (!scm_is_null (rest
))
4336 { x
= scm_logand (x
, y
);
4338 rest
= scm_cdr (rest
);
4340 return scm_logand (x
, y
);
4344 #define s_scm_logand s_scm_i_logand
4346 SCM
scm_logand (SCM n1
, SCM n2
)
4347 #define FUNC_NAME s_scm_logand
4351 if (SCM_UNBNDP (n2
))
4353 if (SCM_UNBNDP (n1
))
4354 return SCM_I_MAKINUM (-1);
4355 else if (!SCM_NUMBERP (n1
))
4356 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4357 else if (SCM_NUMBERP (n1
))
4360 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4363 if (SCM_I_INUMP (n1
))
4365 nn1
= SCM_I_INUM (n1
);
4366 if (SCM_I_INUMP (n2
))
4368 scm_t_inum nn2
= SCM_I_INUM (n2
);
4369 return SCM_I_MAKINUM (nn1
& nn2
);
4371 else if SCM_BIGP (n2
)
4377 SCM result_z
= scm_i_mkbig ();
4379 mpz_init_set_si (nn1_z
, nn1
);
4380 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4381 scm_remember_upto_here_1 (n2
);
4383 return scm_i_normbig (result_z
);
4387 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4389 else if (SCM_BIGP (n1
))
4391 if (SCM_I_INUMP (n2
))
4394 nn1
= SCM_I_INUM (n1
);
4397 else if (SCM_BIGP (n2
))
4399 SCM result_z
= scm_i_mkbig ();
4400 mpz_and (SCM_I_BIG_MPZ (result_z
),
4402 SCM_I_BIG_MPZ (n2
));
4403 scm_remember_upto_here_2 (n1
, n2
);
4404 return scm_i_normbig (result_z
);
4407 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4410 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4415 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4416 (SCM x
, SCM y
, SCM rest
),
4417 "Return the bitwise OR of the integer arguments.\n\n"
4419 "(logior) @result{} 0\n"
4420 "(logior 7) @result{} 7\n"
4421 "(logior #b000 #b001 #b011) @result{} 3\n"
4423 #define FUNC_NAME s_scm_i_logior
4425 while (!scm_is_null (rest
))
4426 { x
= scm_logior (x
, y
);
4428 rest
= scm_cdr (rest
);
4430 return scm_logior (x
, y
);
4434 #define s_scm_logior s_scm_i_logior
4436 SCM
scm_logior (SCM n1
, SCM n2
)
4437 #define FUNC_NAME s_scm_logior
4441 if (SCM_UNBNDP (n2
))
4443 if (SCM_UNBNDP (n1
))
4445 else if (SCM_NUMBERP (n1
))
4448 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4451 if (SCM_I_INUMP (n1
))
4453 nn1
= SCM_I_INUM (n1
);
4454 if (SCM_I_INUMP (n2
))
4456 long nn2
= SCM_I_INUM (n2
);
4457 return SCM_I_MAKINUM (nn1
| nn2
);
4459 else if (SCM_BIGP (n2
))
4465 SCM result_z
= scm_i_mkbig ();
4467 mpz_init_set_si (nn1_z
, nn1
);
4468 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4469 scm_remember_upto_here_1 (n2
);
4471 return scm_i_normbig (result_z
);
4475 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4477 else if (SCM_BIGP (n1
))
4479 if (SCM_I_INUMP (n2
))
4482 nn1
= SCM_I_INUM (n1
);
4485 else if (SCM_BIGP (n2
))
4487 SCM result_z
= scm_i_mkbig ();
4488 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4490 SCM_I_BIG_MPZ (n2
));
4491 scm_remember_upto_here_2 (n1
, n2
);
4492 return scm_i_normbig (result_z
);
4495 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4498 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4503 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4504 (SCM x
, SCM y
, SCM rest
),
4505 "Return the bitwise XOR of the integer arguments. A bit is\n"
4506 "set in the result if it is set in an odd number of arguments.\n"
4508 "(logxor) @result{} 0\n"
4509 "(logxor 7) @result{} 7\n"
4510 "(logxor #b000 #b001 #b011) @result{} 2\n"
4511 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4513 #define FUNC_NAME s_scm_i_logxor
4515 while (!scm_is_null (rest
))
4516 { x
= scm_logxor (x
, y
);
4518 rest
= scm_cdr (rest
);
4520 return scm_logxor (x
, y
);
4524 #define s_scm_logxor s_scm_i_logxor
4526 SCM
scm_logxor (SCM n1
, SCM n2
)
4527 #define FUNC_NAME s_scm_logxor
4531 if (SCM_UNBNDP (n2
))
4533 if (SCM_UNBNDP (n1
))
4535 else if (SCM_NUMBERP (n1
))
4538 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4541 if (SCM_I_INUMP (n1
))
4543 nn1
= SCM_I_INUM (n1
);
4544 if (SCM_I_INUMP (n2
))
4546 scm_t_inum nn2
= SCM_I_INUM (n2
);
4547 return SCM_I_MAKINUM (nn1
^ nn2
);
4549 else if (SCM_BIGP (n2
))
4553 SCM result_z
= scm_i_mkbig ();
4555 mpz_init_set_si (nn1_z
, nn1
);
4556 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4557 scm_remember_upto_here_1 (n2
);
4559 return scm_i_normbig (result_z
);
4563 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4565 else if (SCM_BIGP (n1
))
4567 if (SCM_I_INUMP (n2
))
4570 nn1
= SCM_I_INUM (n1
);
4573 else if (SCM_BIGP (n2
))
4575 SCM result_z
= scm_i_mkbig ();
4576 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4578 SCM_I_BIG_MPZ (n2
));
4579 scm_remember_upto_here_2 (n1
, n2
);
4580 return scm_i_normbig (result_z
);
4583 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4586 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4591 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4593 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4594 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4595 "without actually calculating the @code{logand}, just testing\n"
4599 "(logtest #b0100 #b1011) @result{} #f\n"
4600 "(logtest #b0100 #b0111) @result{} #t\n"
4602 #define FUNC_NAME s_scm_logtest
4606 if (SCM_I_INUMP (j
))
4608 nj
= SCM_I_INUM (j
);
4609 if (SCM_I_INUMP (k
))
4611 scm_t_inum nk
= SCM_I_INUM (k
);
4612 return scm_from_bool (nj
& nk
);
4614 else if (SCM_BIGP (k
))
4622 mpz_init_set_si (nj_z
, nj
);
4623 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4624 scm_remember_upto_here_1 (k
);
4625 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4631 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4633 else if (SCM_BIGP (j
))
4635 if (SCM_I_INUMP (k
))
4638 nj
= SCM_I_INUM (j
);
4641 else if (SCM_BIGP (k
))
4645 mpz_init (result_z
);
4649 scm_remember_upto_here_2 (j
, k
);
4650 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4651 mpz_clear (result_z
);
4655 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4658 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4663 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4665 "Test whether bit number @var{index} in @var{j} is set.\n"
4666 "@var{index} starts from 0 for the least significant bit.\n"
4669 "(logbit? 0 #b1101) @result{} #t\n"
4670 "(logbit? 1 #b1101) @result{} #f\n"
4671 "(logbit? 2 #b1101) @result{} #t\n"
4672 "(logbit? 3 #b1101) @result{} #t\n"
4673 "(logbit? 4 #b1101) @result{} #f\n"
4675 #define FUNC_NAME s_scm_logbit_p
4677 unsigned long int iindex
;
4678 iindex
= scm_to_ulong (index
);
4680 if (SCM_I_INUMP (j
))
4682 /* bits above what's in an inum follow the sign bit */
4683 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4684 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4686 else if (SCM_BIGP (j
))
4688 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4689 scm_remember_upto_here_1 (j
);
4690 return scm_from_bool (val
);
4693 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4698 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4700 "Return the integer which is the ones-complement of the integer\n"
4704 "(number->string (lognot #b10000000) 2)\n"
4705 " @result{} \"-10000001\"\n"
4706 "(number->string (lognot #b0) 2)\n"
4707 " @result{} \"-1\"\n"
4709 #define FUNC_NAME s_scm_lognot
4711 if (SCM_I_INUMP (n
)) {
4712 /* No overflow here, just need to toggle all the bits making up the inum.
4713 Enhancement: No need to strip the tag and add it back, could just xor
4714 a block of 1 bits, if that worked with the various debug versions of
4716 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4718 } else if (SCM_BIGP (n
)) {
4719 SCM result
= scm_i_mkbig ();
4720 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4721 scm_remember_upto_here_1 (n
);
4725 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4730 /* returns 0 if IN is not an integer. OUT must already be
4733 coerce_to_big (SCM in
, mpz_t out
)
4736 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4737 else if (SCM_I_INUMP (in
))
4738 mpz_set_si (out
, SCM_I_INUM (in
));
4745 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4746 (SCM n
, SCM k
, SCM m
),
4747 "Return @var{n} raised to the integer exponent\n"
4748 "@var{k}, modulo @var{m}.\n"
4751 "(modulo-expt 2 3 5)\n"
4754 #define FUNC_NAME s_scm_modulo_expt
4760 /* There are two classes of error we might encounter --
4761 1) Math errors, which we'll report by calling scm_num_overflow,
4763 2) wrong-type errors, which of course we'll report by calling
4765 We don't report those errors immediately, however; instead we do
4766 some cleanup first. These variables tell us which error (if
4767 any) we should report after cleaning up.
4769 int report_overflow
= 0;
4771 int position_of_wrong_type
= 0;
4772 SCM value_of_wrong_type
= SCM_INUM0
;
4774 SCM result
= SCM_UNDEFINED
;
4780 if (scm_is_eq (m
, SCM_INUM0
))
4782 report_overflow
= 1;
4786 if (!coerce_to_big (n
, n_tmp
))
4788 value_of_wrong_type
= n
;
4789 position_of_wrong_type
= 1;
4793 if (!coerce_to_big (k
, k_tmp
))
4795 value_of_wrong_type
= k
;
4796 position_of_wrong_type
= 2;
4800 if (!coerce_to_big (m
, m_tmp
))
4802 value_of_wrong_type
= m
;
4803 position_of_wrong_type
= 3;
4807 /* if the exponent K is negative, and we simply call mpz_powm, we
4808 will get a divide-by-zero exception when an inverse 1/n mod m
4809 doesn't exist (or is not unique). Since exceptions are hard to
4810 handle, we'll attempt the inversion "by hand" -- that way, we get
4811 a simple failure code, which is easy to handle. */
4813 if (-1 == mpz_sgn (k_tmp
))
4815 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4817 report_overflow
= 1;
4820 mpz_neg (k_tmp
, k_tmp
);
4823 result
= scm_i_mkbig ();
4824 mpz_powm (SCM_I_BIG_MPZ (result
),
4829 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4830 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4837 if (report_overflow
)
4838 scm_num_overflow (FUNC_NAME
);
4840 if (position_of_wrong_type
)
4841 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4842 value_of_wrong_type
);
4844 return scm_i_normbig (result
);
4848 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4850 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4851 "exact integer, @var{n} can be any number.\n"
4853 "Negative @var{k} is supported, and results in\n"
4854 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4855 "@math{@var{n}^0} is 1, as usual, and that\n"
4856 "includes @math{0^0} is 1.\n"
4859 "(integer-expt 2 5) @result{} 32\n"
4860 "(integer-expt -3 3) @result{} -27\n"
4861 "(integer-expt 5 -3) @result{} 1/125\n"
4862 "(integer-expt 0 0) @result{} 1\n"
4864 #define FUNC_NAME s_scm_integer_expt
4867 SCM z_i2
= SCM_BOOL_F
;
4869 SCM acc
= SCM_I_MAKINUM (1L);
4871 /* Specifically refrain from checking the type of the first argument.
4872 This allows us to exponentiate any object that can be multiplied.
4873 If we must raise to a negative power, we must also be able to
4874 take its reciprocal. */
4875 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4876 SCM_WRONG_TYPE_ARG (2, k
);
4878 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4879 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4880 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4881 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4882 /* The next check is necessary only because R6RS specifies different
4883 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4884 we simply skip this case and move on. */
4885 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4887 /* k cannot be 0 at this point, because we
4888 have already checked for that case above */
4889 if (scm_is_true (scm_positive_p (k
)))
4891 else /* return NaN for (0 ^ k) for negative k per R6RS */
4894 else if (SCM_FRACTIONP (n
))
4896 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4897 needless reduction of intermediate products to lowest terms.
4898 If a and b have no common factors, then a^k and b^k have no
4899 common factors. Use 'scm_i_make_ratio_already_reduced' to
4900 construct the final result, so that no gcd computations are
4901 needed to exponentiate a fraction. */
4902 if (scm_is_true (scm_positive_p (k
)))
4903 return scm_i_make_ratio_already_reduced
4904 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4905 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4908 k
= scm_difference (k
, SCM_UNDEFINED
);
4909 return scm_i_make_ratio_already_reduced
4910 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4911 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4915 if (SCM_I_INUMP (k
))
4916 i2
= SCM_I_INUM (k
);
4917 else if (SCM_BIGP (k
))
4919 z_i2
= scm_i_clonebig (k
, 1);
4920 scm_remember_upto_here_1 (k
);
4924 SCM_WRONG_TYPE_ARG (2, k
);
4928 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4930 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4931 n
= scm_divide (n
, SCM_UNDEFINED
);
4935 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4939 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4941 return scm_product (acc
, n
);
4943 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4944 acc
= scm_product (acc
, n
);
4945 n
= scm_product (n
, n
);
4946 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4954 n
= scm_divide (n
, SCM_UNDEFINED
);
4961 return scm_product (acc
, n
);
4963 acc
= scm_product (acc
, n
);
4964 n
= scm_product (n
, n
);
4971 /* Efficiently compute (N * 2^COUNT),
4972 where N is an exact integer, and COUNT > 0. */
4974 left_shift_exact_integer (SCM n
, long count
)
4976 if (SCM_I_INUMP (n
))
4978 scm_t_inum nn
= SCM_I_INUM (n
);
4980 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
4981 overflow a non-zero fixnum. For smaller shifts we check the
4982 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4983 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4984 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
4986 [*] There's one exception:
4987 (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
4991 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4992 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4994 return SCM_I_MAKINUM (nn
<< count
);
4997 SCM result
= scm_i_inum2big (nn
);
4998 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5000 return scm_i_normbig (result
);
5003 else if (SCM_BIGP (n
))
5005 SCM result
= scm_i_mkbig ();
5006 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5007 scm_remember_upto_here_1 (n
);
5014 /* Efficiently compute floor (N / 2^COUNT),
5015 where N is an exact integer and COUNT > 0. */
5017 floor_right_shift_exact_integer (SCM n
, long count
)
5019 if (SCM_I_INUMP (n
))
5021 scm_t_inum nn
= SCM_I_INUM (n
);
5023 if (count
>= SCM_I_FIXNUM_BIT
)
5024 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5026 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5028 else if (SCM_BIGP (n
))
5030 SCM result
= scm_i_mkbig ();
5031 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5033 scm_remember_upto_here_1 (n
);
5034 return scm_i_normbig (result
);
5040 /* Efficiently compute round (N / 2^COUNT),
5041 where N is an exact integer and COUNT > 0. */
5043 round_right_shift_exact_integer (SCM n
, long count
)
5045 if (SCM_I_INUMP (n
))
5047 if (count
>= SCM_I_FIXNUM_BIT
)
5051 scm_t_inum nn
= SCM_I_INUM (n
);
5052 scm_t_inum qq
= SCM_SRS (nn
, count
);
5054 if (0 == (nn
& (1L << (count
-1))))
5055 return SCM_I_MAKINUM (qq
); /* round down */
5056 else if (nn
& ((1L << (count
-1)) - 1))
5057 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5059 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5062 else if (SCM_BIGP (n
))
5064 SCM q
= scm_i_mkbig ();
5066 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5067 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5068 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5069 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5070 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5071 scm_remember_upto_here_1 (n
);
5072 return scm_i_normbig (q
);
5078 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5080 "Return @math{floor(@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{ash} means a left shift introducing zero bits\n"
5085 "when @var{count} is positive, or a right shift dropping bits\n"
5086 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5089 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5090 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5092 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5093 "(ash -23 -2) @result{} -6\n"
5095 #define FUNC_NAME s_scm_ash
5097 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5099 long bits_to_shift
= scm_to_long (count
);
5101 if (bits_to_shift
> 0)
5102 return left_shift_exact_integer (n
, bits_to_shift
);
5103 else if (SCM_LIKELY (bits_to_shift
< 0))
5104 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5109 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5113 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5115 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5116 "@var{n} and @var{count} must be exact integers.\n"
5118 "With @var{n} viewed as an infinite-precision twos-complement\n"
5119 "integer, @code{round-ash} means a left shift introducing zero\n"
5120 "bits when @var{count} is positive, or a right shift rounding\n"
5121 "to the nearest integer (with ties going to the nearest even\n"
5122 "integer) when @var{count} is negative. This is a rounded\n"
5123 "``arithmetic'' shift.\n"
5126 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5127 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5128 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5129 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5130 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5131 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5133 #define FUNC_NAME s_scm_round_ash
5135 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5137 long bits_to_shift
= scm_to_long (count
);
5139 if (bits_to_shift
> 0)
5140 return left_shift_exact_integer (n
, bits_to_shift
);
5141 else if (SCM_LIKELY (bits_to_shift
< 0))
5142 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5147 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5152 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5153 (SCM n
, SCM start
, SCM end
),
5154 "Return the integer composed of the @var{start} (inclusive)\n"
5155 "through @var{end} (exclusive) bits of @var{n}. The\n"
5156 "@var{start}th bit becomes the 0-th bit in the result.\n"
5159 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5160 " @result{} \"1010\"\n"
5161 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5162 " @result{} \"10110\"\n"
5164 #define FUNC_NAME s_scm_bit_extract
5166 unsigned long int istart
, iend
, bits
;
5167 istart
= scm_to_ulong (start
);
5168 iend
= scm_to_ulong (end
);
5169 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5171 /* how many bits to keep */
5172 bits
= iend
- istart
;
5174 if (SCM_I_INUMP (n
))
5176 scm_t_inum in
= SCM_I_INUM (n
);
5178 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5179 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5180 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5182 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5184 /* Since we emulate two's complement encoded numbers, this
5185 * special case requires us to produce a result that has
5186 * more bits than can be stored in a fixnum.
5188 SCM result
= scm_i_inum2big (in
);
5189 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5194 /* mask down to requisite bits */
5195 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5196 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5198 else if (SCM_BIGP (n
))
5203 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5207 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5208 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5209 such bits into a ulong. */
5210 result
= scm_i_mkbig ();
5211 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5212 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5213 result
= scm_i_normbig (result
);
5215 scm_remember_upto_here_1 (n
);
5219 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5224 static const char scm_logtab
[] = {
5225 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5228 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5230 "Return the number of bits in integer @var{n}. If integer is\n"
5231 "positive, the 1-bits in its binary representation are counted.\n"
5232 "If negative, the 0-bits in its two's-complement binary\n"
5233 "representation are counted. If 0, 0 is returned.\n"
5236 "(logcount #b10101010)\n"
5243 #define FUNC_NAME s_scm_logcount
5245 if (SCM_I_INUMP (n
))
5247 unsigned long c
= 0;
5248 scm_t_inum nn
= SCM_I_INUM (n
);
5253 c
+= scm_logtab
[15 & nn
];
5256 return SCM_I_MAKINUM (c
);
5258 else if (SCM_BIGP (n
))
5260 unsigned long count
;
5261 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5262 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5264 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5265 scm_remember_upto_here_1 (n
);
5266 return SCM_I_MAKINUM (count
);
5269 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5274 static const char scm_ilentab
[] = {
5275 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5279 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5281 "Return the number of bits necessary to represent @var{n}.\n"
5284 "(integer-length #b10101010)\n"
5286 "(integer-length 0)\n"
5288 "(integer-length #b1111)\n"
5291 #define FUNC_NAME s_scm_integer_length
5293 if (SCM_I_INUMP (n
))
5295 unsigned long c
= 0;
5297 scm_t_inum nn
= SCM_I_INUM (n
);
5303 l
= scm_ilentab
[15 & nn
];
5306 return SCM_I_MAKINUM (c
- 4 + l
);
5308 else if (SCM_BIGP (n
))
5310 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5311 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5312 1 too big, so check for that and adjust. */
5313 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5314 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5315 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5316 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5318 scm_remember_upto_here_1 (n
);
5319 return SCM_I_MAKINUM (size
);
5322 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5326 /*** NUMBERS -> STRINGS ***/
5327 #define SCM_MAX_DBL_RADIX 36
5329 /* use this array as a way to generate a single digit */
5330 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5332 static mpz_t dbl_minimum_normal_mantissa
;
5335 idbl2str (double dbl
, char *a
, int radix
)
5339 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5340 /* revert to existing behavior */
5345 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5355 else if (dbl
== 0.0)
5357 if (copysign (1.0, dbl
) < 0.0)
5359 strcpy (a
+ ch
, "0.0");
5362 else if (isnan (dbl
))
5364 strcpy (a
, "+nan.0");
5368 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5369 Accurately" by Robert G. Burger and R. Kent Dybvig */
5372 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5373 int f_is_even
, f_is_odd
;
5377 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5378 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5379 if (e
< DBL_MIN_EXP
)
5381 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5386 f_is_even
= !mpz_odd_p (f
);
5387 f_is_odd
= !f_is_even
;
5389 /* Initialize r, s, mplus, and mminus according
5390 to Table 1 from the paper. */
5393 mpz_set_ui (mminus
, 1);
5394 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5395 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5397 mpz_set_ui (mplus
, 1);
5398 mpz_mul_2exp (r
, f
, 1);
5399 mpz_mul_2exp (s
, mminus
, 1 - e
);
5403 mpz_set_ui (mplus
, 2);
5404 mpz_mul_2exp (r
, f
, 2);
5405 mpz_mul_2exp (s
, mminus
, 2 - e
);
5410 mpz_set_ui (mminus
, 1);
5411 mpz_mul_2exp (mminus
, mminus
, e
);
5412 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5414 mpz_set (mplus
, mminus
);
5415 mpz_mul_2exp (r
, f
, 1 + e
);
5420 mpz_mul_2exp (mplus
, mminus
, 1);
5421 mpz_mul_2exp (r
, f
, 2 + e
);
5426 /* Find the smallest k such that:
5427 (r + mplus) / s < radix^k (if f is even)
5428 (r + mplus) / s <= radix^k (if f is odd) */
5430 /* IMPROVE-ME: Make an initial guess to speed this up */
5431 mpz_add (hi
, r
, mplus
);
5433 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5435 mpz_mul_ui (s
, s
, radix
);
5440 mpz_mul_ui (hi
, hi
, radix
);
5441 while (mpz_cmp (hi
, s
) < f_is_odd
)
5443 mpz_mul_ui (r
, r
, radix
);
5444 mpz_mul_ui (mplus
, mplus
, radix
);
5445 mpz_mul_ui (mminus
, mminus
, radix
);
5446 mpz_mul_ui (hi
, hi
, radix
);
5457 /* Use scientific notation */
5465 /* Print leading zeroes */
5468 for (i
= 0; i
> k
; i
--)
5475 int end_1_p
, end_2_p
;
5478 mpz_mul_ui (mplus
, mplus
, radix
);
5479 mpz_mul_ui (mminus
, mminus
, radix
);
5480 mpz_mul_ui (r
, r
, radix
);
5481 mpz_fdiv_qr (digit
, r
, r
, s
);
5482 d
= mpz_get_ui (digit
);
5484 mpz_add (hi
, r
, mplus
);
5485 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5486 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5487 if (end_1_p
|| end_2_p
)
5489 mpz_mul_2exp (r
, r
, 1);
5494 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5496 a
[ch
++] = number_chars
[d
];
5503 a
[ch
++] = number_chars
[d
];
5511 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5513 /* Here we would have to print more than three zeroes
5514 followed by a decimal point and another zero. It
5515 makes more sense to use scientific notation. */
5517 /* Adjust k to what it would have been if we had chosen
5518 scientific notation from the beginning. */
5521 /* k will now be <= 0, with magnitude equal to the number of
5522 digits that we printed which should now be put after the
5525 /* Insert a decimal point */
5526 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5546 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5549 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5556 icmplx2str (double real
, double imag
, char *str
, int radix
)
5561 i
= idbl2str (real
, str
, radix
);
5562 #ifdef HAVE_COPYSIGN
5563 sgn
= copysign (1.0, imag
);
5567 /* Don't output a '+' for negative numbers or for Inf and
5568 NaN. They will provide their own sign. */
5569 if (sgn
>= 0 && isfinite (imag
))
5571 i
+= idbl2str (imag
, &str
[i
], radix
);
5577 iflo2str (SCM flt
, char *str
, int radix
)
5580 if (SCM_REALP (flt
))
5581 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5583 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5588 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5589 characters in the result.
5591 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5593 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5598 return scm_iuint2str (-num
, rad
, p
) + 1;
5601 return scm_iuint2str (num
, rad
, p
);
5604 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5605 characters in the result.
5607 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5609 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5613 scm_t_uintmax n
= num
;
5615 if (rad
< 2 || rad
> 36)
5616 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5618 for (n
/= rad
; n
> 0; n
/= rad
)
5628 p
[i
] = number_chars
[d
];
5633 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5635 "Return a string holding the external representation of the\n"
5636 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5637 "inexact, a radix of 10 will be used.")
5638 #define FUNC_NAME s_scm_number_to_string
5642 if (SCM_UNBNDP (radix
))
5645 base
= scm_to_signed_integer (radix
, 2, 36);
5647 if (SCM_I_INUMP (n
))
5649 char num_buf
[SCM_INTBUFLEN
];
5650 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5651 return scm_from_locale_stringn (num_buf
, length
);
5653 else if (SCM_BIGP (n
))
5655 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5656 size_t len
= strlen (str
);
5657 void (*freefunc
) (void *, size_t);
5659 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5660 scm_remember_upto_here_1 (n
);
5661 ret
= scm_from_latin1_stringn (str
, len
);
5662 freefunc (str
, len
+ 1);
5665 else if (SCM_FRACTIONP (n
))
5667 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5668 scm_from_locale_string ("/"),
5669 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5671 else if (SCM_INEXACTP (n
))
5673 char num_buf
[FLOBUFLEN
];
5674 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5677 SCM_WRONG_TYPE_ARG (1, n
);
5682 /* These print routines used to be stubbed here so that scm_repl.c
5683 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5686 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5688 char num_buf
[FLOBUFLEN
];
5689 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5694 scm_i_print_double (double val
, SCM port
)
5696 char num_buf
[FLOBUFLEN
];
5697 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5701 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5704 char num_buf
[FLOBUFLEN
];
5705 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5710 scm_i_print_complex (double real
, double imag
, SCM port
)
5712 char num_buf
[FLOBUFLEN
];
5713 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5717 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5720 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5721 scm_display (str
, port
);
5722 scm_remember_upto_here_1 (str
);
5727 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5729 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5730 size_t len
= strlen (str
);
5731 void (*freefunc
) (void *, size_t);
5732 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5733 scm_remember_upto_here_1 (exp
);
5734 scm_lfwrite_unlocked (str
, len
, port
);
5735 freefunc (str
, len
+ 1);
5738 /*** END nums->strs ***/
5741 /*** STRINGS -> NUMBERS ***/
5743 /* The following functions implement the conversion from strings to numbers.
5744 * The implementation somehow follows the grammar for numbers as it is given
5745 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5746 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5747 * points should be noted about the implementation:
5749 * * Each function keeps a local index variable 'idx' that points at the
5750 * current position within the parsed string. The global index is only
5751 * updated if the function could parse the corresponding syntactic unit
5754 * * Similarly, the functions keep track of indicators of inexactness ('#',
5755 * '.' or exponents) using local variables ('hash_seen', 'x').
5757 * * Sequences of digits are parsed into temporary variables holding fixnums.
5758 * Only if these fixnums would overflow, the result variables are updated
5759 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5760 * the temporary variables holding the fixnums are cleared, and the process
5761 * starts over again. If for example fixnums were able to store five decimal
5762 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5763 * and the result was computed as 12345 * 100000 + 67890. In other words,
5764 * only every five digits two bignum operations were performed.
5766 * Notes on the handling of exactness specifiers:
5768 * When parsing non-real complex numbers, we apply exactness specifiers on
5769 * per-component basis, as is done in PLT Scheme. For complex numbers
5770 * written in rectangular form, exactness specifiers are applied to the
5771 * real and imaginary parts before calling scm_make_rectangular. For
5772 * complex numbers written in polar form, exactness specifiers are applied
5773 * to the magnitude and angle before calling scm_make_polar.
5775 * There are two kinds of exactness specifiers: forced and implicit. A
5776 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5777 * the entire number, and applies to both components of a complex number.
5778 * "#e" causes each component to be made exact, and "#i" causes each
5779 * component to be made inexact. If no forced exactness specifier is
5780 * present, then the exactness of each component is determined
5781 * independently by the presence or absence of a decimal point or hash mark
5782 * within that component. If a decimal point or hash mark is present, the
5783 * component is made inexact, otherwise it is made exact.
5785 * After the exactness specifiers have been applied to each component, they
5786 * are passed to either scm_make_rectangular or scm_make_polar to produce
5787 * the final result. Note that this will result in a real number if the
5788 * imaginary part, magnitude, or angle is an exact 0.
5790 * For example, (string->number "#i5.0+0i") does the equivalent of:
5792 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5795 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5797 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5799 /* Caller is responsible for checking that the return value is in range
5800 for the given radix, which should be <= 36. */
5802 char_decimal_value (scm_t_uint32 c
)
5804 if (c
>= (scm_t_uint32
) '0' && c
<= (scm_t_uint32
) '9')
5805 return c
- (scm_t_uint32
) '0';
5808 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5809 that's certainly above any valid decimal, so we take advantage of
5810 that to elide some tests. */
5811 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5813 /* If that failed, try extended hexadecimals, then. Only accept ascii
5818 if (c
>= (scm_t_uint32
) 'a')
5819 d
= c
- (scm_t_uint32
)'a' + 10U;
5825 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5826 in base RADIX. Upon success, return the unsigned integer and update
5827 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5829 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5830 unsigned int radix
, enum t_exactness
*p_exactness
)
5832 unsigned int idx
= *p_idx
;
5833 unsigned int hash_seen
= 0;
5834 scm_t_bits shift
= 1;
5836 unsigned int digit_value
;
5839 size_t len
= scm_i_string_length (mem
);
5844 c
= scm_i_string_ref (mem
, idx
);
5845 digit_value
= char_decimal_value (c
);
5846 if (digit_value
>= radix
)
5850 result
= SCM_I_MAKINUM (digit_value
);
5853 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5863 digit_value
= char_decimal_value (c
);
5864 /* This check catches non-decimals in addition to out-of-range
5866 if (digit_value
>= radix
)
5871 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5873 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5875 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5882 shift
= shift
* radix
;
5883 add
= add
* radix
+ digit_value
;
5888 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5890 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5894 *p_exactness
= INEXACT
;
5900 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5901 * covers the parts of the rules that start at a potential point. The value
5902 * of the digits up to the point have been parsed by the caller and are given
5903 * in variable result. The content of *p_exactness indicates, whether a hash
5904 * has already been seen in the digits before the point.
5907 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5910 mem2decimal_from_point (SCM result
, SCM mem
,
5911 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5913 unsigned int idx
= *p_idx
;
5914 enum t_exactness x
= *p_exactness
;
5915 size_t len
= scm_i_string_length (mem
);
5920 if (scm_i_string_ref (mem
, idx
) == '.')
5922 scm_t_bits shift
= 1;
5924 unsigned int digit_value
;
5925 SCM big_shift
= SCM_INUM1
;
5930 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5931 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5936 digit_value
= DIGIT2UINT (c
);
5947 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5949 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5950 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5952 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5960 add
= add
* 10 + digit_value
;
5966 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5967 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5968 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5971 result
= scm_divide (result
, big_shift
);
5973 /* We've seen a decimal point, thus the value is implicitly inexact. */
5985 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5987 switch (scm_i_string_ref (mem
, idx
))
5999 c
= scm_i_string_ref (mem
, idx
);
6007 c
= scm_i_string_ref (mem
, idx
);
6016 c
= scm_i_string_ref (mem
, idx
);
6021 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6025 exponent
= DIGIT2UINT (c
);
6028 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6029 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6032 if (exponent
<= SCM_MAXEXP
)
6033 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6039 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6041 size_t exp_len
= idx
- start
;
6042 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6043 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6044 scm_out_of_range ("string->number", exp_num
);
6047 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6049 result
= scm_product (result
, e
);
6051 result
= scm_divide (result
, e
);
6053 /* We've seen an exponent, thus the value is implicitly inexact. */
6071 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6074 mem2ureal (SCM mem
, unsigned int *p_idx
,
6075 unsigned int radix
, enum t_exactness forced_x
,
6076 int allow_inf_or_nan
)
6078 unsigned int idx
= *p_idx
;
6080 size_t len
= scm_i_string_length (mem
);
6082 /* Start off believing that the number will be exact. This changes
6083 to INEXACT if we see a decimal point or a hash. */
6084 enum t_exactness implicit_x
= EXACT
;
6089 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6090 switch (scm_i_string_ref (mem
, idx
))
6093 switch (scm_i_string_ref (mem
, idx
+ 1))
6096 switch (scm_i_string_ref (mem
, idx
+ 2))
6099 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6100 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6108 switch (scm_i_string_ref (mem
, idx
+ 1))
6111 switch (scm_i_string_ref (mem
, idx
+ 2))
6114 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6116 /* Cobble up the fractional part. We might want to
6117 set the NaN's mantissa from it. */
6119 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6122 #if SCM_ENABLE_DEPRECATED == 1
6123 scm_c_issue_deprecation_warning
6124 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6137 if (scm_i_string_ref (mem
, idx
) == '.')
6141 else if (idx
+ 1 == len
)
6143 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6146 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6147 p_idx
, &implicit_x
);
6153 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6154 if (scm_is_false (uinteger
))
6159 else if (scm_i_string_ref (mem
, idx
) == '/')
6167 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6168 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6171 /* both are int/big here, I assume */
6172 result
= scm_i_make_ratio (uinteger
, divisor
);
6174 else if (radix
== 10)
6176 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6177 if (scm_is_false (result
))
6189 if (SCM_INEXACTP (result
))
6190 return scm_inexact_to_exact (result
);
6194 if (SCM_INEXACTP (result
))
6197 return scm_exact_to_inexact (result
);
6199 if (implicit_x
== INEXACT
)
6201 if (SCM_INEXACTP (result
))
6204 return scm_exact_to_inexact (result
);
6210 /* We should never get here */
6215 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6218 mem2complex (SCM mem
, unsigned int idx
,
6219 unsigned int radix
, enum t_exactness forced_x
)
6224 size_t len
= scm_i_string_length (mem
);
6229 c
= scm_i_string_ref (mem
, idx
);
6244 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6245 if (scm_is_false (ureal
))
6247 /* input must be either +i or -i */
6252 if (scm_i_string_ref (mem
, idx
) == 'i'
6253 || scm_i_string_ref (mem
, idx
) == 'I')
6259 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6266 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6267 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6272 c
= scm_i_string_ref (mem
, idx
);
6276 /* either +<ureal>i or -<ureal>i */
6283 return scm_make_rectangular (SCM_INUM0
, ureal
);
6286 /* polar input: <real>@<real>. */
6297 c
= scm_i_string_ref (mem
, idx
);
6315 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6316 if (scm_is_false (angle
))
6321 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6322 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6324 result
= scm_make_polar (ureal
, angle
);
6329 /* expecting input matching <real>[+-]<ureal>?i */
6336 int sign
= (c
== '+') ? 1 : -1;
6337 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6339 if (scm_is_false (imag
))
6340 imag
= SCM_I_MAKINUM (sign
);
6341 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6342 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6346 if (scm_i_string_ref (mem
, idx
) != 'i'
6347 && scm_i_string_ref (mem
, idx
) != 'I')
6354 return scm_make_rectangular (ureal
, imag
);
6363 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6365 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6368 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6370 unsigned int idx
= 0;
6371 unsigned int radix
= NO_RADIX
;
6372 enum t_exactness forced_x
= NO_EXACTNESS
;
6373 size_t len
= scm_i_string_length (mem
);
6375 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6376 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6378 switch (scm_i_string_ref (mem
, idx
+ 1))
6381 if (radix
!= NO_RADIX
)
6386 if (radix
!= NO_RADIX
)
6391 if (forced_x
!= NO_EXACTNESS
)
6396 if (forced_x
!= NO_EXACTNESS
)
6401 if (radix
!= NO_RADIX
)
6406 if (radix
!= NO_RADIX
)
6416 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6417 if (radix
== NO_RADIX
)
6418 radix
= default_radix
;
6420 return mem2complex (mem
, idx
, radix
, forced_x
);
6424 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6425 unsigned int default_radix
)
6427 SCM str
= scm_from_locale_stringn (mem
, len
);
6429 return scm_i_string_to_number (str
, default_radix
);
6433 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6434 (SCM string
, SCM radix
),
6435 "Return a number of the maximally precise representation\n"
6436 "expressed by the given @var{string}. @var{radix} must be an\n"
6437 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6438 "is a default radix that may be overridden by an explicit radix\n"
6439 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6440 "supplied, then the default radix is 10. If string is not a\n"
6441 "syntactically valid notation for a number, then\n"
6442 "@code{string->number} returns @code{#f}.")
6443 #define FUNC_NAME s_scm_string_to_number
6447 SCM_VALIDATE_STRING (1, string
);
6449 if (SCM_UNBNDP (radix
))
6452 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6454 answer
= scm_i_string_to_number (string
, base
);
6455 scm_remember_upto_here_1 (string
);
6461 /*** END strs->nums ***/
6464 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6466 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6468 #define FUNC_NAME s_scm_number_p
6470 return scm_from_bool (SCM_NUMBERP (x
));
6474 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6476 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6477 "otherwise. Note that the sets of real, rational and integer\n"
6478 "values form subsets of the set of complex numbers, i. e. the\n"
6479 "predicate will also be fulfilled if @var{x} is a real,\n"
6480 "rational or integer number.")
6481 #define FUNC_NAME s_scm_complex_p
6483 /* all numbers are complex. */
6484 return scm_number_p (x
);
6488 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6490 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6491 "otherwise. Note that the set of integer values forms a subset of\n"
6492 "the set of real numbers, i. e. the predicate will also be\n"
6493 "fulfilled if @var{x} is an integer number.")
6494 #define FUNC_NAME s_scm_real_p
6496 return scm_from_bool
6497 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6501 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6503 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6504 "otherwise. Note that the set of integer values forms a subset of\n"
6505 "the set of rational numbers, i. e. the predicate will also be\n"
6506 "fulfilled if @var{x} is an integer number.")
6507 #define FUNC_NAME s_scm_rational_p
6509 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6511 else if (SCM_REALP (x
))
6512 /* due to their limited precision, finite floating point numbers are
6513 rational as well. (finite means neither infinity nor a NaN) */
6514 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6520 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6522 "Return @code{#t} if @var{x} is an integer number,\n"
6523 "else return @code{#f}.")
6524 #define FUNC_NAME s_scm_integer_p
6526 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6528 else if (SCM_REALP (x
))
6530 double val
= SCM_REAL_VALUE (x
);
6531 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6538 SCM_DEFINE (scm_exact_integer_p
, "exact-integer?", 1, 0, 0,
6540 "Return @code{#t} if @var{x} is an exact integer number,\n"
6541 "else return @code{#f}.")
6542 #define FUNC_NAME s_scm_exact_integer_p
6544 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6552 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6553 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6554 (SCM x
, SCM y
, SCM rest
),
6555 "Return @code{#t} if all parameters are numerically equal.")
6556 #define FUNC_NAME s_scm_i_num_eq_p
6558 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6560 while (!scm_is_null (rest
))
6562 if (scm_is_false (scm_num_eq_p (x
, y
)))
6566 rest
= scm_cdr (rest
);
6568 return scm_num_eq_p (x
, y
);
6572 scm_num_eq_p (SCM x
, SCM y
)
6575 if (SCM_I_INUMP (x
))
6577 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6578 if (SCM_I_INUMP (y
))
6580 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6581 return scm_from_bool (xx
== yy
);
6583 else if (SCM_BIGP (y
))
6585 else if (SCM_REALP (y
))
6587 /* On a 32-bit system an inum fits a double, we can cast the inum
6588 to a double and compare.
6590 But on a 64-bit system an inum is bigger than a double and
6591 casting it to a double (call that dxx) will round.
6592 Although dxx will not in general be equal to xx, dxx will
6593 always be an integer and within a factor of 2 of xx, so if
6594 dxx==yy, we know that yy is an integer and fits in
6595 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6596 compare with plain xx.
6598 An alternative (for any size system actually) would be to check
6599 yy is an integer (with floor) and is in range of an inum
6600 (compare against appropriate powers of 2) then test
6601 xx==(scm_t_signed_bits)yy. It's just a matter of which
6602 casts/comparisons might be fastest or easiest for the cpu. */
6604 double yy
= SCM_REAL_VALUE (y
);
6605 return scm_from_bool ((double) xx
== yy
6606 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6607 || xx
== (scm_t_signed_bits
) yy
));
6609 else if (SCM_COMPLEXP (y
))
6611 /* see comments with inum/real above */
6612 double ry
= SCM_COMPLEX_REAL (y
);
6613 return scm_from_bool ((double) xx
== ry
6614 && 0.0 == SCM_COMPLEX_IMAG (y
)
6615 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6616 || xx
== (scm_t_signed_bits
) ry
));
6618 else if (SCM_FRACTIONP (y
))
6621 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6624 else if (SCM_BIGP (x
))
6626 if (SCM_I_INUMP (y
))
6628 else if (SCM_BIGP (y
))
6630 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6631 scm_remember_upto_here_2 (x
, y
);
6632 return scm_from_bool (0 == cmp
);
6634 else if (SCM_REALP (y
))
6637 if (isnan (SCM_REAL_VALUE (y
)))
6639 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6640 scm_remember_upto_here_1 (x
);
6641 return scm_from_bool (0 == cmp
);
6643 else if (SCM_COMPLEXP (y
))
6646 if (0.0 != SCM_COMPLEX_IMAG (y
))
6648 if (isnan (SCM_COMPLEX_REAL (y
)))
6650 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6651 scm_remember_upto_here_1 (x
);
6652 return scm_from_bool (0 == cmp
);
6654 else if (SCM_FRACTIONP (y
))
6657 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6660 else if (SCM_REALP (x
))
6662 double xx
= SCM_REAL_VALUE (x
);
6663 if (SCM_I_INUMP (y
))
6665 /* see comments with inum/real above */
6666 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6667 return scm_from_bool (xx
== (double) yy
6668 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6669 || (scm_t_signed_bits
) xx
== yy
));
6671 else if (SCM_BIGP (y
))
6676 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6677 scm_remember_upto_here_1 (y
);
6678 return scm_from_bool (0 == cmp
);
6680 else if (SCM_REALP (y
))
6681 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6682 else if (SCM_COMPLEXP (y
))
6683 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6684 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6685 else if (SCM_FRACTIONP (y
))
6687 if (isnan (xx
) || isinf (xx
))
6689 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6693 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6696 else if (SCM_COMPLEXP (x
))
6698 if (SCM_I_INUMP (y
))
6700 /* see comments with inum/real above */
6701 double rx
= SCM_COMPLEX_REAL (x
);
6702 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6703 return scm_from_bool (rx
== (double) yy
6704 && 0.0 == SCM_COMPLEX_IMAG (x
)
6705 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6706 || (scm_t_signed_bits
) rx
== yy
));
6708 else if (SCM_BIGP (y
))
6711 if (0.0 != SCM_COMPLEX_IMAG (x
))
6713 if (isnan (SCM_COMPLEX_REAL (x
)))
6715 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6716 scm_remember_upto_here_1 (y
);
6717 return scm_from_bool (0 == cmp
);
6719 else if (SCM_REALP (y
))
6720 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6721 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6722 else if (SCM_COMPLEXP (y
))
6723 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6724 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6725 else if (SCM_FRACTIONP (y
))
6728 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6730 xx
= SCM_COMPLEX_REAL (x
);
6731 if (isnan (xx
) || isinf (xx
))
6733 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6737 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6740 else if (SCM_FRACTIONP (x
))
6742 if (SCM_I_INUMP (y
))
6744 else if (SCM_BIGP (y
))
6746 else if (SCM_REALP (y
))
6748 double yy
= SCM_REAL_VALUE (y
);
6749 if (isnan (yy
) || isinf (yy
))
6751 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6754 else if (SCM_COMPLEXP (y
))
6757 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6759 yy
= SCM_COMPLEX_REAL (y
);
6760 if (isnan (yy
) || isinf(yy
))
6762 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6765 else if (SCM_FRACTIONP (y
))
6766 return scm_i_fraction_equalp (x
, y
);
6768 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6772 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6777 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6778 done are good for inums, but for bignums an answer can almost always be
6779 had by just examining a few high bits of the operands, as done by GMP in
6780 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6781 of the float exponent to take into account. */
6783 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6784 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6785 (SCM x
, SCM y
, SCM rest
),
6786 "Return @code{#t} if the list of parameters is monotonically\n"
6788 #define FUNC_NAME s_scm_i_num_less_p
6790 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6792 while (!scm_is_null (rest
))
6794 if (scm_is_false (scm_less_p (x
, y
)))
6798 rest
= scm_cdr (rest
);
6800 return scm_less_p (x
, y
);
6804 scm_less_p (SCM x
, SCM y
)
6807 if (SCM_I_INUMP (x
))
6809 scm_t_inum xx
= SCM_I_INUM (x
);
6810 if (SCM_I_INUMP (y
))
6812 scm_t_inum yy
= SCM_I_INUM (y
);
6813 return scm_from_bool (xx
< yy
);
6815 else if (SCM_BIGP (y
))
6817 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6818 scm_remember_upto_here_1 (y
);
6819 return scm_from_bool (sgn
> 0);
6821 else if (SCM_REALP (y
))
6823 /* We can safely take the ceiling of y without changing the
6824 result of x<y, given that x is an integer. */
6825 double yy
= ceil (SCM_REAL_VALUE (y
));
6827 /* In the following comparisons, it's important that the right
6828 hand side always be a power of 2, so that it can be
6829 losslessly converted to a double even on 64-bit
6831 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6833 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6834 /* The condition above is carefully written to include the
6835 case where yy==NaN. */
6838 /* yy is a finite integer that fits in an inum. */
6839 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6841 else if (SCM_FRACTIONP (y
))
6843 /* "x < a/b" becomes "x*b < a" */
6845 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6846 y
= SCM_FRACTION_NUMERATOR (y
);
6850 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6851 s_scm_i_num_less_p
);
6853 else if (SCM_BIGP (x
))
6855 if (SCM_I_INUMP (y
))
6857 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6858 scm_remember_upto_here_1 (x
);
6859 return scm_from_bool (sgn
< 0);
6861 else if (SCM_BIGP (y
))
6863 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6864 scm_remember_upto_here_2 (x
, y
);
6865 return scm_from_bool (cmp
< 0);
6867 else if (SCM_REALP (y
))
6870 if (isnan (SCM_REAL_VALUE (y
)))
6872 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6873 scm_remember_upto_here_1 (x
);
6874 return scm_from_bool (cmp
< 0);
6876 else if (SCM_FRACTIONP (y
))
6879 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6880 s_scm_i_num_less_p
);
6882 else if (SCM_REALP (x
))
6884 if (SCM_I_INUMP (y
))
6886 /* We can safely take the floor of x without changing the
6887 result of x<y, given that y is an integer. */
6888 double xx
= floor (SCM_REAL_VALUE (x
));
6890 /* In the following comparisons, it's important that the right
6891 hand side always be a power of 2, so that it can be
6892 losslessly converted to a double even on 64-bit
6894 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6896 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6897 /* The condition above is carefully written to include the
6898 case where xx==NaN. */
6901 /* xx is a finite integer that fits in an inum. */
6902 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6904 else if (SCM_BIGP (y
))
6907 if (isnan (SCM_REAL_VALUE (x
)))
6909 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6910 scm_remember_upto_here_1 (y
);
6911 return scm_from_bool (cmp
> 0);
6913 else if (SCM_REALP (y
))
6914 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6915 else if (SCM_FRACTIONP (y
))
6917 double xx
= SCM_REAL_VALUE (x
);
6921 return scm_from_bool (xx
< 0.0);
6922 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6926 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6927 s_scm_i_num_less_p
);
6929 else if (SCM_FRACTIONP (x
))
6931 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6933 /* "a/b < y" becomes "a < y*b" */
6934 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6935 x
= SCM_FRACTION_NUMERATOR (x
);
6938 else if (SCM_REALP (y
))
6940 double yy
= SCM_REAL_VALUE (y
);
6944 return scm_from_bool (0.0 < yy
);
6945 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6948 else if (SCM_FRACTIONP (y
))
6950 /* "a/b < c/d" becomes "a*d < c*b" */
6951 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6952 SCM_FRACTION_DENOMINATOR (y
));
6953 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6954 SCM_FRACTION_DENOMINATOR (x
));
6960 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6961 s_scm_i_num_less_p
);
6964 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6965 s_scm_i_num_less_p
);
6969 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6970 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6971 (SCM x
, SCM y
, SCM rest
),
6972 "Return @code{#t} if the list of parameters is monotonically\n"
6974 #define FUNC_NAME s_scm_i_num_gr_p
6976 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6978 while (!scm_is_null (rest
))
6980 if (scm_is_false (scm_gr_p (x
, y
)))
6984 rest
= scm_cdr (rest
);
6986 return scm_gr_p (x
, y
);
6989 #define FUNC_NAME s_scm_i_num_gr_p
6991 scm_gr_p (SCM x
, SCM y
)
6993 if (!SCM_NUMBERP (x
))
6994 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6995 else if (!SCM_NUMBERP (y
))
6996 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6998 return scm_less_p (y
, x
);
7003 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
7004 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
7005 (SCM x
, SCM y
, SCM rest
),
7006 "Return @code{#t} if the list of parameters is monotonically\n"
7008 #define FUNC_NAME s_scm_i_num_leq_p
7010 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7012 while (!scm_is_null (rest
))
7014 if (scm_is_false (scm_leq_p (x
, y
)))
7018 rest
= scm_cdr (rest
);
7020 return scm_leq_p (x
, y
);
7023 #define FUNC_NAME s_scm_i_num_leq_p
7025 scm_leq_p (SCM x
, SCM y
)
7027 if (!SCM_NUMBERP (x
))
7028 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7029 else if (!SCM_NUMBERP (y
))
7030 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7031 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7034 return scm_not (scm_less_p (y
, x
));
7039 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7040 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7041 (SCM x
, SCM y
, SCM rest
),
7042 "Return @code{#t} if the list of parameters is monotonically\n"
7044 #define FUNC_NAME s_scm_i_num_geq_p
7046 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7048 while (!scm_is_null (rest
))
7050 if (scm_is_false (scm_geq_p (x
, y
)))
7054 rest
= scm_cdr (rest
);
7056 return scm_geq_p (x
, y
);
7059 #define FUNC_NAME s_scm_i_num_geq_p
7061 scm_geq_p (SCM x
, SCM y
)
7063 if (!SCM_NUMBERP (x
))
7064 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7065 else if (!SCM_NUMBERP (y
))
7066 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7067 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7070 return scm_not (scm_less_p (x
, y
));
7075 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7077 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7079 #define FUNC_NAME s_scm_zero_p
7081 if (SCM_I_INUMP (z
))
7082 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7083 else if (SCM_BIGP (z
))
7085 else if (SCM_REALP (z
))
7086 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7087 else if (SCM_COMPLEXP (z
))
7088 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7089 && SCM_COMPLEX_IMAG (z
) == 0.0);
7090 else if (SCM_FRACTIONP (z
))
7093 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7098 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7100 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7102 #define FUNC_NAME s_scm_positive_p
7104 if (SCM_I_INUMP (x
))
7105 return scm_from_bool (SCM_I_INUM (x
) > 0);
7106 else if (SCM_BIGP (x
))
7108 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7109 scm_remember_upto_here_1 (x
);
7110 return scm_from_bool (sgn
> 0);
7112 else if (SCM_REALP (x
))
7113 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7114 else if (SCM_FRACTIONP (x
))
7115 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7117 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7122 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7124 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7126 #define FUNC_NAME s_scm_negative_p
7128 if (SCM_I_INUMP (x
))
7129 return scm_from_bool (SCM_I_INUM (x
) < 0);
7130 else if (SCM_BIGP (x
))
7132 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7133 scm_remember_upto_here_1 (x
);
7134 return scm_from_bool (sgn
< 0);
7136 else if (SCM_REALP (x
))
7137 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7138 else if (SCM_FRACTIONP (x
))
7139 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7141 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7146 /* scm_min and scm_max return an inexact when either argument is inexact, as
7147 required by r5rs. On that basis, for exact/inexact combinations the
7148 exact is converted to inexact to compare and possibly return. This is
7149 unlike scm_less_p above which takes some trouble to preserve all bits in
7150 its test, such trouble is not required for min and max. */
7152 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7153 (SCM x
, SCM y
, SCM rest
),
7154 "Return the maximum of all parameter values.")
7155 #define FUNC_NAME s_scm_i_max
7157 while (!scm_is_null (rest
))
7158 { x
= scm_max (x
, y
);
7160 rest
= scm_cdr (rest
);
7162 return scm_max (x
, y
);
7166 #define s_max s_scm_i_max
7167 #define g_max g_scm_i_max
7170 scm_max (SCM x
, SCM y
)
7175 return scm_wta_dispatch_0 (g_max
, s_max
);
7176 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7179 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7182 if (SCM_I_INUMP (x
))
7184 scm_t_inum xx
= SCM_I_INUM (x
);
7185 if (SCM_I_INUMP (y
))
7187 scm_t_inum yy
= SCM_I_INUM (y
);
7188 return (xx
< yy
) ? y
: x
;
7190 else if (SCM_BIGP (y
))
7192 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7193 scm_remember_upto_here_1 (y
);
7194 return (sgn
< 0) ? x
: y
;
7196 else if (SCM_REALP (y
))
7199 double yyd
= SCM_REAL_VALUE (y
);
7202 return scm_i_from_double (xxd
);
7203 /* If y is a NaN, then "==" is false and we return the NaN */
7204 else if (SCM_LIKELY (!(xxd
== yyd
)))
7206 /* Handle signed zeroes properly */
7212 else if (SCM_FRACTIONP (y
))
7215 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7218 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7220 else if (SCM_BIGP (x
))
7222 if (SCM_I_INUMP (y
))
7224 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7225 scm_remember_upto_here_1 (x
);
7226 return (sgn
< 0) ? y
: x
;
7228 else if (SCM_BIGP (y
))
7230 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7231 scm_remember_upto_here_2 (x
, y
);
7232 return (cmp
> 0) ? x
: y
;
7234 else if (SCM_REALP (y
))
7236 /* if y==NaN then xx>yy is false, so we return the NaN y */
7239 xx
= scm_i_big2dbl (x
);
7240 yy
= SCM_REAL_VALUE (y
);
7241 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7243 else if (SCM_FRACTIONP (y
))
7248 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7250 else if (SCM_REALP (x
))
7252 if (SCM_I_INUMP (y
))
7254 scm_t_inum yy
= SCM_I_INUM (y
);
7255 double xxd
= SCM_REAL_VALUE (x
);
7259 return scm_i_from_double (yyd
);
7260 /* If x is a NaN, then "==" is false and we return the NaN */
7261 else if (SCM_LIKELY (!(xxd
== yyd
)))
7263 /* Handle signed zeroes properly */
7269 else if (SCM_BIGP (y
))
7274 else if (SCM_REALP (y
))
7276 double xx
= SCM_REAL_VALUE (x
);
7277 double yy
= SCM_REAL_VALUE (y
);
7279 /* For purposes of max: nan > +inf.0 > everything else,
7280 per the R6RS errata */
7283 else if (SCM_LIKELY (xx
< yy
))
7285 /* If neither (xx > yy) nor (xx < yy), then
7286 either they're equal or one is a NaN */
7287 else if (SCM_UNLIKELY (xx
!= yy
))
7288 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7289 /* xx == yy, but handle signed zeroes properly */
7290 else if (copysign (1.0, yy
) < 0.0)
7295 else if (SCM_FRACTIONP (y
))
7297 double yy
= scm_i_fraction2double (y
);
7298 double xx
= SCM_REAL_VALUE (x
);
7299 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7302 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7304 else if (SCM_FRACTIONP (x
))
7306 if (SCM_I_INUMP (y
))
7310 else if (SCM_BIGP (y
))
7314 else if (SCM_REALP (y
))
7316 double xx
= scm_i_fraction2double (x
);
7317 /* if y==NaN then ">" is false, so we return the NaN y */
7318 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7320 else if (SCM_FRACTIONP (y
))
7325 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7328 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7332 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7333 (SCM x
, SCM y
, SCM rest
),
7334 "Return the minimum of all parameter values.")
7335 #define FUNC_NAME s_scm_i_min
7337 while (!scm_is_null (rest
))
7338 { x
= scm_min (x
, y
);
7340 rest
= scm_cdr (rest
);
7342 return scm_min (x
, y
);
7346 #define s_min s_scm_i_min
7347 #define g_min g_scm_i_min
7350 scm_min (SCM x
, SCM y
)
7355 return scm_wta_dispatch_0 (g_min
, s_min
);
7356 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7359 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7362 if (SCM_I_INUMP (x
))
7364 scm_t_inum xx
= SCM_I_INUM (x
);
7365 if (SCM_I_INUMP (y
))
7367 scm_t_inum yy
= SCM_I_INUM (y
);
7368 return (xx
< yy
) ? x
: y
;
7370 else if (SCM_BIGP (y
))
7372 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7373 scm_remember_upto_here_1 (y
);
7374 return (sgn
< 0) ? y
: x
;
7376 else if (SCM_REALP (y
))
7379 /* if y==NaN then "<" is false and we return NaN */
7380 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7382 else if (SCM_FRACTIONP (y
))
7385 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7388 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7390 else if (SCM_BIGP (x
))
7392 if (SCM_I_INUMP (y
))
7394 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7395 scm_remember_upto_here_1 (x
);
7396 return (sgn
< 0) ? x
: y
;
7398 else if (SCM_BIGP (y
))
7400 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7401 scm_remember_upto_here_2 (x
, y
);
7402 return (cmp
> 0) ? y
: x
;
7404 else if (SCM_REALP (y
))
7406 /* if y==NaN then xx<yy is false, so we return the NaN y */
7409 xx
= scm_i_big2dbl (x
);
7410 yy
= SCM_REAL_VALUE (y
);
7411 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7413 else if (SCM_FRACTIONP (y
))
7418 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7420 else if (SCM_REALP (x
))
7422 if (SCM_I_INUMP (y
))
7424 double z
= SCM_I_INUM (y
);
7425 /* if x==NaN then "<" is false and we return NaN */
7426 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7428 else if (SCM_BIGP (y
))
7433 else if (SCM_REALP (y
))
7435 double xx
= SCM_REAL_VALUE (x
);
7436 double yy
= SCM_REAL_VALUE (y
);
7438 /* For purposes of min: nan < -inf.0 < everything else,
7439 per the R6RS errata */
7442 else if (SCM_LIKELY (xx
> yy
))
7444 /* If neither (xx < yy) nor (xx > yy), then
7445 either they're equal or one is a NaN */
7446 else if (SCM_UNLIKELY (xx
!= yy
))
7447 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7448 /* xx == yy, but handle signed zeroes properly */
7449 else if (copysign (1.0, xx
) < 0.0)
7454 else if (SCM_FRACTIONP (y
))
7456 double yy
= scm_i_fraction2double (y
);
7457 double xx
= SCM_REAL_VALUE (x
);
7458 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7461 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7463 else if (SCM_FRACTIONP (x
))
7465 if (SCM_I_INUMP (y
))
7469 else if (SCM_BIGP (y
))
7473 else if (SCM_REALP (y
))
7475 double xx
= scm_i_fraction2double (x
);
7476 /* if y==NaN then "<" is false, so we return the NaN y */
7477 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7479 else if (SCM_FRACTIONP (y
))
7484 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7487 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7491 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7492 (SCM x
, SCM y
, SCM rest
),
7493 "Return the sum of all parameter values. Return 0 if called without\n"
7495 #define FUNC_NAME s_scm_i_sum
7497 while (!scm_is_null (rest
))
7498 { x
= scm_sum (x
, y
);
7500 rest
= scm_cdr (rest
);
7502 return scm_sum (x
, y
);
7506 #define s_sum s_scm_i_sum
7507 #define g_sum g_scm_i_sum
7510 scm_sum (SCM x
, SCM y
)
7512 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7514 if (SCM_NUMBERP (x
)) return x
;
7515 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7516 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7519 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7521 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7523 scm_t_inum xx
= SCM_I_INUM (x
);
7524 scm_t_inum yy
= SCM_I_INUM (y
);
7525 scm_t_inum z
= xx
+ yy
;
7526 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7528 else if (SCM_BIGP (y
))
7533 else if (SCM_REALP (y
))
7535 scm_t_inum xx
= SCM_I_INUM (x
);
7536 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7538 else if (SCM_COMPLEXP (y
))
7540 scm_t_inum xx
= SCM_I_INUM (x
);
7541 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7542 SCM_COMPLEX_IMAG (y
));
7544 else if (SCM_FRACTIONP (y
))
7545 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7546 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7547 SCM_FRACTION_DENOMINATOR (y
));
7549 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7550 } else if (SCM_BIGP (x
))
7552 if (SCM_I_INUMP (y
))
7557 inum
= SCM_I_INUM (y
);
7560 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7563 SCM result
= scm_i_mkbig ();
7564 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7565 scm_remember_upto_here_1 (x
);
7566 /* we know the result will have to be a bignum */
7569 return scm_i_normbig (result
);
7573 SCM result
= scm_i_mkbig ();
7574 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7575 scm_remember_upto_here_1 (x
);
7576 /* we know the result will have to be a bignum */
7579 return scm_i_normbig (result
);
7582 else if (SCM_BIGP (y
))
7584 SCM result
= scm_i_mkbig ();
7585 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7586 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7587 mpz_add (SCM_I_BIG_MPZ (result
),
7590 scm_remember_upto_here_2 (x
, y
);
7591 /* we know the result will have to be a bignum */
7594 return scm_i_normbig (result
);
7596 else if (SCM_REALP (y
))
7598 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7599 scm_remember_upto_here_1 (x
);
7600 return scm_i_from_double (result
);
7602 else if (SCM_COMPLEXP (y
))
7604 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7605 + SCM_COMPLEX_REAL (y
));
7606 scm_remember_upto_here_1 (x
);
7607 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7609 else if (SCM_FRACTIONP (y
))
7610 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7611 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7612 SCM_FRACTION_DENOMINATOR (y
));
7614 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7616 else if (SCM_REALP (x
))
7618 if (SCM_I_INUMP (y
))
7619 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7620 else if (SCM_BIGP (y
))
7622 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7623 scm_remember_upto_here_1 (y
);
7624 return scm_i_from_double (result
);
7626 else if (SCM_REALP (y
))
7627 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7628 else if (SCM_COMPLEXP (y
))
7629 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7630 SCM_COMPLEX_IMAG (y
));
7631 else if (SCM_FRACTIONP (y
))
7632 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7634 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7636 else if (SCM_COMPLEXP (x
))
7638 if (SCM_I_INUMP (y
))
7639 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7640 SCM_COMPLEX_IMAG (x
));
7641 else if (SCM_BIGP (y
))
7643 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7644 + SCM_COMPLEX_REAL (x
));
7645 scm_remember_upto_here_1 (y
);
7646 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7648 else if (SCM_REALP (y
))
7649 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7650 SCM_COMPLEX_IMAG (x
));
7651 else if (SCM_COMPLEXP (y
))
7652 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7653 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7654 else if (SCM_FRACTIONP (y
))
7655 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7656 SCM_COMPLEX_IMAG (x
));
7658 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7660 else if (SCM_FRACTIONP (x
))
7662 if (SCM_I_INUMP (y
))
7663 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7664 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7665 SCM_FRACTION_DENOMINATOR (x
));
7666 else if (SCM_BIGP (y
))
7667 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7668 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7669 SCM_FRACTION_DENOMINATOR (x
));
7670 else if (SCM_REALP (y
))
7671 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7672 else if (SCM_COMPLEXP (y
))
7673 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7674 SCM_COMPLEX_IMAG (y
));
7675 else if (SCM_FRACTIONP (y
))
7676 /* a/b + c/d = (ad + bc) / bd */
7677 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7678 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7679 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7681 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7684 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7688 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7690 "Return @math{@var{x}+1}.")
7691 #define FUNC_NAME s_scm_oneplus
7693 return scm_sum (x
, SCM_INUM1
);
7698 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7699 (SCM x
, SCM y
, SCM rest
),
7700 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7701 "the sum of all but the first argument are subtracted from the first\n"
7703 #define FUNC_NAME s_scm_i_difference
7705 while (!scm_is_null (rest
))
7706 { x
= scm_difference (x
, y
);
7708 rest
= scm_cdr (rest
);
7710 return scm_difference (x
, y
);
7714 #define s_difference s_scm_i_difference
7715 #define g_difference g_scm_i_difference
7718 scm_difference (SCM x
, SCM y
)
7719 #define FUNC_NAME s_difference
7721 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7724 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7726 if (SCM_I_INUMP (x
))
7728 scm_t_inum xx
= -SCM_I_INUM (x
);
7729 if (SCM_FIXABLE (xx
))
7730 return SCM_I_MAKINUM (xx
);
7732 return scm_i_inum2big (xx
);
7734 else if (SCM_BIGP (x
))
7735 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7736 bignum, but negating that gives a fixnum. */
7737 return scm_i_normbig (scm_i_clonebig (x
, 0));
7738 else if (SCM_REALP (x
))
7739 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7740 else if (SCM_COMPLEXP (x
))
7741 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7742 -SCM_COMPLEX_IMAG (x
));
7743 else if (SCM_FRACTIONP (x
))
7744 return scm_i_make_ratio_already_reduced
7745 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7746 SCM_FRACTION_DENOMINATOR (x
));
7748 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7751 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7753 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7755 scm_t_inum xx
= SCM_I_INUM (x
);
7756 scm_t_inum yy
= SCM_I_INUM (y
);
7757 scm_t_inum z
= xx
- yy
;
7758 if (SCM_FIXABLE (z
))
7759 return SCM_I_MAKINUM (z
);
7761 return scm_i_inum2big (z
);
7763 else if (SCM_BIGP (y
))
7765 /* inum-x - big-y */
7766 scm_t_inum xx
= SCM_I_INUM (x
);
7770 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7771 bignum, but negating that gives a fixnum. */
7772 return scm_i_normbig (scm_i_clonebig (y
, 0));
7776 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7777 SCM result
= scm_i_mkbig ();
7780 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7783 /* x - y == -(y + -x) */
7784 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7785 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7787 scm_remember_upto_here_1 (y
);
7789 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7790 /* we know the result will have to be a bignum */
7793 return scm_i_normbig (result
);
7796 else if (SCM_REALP (y
))
7798 scm_t_inum xx
= SCM_I_INUM (x
);
7801 * We need to handle x == exact 0
7802 * specially because R6RS states that:
7803 * (- 0.0) ==> -0.0 and
7804 * (- 0.0 0.0) ==> 0.0
7805 * and the scheme compiler changes
7806 * (- 0.0) into (- 0 0.0)
7807 * So we need to treat (- 0 0.0) like (- 0.0).
7808 * At the C level, (-x) is different than (0.0 - x).
7809 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7812 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7814 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7816 else if (SCM_COMPLEXP (y
))
7818 scm_t_inum xx
= SCM_I_INUM (x
);
7820 /* We need to handle x == exact 0 specially.
7821 See the comment above (for SCM_REALP (y)) */
7823 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7824 - SCM_COMPLEX_IMAG (y
));
7826 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7827 - SCM_COMPLEX_IMAG (y
));
7829 else if (SCM_FRACTIONP (y
))
7830 /* a - b/c = (ac - b) / c */
7831 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7832 SCM_FRACTION_NUMERATOR (y
)),
7833 SCM_FRACTION_DENOMINATOR (y
));
7835 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7837 else if (SCM_BIGP (x
))
7839 if (SCM_I_INUMP (y
))
7841 /* big-x - inum-y */
7842 scm_t_inum yy
= SCM_I_INUM (y
);
7843 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7845 scm_remember_upto_here_1 (x
);
7847 return (SCM_FIXABLE (-yy
) ?
7848 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7851 SCM result
= scm_i_mkbig ();
7854 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7856 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7857 scm_remember_upto_here_1 (x
);
7859 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7860 /* we know the result will have to be a bignum */
7863 return scm_i_normbig (result
);
7866 else if (SCM_BIGP (y
))
7868 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7869 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7870 SCM result
= scm_i_mkbig ();
7871 mpz_sub (SCM_I_BIG_MPZ (result
),
7874 scm_remember_upto_here_2 (x
, y
);
7875 /* we know the result will have to be a bignum */
7876 if ((sgn_x
== 1) && (sgn_y
== -1))
7878 if ((sgn_x
== -1) && (sgn_y
== 1))
7880 return scm_i_normbig (result
);
7882 else if (SCM_REALP (y
))
7884 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7885 scm_remember_upto_here_1 (x
);
7886 return scm_i_from_double (result
);
7888 else if (SCM_COMPLEXP (y
))
7890 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7891 - SCM_COMPLEX_REAL (y
));
7892 scm_remember_upto_here_1 (x
);
7893 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7895 else if (SCM_FRACTIONP (y
))
7896 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7897 SCM_FRACTION_NUMERATOR (y
)),
7898 SCM_FRACTION_DENOMINATOR (y
));
7900 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7902 else if (SCM_REALP (x
))
7904 if (SCM_I_INUMP (y
))
7905 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7906 else if (SCM_BIGP (y
))
7908 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7909 scm_remember_upto_here_1 (x
);
7910 return scm_i_from_double (result
);
7912 else if (SCM_REALP (y
))
7913 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7914 else if (SCM_COMPLEXP (y
))
7915 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7916 -SCM_COMPLEX_IMAG (y
));
7917 else if (SCM_FRACTIONP (y
))
7918 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7920 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7922 else if (SCM_COMPLEXP (x
))
7924 if (SCM_I_INUMP (y
))
7925 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7926 SCM_COMPLEX_IMAG (x
));
7927 else if (SCM_BIGP (y
))
7929 double real_part
= (SCM_COMPLEX_REAL (x
)
7930 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7931 scm_remember_upto_here_1 (x
);
7932 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7934 else if (SCM_REALP (y
))
7935 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7936 SCM_COMPLEX_IMAG (x
));
7937 else if (SCM_COMPLEXP (y
))
7938 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7939 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7940 else if (SCM_FRACTIONP (y
))
7941 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7942 SCM_COMPLEX_IMAG (x
));
7944 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7946 else if (SCM_FRACTIONP (x
))
7948 if (SCM_I_INUMP (y
))
7949 /* a/b - c = (a - cb) / b */
7950 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7951 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7952 SCM_FRACTION_DENOMINATOR (x
));
7953 else if (SCM_BIGP (y
))
7954 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7955 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7956 SCM_FRACTION_DENOMINATOR (x
));
7957 else if (SCM_REALP (y
))
7958 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7959 else if (SCM_COMPLEXP (y
))
7960 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7961 -SCM_COMPLEX_IMAG (y
));
7962 else if (SCM_FRACTIONP (y
))
7963 /* a/b - c/d = (ad - bc) / bd */
7964 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7965 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7966 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7968 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7971 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7976 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7978 "Return @math{@var{x}-1}.")
7979 #define FUNC_NAME s_scm_oneminus
7981 return scm_difference (x
, SCM_INUM1
);
7986 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7987 (SCM x
, SCM y
, SCM rest
),
7988 "Return the product of all arguments. If called without arguments,\n"
7990 #define FUNC_NAME s_scm_i_product
7992 while (!scm_is_null (rest
))
7993 { x
= scm_product (x
, y
);
7995 rest
= scm_cdr (rest
);
7997 return scm_product (x
, y
);
8001 #define s_product s_scm_i_product
8002 #define g_product g_scm_i_product
8005 scm_product (SCM x
, SCM y
)
8007 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8010 return SCM_I_MAKINUM (1L);
8011 else if (SCM_NUMBERP (x
))
8014 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
8017 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8022 xx
= SCM_I_INUM (x
);
8027 /* exact1 is the universal multiplicative identity */
8031 /* exact0 times a fixnum is exact0: optimize this case */
8032 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8034 /* if the other argument is inexact, the result is inexact,
8035 and we must do the multiplication in order to handle
8036 infinities and NaNs properly. */
8037 else if (SCM_REALP (y
))
8038 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8039 else if (SCM_COMPLEXP (y
))
8040 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8041 0.0 * SCM_COMPLEX_IMAG (y
));
8042 /* we've already handled inexact numbers,
8043 so y must be exact, and we return exact0 */
8044 else if (SCM_NUMP (y
))
8047 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8051 * This case is important for more than just optimization.
8052 * It handles the case of negating
8053 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8054 * which is a bignum that must be changed back into a fixnum.
8055 * Failure to do so will cause the following to return #f:
8056 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8058 return scm_difference(y
, SCM_UNDEFINED
);
8062 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8064 scm_t_inum yy
= SCM_I_INUM (y
);
8065 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8066 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8067 if (SCM_FIXABLE (kk
))
8068 return SCM_I_MAKINUM (kk
);
8070 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8071 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8072 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8073 return SCM_I_MAKINUM (xx
* yy
);
8077 SCM result
= scm_i_inum2big (xx
);
8078 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8079 return scm_i_normbig (result
);
8082 else if (SCM_BIGP (y
))
8084 SCM result
= scm_i_mkbig ();
8085 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8086 scm_remember_upto_here_1 (y
);
8089 else if (SCM_REALP (y
))
8090 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8091 else if (SCM_COMPLEXP (y
))
8092 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8093 xx
* SCM_COMPLEX_IMAG (y
));
8094 else if (SCM_FRACTIONP (y
))
8095 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8096 SCM_FRACTION_DENOMINATOR (y
));
8098 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8100 else if (SCM_BIGP (x
))
8102 if (SCM_I_INUMP (y
))
8107 else if (SCM_BIGP (y
))
8109 SCM result
= scm_i_mkbig ();
8110 mpz_mul (SCM_I_BIG_MPZ (result
),
8113 scm_remember_upto_here_2 (x
, y
);
8116 else if (SCM_REALP (y
))
8118 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8119 scm_remember_upto_here_1 (x
);
8120 return scm_i_from_double (result
);
8122 else if (SCM_COMPLEXP (y
))
8124 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8125 scm_remember_upto_here_1 (x
);
8126 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8127 z
* SCM_COMPLEX_IMAG (y
));
8129 else if (SCM_FRACTIONP (y
))
8130 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8131 SCM_FRACTION_DENOMINATOR (y
));
8133 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8135 else if (SCM_REALP (x
))
8137 if (SCM_I_INUMP (y
))
8142 else if (SCM_BIGP (y
))
8144 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8145 scm_remember_upto_here_1 (y
);
8146 return scm_i_from_double (result
);
8148 else if (SCM_REALP (y
))
8149 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8150 else if (SCM_COMPLEXP (y
))
8151 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8152 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8153 else if (SCM_FRACTIONP (y
))
8154 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8156 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8158 else if (SCM_COMPLEXP (x
))
8160 if (SCM_I_INUMP (y
))
8165 else if (SCM_BIGP (y
))
8167 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8168 scm_remember_upto_here_1 (y
);
8169 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8170 z
* SCM_COMPLEX_IMAG (x
));
8172 else if (SCM_REALP (y
))
8173 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8174 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8175 else if (SCM_COMPLEXP (y
))
8177 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8178 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8179 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8180 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8182 else if (SCM_FRACTIONP (y
))
8184 double yy
= scm_i_fraction2double (y
);
8185 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8186 yy
* SCM_COMPLEX_IMAG (x
));
8189 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8191 else if (SCM_FRACTIONP (x
))
8193 if (SCM_I_INUMP (y
))
8194 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8195 SCM_FRACTION_DENOMINATOR (x
));
8196 else if (SCM_BIGP (y
))
8197 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8198 SCM_FRACTION_DENOMINATOR (x
));
8199 else if (SCM_REALP (y
))
8200 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8201 else if (SCM_COMPLEXP (y
))
8203 double xx
= scm_i_fraction2double (x
);
8204 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8205 xx
* SCM_COMPLEX_IMAG (y
));
8207 else if (SCM_FRACTIONP (y
))
8208 /* a/b * c/d = ac / bd */
8209 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8210 SCM_FRACTION_NUMERATOR (y
)),
8211 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8212 SCM_FRACTION_DENOMINATOR (y
)));
8214 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8217 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8220 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8221 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8222 #define ALLOW_DIVIDE_BY_ZERO
8223 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8226 /* The code below for complex division is adapted from the GNU
8227 libstdc++, which adapted it from f2c's libF77, and is subject to
8230 /****************************************************************
8231 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8233 Permission to use, copy, modify, and distribute this software
8234 and its documentation for any purpose and without fee is hereby
8235 granted, provided that the above copyright notice appear in all
8236 copies and that both that the copyright notice and this
8237 permission notice and warranty disclaimer appear in supporting
8238 documentation, and that the names of AT&T Bell Laboratories or
8239 Bellcore or any of their entities not be used in advertising or
8240 publicity pertaining to distribution of the software without
8241 specific, written prior permission.
8243 AT&T and Bellcore disclaim all warranties with regard to this
8244 software, including all implied warranties of merchantability
8245 and fitness. In no event shall AT&T or Bellcore be liable for
8246 any special, indirect or consequential damages or any damages
8247 whatsoever resulting from loss of use, data or profits, whether
8248 in an action of contract, negligence or other tortious action,
8249 arising out of or in connection with the use or performance of
8251 ****************************************************************/
8253 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8254 (SCM x
, SCM y
, SCM rest
),
8255 "Divide the first argument by the product of the remaining\n"
8256 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8258 #define FUNC_NAME s_scm_i_divide
8260 while (!scm_is_null (rest
))
8261 { x
= scm_divide (x
, y
);
8263 rest
= scm_cdr (rest
);
8265 return scm_divide (x
, y
);
8269 #define s_divide s_scm_i_divide
8270 #define g_divide g_scm_i_divide
8273 scm_divide (SCM x
, SCM y
)
8274 #define FUNC_NAME s_divide
8278 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8281 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8282 else if (SCM_I_INUMP (x
))
8284 scm_t_inum xx
= SCM_I_INUM (x
);
8285 if (xx
== 1 || xx
== -1)
8287 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8289 scm_num_overflow (s_divide
);
8292 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8294 else if (SCM_BIGP (x
))
8295 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8296 else if (SCM_REALP (x
))
8298 double xx
= SCM_REAL_VALUE (x
);
8299 #ifndef ALLOW_DIVIDE_BY_ZERO
8301 scm_num_overflow (s_divide
);
8304 return scm_i_from_double (1.0 / xx
);
8306 else if (SCM_COMPLEXP (x
))
8308 double r
= SCM_COMPLEX_REAL (x
);
8309 double i
= SCM_COMPLEX_IMAG (x
);
8310 if (fabs(r
) <= fabs(i
))
8313 double d
= i
* (1.0 + t
* t
);
8314 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8319 double d
= r
* (1.0 + t
* t
);
8320 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8323 else if (SCM_FRACTIONP (x
))
8324 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8325 SCM_FRACTION_NUMERATOR (x
));
8327 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8330 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8332 scm_t_inum xx
= SCM_I_INUM (x
);
8333 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8335 scm_t_inum yy
= SCM_I_INUM (y
);
8338 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8339 scm_num_overflow (s_divide
);
8341 return scm_i_from_double ((double) xx
/ (double) yy
);
8344 else if (xx
% yy
!= 0)
8345 return scm_i_make_ratio (x
, y
);
8348 scm_t_inum z
= xx
/ yy
;
8349 if (SCM_FIXABLE (z
))
8350 return SCM_I_MAKINUM (z
);
8352 return scm_i_inum2big (z
);
8355 else if (SCM_BIGP (y
))
8356 return scm_i_make_ratio (x
, y
);
8357 else if (SCM_REALP (y
))
8359 double yy
= SCM_REAL_VALUE (y
);
8360 #ifndef ALLOW_DIVIDE_BY_ZERO
8362 scm_num_overflow (s_divide
);
8365 /* FIXME: Precision may be lost here due to:
8366 (1) The cast from 'scm_t_inum' to 'double'
8367 (2) Double rounding */
8368 return scm_i_from_double ((double) xx
/ yy
);
8370 else if (SCM_COMPLEXP (y
))
8373 complex_div
: /* y _must_ be a complex number */
8375 double r
= SCM_COMPLEX_REAL (y
);
8376 double i
= SCM_COMPLEX_IMAG (y
);
8377 if (fabs(r
) <= fabs(i
))
8380 double d
= i
* (1.0 + t
* t
);
8381 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8386 double d
= r
* (1.0 + t
* t
);
8387 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8391 else if (SCM_FRACTIONP (y
))
8392 /* a / b/c = ac / b */
8393 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8394 SCM_FRACTION_NUMERATOR (y
));
8396 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8398 else if (SCM_BIGP (x
))
8400 if (SCM_I_INUMP (y
))
8402 scm_t_inum yy
= SCM_I_INUM (y
);
8405 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8406 scm_num_overflow (s_divide
);
8408 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8409 scm_remember_upto_here_1 (x
);
8410 return (sgn
== 0) ? scm_nan () : scm_inf ();
8417 /* FIXME: HMM, what are the relative performance issues here?
8418 We need to test. Is it faster on average to test
8419 divisible_p, then perform whichever operation, or is it
8420 faster to perform the integer div opportunistically and
8421 switch to real if there's a remainder? For now we take the
8422 middle ground: test, then if divisible, use the faster div
8425 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8426 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8430 SCM result
= scm_i_mkbig ();
8431 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8432 scm_remember_upto_here_1 (x
);
8434 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8435 return scm_i_normbig (result
);
8438 return scm_i_make_ratio (x
, y
);
8441 else if (SCM_BIGP (y
))
8443 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8447 SCM result
= scm_i_mkbig ();
8448 mpz_divexact (SCM_I_BIG_MPZ (result
),
8451 scm_remember_upto_here_2 (x
, y
);
8452 return scm_i_normbig (result
);
8455 return scm_i_make_ratio (x
, y
);
8457 else if (SCM_REALP (y
))
8459 double yy
= SCM_REAL_VALUE (y
);
8460 #ifndef ALLOW_DIVIDE_BY_ZERO
8462 scm_num_overflow (s_divide
);
8465 /* FIXME: Precision may be lost here due to:
8466 (1) scm_i_big2dbl (2) Double rounding */
8467 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8469 else if (SCM_COMPLEXP (y
))
8471 a
= scm_i_big2dbl (x
);
8474 else if (SCM_FRACTIONP (y
))
8475 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8476 SCM_FRACTION_NUMERATOR (y
));
8478 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8480 else if (SCM_REALP (x
))
8482 double rx
= SCM_REAL_VALUE (x
);
8483 if (SCM_I_INUMP (y
))
8485 scm_t_inum yy
= SCM_I_INUM (y
);
8486 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8488 scm_num_overflow (s_divide
);
8491 /* FIXME: Precision may be lost here due to:
8492 (1) The cast from 'scm_t_inum' to 'double'
8493 (2) Double rounding */
8494 return scm_i_from_double (rx
/ (double) yy
);
8496 else if (SCM_BIGP (y
))
8498 /* FIXME: Precision may be lost here due to:
8499 (1) The conversion from bignum to double
8500 (2) Double rounding */
8501 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8502 scm_remember_upto_here_1 (y
);
8503 return scm_i_from_double (rx
/ dby
);
8505 else if (SCM_REALP (y
))
8507 double yy
= SCM_REAL_VALUE (y
);
8508 #ifndef ALLOW_DIVIDE_BY_ZERO
8510 scm_num_overflow (s_divide
);
8513 return scm_i_from_double (rx
/ yy
);
8515 else if (SCM_COMPLEXP (y
))
8520 else if (SCM_FRACTIONP (y
))
8521 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8523 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8525 else if (SCM_COMPLEXP (x
))
8527 double rx
= SCM_COMPLEX_REAL (x
);
8528 double ix
= SCM_COMPLEX_IMAG (x
);
8529 if (SCM_I_INUMP (y
))
8531 scm_t_inum yy
= SCM_I_INUM (y
);
8532 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8534 scm_num_overflow (s_divide
);
8538 /* FIXME: Precision may be lost here due to:
8539 (1) The conversion from 'scm_t_inum' to double
8540 (2) Double rounding */
8542 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8545 else if (SCM_BIGP (y
))
8547 /* FIXME: Precision may be lost here due to:
8548 (1) The conversion from bignum to double
8549 (2) Double rounding */
8550 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8551 scm_remember_upto_here_1 (y
);
8552 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8554 else if (SCM_REALP (y
))
8556 double yy
= SCM_REAL_VALUE (y
);
8557 #ifndef ALLOW_DIVIDE_BY_ZERO
8559 scm_num_overflow (s_divide
);
8562 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8564 else if (SCM_COMPLEXP (y
))
8566 double ry
= SCM_COMPLEX_REAL (y
);
8567 double iy
= SCM_COMPLEX_IMAG (y
);
8568 if (fabs(ry
) <= fabs(iy
))
8571 double d
= iy
* (1.0 + t
* t
);
8572 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8577 double d
= ry
* (1.0 + t
* t
);
8578 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8581 else if (SCM_FRACTIONP (y
))
8583 /* FIXME: Precision may be lost here due to:
8584 (1) The conversion from fraction to double
8585 (2) Double rounding */
8586 double yy
= scm_i_fraction2double (y
);
8587 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8590 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8592 else if (SCM_FRACTIONP (x
))
8594 if (SCM_I_INUMP (y
))
8596 scm_t_inum yy
= SCM_I_INUM (y
);
8597 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8599 scm_num_overflow (s_divide
);
8602 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8603 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8605 else if (SCM_BIGP (y
))
8607 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8608 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8610 else if (SCM_REALP (y
))
8612 double yy
= SCM_REAL_VALUE (y
);
8613 #ifndef ALLOW_DIVIDE_BY_ZERO
8615 scm_num_overflow (s_divide
);
8618 /* FIXME: Precision may be lost here due to:
8619 (1) The conversion from fraction to double
8620 (2) Double rounding */
8621 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8623 else if (SCM_COMPLEXP (y
))
8625 /* FIXME: Precision may be lost here due to:
8626 (1) The conversion from fraction to double
8627 (2) Double rounding */
8628 a
= scm_i_fraction2double (x
);
8631 else if (SCM_FRACTIONP (y
))
8632 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8633 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8635 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8638 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8644 scm_c_truncate (double x
)
8649 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8650 half-way case (ie. when x is an integer plus 0.5) going upwards.
8651 Then half-way cases are identified and adjusted down if the
8652 round-upwards didn't give the desired even integer.
8654 "plus_half == result" identifies a half-way case. If plus_half, which is
8655 x + 0.5, is an integer then x must be an integer plus 0.5.
8657 An odd "result" value is identified with result/2 != floor(result/2).
8658 This is done with plus_half, since that value is ready for use sooner in
8659 a pipelined cpu, and we're already requiring plus_half == result.
8661 Note however that we need to be careful when x is big and already an
8662 integer. In that case "x+0.5" may round to an adjacent integer, causing
8663 us to return such a value, incorrectly. For instance if the hardware is
8664 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8665 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8666 returned. Or if the hardware is in round-upwards mode, then other bigger
8667 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8668 representable value, 2^128+2^76 (or whatever), again incorrect.
8670 These bad roundings of x+0.5 are avoided by testing at the start whether
8671 x is already an integer. If it is then clearly that's the desired result
8672 already. And if it's not then the exponent must be small enough to allow
8673 an 0.5 to be represented, and hence added without a bad rounding. */
8676 scm_c_round (double x
)
8678 double plus_half
, result
;
8683 plus_half
= x
+ 0.5;
8684 result
= floor (plus_half
);
8685 /* Adjust so that the rounding is towards even. */
8686 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8691 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8693 "Round the number @var{x} towards zero.")
8694 #define FUNC_NAME s_scm_truncate_number
8696 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8698 else if (SCM_REALP (x
))
8699 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8700 else if (SCM_FRACTIONP (x
))
8701 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8702 SCM_FRACTION_DENOMINATOR (x
));
8704 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8705 s_scm_truncate_number
);
8709 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8711 "Round the number @var{x} towards the nearest integer. "
8712 "When it is exactly halfway between two integers, "
8713 "round towards the even one.")
8714 #define FUNC_NAME s_scm_round_number
8716 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8718 else if (SCM_REALP (x
))
8719 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8720 else if (SCM_FRACTIONP (x
))
8721 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8722 SCM_FRACTION_DENOMINATOR (x
));
8724 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8725 s_scm_round_number
);
8729 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8731 "Round the number @var{x} towards minus infinity.")
8732 #define FUNC_NAME s_scm_floor
8734 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8736 else if (SCM_REALP (x
))
8737 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8738 else if (SCM_FRACTIONP (x
))
8739 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8740 SCM_FRACTION_DENOMINATOR (x
));
8742 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8746 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8748 "Round the number @var{x} towards infinity.")
8749 #define FUNC_NAME s_scm_ceiling
8751 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8753 else if (SCM_REALP (x
))
8754 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8755 else if (SCM_FRACTIONP (x
))
8756 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8757 SCM_FRACTION_DENOMINATOR (x
));
8759 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8763 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8765 "Return @var{x} raised to the power of @var{y}.")
8766 #define FUNC_NAME s_scm_expt
8768 if (scm_is_integer (y
))
8770 if (scm_is_true (scm_exact_p (y
)))
8771 return scm_integer_expt (x
, y
);
8774 /* Here we handle the case where the exponent is an inexact
8775 integer. We make the exponent exact in order to use
8776 scm_integer_expt, and thus avoid the spurious imaginary
8777 parts that may result from round-off errors in the general
8778 e^(y log x) method below (for example when squaring a large
8779 negative number). In this case, we must return an inexact
8780 result for correctness. We also make the base inexact so
8781 that scm_integer_expt will use fast inexact arithmetic
8782 internally. Note that making the base inexact is not
8783 sufficient to guarantee an inexact result, because
8784 scm_integer_expt will return an exact 1 when the exponent
8785 is 0, even if the base is inexact. */
8786 return scm_exact_to_inexact
8787 (scm_integer_expt (scm_exact_to_inexact (x
),
8788 scm_inexact_to_exact (y
)));
8791 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8793 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8795 else if (scm_is_complex (x
) && scm_is_complex (y
))
8796 return scm_exp (scm_product (scm_log (x
), y
));
8797 else if (scm_is_complex (x
))
8798 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8800 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8804 /* sin/cos/tan/asin/acos/atan
8805 sinh/cosh/tanh/asinh/acosh/atanh
8806 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8807 Written by Jerry D. Hedden, (C) FSF.
8808 See the file `COPYING' for terms applying to this program. */
8810 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8812 "Compute the sine of @var{z}.")
8813 #define FUNC_NAME s_scm_sin
8815 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8816 return z
; /* sin(exact0) = exact0 */
8817 else if (scm_is_real (z
))
8818 return scm_i_from_double (sin (scm_to_double (z
)));
8819 else if (SCM_COMPLEXP (z
))
8821 x
= SCM_COMPLEX_REAL (z
);
8822 y
= SCM_COMPLEX_IMAG (z
);
8823 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8824 cos (x
) * sinh (y
));
8827 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8831 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8833 "Compute the cosine of @var{z}.")
8834 #define FUNC_NAME s_scm_cos
8836 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8837 return SCM_INUM1
; /* cos(exact0) = exact1 */
8838 else if (scm_is_real (z
))
8839 return scm_i_from_double (cos (scm_to_double (z
)));
8840 else if (SCM_COMPLEXP (z
))
8842 x
= SCM_COMPLEX_REAL (z
);
8843 y
= SCM_COMPLEX_IMAG (z
);
8844 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8845 -sin (x
) * sinh (y
));
8848 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8852 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8854 "Compute the tangent of @var{z}.")
8855 #define FUNC_NAME s_scm_tan
8857 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8858 return z
; /* tan(exact0) = exact0 */
8859 else if (scm_is_real (z
))
8860 return scm_i_from_double (tan (scm_to_double (z
)));
8861 else if (SCM_COMPLEXP (z
))
8863 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8864 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8865 w
= cos (x
) + cosh (y
);
8866 #ifndef ALLOW_DIVIDE_BY_ZERO
8868 scm_num_overflow (s_scm_tan
);
8870 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8873 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8877 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8879 "Compute the hyperbolic sine of @var{z}.")
8880 #define FUNC_NAME s_scm_sinh
8882 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8883 return z
; /* sinh(exact0) = exact0 */
8884 else if (scm_is_real (z
))
8885 return scm_i_from_double (sinh (scm_to_double (z
)));
8886 else if (SCM_COMPLEXP (z
))
8888 x
= SCM_COMPLEX_REAL (z
);
8889 y
= SCM_COMPLEX_IMAG (z
);
8890 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8891 cosh (x
) * sin (y
));
8894 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8898 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8900 "Compute the hyperbolic cosine of @var{z}.")
8901 #define FUNC_NAME s_scm_cosh
8903 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8904 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8905 else if (scm_is_real (z
))
8906 return scm_i_from_double (cosh (scm_to_double (z
)));
8907 else if (SCM_COMPLEXP (z
))
8909 x
= SCM_COMPLEX_REAL (z
);
8910 y
= SCM_COMPLEX_IMAG (z
);
8911 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8912 sinh (x
) * sin (y
));
8915 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8919 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8921 "Compute the hyperbolic tangent of @var{z}.")
8922 #define FUNC_NAME s_scm_tanh
8924 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8925 return z
; /* tanh(exact0) = exact0 */
8926 else if (scm_is_real (z
))
8927 return scm_i_from_double (tanh (scm_to_double (z
)));
8928 else if (SCM_COMPLEXP (z
))
8930 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8931 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8932 w
= cosh (x
) + cos (y
);
8933 #ifndef ALLOW_DIVIDE_BY_ZERO
8935 scm_num_overflow (s_scm_tanh
);
8937 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8940 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8944 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8946 "Compute the arc sine of @var{z}.")
8947 #define FUNC_NAME s_scm_asin
8949 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8950 return z
; /* asin(exact0) = exact0 */
8951 else if (scm_is_real (z
))
8953 double w
= scm_to_double (z
);
8954 if (w
>= -1.0 && w
<= 1.0)
8955 return scm_i_from_double (asin (w
));
8957 return scm_product (scm_c_make_rectangular (0, -1),
8958 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8960 else if (SCM_COMPLEXP (z
))
8962 x
= SCM_COMPLEX_REAL (z
);
8963 y
= SCM_COMPLEX_IMAG (z
);
8964 return scm_product (scm_c_make_rectangular (0, -1),
8965 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8968 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8972 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8974 "Compute the arc cosine of @var{z}.")
8975 #define FUNC_NAME s_scm_acos
8977 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8978 return SCM_INUM0
; /* acos(exact1) = exact0 */
8979 else if (scm_is_real (z
))
8981 double w
= scm_to_double (z
);
8982 if (w
>= -1.0 && w
<= 1.0)
8983 return scm_i_from_double (acos (w
));
8985 return scm_sum (scm_i_from_double (acos (0.0)),
8986 scm_product (scm_c_make_rectangular (0, 1),
8987 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8989 else if (SCM_COMPLEXP (z
))
8991 x
= SCM_COMPLEX_REAL (z
);
8992 y
= SCM_COMPLEX_IMAG (z
);
8993 return scm_sum (scm_i_from_double (acos (0.0)),
8994 scm_product (scm_c_make_rectangular (0, 1),
8995 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8998 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
9002 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
9004 "With one argument, compute the arc tangent of @var{z}.\n"
9005 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
9006 "using the sign of @var{z} and @var{y} to determine the quadrant.")
9007 #define FUNC_NAME s_scm_atan
9011 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9012 return z
; /* atan(exact0) = exact0 */
9013 else if (scm_is_real (z
))
9014 return scm_i_from_double (atan (scm_to_double (z
)));
9015 else if (SCM_COMPLEXP (z
))
9018 v
= SCM_COMPLEX_REAL (z
);
9019 w
= SCM_COMPLEX_IMAG (z
);
9020 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
9021 scm_c_make_rectangular (v
, w
+ 1.0))),
9022 scm_c_make_rectangular (0, 2));
9025 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
9027 else if (scm_is_real (z
))
9029 if (scm_is_real (y
))
9030 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9032 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9035 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9039 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9041 "Compute the inverse hyperbolic sine of @var{z}.")
9042 #define FUNC_NAME s_scm_sys_asinh
9044 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9045 return z
; /* asinh(exact0) = exact0 */
9046 else if (scm_is_real (z
))
9047 return scm_i_from_double (asinh (scm_to_double (z
)));
9048 else if (scm_is_number (z
))
9049 return scm_log (scm_sum (z
,
9050 scm_sqrt (scm_sum (scm_product (z
, z
),
9053 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9057 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9059 "Compute the inverse hyperbolic cosine of @var{z}.")
9060 #define FUNC_NAME s_scm_sys_acosh
9062 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9063 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9064 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9065 return scm_i_from_double (acosh (scm_to_double (z
)));
9066 else if (scm_is_number (z
))
9067 return scm_log (scm_sum (z
,
9068 scm_sqrt (scm_difference (scm_product (z
, z
),
9071 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9075 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9077 "Compute the inverse hyperbolic tangent of @var{z}.")
9078 #define FUNC_NAME s_scm_sys_atanh
9080 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9081 return z
; /* atanh(exact0) = exact0 */
9082 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9083 return scm_i_from_double (atanh (scm_to_double (z
)));
9084 else if (scm_is_number (z
))
9085 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9086 scm_difference (SCM_INUM1
, z
))),
9089 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9094 scm_c_make_rectangular (double re
, double im
)
9098 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9100 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9101 SCM_COMPLEX_REAL (z
) = re
;
9102 SCM_COMPLEX_IMAG (z
) = im
;
9106 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9107 (SCM real_part
, SCM imaginary_part
),
9108 "Return a complex number constructed of the given @var{real_part} "
9109 "and @var{imaginary_part} parts.")
9110 #define FUNC_NAME s_scm_make_rectangular
9112 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9113 SCM_ARG1
, FUNC_NAME
, "real");
9114 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9115 SCM_ARG2
, FUNC_NAME
, "real");
9117 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9118 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9121 return scm_c_make_rectangular (scm_to_double (real_part
),
9122 scm_to_double (imaginary_part
));
9127 scm_c_make_polar (double mag
, double ang
)
9131 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9132 use it on Glibc-based systems that have it (it's a GNU extension). See
9133 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9135 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9136 sincos (ang
, &s
, &c
);
9142 /* If s and c are NaNs, this indicates that the angle is a NaN,
9143 infinite, or perhaps simply too large to determine its value
9144 mod 2*pi. However, we know something that the floating-point
9145 implementation doesn't know: We know that s and c are finite.
9146 Therefore, if the magnitude is zero, return a complex zero.
9148 The reason we check for the NaNs instead of using this case
9149 whenever mag == 0.0 is because when the angle is known, we'd
9150 like to return the correct kind of non-real complex zero:
9151 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9152 on which quadrant the angle is in.
9154 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9155 return scm_c_make_rectangular (0.0, 0.0);
9157 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9160 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9162 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9163 #define FUNC_NAME s_scm_make_polar
9165 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9166 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9168 /* If mag is exact0, return exact0 */
9169 if (scm_is_eq (mag
, SCM_INUM0
))
9171 /* Return a real if ang is exact0 */
9172 else if (scm_is_eq (ang
, SCM_INUM0
))
9175 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9180 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9182 "Return the real part of the number @var{z}.")
9183 #define FUNC_NAME s_scm_real_part
9185 if (SCM_COMPLEXP (z
))
9186 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9187 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9190 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9195 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9197 "Return the imaginary part of the number @var{z}.")
9198 #define FUNC_NAME s_scm_imag_part
9200 if (SCM_COMPLEXP (z
))
9201 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9202 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9205 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9209 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9211 "Return the numerator of the number @var{z}.")
9212 #define FUNC_NAME s_scm_numerator
9214 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9216 else if (SCM_FRACTIONP (z
))
9217 return SCM_FRACTION_NUMERATOR (z
);
9218 else if (SCM_REALP (z
))
9220 double zz
= SCM_REAL_VALUE (z
);
9221 if (zz
== floor (zz
))
9222 /* Handle -0.0 and infinities in accordance with R6RS
9223 flnumerator, and optimize handling of integers. */
9226 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9229 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9234 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9236 "Return the denominator of the number @var{z}.")
9237 #define FUNC_NAME s_scm_denominator
9239 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9241 else if (SCM_FRACTIONP (z
))
9242 return SCM_FRACTION_DENOMINATOR (z
);
9243 else if (SCM_REALP (z
))
9245 double zz
= SCM_REAL_VALUE (z
);
9246 if (zz
== floor (zz
))
9247 /* Handle infinities in accordance with R6RS fldenominator, and
9248 optimize handling of integers. */
9249 return scm_i_from_double (1.0);
9251 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9254 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9260 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9262 "Return the magnitude of the number @var{z}. This is the same as\n"
9263 "@code{abs} for real arguments, but also allows complex numbers.")
9264 #define FUNC_NAME s_scm_magnitude
9266 if (SCM_I_INUMP (z
))
9268 scm_t_inum zz
= SCM_I_INUM (z
);
9271 else if (SCM_POSFIXABLE (-zz
))
9272 return SCM_I_MAKINUM (-zz
);
9274 return scm_i_inum2big (-zz
);
9276 else if (SCM_BIGP (z
))
9278 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9279 scm_remember_upto_here_1 (z
);
9281 return scm_i_clonebig (z
, 0);
9285 else if (SCM_REALP (z
))
9286 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9287 else if (SCM_COMPLEXP (z
))
9288 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9289 else if (SCM_FRACTIONP (z
))
9291 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9293 return scm_i_make_ratio_already_reduced
9294 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9295 SCM_FRACTION_DENOMINATOR (z
));
9298 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9304 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9306 "Return the angle of the complex number @var{z}.")
9307 #define FUNC_NAME s_scm_angle
9309 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9310 flo0 to save allocating a new flonum with scm_i_from_double each time.
9311 But if atan2 follows the floating point rounding mode, then the value
9312 is not a constant. Maybe it'd be close enough though. */
9313 if (SCM_I_INUMP (z
))
9315 if (SCM_I_INUM (z
) >= 0)
9318 return scm_i_from_double (atan2 (0.0, -1.0));
9320 else if (SCM_BIGP (z
))
9322 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9323 scm_remember_upto_here_1 (z
);
9325 return scm_i_from_double (atan2 (0.0, -1.0));
9329 else if (SCM_REALP (z
))
9331 double x
= SCM_REAL_VALUE (z
);
9332 if (copysign (1.0, x
) > 0.0)
9335 return scm_i_from_double (atan2 (0.0, -1.0));
9337 else if (SCM_COMPLEXP (z
))
9338 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9339 else if (SCM_FRACTIONP (z
))
9341 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9343 else return scm_i_from_double (atan2 (0.0, -1.0));
9346 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9351 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9353 "Convert the number @var{z} to its inexact representation.\n")
9354 #define FUNC_NAME s_scm_exact_to_inexact
9356 if (SCM_I_INUMP (z
))
9357 return scm_i_from_double ((double) SCM_I_INUM (z
));
9358 else if (SCM_BIGP (z
))
9359 return scm_i_from_double (scm_i_big2dbl (z
));
9360 else if (SCM_FRACTIONP (z
))
9361 return scm_i_from_double (scm_i_fraction2double (z
));
9362 else if (SCM_INEXACTP (z
))
9365 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9366 s_scm_exact_to_inexact
);
9371 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9373 "Return an exact number that is numerically closest to @var{z}.")
9374 #define FUNC_NAME s_scm_inexact_to_exact
9376 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9383 val
= SCM_REAL_VALUE (z
);
9384 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9385 val
= SCM_COMPLEX_REAL (z
);
9387 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9388 s_scm_inexact_to_exact
);
9390 if (!SCM_LIKELY (isfinite (val
)))
9391 SCM_OUT_OF_RANGE (1, z
);
9392 else if (val
== 0.0)
9399 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9401 expon
-= DBL_MANT_DIG
;
9404 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9408 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9409 SCM_I_BIG_MPZ (numerator
),
9413 numerator
= scm_i_normbig (numerator
);
9415 return scm_i_make_ratio_already_reduced
9416 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9418 return left_shift_exact_integer (numerator
, expon
);
9426 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9428 "Returns the @emph{simplest} rational number differing\n"
9429 "from @var{x} by no more than @var{eps}.\n"
9431 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9432 "exact result when both its arguments are exact. Thus, you might need\n"
9433 "to use @code{inexact->exact} on the arguments.\n"
9436 "(rationalize (inexact->exact 1.2) 1/100)\n"
9439 #define FUNC_NAME s_scm_rationalize
9441 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9442 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9444 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9446 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9448 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9453 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9456 return scm_exact_to_inexact
9457 (scm_rationalize (scm_inexact_to_exact (x
),
9458 scm_inexact_to_exact (eps
)));
9462 /* X and EPS are exact rationals.
9464 The code that follows is equivalent to the following Scheme code:
9466 (define (exact-rationalize x eps)
9467 (let ((n1 (if (negative? x) -1 1))
9470 (let ((lo (- x eps))
9474 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9475 (nhi (numerator hi)) (dhi (denominator hi))
9476 (n1 n1) (d1 0) (n2 0) (d2 1))
9477 (let-values (((qlo rlo) (floor/ nlo dlo))
9478 ((qhi rhi) (floor/ nhi dhi)))
9479 (let ((n0 (+ n2 (* n1 qlo)))
9480 (d0 (+ d2 (* d1 qlo))))
9481 (cond ((zero? rlo) (/ n0 d0))
9482 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9483 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9489 eps
= scm_abs (eps
);
9490 if (scm_is_true (scm_negative_p (x
)))
9493 x
= scm_difference (x
, SCM_UNDEFINED
);
9496 /* X and EPS are non-negative exact rationals. */
9498 lo
= scm_difference (x
, eps
);
9499 hi
= scm_sum (x
, eps
);
9501 if (scm_is_false (scm_positive_p (lo
)))
9502 /* If zero is included in the interval, return it.
9503 It is the simplest rational of all. */
9508 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9509 mpz_t nlo
, dlo
, nhi
, dhi
;
9510 mpz_t qlo
, rlo
, qhi
, rhi
;
9512 /* LO and HI are positive exact rationals. */
9514 /* Our approach here follows the method described by Alan
9515 Bawden in a message entitled "(rationalize x y)" on the
9516 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9518 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9520 In brief, we compute the continued fractions of the two
9521 endpoints of the interval (LO and HI). The continued
9522 fraction of the result consists of the common prefix of the
9523 continued fractions of LO and HI, plus one final term. The
9524 final term of the result is the smallest integer contained
9525 in the interval between the remainders of LO and HI after
9526 the common prefix has been removed.
9528 The following code lazily computes the continued fraction
9529 representations of LO and HI, and simultaneously converts
9530 the continued fraction of the result into a rational
9531 number. We use MPZ functions directly to avoid type
9532 dispatch and GC allocation during the loop. */
9534 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9539 /* The variables N1, D1, N2 and D2 are used to compute the
9540 resulting rational from its continued fraction. At each
9541 step, N2/D2 and N1/D1 are the last two convergents. They
9542 are normally initialized to 0/1 and 1/0, respectively.
9543 However, if we negated X then we must negate the result as
9544 well, and we do that by initializing N1/D1 to -1/0. */
9545 mpz_set_si (n1
, n1_init
);
9550 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9551 compute the continued fraction representations of LO and HI
9552 using Euclid's algorithm. Initially, NLO/DLO == LO and
9554 scm_to_mpz (scm_numerator (lo
), nlo
);
9555 scm_to_mpz (scm_denominator (lo
), dlo
);
9556 scm_to_mpz (scm_numerator (hi
), nhi
);
9557 scm_to_mpz (scm_denominator (hi
), dhi
);
9559 /* As long as we're using exact arithmetic, the following loop
9560 is guaranteed to terminate. */
9563 /* Compute the next terms (QLO and QHI) of the continued
9564 fractions of LO and HI. */
9565 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9566 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9568 /* The next term of the result will be either QLO or
9569 QLO+1. Here we compute the next convergent of the
9570 result based on the assumption that QLO is the next
9571 term. If that turns out to be wrong, we'll adjust
9572 these later by adding N1 to N0 and D1 to D0. */
9573 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9574 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9576 /* We stop iterating when an integer is contained in the
9577 interval between the remainders NLO/DLO and NHI/DHI.
9578 There are two cases to consider: either NLO/DLO == QLO
9579 is an integer (indicated by RLO == 0), or QLO < QHI. */
9580 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9583 /* Efficiently shuffle variables around for the next
9584 iteration. First we shift the recent convergents. */
9585 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9586 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9588 /* The following shuffling is a bit confusing, so some
9589 explanation is in order. Conceptually, we're doing a
9590 couple of things here. After substracting the floor of
9591 NLO/DLO, the remainder is RLO/DLO. The rest of the
9592 continued fraction will represent the remainder's
9593 reciprocal DLO/RLO. Similarly for the HI endpoint.
9594 So in the next iteration, the new endpoints will be
9595 DLO/RLO and DHI/RHI. However, when we take the
9596 reciprocals of these endpoints, their order is
9597 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9598 and NHI/DHI <-- DLO/RLO. */
9599 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9600 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9603 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9604 The last term of the result will be the smallest integer in
9605 that interval, which is ceiling(NLO/DLO). We have already
9606 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9607 equal to the ceiling. */
9608 if (mpz_sgn (rlo
) != 0)
9610 /* If RLO is non-zero, then NLO/DLO is not an integer and
9611 the next term will be QLO+1. QLO was used in the
9612 computation of N0 and D0 above. Here we adjust N0 and
9613 D0 to be based on QLO+1 instead of QLO. */
9614 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9615 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9618 /* The simplest rational in the interval is N0/D0 */
9619 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9621 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9631 /* conversion functions */
9634 scm_is_integer (SCM val
)
9636 return scm_is_true (scm_integer_p (val
));
9640 scm_is_exact_integer (SCM val
)
9642 return scm_is_true (scm_exact_integer_p (val
));
9646 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9648 if (SCM_I_INUMP (val
))
9650 scm_t_signed_bits n
= SCM_I_INUM (val
);
9651 return n
>= min
&& n
<= max
;
9653 else if (SCM_BIGP (val
))
9655 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9657 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9659 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9661 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9662 return n
>= min
&& n
<= max
;
9672 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9673 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9676 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9677 SCM_I_BIG_MPZ (val
));
9679 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9691 return n
>= min
&& n
<= max
;
9699 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9701 if (SCM_I_INUMP (val
))
9703 scm_t_signed_bits n
= SCM_I_INUM (val
);
9704 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9706 else if (SCM_BIGP (val
))
9708 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9710 else if (max
<= ULONG_MAX
)
9712 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9714 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9715 return n
>= min
&& n
<= max
;
9725 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9728 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9729 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9732 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9733 SCM_I_BIG_MPZ (val
));
9735 return n
>= min
&& n
<= max
;
9743 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9745 scm_error (scm_out_of_range_key
,
9747 "Value out of range ~S to ~S: ~S",
9748 scm_list_3 (min
, max
, bad_val
),
9749 scm_list_1 (bad_val
));
9752 #define TYPE scm_t_intmax
9753 #define TYPE_MIN min
9754 #define TYPE_MAX max
9755 #define SIZEOF_TYPE 0
9756 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9757 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9758 #include "libguile/conv-integer.i.c"
9760 #define TYPE scm_t_uintmax
9761 #define TYPE_MIN min
9762 #define TYPE_MAX max
9763 #define SIZEOF_TYPE 0
9764 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9765 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9766 #include "libguile/conv-uinteger.i.c"
9768 #define TYPE scm_t_int8
9769 #define TYPE_MIN SCM_T_INT8_MIN
9770 #define TYPE_MAX SCM_T_INT8_MAX
9771 #define SIZEOF_TYPE 1
9772 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9773 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9774 #include "libguile/conv-integer.i.c"
9776 #define TYPE scm_t_uint8
9778 #define TYPE_MAX SCM_T_UINT8_MAX
9779 #define SIZEOF_TYPE 1
9780 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9781 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9782 #include "libguile/conv-uinteger.i.c"
9784 #define TYPE scm_t_int16
9785 #define TYPE_MIN SCM_T_INT16_MIN
9786 #define TYPE_MAX SCM_T_INT16_MAX
9787 #define SIZEOF_TYPE 2
9788 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9789 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9790 #include "libguile/conv-integer.i.c"
9792 #define TYPE scm_t_uint16
9794 #define TYPE_MAX SCM_T_UINT16_MAX
9795 #define SIZEOF_TYPE 2
9796 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9797 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9798 #include "libguile/conv-uinteger.i.c"
9800 #define TYPE scm_t_int32
9801 #define TYPE_MIN SCM_T_INT32_MIN
9802 #define TYPE_MAX SCM_T_INT32_MAX
9803 #define SIZEOF_TYPE 4
9804 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9805 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9806 #include "libguile/conv-integer.i.c"
9808 #define TYPE scm_t_uint32
9810 #define TYPE_MAX SCM_T_UINT32_MAX
9811 #define SIZEOF_TYPE 4
9812 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9813 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9814 #include "libguile/conv-uinteger.i.c"
9816 #define TYPE scm_t_wchar
9817 #define TYPE_MIN (scm_t_int32)-1
9818 #define TYPE_MAX (scm_t_int32)0x10ffff
9819 #define SIZEOF_TYPE 4
9820 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9821 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9822 #include "libguile/conv-integer.i.c"
9824 #define TYPE scm_t_int64
9825 #define TYPE_MIN SCM_T_INT64_MIN
9826 #define TYPE_MAX SCM_T_INT64_MAX
9827 #define SIZEOF_TYPE 8
9828 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9829 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9830 #include "libguile/conv-integer.i.c"
9832 #define TYPE scm_t_uint64
9834 #define TYPE_MAX SCM_T_UINT64_MAX
9835 #define SIZEOF_TYPE 8
9836 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9837 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9838 #include "libguile/conv-uinteger.i.c"
9841 scm_to_mpz (SCM val
, mpz_t rop
)
9843 if (SCM_I_INUMP (val
))
9844 mpz_set_si (rop
, SCM_I_INUM (val
));
9845 else if (SCM_BIGP (val
))
9846 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9848 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9852 scm_from_mpz (mpz_t val
)
9854 return scm_i_mpz2num (val
);
9858 scm_is_real (SCM val
)
9860 return scm_is_true (scm_real_p (val
));
9864 scm_is_rational (SCM val
)
9866 return scm_is_true (scm_rational_p (val
));
9870 scm_to_double (SCM val
)
9872 if (SCM_I_INUMP (val
))
9873 return SCM_I_INUM (val
);
9874 else if (SCM_BIGP (val
))
9875 return scm_i_big2dbl (val
);
9876 else if (SCM_FRACTIONP (val
))
9877 return scm_i_fraction2double (val
);
9878 else if (SCM_REALP (val
))
9879 return SCM_REAL_VALUE (val
);
9881 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9885 scm_from_double (double val
)
9887 return scm_i_from_double (val
);
9891 scm_is_complex (SCM val
)
9893 return scm_is_true (scm_complex_p (val
));
9897 scm_c_real_part (SCM z
)
9899 if (SCM_COMPLEXP (z
))
9900 return SCM_COMPLEX_REAL (z
);
9903 /* Use the scm_real_part to get proper error checking and
9906 return scm_to_double (scm_real_part (z
));
9911 scm_c_imag_part (SCM z
)
9913 if (SCM_COMPLEXP (z
))
9914 return SCM_COMPLEX_IMAG (z
);
9917 /* Use the scm_imag_part to get proper error checking and
9918 dispatching. The result will almost always be 0.0, but not
9921 return scm_to_double (scm_imag_part (z
));
9926 scm_c_magnitude (SCM z
)
9928 return scm_to_double (scm_magnitude (z
));
9934 return scm_to_double (scm_angle (z
));
9938 scm_is_number (SCM z
)
9940 return scm_is_true (scm_number_p (z
));
9944 /* Returns log(x * 2^shift) */
9946 log_of_shifted_double (double x
, long shift
)
9948 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9950 if (copysign (1.0, x
) > 0.0)
9951 return scm_i_from_double (ans
);
9953 return scm_c_make_rectangular (ans
, M_PI
);
9956 /* Returns log(n), for exact integer n */
9958 log_of_exact_integer (SCM n
)
9960 if (SCM_I_INUMP (n
))
9961 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9962 else if (SCM_BIGP (n
))
9965 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9966 return log_of_shifted_double (signif
, expon
);
9969 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9972 /* Returns log(n/d), for exact non-zero integers n and d */
9974 log_of_fraction (SCM n
, SCM d
)
9976 long n_size
= scm_to_long (scm_integer_length (n
));
9977 long d_size
= scm_to_long (scm_integer_length (d
));
9979 if (abs (n_size
- d_size
) > 1)
9980 return (scm_difference (log_of_exact_integer (n
),
9981 log_of_exact_integer (d
)));
9982 else if (scm_is_false (scm_negative_p (n
)))
9983 return scm_i_from_double
9984 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9986 return scm_c_make_rectangular
9987 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9993 /* In the following functions we dispatch to the real-arg funcs like log()
9994 when we know the arg is real, instead of just handing everything to
9995 clog() for instance. This is in case clog() doesn't optimize for a
9996 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9997 well use it to go straight to the applicable C func. */
9999 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
10001 "Return the natural logarithm of @var{z}.")
10002 #define FUNC_NAME s_scm_log
10004 if (SCM_COMPLEXP (z
))
10006 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
10007 && defined (SCM_COMPLEX_VALUE)
10008 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
10010 double re
= SCM_COMPLEX_REAL (z
);
10011 double im
= SCM_COMPLEX_IMAG (z
);
10012 return scm_c_make_rectangular (log (hypot (re
, im
)),
10016 else if (SCM_REALP (z
))
10017 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
10018 else if (SCM_I_INUMP (z
))
10020 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10021 if (scm_is_eq (z
, SCM_INUM0
))
10022 scm_num_overflow (s_scm_log
);
10024 return log_of_shifted_double (SCM_I_INUM (z
), 0);
10026 else if (SCM_BIGP (z
))
10027 return log_of_exact_integer (z
);
10028 else if (SCM_FRACTIONP (z
))
10029 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10030 SCM_FRACTION_DENOMINATOR (z
));
10032 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
10037 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10039 "Return the base 10 logarithm of @var{z}.")
10040 #define FUNC_NAME s_scm_log10
10042 if (SCM_COMPLEXP (z
))
10044 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10045 clog() and a multiply by M_LOG10E, rather than the fallback
10046 log10+hypot+atan2.) */
10047 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10048 && defined SCM_COMPLEX_VALUE
10049 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10051 double re
= SCM_COMPLEX_REAL (z
);
10052 double im
= SCM_COMPLEX_IMAG (z
);
10053 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10054 M_LOG10E
* atan2 (im
, re
));
10057 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10059 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10060 if (scm_is_eq (z
, SCM_INUM0
))
10061 scm_num_overflow (s_scm_log10
);
10064 double re
= scm_to_double (z
);
10065 double l
= log10 (fabs (re
));
10066 if (copysign (1.0, re
) > 0.0)
10067 return scm_i_from_double (l
);
10069 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10072 else if (SCM_BIGP (z
))
10073 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10074 else if (SCM_FRACTIONP (z
))
10075 return scm_product (flo_log10e
,
10076 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10077 SCM_FRACTION_DENOMINATOR (z
)));
10079 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10084 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10086 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10087 "base of natural logarithms (2.71828@dots{}).")
10088 #define FUNC_NAME s_scm_exp
10090 if (SCM_COMPLEXP (z
))
10092 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10093 && defined (SCM_COMPLEX_VALUE)
10094 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10096 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10097 SCM_COMPLEX_IMAG (z
));
10100 else if (SCM_NUMBERP (z
))
10102 /* When z is a negative bignum the conversion to double overflows,
10103 giving -infinity, but that's ok, the exp is still 0.0. */
10104 return scm_i_from_double (exp (scm_to_double (z
)));
10107 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10112 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10114 "Return two exact non-negative integers @var{s} and @var{r}\n"
10115 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10116 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10117 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10120 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10122 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10126 scm_exact_integer_sqrt (k
, &s
, &r
);
10127 return scm_values (scm_list_2 (s
, r
));
10132 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10134 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10138 if (SCM_I_INUM (k
) < 0)
10139 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10140 "exact non-negative integer");
10141 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10142 mpz_inits (ss
, rr
, NULL
);
10143 mpz_sqrtrem (ss
, rr
, kk
);
10144 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10145 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10146 mpz_clears (kk
, ss
, rr
, NULL
);
10148 else if (SCM_LIKELY (SCM_BIGP (k
)))
10152 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10153 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10154 "exact non-negative integer");
10155 s
= scm_i_mkbig ();
10156 r
= scm_i_mkbig ();
10157 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10158 scm_remember_upto_here_1 (k
);
10159 *sp
= scm_i_normbig (s
);
10160 *rp
= scm_i_normbig (r
);
10163 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10164 "exact non-negative integer");
10167 /* Return true iff K is a perfect square.
10168 K must be an exact integer. */
10170 exact_integer_is_perfect_square (SCM k
)
10174 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10178 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10179 result
= mpz_perfect_square_p (kk
);
10184 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10185 scm_remember_upto_here_1 (k
);
10190 /* Return the floor of the square root of K.
10191 K must be an exact integer. */
10193 exact_integer_floor_square_root (SCM k
)
10195 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10200 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10202 ss
= mpz_get_ui (kk
);
10204 return SCM_I_MAKINUM (ss
);
10210 s
= scm_i_mkbig ();
10211 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10212 scm_remember_upto_here_1 (k
);
10213 return scm_i_normbig (s
);
10218 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10220 "Return the square root of @var{z}. Of the two possible roots\n"
10221 "(positive and negative), the one with positive real part\n"
10222 "is returned, or if that's zero then a positive imaginary part.\n"
10226 "(sqrt 9.0) @result{} 3.0\n"
10227 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10228 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10229 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10231 #define FUNC_NAME s_scm_sqrt
10233 if (SCM_COMPLEXP (z
))
10235 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10236 && defined SCM_COMPLEX_VALUE
10237 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10239 double re
= SCM_COMPLEX_REAL (z
);
10240 double im
= SCM_COMPLEX_IMAG (z
);
10241 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10242 0.5 * atan2 (im
, re
));
10245 else if (SCM_NUMBERP (z
))
10247 if (SCM_I_INUMP (z
))
10249 scm_t_inum x
= SCM_I_INUM (z
);
10251 if (SCM_LIKELY (x
>= 0))
10253 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10254 || x
< (1L << (DBL_MANT_DIG
- 1))))
10256 double root
= sqrt (x
);
10258 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10259 integer, then the result is exact. */
10260 if (root
== floor (root
))
10261 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10263 return scm_i_from_double (root
);
10270 mpz_init_set_ui (xx
, x
);
10271 if (mpz_perfect_square_p (xx
))
10274 root
= mpz_get_ui (xx
);
10276 return SCM_I_MAKINUM (root
);
10283 else if (SCM_BIGP (z
))
10285 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10287 SCM root
= scm_i_mkbig ();
10289 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10290 scm_remember_upto_here_1 (z
);
10291 return scm_i_normbig (root
);
10296 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10304 return scm_c_make_rectangular
10305 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10307 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10310 else if (SCM_FRACTIONP (z
))
10312 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10313 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10315 if (exact_integer_is_perfect_square (n
)
10316 && exact_integer_is_perfect_square (d
))
10317 return scm_i_make_ratio_already_reduced
10318 (exact_integer_floor_square_root (n
),
10319 exact_integer_floor_square_root (d
));
10322 double xx
= scm_i_divide2double (n
, d
);
10323 double abs_xx
= fabs (xx
);
10326 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10328 shift
= (scm_to_long (scm_integer_length (n
))
10329 - scm_to_long (scm_integer_length (d
))) / 2;
10331 d
= left_shift_exact_integer (d
, 2 * shift
);
10333 n
= left_shift_exact_integer (n
, -2 * shift
);
10334 xx
= scm_i_divide2double (n
, d
);
10338 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10340 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10344 /* Fallback method, when the cases above do not apply. */
10346 double xx
= scm_to_double (z
);
10348 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10350 return scm_i_from_double (sqrt (xx
));
10354 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10361 scm_init_numbers ()
10363 if (scm_install_gmp_memory_functions
)
10364 mp_set_memory_functions (custom_gmp_malloc
,
10365 custom_gmp_realloc
,
10368 mpz_init_set_si (z_negative_one
, -1);
10370 /* It may be possible to tune the performance of some algorithms by using
10371 * the following constants to avoid the creation of bignums. Please, before
10372 * using these values, remember the two rules of program optimization:
10373 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10374 scm_c_define ("most-positive-fixnum",
10375 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10376 scm_c_define ("most-negative-fixnum",
10377 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10379 scm_add_feature ("complex");
10380 scm_add_feature ("inexact");
10381 flo0
= scm_i_from_double (0.0);
10382 flo_log10e
= scm_i_from_double (M_LOG10E
);
10384 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10387 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10388 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10389 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10390 scm_i_divide2double_lo2b
,
10391 DBL_MANT_DIG
+ 1); /* 2 b^p */
10392 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10396 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10397 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10398 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10399 dbl_minimum_normal_mantissa
,
10403 #include "libguile/numbers.x"
10408 c-file-style: "gnu"