1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
3 * 2013, 2014 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 if (iindex
< SCM_LONG_BIT
- 1)
4683 /* Arrange for the number to be converted to unsigned before
4684 checking the bit, to ensure that we're testing the bit in a
4685 two's complement representation (regardless of the native
4687 return scm_from_bool ((1UL << iindex
) & SCM_I_INUM (j
));
4689 /* Portably check the sign. */
4690 return scm_from_bool (SCM_I_INUM (j
) < 0);
4692 else if (SCM_BIGP (j
))
4694 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4695 scm_remember_upto_here_1 (j
);
4696 return scm_from_bool (val
);
4699 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4704 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4706 "Return the integer which is the ones-complement of the integer\n"
4710 "(number->string (lognot #b10000000) 2)\n"
4711 " @result{} \"-10000001\"\n"
4712 "(number->string (lognot #b0) 2)\n"
4713 " @result{} \"-1\"\n"
4715 #define FUNC_NAME s_scm_lognot
4717 if (SCM_I_INUMP (n
)) {
4718 /* No overflow here, just need to toggle all the bits making up the inum.
4719 Enhancement: No need to strip the tag and add it back, could just xor
4720 a block of 1 bits, if that worked with the various debug versions of
4722 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4724 } else if (SCM_BIGP (n
)) {
4725 SCM result
= scm_i_mkbig ();
4726 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4727 scm_remember_upto_here_1 (n
);
4731 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4736 /* returns 0 if IN is not an integer. OUT must already be
4739 coerce_to_big (SCM in
, mpz_t out
)
4742 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4743 else if (SCM_I_INUMP (in
))
4744 mpz_set_si (out
, SCM_I_INUM (in
));
4751 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4752 (SCM n
, SCM k
, SCM m
),
4753 "Return @var{n} raised to the integer exponent\n"
4754 "@var{k}, modulo @var{m}.\n"
4757 "(modulo-expt 2 3 5)\n"
4760 #define FUNC_NAME s_scm_modulo_expt
4766 /* There are two classes of error we might encounter --
4767 1) Math errors, which we'll report by calling scm_num_overflow,
4769 2) wrong-type errors, which of course we'll report by calling
4771 We don't report those errors immediately, however; instead we do
4772 some cleanup first. These variables tell us which error (if
4773 any) we should report after cleaning up.
4775 int report_overflow
= 0;
4777 int position_of_wrong_type
= 0;
4778 SCM value_of_wrong_type
= SCM_INUM0
;
4780 SCM result
= SCM_UNDEFINED
;
4786 if (scm_is_eq (m
, SCM_INUM0
))
4788 report_overflow
= 1;
4792 if (!coerce_to_big (n
, n_tmp
))
4794 value_of_wrong_type
= n
;
4795 position_of_wrong_type
= 1;
4799 if (!coerce_to_big (k
, k_tmp
))
4801 value_of_wrong_type
= k
;
4802 position_of_wrong_type
= 2;
4806 if (!coerce_to_big (m
, m_tmp
))
4808 value_of_wrong_type
= m
;
4809 position_of_wrong_type
= 3;
4813 /* if the exponent K is negative, and we simply call mpz_powm, we
4814 will get a divide-by-zero exception when an inverse 1/n mod m
4815 doesn't exist (or is not unique). Since exceptions are hard to
4816 handle, we'll attempt the inversion "by hand" -- that way, we get
4817 a simple failure code, which is easy to handle. */
4819 if (-1 == mpz_sgn (k_tmp
))
4821 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4823 report_overflow
= 1;
4826 mpz_neg (k_tmp
, k_tmp
);
4829 result
= scm_i_mkbig ();
4830 mpz_powm (SCM_I_BIG_MPZ (result
),
4835 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4836 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4843 if (report_overflow
)
4844 scm_num_overflow (FUNC_NAME
);
4846 if (position_of_wrong_type
)
4847 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4848 value_of_wrong_type
);
4850 return scm_i_normbig (result
);
4854 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4856 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4857 "exact integer, @var{n} can be any number.\n"
4859 "Negative @var{k} is supported, and results in\n"
4860 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4861 "@math{@var{n}^0} is 1, as usual, and that\n"
4862 "includes @math{0^0} is 1.\n"
4865 "(integer-expt 2 5) @result{} 32\n"
4866 "(integer-expt -3 3) @result{} -27\n"
4867 "(integer-expt 5 -3) @result{} 1/125\n"
4868 "(integer-expt 0 0) @result{} 1\n"
4870 #define FUNC_NAME s_scm_integer_expt
4873 SCM z_i2
= SCM_BOOL_F
;
4875 SCM acc
= SCM_I_MAKINUM (1L);
4877 /* Specifically refrain from checking the type of the first argument.
4878 This allows us to exponentiate any object that can be multiplied.
4879 If we must raise to a negative power, we must also be able to
4880 take its reciprocal. */
4881 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4882 SCM_WRONG_TYPE_ARG (2, k
);
4884 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4885 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4886 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4887 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4888 /* The next check is necessary only because R6RS specifies different
4889 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4890 we simply skip this case and move on. */
4891 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4893 /* k cannot be 0 at this point, because we
4894 have already checked for that case above */
4895 if (scm_is_true (scm_positive_p (k
)))
4897 else /* return NaN for (0 ^ k) for negative k per R6RS */
4900 else if (SCM_FRACTIONP (n
))
4902 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4903 needless reduction of intermediate products to lowest terms.
4904 If a and b have no common factors, then a^k and b^k have no
4905 common factors. Use 'scm_i_make_ratio_already_reduced' to
4906 construct the final result, so that no gcd computations are
4907 needed to exponentiate a fraction. */
4908 if (scm_is_true (scm_positive_p (k
)))
4909 return scm_i_make_ratio_already_reduced
4910 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4911 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4914 k
= scm_difference (k
, SCM_UNDEFINED
);
4915 return scm_i_make_ratio_already_reduced
4916 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4917 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4921 if (SCM_I_INUMP (k
))
4922 i2
= SCM_I_INUM (k
);
4923 else if (SCM_BIGP (k
))
4925 z_i2
= scm_i_clonebig (k
, 1);
4926 scm_remember_upto_here_1 (k
);
4930 SCM_WRONG_TYPE_ARG (2, k
);
4934 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4936 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4937 n
= scm_divide (n
, SCM_UNDEFINED
);
4941 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4945 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4947 return scm_product (acc
, n
);
4949 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4950 acc
= scm_product (acc
, n
);
4951 n
= scm_product (n
, n
);
4952 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4960 n
= scm_divide (n
, SCM_UNDEFINED
);
4967 return scm_product (acc
, n
);
4969 acc
= scm_product (acc
, n
);
4970 n
= scm_product (n
, n
);
4977 /* Efficiently compute (N * 2^COUNT),
4978 where N is an exact integer, and COUNT > 0. */
4980 left_shift_exact_integer (SCM n
, long count
)
4982 if (SCM_I_INUMP (n
))
4984 scm_t_inum nn
= SCM_I_INUM (n
);
4986 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
4987 overflow a non-zero fixnum. For smaller shifts we check the
4988 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4989 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4990 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
4992 [*] There's one exception:
4993 (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
4997 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4998 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
5000 return SCM_I_MAKINUM (nn
< 0 ? -(-nn
<< count
) : (nn
<< count
));
5003 SCM result
= scm_i_inum2big (nn
);
5004 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5006 return scm_i_normbig (result
);
5009 else if (SCM_BIGP (n
))
5011 SCM result
= scm_i_mkbig ();
5012 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5013 scm_remember_upto_here_1 (n
);
5020 /* Efficiently compute floor (N / 2^COUNT),
5021 where N is an exact integer and COUNT > 0. */
5023 floor_right_shift_exact_integer (SCM n
, long count
)
5025 if (SCM_I_INUMP (n
))
5027 scm_t_inum nn
= SCM_I_INUM (n
);
5029 if (count
>= SCM_I_FIXNUM_BIT
)
5030 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5032 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5034 else if (SCM_BIGP (n
))
5036 SCM result
= scm_i_mkbig ();
5037 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5039 scm_remember_upto_here_1 (n
);
5040 return scm_i_normbig (result
);
5046 /* Efficiently compute round (N / 2^COUNT),
5047 where N is an exact integer and COUNT > 0. */
5049 round_right_shift_exact_integer (SCM n
, long count
)
5051 if (SCM_I_INUMP (n
))
5053 if (count
>= SCM_I_FIXNUM_BIT
)
5057 scm_t_inum nn
= SCM_I_INUM (n
);
5058 scm_t_inum qq
= SCM_SRS (nn
, count
);
5060 if (0 == (nn
& (1L << (count
-1))))
5061 return SCM_I_MAKINUM (qq
); /* round down */
5062 else if (nn
& ((1L << (count
-1)) - 1))
5063 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5065 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5068 else if (SCM_BIGP (n
))
5070 SCM q
= scm_i_mkbig ();
5072 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5073 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5074 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5075 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5076 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5077 scm_remember_upto_here_1 (n
);
5078 return scm_i_normbig (q
);
5084 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5086 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5087 "@var{n} and @var{count} must be exact integers.\n"
5089 "With @var{n} viewed as an infinite-precision twos-complement\n"
5090 "integer, @code{ash} means a left shift introducing zero bits\n"
5091 "when @var{count} is positive, or a right shift dropping bits\n"
5092 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5095 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5096 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5098 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5099 "(ash -23 -2) @result{} -6\n"
5101 #define FUNC_NAME s_scm_ash
5103 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5105 long bits_to_shift
= scm_to_long (count
);
5107 if (bits_to_shift
> 0)
5108 return left_shift_exact_integer (n
, bits_to_shift
);
5109 else if (SCM_LIKELY (bits_to_shift
< 0))
5110 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5115 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5119 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5121 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5122 "@var{n} and @var{count} must be exact integers.\n"
5124 "With @var{n} viewed as an infinite-precision twos-complement\n"
5125 "integer, @code{round-ash} means a left shift introducing zero\n"
5126 "bits when @var{count} is positive, or a right shift rounding\n"
5127 "to the nearest integer (with ties going to the nearest even\n"
5128 "integer) when @var{count} is negative. This is a rounded\n"
5129 "``arithmetic'' shift.\n"
5132 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5133 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5134 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5135 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5136 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5137 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5139 #define FUNC_NAME s_scm_round_ash
5141 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5143 long bits_to_shift
= scm_to_long (count
);
5145 if (bits_to_shift
> 0)
5146 return left_shift_exact_integer (n
, bits_to_shift
);
5147 else if (SCM_LIKELY (bits_to_shift
< 0))
5148 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5153 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5158 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5159 (SCM n
, SCM start
, SCM end
),
5160 "Return the integer composed of the @var{start} (inclusive)\n"
5161 "through @var{end} (exclusive) bits of @var{n}. The\n"
5162 "@var{start}th bit becomes the 0-th bit in the result.\n"
5165 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5166 " @result{} \"1010\"\n"
5167 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5168 " @result{} \"10110\"\n"
5170 #define FUNC_NAME s_scm_bit_extract
5172 unsigned long int istart
, iend
, bits
;
5173 istart
= scm_to_ulong (start
);
5174 iend
= scm_to_ulong (end
);
5175 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5177 /* how many bits to keep */
5178 bits
= iend
- istart
;
5180 if (SCM_I_INUMP (n
))
5182 scm_t_inum in
= SCM_I_INUM (n
);
5184 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5185 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5186 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5188 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5190 /* Since we emulate two's complement encoded numbers, this
5191 * special case requires us to produce a result that has
5192 * more bits than can be stored in a fixnum.
5194 SCM result
= scm_i_inum2big (in
);
5195 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5200 /* mask down to requisite bits */
5201 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5202 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5204 else if (SCM_BIGP (n
))
5209 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5213 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5214 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5215 such bits into a ulong. */
5216 result
= scm_i_mkbig ();
5217 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5218 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5219 result
= scm_i_normbig (result
);
5221 scm_remember_upto_here_1 (n
);
5225 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5230 static const char scm_logtab
[] = {
5231 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5234 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5236 "Return the number of bits in integer @var{n}. If integer is\n"
5237 "positive, the 1-bits in its binary representation are counted.\n"
5238 "If negative, the 0-bits in its two's-complement binary\n"
5239 "representation are counted. If 0, 0 is returned.\n"
5242 "(logcount #b10101010)\n"
5249 #define FUNC_NAME s_scm_logcount
5251 if (SCM_I_INUMP (n
))
5253 unsigned long c
= 0;
5254 scm_t_inum nn
= SCM_I_INUM (n
);
5259 c
+= scm_logtab
[15 & nn
];
5262 return SCM_I_MAKINUM (c
);
5264 else if (SCM_BIGP (n
))
5266 unsigned long count
;
5267 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5268 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5270 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5271 scm_remember_upto_here_1 (n
);
5272 return SCM_I_MAKINUM (count
);
5275 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5280 static const char scm_ilentab
[] = {
5281 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5285 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5287 "Return the number of bits necessary to represent @var{n}.\n"
5290 "(integer-length #b10101010)\n"
5292 "(integer-length 0)\n"
5294 "(integer-length #b1111)\n"
5297 #define FUNC_NAME s_scm_integer_length
5299 if (SCM_I_INUMP (n
))
5301 unsigned long c
= 0;
5303 scm_t_inum nn
= SCM_I_INUM (n
);
5309 l
= scm_ilentab
[15 & nn
];
5312 return SCM_I_MAKINUM (c
- 4 + l
);
5314 else if (SCM_BIGP (n
))
5316 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5317 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5318 1 too big, so check for that and adjust. */
5319 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5320 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5321 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5322 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5324 scm_remember_upto_here_1 (n
);
5325 return SCM_I_MAKINUM (size
);
5328 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5332 /*** NUMBERS -> STRINGS ***/
5333 #define SCM_MAX_DBL_RADIX 36
5335 /* use this array as a way to generate a single digit */
5336 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5338 static mpz_t dbl_minimum_normal_mantissa
;
5341 idbl2str (double dbl
, char *a
, int radix
)
5345 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5346 /* revert to existing behavior */
5351 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5361 else if (dbl
== 0.0)
5363 if (copysign (1.0, dbl
) < 0.0)
5365 strcpy (a
+ ch
, "0.0");
5368 else if (isnan (dbl
))
5370 strcpy (a
, "+nan.0");
5374 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5375 Accurately" by Robert G. Burger and R. Kent Dybvig */
5378 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5379 int f_is_even
, f_is_odd
;
5383 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5384 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5385 if (e
< DBL_MIN_EXP
)
5387 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5392 f_is_even
= !mpz_odd_p (f
);
5393 f_is_odd
= !f_is_even
;
5395 /* Initialize r, s, mplus, and mminus according
5396 to Table 1 from the paper. */
5399 mpz_set_ui (mminus
, 1);
5400 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5401 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5403 mpz_set_ui (mplus
, 1);
5404 mpz_mul_2exp (r
, f
, 1);
5405 mpz_mul_2exp (s
, mminus
, 1 - e
);
5409 mpz_set_ui (mplus
, 2);
5410 mpz_mul_2exp (r
, f
, 2);
5411 mpz_mul_2exp (s
, mminus
, 2 - e
);
5416 mpz_set_ui (mminus
, 1);
5417 mpz_mul_2exp (mminus
, mminus
, e
);
5418 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5420 mpz_set (mplus
, mminus
);
5421 mpz_mul_2exp (r
, f
, 1 + e
);
5426 mpz_mul_2exp (mplus
, mminus
, 1);
5427 mpz_mul_2exp (r
, f
, 2 + e
);
5432 /* Find the smallest k such that:
5433 (r + mplus) / s < radix^k (if f is even)
5434 (r + mplus) / s <= radix^k (if f is odd) */
5436 /* IMPROVE-ME: Make an initial guess to speed this up */
5437 mpz_add (hi
, r
, mplus
);
5439 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5441 mpz_mul_ui (s
, s
, radix
);
5446 mpz_mul_ui (hi
, hi
, radix
);
5447 while (mpz_cmp (hi
, s
) < f_is_odd
)
5449 mpz_mul_ui (r
, r
, radix
);
5450 mpz_mul_ui (mplus
, mplus
, radix
);
5451 mpz_mul_ui (mminus
, mminus
, radix
);
5452 mpz_mul_ui (hi
, hi
, radix
);
5463 /* Use scientific notation */
5471 /* Print leading zeroes */
5474 for (i
= 0; i
> k
; i
--)
5481 int end_1_p
, end_2_p
;
5484 mpz_mul_ui (mplus
, mplus
, radix
);
5485 mpz_mul_ui (mminus
, mminus
, radix
);
5486 mpz_mul_ui (r
, r
, radix
);
5487 mpz_fdiv_qr (digit
, r
, r
, s
);
5488 d
= mpz_get_ui (digit
);
5490 mpz_add (hi
, r
, mplus
);
5491 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5492 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5493 if (end_1_p
|| end_2_p
)
5495 mpz_mul_2exp (r
, r
, 1);
5500 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5502 a
[ch
++] = number_chars
[d
];
5509 a
[ch
++] = number_chars
[d
];
5517 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5519 /* Here we would have to print more than three zeroes
5520 followed by a decimal point and another zero. It
5521 makes more sense to use scientific notation. */
5523 /* Adjust k to what it would have been if we had chosen
5524 scientific notation from the beginning. */
5527 /* k will now be <= 0, with magnitude equal to the number of
5528 digits that we printed which should now be put after the
5531 /* Insert a decimal point */
5532 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5552 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5555 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5562 icmplx2str (double real
, double imag
, char *str
, int radix
)
5567 i
= idbl2str (real
, str
, radix
);
5568 #ifdef HAVE_COPYSIGN
5569 sgn
= copysign (1.0, imag
);
5573 /* Don't output a '+' for negative numbers or for Inf and
5574 NaN. They will provide their own sign. */
5575 if (sgn
>= 0 && isfinite (imag
))
5577 i
+= idbl2str (imag
, &str
[i
], radix
);
5583 iflo2str (SCM flt
, char *str
, int radix
)
5586 if (SCM_REALP (flt
))
5587 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5589 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5594 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5595 characters in the result.
5597 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5599 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5604 return scm_iuint2str (-num
, rad
, p
) + 1;
5607 return scm_iuint2str (num
, rad
, p
);
5610 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5611 characters in the result.
5613 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5615 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5619 scm_t_uintmax n
= num
;
5621 if (rad
< 2 || rad
> 36)
5622 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5624 for (n
/= rad
; n
> 0; n
/= rad
)
5634 p
[i
] = number_chars
[d
];
5639 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5641 "Return a string holding the external representation of the\n"
5642 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5643 "inexact, a radix of 10 will be used.")
5644 #define FUNC_NAME s_scm_number_to_string
5648 if (SCM_UNBNDP (radix
))
5651 base
= scm_to_signed_integer (radix
, 2, 36);
5653 if (SCM_I_INUMP (n
))
5655 char num_buf
[SCM_INTBUFLEN
];
5656 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5657 return scm_from_locale_stringn (num_buf
, length
);
5659 else if (SCM_BIGP (n
))
5661 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5662 size_t len
= strlen (str
);
5663 void (*freefunc
) (void *, size_t);
5665 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5666 scm_remember_upto_here_1 (n
);
5667 ret
= scm_from_latin1_stringn (str
, len
);
5668 freefunc (str
, len
+ 1);
5671 else if (SCM_FRACTIONP (n
))
5673 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5674 scm_from_locale_string ("/"),
5675 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5677 else if (SCM_INEXACTP (n
))
5679 char num_buf
[FLOBUFLEN
];
5680 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5683 SCM_WRONG_TYPE_ARG (1, n
);
5688 /* These print routines used to be stubbed here so that scm_repl.c
5689 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5692 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5694 char num_buf
[FLOBUFLEN
];
5695 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5700 scm_i_print_double (double val
, SCM port
)
5702 char num_buf
[FLOBUFLEN
];
5703 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5707 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5710 char num_buf
[FLOBUFLEN
];
5711 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5716 scm_i_print_complex (double real
, double imag
, SCM port
)
5718 char num_buf
[FLOBUFLEN
];
5719 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5723 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5726 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5727 scm_display (str
, port
);
5728 scm_remember_upto_here_1 (str
);
5733 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5735 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5736 size_t len
= strlen (str
);
5737 void (*freefunc
) (void *, size_t);
5738 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5739 scm_remember_upto_here_1 (exp
);
5740 scm_lfwrite_unlocked (str
, len
, port
);
5741 freefunc (str
, len
+ 1);
5744 /*** END nums->strs ***/
5747 /*** STRINGS -> NUMBERS ***/
5749 /* The following functions implement the conversion from strings to numbers.
5750 * The implementation somehow follows the grammar for numbers as it is given
5751 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5752 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5753 * points should be noted about the implementation:
5755 * * Each function keeps a local index variable 'idx' that points at the
5756 * current position within the parsed string. The global index is only
5757 * updated if the function could parse the corresponding syntactic unit
5760 * * Similarly, the functions keep track of indicators of inexactness ('#',
5761 * '.' or exponents) using local variables ('hash_seen', 'x').
5763 * * Sequences of digits are parsed into temporary variables holding fixnums.
5764 * Only if these fixnums would overflow, the result variables are updated
5765 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5766 * the temporary variables holding the fixnums are cleared, and the process
5767 * starts over again. If for example fixnums were able to store five decimal
5768 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5769 * and the result was computed as 12345 * 100000 + 67890. In other words,
5770 * only every five digits two bignum operations were performed.
5772 * Notes on the handling of exactness specifiers:
5774 * When parsing non-real complex numbers, we apply exactness specifiers on
5775 * per-component basis, as is done in PLT Scheme. For complex numbers
5776 * written in rectangular form, exactness specifiers are applied to the
5777 * real and imaginary parts before calling scm_make_rectangular. For
5778 * complex numbers written in polar form, exactness specifiers are applied
5779 * to the magnitude and angle before calling scm_make_polar.
5781 * There are two kinds of exactness specifiers: forced and implicit. A
5782 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5783 * the entire number, and applies to both components of a complex number.
5784 * "#e" causes each component to be made exact, and "#i" causes each
5785 * component to be made inexact. If no forced exactness specifier is
5786 * present, then the exactness of each component is determined
5787 * independently by the presence or absence of a decimal point or hash mark
5788 * within that component. If a decimal point or hash mark is present, the
5789 * component is made inexact, otherwise it is made exact.
5791 * After the exactness specifiers have been applied to each component, they
5792 * are passed to either scm_make_rectangular or scm_make_polar to produce
5793 * the final result. Note that this will result in a real number if the
5794 * imaginary part, magnitude, or angle is an exact 0.
5796 * For example, (string->number "#i5.0+0i") does the equivalent of:
5798 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5801 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5803 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5805 /* Caller is responsible for checking that the return value is in range
5806 for the given radix, which should be <= 36. */
5808 char_decimal_value (scm_t_uint32 c
)
5810 if (c
>= (scm_t_uint32
) '0' && c
<= (scm_t_uint32
) '9')
5811 return c
- (scm_t_uint32
) '0';
5814 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5815 that's certainly above any valid decimal, so we take advantage of
5816 that to elide some tests. */
5817 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5819 /* If that failed, try extended hexadecimals, then. Only accept ascii
5824 if (c
>= (scm_t_uint32
) 'a')
5825 d
= c
- (scm_t_uint32
)'a' + 10U;
5831 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5832 in base RADIX. Upon success, return the unsigned integer and update
5833 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5835 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5836 unsigned int radix
, enum t_exactness
*p_exactness
)
5838 unsigned int idx
= *p_idx
;
5839 unsigned int hash_seen
= 0;
5840 scm_t_bits shift
= 1;
5842 unsigned int digit_value
;
5845 size_t len
= scm_i_string_length (mem
);
5850 c
= scm_i_string_ref (mem
, idx
);
5851 digit_value
= char_decimal_value (c
);
5852 if (digit_value
>= radix
)
5856 result
= SCM_I_MAKINUM (digit_value
);
5859 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5869 digit_value
= char_decimal_value (c
);
5870 /* This check catches non-decimals in addition to out-of-range
5872 if (digit_value
>= radix
)
5877 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5879 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5881 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5888 shift
= shift
* radix
;
5889 add
= add
* radix
+ digit_value
;
5894 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5896 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5900 *p_exactness
= INEXACT
;
5906 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5907 * covers the parts of the rules that start at a potential point. The value
5908 * of the digits up to the point have been parsed by the caller and are given
5909 * in variable result. The content of *p_exactness indicates, whether a hash
5910 * has already been seen in the digits before the point.
5913 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5916 mem2decimal_from_point (SCM result
, SCM mem
,
5917 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5919 unsigned int idx
= *p_idx
;
5920 enum t_exactness x
= *p_exactness
;
5921 size_t len
= scm_i_string_length (mem
);
5926 if (scm_i_string_ref (mem
, idx
) == '.')
5928 scm_t_bits shift
= 1;
5930 unsigned int digit_value
;
5931 SCM big_shift
= SCM_INUM1
;
5936 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5937 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5942 digit_value
= DIGIT2UINT (c
);
5953 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5955 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5956 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5958 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5966 add
= add
* 10 + digit_value
;
5972 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5973 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5974 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5977 result
= scm_divide (result
, big_shift
);
5979 /* We've seen a decimal point, thus the value is implicitly inexact. */
5991 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5993 switch (scm_i_string_ref (mem
, idx
))
6005 c
= scm_i_string_ref (mem
, idx
);
6013 c
= scm_i_string_ref (mem
, idx
);
6022 c
= scm_i_string_ref (mem
, idx
);
6027 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6031 exponent
= DIGIT2UINT (c
);
6034 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6035 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6038 if (exponent
<= SCM_MAXEXP
)
6039 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6045 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6047 size_t exp_len
= idx
- start
;
6048 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6049 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6050 scm_out_of_range ("string->number", exp_num
);
6053 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6055 result
= scm_product (result
, e
);
6057 result
= scm_divide (result
, e
);
6059 /* We've seen an exponent, thus the value is implicitly inexact. */
6077 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6080 mem2ureal (SCM mem
, unsigned int *p_idx
,
6081 unsigned int radix
, enum t_exactness forced_x
,
6082 int allow_inf_or_nan
)
6084 unsigned int idx
= *p_idx
;
6086 size_t len
= scm_i_string_length (mem
);
6088 /* Start off believing that the number will be exact. This changes
6089 to INEXACT if we see a decimal point or a hash. */
6090 enum t_exactness implicit_x
= EXACT
;
6095 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6096 switch (scm_i_string_ref (mem
, idx
))
6099 switch (scm_i_string_ref (mem
, idx
+ 1))
6102 switch (scm_i_string_ref (mem
, idx
+ 2))
6105 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6106 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6114 switch (scm_i_string_ref (mem
, idx
+ 1))
6117 switch (scm_i_string_ref (mem
, idx
+ 2))
6120 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6122 /* Cobble up the fractional part. We might want to
6123 set the NaN's mantissa from it. */
6125 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6128 #if SCM_ENABLE_DEPRECATED == 1
6129 scm_c_issue_deprecation_warning
6130 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6143 if (scm_i_string_ref (mem
, idx
) == '.')
6147 else if (idx
+ 1 == len
)
6149 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6152 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6153 p_idx
, &implicit_x
);
6159 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6160 if (scm_is_false (uinteger
))
6165 else if (scm_i_string_ref (mem
, idx
) == '/')
6173 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6174 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6177 /* both are int/big here, I assume */
6178 result
= scm_i_make_ratio (uinteger
, divisor
);
6180 else if (radix
== 10)
6182 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6183 if (scm_is_false (result
))
6195 if (SCM_INEXACTP (result
))
6196 return scm_inexact_to_exact (result
);
6200 if (SCM_INEXACTP (result
))
6203 return scm_exact_to_inexact (result
);
6205 if (implicit_x
== INEXACT
)
6207 if (SCM_INEXACTP (result
))
6210 return scm_exact_to_inexact (result
);
6216 /* We should never get here */
6221 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6224 mem2complex (SCM mem
, unsigned int idx
,
6225 unsigned int radix
, enum t_exactness forced_x
)
6230 size_t len
= scm_i_string_length (mem
);
6235 c
= scm_i_string_ref (mem
, idx
);
6250 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6251 if (scm_is_false (ureal
))
6253 /* input must be either +i or -i */
6258 if (scm_i_string_ref (mem
, idx
) == 'i'
6259 || scm_i_string_ref (mem
, idx
) == 'I')
6265 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6272 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6273 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6278 c
= scm_i_string_ref (mem
, idx
);
6282 /* either +<ureal>i or -<ureal>i */
6289 return scm_make_rectangular (SCM_INUM0
, ureal
);
6292 /* polar input: <real>@<real>. */
6303 c
= scm_i_string_ref (mem
, idx
);
6321 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6322 if (scm_is_false (angle
))
6327 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6328 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6330 result
= scm_make_polar (ureal
, angle
);
6335 /* expecting input matching <real>[+-]<ureal>?i */
6342 int sign
= (c
== '+') ? 1 : -1;
6343 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6345 if (scm_is_false (imag
))
6346 imag
= SCM_I_MAKINUM (sign
);
6347 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6348 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6352 if (scm_i_string_ref (mem
, idx
) != 'i'
6353 && scm_i_string_ref (mem
, idx
) != 'I')
6360 return scm_make_rectangular (ureal
, imag
);
6369 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6371 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6374 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6376 unsigned int idx
= 0;
6377 unsigned int radix
= NO_RADIX
;
6378 enum t_exactness forced_x
= NO_EXACTNESS
;
6379 size_t len
= scm_i_string_length (mem
);
6381 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6382 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6384 switch (scm_i_string_ref (mem
, idx
+ 1))
6387 if (radix
!= NO_RADIX
)
6392 if (radix
!= NO_RADIX
)
6397 if (forced_x
!= NO_EXACTNESS
)
6402 if (forced_x
!= NO_EXACTNESS
)
6407 if (radix
!= NO_RADIX
)
6412 if (radix
!= NO_RADIX
)
6422 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6423 if (radix
== NO_RADIX
)
6424 radix
= default_radix
;
6426 return mem2complex (mem
, idx
, radix
, forced_x
);
6430 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6431 unsigned int default_radix
)
6433 SCM str
= scm_from_locale_stringn (mem
, len
);
6435 return scm_i_string_to_number (str
, default_radix
);
6439 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6440 (SCM string
, SCM radix
),
6441 "Return a number of the maximally precise representation\n"
6442 "expressed by the given @var{string}. @var{radix} must be an\n"
6443 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6444 "is a default radix that may be overridden by an explicit radix\n"
6445 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6446 "supplied, then the default radix is 10. If string is not a\n"
6447 "syntactically valid notation for a number, then\n"
6448 "@code{string->number} returns @code{#f}.")
6449 #define FUNC_NAME s_scm_string_to_number
6453 SCM_VALIDATE_STRING (1, string
);
6455 if (SCM_UNBNDP (radix
))
6458 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6460 answer
= scm_i_string_to_number (string
, base
);
6461 scm_remember_upto_here_1 (string
);
6467 /*** END strs->nums ***/
6470 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6472 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6474 #define FUNC_NAME s_scm_number_p
6476 return scm_from_bool (SCM_NUMBERP (x
));
6480 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6482 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6483 "otherwise. Note that the sets of real, rational and integer\n"
6484 "values form subsets of the set of complex numbers, i. e. the\n"
6485 "predicate will also be fulfilled if @var{x} is a real,\n"
6486 "rational or integer number.")
6487 #define FUNC_NAME s_scm_complex_p
6489 /* all numbers are complex. */
6490 return scm_number_p (x
);
6494 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6496 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6497 "otherwise. Note that the set of integer values forms a subset of\n"
6498 "the set of real numbers, i. e. the predicate will also be\n"
6499 "fulfilled if @var{x} is an integer number.")
6500 #define FUNC_NAME s_scm_real_p
6502 return scm_from_bool
6503 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6507 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6509 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6510 "otherwise. Note that the set of integer values forms a subset of\n"
6511 "the set of rational numbers, i. e. the predicate will also be\n"
6512 "fulfilled if @var{x} is an integer number.")
6513 #define FUNC_NAME s_scm_rational_p
6515 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6517 else if (SCM_REALP (x
))
6518 /* due to their limited precision, finite floating point numbers are
6519 rational as well. (finite means neither infinity nor a NaN) */
6520 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6526 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6528 "Return @code{#t} if @var{x} is an integer number,\n"
6529 "else return @code{#f}.")
6530 #define FUNC_NAME s_scm_integer_p
6532 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6534 else if (SCM_REALP (x
))
6536 double val
= SCM_REAL_VALUE (x
);
6537 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6544 SCM_DEFINE (scm_exact_integer_p
, "exact-integer?", 1, 0, 0,
6546 "Return @code{#t} if @var{x} is an exact integer number,\n"
6547 "else return @code{#f}.")
6548 #define FUNC_NAME s_scm_exact_integer_p
6550 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6558 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6559 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6560 (SCM x
, SCM y
, SCM rest
),
6561 "Return @code{#t} if all parameters are numerically equal.")
6562 #define FUNC_NAME s_scm_i_num_eq_p
6564 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6566 while (!scm_is_null (rest
))
6568 if (scm_is_false (scm_num_eq_p (x
, y
)))
6572 rest
= scm_cdr (rest
);
6574 return scm_num_eq_p (x
, y
);
6578 scm_num_eq_p (SCM x
, SCM y
)
6581 if (SCM_I_INUMP (x
))
6583 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6584 if (SCM_I_INUMP (y
))
6586 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6587 return scm_from_bool (xx
== yy
);
6589 else if (SCM_BIGP (y
))
6591 else if (SCM_REALP (y
))
6593 /* On a 32-bit system an inum fits a double, we can cast the inum
6594 to a double and compare.
6596 But on a 64-bit system an inum is bigger than a double and
6597 casting it to a double (call that dxx) will round.
6598 Although dxx will not in general be equal to xx, dxx will
6599 always be an integer and within a factor of 2 of xx, so if
6600 dxx==yy, we know that yy is an integer and fits in
6601 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6602 compare with plain xx.
6604 An alternative (for any size system actually) would be to check
6605 yy is an integer (with floor) and is in range of an inum
6606 (compare against appropriate powers of 2) then test
6607 xx==(scm_t_signed_bits)yy. It's just a matter of which
6608 casts/comparisons might be fastest or easiest for the cpu. */
6610 double yy
= SCM_REAL_VALUE (y
);
6611 return scm_from_bool ((double) xx
== yy
6612 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6613 || xx
== (scm_t_signed_bits
) yy
));
6615 else if (SCM_COMPLEXP (y
))
6617 /* see comments with inum/real above */
6618 double ry
= SCM_COMPLEX_REAL (y
);
6619 return scm_from_bool ((double) xx
== ry
6620 && 0.0 == SCM_COMPLEX_IMAG (y
)
6621 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6622 || xx
== (scm_t_signed_bits
) ry
));
6624 else if (SCM_FRACTIONP (y
))
6627 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6630 else if (SCM_BIGP (x
))
6632 if (SCM_I_INUMP (y
))
6634 else if (SCM_BIGP (y
))
6636 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6637 scm_remember_upto_here_2 (x
, y
);
6638 return scm_from_bool (0 == cmp
);
6640 else if (SCM_REALP (y
))
6643 if (isnan (SCM_REAL_VALUE (y
)))
6645 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6646 scm_remember_upto_here_1 (x
);
6647 return scm_from_bool (0 == cmp
);
6649 else if (SCM_COMPLEXP (y
))
6652 if (0.0 != SCM_COMPLEX_IMAG (y
))
6654 if (isnan (SCM_COMPLEX_REAL (y
)))
6656 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6657 scm_remember_upto_here_1 (x
);
6658 return scm_from_bool (0 == cmp
);
6660 else if (SCM_FRACTIONP (y
))
6663 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6666 else if (SCM_REALP (x
))
6668 double xx
= SCM_REAL_VALUE (x
);
6669 if (SCM_I_INUMP (y
))
6671 /* see comments with inum/real above */
6672 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6673 return scm_from_bool (xx
== (double) yy
6674 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6675 || (scm_t_signed_bits
) xx
== yy
));
6677 else if (SCM_BIGP (y
))
6682 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6683 scm_remember_upto_here_1 (y
);
6684 return scm_from_bool (0 == cmp
);
6686 else if (SCM_REALP (y
))
6687 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6688 else if (SCM_COMPLEXP (y
))
6689 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6690 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6691 else if (SCM_FRACTIONP (y
))
6693 if (isnan (xx
) || isinf (xx
))
6695 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6699 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6702 else if (SCM_COMPLEXP (x
))
6704 if (SCM_I_INUMP (y
))
6706 /* see comments with inum/real above */
6707 double rx
= SCM_COMPLEX_REAL (x
);
6708 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6709 return scm_from_bool (rx
== (double) yy
6710 && 0.0 == SCM_COMPLEX_IMAG (x
)
6711 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6712 || (scm_t_signed_bits
) rx
== yy
));
6714 else if (SCM_BIGP (y
))
6717 if (0.0 != SCM_COMPLEX_IMAG (x
))
6719 if (isnan (SCM_COMPLEX_REAL (x
)))
6721 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6722 scm_remember_upto_here_1 (y
);
6723 return scm_from_bool (0 == cmp
);
6725 else if (SCM_REALP (y
))
6726 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6727 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6728 else if (SCM_COMPLEXP (y
))
6729 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6730 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6731 else if (SCM_FRACTIONP (y
))
6734 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6736 xx
= SCM_COMPLEX_REAL (x
);
6737 if (isnan (xx
) || isinf (xx
))
6739 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6743 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6746 else if (SCM_FRACTIONP (x
))
6748 if (SCM_I_INUMP (y
))
6750 else if (SCM_BIGP (y
))
6752 else if (SCM_REALP (y
))
6754 double yy
= SCM_REAL_VALUE (y
);
6755 if (isnan (yy
) || isinf (yy
))
6757 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6760 else if (SCM_COMPLEXP (y
))
6763 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6765 yy
= SCM_COMPLEX_REAL (y
);
6766 if (isnan (yy
) || isinf(yy
))
6768 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6771 else if (SCM_FRACTIONP (y
))
6772 return scm_i_fraction_equalp (x
, y
);
6774 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6778 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6783 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6784 done are good for inums, but for bignums an answer can almost always be
6785 had by just examining a few high bits of the operands, as done by GMP in
6786 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6787 of the float exponent to take into account. */
6789 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6790 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6791 (SCM x
, SCM y
, SCM rest
),
6792 "Return @code{#t} if the list of parameters is monotonically\n"
6794 #define FUNC_NAME s_scm_i_num_less_p
6796 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6798 while (!scm_is_null (rest
))
6800 if (scm_is_false (scm_less_p (x
, y
)))
6804 rest
= scm_cdr (rest
);
6806 return scm_less_p (x
, y
);
6810 scm_less_p (SCM x
, SCM y
)
6813 if (SCM_I_INUMP (x
))
6815 scm_t_inum xx
= SCM_I_INUM (x
);
6816 if (SCM_I_INUMP (y
))
6818 scm_t_inum yy
= SCM_I_INUM (y
);
6819 return scm_from_bool (xx
< yy
);
6821 else if (SCM_BIGP (y
))
6823 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6824 scm_remember_upto_here_1 (y
);
6825 return scm_from_bool (sgn
> 0);
6827 else if (SCM_REALP (y
))
6829 /* We can safely take the ceiling of y without changing the
6830 result of x<y, given that x is an integer. */
6831 double yy
= ceil (SCM_REAL_VALUE (y
));
6833 /* In the following comparisons, it's important that the right
6834 hand side always be a power of 2, so that it can be
6835 losslessly converted to a double even on 64-bit
6837 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6839 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6840 /* The condition above is carefully written to include the
6841 case where yy==NaN. */
6844 /* yy is a finite integer that fits in an inum. */
6845 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6847 else if (SCM_FRACTIONP (y
))
6849 /* "x < a/b" becomes "x*b < a" */
6851 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6852 y
= SCM_FRACTION_NUMERATOR (y
);
6856 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6857 s_scm_i_num_less_p
);
6859 else if (SCM_BIGP (x
))
6861 if (SCM_I_INUMP (y
))
6863 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6864 scm_remember_upto_here_1 (x
);
6865 return scm_from_bool (sgn
< 0);
6867 else if (SCM_BIGP (y
))
6869 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6870 scm_remember_upto_here_2 (x
, y
);
6871 return scm_from_bool (cmp
< 0);
6873 else if (SCM_REALP (y
))
6876 if (isnan (SCM_REAL_VALUE (y
)))
6878 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6879 scm_remember_upto_here_1 (x
);
6880 return scm_from_bool (cmp
< 0);
6882 else if (SCM_FRACTIONP (y
))
6885 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6886 s_scm_i_num_less_p
);
6888 else if (SCM_REALP (x
))
6890 if (SCM_I_INUMP (y
))
6892 /* We can safely take the floor of x without changing the
6893 result of x<y, given that y is an integer. */
6894 double xx
= floor (SCM_REAL_VALUE (x
));
6896 /* In the following comparisons, it's important that the right
6897 hand side always be a power of 2, so that it can be
6898 losslessly converted to a double even on 64-bit
6900 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6902 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6903 /* The condition above is carefully written to include the
6904 case where xx==NaN. */
6907 /* xx is a finite integer that fits in an inum. */
6908 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6910 else if (SCM_BIGP (y
))
6913 if (isnan (SCM_REAL_VALUE (x
)))
6915 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6916 scm_remember_upto_here_1 (y
);
6917 return scm_from_bool (cmp
> 0);
6919 else if (SCM_REALP (y
))
6920 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6921 else if (SCM_FRACTIONP (y
))
6923 double xx
= SCM_REAL_VALUE (x
);
6927 return scm_from_bool (xx
< 0.0);
6928 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6932 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6933 s_scm_i_num_less_p
);
6935 else if (SCM_FRACTIONP (x
))
6937 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6939 /* "a/b < y" becomes "a < y*b" */
6940 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6941 x
= SCM_FRACTION_NUMERATOR (x
);
6944 else if (SCM_REALP (y
))
6946 double yy
= SCM_REAL_VALUE (y
);
6950 return scm_from_bool (0.0 < yy
);
6951 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6954 else if (SCM_FRACTIONP (y
))
6956 /* "a/b < c/d" becomes "a*d < c*b" */
6957 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6958 SCM_FRACTION_DENOMINATOR (y
));
6959 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6960 SCM_FRACTION_DENOMINATOR (x
));
6966 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6967 s_scm_i_num_less_p
);
6970 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6971 s_scm_i_num_less_p
);
6975 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6976 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6977 (SCM x
, SCM y
, SCM rest
),
6978 "Return @code{#t} if the list of parameters is monotonically\n"
6980 #define FUNC_NAME s_scm_i_num_gr_p
6982 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6984 while (!scm_is_null (rest
))
6986 if (scm_is_false (scm_gr_p (x
, y
)))
6990 rest
= scm_cdr (rest
);
6992 return scm_gr_p (x
, y
);
6995 #define FUNC_NAME s_scm_i_num_gr_p
6997 scm_gr_p (SCM x
, SCM y
)
6999 if (!SCM_NUMBERP (x
))
7000 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7001 else if (!SCM_NUMBERP (y
))
7002 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7004 return scm_less_p (y
, x
);
7009 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
7010 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
7011 (SCM x
, SCM y
, SCM rest
),
7012 "Return @code{#t} if the list of parameters is monotonically\n"
7014 #define FUNC_NAME s_scm_i_num_leq_p
7016 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7018 while (!scm_is_null (rest
))
7020 if (scm_is_false (scm_leq_p (x
, y
)))
7024 rest
= scm_cdr (rest
);
7026 return scm_leq_p (x
, y
);
7029 #define FUNC_NAME s_scm_i_num_leq_p
7031 scm_leq_p (SCM x
, SCM y
)
7033 if (!SCM_NUMBERP (x
))
7034 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7035 else if (!SCM_NUMBERP (y
))
7036 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7037 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7040 return scm_not (scm_less_p (y
, x
));
7045 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7046 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7047 (SCM x
, SCM y
, SCM rest
),
7048 "Return @code{#t} if the list of parameters is monotonically\n"
7050 #define FUNC_NAME s_scm_i_num_geq_p
7052 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7054 while (!scm_is_null (rest
))
7056 if (scm_is_false (scm_geq_p (x
, y
)))
7060 rest
= scm_cdr (rest
);
7062 return scm_geq_p (x
, y
);
7065 #define FUNC_NAME s_scm_i_num_geq_p
7067 scm_geq_p (SCM x
, SCM y
)
7069 if (!SCM_NUMBERP (x
))
7070 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7071 else if (!SCM_NUMBERP (y
))
7072 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7073 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7076 return scm_not (scm_less_p (x
, y
));
7081 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7083 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7085 #define FUNC_NAME s_scm_zero_p
7087 if (SCM_I_INUMP (z
))
7088 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7089 else if (SCM_BIGP (z
))
7091 else if (SCM_REALP (z
))
7092 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7093 else if (SCM_COMPLEXP (z
))
7094 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7095 && SCM_COMPLEX_IMAG (z
) == 0.0);
7096 else if (SCM_FRACTIONP (z
))
7099 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7104 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7106 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7108 #define FUNC_NAME s_scm_positive_p
7110 if (SCM_I_INUMP (x
))
7111 return scm_from_bool (SCM_I_INUM (x
) > 0);
7112 else if (SCM_BIGP (x
))
7114 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7115 scm_remember_upto_here_1 (x
);
7116 return scm_from_bool (sgn
> 0);
7118 else if (SCM_REALP (x
))
7119 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7120 else if (SCM_FRACTIONP (x
))
7121 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7123 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7128 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7130 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7132 #define FUNC_NAME s_scm_negative_p
7134 if (SCM_I_INUMP (x
))
7135 return scm_from_bool (SCM_I_INUM (x
) < 0);
7136 else if (SCM_BIGP (x
))
7138 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7139 scm_remember_upto_here_1 (x
);
7140 return scm_from_bool (sgn
< 0);
7142 else if (SCM_REALP (x
))
7143 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7144 else if (SCM_FRACTIONP (x
))
7145 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7147 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7152 /* scm_min and scm_max return an inexact when either argument is inexact, as
7153 required by r5rs. On that basis, for exact/inexact combinations the
7154 exact is converted to inexact to compare and possibly return. This is
7155 unlike scm_less_p above which takes some trouble to preserve all bits in
7156 its test, such trouble is not required for min and max. */
7158 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7159 (SCM x
, SCM y
, SCM rest
),
7160 "Return the maximum of all parameter values.")
7161 #define FUNC_NAME s_scm_i_max
7163 while (!scm_is_null (rest
))
7164 { x
= scm_max (x
, y
);
7166 rest
= scm_cdr (rest
);
7168 return scm_max (x
, y
);
7172 #define s_max s_scm_i_max
7173 #define g_max g_scm_i_max
7176 scm_max (SCM x
, SCM y
)
7181 return scm_wta_dispatch_0 (g_max
, s_max
);
7182 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7185 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7188 if (SCM_I_INUMP (x
))
7190 scm_t_inum xx
= SCM_I_INUM (x
);
7191 if (SCM_I_INUMP (y
))
7193 scm_t_inum yy
= SCM_I_INUM (y
);
7194 return (xx
< yy
) ? y
: x
;
7196 else if (SCM_BIGP (y
))
7198 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7199 scm_remember_upto_here_1 (y
);
7200 return (sgn
< 0) ? x
: y
;
7202 else if (SCM_REALP (y
))
7205 double yyd
= SCM_REAL_VALUE (y
);
7208 return scm_i_from_double (xxd
);
7209 /* If y is a NaN, then "==" is false and we return the NaN */
7210 else if (SCM_LIKELY (!(xxd
== yyd
)))
7212 /* Handle signed zeroes properly */
7218 else if (SCM_FRACTIONP (y
))
7221 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7224 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7226 else if (SCM_BIGP (x
))
7228 if (SCM_I_INUMP (y
))
7230 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7231 scm_remember_upto_here_1 (x
);
7232 return (sgn
< 0) ? y
: x
;
7234 else if (SCM_BIGP (y
))
7236 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7237 scm_remember_upto_here_2 (x
, y
);
7238 return (cmp
> 0) ? x
: y
;
7240 else if (SCM_REALP (y
))
7242 /* if y==NaN then xx>yy is false, so we return the NaN y */
7245 xx
= scm_i_big2dbl (x
);
7246 yy
= SCM_REAL_VALUE (y
);
7247 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7249 else if (SCM_FRACTIONP (y
))
7254 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7256 else if (SCM_REALP (x
))
7258 if (SCM_I_INUMP (y
))
7260 scm_t_inum yy
= SCM_I_INUM (y
);
7261 double xxd
= SCM_REAL_VALUE (x
);
7265 return scm_i_from_double (yyd
);
7266 /* If x is a NaN, then "==" is false and we return the NaN */
7267 else if (SCM_LIKELY (!(xxd
== yyd
)))
7269 /* Handle signed zeroes properly */
7275 else if (SCM_BIGP (y
))
7280 else if (SCM_REALP (y
))
7282 double xx
= SCM_REAL_VALUE (x
);
7283 double yy
= SCM_REAL_VALUE (y
);
7285 /* For purposes of max: nan > +inf.0 > everything else,
7286 per the R6RS errata */
7289 else if (SCM_LIKELY (xx
< yy
))
7291 /* If neither (xx > yy) nor (xx < yy), then
7292 either they're equal or one is a NaN */
7293 else if (SCM_UNLIKELY (xx
!= yy
))
7294 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7295 /* xx == yy, but handle signed zeroes properly */
7296 else if (copysign (1.0, yy
) < 0.0)
7301 else if (SCM_FRACTIONP (y
))
7303 double yy
= scm_i_fraction2double (y
);
7304 double xx
= SCM_REAL_VALUE (x
);
7305 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7308 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7310 else if (SCM_FRACTIONP (x
))
7312 if (SCM_I_INUMP (y
))
7316 else if (SCM_BIGP (y
))
7320 else if (SCM_REALP (y
))
7322 double xx
= scm_i_fraction2double (x
);
7323 /* if y==NaN then ">" is false, so we return the NaN y */
7324 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7326 else if (SCM_FRACTIONP (y
))
7331 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7334 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7338 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7339 (SCM x
, SCM y
, SCM rest
),
7340 "Return the minimum of all parameter values.")
7341 #define FUNC_NAME s_scm_i_min
7343 while (!scm_is_null (rest
))
7344 { x
= scm_min (x
, y
);
7346 rest
= scm_cdr (rest
);
7348 return scm_min (x
, y
);
7352 #define s_min s_scm_i_min
7353 #define g_min g_scm_i_min
7356 scm_min (SCM x
, SCM y
)
7361 return scm_wta_dispatch_0 (g_min
, s_min
);
7362 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7365 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7368 if (SCM_I_INUMP (x
))
7370 scm_t_inum xx
= SCM_I_INUM (x
);
7371 if (SCM_I_INUMP (y
))
7373 scm_t_inum yy
= SCM_I_INUM (y
);
7374 return (xx
< yy
) ? x
: y
;
7376 else if (SCM_BIGP (y
))
7378 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7379 scm_remember_upto_here_1 (y
);
7380 return (sgn
< 0) ? y
: x
;
7382 else if (SCM_REALP (y
))
7385 /* if y==NaN then "<" is false and we return NaN */
7386 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7388 else if (SCM_FRACTIONP (y
))
7391 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7394 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7396 else if (SCM_BIGP (x
))
7398 if (SCM_I_INUMP (y
))
7400 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7401 scm_remember_upto_here_1 (x
);
7402 return (sgn
< 0) ? x
: y
;
7404 else if (SCM_BIGP (y
))
7406 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7407 scm_remember_upto_here_2 (x
, y
);
7408 return (cmp
> 0) ? y
: x
;
7410 else if (SCM_REALP (y
))
7412 /* if y==NaN then xx<yy is false, so we return the NaN y */
7415 xx
= scm_i_big2dbl (x
);
7416 yy
= SCM_REAL_VALUE (y
);
7417 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7419 else if (SCM_FRACTIONP (y
))
7424 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7426 else if (SCM_REALP (x
))
7428 if (SCM_I_INUMP (y
))
7430 double z
= SCM_I_INUM (y
);
7431 /* if x==NaN then "<" is false and we return NaN */
7432 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7434 else if (SCM_BIGP (y
))
7439 else if (SCM_REALP (y
))
7441 double xx
= SCM_REAL_VALUE (x
);
7442 double yy
= SCM_REAL_VALUE (y
);
7444 /* For purposes of min: nan < -inf.0 < everything else,
7445 per the R6RS errata */
7448 else if (SCM_LIKELY (xx
> yy
))
7450 /* If neither (xx < yy) nor (xx > yy), then
7451 either they're equal or one is a NaN */
7452 else if (SCM_UNLIKELY (xx
!= yy
))
7453 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7454 /* xx == yy, but handle signed zeroes properly */
7455 else if (copysign (1.0, xx
) < 0.0)
7460 else if (SCM_FRACTIONP (y
))
7462 double yy
= scm_i_fraction2double (y
);
7463 double xx
= SCM_REAL_VALUE (x
);
7464 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7467 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7469 else if (SCM_FRACTIONP (x
))
7471 if (SCM_I_INUMP (y
))
7475 else if (SCM_BIGP (y
))
7479 else if (SCM_REALP (y
))
7481 double xx
= scm_i_fraction2double (x
);
7482 /* if y==NaN then "<" is false, so we return the NaN y */
7483 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7485 else if (SCM_FRACTIONP (y
))
7490 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7493 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7497 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7498 (SCM x
, SCM y
, SCM rest
),
7499 "Return the sum of all parameter values. Return 0 if called without\n"
7501 #define FUNC_NAME s_scm_i_sum
7503 while (!scm_is_null (rest
))
7504 { x
= scm_sum (x
, y
);
7506 rest
= scm_cdr (rest
);
7508 return scm_sum (x
, y
);
7512 #define s_sum s_scm_i_sum
7513 #define g_sum g_scm_i_sum
7516 scm_sum (SCM x
, SCM y
)
7518 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7520 if (SCM_NUMBERP (x
)) return x
;
7521 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7522 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7525 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7527 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7529 scm_t_inum xx
= SCM_I_INUM (x
);
7530 scm_t_inum yy
= SCM_I_INUM (y
);
7531 scm_t_inum z
= xx
+ yy
;
7532 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7534 else if (SCM_BIGP (y
))
7539 else if (SCM_REALP (y
))
7541 scm_t_inum xx
= SCM_I_INUM (x
);
7542 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7544 else if (SCM_COMPLEXP (y
))
7546 scm_t_inum xx
= SCM_I_INUM (x
);
7547 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7548 SCM_COMPLEX_IMAG (y
));
7550 else if (SCM_FRACTIONP (y
))
7551 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7552 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7553 SCM_FRACTION_DENOMINATOR (y
));
7555 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7556 } else if (SCM_BIGP (x
))
7558 if (SCM_I_INUMP (y
))
7563 inum
= SCM_I_INUM (y
);
7566 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7569 SCM result
= scm_i_mkbig ();
7570 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7571 scm_remember_upto_here_1 (x
);
7572 /* we know the result will have to be a bignum */
7575 return scm_i_normbig (result
);
7579 SCM result
= scm_i_mkbig ();
7580 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7581 scm_remember_upto_here_1 (x
);
7582 /* we know the result will have to be a bignum */
7585 return scm_i_normbig (result
);
7588 else if (SCM_BIGP (y
))
7590 SCM result
= scm_i_mkbig ();
7591 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7592 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7593 mpz_add (SCM_I_BIG_MPZ (result
),
7596 scm_remember_upto_here_2 (x
, y
);
7597 /* we know the result will have to be a bignum */
7600 return scm_i_normbig (result
);
7602 else if (SCM_REALP (y
))
7604 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7605 scm_remember_upto_here_1 (x
);
7606 return scm_i_from_double (result
);
7608 else if (SCM_COMPLEXP (y
))
7610 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7611 + SCM_COMPLEX_REAL (y
));
7612 scm_remember_upto_here_1 (x
);
7613 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7615 else if (SCM_FRACTIONP (y
))
7616 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7617 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7618 SCM_FRACTION_DENOMINATOR (y
));
7620 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7622 else if (SCM_REALP (x
))
7624 if (SCM_I_INUMP (y
))
7625 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7626 else if (SCM_BIGP (y
))
7628 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7629 scm_remember_upto_here_1 (y
);
7630 return scm_i_from_double (result
);
7632 else if (SCM_REALP (y
))
7633 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7634 else if (SCM_COMPLEXP (y
))
7635 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7636 SCM_COMPLEX_IMAG (y
));
7637 else if (SCM_FRACTIONP (y
))
7638 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7640 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7642 else if (SCM_COMPLEXP (x
))
7644 if (SCM_I_INUMP (y
))
7645 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7646 SCM_COMPLEX_IMAG (x
));
7647 else if (SCM_BIGP (y
))
7649 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7650 + SCM_COMPLEX_REAL (x
));
7651 scm_remember_upto_here_1 (y
);
7652 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7654 else if (SCM_REALP (y
))
7655 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7656 SCM_COMPLEX_IMAG (x
));
7657 else if (SCM_COMPLEXP (y
))
7658 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7659 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7660 else if (SCM_FRACTIONP (y
))
7661 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7662 SCM_COMPLEX_IMAG (x
));
7664 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7666 else if (SCM_FRACTIONP (x
))
7668 if (SCM_I_INUMP (y
))
7669 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7670 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7671 SCM_FRACTION_DENOMINATOR (x
));
7672 else if (SCM_BIGP (y
))
7673 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7674 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7675 SCM_FRACTION_DENOMINATOR (x
));
7676 else if (SCM_REALP (y
))
7677 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7678 else if (SCM_COMPLEXP (y
))
7679 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7680 SCM_COMPLEX_IMAG (y
));
7681 else if (SCM_FRACTIONP (y
))
7682 /* a/b + c/d = (ad + bc) / bd */
7683 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7684 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7685 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7687 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7690 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7694 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7696 "Return @math{@var{x}+1}.")
7697 #define FUNC_NAME s_scm_oneplus
7699 return scm_sum (x
, SCM_INUM1
);
7704 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7705 (SCM x
, SCM y
, SCM rest
),
7706 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7707 "the sum of all but the first argument are subtracted from the first\n"
7709 #define FUNC_NAME s_scm_i_difference
7711 while (!scm_is_null (rest
))
7712 { x
= scm_difference (x
, y
);
7714 rest
= scm_cdr (rest
);
7716 return scm_difference (x
, y
);
7720 #define s_difference s_scm_i_difference
7721 #define g_difference g_scm_i_difference
7724 scm_difference (SCM x
, SCM y
)
7725 #define FUNC_NAME s_difference
7727 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7730 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7732 if (SCM_I_INUMP (x
))
7734 scm_t_inum xx
= -SCM_I_INUM (x
);
7735 if (SCM_FIXABLE (xx
))
7736 return SCM_I_MAKINUM (xx
);
7738 return scm_i_inum2big (xx
);
7740 else if (SCM_BIGP (x
))
7741 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7742 bignum, but negating that gives a fixnum. */
7743 return scm_i_normbig (scm_i_clonebig (x
, 0));
7744 else if (SCM_REALP (x
))
7745 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7746 else if (SCM_COMPLEXP (x
))
7747 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7748 -SCM_COMPLEX_IMAG (x
));
7749 else if (SCM_FRACTIONP (x
))
7750 return scm_i_make_ratio_already_reduced
7751 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7752 SCM_FRACTION_DENOMINATOR (x
));
7754 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7757 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7759 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7761 scm_t_inum xx
= SCM_I_INUM (x
);
7762 scm_t_inum yy
= SCM_I_INUM (y
);
7763 scm_t_inum z
= xx
- yy
;
7764 if (SCM_FIXABLE (z
))
7765 return SCM_I_MAKINUM (z
);
7767 return scm_i_inum2big (z
);
7769 else if (SCM_BIGP (y
))
7771 /* inum-x - big-y */
7772 scm_t_inum xx
= SCM_I_INUM (x
);
7776 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7777 bignum, but negating that gives a fixnum. */
7778 return scm_i_normbig (scm_i_clonebig (y
, 0));
7782 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7783 SCM result
= scm_i_mkbig ();
7786 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7789 /* x - y == -(y + -x) */
7790 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7791 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7793 scm_remember_upto_here_1 (y
);
7795 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7796 /* we know the result will have to be a bignum */
7799 return scm_i_normbig (result
);
7802 else if (SCM_REALP (y
))
7804 scm_t_inum xx
= SCM_I_INUM (x
);
7807 * We need to handle x == exact 0
7808 * specially because R6RS states that:
7809 * (- 0.0) ==> -0.0 and
7810 * (- 0.0 0.0) ==> 0.0
7811 * and the scheme compiler changes
7812 * (- 0.0) into (- 0 0.0)
7813 * So we need to treat (- 0 0.0) like (- 0.0).
7814 * At the C level, (-x) is different than (0.0 - x).
7815 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7818 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7820 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7822 else if (SCM_COMPLEXP (y
))
7824 scm_t_inum xx
= SCM_I_INUM (x
);
7826 /* We need to handle x == exact 0 specially.
7827 See the comment above (for SCM_REALP (y)) */
7829 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7830 - SCM_COMPLEX_IMAG (y
));
7832 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7833 - SCM_COMPLEX_IMAG (y
));
7835 else if (SCM_FRACTIONP (y
))
7836 /* a - b/c = (ac - b) / c */
7837 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7838 SCM_FRACTION_NUMERATOR (y
)),
7839 SCM_FRACTION_DENOMINATOR (y
));
7841 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7843 else if (SCM_BIGP (x
))
7845 if (SCM_I_INUMP (y
))
7847 /* big-x - inum-y */
7848 scm_t_inum yy
= SCM_I_INUM (y
);
7849 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7851 scm_remember_upto_here_1 (x
);
7853 return (SCM_FIXABLE (-yy
) ?
7854 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7857 SCM result
= scm_i_mkbig ();
7860 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7862 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7863 scm_remember_upto_here_1 (x
);
7865 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7866 /* we know the result will have to be a bignum */
7869 return scm_i_normbig (result
);
7872 else if (SCM_BIGP (y
))
7874 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7875 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7876 SCM result
= scm_i_mkbig ();
7877 mpz_sub (SCM_I_BIG_MPZ (result
),
7880 scm_remember_upto_here_2 (x
, y
);
7881 /* we know the result will have to be a bignum */
7882 if ((sgn_x
== 1) && (sgn_y
== -1))
7884 if ((sgn_x
== -1) && (sgn_y
== 1))
7886 return scm_i_normbig (result
);
7888 else if (SCM_REALP (y
))
7890 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7891 scm_remember_upto_here_1 (x
);
7892 return scm_i_from_double (result
);
7894 else if (SCM_COMPLEXP (y
))
7896 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7897 - SCM_COMPLEX_REAL (y
));
7898 scm_remember_upto_here_1 (x
);
7899 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7901 else if (SCM_FRACTIONP (y
))
7902 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7903 SCM_FRACTION_NUMERATOR (y
)),
7904 SCM_FRACTION_DENOMINATOR (y
));
7906 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7908 else if (SCM_REALP (x
))
7910 if (SCM_I_INUMP (y
))
7911 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7912 else if (SCM_BIGP (y
))
7914 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7915 scm_remember_upto_here_1 (x
);
7916 return scm_i_from_double (result
);
7918 else if (SCM_REALP (y
))
7919 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7920 else if (SCM_COMPLEXP (y
))
7921 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7922 -SCM_COMPLEX_IMAG (y
));
7923 else if (SCM_FRACTIONP (y
))
7924 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7926 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7928 else if (SCM_COMPLEXP (x
))
7930 if (SCM_I_INUMP (y
))
7931 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7932 SCM_COMPLEX_IMAG (x
));
7933 else if (SCM_BIGP (y
))
7935 double real_part
= (SCM_COMPLEX_REAL (x
)
7936 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7937 scm_remember_upto_here_1 (x
);
7938 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7940 else if (SCM_REALP (y
))
7941 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7942 SCM_COMPLEX_IMAG (x
));
7943 else if (SCM_COMPLEXP (y
))
7944 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7945 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7946 else if (SCM_FRACTIONP (y
))
7947 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7948 SCM_COMPLEX_IMAG (x
));
7950 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7952 else if (SCM_FRACTIONP (x
))
7954 if (SCM_I_INUMP (y
))
7955 /* a/b - c = (a - cb) / b */
7956 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7957 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7958 SCM_FRACTION_DENOMINATOR (x
));
7959 else if (SCM_BIGP (y
))
7960 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7961 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7962 SCM_FRACTION_DENOMINATOR (x
));
7963 else if (SCM_REALP (y
))
7964 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7965 else if (SCM_COMPLEXP (y
))
7966 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7967 -SCM_COMPLEX_IMAG (y
));
7968 else if (SCM_FRACTIONP (y
))
7969 /* a/b - c/d = (ad - bc) / bd */
7970 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7971 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7972 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7974 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7977 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7982 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7984 "Return @math{@var{x}-1}.")
7985 #define FUNC_NAME s_scm_oneminus
7987 return scm_difference (x
, SCM_INUM1
);
7992 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7993 (SCM x
, SCM y
, SCM rest
),
7994 "Return the product of all arguments. If called without arguments,\n"
7996 #define FUNC_NAME s_scm_i_product
7998 while (!scm_is_null (rest
))
7999 { x
= scm_product (x
, y
);
8001 rest
= scm_cdr (rest
);
8003 return scm_product (x
, y
);
8007 #define s_product s_scm_i_product
8008 #define g_product g_scm_i_product
8011 scm_product (SCM x
, SCM y
)
8013 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8016 return SCM_I_MAKINUM (1L);
8017 else if (SCM_NUMBERP (x
))
8020 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
8023 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8028 xx
= SCM_I_INUM (x
);
8033 /* exact1 is the universal multiplicative identity */
8037 /* exact0 times a fixnum is exact0: optimize this case */
8038 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8040 /* if the other argument is inexact, the result is inexact,
8041 and we must do the multiplication in order to handle
8042 infinities and NaNs properly. */
8043 else if (SCM_REALP (y
))
8044 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8045 else if (SCM_COMPLEXP (y
))
8046 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8047 0.0 * SCM_COMPLEX_IMAG (y
));
8048 /* we've already handled inexact numbers,
8049 so y must be exact, and we return exact0 */
8050 else if (SCM_NUMP (y
))
8053 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8057 * This case is important for more than just optimization.
8058 * It handles the case of negating
8059 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8060 * which is a bignum that must be changed back into a fixnum.
8061 * Failure to do so will cause the following to return #f:
8062 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8064 return scm_difference(y
, SCM_UNDEFINED
);
8068 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8070 scm_t_inum yy
= SCM_I_INUM (y
);
8071 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8072 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8073 if (SCM_FIXABLE (kk
))
8074 return SCM_I_MAKINUM (kk
);
8076 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8077 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8078 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8079 return SCM_I_MAKINUM (xx
* yy
);
8083 SCM result
= scm_i_inum2big (xx
);
8084 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8085 return scm_i_normbig (result
);
8088 else if (SCM_BIGP (y
))
8090 SCM result
= scm_i_mkbig ();
8091 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8092 scm_remember_upto_here_1 (y
);
8095 else if (SCM_REALP (y
))
8096 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8097 else if (SCM_COMPLEXP (y
))
8098 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8099 xx
* SCM_COMPLEX_IMAG (y
));
8100 else if (SCM_FRACTIONP (y
))
8101 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8102 SCM_FRACTION_DENOMINATOR (y
));
8104 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8106 else if (SCM_BIGP (x
))
8108 if (SCM_I_INUMP (y
))
8113 else if (SCM_BIGP (y
))
8115 SCM result
= scm_i_mkbig ();
8116 mpz_mul (SCM_I_BIG_MPZ (result
),
8119 scm_remember_upto_here_2 (x
, y
);
8122 else if (SCM_REALP (y
))
8124 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8125 scm_remember_upto_here_1 (x
);
8126 return scm_i_from_double (result
);
8128 else if (SCM_COMPLEXP (y
))
8130 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8131 scm_remember_upto_here_1 (x
);
8132 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8133 z
* SCM_COMPLEX_IMAG (y
));
8135 else if (SCM_FRACTIONP (y
))
8136 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8137 SCM_FRACTION_DENOMINATOR (y
));
8139 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8141 else if (SCM_REALP (x
))
8143 if (SCM_I_INUMP (y
))
8148 else if (SCM_BIGP (y
))
8150 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8151 scm_remember_upto_here_1 (y
);
8152 return scm_i_from_double (result
);
8154 else if (SCM_REALP (y
))
8155 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8156 else if (SCM_COMPLEXP (y
))
8157 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8158 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8159 else if (SCM_FRACTIONP (y
))
8160 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8162 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8164 else if (SCM_COMPLEXP (x
))
8166 if (SCM_I_INUMP (y
))
8171 else if (SCM_BIGP (y
))
8173 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8174 scm_remember_upto_here_1 (y
);
8175 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8176 z
* SCM_COMPLEX_IMAG (x
));
8178 else if (SCM_REALP (y
))
8179 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8180 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8181 else if (SCM_COMPLEXP (y
))
8183 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8184 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8185 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8186 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8188 else if (SCM_FRACTIONP (y
))
8190 double yy
= scm_i_fraction2double (y
);
8191 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8192 yy
* SCM_COMPLEX_IMAG (x
));
8195 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8197 else if (SCM_FRACTIONP (x
))
8199 if (SCM_I_INUMP (y
))
8200 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8201 SCM_FRACTION_DENOMINATOR (x
));
8202 else if (SCM_BIGP (y
))
8203 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8204 SCM_FRACTION_DENOMINATOR (x
));
8205 else if (SCM_REALP (y
))
8206 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8207 else if (SCM_COMPLEXP (y
))
8209 double xx
= scm_i_fraction2double (x
);
8210 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8211 xx
* SCM_COMPLEX_IMAG (y
));
8213 else if (SCM_FRACTIONP (y
))
8214 /* a/b * c/d = ac / bd */
8215 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8216 SCM_FRACTION_NUMERATOR (y
)),
8217 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8218 SCM_FRACTION_DENOMINATOR (y
)));
8220 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8223 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8226 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8227 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8228 #define ALLOW_DIVIDE_BY_ZERO
8229 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8232 /* The code below for complex division is adapted from the GNU
8233 libstdc++, which adapted it from f2c's libF77, and is subject to
8236 /****************************************************************
8237 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8239 Permission to use, copy, modify, and distribute this software
8240 and its documentation for any purpose and without fee is hereby
8241 granted, provided that the above copyright notice appear in all
8242 copies and that both that the copyright notice and this
8243 permission notice and warranty disclaimer appear in supporting
8244 documentation, and that the names of AT&T Bell Laboratories or
8245 Bellcore or any of their entities not be used in advertising or
8246 publicity pertaining to distribution of the software without
8247 specific, written prior permission.
8249 AT&T and Bellcore disclaim all warranties with regard to this
8250 software, including all implied warranties of merchantability
8251 and fitness. In no event shall AT&T or Bellcore be liable for
8252 any special, indirect or consequential damages or any damages
8253 whatsoever resulting from loss of use, data or profits, whether
8254 in an action of contract, negligence or other tortious action,
8255 arising out of or in connection with the use or performance of
8257 ****************************************************************/
8259 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8260 (SCM x
, SCM y
, SCM rest
),
8261 "Divide the first argument by the product of the remaining\n"
8262 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8264 #define FUNC_NAME s_scm_i_divide
8266 while (!scm_is_null (rest
))
8267 { x
= scm_divide (x
, y
);
8269 rest
= scm_cdr (rest
);
8271 return scm_divide (x
, y
);
8275 #define s_divide s_scm_i_divide
8276 #define g_divide g_scm_i_divide
8279 scm_divide (SCM x
, SCM y
)
8280 #define FUNC_NAME s_divide
8284 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8287 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8288 else if (SCM_I_INUMP (x
))
8290 scm_t_inum xx
= SCM_I_INUM (x
);
8291 if (xx
== 1 || xx
== -1)
8293 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8295 scm_num_overflow (s_divide
);
8298 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8300 else if (SCM_BIGP (x
))
8301 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8302 else if (SCM_REALP (x
))
8304 double xx
= SCM_REAL_VALUE (x
);
8305 #ifndef ALLOW_DIVIDE_BY_ZERO
8307 scm_num_overflow (s_divide
);
8310 return scm_i_from_double (1.0 / xx
);
8312 else if (SCM_COMPLEXP (x
))
8314 double r
= SCM_COMPLEX_REAL (x
);
8315 double i
= SCM_COMPLEX_IMAG (x
);
8316 if (fabs(r
) <= fabs(i
))
8319 double d
= i
* (1.0 + t
* t
);
8320 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8325 double d
= r
* (1.0 + t
* t
);
8326 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8329 else if (SCM_FRACTIONP (x
))
8330 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8331 SCM_FRACTION_NUMERATOR (x
));
8333 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8336 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8338 scm_t_inum xx
= SCM_I_INUM (x
);
8339 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8341 scm_t_inum yy
= SCM_I_INUM (y
);
8344 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8345 scm_num_overflow (s_divide
);
8347 return scm_i_from_double ((double) xx
/ (double) yy
);
8350 else if (xx
% yy
!= 0)
8351 return scm_i_make_ratio (x
, y
);
8354 scm_t_inum z
= xx
/ yy
;
8355 if (SCM_FIXABLE (z
))
8356 return SCM_I_MAKINUM (z
);
8358 return scm_i_inum2big (z
);
8361 else if (SCM_BIGP (y
))
8362 return scm_i_make_ratio (x
, y
);
8363 else if (SCM_REALP (y
))
8365 double yy
= SCM_REAL_VALUE (y
);
8366 #ifndef ALLOW_DIVIDE_BY_ZERO
8368 scm_num_overflow (s_divide
);
8371 /* FIXME: Precision may be lost here due to:
8372 (1) The cast from 'scm_t_inum' to 'double'
8373 (2) Double rounding */
8374 return scm_i_from_double ((double) xx
/ yy
);
8376 else if (SCM_COMPLEXP (y
))
8379 complex_div
: /* y _must_ be a complex number */
8381 double r
= SCM_COMPLEX_REAL (y
);
8382 double i
= SCM_COMPLEX_IMAG (y
);
8383 if (fabs(r
) <= fabs(i
))
8386 double d
= i
* (1.0 + t
* t
);
8387 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8392 double d
= r
* (1.0 + t
* t
);
8393 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8397 else if (SCM_FRACTIONP (y
))
8398 /* a / b/c = ac / b */
8399 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8400 SCM_FRACTION_NUMERATOR (y
));
8402 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8404 else if (SCM_BIGP (x
))
8406 if (SCM_I_INUMP (y
))
8408 scm_t_inum yy
= SCM_I_INUM (y
);
8411 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8412 scm_num_overflow (s_divide
);
8414 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8415 scm_remember_upto_here_1 (x
);
8416 return (sgn
== 0) ? scm_nan () : scm_inf ();
8423 /* FIXME: HMM, what are the relative performance issues here?
8424 We need to test. Is it faster on average to test
8425 divisible_p, then perform whichever operation, or is it
8426 faster to perform the integer div opportunistically and
8427 switch to real if there's a remainder? For now we take the
8428 middle ground: test, then if divisible, use the faster div
8431 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8432 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8436 SCM result
= scm_i_mkbig ();
8437 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8438 scm_remember_upto_here_1 (x
);
8440 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8441 return scm_i_normbig (result
);
8444 return scm_i_make_ratio (x
, y
);
8447 else if (SCM_BIGP (y
))
8449 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8453 SCM result
= scm_i_mkbig ();
8454 mpz_divexact (SCM_I_BIG_MPZ (result
),
8457 scm_remember_upto_here_2 (x
, y
);
8458 return scm_i_normbig (result
);
8461 return scm_i_make_ratio (x
, y
);
8463 else if (SCM_REALP (y
))
8465 double yy
= SCM_REAL_VALUE (y
);
8466 #ifndef ALLOW_DIVIDE_BY_ZERO
8468 scm_num_overflow (s_divide
);
8471 /* FIXME: Precision may be lost here due to:
8472 (1) scm_i_big2dbl (2) Double rounding */
8473 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8475 else if (SCM_COMPLEXP (y
))
8477 a
= scm_i_big2dbl (x
);
8480 else if (SCM_FRACTIONP (y
))
8481 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8482 SCM_FRACTION_NUMERATOR (y
));
8484 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8486 else if (SCM_REALP (x
))
8488 double rx
= SCM_REAL_VALUE (x
);
8489 if (SCM_I_INUMP (y
))
8491 scm_t_inum yy
= SCM_I_INUM (y
);
8492 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8494 scm_num_overflow (s_divide
);
8497 /* FIXME: Precision may be lost here due to:
8498 (1) The cast from 'scm_t_inum' to 'double'
8499 (2) Double rounding */
8500 return scm_i_from_double (rx
/ (double) yy
);
8502 else if (SCM_BIGP (y
))
8504 /* FIXME: Precision may be lost here due to:
8505 (1) The conversion from bignum to double
8506 (2) Double rounding */
8507 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8508 scm_remember_upto_here_1 (y
);
8509 return scm_i_from_double (rx
/ dby
);
8511 else if (SCM_REALP (y
))
8513 double yy
= SCM_REAL_VALUE (y
);
8514 #ifndef ALLOW_DIVIDE_BY_ZERO
8516 scm_num_overflow (s_divide
);
8519 return scm_i_from_double (rx
/ yy
);
8521 else if (SCM_COMPLEXP (y
))
8526 else if (SCM_FRACTIONP (y
))
8527 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8529 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8531 else if (SCM_COMPLEXP (x
))
8533 double rx
= SCM_COMPLEX_REAL (x
);
8534 double ix
= SCM_COMPLEX_IMAG (x
);
8535 if (SCM_I_INUMP (y
))
8537 scm_t_inum yy
= SCM_I_INUM (y
);
8538 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8540 scm_num_overflow (s_divide
);
8544 /* FIXME: Precision may be lost here due to:
8545 (1) The conversion from 'scm_t_inum' to double
8546 (2) Double rounding */
8548 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8551 else if (SCM_BIGP (y
))
8553 /* FIXME: Precision may be lost here due to:
8554 (1) The conversion from bignum to double
8555 (2) Double rounding */
8556 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8557 scm_remember_upto_here_1 (y
);
8558 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8560 else if (SCM_REALP (y
))
8562 double yy
= SCM_REAL_VALUE (y
);
8563 #ifndef ALLOW_DIVIDE_BY_ZERO
8565 scm_num_overflow (s_divide
);
8568 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8570 else if (SCM_COMPLEXP (y
))
8572 double ry
= SCM_COMPLEX_REAL (y
);
8573 double iy
= SCM_COMPLEX_IMAG (y
);
8574 if (fabs(ry
) <= fabs(iy
))
8577 double d
= iy
* (1.0 + t
* t
);
8578 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8583 double d
= ry
* (1.0 + t
* t
);
8584 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8587 else if (SCM_FRACTIONP (y
))
8589 /* FIXME: Precision may be lost here due to:
8590 (1) The conversion from fraction to double
8591 (2) Double rounding */
8592 double yy
= scm_i_fraction2double (y
);
8593 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8596 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8598 else if (SCM_FRACTIONP (x
))
8600 if (SCM_I_INUMP (y
))
8602 scm_t_inum yy
= SCM_I_INUM (y
);
8603 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8605 scm_num_overflow (s_divide
);
8608 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8609 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8611 else if (SCM_BIGP (y
))
8613 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8614 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8616 else if (SCM_REALP (y
))
8618 double yy
= SCM_REAL_VALUE (y
);
8619 #ifndef ALLOW_DIVIDE_BY_ZERO
8621 scm_num_overflow (s_divide
);
8624 /* FIXME: Precision may be lost here due to:
8625 (1) The conversion from fraction to double
8626 (2) Double rounding */
8627 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8629 else if (SCM_COMPLEXP (y
))
8631 /* FIXME: Precision may be lost here due to:
8632 (1) The conversion from fraction to double
8633 (2) Double rounding */
8634 a
= scm_i_fraction2double (x
);
8637 else if (SCM_FRACTIONP (y
))
8638 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8639 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8641 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8644 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8650 scm_c_truncate (double x
)
8655 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8656 half-way case (ie. when x is an integer plus 0.5) going upwards.
8657 Then half-way cases are identified and adjusted down if the
8658 round-upwards didn't give the desired even integer.
8660 "plus_half == result" identifies a half-way case. If plus_half, which is
8661 x + 0.5, is an integer then x must be an integer plus 0.5.
8663 An odd "result" value is identified with result/2 != floor(result/2).
8664 This is done with plus_half, since that value is ready for use sooner in
8665 a pipelined cpu, and we're already requiring plus_half == result.
8667 Note however that we need to be careful when x is big and already an
8668 integer. In that case "x+0.5" may round to an adjacent integer, causing
8669 us to return such a value, incorrectly. For instance if the hardware is
8670 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8671 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8672 returned. Or if the hardware is in round-upwards mode, then other bigger
8673 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8674 representable value, 2^128+2^76 (or whatever), again incorrect.
8676 These bad roundings of x+0.5 are avoided by testing at the start whether
8677 x is already an integer. If it is then clearly that's the desired result
8678 already. And if it's not then the exponent must be small enough to allow
8679 an 0.5 to be represented, and hence added without a bad rounding. */
8682 scm_c_round (double x
)
8684 double plus_half
, result
;
8689 plus_half
= x
+ 0.5;
8690 result
= floor (plus_half
);
8691 /* Adjust so that the rounding is towards even. */
8692 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8697 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8699 "Round the number @var{x} towards zero.")
8700 #define FUNC_NAME s_scm_truncate_number
8702 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8704 else if (SCM_REALP (x
))
8705 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8706 else if (SCM_FRACTIONP (x
))
8707 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8708 SCM_FRACTION_DENOMINATOR (x
));
8710 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8711 s_scm_truncate_number
);
8715 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8717 "Round the number @var{x} towards the nearest integer. "
8718 "When it is exactly halfway between two integers, "
8719 "round towards the even one.")
8720 #define FUNC_NAME s_scm_round_number
8722 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8724 else if (SCM_REALP (x
))
8725 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8726 else if (SCM_FRACTIONP (x
))
8727 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8728 SCM_FRACTION_DENOMINATOR (x
));
8730 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8731 s_scm_round_number
);
8735 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8737 "Round the number @var{x} towards minus infinity.")
8738 #define FUNC_NAME s_scm_floor
8740 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8742 else if (SCM_REALP (x
))
8743 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8744 else if (SCM_FRACTIONP (x
))
8745 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8746 SCM_FRACTION_DENOMINATOR (x
));
8748 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8752 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8754 "Round the number @var{x} towards infinity.")
8755 #define FUNC_NAME s_scm_ceiling
8757 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8759 else if (SCM_REALP (x
))
8760 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8761 else if (SCM_FRACTIONP (x
))
8762 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8763 SCM_FRACTION_DENOMINATOR (x
));
8765 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8769 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8771 "Return @var{x} raised to the power of @var{y}.")
8772 #define FUNC_NAME s_scm_expt
8774 if (scm_is_integer (y
))
8776 if (scm_is_true (scm_exact_p (y
)))
8777 return scm_integer_expt (x
, y
);
8780 /* Here we handle the case where the exponent is an inexact
8781 integer. We make the exponent exact in order to use
8782 scm_integer_expt, and thus avoid the spurious imaginary
8783 parts that may result from round-off errors in the general
8784 e^(y log x) method below (for example when squaring a large
8785 negative number). In this case, we must return an inexact
8786 result for correctness. We also make the base inexact so
8787 that scm_integer_expt will use fast inexact arithmetic
8788 internally. Note that making the base inexact is not
8789 sufficient to guarantee an inexact result, because
8790 scm_integer_expt will return an exact 1 when the exponent
8791 is 0, even if the base is inexact. */
8792 return scm_exact_to_inexact
8793 (scm_integer_expt (scm_exact_to_inexact (x
),
8794 scm_inexact_to_exact (y
)));
8797 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8799 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8801 else if (scm_is_complex (x
) && scm_is_complex (y
))
8802 return scm_exp (scm_product (scm_log (x
), y
));
8803 else if (scm_is_complex (x
))
8804 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8806 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8810 /* sin/cos/tan/asin/acos/atan
8811 sinh/cosh/tanh/asinh/acosh/atanh
8812 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8813 Written by Jerry D. Hedden, (C) FSF.
8814 See the file `COPYING' for terms applying to this program. */
8816 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8818 "Compute the sine of @var{z}.")
8819 #define FUNC_NAME s_scm_sin
8821 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8822 return z
; /* sin(exact0) = exact0 */
8823 else if (scm_is_real (z
))
8824 return scm_i_from_double (sin (scm_to_double (z
)));
8825 else if (SCM_COMPLEXP (z
))
8827 x
= SCM_COMPLEX_REAL (z
);
8828 y
= SCM_COMPLEX_IMAG (z
);
8829 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8830 cos (x
) * sinh (y
));
8833 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8837 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8839 "Compute the cosine of @var{z}.")
8840 #define FUNC_NAME s_scm_cos
8842 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8843 return SCM_INUM1
; /* cos(exact0) = exact1 */
8844 else if (scm_is_real (z
))
8845 return scm_i_from_double (cos (scm_to_double (z
)));
8846 else if (SCM_COMPLEXP (z
))
8848 x
= SCM_COMPLEX_REAL (z
);
8849 y
= SCM_COMPLEX_IMAG (z
);
8850 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8851 -sin (x
) * sinh (y
));
8854 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8858 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8860 "Compute the tangent of @var{z}.")
8861 #define FUNC_NAME s_scm_tan
8863 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8864 return z
; /* tan(exact0) = exact0 */
8865 else if (scm_is_real (z
))
8866 return scm_i_from_double (tan (scm_to_double (z
)));
8867 else if (SCM_COMPLEXP (z
))
8869 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8870 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8871 w
= cos (x
) + cosh (y
);
8872 #ifndef ALLOW_DIVIDE_BY_ZERO
8874 scm_num_overflow (s_scm_tan
);
8876 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8879 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8883 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8885 "Compute the hyperbolic sine of @var{z}.")
8886 #define FUNC_NAME s_scm_sinh
8888 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8889 return z
; /* sinh(exact0) = exact0 */
8890 else if (scm_is_real (z
))
8891 return scm_i_from_double (sinh (scm_to_double (z
)));
8892 else if (SCM_COMPLEXP (z
))
8894 x
= SCM_COMPLEX_REAL (z
);
8895 y
= SCM_COMPLEX_IMAG (z
);
8896 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8897 cosh (x
) * sin (y
));
8900 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8904 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8906 "Compute the hyperbolic cosine of @var{z}.")
8907 #define FUNC_NAME s_scm_cosh
8909 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8910 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8911 else if (scm_is_real (z
))
8912 return scm_i_from_double (cosh (scm_to_double (z
)));
8913 else if (SCM_COMPLEXP (z
))
8915 x
= SCM_COMPLEX_REAL (z
);
8916 y
= SCM_COMPLEX_IMAG (z
);
8917 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8918 sinh (x
) * sin (y
));
8921 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8925 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8927 "Compute the hyperbolic tangent of @var{z}.")
8928 #define FUNC_NAME s_scm_tanh
8930 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8931 return z
; /* tanh(exact0) = exact0 */
8932 else if (scm_is_real (z
))
8933 return scm_i_from_double (tanh (scm_to_double (z
)));
8934 else if (SCM_COMPLEXP (z
))
8936 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8937 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8938 w
= cosh (x
) + cos (y
);
8939 #ifndef ALLOW_DIVIDE_BY_ZERO
8941 scm_num_overflow (s_scm_tanh
);
8943 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8946 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8950 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8952 "Compute the arc sine of @var{z}.")
8953 #define FUNC_NAME s_scm_asin
8955 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8956 return z
; /* asin(exact0) = exact0 */
8957 else if (scm_is_real (z
))
8959 double w
= scm_to_double (z
);
8960 if (w
>= -1.0 && w
<= 1.0)
8961 return scm_i_from_double (asin (w
));
8963 return scm_product (scm_c_make_rectangular (0, -1),
8964 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8966 else if (SCM_COMPLEXP (z
))
8968 x
= SCM_COMPLEX_REAL (z
);
8969 y
= SCM_COMPLEX_IMAG (z
);
8970 return scm_product (scm_c_make_rectangular (0, -1),
8971 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8974 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8978 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8980 "Compute the arc cosine of @var{z}.")
8981 #define FUNC_NAME s_scm_acos
8983 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8984 return SCM_INUM0
; /* acos(exact1) = exact0 */
8985 else if (scm_is_real (z
))
8987 double w
= scm_to_double (z
);
8988 if (w
>= -1.0 && w
<= 1.0)
8989 return scm_i_from_double (acos (w
));
8991 return scm_sum (scm_i_from_double (acos (0.0)),
8992 scm_product (scm_c_make_rectangular (0, 1),
8993 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8995 else if (SCM_COMPLEXP (z
))
8997 x
= SCM_COMPLEX_REAL (z
);
8998 y
= SCM_COMPLEX_IMAG (z
);
8999 return scm_sum (scm_i_from_double (acos (0.0)),
9000 scm_product (scm_c_make_rectangular (0, 1),
9001 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
9004 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
9008 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
9010 "With one argument, compute the arc tangent of @var{z}.\n"
9011 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
9012 "using the sign of @var{z} and @var{y} to determine the quadrant.")
9013 #define FUNC_NAME s_scm_atan
9017 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9018 return z
; /* atan(exact0) = exact0 */
9019 else if (scm_is_real (z
))
9020 return scm_i_from_double (atan (scm_to_double (z
)));
9021 else if (SCM_COMPLEXP (z
))
9024 v
= SCM_COMPLEX_REAL (z
);
9025 w
= SCM_COMPLEX_IMAG (z
);
9026 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
9027 scm_c_make_rectangular (v
, w
+ 1.0))),
9028 scm_c_make_rectangular (0, 2));
9031 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
9033 else if (scm_is_real (z
))
9035 if (scm_is_real (y
))
9036 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9038 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9041 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9045 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9047 "Compute the inverse hyperbolic sine of @var{z}.")
9048 #define FUNC_NAME s_scm_sys_asinh
9050 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9051 return z
; /* asinh(exact0) = exact0 */
9052 else if (scm_is_real (z
))
9053 return scm_i_from_double (asinh (scm_to_double (z
)));
9054 else if (scm_is_number (z
))
9055 return scm_log (scm_sum (z
,
9056 scm_sqrt (scm_sum (scm_product (z
, z
),
9059 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9063 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9065 "Compute the inverse hyperbolic cosine of @var{z}.")
9066 #define FUNC_NAME s_scm_sys_acosh
9068 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9069 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9070 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9071 return scm_i_from_double (acosh (scm_to_double (z
)));
9072 else if (scm_is_number (z
))
9073 return scm_log (scm_sum (z
,
9074 scm_sqrt (scm_difference (scm_product (z
, z
),
9077 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9081 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9083 "Compute the inverse hyperbolic tangent of @var{z}.")
9084 #define FUNC_NAME s_scm_sys_atanh
9086 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9087 return z
; /* atanh(exact0) = exact0 */
9088 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9089 return scm_i_from_double (atanh (scm_to_double (z
)));
9090 else if (scm_is_number (z
))
9091 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9092 scm_difference (SCM_INUM1
, z
))),
9095 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9100 scm_c_make_rectangular (double re
, double im
)
9104 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9106 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9107 SCM_COMPLEX_REAL (z
) = re
;
9108 SCM_COMPLEX_IMAG (z
) = im
;
9112 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9113 (SCM real_part
, SCM imaginary_part
),
9114 "Return a complex number constructed of the given @var{real_part} "
9115 "and @var{imaginary_part} parts.")
9116 #define FUNC_NAME s_scm_make_rectangular
9118 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9119 SCM_ARG1
, FUNC_NAME
, "real");
9120 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9121 SCM_ARG2
, FUNC_NAME
, "real");
9123 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9124 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9127 return scm_c_make_rectangular (scm_to_double (real_part
),
9128 scm_to_double (imaginary_part
));
9133 scm_c_make_polar (double mag
, double ang
)
9137 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9138 use it on Glibc-based systems that have it (it's a GNU extension). See
9139 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9141 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9142 sincos (ang
, &s
, &c
);
9148 /* If s and c are NaNs, this indicates that the angle is a NaN,
9149 infinite, or perhaps simply too large to determine its value
9150 mod 2*pi. However, we know something that the floating-point
9151 implementation doesn't know: We know that s and c are finite.
9152 Therefore, if the magnitude is zero, return a complex zero.
9154 The reason we check for the NaNs instead of using this case
9155 whenever mag == 0.0 is because when the angle is known, we'd
9156 like to return the correct kind of non-real complex zero:
9157 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9158 on which quadrant the angle is in.
9160 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9161 return scm_c_make_rectangular (0.0, 0.0);
9163 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9166 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9168 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9169 #define FUNC_NAME s_scm_make_polar
9171 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9172 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9174 /* If mag is exact0, return exact0 */
9175 if (scm_is_eq (mag
, SCM_INUM0
))
9177 /* Return a real if ang is exact0 */
9178 else if (scm_is_eq (ang
, SCM_INUM0
))
9181 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9186 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9188 "Return the real part of the number @var{z}.")
9189 #define FUNC_NAME s_scm_real_part
9191 if (SCM_COMPLEXP (z
))
9192 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9193 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9196 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9201 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9203 "Return the imaginary part of the number @var{z}.")
9204 #define FUNC_NAME s_scm_imag_part
9206 if (SCM_COMPLEXP (z
))
9207 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9208 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9211 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9215 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9217 "Return the numerator of the number @var{z}.")
9218 #define FUNC_NAME s_scm_numerator
9220 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9222 else if (SCM_FRACTIONP (z
))
9223 return SCM_FRACTION_NUMERATOR (z
);
9224 else if (SCM_REALP (z
))
9226 double zz
= SCM_REAL_VALUE (z
);
9227 if (zz
== floor (zz
))
9228 /* Handle -0.0 and infinities in accordance with R6RS
9229 flnumerator, and optimize handling of integers. */
9232 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9235 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9240 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9242 "Return the denominator of the number @var{z}.")
9243 #define FUNC_NAME s_scm_denominator
9245 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9247 else if (SCM_FRACTIONP (z
))
9248 return SCM_FRACTION_DENOMINATOR (z
);
9249 else if (SCM_REALP (z
))
9251 double zz
= SCM_REAL_VALUE (z
);
9252 if (zz
== floor (zz
))
9253 /* Handle infinities in accordance with R6RS fldenominator, and
9254 optimize handling of integers. */
9255 return scm_i_from_double (1.0);
9257 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9260 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9266 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9268 "Return the magnitude of the number @var{z}. This is the same as\n"
9269 "@code{abs} for real arguments, but also allows complex numbers.")
9270 #define FUNC_NAME s_scm_magnitude
9272 if (SCM_I_INUMP (z
))
9274 scm_t_inum zz
= SCM_I_INUM (z
);
9277 else if (SCM_POSFIXABLE (-zz
))
9278 return SCM_I_MAKINUM (-zz
);
9280 return scm_i_inum2big (-zz
);
9282 else if (SCM_BIGP (z
))
9284 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9285 scm_remember_upto_here_1 (z
);
9287 return scm_i_clonebig (z
, 0);
9291 else if (SCM_REALP (z
))
9292 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9293 else if (SCM_COMPLEXP (z
))
9294 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9295 else if (SCM_FRACTIONP (z
))
9297 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9299 return scm_i_make_ratio_already_reduced
9300 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9301 SCM_FRACTION_DENOMINATOR (z
));
9304 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9310 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9312 "Return the angle of the complex number @var{z}.")
9313 #define FUNC_NAME s_scm_angle
9315 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9316 flo0 to save allocating a new flonum with scm_i_from_double each time.
9317 But if atan2 follows the floating point rounding mode, then the value
9318 is not a constant. Maybe it'd be close enough though. */
9319 if (SCM_I_INUMP (z
))
9321 if (SCM_I_INUM (z
) >= 0)
9324 return scm_i_from_double (atan2 (0.0, -1.0));
9326 else if (SCM_BIGP (z
))
9328 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9329 scm_remember_upto_here_1 (z
);
9331 return scm_i_from_double (atan2 (0.0, -1.0));
9335 else if (SCM_REALP (z
))
9337 double x
= SCM_REAL_VALUE (z
);
9338 if (copysign (1.0, x
) > 0.0)
9341 return scm_i_from_double (atan2 (0.0, -1.0));
9343 else if (SCM_COMPLEXP (z
))
9344 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9345 else if (SCM_FRACTIONP (z
))
9347 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9349 else return scm_i_from_double (atan2 (0.0, -1.0));
9352 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9357 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9359 "Convert the number @var{z} to its inexact representation.\n")
9360 #define FUNC_NAME s_scm_exact_to_inexact
9362 if (SCM_I_INUMP (z
))
9363 return scm_i_from_double ((double) SCM_I_INUM (z
));
9364 else if (SCM_BIGP (z
))
9365 return scm_i_from_double (scm_i_big2dbl (z
));
9366 else if (SCM_FRACTIONP (z
))
9367 return scm_i_from_double (scm_i_fraction2double (z
));
9368 else if (SCM_INEXACTP (z
))
9371 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9372 s_scm_exact_to_inexact
);
9377 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9379 "Return an exact number that is numerically closest to @var{z}.")
9380 #define FUNC_NAME s_scm_inexact_to_exact
9382 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9389 val
= SCM_REAL_VALUE (z
);
9390 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9391 val
= SCM_COMPLEX_REAL (z
);
9393 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9394 s_scm_inexact_to_exact
);
9396 if (!SCM_LIKELY (isfinite (val
)))
9397 SCM_OUT_OF_RANGE (1, z
);
9398 else if (val
== 0.0)
9405 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9407 expon
-= DBL_MANT_DIG
;
9410 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9414 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9415 SCM_I_BIG_MPZ (numerator
),
9419 numerator
= scm_i_normbig (numerator
);
9421 return scm_i_make_ratio_already_reduced
9422 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9424 return left_shift_exact_integer (numerator
, expon
);
9432 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9434 "Returns the @emph{simplest} rational number differing\n"
9435 "from @var{x} by no more than @var{eps}.\n"
9437 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9438 "exact result when both its arguments are exact. Thus, you might need\n"
9439 "to use @code{inexact->exact} on the arguments.\n"
9442 "(rationalize (inexact->exact 1.2) 1/100)\n"
9445 #define FUNC_NAME s_scm_rationalize
9447 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9448 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9450 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9452 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9454 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9459 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9462 return scm_exact_to_inexact
9463 (scm_rationalize (scm_inexact_to_exact (x
),
9464 scm_inexact_to_exact (eps
)));
9468 /* X and EPS are exact rationals.
9470 The code that follows is equivalent to the following Scheme code:
9472 (define (exact-rationalize x eps)
9473 (let ((n1 (if (negative? x) -1 1))
9476 (let ((lo (- x eps))
9480 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9481 (nhi (numerator hi)) (dhi (denominator hi))
9482 (n1 n1) (d1 0) (n2 0) (d2 1))
9483 (let-values (((qlo rlo) (floor/ nlo dlo))
9484 ((qhi rhi) (floor/ nhi dhi)))
9485 (let ((n0 (+ n2 (* n1 qlo)))
9486 (d0 (+ d2 (* d1 qlo))))
9487 (cond ((zero? rlo) (/ n0 d0))
9488 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9489 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9495 eps
= scm_abs (eps
);
9496 if (scm_is_true (scm_negative_p (x
)))
9499 x
= scm_difference (x
, SCM_UNDEFINED
);
9502 /* X and EPS are non-negative exact rationals. */
9504 lo
= scm_difference (x
, eps
);
9505 hi
= scm_sum (x
, eps
);
9507 if (scm_is_false (scm_positive_p (lo
)))
9508 /* If zero is included in the interval, return it.
9509 It is the simplest rational of all. */
9514 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9515 mpz_t nlo
, dlo
, nhi
, dhi
;
9516 mpz_t qlo
, rlo
, qhi
, rhi
;
9518 /* LO and HI are positive exact rationals. */
9520 /* Our approach here follows the method described by Alan
9521 Bawden in a message entitled "(rationalize x y)" on the
9522 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9524 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9526 In brief, we compute the continued fractions of the two
9527 endpoints of the interval (LO and HI). The continued
9528 fraction of the result consists of the common prefix of the
9529 continued fractions of LO and HI, plus one final term. The
9530 final term of the result is the smallest integer contained
9531 in the interval between the remainders of LO and HI after
9532 the common prefix has been removed.
9534 The following code lazily computes the continued fraction
9535 representations of LO and HI, and simultaneously converts
9536 the continued fraction of the result into a rational
9537 number. We use MPZ functions directly to avoid type
9538 dispatch and GC allocation during the loop. */
9540 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9545 /* The variables N1, D1, N2 and D2 are used to compute the
9546 resulting rational from its continued fraction. At each
9547 step, N2/D2 and N1/D1 are the last two convergents. They
9548 are normally initialized to 0/1 and 1/0, respectively.
9549 However, if we negated X then we must negate the result as
9550 well, and we do that by initializing N1/D1 to -1/0. */
9551 mpz_set_si (n1
, n1_init
);
9556 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9557 compute the continued fraction representations of LO and HI
9558 using Euclid's algorithm. Initially, NLO/DLO == LO and
9560 scm_to_mpz (scm_numerator (lo
), nlo
);
9561 scm_to_mpz (scm_denominator (lo
), dlo
);
9562 scm_to_mpz (scm_numerator (hi
), nhi
);
9563 scm_to_mpz (scm_denominator (hi
), dhi
);
9565 /* As long as we're using exact arithmetic, the following loop
9566 is guaranteed to terminate. */
9569 /* Compute the next terms (QLO and QHI) of the continued
9570 fractions of LO and HI. */
9571 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9572 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9574 /* The next term of the result will be either QLO or
9575 QLO+1. Here we compute the next convergent of the
9576 result based on the assumption that QLO is the next
9577 term. If that turns out to be wrong, we'll adjust
9578 these later by adding N1 to N0 and D1 to D0. */
9579 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9580 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9582 /* We stop iterating when an integer is contained in the
9583 interval between the remainders NLO/DLO and NHI/DHI.
9584 There are two cases to consider: either NLO/DLO == QLO
9585 is an integer (indicated by RLO == 0), or QLO < QHI. */
9586 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9589 /* Efficiently shuffle variables around for the next
9590 iteration. First we shift the recent convergents. */
9591 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9592 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9594 /* The following shuffling is a bit confusing, so some
9595 explanation is in order. Conceptually, we're doing a
9596 couple of things here. After substracting the floor of
9597 NLO/DLO, the remainder is RLO/DLO. The rest of the
9598 continued fraction will represent the remainder's
9599 reciprocal DLO/RLO. Similarly for the HI endpoint.
9600 So in the next iteration, the new endpoints will be
9601 DLO/RLO and DHI/RHI. However, when we take the
9602 reciprocals of these endpoints, their order is
9603 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9604 and NHI/DHI <-- DLO/RLO. */
9605 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9606 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9609 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9610 The last term of the result will be the smallest integer in
9611 that interval, which is ceiling(NLO/DLO). We have already
9612 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9613 equal to the ceiling. */
9614 if (mpz_sgn (rlo
) != 0)
9616 /* If RLO is non-zero, then NLO/DLO is not an integer and
9617 the next term will be QLO+1. QLO was used in the
9618 computation of N0 and D0 above. Here we adjust N0 and
9619 D0 to be based on QLO+1 instead of QLO. */
9620 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9621 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9624 /* The simplest rational in the interval is N0/D0 */
9625 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9627 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9637 /* conversion functions */
9640 scm_is_integer (SCM val
)
9642 return scm_is_true (scm_integer_p (val
));
9646 scm_is_exact_integer (SCM val
)
9648 return scm_is_true (scm_exact_integer_p (val
));
9652 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9654 if (SCM_I_INUMP (val
))
9656 scm_t_signed_bits n
= SCM_I_INUM (val
);
9657 return n
>= min
&& n
<= max
;
9659 else if (SCM_BIGP (val
))
9661 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9663 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9665 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9667 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9668 return n
>= min
&& n
<= max
;
9678 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9679 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9682 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9683 SCM_I_BIG_MPZ (val
));
9685 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9697 return n
>= min
&& n
<= max
;
9705 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9707 if (SCM_I_INUMP (val
))
9709 scm_t_signed_bits n
= SCM_I_INUM (val
);
9710 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9712 else if (SCM_BIGP (val
))
9714 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9716 else if (max
<= ULONG_MAX
)
9718 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9720 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9721 return n
>= min
&& n
<= max
;
9731 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9734 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9735 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9738 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9739 SCM_I_BIG_MPZ (val
));
9741 return n
>= min
&& n
<= max
;
9749 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9751 scm_error (scm_out_of_range_key
,
9753 "Value out of range ~S to ~S: ~S",
9754 scm_list_3 (min
, max
, bad_val
),
9755 scm_list_1 (bad_val
));
9758 #define TYPE scm_t_intmax
9759 #define TYPE_MIN min
9760 #define TYPE_MAX max
9761 #define SIZEOF_TYPE 0
9762 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9763 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9764 #include "libguile/conv-integer.i.c"
9766 #define TYPE scm_t_uintmax
9767 #define TYPE_MIN min
9768 #define TYPE_MAX max
9769 #define SIZEOF_TYPE 0
9770 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9771 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9772 #include "libguile/conv-uinteger.i.c"
9774 #define TYPE scm_t_int8
9775 #define TYPE_MIN SCM_T_INT8_MIN
9776 #define TYPE_MAX SCM_T_INT8_MAX
9777 #define SIZEOF_TYPE 1
9778 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9779 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9780 #include "libguile/conv-integer.i.c"
9782 #define TYPE scm_t_uint8
9784 #define TYPE_MAX SCM_T_UINT8_MAX
9785 #define SIZEOF_TYPE 1
9786 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9787 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9788 #include "libguile/conv-uinteger.i.c"
9790 #define TYPE scm_t_int16
9791 #define TYPE_MIN SCM_T_INT16_MIN
9792 #define TYPE_MAX SCM_T_INT16_MAX
9793 #define SIZEOF_TYPE 2
9794 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9795 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9796 #include "libguile/conv-integer.i.c"
9798 #define TYPE scm_t_uint16
9800 #define TYPE_MAX SCM_T_UINT16_MAX
9801 #define SIZEOF_TYPE 2
9802 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9803 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9804 #include "libguile/conv-uinteger.i.c"
9806 #define TYPE scm_t_int32
9807 #define TYPE_MIN SCM_T_INT32_MIN
9808 #define TYPE_MAX SCM_T_INT32_MAX
9809 #define SIZEOF_TYPE 4
9810 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9811 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9812 #include "libguile/conv-integer.i.c"
9814 #define TYPE scm_t_uint32
9816 #define TYPE_MAX SCM_T_UINT32_MAX
9817 #define SIZEOF_TYPE 4
9818 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9819 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9820 #include "libguile/conv-uinteger.i.c"
9822 #define TYPE scm_t_wchar
9823 #define TYPE_MIN (scm_t_int32)-1
9824 #define TYPE_MAX (scm_t_int32)0x10ffff
9825 #define SIZEOF_TYPE 4
9826 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9827 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9828 #include "libguile/conv-integer.i.c"
9830 #define TYPE scm_t_int64
9831 #define TYPE_MIN SCM_T_INT64_MIN
9832 #define TYPE_MAX SCM_T_INT64_MAX
9833 #define SIZEOF_TYPE 8
9834 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9835 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9836 #include "libguile/conv-integer.i.c"
9838 #define TYPE scm_t_uint64
9840 #define TYPE_MAX SCM_T_UINT64_MAX
9841 #define SIZEOF_TYPE 8
9842 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9843 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9844 #include "libguile/conv-uinteger.i.c"
9847 scm_to_mpz (SCM val
, mpz_t rop
)
9849 if (SCM_I_INUMP (val
))
9850 mpz_set_si (rop
, SCM_I_INUM (val
));
9851 else if (SCM_BIGP (val
))
9852 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9854 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9858 scm_from_mpz (mpz_t val
)
9860 return scm_i_mpz2num (val
);
9864 scm_is_real (SCM val
)
9866 return scm_is_true (scm_real_p (val
));
9870 scm_is_rational (SCM val
)
9872 return scm_is_true (scm_rational_p (val
));
9876 scm_to_double (SCM val
)
9878 if (SCM_I_INUMP (val
))
9879 return SCM_I_INUM (val
);
9880 else if (SCM_BIGP (val
))
9881 return scm_i_big2dbl (val
);
9882 else if (SCM_FRACTIONP (val
))
9883 return scm_i_fraction2double (val
);
9884 else if (SCM_REALP (val
))
9885 return SCM_REAL_VALUE (val
);
9887 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9891 scm_from_double (double val
)
9893 return scm_i_from_double (val
);
9897 scm_is_complex (SCM val
)
9899 return scm_is_true (scm_complex_p (val
));
9903 scm_c_real_part (SCM z
)
9905 if (SCM_COMPLEXP (z
))
9906 return SCM_COMPLEX_REAL (z
);
9909 /* Use the scm_real_part to get proper error checking and
9912 return scm_to_double (scm_real_part (z
));
9917 scm_c_imag_part (SCM z
)
9919 if (SCM_COMPLEXP (z
))
9920 return SCM_COMPLEX_IMAG (z
);
9923 /* Use the scm_imag_part to get proper error checking and
9924 dispatching. The result will almost always be 0.0, but not
9927 return scm_to_double (scm_imag_part (z
));
9932 scm_c_magnitude (SCM z
)
9934 return scm_to_double (scm_magnitude (z
));
9940 return scm_to_double (scm_angle (z
));
9944 scm_is_number (SCM z
)
9946 return scm_is_true (scm_number_p (z
));
9950 /* Returns log(x * 2^shift) */
9952 log_of_shifted_double (double x
, long shift
)
9954 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9956 if (copysign (1.0, x
) > 0.0)
9957 return scm_i_from_double (ans
);
9959 return scm_c_make_rectangular (ans
, M_PI
);
9962 /* Returns log(n), for exact integer n */
9964 log_of_exact_integer (SCM n
)
9966 if (SCM_I_INUMP (n
))
9967 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9968 else if (SCM_BIGP (n
))
9971 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9972 return log_of_shifted_double (signif
, expon
);
9975 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9978 /* Returns log(n/d), for exact non-zero integers n and d */
9980 log_of_fraction (SCM n
, SCM d
)
9982 long n_size
= scm_to_long (scm_integer_length (n
));
9983 long d_size
= scm_to_long (scm_integer_length (d
));
9985 if (abs (n_size
- d_size
) > 1)
9986 return (scm_difference (log_of_exact_integer (n
),
9987 log_of_exact_integer (d
)));
9988 else if (scm_is_false (scm_negative_p (n
)))
9989 return scm_i_from_double
9990 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9992 return scm_c_make_rectangular
9993 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9999 /* In the following functions we dispatch to the real-arg funcs like log()
10000 when we know the arg is real, instead of just handing everything to
10001 clog() for instance. This is in case clog() doesn't optimize for a
10002 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
10003 well use it to go straight to the applicable C func. */
10005 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
10007 "Return the natural logarithm of @var{z}.")
10008 #define FUNC_NAME s_scm_log
10010 if (SCM_COMPLEXP (z
))
10012 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
10013 && defined (SCM_COMPLEX_VALUE)
10014 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
10016 double re
= SCM_COMPLEX_REAL (z
);
10017 double im
= SCM_COMPLEX_IMAG (z
);
10018 return scm_c_make_rectangular (log (hypot (re
, im
)),
10022 else if (SCM_REALP (z
))
10023 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
10024 else if (SCM_I_INUMP (z
))
10026 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10027 if (scm_is_eq (z
, SCM_INUM0
))
10028 scm_num_overflow (s_scm_log
);
10030 return log_of_shifted_double (SCM_I_INUM (z
), 0);
10032 else if (SCM_BIGP (z
))
10033 return log_of_exact_integer (z
);
10034 else if (SCM_FRACTIONP (z
))
10035 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10036 SCM_FRACTION_DENOMINATOR (z
));
10038 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
10043 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10045 "Return the base 10 logarithm of @var{z}.")
10046 #define FUNC_NAME s_scm_log10
10048 if (SCM_COMPLEXP (z
))
10050 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10051 clog() and a multiply by M_LOG10E, rather than the fallback
10052 log10+hypot+atan2.) */
10053 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10054 && defined SCM_COMPLEX_VALUE
10055 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10057 double re
= SCM_COMPLEX_REAL (z
);
10058 double im
= SCM_COMPLEX_IMAG (z
);
10059 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10060 M_LOG10E
* atan2 (im
, re
));
10063 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10065 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10066 if (scm_is_eq (z
, SCM_INUM0
))
10067 scm_num_overflow (s_scm_log10
);
10070 double re
= scm_to_double (z
);
10071 double l
= log10 (fabs (re
));
10072 if (copysign (1.0, re
) > 0.0)
10073 return scm_i_from_double (l
);
10075 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10078 else if (SCM_BIGP (z
))
10079 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10080 else if (SCM_FRACTIONP (z
))
10081 return scm_product (flo_log10e
,
10082 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10083 SCM_FRACTION_DENOMINATOR (z
)));
10085 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10090 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10092 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10093 "base of natural logarithms (2.71828@dots{}).")
10094 #define FUNC_NAME s_scm_exp
10096 if (SCM_COMPLEXP (z
))
10098 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10099 && defined (SCM_COMPLEX_VALUE)
10100 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10102 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10103 SCM_COMPLEX_IMAG (z
));
10106 else if (SCM_NUMBERP (z
))
10108 /* When z is a negative bignum the conversion to double overflows,
10109 giving -infinity, but that's ok, the exp is still 0.0. */
10110 return scm_i_from_double (exp (scm_to_double (z
)));
10113 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10118 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10120 "Return two exact non-negative integers @var{s} and @var{r}\n"
10121 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10122 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10123 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10126 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10128 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10132 scm_exact_integer_sqrt (k
, &s
, &r
);
10133 return scm_values (scm_list_2 (s
, r
));
10138 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10140 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10144 if (SCM_I_INUM (k
) < 0)
10145 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10146 "exact non-negative integer");
10147 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10148 mpz_inits (ss
, rr
, NULL
);
10149 mpz_sqrtrem (ss
, rr
, kk
);
10150 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10151 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10152 mpz_clears (kk
, ss
, rr
, NULL
);
10154 else if (SCM_LIKELY (SCM_BIGP (k
)))
10158 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10159 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10160 "exact non-negative integer");
10161 s
= scm_i_mkbig ();
10162 r
= scm_i_mkbig ();
10163 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10164 scm_remember_upto_here_1 (k
);
10165 *sp
= scm_i_normbig (s
);
10166 *rp
= scm_i_normbig (r
);
10169 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10170 "exact non-negative integer");
10173 /* Return true iff K is a perfect square.
10174 K must be an exact integer. */
10176 exact_integer_is_perfect_square (SCM k
)
10180 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10184 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10185 result
= mpz_perfect_square_p (kk
);
10190 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10191 scm_remember_upto_here_1 (k
);
10196 /* Return the floor of the square root of K.
10197 K must be an exact integer. */
10199 exact_integer_floor_square_root (SCM k
)
10201 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10206 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10208 ss
= mpz_get_ui (kk
);
10210 return SCM_I_MAKINUM (ss
);
10216 s
= scm_i_mkbig ();
10217 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10218 scm_remember_upto_here_1 (k
);
10219 return scm_i_normbig (s
);
10224 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10226 "Return the square root of @var{z}. Of the two possible roots\n"
10227 "(positive and negative), the one with positive real part\n"
10228 "is returned, or if that's zero then a positive imaginary part.\n"
10232 "(sqrt 9.0) @result{} 3.0\n"
10233 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10234 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10235 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10237 #define FUNC_NAME s_scm_sqrt
10239 if (SCM_COMPLEXP (z
))
10241 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10242 && defined SCM_COMPLEX_VALUE
10243 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10245 double re
= SCM_COMPLEX_REAL (z
);
10246 double im
= SCM_COMPLEX_IMAG (z
);
10247 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10248 0.5 * atan2 (im
, re
));
10251 else if (SCM_NUMBERP (z
))
10253 if (SCM_I_INUMP (z
))
10255 scm_t_inum x
= SCM_I_INUM (z
);
10257 if (SCM_LIKELY (x
>= 0))
10259 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10260 || x
< (1L << (DBL_MANT_DIG
- 1))))
10262 double root
= sqrt (x
);
10264 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10265 integer, then the result is exact. */
10266 if (root
== floor (root
))
10267 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10269 return scm_i_from_double (root
);
10276 mpz_init_set_ui (xx
, x
);
10277 if (mpz_perfect_square_p (xx
))
10280 root
= mpz_get_ui (xx
);
10282 return SCM_I_MAKINUM (root
);
10289 else if (SCM_BIGP (z
))
10291 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10293 SCM root
= scm_i_mkbig ();
10295 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10296 scm_remember_upto_here_1 (z
);
10297 return scm_i_normbig (root
);
10302 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10310 return scm_c_make_rectangular
10311 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10313 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10316 else if (SCM_FRACTIONP (z
))
10318 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10319 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10321 if (exact_integer_is_perfect_square (n
)
10322 && exact_integer_is_perfect_square (d
))
10323 return scm_i_make_ratio_already_reduced
10324 (exact_integer_floor_square_root (n
),
10325 exact_integer_floor_square_root (d
));
10328 double xx
= scm_i_divide2double (n
, d
);
10329 double abs_xx
= fabs (xx
);
10332 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10334 shift
= (scm_to_long (scm_integer_length (n
))
10335 - scm_to_long (scm_integer_length (d
))) / 2;
10337 d
= left_shift_exact_integer (d
, 2 * shift
);
10339 n
= left_shift_exact_integer (n
, -2 * shift
);
10340 xx
= scm_i_divide2double (n
, d
);
10344 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10346 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10350 /* Fallback method, when the cases above do not apply. */
10352 double xx
= scm_to_double (z
);
10354 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10356 return scm_i_from_double (sqrt (xx
));
10360 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10367 scm_init_numbers ()
10369 if (scm_install_gmp_memory_functions
)
10370 mp_set_memory_functions (custom_gmp_malloc
,
10371 custom_gmp_realloc
,
10374 mpz_init_set_si (z_negative_one
, -1);
10376 /* It may be possible to tune the performance of some algorithms by using
10377 * the following constants to avoid the creation of bignums. Please, before
10378 * using these values, remember the two rules of program optimization:
10379 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10380 scm_c_define ("most-positive-fixnum",
10381 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10382 scm_c_define ("most-negative-fixnum",
10383 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10385 scm_add_feature ("complex");
10386 scm_add_feature ("inexact");
10387 flo0
= scm_i_from_double (0.0);
10388 flo_log10e
= scm_i_from_double (M_LOG10E
);
10390 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10393 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10394 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10395 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10396 scm_i_divide2double_lo2b
,
10397 DBL_MANT_DIG
+ 1); /* 2 b^p */
10398 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10402 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10403 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10404 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10405 dbl_minimum_normal_mantissa
,
10409 #include "libguile/numbers.x"
10414 c-file-style: "gnu"