1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
3 * 2013 Free Software Foundation, Inc.
5 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
6 * and Bellcore. See scm_divide.
9 * This library is free software; you can redistribute it and/or
10 * modify it under the terms of the GNU Lesser General Public License
11 * as published by the Free Software Foundation; either version 3 of
12 * the License, or (at your option) any later version.
14 * This library is distributed in the hope that it will be useful, but
15 * WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * Lesser General Public License for more details.
19 * You should have received a copy of the GNU Lesser General Public
20 * License along with this library; if not, write to the Free Software
21 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 /* General assumptions:
27 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
28 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
29 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
30 * XXX What about infinities? They are equal to their own floor! -mhw
31 * All objects satisfying SCM_FRACTIONP are never an integer.
36 - see if special casing bignums and reals in integer-exponent when
37 possible (to use mpz_pow and mpf_pow_ui) is faster.
39 - look in to better short-circuiting of common cases in
40 integer-expt and elsewhere.
42 - see if direct mpz operations can help in ash and elsewhere.
64 #include "libguile/_scm.h"
65 #include "libguile/feature.h"
66 #include "libguile/ports.h"
67 #include "libguile/root.h"
68 #include "libguile/smob.h"
69 #include "libguile/strings.h"
70 #include "libguile/bdw-gc.h"
72 #include "libguile/validate.h"
73 #include "libguile/numbers.h"
74 #include "libguile/deprecation.h"
76 #include "libguile/eq.h"
78 /* values per glibc, if not already defined */
80 #define M_LOG10E 0.43429448190325182765
83 #define M_LN2 0.69314718055994530942
86 #define M_PI 3.14159265358979323846
89 /* FIXME: We assume that FLT_RADIX is 2 */
90 verify (FLT_RADIX
== 2);
92 typedef scm_t_signed_bits scm_t_inum
;
93 #define scm_from_inum(x) (scm_from_signed_integer (x))
95 /* Test an inum to see if it can be converted to a double without loss
96 of precision. Note that this will sometimes return 0 even when 1
97 could have been returned, e.g. for large powers of 2. It is designed
98 to be a fast check to optimize common cases. */
99 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
100 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
101 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
103 #if ! HAVE_DECL_MPZ_INITS
105 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
107 #define VARARG_MPZ_ITERATOR(func) \
109 func ## s (mpz_t x, ...) \
117 x = va_arg (ap, mpz_ptr); \
122 VARARG_MPZ_ITERATOR (mpz_init
)
123 VARARG_MPZ_ITERATOR (mpz_clear
)
130 Wonder if this might be faster for some of our code? A switch on
131 the numtag would jump directly to the right case, and the
132 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
134 #define SCM_I_NUMTAG_NOTNUM 0
135 #define SCM_I_NUMTAG_INUM 1
136 #define SCM_I_NUMTAG_BIG scm_tc16_big
137 #define SCM_I_NUMTAG_REAL scm_tc16_real
138 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
139 #define SCM_I_NUMTAG(x) \
140 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
141 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
142 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
143 : SCM_I_NUMTAG_NOTNUM)))
145 /* the macro above will not work as is with fractions */
148 /* Default to 1, because as we used to hard-code `free' as the
149 deallocator, we know that overriding these functions with
150 instrumented `malloc' / `free' is OK. */
151 int scm_install_gmp_memory_functions
= 1;
153 static SCM exactly_one_half
;
154 static SCM flo_log10e
;
156 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
158 /* FLOBUFLEN is the maximum number of characters neccessary for the
159 * printed or scm_string representation of an inexact number.
161 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
164 #if !defined (HAVE_ASINH)
165 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
167 #if !defined (HAVE_ACOSH)
168 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
170 #if !defined (HAVE_ATANH)
171 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
174 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
175 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
176 in March 2006), mpz_cmp_d now handles infinities properly. */
178 #define xmpz_cmp_d(z, d) \
179 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
181 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
185 #if defined (GUILE_I)
186 #if defined HAVE_COMPLEX_DOUBLE
188 /* For an SCM object Z which is a complex number (ie. satisfies
189 SCM_COMPLEXP), return its value as a C level "complex double". */
190 #define SCM_COMPLEX_VALUE(z) \
191 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
193 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
195 /* Convert a C "complex double" to an SCM value. */
197 scm_from_complex_double (complex double z
)
199 return scm_c_make_rectangular (creal (z
), cimag (z
));
202 #endif /* HAVE_COMPLEX_DOUBLE */
207 static mpz_t z_negative_one
;
211 /* Clear the `mpz_t' embedded in bignum PTR. */
213 finalize_bignum (void *ptr
, void *data
)
217 bignum
= SCM_PACK_POINTER (ptr
);
218 mpz_clear (SCM_I_BIG_MPZ (bignum
));
221 /* The next three functions (custom_libgmp_*) are passed to
222 mp_set_memory_functions (in GMP) so that memory used by the digits
223 themselves is known to the garbage collector. This is needed so
224 that GC will be run at appropriate times. Otherwise, a program which
225 creates many large bignums would malloc a huge amount of memory
226 before the GC runs. */
228 custom_gmp_malloc (size_t alloc_size
)
230 return scm_malloc (alloc_size
);
234 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
236 return scm_realloc (old_ptr
, new_size
);
240 custom_gmp_free (void *ptr
, size_t size
)
246 /* Return a new uninitialized bignum. */
252 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
253 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
257 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
266 /* Return a newly created bignum. */
267 SCM z
= make_bignum ();
268 mpz_init (SCM_I_BIG_MPZ (z
));
273 scm_i_inum2big (scm_t_inum x
)
275 /* Return a newly created bignum initialized to X. */
276 SCM z
= make_bignum ();
277 #if SIZEOF_VOID_P == SIZEOF_LONG
278 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
280 /* Note that in this case, you'll also have to check all mpz_*_ui and
281 mpz_*_si invocations in Guile. */
282 #error creation of mpz not implemented for this inum size
288 scm_i_long2big (long x
)
290 /* Return a newly created bignum initialized to X. */
291 SCM z
= make_bignum ();
292 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
297 scm_i_ulong2big (unsigned long x
)
299 /* Return a newly created bignum initialized to X. */
300 SCM z
= make_bignum ();
301 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
306 scm_i_clonebig (SCM src_big
, int same_sign_p
)
308 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
309 SCM z
= make_bignum ();
310 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
312 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
317 scm_i_bigcmp (SCM x
, SCM y
)
319 /* Return neg if x < y, pos if x > y, and 0 if x == y */
320 /* presume we already know x and y are bignums */
321 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
322 scm_remember_upto_here_2 (x
, y
);
327 scm_i_dbl2big (double d
)
329 /* results are only defined if d is an integer */
330 SCM z
= make_bignum ();
331 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
335 /* Convert a integer in double representation to a SCM number. */
338 scm_i_dbl2num (double u
)
340 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
341 powers of 2, so there's no rounding when making "double" values
342 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
343 get rounded on a 64-bit machine, hence the "+1".
345 The use of floor() to force to an integer value ensures we get a
346 "numerically closest" value without depending on how a
347 double->long cast or how mpz_set_d will round. For reference,
348 double->long probably follows the hardware rounding mode,
349 mpz_set_d truncates towards zero. */
351 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
352 representable as a double? */
354 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
355 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
356 return SCM_I_MAKINUM ((scm_t_inum
) u
);
358 return scm_i_dbl2big (u
);
361 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
363 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
364 bignum b into a normalized significand and exponent such that
365 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
366 The return value is the significand rounded to the closest
367 representable double, and the exponent is placed into *expon_p.
368 If b is zero, then the returned exponent and significand are both
372 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
374 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
377 if (bits
> DBL_MANT_DIG
)
379 shift
= bits
- DBL_MANT_DIG
;
380 b
= round_right_shift_exact_integer (b
, shift
);
384 double signif
= frexp (SCM_I_INUM (b
), &expon
);
385 *expon_p
= expon
+ shift
;
392 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
393 scm_remember_upto_here_1 (b
);
394 *expon_p
= expon
+ shift
;
399 /* scm_i_big2dbl() rounds to the closest representable double,
400 in accordance with R5RS exact->inexact. */
402 scm_i_big2dbl (SCM b
)
405 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
406 return ldexp (signif
, expon
);
410 scm_i_normbig (SCM b
)
412 /* convert a big back to a fixnum if it'll fit */
413 /* presume b is a bignum */
414 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
416 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
417 if (SCM_FIXABLE (val
))
418 b
= SCM_I_MAKINUM (val
);
423 static SCM_C_INLINE_KEYWORD SCM
424 scm_i_mpz2num (mpz_t b
)
426 /* convert a mpz number to a SCM number. */
427 if (mpz_fits_slong_p (b
))
429 scm_t_inum val
= mpz_get_si (b
);
430 if (SCM_FIXABLE (val
))
431 return SCM_I_MAKINUM (val
);
435 SCM z
= make_bignum ();
436 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
441 /* Make the ratio NUMERATOR/DENOMINATOR, where:
442 1. NUMERATOR and DENOMINATOR are exact integers
443 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
445 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
447 /* Flip signs so that the denominator is positive. */
448 if (scm_is_false (scm_positive_p (denominator
)))
450 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
451 scm_num_overflow ("make-ratio");
454 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
455 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
459 /* Check for the integer case */
460 if (scm_is_eq (denominator
, SCM_INUM1
))
463 return scm_double_cell (scm_tc16_fraction
,
464 SCM_UNPACK (numerator
),
465 SCM_UNPACK (denominator
), 0);
468 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
470 /* Make the ratio NUMERATOR/DENOMINATOR */
472 scm_i_make_ratio (SCM numerator
, SCM denominator
)
473 #define FUNC_NAME "make-ratio"
475 /* Make sure the arguments are proper */
476 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
477 SCM_WRONG_TYPE_ARG (1, numerator
);
478 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
479 SCM_WRONG_TYPE_ARG (2, denominator
);
482 SCM the_gcd
= scm_gcd (numerator
, denominator
);
483 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
485 /* Reduce to lowest terms */
486 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
487 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
489 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
494 static mpz_t scm_i_divide2double_lo2b
;
496 /* Return the double that is closest to the exact rational N/D, with
497 ties rounded toward even mantissas. N and D must be exact
500 scm_i_divide2double (SCM n
, SCM d
)
503 mpz_t nn
, dd
, lo
, hi
, x
;
506 if (SCM_LIKELY (SCM_I_INUMP (d
)))
510 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n
))
511 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d
))))
512 /* If both N and D can be losslessly converted to doubles, then
513 we can rely on IEEE floating point to do proper rounding much
514 faster than we can. */
515 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
517 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
519 if (scm_is_true (scm_positive_p (n
)))
521 else if (scm_is_true (scm_negative_p (n
)))
527 mpz_init_set_si (dd
, SCM_I_INUM (d
));
530 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
533 mpz_init_set_si (nn
, SCM_I_INUM (n
));
535 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
537 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
541 /* Now we need to find the value of e such that:
544 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
545 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
546 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
549 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
550 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
551 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
553 where: p = DBL_MANT_DIG
554 b = FLT_RADIX (here assumed to be 2)
556 After rounding, the mantissa must be an integer between b^{p-1} and
557 (b^p - 1), except for subnormal numbers. In the inequations [1A]
558 and [1B], the middle expression represents the mantissa *before*
559 rounding, and therefore is bounded by the range of values that will
560 round to a floating-point number with the exponent e. The upper
561 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
562 ties will round up to the next power of b. The lower bound is
563 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
564 this power of b. Here we subtract 1/2b instead of 1/2 because it
565 is in the range of the next smaller exponent, where the
566 representable numbers are closer together by a factor of b.
568 Inequations [2A] and [2B] are derived from [1A] and [1B] by
569 multiplying by 2b, and in [3A] and [3B] we multiply by the
570 denominator of the middle value to obtain integer expressions.
572 In the code below, we refer to the three expressions in [3A] or
573 [3B] as lo, x, and hi. If the number is normalizable, we will
574 achieve the goal: lo <= x < hi */
576 /* Make an initial guess for e */
577 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
578 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
579 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
581 /* Compute the initial values of lo, x, and hi
582 based on the initial guess of e */
583 mpz_inits (lo
, hi
, x
, NULL
);
584 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
585 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
587 mpz_mul_2exp (lo
, lo
, e
);
588 mpz_mul_2exp (hi
, lo
, 1);
590 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
591 (but without making e less then the minimum exponent) */
592 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
594 mpz_mul_2exp (x
, x
, 1);
597 while (mpz_cmp (x
, hi
) >= 0)
599 /* If we ever used lo's value again,
600 we would need to double lo here. */
601 mpz_mul_2exp (hi
, hi
, 1);
605 /* Now compute the rounded mantissa:
606 n / b^e d (if e >= 0)
607 n b^-e / d (if e <= 0) */
613 mpz_mul_2exp (nn
, nn
, -e
);
615 mpz_mul_2exp (dd
, dd
, e
);
617 /* mpz does not directly support rounded right
618 shifts, so we have to do it the hard way.
619 For efficiency, we reuse lo and hi.
620 hi == quotient, lo == remainder */
621 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
623 /* The fractional part of the unrounded mantissa would be
624 remainder/dividend, i.e. lo/dd. So we have a tie if
625 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
626 integer expression 2*lo = dd. Here we do that comparison
627 to decide whether to round up or down. */
628 mpz_mul_2exp (lo
, lo
, 1);
629 cmp
= mpz_cmp (lo
, dd
);
630 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
631 mpz_add_ui (hi
, hi
, 1);
633 result
= ldexp (mpz_get_d (hi
), e
);
637 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
643 scm_i_fraction2double (SCM z
)
645 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
646 SCM_FRACTION_DENOMINATOR (z
));
650 scm_i_from_double (double val
)
654 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
656 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
657 SCM_REAL_VALUE (z
) = val
;
662 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
664 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
666 #define FUNC_NAME s_scm_exact_p
668 if (SCM_INEXACTP (x
))
670 else if (SCM_NUMBERP (x
))
673 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
678 scm_is_exact (SCM val
)
680 return scm_is_true (scm_exact_p (val
));
683 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
685 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
687 #define FUNC_NAME s_scm_inexact_p
689 if (SCM_INEXACTP (x
))
691 else if (SCM_NUMBERP (x
))
694 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
699 scm_is_inexact (SCM val
)
701 return scm_is_true (scm_inexact_p (val
));
704 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
706 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
708 #define FUNC_NAME s_scm_odd_p
712 scm_t_inum val
= SCM_I_INUM (n
);
713 return scm_from_bool ((val
& 1L) != 0);
715 else if (SCM_BIGP (n
))
717 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
718 scm_remember_upto_here_1 (n
);
719 return scm_from_bool (odd_p
);
721 else if (SCM_REALP (n
))
723 double val
= SCM_REAL_VALUE (n
);
726 double rem
= fabs (fmod (val
, 2.0));
733 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
738 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
740 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
742 #define FUNC_NAME s_scm_even_p
746 scm_t_inum val
= SCM_I_INUM (n
);
747 return scm_from_bool ((val
& 1L) == 0);
749 else if (SCM_BIGP (n
))
751 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
752 scm_remember_upto_here_1 (n
);
753 return scm_from_bool (even_p
);
755 else if (SCM_REALP (n
))
757 double val
= SCM_REAL_VALUE (n
);
760 double rem
= fabs (fmod (val
, 2.0));
767 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
771 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
773 "Return @code{#t} if the real number @var{x} is neither\n"
774 "infinite nor a NaN, @code{#f} otherwise.")
775 #define FUNC_NAME s_scm_finite_p
778 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
779 else if (scm_is_real (x
))
782 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
786 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
788 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
789 "@samp{-inf.0}. Otherwise return @code{#f}.")
790 #define FUNC_NAME s_scm_inf_p
793 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
794 else if (scm_is_real (x
))
797 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
801 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
803 "Return @code{#t} if the real number @var{x} is a NaN,\n"
804 "or @code{#f} otherwise.")
805 #define FUNC_NAME s_scm_nan_p
808 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
809 else if (scm_is_real (x
))
812 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
816 /* Guile's idea of infinity. */
817 static double guile_Inf
;
819 /* Guile's idea of not a number. */
820 static double guile_NaN
;
823 guile_ieee_init (void)
825 /* Some version of gcc on some old version of Linux used to crash when
826 trying to make Inf and NaN. */
829 /* C99 INFINITY, when available.
830 FIXME: The standard allows for INFINITY to be something that overflows
831 at compile time. We ought to have a configure test to check for that
832 before trying to use it. (But in practice we believe this is not a
833 problem on any system guile is likely to target.) */
834 guile_Inf
= INFINITY
;
835 #elif defined HAVE_DINFINITY
837 extern unsigned int DINFINITY
[2];
838 guile_Inf
= (*((double *) (DINFINITY
)));
845 if (guile_Inf
== tmp
)
852 /* C99 NAN, when available */
854 #elif defined HAVE_DQNAN
857 extern unsigned int DQNAN
[2];
858 guile_NaN
= (*((double *)(DQNAN
)));
861 guile_NaN
= guile_Inf
/ guile_Inf
;
865 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
868 #define FUNC_NAME s_scm_inf
870 static int initialized
= 0;
876 return scm_i_from_double (guile_Inf
);
880 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
883 #define FUNC_NAME s_scm_nan
885 static int initialized
= 0;
891 return scm_i_from_double (guile_NaN
);
896 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
898 "Return the absolute value of @var{x}.")
899 #define FUNC_NAME s_scm_abs
903 scm_t_inum xx
= SCM_I_INUM (x
);
906 else if (SCM_POSFIXABLE (-xx
))
907 return SCM_I_MAKINUM (-xx
);
909 return scm_i_inum2big (-xx
);
911 else if (SCM_LIKELY (SCM_REALP (x
)))
913 double xx
= SCM_REAL_VALUE (x
);
914 /* If x is a NaN then xx<0 is false so we return x unchanged */
916 return scm_i_from_double (-xx
);
917 /* Handle signed zeroes properly */
918 else if (SCM_UNLIKELY (xx
== 0.0))
923 else if (SCM_BIGP (x
))
925 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
927 return scm_i_clonebig (x
, 0);
931 else if (SCM_FRACTIONP (x
))
933 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
935 return scm_i_make_ratio_already_reduced
936 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
937 SCM_FRACTION_DENOMINATOR (x
));
940 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
945 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
947 "Return the quotient of the numbers @var{x} and @var{y}.")
948 #define FUNC_NAME s_scm_quotient
950 if (SCM_LIKELY (scm_is_integer (x
)))
952 if (SCM_LIKELY (scm_is_integer (y
)))
953 return scm_truncate_quotient (x
, y
);
955 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
958 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
962 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
964 "Return the remainder of the numbers @var{x} and @var{y}.\n"
966 "(remainder 13 4) @result{} 1\n"
967 "(remainder -13 4) @result{} -1\n"
969 #define FUNC_NAME s_scm_remainder
971 if (SCM_LIKELY (scm_is_integer (x
)))
973 if (SCM_LIKELY (scm_is_integer (y
)))
974 return scm_truncate_remainder (x
, y
);
976 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
979 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
984 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
986 "Return the modulo of the numbers @var{x} and @var{y}.\n"
988 "(modulo 13 4) @result{} 1\n"
989 "(modulo -13 4) @result{} 3\n"
991 #define FUNC_NAME s_scm_modulo
993 if (SCM_LIKELY (scm_is_integer (x
)))
995 if (SCM_LIKELY (scm_is_integer (y
)))
996 return scm_floor_remainder (x
, y
);
998 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
1001 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1005 /* Return the exact integer q such that n = q*d, for exact integers n
1006 and d, where d is known in advance to divide n evenly (with zero
1007 remainder). For large integers, this can be computed more
1008 efficiently than when the remainder is unknown. */
1010 scm_exact_integer_quotient (SCM n
, SCM d
)
1011 #define FUNC_NAME "exact-integer-quotient"
1013 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1015 scm_t_inum nn
= SCM_I_INUM (n
);
1016 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1018 scm_t_inum dd
= SCM_I_INUM (d
);
1019 if (SCM_UNLIKELY (dd
== 0))
1020 scm_num_overflow ("exact-integer-quotient");
1023 scm_t_inum qq
= nn
/ dd
;
1024 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1025 return SCM_I_MAKINUM (qq
);
1027 return scm_i_inum2big (qq
);
1030 else if (SCM_LIKELY (SCM_BIGP (d
)))
1032 /* n is an inum and d is a bignum. Given that d is known to
1033 divide n evenly, there are only two possibilities: n is 0,
1034 or else n is fixnum-min and d is abs(fixnum-min). */
1038 return SCM_I_MAKINUM (-1);
1041 SCM_WRONG_TYPE_ARG (2, d
);
1043 else if (SCM_LIKELY (SCM_BIGP (n
)))
1045 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1047 scm_t_inum dd
= SCM_I_INUM (d
);
1048 if (SCM_UNLIKELY (dd
== 0))
1049 scm_num_overflow ("exact-integer-quotient");
1050 else if (SCM_UNLIKELY (dd
== 1))
1054 SCM q
= scm_i_mkbig ();
1056 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1059 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1060 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1062 scm_remember_upto_here_1 (n
);
1063 return scm_i_normbig (q
);
1066 else if (SCM_LIKELY (SCM_BIGP (d
)))
1068 SCM q
= scm_i_mkbig ();
1069 mpz_divexact (SCM_I_BIG_MPZ (q
),
1072 scm_remember_upto_here_2 (n
, d
);
1073 return scm_i_normbig (q
);
1076 SCM_WRONG_TYPE_ARG (2, d
);
1079 SCM_WRONG_TYPE_ARG (1, n
);
1083 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1084 two-valued functions. It is called from primitive generics that take
1085 two arguments and return two values, when the core procedure is
1086 unable to handle the given argument types. If there are GOOPS
1087 methods for this primitive generic, it dispatches to GOOPS and, if
1088 successful, expects two values to be returned, which are placed in
1089 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1090 wrong-type-arg exception.
1092 FIXME: This obviously belongs somewhere else, but until we decide on
1093 the right API, it is here as a static function, because it is needed
1094 by the *_divide functions below.
1097 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1098 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1100 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
1102 scm_i_extract_values_2 (vals
, rp1
, rp2
);
1105 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1107 "Return the integer @var{q} such that\n"
1108 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1109 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1111 "(euclidean-quotient 123 10) @result{} 12\n"
1112 "(euclidean-quotient 123 -10) @result{} -12\n"
1113 "(euclidean-quotient -123 10) @result{} -13\n"
1114 "(euclidean-quotient -123 -10) @result{} 13\n"
1115 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1116 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1118 #define FUNC_NAME s_scm_euclidean_quotient
1120 if (scm_is_false (scm_negative_p (y
)))
1121 return scm_floor_quotient (x
, y
);
1123 return scm_ceiling_quotient (x
, y
);
1127 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1129 "Return the real number @var{r} such that\n"
1130 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1131 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1132 "for some integer @var{q}.\n"
1134 "(euclidean-remainder 123 10) @result{} 3\n"
1135 "(euclidean-remainder 123 -10) @result{} 3\n"
1136 "(euclidean-remainder -123 10) @result{} 7\n"
1137 "(euclidean-remainder -123 -10) @result{} 7\n"
1138 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1139 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1141 #define FUNC_NAME s_scm_euclidean_remainder
1143 if (scm_is_false (scm_negative_p (y
)))
1144 return scm_floor_remainder (x
, y
);
1146 return scm_ceiling_remainder (x
, y
);
1150 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1152 "Return the integer @var{q} and the real number @var{r}\n"
1153 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1154 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1156 "(euclidean/ 123 10) @result{} 12 and 3\n"
1157 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1158 "(euclidean/ -123 10) @result{} -13 and 7\n"
1159 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1160 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1161 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1163 #define FUNC_NAME s_scm_i_euclidean_divide
1165 if (scm_is_false (scm_negative_p (y
)))
1166 return scm_i_floor_divide (x
, y
);
1168 return scm_i_ceiling_divide (x
, y
);
1173 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1175 if (scm_is_false (scm_negative_p (y
)))
1176 return scm_floor_divide (x
, y
, qp
, rp
);
1178 return scm_ceiling_divide (x
, y
, qp
, rp
);
1181 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1182 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1184 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1186 "Return the floor of @math{@var{x} / @var{y}}.\n"
1188 "(floor-quotient 123 10) @result{} 12\n"
1189 "(floor-quotient 123 -10) @result{} -13\n"
1190 "(floor-quotient -123 10) @result{} -13\n"
1191 "(floor-quotient -123 -10) @result{} 12\n"
1192 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1193 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1195 #define FUNC_NAME s_scm_floor_quotient
1197 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1199 scm_t_inum xx
= SCM_I_INUM (x
);
1200 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1202 scm_t_inum yy
= SCM_I_INUM (y
);
1203 scm_t_inum xx1
= xx
;
1205 if (SCM_LIKELY (yy
> 0))
1207 if (SCM_UNLIKELY (xx
< 0))
1210 else if (SCM_UNLIKELY (yy
== 0))
1211 scm_num_overflow (s_scm_floor_quotient
);
1215 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1216 return SCM_I_MAKINUM (qq
);
1218 return scm_i_inum2big (qq
);
1220 else if (SCM_BIGP (y
))
1222 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1223 scm_remember_upto_here_1 (y
);
1225 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1227 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1229 else if (SCM_REALP (y
))
1230 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1231 else if (SCM_FRACTIONP (y
))
1232 return scm_i_exact_rational_floor_quotient (x
, y
);
1234 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1235 s_scm_floor_quotient
);
1237 else if (SCM_BIGP (x
))
1239 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1241 scm_t_inum yy
= SCM_I_INUM (y
);
1242 if (SCM_UNLIKELY (yy
== 0))
1243 scm_num_overflow (s_scm_floor_quotient
);
1244 else if (SCM_UNLIKELY (yy
== 1))
1248 SCM q
= scm_i_mkbig ();
1250 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1253 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1254 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1256 scm_remember_upto_here_1 (x
);
1257 return scm_i_normbig (q
);
1260 else if (SCM_BIGP (y
))
1262 SCM q
= scm_i_mkbig ();
1263 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1266 scm_remember_upto_here_2 (x
, y
);
1267 return scm_i_normbig (q
);
1269 else if (SCM_REALP (y
))
1270 return scm_i_inexact_floor_quotient
1271 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1272 else if (SCM_FRACTIONP (y
))
1273 return scm_i_exact_rational_floor_quotient (x
, y
);
1275 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1276 s_scm_floor_quotient
);
1278 else if (SCM_REALP (x
))
1280 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1281 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1282 return scm_i_inexact_floor_quotient
1283 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1285 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1286 s_scm_floor_quotient
);
1288 else if (SCM_FRACTIONP (x
))
1291 return scm_i_inexact_floor_quotient
1292 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1293 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1294 return scm_i_exact_rational_floor_quotient (x
, y
);
1296 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1297 s_scm_floor_quotient
);
1300 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1301 s_scm_floor_quotient
);
1306 scm_i_inexact_floor_quotient (double x
, double y
)
1308 if (SCM_UNLIKELY (y
== 0))
1309 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1311 return scm_i_from_double (floor (x
/ y
));
1315 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1317 return scm_floor_quotient
1318 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1319 scm_product (scm_numerator (y
), scm_denominator (x
)));
1322 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1323 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1325 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1327 "Return the real number @var{r} such that\n"
1328 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1329 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1331 "(floor-remainder 123 10) @result{} 3\n"
1332 "(floor-remainder 123 -10) @result{} -7\n"
1333 "(floor-remainder -123 10) @result{} 7\n"
1334 "(floor-remainder -123 -10) @result{} -3\n"
1335 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1336 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1338 #define FUNC_NAME s_scm_floor_remainder
1340 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1342 scm_t_inum xx
= SCM_I_INUM (x
);
1343 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1345 scm_t_inum yy
= SCM_I_INUM (y
);
1346 if (SCM_UNLIKELY (yy
== 0))
1347 scm_num_overflow (s_scm_floor_remainder
);
1350 scm_t_inum rr
= xx
% yy
;
1351 int needs_adjustment
;
1353 if (SCM_LIKELY (yy
> 0))
1354 needs_adjustment
= (rr
< 0);
1356 needs_adjustment
= (rr
> 0);
1358 if (needs_adjustment
)
1360 return SCM_I_MAKINUM (rr
);
1363 else if (SCM_BIGP (y
))
1365 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1366 scm_remember_upto_here_1 (y
);
1371 SCM r
= scm_i_mkbig ();
1372 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1373 scm_remember_upto_here_1 (y
);
1374 return scm_i_normbig (r
);
1383 SCM r
= scm_i_mkbig ();
1384 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1385 scm_remember_upto_here_1 (y
);
1386 return scm_i_normbig (r
);
1389 else if (SCM_REALP (y
))
1390 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1391 else if (SCM_FRACTIONP (y
))
1392 return scm_i_exact_rational_floor_remainder (x
, y
);
1394 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1395 s_scm_floor_remainder
);
1397 else if (SCM_BIGP (x
))
1399 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1401 scm_t_inum yy
= SCM_I_INUM (y
);
1402 if (SCM_UNLIKELY (yy
== 0))
1403 scm_num_overflow (s_scm_floor_remainder
);
1408 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1410 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1411 scm_remember_upto_here_1 (x
);
1412 return SCM_I_MAKINUM (rr
);
1415 else if (SCM_BIGP (y
))
1417 SCM r
= scm_i_mkbig ();
1418 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1421 scm_remember_upto_here_2 (x
, y
);
1422 return scm_i_normbig (r
);
1424 else if (SCM_REALP (y
))
1425 return scm_i_inexact_floor_remainder
1426 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1427 else if (SCM_FRACTIONP (y
))
1428 return scm_i_exact_rational_floor_remainder (x
, y
);
1430 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1431 s_scm_floor_remainder
);
1433 else if (SCM_REALP (x
))
1435 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1436 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1437 return scm_i_inexact_floor_remainder
1438 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1440 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1441 s_scm_floor_remainder
);
1443 else if (SCM_FRACTIONP (x
))
1446 return scm_i_inexact_floor_remainder
1447 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1448 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1449 return scm_i_exact_rational_floor_remainder (x
, y
);
1451 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1452 s_scm_floor_remainder
);
1455 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1456 s_scm_floor_remainder
);
1461 scm_i_inexact_floor_remainder (double x
, double y
)
1463 /* Although it would be more efficient to use fmod here, we can't
1464 because it would in some cases produce results inconsistent with
1465 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1466 close). In particular, when x is very close to a multiple of y,
1467 then r might be either 0.0 or y, but those two cases must
1468 correspond to different choices of q. If r = 0.0 then q must be
1469 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1470 and remainder chooses the other, it would be bad. */
1471 if (SCM_UNLIKELY (y
== 0))
1472 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1474 return scm_i_from_double (x
- y
* floor (x
/ y
));
1478 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1480 SCM xd
= scm_denominator (x
);
1481 SCM yd
= scm_denominator (y
);
1482 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1483 scm_product (scm_numerator (y
), xd
));
1484 return scm_divide (r1
, scm_product (xd
, yd
));
1488 static void scm_i_inexact_floor_divide (double x
, double y
,
1490 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1493 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1495 "Return the integer @var{q} and the real number @var{r}\n"
1496 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1497 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1499 "(floor/ 123 10) @result{} 12 and 3\n"
1500 "(floor/ 123 -10) @result{} -13 and -7\n"
1501 "(floor/ -123 10) @result{} -13 and 7\n"
1502 "(floor/ -123 -10) @result{} 12 and -3\n"
1503 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1504 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1506 #define FUNC_NAME s_scm_i_floor_divide
1510 scm_floor_divide(x
, y
, &q
, &r
);
1511 return scm_values (scm_list_2 (q
, r
));
1515 #define s_scm_floor_divide s_scm_i_floor_divide
1516 #define g_scm_floor_divide g_scm_i_floor_divide
1519 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1521 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1523 scm_t_inum xx
= SCM_I_INUM (x
);
1524 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1526 scm_t_inum yy
= SCM_I_INUM (y
);
1527 if (SCM_UNLIKELY (yy
== 0))
1528 scm_num_overflow (s_scm_floor_divide
);
1531 scm_t_inum qq
= xx
/ yy
;
1532 scm_t_inum rr
= xx
% yy
;
1533 int needs_adjustment
;
1535 if (SCM_LIKELY (yy
> 0))
1536 needs_adjustment
= (rr
< 0);
1538 needs_adjustment
= (rr
> 0);
1540 if (needs_adjustment
)
1546 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1547 *qp
= SCM_I_MAKINUM (qq
);
1549 *qp
= scm_i_inum2big (qq
);
1550 *rp
= SCM_I_MAKINUM (rr
);
1554 else if (SCM_BIGP (y
))
1556 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1557 scm_remember_upto_here_1 (y
);
1562 SCM r
= scm_i_mkbig ();
1563 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1564 scm_remember_upto_here_1 (y
);
1565 *qp
= SCM_I_MAKINUM (-1);
1566 *rp
= scm_i_normbig (r
);
1581 SCM r
= scm_i_mkbig ();
1582 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1583 scm_remember_upto_here_1 (y
);
1584 *qp
= SCM_I_MAKINUM (-1);
1585 *rp
= scm_i_normbig (r
);
1589 else if (SCM_REALP (y
))
1590 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1591 else if (SCM_FRACTIONP (y
))
1592 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1594 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1595 s_scm_floor_divide
, qp
, rp
);
1597 else if (SCM_BIGP (x
))
1599 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1601 scm_t_inum yy
= SCM_I_INUM (y
);
1602 if (SCM_UNLIKELY (yy
== 0))
1603 scm_num_overflow (s_scm_floor_divide
);
1606 SCM q
= scm_i_mkbig ();
1607 SCM r
= scm_i_mkbig ();
1609 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1610 SCM_I_BIG_MPZ (x
), yy
);
1613 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1614 SCM_I_BIG_MPZ (x
), -yy
);
1615 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1617 scm_remember_upto_here_1 (x
);
1618 *qp
= scm_i_normbig (q
);
1619 *rp
= scm_i_normbig (r
);
1623 else if (SCM_BIGP (y
))
1625 SCM q
= scm_i_mkbig ();
1626 SCM r
= scm_i_mkbig ();
1627 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1628 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1629 scm_remember_upto_here_2 (x
, y
);
1630 *qp
= scm_i_normbig (q
);
1631 *rp
= scm_i_normbig (r
);
1634 else if (SCM_REALP (y
))
1635 return scm_i_inexact_floor_divide
1636 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1637 else if (SCM_FRACTIONP (y
))
1638 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1640 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1641 s_scm_floor_divide
, qp
, rp
);
1643 else if (SCM_REALP (x
))
1645 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1646 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1647 return scm_i_inexact_floor_divide
1648 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1650 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1651 s_scm_floor_divide
, qp
, rp
);
1653 else if (SCM_FRACTIONP (x
))
1656 return scm_i_inexact_floor_divide
1657 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1658 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1659 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1661 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1662 s_scm_floor_divide
, qp
, rp
);
1665 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1666 s_scm_floor_divide
, qp
, rp
);
1670 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1672 if (SCM_UNLIKELY (y
== 0))
1673 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1676 double q
= floor (x
/ y
);
1677 double r
= x
- q
* y
;
1678 *qp
= scm_i_from_double (q
);
1679 *rp
= scm_i_from_double (r
);
1684 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1687 SCM xd
= scm_denominator (x
);
1688 SCM yd
= scm_denominator (y
);
1690 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1691 scm_product (scm_numerator (y
), xd
),
1693 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1696 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1697 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1699 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1701 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1703 "(ceiling-quotient 123 10) @result{} 13\n"
1704 "(ceiling-quotient 123 -10) @result{} -12\n"
1705 "(ceiling-quotient -123 10) @result{} -12\n"
1706 "(ceiling-quotient -123 -10) @result{} 13\n"
1707 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1708 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1710 #define FUNC_NAME s_scm_ceiling_quotient
1712 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1714 scm_t_inum xx
= SCM_I_INUM (x
);
1715 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1717 scm_t_inum yy
= SCM_I_INUM (y
);
1718 if (SCM_UNLIKELY (yy
== 0))
1719 scm_num_overflow (s_scm_ceiling_quotient
);
1722 scm_t_inum xx1
= xx
;
1724 if (SCM_LIKELY (yy
> 0))
1726 if (SCM_LIKELY (xx
>= 0))
1732 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1733 return SCM_I_MAKINUM (qq
);
1735 return scm_i_inum2big (qq
);
1738 else if (SCM_BIGP (y
))
1740 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1741 scm_remember_upto_here_1 (y
);
1742 if (SCM_LIKELY (sign
> 0))
1744 if (SCM_LIKELY (xx
> 0))
1746 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1747 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1748 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1750 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1751 scm_remember_upto_here_1 (y
);
1752 return SCM_I_MAKINUM (-1);
1762 else if (SCM_REALP (y
))
1763 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1764 else if (SCM_FRACTIONP (y
))
1765 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1767 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1768 s_scm_ceiling_quotient
);
1770 else if (SCM_BIGP (x
))
1772 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1774 scm_t_inum yy
= SCM_I_INUM (y
);
1775 if (SCM_UNLIKELY (yy
== 0))
1776 scm_num_overflow (s_scm_ceiling_quotient
);
1777 else if (SCM_UNLIKELY (yy
== 1))
1781 SCM q
= scm_i_mkbig ();
1783 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1786 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1787 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1789 scm_remember_upto_here_1 (x
);
1790 return scm_i_normbig (q
);
1793 else if (SCM_BIGP (y
))
1795 SCM q
= scm_i_mkbig ();
1796 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1799 scm_remember_upto_here_2 (x
, y
);
1800 return scm_i_normbig (q
);
1802 else if (SCM_REALP (y
))
1803 return scm_i_inexact_ceiling_quotient
1804 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1805 else if (SCM_FRACTIONP (y
))
1806 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1808 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1809 s_scm_ceiling_quotient
);
1811 else if (SCM_REALP (x
))
1813 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1814 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1815 return scm_i_inexact_ceiling_quotient
1816 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1818 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1819 s_scm_ceiling_quotient
);
1821 else if (SCM_FRACTIONP (x
))
1824 return scm_i_inexact_ceiling_quotient
1825 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1826 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1827 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1829 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1830 s_scm_ceiling_quotient
);
1833 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1834 s_scm_ceiling_quotient
);
1839 scm_i_inexact_ceiling_quotient (double x
, double y
)
1841 if (SCM_UNLIKELY (y
== 0))
1842 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1844 return scm_i_from_double (ceil (x
/ y
));
1848 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1850 return scm_ceiling_quotient
1851 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1852 scm_product (scm_numerator (y
), scm_denominator (x
)));
1855 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1856 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1858 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1860 "Return the real number @var{r} such that\n"
1861 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1862 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1864 "(ceiling-remainder 123 10) @result{} -7\n"
1865 "(ceiling-remainder 123 -10) @result{} 3\n"
1866 "(ceiling-remainder -123 10) @result{} -3\n"
1867 "(ceiling-remainder -123 -10) @result{} 7\n"
1868 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1869 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1871 #define FUNC_NAME s_scm_ceiling_remainder
1873 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1875 scm_t_inum xx
= SCM_I_INUM (x
);
1876 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1878 scm_t_inum yy
= SCM_I_INUM (y
);
1879 if (SCM_UNLIKELY (yy
== 0))
1880 scm_num_overflow (s_scm_ceiling_remainder
);
1883 scm_t_inum rr
= xx
% yy
;
1884 int needs_adjustment
;
1886 if (SCM_LIKELY (yy
> 0))
1887 needs_adjustment
= (rr
> 0);
1889 needs_adjustment
= (rr
< 0);
1891 if (needs_adjustment
)
1893 return SCM_I_MAKINUM (rr
);
1896 else if (SCM_BIGP (y
))
1898 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1899 scm_remember_upto_here_1 (y
);
1900 if (SCM_LIKELY (sign
> 0))
1902 if (SCM_LIKELY (xx
> 0))
1904 SCM r
= scm_i_mkbig ();
1905 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1906 scm_remember_upto_here_1 (y
);
1907 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1908 return scm_i_normbig (r
);
1910 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1911 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1912 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1914 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1915 scm_remember_upto_here_1 (y
);
1925 SCM r
= scm_i_mkbig ();
1926 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1927 scm_remember_upto_here_1 (y
);
1928 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1929 return scm_i_normbig (r
);
1932 else if (SCM_REALP (y
))
1933 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1934 else if (SCM_FRACTIONP (y
))
1935 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1937 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1938 s_scm_ceiling_remainder
);
1940 else if (SCM_BIGP (x
))
1942 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1944 scm_t_inum yy
= SCM_I_INUM (y
);
1945 if (SCM_UNLIKELY (yy
== 0))
1946 scm_num_overflow (s_scm_ceiling_remainder
);
1951 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1953 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1954 scm_remember_upto_here_1 (x
);
1955 return SCM_I_MAKINUM (rr
);
1958 else if (SCM_BIGP (y
))
1960 SCM r
= scm_i_mkbig ();
1961 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1964 scm_remember_upto_here_2 (x
, y
);
1965 return scm_i_normbig (r
);
1967 else if (SCM_REALP (y
))
1968 return scm_i_inexact_ceiling_remainder
1969 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1970 else if (SCM_FRACTIONP (y
))
1971 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1973 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1974 s_scm_ceiling_remainder
);
1976 else if (SCM_REALP (x
))
1978 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1979 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1980 return scm_i_inexact_ceiling_remainder
1981 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1983 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1984 s_scm_ceiling_remainder
);
1986 else if (SCM_FRACTIONP (x
))
1989 return scm_i_inexact_ceiling_remainder
1990 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1991 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1992 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1994 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1995 s_scm_ceiling_remainder
);
1998 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1999 s_scm_ceiling_remainder
);
2004 scm_i_inexact_ceiling_remainder (double x
, double y
)
2006 /* Although it would be more efficient to use fmod here, we can't
2007 because it would in some cases produce results inconsistent with
2008 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2009 close). In particular, when x is very close to a multiple of y,
2010 then r might be either 0.0 or -y, but those two cases must
2011 correspond to different choices of q. If r = 0.0 then q must be
2012 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2013 and remainder chooses the other, it would be bad. */
2014 if (SCM_UNLIKELY (y
== 0))
2015 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2017 return scm_i_from_double (x
- y
* ceil (x
/ y
));
2021 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2023 SCM xd
= scm_denominator (x
);
2024 SCM yd
= scm_denominator (y
);
2025 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2026 scm_product (scm_numerator (y
), xd
));
2027 return scm_divide (r1
, scm_product (xd
, yd
));
2030 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2032 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2035 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2037 "Return the integer @var{q} and the real number @var{r}\n"
2038 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2039 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2041 "(ceiling/ 123 10) @result{} 13 and -7\n"
2042 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2043 "(ceiling/ -123 10) @result{} -12 and -3\n"
2044 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2045 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2046 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2048 #define FUNC_NAME s_scm_i_ceiling_divide
2052 scm_ceiling_divide(x
, y
, &q
, &r
);
2053 return scm_values (scm_list_2 (q
, r
));
2057 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2058 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2061 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2063 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2065 scm_t_inum xx
= SCM_I_INUM (x
);
2066 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2068 scm_t_inum yy
= SCM_I_INUM (y
);
2069 if (SCM_UNLIKELY (yy
== 0))
2070 scm_num_overflow (s_scm_ceiling_divide
);
2073 scm_t_inum qq
= xx
/ yy
;
2074 scm_t_inum rr
= xx
% yy
;
2075 int needs_adjustment
;
2077 if (SCM_LIKELY (yy
> 0))
2078 needs_adjustment
= (rr
> 0);
2080 needs_adjustment
= (rr
< 0);
2082 if (needs_adjustment
)
2087 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2088 *qp
= SCM_I_MAKINUM (qq
);
2090 *qp
= scm_i_inum2big (qq
);
2091 *rp
= SCM_I_MAKINUM (rr
);
2095 else if (SCM_BIGP (y
))
2097 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2098 scm_remember_upto_here_1 (y
);
2099 if (SCM_LIKELY (sign
> 0))
2101 if (SCM_LIKELY (xx
> 0))
2103 SCM r
= scm_i_mkbig ();
2104 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2105 scm_remember_upto_here_1 (y
);
2106 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2108 *rp
= scm_i_normbig (r
);
2110 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2111 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2112 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2114 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2115 scm_remember_upto_here_1 (y
);
2116 *qp
= SCM_I_MAKINUM (-1);
2132 SCM r
= scm_i_mkbig ();
2133 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2134 scm_remember_upto_here_1 (y
);
2135 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2137 *rp
= scm_i_normbig (r
);
2141 else if (SCM_REALP (y
))
2142 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2143 else if (SCM_FRACTIONP (y
))
2144 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2146 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2147 s_scm_ceiling_divide
, qp
, rp
);
2149 else if (SCM_BIGP (x
))
2151 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2153 scm_t_inum yy
= SCM_I_INUM (y
);
2154 if (SCM_UNLIKELY (yy
== 0))
2155 scm_num_overflow (s_scm_ceiling_divide
);
2158 SCM q
= scm_i_mkbig ();
2159 SCM r
= scm_i_mkbig ();
2161 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2162 SCM_I_BIG_MPZ (x
), yy
);
2165 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2166 SCM_I_BIG_MPZ (x
), -yy
);
2167 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2169 scm_remember_upto_here_1 (x
);
2170 *qp
= scm_i_normbig (q
);
2171 *rp
= scm_i_normbig (r
);
2175 else if (SCM_BIGP (y
))
2177 SCM q
= scm_i_mkbig ();
2178 SCM r
= scm_i_mkbig ();
2179 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2180 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2181 scm_remember_upto_here_2 (x
, y
);
2182 *qp
= scm_i_normbig (q
);
2183 *rp
= scm_i_normbig (r
);
2186 else if (SCM_REALP (y
))
2187 return scm_i_inexact_ceiling_divide
2188 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2189 else if (SCM_FRACTIONP (y
))
2190 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2192 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2193 s_scm_ceiling_divide
, qp
, rp
);
2195 else if (SCM_REALP (x
))
2197 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2198 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2199 return scm_i_inexact_ceiling_divide
2200 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2202 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2203 s_scm_ceiling_divide
, qp
, rp
);
2205 else if (SCM_FRACTIONP (x
))
2208 return scm_i_inexact_ceiling_divide
2209 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2210 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2211 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2213 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2214 s_scm_ceiling_divide
, qp
, rp
);
2217 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2218 s_scm_ceiling_divide
, qp
, rp
);
2222 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2224 if (SCM_UNLIKELY (y
== 0))
2225 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2228 double q
= ceil (x
/ y
);
2229 double r
= x
- q
* y
;
2230 *qp
= scm_i_from_double (q
);
2231 *rp
= scm_i_from_double (r
);
2236 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2239 SCM xd
= scm_denominator (x
);
2240 SCM yd
= scm_denominator (y
);
2242 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2243 scm_product (scm_numerator (y
), xd
),
2245 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2248 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2249 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2251 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2253 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2255 "(truncate-quotient 123 10) @result{} 12\n"
2256 "(truncate-quotient 123 -10) @result{} -12\n"
2257 "(truncate-quotient -123 10) @result{} -12\n"
2258 "(truncate-quotient -123 -10) @result{} 12\n"
2259 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2260 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2262 #define FUNC_NAME s_scm_truncate_quotient
2264 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2266 scm_t_inum xx
= SCM_I_INUM (x
);
2267 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2269 scm_t_inum yy
= SCM_I_INUM (y
);
2270 if (SCM_UNLIKELY (yy
== 0))
2271 scm_num_overflow (s_scm_truncate_quotient
);
2274 scm_t_inum qq
= xx
/ yy
;
2275 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2276 return SCM_I_MAKINUM (qq
);
2278 return scm_i_inum2big (qq
);
2281 else if (SCM_BIGP (y
))
2283 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2284 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2285 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2287 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2288 scm_remember_upto_here_1 (y
);
2289 return SCM_I_MAKINUM (-1);
2294 else if (SCM_REALP (y
))
2295 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2296 else if (SCM_FRACTIONP (y
))
2297 return scm_i_exact_rational_truncate_quotient (x
, y
);
2299 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2300 s_scm_truncate_quotient
);
2302 else if (SCM_BIGP (x
))
2304 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2306 scm_t_inum yy
= SCM_I_INUM (y
);
2307 if (SCM_UNLIKELY (yy
== 0))
2308 scm_num_overflow (s_scm_truncate_quotient
);
2309 else if (SCM_UNLIKELY (yy
== 1))
2313 SCM q
= scm_i_mkbig ();
2315 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2318 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2319 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2321 scm_remember_upto_here_1 (x
);
2322 return scm_i_normbig (q
);
2325 else if (SCM_BIGP (y
))
2327 SCM q
= scm_i_mkbig ();
2328 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2331 scm_remember_upto_here_2 (x
, y
);
2332 return scm_i_normbig (q
);
2334 else if (SCM_REALP (y
))
2335 return scm_i_inexact_truncate_quotient
2336 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2337 else if (SCM_FRACTIONP (y
))
2338 return scm_i_exact_rational_truncate_quotient (x
, y
);
2340 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2341 s_scm_truncate_quotient
);
2343 else if (SCM_REALP (x
))
2345 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2346 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2347 return scm_i_inexact_truncate_quotient
2348 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2350 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2351 s_scm_truncate_quotient
);
2353 else if (SCM_FRACTIONP (x
))
2356 return scm_i_inexact_truncate_quotient
2357 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2358 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2359 return scm_i_exact_rational_truncate_quotient (x
, y
);
2361 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2362 s_scm_truncate_quotient
);
2365 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2366 s_scm_truncate_quotient
);
2371 scm_i_inexact_truncate_quotient (double x
, double y
)
2373 if (SCM_UNLIKELY (y
== 0))
2374 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2376 return scm_i_from_double (trunc (x
/ y
));
2380 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2382 return scm_truncate_quotient
2383 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2384 scm_product (scm_numerator (y
), scm_denominator (x
)));
2387 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2388 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2390 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2392 "Return the real number @var{r} such that\n"
2393 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2394 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2396 "(truncate-remainder 123 10) @result{} 3\n"
2397 "(truncate-remainder 123 -10) @result{} 3\n"
2398 "(truncate-remainder -123 10) @result{} -3\n"
2399 "(truncate-remainder -123 -10) @result{} -3\n"
2400 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2401 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2403 #define FUNC_NAME s_scm_truncate_remainder
2405 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2407 scm_t_inum xx
= SCM_I_INUM (x
);
2408 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2410 scm_t_inum yy
= SCM_I_INUM (y
);
2411 if (SCM_UNLIKELY (yy
== 0))
2412 scm_num_overflow (s_scm_truncate_remainder
);
2414 return SCM_I_MAKINUM (xx
% yy
);
2416 else if (SCM_BIGP (y
))
2418 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2419 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2420 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2422 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2423 scm_remember_upto_here_1 (y
);
2429 else if (SCM_REALP (y
))
2430 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2431 else if (SCM_FRACTIONP (y
))
2432 return scm_i_exact_rational_truncate_remainder (x
, y
);
2434 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2435 s_scm_truncate_remainder
);
2437 else if (SCM_BIGP (x
))
2439 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2441 scm_t_inum yy
= SCM_I_INUM (y
);
2442 if (SCM_UNLIKELY (yy
== 0))
2443 scm_num_overflow (s_scm_truncate_remainder
);
2446 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2447 (yy
> 0) ? yy
: -yy
)
2448 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2449 scm_remember_upto_here_1 (x
);
2450 return SCM_I_MAKINUM (rr
);
2453 else if (SCM_BIGP (y
))
2455 SCM r
= scm_i_mkbig ();
2456 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2459 scm_remember_upto_here_2 (x
, y
);
2460 return scm_i_normbig (r
);
2462 else if (SCM_REALP (y
))
2463 return scm_i_inexact_truncate_remainder
2464 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2465 else if (SCM_FRACTIONP (y
))
2466 return scm_i_exact_rational_truncate_remainder (x
, y
);
2468 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2469 s_scm_truncate_remainder
);
2471 else if (SCM_REALP (x
))
2473 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2474 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2475 return scm_i_inexact_truncate_remainder
2476 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2478 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2479 s_scm_truncate_remainder
);
2481 else if (SCM_FRACTIONP (x
))
2484 return scm_i_inexact_truncate_remainder
2485 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2486 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2487 return scm_i_exact_rational_truncate_remainder (x
, y
);
2489 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2490 s_scm_truncate_remainder
);
2493 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2494 s_scm_truncate_remainder
);
2499 scm_i_inexact_truncate_remainder (double x
, double y
)
2501 /* Although it would be more efficient to use fmod here, we can't
2502 because it would in some cases produce results inconsistent with
2503 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2504 close). In particular, when x is very close to a multiple of y,
2505 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2506 correspond to different choices of q. If quotient chooses one and
2507 remainder chooses the other, it would be bad. */
2508 if (SCM_UNLIKELY (y
== 0))
2509 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2511 return scm_i_from_double (x
- y
* trunc (x
/ y
));
2515 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2517 SCM xd
= scm_denominator (x
);
2518 SCM yd
= scm_denominator (y
);
2519 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2520 scm_product (scm_numerator (y
), xd
));
2521 return scm_divide (r1
, scm_product (xd
, yd
));
2525 static void scm_i_inexact_truncate_divide (double x
, double y
,
2527 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2530 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2532 "Return the integer @var{q} and the real number @var{r}\n"
2533 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2534 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2536 "(truncate/ 123 10) @result{} 12 and 3\n"
2537 "(truncate/ 123 -10) @result{} -12 and 3\n"
2538 "(truncate/ -123 10) @result{} -12 and -3\n"
2539 "(truncate/ -123 -10) @result{} 12 and -3\n"
2540 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2541 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2543 #define FUNC_NAME s_scm_i_truncate_divide
2547 scm_truncate_divide(x
, y
, &q
, &r
);
2548 return scm_values (scm_list_2 (q
, r
));
2552 #define s_scm_truncate_divide s_scm_i_truncate_divide
2553 #define g_scm_truncate_divide g_scm_i_truncate_divide
2556 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2558 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2560 scm_t_inum xx
= SCM_I_INUM (x
);
2561 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2563 scm_t_inum yy
= SCM_I_INUM (y
);
2564 if (SCM_UNLIKELY (yy
== 0))
2565 scm_num_overflow (s_scm_truncate_divide
);
2568 scm_t_inum qq
= xx
/ yy
;
2569 scm_t_inum rr
= xx
% yy
;
2570 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2571 *qp
= SCM_I_MAKINUM (qq
);
2573 *qp
= scm_i_inum2big (qq
);
2574 *rp
= SCM_I_MAKINUM (rr
);
2578 else if (SCM_BIGP (y
))
2580 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2581 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2582 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2584 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2585 scm_remember_upto_here_1 (y
);
2586 *qp
= SCM_I_MAKINUM (-1);
2596 else if (SCM_REALP (y
))
2597 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2598 else if (SCM_FRACTIONP (y
))
2599 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2601 return two_valued_wta_dispatch_2
2602 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2603 s_scm_truncate_divide
, qp
, rp
);
2605 else if (SCM_BIGP (x
))
2607 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2609 scm_t_inum yy
= SCM_I_INUM (y
);
2610 if (SCM_UNLIKELY (yy
== 0))
2611 scm_num_overflow (s_scm_truncate_divide
);
2614 SCM q
= scm_i_mkbig ();
2617 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2618 SCM_I_BIG_MPZ (x
), yy
);
2621 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2622 SCM_I_BIG_MPZ (x
), -yy
);
2623 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2625 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2626 scm_remember_upto_here_1 (x
);
2627 *qp
= scm_i_normbig (q
);
2628 *rp
= SCM_I_MAKINUM (rr
);
2632 else if (SCM_BIGP (y
))
2634 SCM q
= scm_i_mkbig ();
2635 SCM r
= scm_i_mkbig ();
2636 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2637 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2638 scm_remember_upto_here_2 (x
, y
);
2639 *qp
= scm_i_normbig (q
);
2640 *rp
= scm_i_normbig (r
);
2642 else if (SCM_REALP (y
))
2643 return scm_i_inexact_truncate_divide
2644 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2645 else if (SCM_FRACTIONP (y
))
2646 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2648 return two_valued_wta_dispatch_2
2649 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2650 s_scm_truncate_divide
, qp
, rp
);
2652 else if (SCM_REALP (x
))
2654 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2655 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2656 return scm_i_inexact_truncate_divide
2657 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2659 return two_valued_wta_dispatch_2
2660 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2661 s_scm_truncate_divide
, qp
, rp
);
2663 else if (SCM_FRACTIONP (x
))
2666 return scm_i_inexact_truncate_divide
2667 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2668 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2669 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2671 return two_valued_wta_dispatch_2
2672 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2673 s_scm_truncate_divide
, qp
, rp
);
2676 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2677 s_scm_truncate_divide
, qp
, rp
);
2681 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2683 if (SCM_UNLIKELY (y
== 0))
2684 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2687 double q
= trunc (x
/ y
);
2688 double r
= x
- q
* y
;
2689 *qp
= scm_i_from_double (q
);
2690 *rp
= scm_i_from_double (r
);
2695 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2698 SCM xd
= scm_denominator (x
);
2699 SCM yd
= scm_denominator (y
);
2701 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2702 scm_product (scm_numerator (y
), xd
),
2704 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2707 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2708 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2709 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2711 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2713 "Return the integer @var{q} such that\n"
2714 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2715 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2717 "(centered-quotient 123 10) @result{} 12\n"
2718 "(centered-quotient 123 -10) @result{} -12\n"
2719 "(centered-quotient -123 10) @result{} -12\n"
2720 "(centered-quotient -123 -10) @result{} 12\n"
2721 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2722 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2724 #define FUNC_NAME s_scm_centered_quotient
2726 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2728 scm_t_inum xx
= SCM_I_INUM (x
);
2729 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2731 scm_t_inum yy
= SCM_I_INUM (y
);
2732 if (SCM_UNLIKELY (yy
== 0))
2733 scm_num_overflow (s_scm_centered_quotient
);
2736 scm_t_inum qq
= xx
/ yy
;
2737 scm_t_inum rr
= xx
% yy
;
2738 if (SCM_LIKELY (xx
> 0))
2740 if (SCM_LIKELY (yy
> 0))
2742 if (rr
>= (yy
+ 1) / 2)
2747 if (rr
>= (1 - yy
) / 2)
2753 if (SCM_LIKELY (yy
> 0))
2764 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2765 return SCM_I_MAKINUM (qq
);
2767 return scm_i_inum2big (qq
);
2770 else if (SCM_BIGP (y
))
2772 /* Pass a denormalized bignum version of x (even though it
2773 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2774 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2776 else if (SCM_REALP (y
))
2777 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2778 else if (SCM_FRACTIONP (y
))
2779 return scm_i_exact_rational_centered_quotient (x
, y
);
2781 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2782 s_scm_centered_quotient
);
2784 else if (SCM_BIGP (x
))
2786 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2788 scm_t_inum yy
= SCM_I_INUM (y
);
2789 if (SCM_UNLIKELY (yy
== 0))
2790 scm_num_overflow (s_scm_centered_quotient
);
2791 else if (SCM_UNLIKELY (yy
== 1))
2795 SCM q
= scm_i_mkbig ();
2797 /* Arrange for rr to initially be non-positive,
2798 because that simplifies the test to see
2799 if it is within the needed bounds. */
2802 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2803 SCM_I_BIG_MPZ (x
), yy
);
2804 scm_remember_upto_here_1 (x
);
2806 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2807 SCM_I_BIG_MPZ (q
), 1);
2811 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2812 SCM_I_BIG_MPZ (x
), -yy
);
2813 scm_remember_upto_here_1 (x
);
2814 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2816 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2817 SCM_I_BIG_MPZ (q
), 1);
2819 return scm_i_normbig (q
);
2822 else if (SCM_BIGP (y
))
2823 return scm_i_bigint_centered_quotient (x
, y
);
2824 else if (SCM_REALP (y
))
2825 return scm_i_inexact_centered_quotient
2826 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2827 else if (SCM_FRACTIONP (y
))
2828 return scm_i_exact_rational_centered_quotient (x
, y
);
2830 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2831 s_scm_centered_quotient
);
2833 else if (SCM_REALP (x
))
2835 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2836 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2837 return scm_i_inexact_centered_quotient
2838 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2840 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2841 s_scm_centered_quotient
);
2843 else if (SCM_FRACTIONP (x
))
2846 return scm_i_inexact_centered_quotient
2847 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2848 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2849 return scm_i_exact_rational_centered_quotient (x
, y
);
2851 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2852 s_scm_centered_quotient
);
2855 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2856 s_scm_centered_quotient
);
2861 scm_i_inexact_centered_quotient (double x
, double y
)
2863 if (SCM_LIKELY (y
> 0))
2864 return scm_i_from_double (floor (x
/y
+ 0.5));
2865 else if (SCM_LIKELY (y
< 0))
2866 return scm_i_from_double (ceil (x
/y
- 0.5));
2868 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2873 /* Assumes that both x and y are bigints, though
2874 x might be able to fit into a fixnum. */
2876 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2880 /* Note that x might be small enough to fit into a
2881 fixnum, so we must not let it escape into the wild */
2885 /* min_r will eventually become -abs(y)/2 */
2886 min_r
= scm_i_mkbig ();
2887 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2888 SCM_I_BIG_MPZ (y
), 1);
2890 /* Arrange for rr to initially be non-positive,
2891 because that simplifies the test to see
2892 if it is within the needed bounds. */
2893 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2895 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2896 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2897 scm_remember_upto_here_2 (x
, y
);
2898 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2899 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2900 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2901 SCM_I_BIG_MPZ (q
), 1);
2905 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2906 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2907 scm_remember_upto_here_2 (x
, y
);
2908 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2909 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2910 SCM_I_BIG_MPZ (q
), 1);
2912 scm_remember_upto_here_2 (r
, min_r
);
2913 return scm_i_normbig (q
);
2917 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2919 return scm_centered_quotient
2920 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2921 scm_product (scm_numerator (y
), scm_denominator (x
)));
2924 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2925 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2926 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2928 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2930 "Return the real number @var{r} such that\n"
2931 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2932 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2933 "for some integer @var{q}.\n"
2935 "(centered-remainder 123 10) @result{} 3\n"
2936 "(centered-remainder 123 -10) @result{} 3\n"
2937 "(centered-remainder -123 10) @result{} -3\n"
2938 "(centered-remainder -123 -10) @result{} -3\n"
2939 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2940 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2942 #define FUNC_NAME s_scm_centered_remainder
2944 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2946 scm_t_inum xx
= SCM_I_INUM (x
);
2947 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2949 scm_t_inum yy
= SCM_I_INUM (y
);
2950 if (SCM_UNLIKELY (yy
== 0))
2951 scm_num_overflow (s_scm_centered_remainder
);
2954 scm_t_inum rr
= xx
% yy
;
2955 if (SCM_LIKELY (xx
> 0))
2957 if (SCM_LIKELY (yy
> 0))
2959 if (rr
>= (yy
+ 1) / 2)
2964 if (rr
>= (1 - yy
) / 2)
2970 if (SCM_LIKELY (yy
> 0))
2981 return SCM_I_MAKINUM (rr
);
2984 else if (SCM_BIGP (y
))
2986 /* Pass a denormalized bignum version of x (even though it
2987 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2988 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2990 else if (SCM_REALP (y
))
2991 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2992 else if (SCM_FRACTIONP (y
))
2993 return scm_i_exact_rational_centered_remainder (x
, y
);
2995 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2996 s_scm_centered_remainder
);
2998 else if (SCM_BIGP (x
))
3000 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3002 scm_t_inum yy
= SCM_I_INUM (y
);
3003 if (SCM_UNLIKELY (yy
== 0))
3004 scm_num_overflow (s_scm_centered_remainder
);
3008 /* Arrange for rr to initially be non-positive,
3009 because that simplifies the test to see
3010 if it is within the needed bounds. */
3013 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3014 scm_remember_upto_here_1 (x
);
3020 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3021 scm_remember_upto_here_1 (x
);
3025 return SCM_I_MAKINUM (rr
);
3028 else if (SCM_BIGP (y
))
3029 return scm_i_bigint_centered_remainder (x
, y
);
3030 else if (SCM_REALP (y
))
3031 return scm_i_inexact_centered_remainder
3032 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3033 else if (SCM_FRACTIONP (y
))
3034 return scm_i_exact_rational_centered_remainder (x
, y
);
3036 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3037 s_scm_centered_remainder
);
3039 else if (SCM_REALP (x
))
3041 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3042 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3043 return scm_i_inexact_centered_remainder
3044 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3046 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3047 s_scm_centered_remainder
);
3049 else if (SCM_FRACTIONP (x
))
3052 return scm_i_inexact_centered_remainder
3053 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3054 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3055 return scm_i_exact_rational_centered_remainder (x
, y
);
3057 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3058 s_scm_centered_remainder
);
3061 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3062 s_scm_centered_remainder
);
3067 scm_i_inexact_centered_remainder (double x
, double y
)
3071 /* Although it would be more efficient to use fmod here, we can't
3072 because it would in some cases produce results inconsistent with
3073 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3074 close). In particular, when x-y/2 is very close to a multiple of
3075 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3076 two cases must correspond to different choices of q. If quotient
3077 chooses one and remainder chooses the other, it would be bad. */
3078 if (SCM_LIKELY (y
> 0))
3079 q
= floor (x
/y
+ 0.5);
3080 else if (SCM_LIKELY (y
< 0))
3081 q
= ceil (x
/y
- 0.5);
3083 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3086 return scm_i_from_double (x
- q
* y
);
3089 /* Assumes that both x and y are bigints, though
3090 x might be able to fit into a fixnum. */
3092 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3096 /* Note that x might be small enough to fit into a
3097 fixnum, so we must not let it escape into the wild */
3100 /* min_r will eventually become -abs(y)/2 */
3101 min_r
= scm_i_mkbig ();
3102 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3103 SCM_I_BIG_MPZ (y
), 1);
3105 /* Arrange for rr to initially be non-positive,
3106 because that simplifies the test to see
3107 if it is within the needed bounds. */
3108 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3110 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3111 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3112 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3113 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3114 mpz_add (SCM_I_BIG_MPZ (r
),
3120 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3121 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3122 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3123 mpz_sub (SCM_I_BIG_MPZ (r
),
3127 scm_remember_upto_here_2 (x
, y
);
3128 return scm_i_normbig (r
);
3132 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3134 SCM xd
= scm_denominator (x
);
3135 SCM yd
= scm_denominator (y
);
3136 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3137 scm_product (scm_numerator (y
), xd
));
3138 return scm_divide (r1
, scm_product (xd
, yd
));
3142 static void scm_i_inexact_centered_divide (double x
, double y
,
3144 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3145 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3148 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3150 "Return the integer @var{q} and the real number @var{r}\n"
3151 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3152 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3154 "(centered/ 123 10) @result{} 12 and 3\n"
3155 "(centered/ 123 -10) @result{} -12 and 3\n"
3156 "(centered/ -123 10) @result{} -12 and -3\n"
3157 "(centered/ -123 -10) @result{} 12 and -3\n"
3158 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3159 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3161 #define FUNC_NAME s_scm_i_centered_divide
3165 scm_centered_divide(x
, y
, &q
, &r
);
3166 return scm_values (scm_list_2 (q
, r
));
3170 #define s_scm_centered_divide s_scm_i_centered_divide
3171 #define g_scm_centered_divide g_scm_i_centered_divide
3174 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3176 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3178 scm_t_inum xx
= SCM_I_INUM (x
);
3179 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3181 scm_t_inum yy
= SCM_I_INUM (y
);
3182 if (SCM_UNLIKELY (yy
== 0))
3183 scm_num_overflow (s_scm_centered_divide
);
3186 scm_t_inum qq
= xx
/ yy
;
3187 scm_t_inum rr
= xx
% yy
;
3188 if (SCM_LIKELY (xx
> 0))
3190 if (SCM_LIKELY (yy
> 0))
3192 if (rr
>= (yy
+ 1) / 2)
3197 if (rr
>= (1 - yy
) / 2)
3203 if (SCM_LIKELY (yy
> 0))
3214 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3215 *qp
= SCM_I_MAKINUM (qq
);
3217 *qp
= scm_i_inum2big (qq
);
3218 *rp
= SCM_I_MAKINUM (rr
);
3222 else if (SCM_BIGP (y
))
3224 /* Pass a denormalized bignum version of x (even though it
3225 can fit in a fixnum) to scm_i_bigint_centered_divide */
3226 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3228 else if (SCM_REALP (y
))
3229 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3230 else if (SCM_FRACTIONP (y
))
3231 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3233 return two_valued_wta_dispatch_2
3234 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3235 s_scm_centered_divide
, qp
, rp
);
3237 else if (SCM_BIGP (x
))
3239 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3241 scm_t_inum yy
= SCM_I_INUM (y
);
3242 if (SCM_UNLIKELY (yy
== 0))
3243 scm_num_overflow (s_scm_centered_divide
);
3246 SCM q
= scm_i_mkbig ();
3248 /* Arrange for rr to initially be non-positive,
3249 because that simplifies the test to see
3250 if it is within the needed bounds. */
3253 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3254 SCM_I_BIG_MPZ (x
), yy
);
3255 scm_remember_upto_here_1 (x
);
3258 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3259 SCM_I_BIG_MPZ (q
), 1);
3265 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3266 SCM_I_BIG_MPZ (x
), -yy
);
3267 scm_remember_upto_here_1 (x
);
3268 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3271 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3272 SCM_I_BIG_MPZ (q
), 1);
3276 *qp
= scm_i_normbig (q
);
3277 *rp
= SCM_I_MAKINUM (rr
);
3281 else if (SCM_BIGP (y
))
3282 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3283 else if (SCM_REALP (y
))
3284 return scm_i_inexact_centered_divide
3285 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3286 else if (SCM_FRACTIONP (y
))
3287 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3289 return two_valued_wta_dispatch_2
3290 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3291 s_scm_centered_divide
, qp
, rp
);
3293 else if (SCM_REALP (x
))
3295 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3296 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3297 return scm_i_inexact_centered_divide
3298 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3300 return two_valued_wta_dispatch_2
3301 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3302 s_scm_centered_divide
, qp
, rp
);
3304 else if (SCM_FRACTIONP (x
))
3307 return scm_i_inexact_centered_divide
3308 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3309 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3310 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3312 return two_valued_wta_dispatch_2
3313 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3314 s_scm_centered_divide
, qp
, rp
);
3317 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3318 s_scm_centered_divide
, qp
, rp
);
3322 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3326 if (SCM_LIKELY (y
> 0))
3327 q
= floor (x
/y
+ 0.5);
3328 else if (SCM_LIKELY (y
< 0))
3329 q
= ceil (x
/y
- 0.5);
3331 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3335 *qp
= scm_i_from_double (q
);
3336 *rp
= scm_i_from_double (r
);
3339 /* Assumes that both x and y are bigints, though
3340 x might be able to fit into a fixnum. */
3342 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3346 /* Note that x might be small enough to fit into a
3347 fixnum, so we must not let it escape into the wild */
3351 /* min_r will eventually become -abs(y/2) */
3352 min_r
= scm_i_mkbig ();
3353 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3354 SCM_I_BIG_MPZ (y
), 1);
3356 /* Arrange for rr to initially be non-positive,
3357 because that simplifies the test to see
3358 if it is within the needed bounds. */
3359 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3361 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3362 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3363 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3364 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3366 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3367 SCM_I_BIG_MPZ (q
), 1);
3368 mpz_add (SCM_I_BIG_MPZ (r
),
3375 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3376 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3377 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3379 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3380 SCM_I_BIG_MPZ (q
), 1);
3381 mpz_sub (SCM_I_BIG_MPZ (r
),
3386 scm_remember_upto_here_2 (x
, y
);
3387 *qp
= scm_i_normbig (q
);
3388 *rp
= scm_i_normbig (r
);
3392 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3395 SCM xd
= scm_denominator (x
);
3396 SCM yd
= scm_denominator (y
);
3398 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3399 scm_product (scm_numerator (y
), xd
),
3401 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3404 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3405 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3406 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3408 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3410 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3411 "with ties going to the nearest even integer.\n"
3413 "(round-quotient 123 10) @result{} 12\n"
3414 "(round-quotient 123 -10) @result{} -12\n"
3415 "(round-quotient -123 10) @result{} -12\n"
3416 "(round-quotient -123 -10) @result{} 12\n"
3417 "(round-quotient 125 10) @result{} 12\n"
3418 "(round-quotient 127 10) @result{} 13\n"
3419 "(round-quotient 135 10) @result{} 14\n"
3420 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3421 "(round-quotient 16/3 -10/7) @result{} -4\n"
3423 #define FUNC_NAME s_scm_round_quotient
3425 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3427 scm_t_inum xx
= SCM_I_INUM (x
);
3428 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3430 scm_t_inum yy
= SCM_I_INUM (y
);
3431 if (SCM_UNLIKELY (yy
== 0))
3432 scm_num_overflow (s_scm_round_quotient
);
3435 scm_t_inum qq
= xx
/ yy
;
3436 scm_t_inum rr
= xx
% yy
;
3438 scm_t_inum r2
= 2 * rr
;
3440 if (SCM_LIKELY (yy
< 0))
3460 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3461 return SCM_I_MAKINUM (qq
);
3463 return scm_i_inum2big (qq
);
3466 else if (SCM_BIGP (y
))
3468 /* Pass a denormalized bignum version of x (even though it
3469 can fit in a fixnum) to scm_i_bigint_round_quotient */
3470 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3472 else if (SCM_REALP (y
))
3473 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3474 else if (SCM_FRACTIONP (y
))
3475 return scm_i_exact_rational_round_quotient (x
, y
);
3477 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3478 s_scm_round_quotient
);
3480 else if (SCM_BIGP (x
))
3482 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3484 scm_t_inum yy
= SCM_I_INUM (y
);
3485 if (SCM_UNLIKELY (yy
== 0))
3486 scm_num_overflow (s_scm_round_quotient
);
3487 else if (SCM_UNLIKELY (yy
== 1))
3491 SCM q
= scm_i_mkbig ();
3493 int needs_adjustment
;
3497 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3498 SCM_I_BIG_MPZ (x
), yy
);
3499 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3500 needs_adjustment
= (2*rr
>= yy
);
3502 needs_adjustment
= (2*rr
> yy
);
3506 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3507 SCM_I_BIG_MPZ (x
), -yy
);
3508 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3509 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3510 needs_adjustment
= (2*rr
<= yy
);
3512 needs_adjustment
= (2*rr
< yy
);
3514 scm_remember_upto_here_1 (x
);
3515 if (needs_adjustment
)
3516 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3517 return scm_i_normbig (q
);
3520 else if (SCM_BIGP (y
))
3521 return scm_i_bigint_round_quotient (x
, y
);
3522 else if (SCM_REALP (y
))
3523 return scm_i_inexact_round_quotient
3524 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3525 else if (SCM_FRACTIONP (y
))
3526 return scm_i_exact_rational_round_quotient (x
, y
);
3528 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3529 s_scm_round_quotient
);
3531 else if (SCM_REALP (x
))
3533 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3534 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3535 return scm_i_inexact_round_quotient
3536 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3538 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3539 s_scm_round_quotient
);
3541 else if (SCM_FRACTIONP (x
))
3544 return scm_i_inexact_round_quotient
3545 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3546 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3547 return scm_i_exact_rational_round_quotient (x
, y
);
3549 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3550 s_scm_round_quotient
);
3553 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3554 s_scm_round_quotient
);
3559 scm_i_inexact_round_quotient (double x
, double y
)
3561 if (SCM_UNLIKELY (y
== 0))
3562 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3564 return scm_i_from_double (scm_c_round (x
/ y
));
3567 /* Assumes that both x and y are bigints, though
3568 x might be able to fit into a fixnum. */
3570 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3573 int cmp
, needs_adjustment
;
3575 /* Note that x might be small enough to fit into a
3576 fixnum, so we must not let it escape into the wild */
3579 r2
= scm_i_mkbig ();
3581 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3582 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3583 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3584 scm_remember_upto_here_2 (x
, r
);
3586 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3587 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3588 needs_adjustment
= (cmp
>= 0);
3590 needs_adjustment
= (cmp
> 0);
3591 scm_remember_upto_here_2 (r2
, y
);
3593 if (needs_adjustment
)
3594 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3596 return scm_i_normbig (q
);
3600 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3602 return scm_round_quotient
3603 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3604 scm_product (scm_numerator (y
), scm_denominator (x
)));
3607 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3608 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3609 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3611 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3613 "Return the real number @var{r} such that\n"
3614 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3615 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3616 "nearest integer, with ties going to the nearest\n"
3619 "(round-remainder 123 10) @result{} 3\n"
3620 "(round-remainder 123 -10) @result{} 3\n"
3621 "(round-remainder -123 10) @result{} -3\n"
3622 "(round-remainder -123 -10) @result{} -3\n"
3623 "(round-remainder 125 10) @result{} 5\n"
3624 "(round-remainder 127 10) @result{} -3\n"
3625 "(round-remainder 135 10) @result{} -5\n"
3626 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3627 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3629 #define FUNC_NAME s_scm_round_remainder
3631 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3633 scm_t_inum xx
= SCM_I_INUM (x
);
3634 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3636 scm_t_inum yy
= SCM_I_INUM (y
);
3637 if (SCM_UNLIKELY (yy
== 0))
3638 scm_num_overflow (s_scm_round_remainder
);
3641 scm_t_inum qq
= xx
/ yy
;
3642 scm_t_inum rr
= xx
% yy
;
3644 scm_t_inum r2
= 2 * rr
;
3646 if (SCM_LIKELY (yy
< 0))
3666 return SCM_I_MAKINUM (rr
);
3669 else if (SCM_BIGP (y
))
3671 /* Pass a denormalized bignum version of x (even though it
3672 can fit in a fixnum) to scm_i_bigint_round_remainder */
3673 return scm_i_bigint_round_remainder
3674 (scm_i_long2big (xx
), y
);
3676 else if (SCM_REALP (y
))
3677 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3678 else if (SCM_FRACTIONP (y
))
3679 return scm_i_exact_rational_round_remainder (x
, y
);
3681 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3682 s_scm_round_remainder
);
3684 else if (SCM_BIGP (x
))
3686 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3688 scm_t_inum yy
= SCM_I_INUM (y
);
3689 if (SCM_UNLIKELY (yy
== 0))
3690 scm_num_overflow (s_scm_round_remainder
);
3693 SCM q
= scm_i_mkbig ();
3695 int needs_adjustment
;
3699 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3700 SCM_I_BIG_MPZ (x
), yy
);
3701 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3702 needs_adjustment
= (2*rr
>= yy
);
3704 needs_adjustment
= (2*rr
> yy
);
3708 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3709 SCM_I_BIG_MPZ (x
), -yy
);
3710 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3711 needs_adjustment
= (2*rr
<= yy
);
3713 needs_adjustment
= (2*rr
< yy
);
3715 scm_remember_upto_here_2 (x
, q
);
3716 if (needs_adjustment
)
3718 return SCM_I_MAKINUM (rr
);
3721 else if (SCM_BIGP (y
))
3722 return scm_i_bigint_round_remainder (x
, y
);
3723 else if (SCM_REALP (y
))
3724 return scm_i_inexact_round_remainder
3725 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3726 else if (SCM_FRACTIONP (y
))
3727 return scm_i_exact_rational_round_remainder (x
, y
);
3729 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3730 s_scm_round_remainder
);
3732 else if (SCM_REALP (x
))
3734 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3735 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3736 return scm_i_inexact_round_remainder
3737 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3739 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3740 s_scm_round_remainder
);
3742 else if (SCM_FRACTIONP (x
))
3745 return scm_i_inexact_round_remainder
3746 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3747 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3748 return scm_i_exact_rational_round_remainder (x
, y
);
3750 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3751 s_scm_round_remainder
);
3754 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3755 s_scm_round_remainder
);
3760 scm_i_inexact_round_remainder (double x
, double y
)
3762 /* Although it would be more efficient to use fmod here, we can't
3763 because it would in some cases produce results inconsistent with
3764 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3765 close). In particular, when x-y/2 is very close to a multiple of
3766 y, then r might be either -abs(y/2) or abs(y/2), but those two
3767 cases must correspond to different choices of q. If quotient
3768 chooses one and remainder chooses the other, it would be bad. */
3770 if (SCM_UNLIKELY (y
== 0))
3771 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3774 double q
= scm_c_round (x
/ y
);
3775 return scm_i_from_double (x
- q
* y
);
3779 /* Assumes that both x and y are bigints, though
3780 x might be able to fit into a fixnum. */
3782 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3785 int cmp
, needs_adjustment
;
3787 /* Note that x might be small enough to fit into a
3788 fixnum, so we must not let it escape into the wild */
3791 r2
= scm_i_mkbig ();
3793 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3794 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3795 scm_remember_upto_here_1 (x
);
3796 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3798 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3799 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3800 needs_adjustment
= (cmp
>= 0);
3802 needs_adjustment
= (cmp
> 0);
3803 scm_remember_upto_here_2 (q
, r2
);
3805 if (needs_adjustment
)
3806 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3808 scm_remember_upto_here_1 (y
);
3809 return scm_i_normbig (r
);
3813 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3815 SCM xd
= scm_denominator (x
);
3816 SCM yd
= scm_denominator (y
);
3817 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3818 scm_product (scm_numerator (y
), xd
));
3819 return scm_divide (r1
, scm_product (xd
, yd
));
3823 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3824 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3825 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3827 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3829 "Return the integer @var{q} and the real number @var{r}\n"
3830 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3831 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3832 "nearest integer, with ties going to the nearest even integer.\n"
3834 "(round/ 123 10) @result{} 12 and 3\n"
3835 "(round/ 123 -10) @result{} -12 and 3\n"
3836 "(round/ -123 10) @result{} -12 and -3\n"
3837 "(round/ -123 -10) @result{} 12 and -3\n"
3838 "(round/ 125 10) @result{} 12 and 5\n"
3839 "(round/ 127 10) @result{} 13 and -3\n"
3840 "(round/ 135 10) @result{} 14 and -5\n"
3841 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3842 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3844 #define FUNC_NAME s_scm_i_round_divide
3848 scm_round_divide(x
, y
, &q
, &r
);
3849 return scm_values (scm_list_2 (q
, r
));
3853 #define s_scm_round_divide s_scm_i_round_divide
3854 #define g_scm_round_divide g_scm_i_round_divide
3857 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3859 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3861 scm_t_inum xx
= SCM_I_INUM (x
);
3862 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3864 scm_t_inum yy
= SCM_I_INUM (y
);
3865 if (SCM_UNLIKELY (yy
== 0))
3866 scm_num_overflow (s_scm_round_divide
);
3869 scm_t_inum qq
= xx
/ yy
;
3870 scm_t_inum rr
= xx
% yy
;
3872 scm_t_inum r2
= 2 * rr
;
3874 if (SCM_LIKELY (yy
< 0))
3894 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3895 *qp
= SCM_I_MAKINUM (qq
);
3897 *qp
= scm_i_inum2big (qq
);
3898 *rp
= SCM_I_MAKINUM (rr
);
3902 else if (SCM_BIGP (y
))
3904 /* Pass a denormalized bignum version of x (even though it
3905 can fit in a fixnum) to scm_i_bigint_round_divide */
3906 return scm_i_bigint_round_divide
3907 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3909 else if (SCM_REALP (y
))
3910 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3911 else if (SCM_FRACTIONP (y
))
3912 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3914 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3915 s_scm_round_divide
, qp
, rp
);
3917 else if (SCM_BIGP (x
))
3919 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3921 scm_t_inum yy
= SCM_I_INUM (y
);
3922 if (SCM_UNLIKELY (yy
== 0))
3923 scm_num_overflow (s_scm_round_divide
);
3926 SCM q
= scm_i_mkbig ();
3928 int needs_adjustment
;
3932 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3933 SCM_I_BIG_MPZ (x
), yy
);
3934 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3935 needs_adjustment
= (2*rr
>= yy
);
3937 needs_adjustment
= (2*rr
> yy
);
3941 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3942 SCM_I_BIG_MPZ (x
), -yy
);
3943 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3944 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3945 needs_adjustment
= (2*rr
<= yy
);
3947 needs_adjustment
= (2*rr
< yy
);
3949 scm_remember_upto_here_1 (x
);
3950 if (needs_adjustment
)
3952 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3955 *qp
= scm_i_normbig (q
);
3956 *rp
= SCM_I_MAKINUM (rr
);
3960 else if (SCM_BIGP (y
))
3961 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3962 else if (SCM_REALP (y
))
3963 return scm_i_inexact_round_divide
3964 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3965 else if (SCM_FRACTIONP (y
))
3966 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3968 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3969 s_scm_round_divide
, qp
, rp
);
3971 else if (SCM_REALP (x
))
3973 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3974 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3975 return scm_i_inexact_round_divide
3976 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3978 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3979 s_scm_round_divide
, qp
, rp
);
3981 else if (SCM_FRACTIONP (x
))
3984 return scm_i_inexact_round_divide
3985 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3986 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3987 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3989 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3990 s_scm_round_divide
, qp
, rp
);
3993 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3994 s_scm_round_divide
, qp
, rp
);
3998 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
4000 if (SCM_UNLIKELY (y
== 0))
4001 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4004 double q
= scm_c_round (x
/ y
);
4005 double r
= x
- q
* y
;
4006 *qp
= scm_i_from_double (q
);
4007 *rp
= scm_i_from_double (r
);
4011 /* Assumes that both x and y are bigints, though
4012 x might be able to fit into a fixnum. */
4014 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4017 int cmp
, needs_adjustment
;
4019 /* Note that x might be small enough to fit into a
4020 fixnum, so we must not let it escape into the wild */
4023 r2
= scm_i_mkbig ();
4025 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4026 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4027 scm_remember_upto_here_1 (x
);
4028 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4030 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4031 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4032 needs_adjustment
= (cmp
>= 0);
4034 needs_adjustment
= (cmp
> 0);
4036 if (needs_adjustment
)
4038 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4039 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4042 scm_remember_upto_here_2 (r2
, y
);
4043 *qp
= scm_i_normbig (q
);
4044 *rp
= scm_i_normbig (r
);
4048 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4051 SCM xd
= scm_denominator (x
);
4052 SCM yd
= scm_denominator (y
);
4054 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4055 scm_product (scm_numerator (y
), xd
),
4057 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4061 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4062 (SCM x
, SCM y
, SCM rest
),
4063 "Return the greatest common divisor of all parameter values.\n"
4064 "If called without arguments, 0 is returned.")
4065 #define FUNC_NAME s_scm_i_gcd
4067 while (!scm_is_null (rest
))
4068 { x
= scm_gcd (x
, y
);
4070 rest
= scm_cdr (rest
);
4072 return scm_gcd (x
, y
);
4076 #define s_gcd s_scm_i_gcd
4077 #define g_gcd g_scm_i_gcd
4080 scm_gcd (SCM x
, SCM y
)
4082 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4083 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4085 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4087 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4089 scm_t_inum xx
= SCM_I_INUM (x
);
4090 scm_t_inum yy
= SCM_I_INUM (y
);
4091 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4092 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4094 if (SCM_UNLIKELY (xx
== 0))
4096 else if (SCM_UNLIKELY (yy
== 0))
4101 /* Determine a common factor 2^k */
4102 while (((u
| v
) & 1) == 0)
4108 /* Now, any factor 2^n can be eliminated */
4110 while ((u
& 1) == 0)
4113 while ((v
& 1) == 0)
4115 /* Both u and v are now odd. Subtract the smaller one
4116 from the larger one to produce an even number, remove
4117 more factors of two, and repeat. */
4123 while ((u
& 1) == 0)
4129 while ((v
& 1) == 0)
4135 return (SCM_POSFIXABLE (result
)
4136 ? SCM_I_MAKINUM (result
)
4137 : scm_i_inum2big (result
));
4139 else if (SCM_BIGP (y
))
4144 else if (SCM_REALP (y
) && scm_is_integer (y
))
4145 goto handle_inexacts
;
4147 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4149 else if (SCM_BIGP (x
))
4151 if (SCM_I_INUMP (y
))
4156 yy
= SCM_I_INUM (y
);
4161 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4162 scm_remember_upto_here_1 (x
);
4163 return (SCM_POSFIXABLE (result
)
4164 ? SCM_I_MAKINUM (result
)
4165 : scm_from_unsigned_integer (result
));
4167 else if (SCM_BIGP (y
))
4169 SCM result
= scm_i_mkbig ();
4170 mpz_gcd (SCM_I_BIG_MPZ (result
),
4173 scm_remember_upto_here_2 (x
, y
);
4174 return scm_i_normbig (result
);
4176 else if (SCM_REALP (y
) && scm_is_integer (y
))
4177 goto handle_inexacts
;
4179 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4181 else if (SCM_REALP (x
) && scm_is_integer (x
))
4183 if (SCM_I_INUMP (y
) || SCM_BIGP (y
)
4184 || (SCM_REALP (y
) && scm_is_integer (y
)))
4187 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x
),
4188 scm_inexact_to_exact (y
)));
4191 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4194 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4197 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4198 (SCM x
, SCM y
, SCM rest
),
4199 "Return the least common multiple of the arguments.\n"
4200 "If called without arguments, 1 is returned.")
4201 #define FUNC_NAME s_scm_i_lcm
4203 while (!scm_is_null (rest
))
4204 { x
= scm_lcm (x
, y
);
4206 rest
= scm_cdr (rest
);
4208 return scm_lcm (x
, y
);
4212 #define s_lcm s_scm_i_lcm
4213 #define g_lcm g_scm_i_lcm
4216 scm_lcm (SCM n1
, SCM n2
)
4218 if (SCM_UNLIKELY (SCM_UNBNDP (n2
)))
4219 return SCM_UNBNDP (n1
) ? SCM_INUM1
: scm_abs (n1
);
4221 if (SCM_LIKELY (SCM_I_INUMP (n1
)))
4223 if (SCM_LIKELY (SCM_I_INUMP (n2
)))
4225 SCM d
= scm_gcd (n1
, n2
);
4226 if (scm_is_eq (d
, SCM_INUM0
))
4229 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4231 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4233 /* inum n1, big n2 */
4236 SCM result
= scm_i_mkbig ();
4237 scm_t_inum nn1
= SCM_I_INUM (n1
);
4238 if (nn1
== 0) return SCM_INUM0
;
4239 if (nn1
< 0) nn1
= - nn1
;
4240 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4241 scm_remember_upto_here_1 (n2
);
4245 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4246 goto handle_inexacts
;
4248 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4250 else if (SCM_LIKELY (SCM_BIGP (n1
)))
4253 if (SCM_I_INUMP (n2
))
4258 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4260 SCM result
= scm_i_mkbig ();
4261 mpz_lcm(SCM_I_BIG_MPZ (result
),
4263 SCM_I_BIG_MPZ (n2
));
4264 scm_remember_upto_here_2(n1
, n2
);
4265 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4268 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4269 goto handle_inexacts
;
4271 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4273 else if (SCM_REALP (n1
) && scm_is_integer (n1
))
4275 if (SCM_I_INUMP (n2
) || SCM_BIGP (n2
)
4276 || (SCM_REALP (n2
) && scm_is_integer (n2
)))
4279 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1
),
4280 scm_inexact_to_exact (n2
)));
4283 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4286 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4289 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4294 + + + x (map digit:logand X Y)
4295 + - + x (map digit:logand X (lognot (+ -1 Y)))
4296 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4297 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4302 + + + (map digit:logior X Y)
4303 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4304 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4305 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4310 + + + (map digit:logxor X Y)
4311 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4312 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4313 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4318 + + (any digit:logand X Y)
4319 + - (any digit:logand X (lognot (+ -1 Y)))
4320 - + (any digit:logand (lognot (+ -1 X)) Y)
4325 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4326 (SCM x
, SCM y
, SCM rest
),
4327 "Return the bitwise AND of the integer arguments.\n\n"
4329 "(logand) @result{} -1\n"
4330 "(logand 7) @result{} 7\n"
4331 "(logand #b111 #b011 #b001) @result{} 1\n"
4333 #define FUNC_NAME s_scm_i_logand
4335 while (!scm_is_null (rest
))
4336 { x
= scm_logand (x
, y
);
4338 rest
= scm_cdr (rest
);
4340 return scm_logand (x
, y
);
4344 #define s_scm_logand s_scm_i_logand
4346 SCM
scm_logand (SCM n1
, SCM n2
)
4347 #define FUNC_NAME s_scm_logand
4351 if (SCM_UNBNDP (n2
))
4353 if (SCM_UNBNDP (n1
))
4354 return SCM_I_MAKINUM (-1);
4355 else if (!SCM_NUMBERP (n1
))
4356 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4357 else if (SCM_NUMBERP (n1
))
4360 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4363 if (SCM_I_INUMP (n1
))
4365 nn1
= SCM_I_INUM (n1
);
4366 if (SCM_I_INUMP (n2
))
4368 scm_t_inum nn2
= SCM_I_INUM (n2
);
4369 return SCM_I_MAKINUM (nn1
& nn2
);
4371 else if SCM_BIGP (n2
)
4377 SCM result_z
= scm_i_mkbig ();
4379 mpz_init_set_si (nn1_z
, nn1
);
4380 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4381 scm_remember_upto_here_1 (n2
);
4383 return scm_i_normbig (result_z
);
4387 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4389 else if (SCM_BIGP (n1
))
4391 if (SCM_I_INUMP (n2
))
4394 nn1
= SCM_I_INUM (n1
);
4397 else if (SCM_BIGP (n2
))
4399 SCM result_z
= scm_i_mkbig ();
4400 mpz_and (SCM_I_BIG_MPZ (result_z
),
4402 SCM_I_BIG_MPZ (n2
));
4403 scm_remember_upto_here_2 (n1
, n2
);
4404 return scm_i_normbig (result_z
);
4407 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4410 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4415 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4416 (SCM x
, SCM y
, SCM rest
),
4417 "Return the bitwise OR of the integer arguments.\n\n"
4419 "(logior) @result{} 0\n"
4420 "(logior 7) @result{} 7\n"
4421 "(logior #b000 #b001 #b011) @result{} 3\n"
4423 #define FUNC_NAME s_scm_i_logior
4425 while (!scm_is_null (rest
))
4426 { x
= scm_logior (x
, y
);
4428 rest
= scm_cdr (rest
);
4430 return scm_logior (x
, y
);
4434 #define s_scm_logior s_scm_i_logior
4436 SCM
scm_logior (SCM n1
, SCM n2
)
4437 #define FUNC_NAME s_scm_logior
4441 if (SCM_UNBNDP (n2
))
4443 if (SCM_UNBNDP (n1
))
4445 else if (SCM_NUMBERP (n1
))
4448 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4451 if (SCM_I_INUMP (n1
))
4453 nn1
= SCM_I_INUM (n1
);
4454 if (SCM_I_INUMP (n2
))
4456 long nn2
= SCM_I_INUM (n2
);
4457 return SCM_I_MAKINUM (nn1
| nn2
);
4459 else if (SCM_BIGP (n2
))
4465 SCM result_z
= scm_i_mkbig ();
4467 mpz_init_set_si (nn1_z
, nn1
);
4468 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4469 scm_remember_upto_here_1 (n2
);
4471 return scm_i_normbig (result_z
);
4475 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4477 else if (SCM_BIGP (n1
))
4479 if (SCM_I_INUMP (n2
))
4482 nn1
= SCM_I_INUM (n1
);
4485 else if (SCM_BIGP (n2
))
4487 SCM result_z
= scm_i_mkbig ();
4488 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4490 SCM_I_BIG_MPZ (n2
));
4491 scm_remember_upto_here_2 (n1
, n2
);
4492 return scm_i_normbig (result_z
);
4495 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4498 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4503 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4504 (SCM x
, SCM y
, SCM rest
),
4505 "Return the bitwise XOR of the integer arguments. A bit is\n"
4506 "set in the result if it is set in an odd number of arguments.\n"
4508 "(logxor) @result{} 0\n"
4509 "(logxor 7) @result{} 7\n"
4510 "(logxor #b000 #b001 #b011) @result{} 2\n"
4511 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4513 #define FUNC_NAME s_scm_i_logxor
4515 while (!scm_is_null (rest
))
4516 { x
= scm_logxor (x
, y
);
4518 rest
= scm_cdr (rest
);
4520 return scm_logxor (x
, y
);
4524 #define s_scm_logxor s_scm_i_logxor
4526 SCM
scm_logxor (SCM n1
, SCM n2
)
4527 #define FUNC_NAME s_scm_logxor
4531 if (SCM_UNBNDP (n2
))
4533 if (SCM_UNBNDP (n1
))
4535 else if (SCM_NUMBERP (n1
))
4538 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4541 if (SCM_I_INUMP (n1
))
4543 nn1
= SCM_I_INUM (n1
);
4544 if (SCM_I_INUMP (n2
))
4546 scm_t_inum nn2
= SCM_I_INUM (n2
);
4547 return SCM_I_MAKINUM (nn1
^ nn2
);
4549 else if (SCM_BIGP (n2
))
4553 SCM result_z
= scm_i_mkbig ();
4555 mpz_init_set_si (nn1_z
, nn1
);
4556 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4557 scm_remember_upto_here_1 (n2
);
4559 return scm_i_normbig (result_z
);
4563 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4565 else if (SCM_BIGP (n1
))
4567 if (SCM_I_INUMP (n2
))
4570 nn1
= SCM_I_INUM (n1
);
4573 else if (SCM_BIGP (n2
))
4575 SCM result_z
= scm_i_mkbig ();
4576 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4578 SCM_I_BIG_MPZ (n2
));
4579 scm_remember_upto_here_2 (n1
, n2
);
4580 return scm_i_normbig (result_z
);
4583 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4586 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4591 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4593 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4594 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4595 "without actually calculating the @code{logand}, just testing\n"
4599 "(logtest #b0100 #b1011) @result{} #f\n"
4600 "(logtest #b0100 #b0111) @result{} #t\n"
4602 #define FUNC_NAME s_scm_logtest
4606 if (SCM_I_INUMP (j
))
4608 nj
= SCM_I_INUM (j
);
4609 if (SCM_I_INUMP (k
))
4611 scm_t_inum nk
= SCM_I_INUM (k
);
4612 return scm_from_bool (nj
& nk
);
4614 else if (SCM_BIGP (k
))
4622 mpz_init_set_si (nj_z
, nj
);
4623 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4624 scm_remember_upto_here_1 (k
);
4625 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4631 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4633 else if (SCM_BIGP (j
))
4635 if (SCM_I_INUMP (k
))
4638 nj
= SCM_I_INUM (j
);
4641 else if (SCM_BIGP (k
))
4645 mpz_init (result_z
);
4649 scm_remember_upto_here_2 (j
, k
);
4650 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4651 mpz_clear (result_z
);
4655 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4658 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4663 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4665 "Test whether bit number @var{index} in @var{j} is set.\n"
4666 "@var{index} starts from 0 for the least significant bit.\n"
4669 "(logbit? 0 #b1101) @result{} #t\n"
4670 "(logbit? 1 #b1101) @result{} #f\n"
4671 "(logbit? 2 #b1101) @result{} #t\n"
4672 "(logbit? 3 #b1101) @result{} #t\n"
4673 "(logbit? 4 #b1101) @result{} #f\n"
4675 #define FUNC_NAME s_scm_logbit_p
4677 unsigned long int iindex
;
4678 iindex
= scm_to_ulong (index
);
4680 if (SCM_I_INUMP (j
))
4682 /* bits above what's in an inum follow the sign bit */
4683 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4684 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4686 else if (SCM_BIGP (j
))
4688 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4689 scm_remember_upto_here_1 (j
);
4690 return scm_from_bool (val
);
4693 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4698 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4700 "Return the integer which is the ones-complement of the integer\n"
4704 "(number->string (lognot #b10000000) 2)\n"
4705 " @result{} \"-10000001\"\n"
4706 "(number->string (lognot #b0) 2)\n"
4707 " @result{} \"-1\"\n"
4709 #define FUNC_NAME s_scm_lognot
4711 if (SCM_I_INUMP (n
)) {
4712 /* No overflow here, just need to toggle all the bits making up the inum.
4713 Enhancement: No need to strip the tag and add it back, could just xor
4714 a block of 1 bits, if that worked with the various debug versions of
4716 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4718 } else if (SCM_BIGP (n
)) {
4719 SCM result
= scm_i_mkbig ();
4720 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4721 scm_remember_upto_here_1 (n
);
4725 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4730 /* returns 0 if IN is not an integer. OUT must already be
4733 coerce_to_big (SCM in
, mpz_t out
)
4736 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4737 else if (SCM_I_INUMP (in
))
4738 mpz_set_si (out
, SCM_I_INUM (in
));
4745 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4746 (SCM n
, SCM k
, SCM m
),
4747 "Return @var{n} raised to the integer exponent\n"
4748 "@var{k}, modulo @var{m}.\n"
4751 "(modulo-expt 2 3 5)\n"
4754 #define FUNC_NAME s_scm_modulo_expt
4760 /* There are two classes of error we might encounter --
4761 1) Math errors, which we'll report by calling scm_num_overflow,
4763 2) wrong-type errors, which of course we'll report by calling
4765 We don't report those errors immediately, however; instead we do
4766 some cleanup first. These variables tell us which error (if
4767 any) we should report after cleaning up.
4769 int report_overflow
= 0;
4771 int position_of_wrong_type
= 0;
4772 SCM value_of_wrong_type
= SCM_INUM0
;
4774 SCM result
= SCM_UNDEFINED
;
4780 if (scm_is_eq (m
, SCM_INUM0
))
4782 report_overflow
= 1;
4786 if (!coerce_to_big (n
, n_tmp
))
4788 value_of_wrong_type
= n
;
4789 position_of_wrong_type
= 1;
4793 if (!coerce_to_big (k
, k_tmp
))
4795 value_of_wrong_type
= k
;
4796 position_of_wrong_type
= 2;
4800 if (!coerce_to_big (m
, m_tmp
))
4802 value_of_wrong_type
= m
;
4803 position_of_wrong_type
= 3;
4807 /* if the exponent K is negative, and we simply call mpz_powm, we
4808 will get a divide-by-zero exception when an inverse 1/n mod m
4809 doesn't exist (or is not unique). Since exceptions are hard to
4810 handle, we'll attempt the inversion "by hand" -- that way, we get
4811 a simple failure code, which is easy to handle. */
4813 if (-1 == mpz_sgn (k_tmp
))
4815 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4817 report_overflow
= 1;
4820 mpz_neg (k_tmp
, k_tmp
);
4823 result
= scm_i_mkbig ();
4824 mpz_powm (SCM_I_BIG_MPZ (result
),
4829 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4830 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4837 if (report_overflow
)
4838 scm_num_overflow (FUNC_NAME
);
4840 if (position_of_wrong_type
)
4841 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4842 value_of_wrong_type
);
4844 return scm_i_normbig (result
);
4848 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4850 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4851 "exact integer, @var{n} can be any number.\n"
4853 "Negative @var{k} is supported, and results in\n"
4854 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4855 "@math{@var{n}^0} is 1, as usual, and that\n"
4856 "includes @math{0^0} is 1.\n"
4859 "(integer-expt 2 5) @result{} 32\n"
4860 "(integer-expt -3 3) @result{} -27\n"
4861 "(integer-expt 5 -3) @result{} 1/125\n"
4862 "(integer-expt 0 0) @result{} 1\n"
4864 #define FUNC_NAME s_scm_integer_expt
4867 SCM z_i2
= SCM_BOOL_F
;
4869 SCM acc
= SCM_I_MAKINUM (1L);
4871 /* Specifically refrain from checking the type of the first argument.
4872 This allows us to exponentiate any object that can be multiplied.
4873 If we must raise to a negative power, we must also be able to
4874 take its reciprocal. */
4875 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4876 SCM_WRONG_TYPE_ARG (2, k
);
4878 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4879 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4880 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4881 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4882 /* The next check is necessary only because R6RS specifies different
4883 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4884 we simply skip this case and move on. */
4885 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4887 /* k cannot be 0 at this point, because we
4888 have already checked for that case above */
4889 if (scm_is_true (scm_positive_p (k
)))
4891 else /* return NaN for (0 ^ k) for negative k per R6RS */
4894 else if (SCM_FRACTIONP (n
))
4896 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4897 needless reduction of intermediate products to lowest terms.
4898 If a and b have no common factors, then a^k and b^k have no
4899 common factors. Use 'scm_i_make_ratio_already_reduced' to
4900 construct the final result, so that no gcd computations are
4901 needed to exponentiate a fraction. */
4902 if (scm_is_true (scm_positive_p (k
)))
4903 return scm_i_make_ratio_already_reduced
4904 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4905 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4908 k
= scm_difference (k
, SCM_UNDEFINED
);
4909 return scm_i_make_ratio_already_reduced
4910 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4911 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4915 if (SCM_I_INUMP (k
))
4916 i2
= SCM_I_INUM (k
);
4917 else if (SCM_BIGP (k
))
4919 z_i2
= scm_i_clonebig (k
, 1);
4920 scm_remember_upto_here_1 (k
);
4924 SCM_WRONG_TYPE_ARG (2, k
);
4928 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4930 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4931 n
= scm_divide (n
, SCM_UNDEFINED
);
4935 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4939 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4941 return scm_product (acc
, n
);
4943 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4944 acc
= scm_product (acc
, n
);
4945 n
= scm_product (n
, n
);
4946 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4954 n
= scm_divide (n
, SCM_UNDEFINED
);
4961 return scm_product (acc
, n
);
4963 acc
= scm_product (acc
, n
);
4964 n
= scm_product (n
, n
);
4971 /* Efficiently compute (N * 2^COUNT),
4972 where N is an exact integer, and COUNT > 0. */
4974 left_shift_exact_integer (SCM n
, long count
)
4976 if (SCM_I_INUMP (n
))
4978 scm_t_inum nn
= SCM_I_INUM (n
);
4980 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
4981 overflow a non-zero fixnum. For smaller shifts we check the
4982 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4983 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4984 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
4986 [*] There's one exception:
4987 (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
4991 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4992 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4994 return SCM_I_MAKINUM (nn
<< count
);
4997 SCM result
= scm_i_inum2big (nn
);
4998 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5000 return scm_i_normbig (result
);
5003 else if (SCM_BIGP (n
))
5005 SCM result
= scm_i_mkbig ();
5006 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5007 scm_remember_upto_here_1 (n
);
5014 /* Efficiently compute floor (N / 2^COUNT),
5015 where N is an exact integer and COUNT > 0. */
5017 floor_right_shift_exact_integer (SCM n
, long count
)
5019 if (SCM_I_INUMP (n
))
5021 scm_t_inum nn
= SCM_I_INUM (n
);
5023 if (count
>= SCM_I_FIXNUM_BIT
)
5024 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5026 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5028 else if (SCM_BIGP (n
))
5030 SCM result
= scm_i_mkbig ();
5031 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5033 scm_remember_upto_here_1 (n
);
5034 return scm_i_normbig (result
);
5040 /* Efficiently compute round (N / 2^COUNT),
5041 where N is an exact integer and COUNT > 0. */
5043 round_right_shift_exact_integer (SCM n
, long count
)
5045 if (SCM_I_INUMP (n
))
5047 if (count
>= SCM_I_FIXNUM_BIT
)
5051 scm_t_inum nn
= SCM_I_INUM (n
);
5052 scm_t_inum qq
= SCM_SRS (nn
, count
);
5054 if (0 == (nn
& (1L << (count
-1))))
5055 return SCM_I_MAKINUM (qq
); /* round down */
5056 else if (nn
& ((1L << (count
-1)) - 1))
5057 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5059 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5062 else if (SCM_BIGP (n
))
5064 SCM q
= scm_i_mkbig ();
5066 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5067 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5068 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5069 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5070 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5071 scm_remember_upto_here_1 (n
);
5072 return scm_i_normbig (q
);
5078 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5080 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5081 "@var{n} and @var{count} must be exact integers.\n"
5083 "With @var{n} viewed as an infinite-precision twos-complement\n"
5084 "integer, @code{ash} means a left shift introducing zero bits\n"
5085 "when @var{count} is positive, or a right shift dropping bits\n"
5086 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5089 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5090 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5092 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5093 "(ash -23 -2) @result{} -6\n"
5095 #define FUNC_NAME s_scm_ash
5097 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5099 long bits_to_shift
= scm_to_long (count
);
5101 if (bits_to_shift
> 0)
5102 return left_shift_exact_integer (n
, bits_to_shift
);
5103 else if (SCM_LIKELY (bits_to_shift
< 0))
5104 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5109 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5113 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5115 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5116 "@var{n} and @var{count} must be exact integers.\n"
5118 "With @var{n} viewed as an infinite-precision twos-complement\n"
5119 "integer, @code{round-ash} means a left shift introducing zero\n"
5120 "bits when @var{count} is positive, or a right shift rounding\n"
5121 "to the nearest integer (with ties going to the nearest even\n"
5122 "integer) when @var{count} is negative. This is a rounded\n"
5123 "``arithmetic'' shift.\n"
5126 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5127 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5128 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5129 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5130 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5131 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5133 #define FUNC_NAME s_scm_round_ash
5135 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5137 long bits_to_shift
= scm_to_long (count
);
5139 if (bits_to_shift
> 0)
5140 return left_shift_exact_integer (n
, bits_to_shift
);
5141 else if (SCM_LIKELY (bits_to_shift
< 0))
5142 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5147 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5152 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5153 (SCM n
, SCM start
, SCM end
),
5154 "Return the integer composed of the @var{start} (inclusive)\n"
5155 "through @var{end} (exclusive) bits of @var{n}. The\n"
5156 "@var{start}th bit becomes the 0-th bit in the result.\n"
5159 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5160 " @result{} \"1010\"\n"
5161 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5162 " @result{} \"10110\"\n"
5164 #define FUNC_NAME s_scm_bit_extract
5166 unsigned long int istart
, iend
, bits
;
5167 istart
= scm_to_ulong (start
);
5168 iend
= scm_to_ulong (end
);
5169 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5171 /* how many bits to keep */
5172 bits
= iend
- istart
;
5174 if (SCM_I_INUMP (n
))
5176 scm_t_inum in
= SCM_I_INUM (n
);
5178 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5179 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5180 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5182 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5184 /* Since we emulate two's complement encoded numbers, this
5185 * special case requires us to produce a result that has
5186 * more bits than can be stored in a fixnum.
5188 SCM result
= scm_i_inum2big (in
);
5189 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5194 /* mask down to requisite bits */
5195 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5196 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5198 else if (SCM_BIGP (n
))
5203 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5207 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5208 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5209 such bits into a ulong. */
5210 result
= scm_i_mkbig ();
5211 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5212 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5213 result
= scm_i_normbig (result
);
5215 scm_remember_upto_here_1 (n
);
5219 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5224 static const char scm_logtab
[] = {
5225 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5228 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5230 "Return the number of bits in integer @var{n}. If integer is\n"
5231 "positive, the 1-bits in its binary representation are counted.\n"
5232 "If negative, the 0-bits in its two's-complement binary\n"
5233 "representation are counted. If 0, 0 is returned.\n"
5236 "(logcount #b10101010)\n"
5243 #define FUNC_NAME s_scm_logcount
5245 if (SCM_I_INUMP (n
))
5247 unsigned long c
= 0;
5248 scm_t_inum nn
= SCM_I_INUM (n
);
5253 c
+= scm_logtab
[15 & nn
];
5256 return SCM_I_MAKINUM (c
);
5258 else if (SCM_BIGP (n
))
5260 unsigned long count
;
5261 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5262 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5264 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5265 scm_remember_upto_here_1 (n
);
5266 return SCM_I_MAKINUM (count
);
5269 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5274 static const char scm_ilentab
[] = {
5275 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5279 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5281 "Return the number of bits necessary to represent @var{n}.\n"
5284 "(integer-length #b10101010)\n"
5286 "(integer-length 0)\n"
5288 "(integer-length #b1111)\n"
5291 #define FUNC_NAME s_scm_integer_length
5293 if (SCM_I_INUMP (n
))
5295 unsigned long c
= 0;
5297 scm_t_inum nn
= SCM_I_INUM (n
);
5303 l
= scm_ilentab
[15 & nn
];
5306 return SCM_I_MAKINUM (c
- 4 + l
);
5308 else if (SCM_BIGP (n
))
5310 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5311 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5312 1 too big, so check for that and adjust. */
5313 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5314 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5315 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5316 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5318 scm_remember_upto_here_1 (n
);
5319 return SCM_I_MAKINUM (size
);
5322 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5326 /*** NUMBERS -> STRINGS ***/
5327 #define SCM_MAX_DBL_RADIX 36
5329 /* use this array as a way to generate a single digit */
5330 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5332 static mpz_t dbl_minimum_normal_mantissa
;
5335 idbl2str (double dbl
, char *a
, int radix
)
5339 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5340 /* revert to existing behavior */
5345 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5355 else if (dbl
== 0.0)
5357 if (copysign (1.0, dbl
) < 0.0)
5359 strcpy (a
+ ch
, "0.0");
5362 else if (isnan (dbl
))
5364 strcpy (a
, "+nan.0");
5368 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5369 Accurately" by Robert G. Burger and R. Kent Dybvig */
5372 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5373 int f_is_even
, f_is_odd
;
5377 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5378 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5379 if (e
< DBL_MIN_EXP
)
5381 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5386 f_is_even
= !mpz_odd_p (f
);
5387 f_is_odd
= !f_is_even
;
5389 /* Initialize r, s, mplus, and mminus according
5390 to Table 1 from the paper. */
5393 mpz_set_ui (mminus
, 1);
5394 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5395 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5397 mpz_set_ui (mplus
, 1);
5398 mpz_mul_2exp (r
, f
, 1);
5399 mpz_mul_2exp (s
, mminus
, 1 - e
);
5403 mpz_set_ui (mplus
, 2);
5404 mpz_mul_2exp (r
, f
, 2);
5405 mpz_mul_2exp (s
, mminus
, 2 - e
);
5410 mpz_set_ui (mminus
, 1);
5411 mpz_mul_2exp (mminus
, mminus
, e
);
5412 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5414 mpz_set (mplus
, mminus
);
5415 mpz_mul_2exp (r
, f
, 1 + e
);
5420 mpz_mul_2exp (mplus
, mminus
, 1);
5421 mpz_mul_2exp (r
, f
, 2 + e
);
5426 /* Find the smallest k such that:
5427 (r + mplus) / s < radix^k (if f is even)
5428 (r + mplus) / s <= radix^k (if f is odd) */
5430 /* IMPROVE-ME: Make an initial guess to speed this up */
5431 mpz_add (hi
, r
, mplus
);
5433 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5435 mpz_mul_ui (s
, s
, radix
);
5440 mpz_mul_ui (hi
, hi
, radix
);
5441 while (mpz_cmp (hi
, s
) < f_is_odd
)
5443 mpz_mul_ui (r
, r
, radix
);
5444 mpz_mul_ui (mplus
, mplus
, radix
);
5445 mpz_mul_ui (mminus
, mminus
, radix
);
5446 mpz_mul_ui (hi
, hi
, radix
);
5457 /* Use scientific notation */
5465 /* Print leading zeroes */
5468 for (i
= 0; i
> k
; i
--)
5475 int end_1_p
, end_2_p
;
5478 mpz_mul_ui (mplus
, mplus
, radix
);
5479 mpz_mul_ui (mminus
, mminus
, radix
);
5480 mpz_mul_ui (r
, r
, radix
);
5481 mpz_fdiv_qr (digit
, r
, r
, s
);
5482 d
= mpz_get_ui (digit
);
5484 mpz_add (hi
, r
, mplus
);
5485 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5486 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5487 if (end_1_p
|| end_2_p
)
5489 mpz_mul_2exp (r
, r
, 1);
5494 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5496 a
[ch
++] = number_chars
[d
];
5503 a
[ch
++] = number_chars
[d
];
5511 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5513 /* Here we would have to print more than three zeroes
5514 followed by a decimal point and another zero. It
5515 makes more sense to use scientific notation. */
5517 /* Adjust k to what it would have been if we had chosen
5518 scientific notation from the beginning. */
5521 /* k will now be <= 0, with magnitude equal to the number of
5522 digits that we printed which should now be put after the
5525 /* Insert a decimal point */
5526 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5546 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5549 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5556 icmplx2str (double real
, double imag
, char *str
, int radix
)
5561 i
= idbl2str (real
, str
, radix
);
5562 #ifdef HAVE_COPYSIGN
5563 sgn
= copysign (1.0, imag
);
5567 /* Don't output a '+' for negative numbers or for Inf and
5568 NaN. They will provide their own sign. */
5569 if (sgn
>= 0 && isfinite (imag
))
5571 i
+= idbl2str (imag
, &str
[i
], radix
);
5577 iflo2str (SCM flt
, char *str
, int radix
)
5580 if (SCM_REALP (flt
))
5581 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5583 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5588 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5589 characters in the result.
5591 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5593 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5598 return scm_iuint2str (-num
, rad
, p
) + 1;
5601 return scm_iuint2str (num
, rad
, p
);
5604 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5605 characters in the result.
5607 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5609 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5613 scm_t_uintmax n
= num
;
5615 if (rad
< 2 || rad
> 36)
5616 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5618 for (n
/= rad
; n
> 0; n
/= rad
)
5628 p
[i
] = number_chars
[d
];
5633 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5635 "Return a string holding the external representation of the\n"
5636 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5637 "inexact, a radix of 10 will be used.")
5638 #define FUNC_NAME s_scm_number_to_string
5642 if (SCM_UNBNDP (radix
))
5645 base
= scm_to_signed_integer (radix
, 2, 36);
5647 if (SCM_I_INUMP (n
))
5649 char num_buf
[SCM_INTBUFLEN
];
5650 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5651 return scm_from_locale_stringn (num_buf
, length
);
5653 else if (SCM_BIGP (n
))
5655 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5656 size_t len
= strlen (str
);
5657 void (*freefunc
) (void *, size_t);
5659 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5660 scm_remember_upto_here_1 (n
);
5661 ret
= scm_from_latin1_stringn (str
, len
);
5662 freefunc (str
, len
+ 1);
5665 else if (SCM_FRACTIONP (n
))
5667 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5668 scm_from_locale_string ("/"),
5669 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5671 else if (SCM_INEXACTP (n
))
5673 char num_buf
[FLOBUFLEN
];
5674 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5677 SCM_WRONG_TYPE_ARG (1, n
);
5682 /* These print routines used to be stubbed here so that scm_repl.c
5683 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5686 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5688 char num_buf
[FLOBUFLEN
];
5689 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5694 scm_i_print_double (double val
, SCM port
)
5696 char num_buf
[FLOBUFLEN
];
5697 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5701 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5704 char num_buf
[FLOBUFLEN
];
5705 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5710 scm_i_print_complex (double real
, double imag
, SCM port
)
5712 char num_buf
[FLOBUFLEN
];
5713 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5717 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5720 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5721 scm_display (str
, port
);
5722 scm_remember_upto_here_1 (str
);
5727 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5729 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5730 size_t len
= strlen (str
);
5731 void (*freefunc
) (void *, size_t);
5732 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5733 scm_remember_upto_here_1 (exp
);
5734 scm_lfwrite_unlocked (str
, len
, port
);
5735 freefunc (str
, len
+ 1);
5738 /*** END nums->strs ***/
5741 /*** STRINGS -> NUMBERS ***/
5743 /* The following functions implement the conversion from strings to numbers.
5744 * The implementation somehow follows the grammar for numbers as it is given
5745 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5746 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5747 * points should be noted about the implementation:
5749 * * Each function keeps a local index variable 'idx' that points at the
5750 * current position within the parsed string. The global index is only
5751 * updated if the function could parse the corresponding syntactic unit
5754 * * Similarly, the functions keep track of indicators of inexactness ('#',
5755 * '.' or exponents) using local variables ('hash_seen', 'x').
5757 * * Sequences of digits are parsed into temporary variables holding fixnums.
5758 * Only if these fixnums would overflow, the result variables are updated
5759 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5760 * the temporary variables holding the fixnums are cleared, and the process
5761 * starts over again. If for example fixnums were able to store five decimal
5762 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5763 * and the result was computed as 12345 * 100000 + 67890. In other words,
5764 * only every five digits two bignum operations were performed.
5766 * Notes on the handling of exactness specifiers:
5768 * When parsing non-real complex numbers, we apply exactness specifiers on
5769 * per-component basis, as is done in PLT Scheme. For complex numbers
5770 * written in rectangular form, exactness specifiers are applied to the
5771 * real and imaginary parts before calling scm_make_rectangular. For
5772 * complex numbers written in polar form, exactness specifiers are applied
5773 * to the magnitude and angle before calling scm_make_polar.
5775 * There are two kinds of exactness specifiers: forced and implicit. A
5776 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5777 * the entire number, and applies to both components of a complex number.
5778 * "#e" causes each component to be made exact, and "#i" causes each
5779 * component to be made inexact. If no forced exactness specifier is
5780 * present, then the exactness of each component is determined
5781 * independently by the presence or absence of a decimal point or hash mark
5782 * within that component. If a decimal point or hash mark is present, the
5783 * component is made inexact, otherwise it is made exact.
5785 * After the exactness specifiers have been applied to each component, they
5786 * are passed to either scm_make_rectangular or scm_make_polar to produce
5787 * the final result. Note that this will result in a real number if the
5788 * imaginary part, magnitude, or angle is an exact 0.
5790 * For example, (string->number "#i5.0+0i") does the equivalent of:
5792 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5795 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5797 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5799 /* Caller is responsible for checking that the return value is in range
5800 for the given radix, which should be <= 36. */
5802 char_decimal_value (scm_t_uint32 c
)
5804 if (c
>= (scm_t_uint32
) '0' && c
<= (scm_t_uint32
) '9')
5805 return c
- (scm_t_uint32
) '0';
5808 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5809 that's certainly above any valid decimal, so we take advantage of
5810 that to elide some tests. */
5811 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5813 /* If that failed, try extended hexadecimals, then. Only accept ascii
5818 if (c
>= (scm_t_uint32
) 'a')
5819 d
= c
- (scm_t_uint32
)'a' + 10U;
5825 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5826 in base RADIX. Upon success, return the unsigned integer and update
5827 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5829 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5830 unsigned int radix
, enum t_exactness
*p_exactness
)
5832 unsigned int idx
= *p_idx
;
5833 unsigned int hash_seen
= 0;
5834 scm_t_bits shift
= 1;
5836 unsigned int digit_value
;
5839 size_t len
= scm_i_string_length (mem
);
5844 c
= scm_i_string_ref (mem
, idx
);
5845 digit_value
= char_decimal_value (c
);
5846 if (digit_value
>= radix
)
5850 result
= SCM_I_MAKINUM (digit_value
);
5853 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5863 digit_value
= char_decimal_value (c
);
5864 /* This check catches non-decimals in addition to out-of-range
5866 if (digit_value
>= radix
)
5871 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5873 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5875 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5882 shift
= shift
* radix
;
5883 add
= add
* radix
+ digit_value
;
5888 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5890 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5894 *p_exactness
= INEXACT
;
5900 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5901 * covers the parts of the rules that start at a potential point. The value
5902 * of the digits up to the point have been parsed by the caller and are given
5903 * in variable result. The content of *p_exactness indicates, whether a hash
5904 * has already been seen in the digits before the point.
5907 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5910 mem2decimal_from_point (SCM result
, SCM mem
,
5911 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5913 unsigned int idx
= *p_idx
;
5914 enum t_exactness x
= *p_exactness
;
5915 size_t len
= scm_i_string_length (mem
);
5920 if (scm_i_string_ref (mem
, idx
) == '.')
5922 scm_t_bits shift
= 1;
5924 unsigned int digit_value
;
5925 SCM big_shift
= SCM_INUM1
;
5930 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5931 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5936 digit_value
= DIGIT2UINT (c
);
5947 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5949 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5950 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5952 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5960 add
= add
* 10 + digit_value
;
5966 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5967 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5968 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5971 result
= scm_divide (result
, big_shift
);
5973 /* We've seen a decimal point, thus the value is implicitly inexact. */
5985 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5987 switch (scm_i_string_ref (mem
, idx
))
5999 c
= scm_i_string_ref (mem
, idx
);
6007 c
= scm_i_string_ref (mem
, idx
);
6016 c
= scm_i_string_ref (mem
, idx
);
6021 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6025 exponent
= DIGIT2UINT (c
);
6028 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6029 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6032 if (exponent
<= SCM_MAXEXP
)
6033 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6039 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6041 size_t exp_len
= idx
- start
;
6042 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6043 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6044 scm_out_of_range ("string->number", exp_num
);
6047 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6049 result
= scm_product (result
, e
);
6051 result
= scm_divide (result
, e
);
6053 /* We've seen an exponent, thus the value is implicitly inexact. */
6071 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6074 mem2ureal (SCM mem
, unsigned int *p_idx
,
6075 unsigned int radix
, enum t_exactness forced_x
,
6076 int allow_inf_or_nan
)
6078 unsigned int idx
= *p_idx
;
6080 size_t len
= scm_i_string_length (mem
);
6082 /* Start off believing that the number will be exact. This changes
6083 to INEXACT if we see a decimal point or a hash. */
6084 enum t_exactness implicit_x
= EXACT
;
6089 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6090 switch (scm_i_string_ref (mem
, idx
))
6093 switch (scm_i_string_ref (mem
, idx
+ 1))
6096 switch (scm_i_string_ref (mem
, idx
+ 2))
6099 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6100 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6108 switch (scm_i_string_ref (mem
, idx
+ 1))
6111 switch (scm_i_string_ref (mem
, idx
+ 2))
6114 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6116 /* Cobble up the fractional part. We might want to
6117 set the NaN's mantissa from it. */
6119 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6122 #if SCM_ENABLE_DEPRECATED == 1
6123 scm_c_issue_deprecation_warning
6124 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6137 if (scm_i_string_ref (mem
, idx
) == '.')
6141 else if (idx
+ 1 == len
)
6143 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6146 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6147 p_idx
, &implicit_x
);
6153 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6154 if (scm_is_false (uinteger
))
6159 else if (scm_i_string_ref (mem
, idx
) == '/')
6167 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6168 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6171 /* both are int/big here, I assume */
6172 result
= scm_i_make_ratio (uinteger
, divisor
);
6174 else if (radix
== 10)
6176 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6177 if (scm_is_false (result
))
6189 if (SCM_INEXACTP (result
))
6190 return scm_inexact_to_exact (result
);
6194 if (SCM_INEXACTP (result
))
6197 return scm_exact_to_inexact (result
);
6199 if (implicit_x
== INEXACT
)
6201 if (SCM_INEXACTP (result
))
6204 return scm_exact_to_inexact (result
);
6210 /* We should never get here */
6215 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6218 mem2complex (SCM mem
, unsigned int idx
,
6219 unsigned int radix
, enum t_exactness forced_x
)
6224 size_t len
= scm_i_string_length (mem
);
6229 c
= scm_i_string_ref (mem
, idx
);
6244 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6245 if (scm_is_false (ureal
))
6247 /* input must be either +i or -i */
6252 if (scm_i_string_ref (mem
, idx
) == 'i'
6253 || scm_i_string_ref (mem
, idx
) == 'I')
6259 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6266 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6267 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6272 c
= scm_i_string_ref (mem
, idx
);
6276 /* either +<ureal>i or -<ureal>i */
6283 return scm_make_rectangular (SCM_INUM0
, ureal
);
6286 /* polar input: <real>@<real>. */
6297 c
= scm_i_string_ref (mem
, idx
);
6315 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6316 if (scm_is_false (angle
))
6321 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6322 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6324 result
= scm_make_polar (ureal
, angle
);
6329 /* expecting input matching <real>[+-]<ureal>?i */
6336 int sign
= (c
== '+') ? 1 : -1;
6337 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6339 if (scm_is_false (imag
))
6340 imag
= SCM_I_MAKINUM (sign
);
6341 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6342 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6346 if (scm_i_string_ref (mem
, idx
) != 'i'
6347 && scm_i_string_ref (mem
, idx
) != 'I')
6354 return scm_make_rectangular (ureal
, imag
);
6363 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6365 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6368 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6370 unsigned int idx
= 0;
6371 unsigned int radix
= NO_RADIX
;
6372 enum t_exactness forced_x
= NO_EXACTNESS
;
6373 size_t len
= scm_i_string_length (mem
);
6375 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6376 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6378 switch (scm_i_string_ref (mem
, idx
+ 1))
6381 if (radix
!= NO_RADIX
)
6386 if (radix
!= NO_RADIX
)
6391 if (forced_x
!= NO_EXACTNESS
)
6396 if (forced_x
!= NO_EXACTNESS
)
6401 if (radix
!= NO_RADIX
)
6406 if (radix
!= NO_RADIX
)
6416 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6417 if (radix
== NO_RADIX
)
6418 radix
= default_radix
;
6420 return mem2complex (mem
, idx
, radix
, forced_x
);
6424 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6425 unsigned int default_radix
)
6427 SCM str
= scm_from_locale_stringn (mem
, len
);
6429 return scm_i_string_to_number (str
, default_radix
);
6433 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6434 (SCM string
, SCM radix
),
6435 "Return a number of the maximally precise representation\n"
6436 "expressed by the given @var{string}. @var{radix} must be an\n"
6437 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6438 "is a default radix that may be overridden by an explicit radix\n"
6439 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6440 "supplied, then the default radix is 10. If string is not a\n"
6441 "syntactically valid notation for a number, then\n"
6442 "@code{string->number} returns @code{#f}.")
6443 #define FUNC_NAME s_scm_string_to_number
6447 SCM_VALIDATE_STRING (1, string
);
6449 if (SCM_UNBNDP (radix
))
6452 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6454 answer
= scm_i_string_to_number (string
, base
);
6455 scm_remember_upto_here_1 (string
);
6461 /*** END strs->nums ***/
6464 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6466 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6468 #define FUNC_NAME s_scm_number_p
6470 return scm_from_bool (SCM_NUMBERP (x
));
6474 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6476 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6477 "otherwise. Note that the sets of real, rational and integer\n"
6478 "values form subsets of the set of complex numbers, i. e. the\n"
6479 "predicate will also be fulfilled if @var{x} is a real,\n"
6480 "rational or integer number.")
6481 #define FUNC_NAME s_scm_complex_p
6483 /* all numbers are complex. */
6484 return scm_number_p (x
);
6488 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6490 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6491 "otherwise. Note that the set of integer values forms a subset of\n"
6492 "the set of real numbers, i. e. the predicate will also be\n"
6493 "fulfilled if @var{x} is an integer number.")
6494 #define FUNC_NAME s_scm_real_p
6496 return scm_from_bool
6497 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6501 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6503 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6504 "otherwise. Note that the set of integer values forms a subset of\n"
6505 "the set of rational numbers, i. e. the predicate will also be\n"
6506 "fulfilled if @var{x} is an integer number.")
6507 #define FUNC_NAME s_scm_rational_p
6509 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6511 else if (SCM_REALP (x
))
6512 /* due to their limited precision, finite floating point numbers are
6513 rational as well. (finite means neither infinity nor a NaN) */
6514 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6520 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6522 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6524 #define FUNC_NAME s_scm_integer_p
6526 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6528 else if (SCM_REALP (x
))
6530 double val
= SCM_REAL_VALUE (x
);
6531 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6539 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6540 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6541 (SCM x
, SCM y
, SCM rest
),
6542 "Return @code{#t} if all parameters are numerically equal.")
6543 #define FUNC_NAME s_scm_i_num_eq_p
6545 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6547 while (!scm_is_null (rest
))
6549 if (scm_is_false (scm_num_eq_p (x
, y
)))
6553 rest
= scm_cdr (rest
);
6555 return scm_num_eq_p (x
, y
);
6559 scm_num_eq_p (SCM x
, SCM y
)
6562 if (SCM_I_INUMP (x
))
6564 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6565 if (SCM_I_INUMP (y
))
6567 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6568 return scm_from_bool (xx
== yy
);
6570 else if (SCM_BIGP (y
))
6572 else if (SCM_REALP (y
))
6574 /* On a 32-bit system an inum fits a double, we can cast the inum
6575 to a double and compare.
6577 But on a 64-bit system an inum is bigger than a double and
6578 casting it to a double (call that dxx) will round.
6579 Although dxx will not in general be equal to xx, dxx will
6580 always be an integer and within a factor of 2 of xx, so if
6581 dxx==yy, we know that yy is an integer and fits in
6582 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6583 compare with plain xx.
6585 An alternative (for any size system actually) would be to check
6586 yy is an integer (with floor) and is in range of an inum
6587 (compare against appropriate powers of 2) then test
6588 xx==(scm_t_signed_bits)yy. It's just a matter of which
6589 casts/comparisons might be fastest or easiest for the cpu. */
6591 double yy
= SCM_REAL_VALUE (y
);
6592 return scm_from_bool ((double) xx
== yy
6593 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6594 || xx
== (scm_t_signed_bits
) yy
));
6596 else if (SCM_COMPLEXP (y
))
6598 /* see comments with inum/real above */
6599 double ry
= SCM_COMPLEX_REAL (y
);
6600 return scm_from_bool ((double) xx
== ry
6601 && 0.0 == SCM_COMPLEX_IMAG (y
)
6602 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6603 || xx
== (scm_t_signed_bits
) ry
));
6605 else if (SCM_FRACTIONP (y
))
6608 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6611 else if (SCM_BIGP (x
))
6613 if (SCM_I_INUMP (y
))
6615 else if (SCM_BIGP (y
))
6617 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6618 scm_remember_upto_here_2 (x
, y
);
6619 return scm_from_bool (0 == cmp
);
6621 else if (SCM_REALP (y
))
6624 if (isnan (SCM_REAL_VALUE (y
)))
6626 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6627 scm_remember_upto_here_1 (x
);
6628 return scm_from_bool (0 == cmp
);
6630 else if (SCM_COMPLEXP (y
))
6633 if (0.0 != SCM_COMPLEX_IMAG (y
))
6635 if (isnan (SCM_COMPLEX_REAL (y
)))
6637 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6638 scm_remember_upto_here_1 (x
);
6639 return scm_from_bool (0 == cmp
);
6641 else if (SCM_FRACTIONP (y
))
6644 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6647 else if (SCM_REALP (x
))
6649 double xx
= SCM_REAL_VALUE (x
);
6650 if (SCM_I_INUMP (y
))
6652 /* see comments with inum/real above */
6653 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6654 return scm_from_bool (xx
== (double) yy
6655 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6656 || (scm_t_signed_bits
) xx
== yy
));
6658 else if (SCM_BIGP (y
))
6663 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6664 scm_remember_upto_here_1 (y
);
6665 return scm_from_bool (0 == cmp
);
6667 else if (SCM_REALP (y
))
6668 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6669 else if (SCM_COMPLEXP (y
))
6670 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6671 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6672 else if (SCM_FRACTIONP (y
))
6674 if (isnan (xx
) || isinf (xx
))
6676 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6680 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6683 else if (SCM_COMPLEXP (x
))
6685 if (SCM_I_INUMP (y
))
6687 /* see comments with inum/real above */
6688 double rx
= SCM_COMPLEX_REAL (x
);
6689 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6690 return scm_from_bool (rx
== (double) yy
6691 && 0.0 == SCM_COMPLEX_IMAG (x
)
6692 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6693 || (scm_t_signed_bits
) rx
== yy
));
6695 else if (SCM_BIGP (y
))
6698 if (0.0 != SCM_COMPLEX_IMAG (x
))
6700 if (isnan (SCM_COMPLEX_REAL (x
)))
6702 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6703 scm_remember_upto_here_1 (y
);
6704 return scm_from_bool (0 == cmp
);
6706 else if (SCM_REALP (y
))
6707 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6708 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6709 else if (SCM_COMPLEXP (y
))
6710 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6711 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6712 else if (SCM_FRACTIONP (y
))
6715 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6717 xx
= SCM_COMPLEX_REAL (x
);
6718 if (isnan (xx
) || isinf (xx
))
6720 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6724 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6727 else if (SCM_FRACTIONP (x
))
6729 if (SCM_I_INUMP (y
))
6731 else if (SCM_BIGP (y
))
6733 else if (SCM_REALP (y
))
6735 double yy
= SCM_REAL_VALUE (y
);
6736 if (isnan (yy
) || isinf (yy
))
6738 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6741 else if (SCM_COMPLEXP (y
))
6744 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6746 yy
= SCM_COMPLEX_REAL (y
);
6747 if (isnan (yy
) || isinf(yy
))
6749 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6752 else if (SCM_FRACTIONP (y
))
6753 return scm_i_fraction_equalp (x
, y
);
6755 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6759 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6764 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6765 done are good for inums, but for bignums an answer can almost always be
6766 had by just examining a few high bits of the operands, as done by GMP in
6767 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6768 of the float exponent to take into account. */
6770 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6771 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6772 (SCM x
, SCM y
, SCM rest
),
6773 "Return @code{#t} if the list of parameters is monotonically\n"
6775 #define FUNC_NAME s_scm_i_num_less_p
6777 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6779 while (!scm_is_null (rest
))
6781 if (scm_is_false (scm_less_p (x
, y
)))
6785 rest
= scm_cdr (rest
);
6787 return scm_less_p (x
, y
);
6791 scm_less_p (SCM x
, SCM y
)
6794 if (SCM_I_INUMP (x
))
6796 scm_t_inum xx
= SCM_I_INUM (x
);
6797 if (SCM_I_INUMP (y
))
6799 scm_t_inum yy
= SCM_I_INUM (y
);
6800 return scm_from_bool (xx
< yy
);
6802 else if (SCM_BIGP (y
))
6804 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6805 scm_remember_upto_here_1 (y
);
6806 return scm_from_bool (sgn
> 0);
6808 else if (SCM_REALP (y
))
6810 /* We can safely take the ceiling of y without changing the
6811 result of x<y, given that x is an integer. */
6812 double yy
= ceil (SCM_REAL_VALUE (y
));
6814 /* In the following comparisons, it's important that the right
6815 hand side always be a power of 2, so that it can be
6816 losslessly converted to a double even on 64-bit
6818 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6820 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6821 /* The condition above is carefully written to include the
6822 case where yy==NaN. */
6825 /* yy is a finite integer that fits in an inum. */
6826 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6828 else if (SCM_FRACTIONP (y
))
6830 /* "x < a/b" becomes "x*b < a" */
6832 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6833 y
= SCM_FRACTION_NUMERATOR (y
);
6837 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6838 s_scm_i_num_less_p
);
6840 else if (SCM_BIGP (x
))
6842 if (SCM_I_INUMP (y
))
6844 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6845 scm_remember_upto_here_1 (x
);
6846 return scm_from_bool (sgn
< 0);
6848 else if (SCM_BIGP (y
))
6850 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6851 scm_remember_upto_here_2 (x
, y
);
6852 return scm_from_bool (cmp
< 0);
6854 else if (SCM_REALP (y
))
6857 if (isnan (SCM_REAL_VALUE (y
)))
6859 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6860 scm_remember_upto_here_1 (x
);
6861 return scm_from_bool (cmp
< 0);
6863 else if (SCM_FRACTIONP (y
))
6866 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6867 s_scm_i_num_less_p
);
6869 else if (SCM_REALP (x
))
6871 if (SCM_I_INUMP (y
))
6873 /* We can safely take the floor of x without changing the
6874 result of x<y, given that y is an integer. */
6875 double xx
= floor (SCM_REAL_VALUE (x
));
6877 /* In the following comparisons, it's important that the right
6878 hand side always be a power of 2, so that it can be
6879 losslessly converted to a double even on 64-bit
6881 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6883 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6884 /* The condition above is carefully written to include the
6885 case where xx==NaN. */
6888 /* xx is a finite integer that fits in an inum. */
6889 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6891 else if (SCM_BIGP (y
))
6894 if (isnan (SCM_REAL_VALUE (x
)))
6896 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6897 scm_remember_upto_here_1 (y
);
6898 return scm_from_bool (cmp
> 0);
6900 else if (SCM_REALP (y
))
6901 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6902 else if (SCM_FRACTIONP (y
))
6904 double xx
= SCM_REAL_VALUE (x
);
6908 return scm_from_bool (xx
< 0.0);
6909 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6913 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6914 s_scm_i_num_less_p
);
6916 else if (SCM_FRACTIONP (x
))
6918 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6920 /* "a/b < y" becomes "a < y*b" */
6921 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6922 x
= SCM_FRACTION_NUMERATOR (x
);
6925 else if (SCM_REALP (y
))
6927 double yy
= SCM_REAL_VALUE (y
);
6931 return scm_from_bool (0.0 < yy
);
6932 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6935 else if (SCM_FRACTIONP (y
))
6937 /* "a/b < c/d" becomes "a*d < c*b" */
6938 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6939 SCM_FRACTION_DENOMINATOR (y
));
6940 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6941 SCM_FRACTION_DENOMINATOR (x
));
6947 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6948 s_scm_i_num_less_p
);
6951 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6952 s_scm_i_num_less_p
);
6956 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6957 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6958 (SCM x
, SCM y
, SCM rest
),
6959 "Return @code{#t} if the list of parameters is monotonically\n"
6961 #define FUNC_NAME s_scm_i_num_gr_p
6963 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6965 while (!scm_is_null (rest
))
6967 if (scm_is_false (scm_gr_p (x
, y
)))
6971 rest
= scm_cdr (rest
);
6973 return scm_gr_p (x
, y
);
6976 #define FUNC_NAME s_scm_i_num_gr_p
6978 scm_gr_p (SCM x
, SCM y
)
6980 if (!SCM_NUMBERP (x
))
6981 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6982 else if (!SCM_NUMBERP (y
))
6983 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6985 return scm_less_p (y
, x
);
6990 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6991 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6992 (SCM x
, SCM y
, SCM rest
),
6993 "Return @code{#t} if the list of parameters is monotonically\n"
6995 #define FUNC_NAME s_scm_i_num_leq_p
6997 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6999 while (!scm_is_null (rest
))
7001 if (scm_is_false (scm_leq_p (x
, y
)))
7005 rest
= scm_cdr (rest
);
7007 return scm_leq_p (x
, y
);
7010 #define FUNC_NAME s_scm_i_num_leq_p
7012 scm_leq_p (SCM x
, SCM y
)
7014 if (!SCM_NUMBERP (x
))
7015 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7016 else if (!SCM_NUMBERP (y
))
7017 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7018 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7021 return scm_not (scm_less_p (y
, x
));
7026 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7027 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7028 (SCM x
, SCM y
, SCM rest
),
7029 "Return @code{#t} if the list of parameters is monotonically\n"
7031 #define FUNC_NAME s_scm_i_num_geq_p
7033 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7035 while (!scm_is_null (rest
))
7037 if (scm_is_false (scm_geq_p (x
, y
)))
7041 rest
= scm_cdr (rest
);
7043 return scm_geq_p (x
, y
);
7046 #define FUNC_NAME s_scm_i_num_geq_p
7048 scm_geq_p (SCM x
, SCM y
)
7050 if (!SCM_NUMBERP (x
))
7051 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7052 else if (!SCM_NUMBERP (y
))
7053 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7054 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7057 return scm_not (scm_less_p (x
, y
));
7062 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7064 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7066 #define FUNC_NAME s_scm_zero_p
7068 if (SCM_I_INUMP (z
))
7069 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7070 else if (SCM_BIGP (z
))
7072 else if (SCM_REALP (z
))
7073 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7074 else if (SCM_COMPLEXP (z
))
7075 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7076 && SCM_COMPLEX_IMAG (z
) == 0.0);
7077 else if (SCM_FRACTIONP (z
))
7080 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7085 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7087 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7089 #define FUNC_NAME s_scm_positive_p
7091 if (SCM_I_INUMP (x
))
7092 return scm_from_bool (SCM_I_INUM (x
) > 0);
7093 else if (SCM_BIGP (x
))
7095 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7096 scm_remember_upto_here_1 (x
);
7097 return scm_from_bool (sgn
> 0);
7099 else if (SCM_REALP (x
))
7100 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7101 else if (SCM_FRACTIONP (x
))
7102 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7104 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7109 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7111 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7113 #define FUNC_NAME s_scm_negative_p
7115 if (SCM_I_INUMP (x
))
7116 return scm_from_bool (SCM_I_INUM (x
) < 0);
7117 else if (SCM_BIGP (x
))
7119 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7120 scm_remember_upto_here_1 (x
);
7121 return scm_from_bool (sgn
< 0);
7123 else if (SCM_REALP (x
))
7124 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7125 else if (SCM_FRACTIONP (x
))
7126 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7128 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7133 /* scm_min and scm_max return an inexact when either argument is inexact, as
7134 required by r5rs. On that basis, for exact/inexact combinations the
7135 exact is converted to inexact to compare and possibly return. This is
7136 unlike scm_less_p above which takes some trouble to preserve all bits in
7137 its test, such trouble is not required for min and max. */
7139 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7140 (SCM x
, SCM y
, SCM rest
),
7141 "Return the maximum of all parameter values.")
7142 #define FUNC_NAME s_scm_i_max
7144 while (!scm_is_null (rest
))
7145 { x
= scm_max (x
, y
);
7147 rest
= scm_cdr (rest
);
7149 return scm_max (x
, y
);
7153 #define s_max s_scm_i_max
7154 #define g_max g_scm_i_max
7157 scm_max (SCM x
, SCM y
)
7162 return scm_wta_dispatch_0 (g_max
, s_max
);
7163 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7166 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7169 if (SCM_I_INUMP (x
))
7171 scm_t_inum xx
= SCM_I_INUM (x
);
7172 if (SCM_I_INUMP (y
))
7174 scm_t_inum yy
= SCM_I_INUM (y
);
7175 return (xx
< yy
) ? y
: x
;
7177 else if (SCM_BIGP (y
))
7179 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7180 scm_remember_upto_here_1 (y
);
7181 return (sgn
< 0) ? x
: y
;
7183 else if (SCM_REALP (y
))
7186 double yyd
= SCM_REAL_VALUE (y
);
7189 return scm_i_from_double (xxd
);
7190 /* If y is a NaN, then "==" is false and we return the NaN */
7191 else if (SCM_LIKELY (!(xxd
== yyd
)))
7193 /* Handle signed zeroes properly */
7199 else if (SCM_FRACTIONP (y
))
7202 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7205 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7207 else if (SCM_BIGP (x
))
7209 if (SCM_I_INUMP (y
))
7211 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7212 scm_remember_upto_here_1 (x
);
7213 return (sgn
< 0) ? y
: x
;
7215 else if (SCM_BIGP (y
))
7217 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7218 scm_remember_upto_here_2 (x
, y
);
7219 return (cmp
> 0) ? x
: y
;
7221 else if (SCM_REALP (y
))
7223 /* if y==NaN then xx>yy is false, so we return the NaN y */
7226 xx
= scm_i_big2dbl (x
);
7227 yy
= SCM_REAL_VALUE (y
);
7228 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7230 else if (SCM_FRACTIONP (y
))
7235 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7237 else if (SCM_REALP (x
))
7239 if (SCM_I_INUMP (y
))
7241 scm_t_inum yy
= SCM_I_INUM (y
);
7242 double xxd
= SCM_REAL_VALUE (x
);
7246 return scm_i_from_double (yyd
);
7247 /* If x is a NaN, then "==" is false and we return the NaN */
7248 else if (SCM_LIKELY (!(xxd
== yyd
)))
7250 /* Handle signed zeroes properly */
7256 else if (SCM_BIGP (y
))
7261 else if (SCM_REALP (y
))
7263 double xx
= SCM_REAL_VALUE (x
);
7264 double yy
= SCM_REAL_VALUE (y
);
7266 /* For purposes of max: nan > +inf.0 > everything else,
7267 per the R6RS errata */
7270 else if (SCM_LIKELY (xx
< yy
))
7272 /* If neither (xx > yy) nor (xx < yy), then
7273 either they're equal or one is a NaN */
7274 else if (SCM_UNLIKELY (xx
!= yy
))
7275 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7276 /* xx == yy, but handle signed zeroes properly */
7277 else if (copysign (1.0, yy
) < 0.0)
7282 else if (SCM_FRACTIONP (y
))
7284 double yy
= scm_i_fraction2double (y
);
7285 double xx
= SCM_REAL_VALUE (x
);
7286 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7289 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7291 else if (SCM_FRACTIONP (x
))
7293 if (SCM_I_INUMP (y
))
7297 else if (SCM_BIGP (y
))
7301 else if (SCM_REALP (y
))
7303 double xx
= scm_i_fraction2double (x
);
7304 /* if y==NaN then ">" is false, so we return the NaN y */
7305 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7307 else if (SCM_FRACTIONP (y
))
7312 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7315 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7319 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7320 (SCM x
, SCM y
, SCM rest
),
7321 "Return the minimum of all parameter values.")
7322 #define FUNC_NAME s_scm_i_min
7324 while (!scm_is_null (rest
))
7325 { x
= scm_min (x
, y
);
7327 rest
= scm_cdr (rest
);
7329 return scm_min (x
, y
);
7333 #define s_min s_scm_i_min
7334 #define g_min g_scm_i_min
7337 scm_min (SCM x
, SCM y
)
7342 return scm_wta_dispatch_0 (g_min
, s_min
);
7343 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7346 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7349 if (SCM_I_INUMP (x
))
7351 scm_t_inum xx
= SCM_I_INUM (x
);
7352 if (SCM_I_INUMP (y
))
7354 scm_t_inum yy
= SCM_I_INUM (y
);
7355 return (xx
< yy
) ? x
: y
;
7357 else if (SCM_BIGP (y
))
7359 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7360 scm_remember_upto_here_1 (y
);
7361 return (sgn
< 0) ? y
: x
;
7363 else if (SCM_REALP (y
))
7366 /* if y==NaN then "<" is false and we return NaN */
7367 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7369 else if (SCM_FRACTIONP (y
))
7372 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7375 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7377 else if (SCM_BIGP (x
))
7379 if (SCM_I_INUMP (y
))
7381 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7382 scm_remember_upto_here_1 (x
);
7383 return (sgn
< 0) ? x
: y
;
7385 else if (SCM_BIGP (y
))
7387 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7388 scm_remember_upto_here_2 (x
, y
);
7389 return (cmp
> 0) ? y
: x
;
7391 else if (SCM_REALP (y
))
7393 /* if y==NaN then xx<yy is false, so we return the NaN y */
7396 xx
= scm_i_big2dbl (x
);
7397 yy
= SCM_REAL_VALUE (y
);
7398 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7400 else if (SCM_FRACTIONP (y
))
7405 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7407 else if (SCM_REALP (x
))
7409 if (SCM_I_INUMP (y
))
7411 double z
= SCM_I_INUM (y
);
7412 /* if x==NaN then "<" is false and we return NaN */
7413 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7415 else if (SCM_BIGP (y
))
7420 else if (SCM_REALP (y
))
7422 double xx
= SCM_REAL_VALUE (x
);
7423 double yy
= SCM_REAL_VALUE (y
);
7425 /* For purposes of min: nan < -inf.0 < everything else,
7426 per the R6RS errata */
7429 else if (SCM_LIKELY (xx
> yy
))
7431 /* If neither (xx < yy) nor (xx > yy), then
7432 either they're equal or one is a NaN */
7433 else if (SCM_UNLIKELY (xx
!= yy
))
7434 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7435 /* xx == yy, but handle signed zeroes properly */
7436 else if (copysign (1.0, xx
) < 0.0)
7441 else if (SCM_FRACTIONP (y
))
7443 double yy
= scm_i_fraction2double (y
);
7444 double xx
= SCM_REAL_VALUE (x
);
7445 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7448 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7450 else if (SCM_FRACTIONP (x
))
7452 if (SCM_I_INUMP (y
))
7456 else if (SCM_BIGP (y
))
7460 else if (SCM_REALP (y
))
7462 double xx
= scm_i_fraction2double (x
);
7463 /* if y==NaN then "<" is false, so we return the NaN y */
7464 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7466 else if (SCM_FRACTIONP (y
))
7471 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7474 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7478 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7479 (SCM x
, SCM y
, SCM rest
),
7480 "Return the sum of all parameter values. Return 0 if called without\n"
7482 #define FUNC_NAME s_scm_i_sum
7484 while (!scm_is_null (rest
))
7485 { x
= scm_sum (x
, y
);
7487 rest
= scm_cdr (rest
);
7489 return scm_sum (x
, y
);
7493 #define s_sum s_scm_i_sum
7494 #define g_sum g_scm_i_sum
7497 scm_sum (SCM x
, SCM y
)
7499 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7501 if (SCM_NUMBERP (x
)) return x
;
7502 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7503 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7506 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7508 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7510 scm_t_inum xx
= SCM_I_INUM (x
);
7511 scm_t_inum yy
= SCM_I_INUM (y
);
7512 scm_t_inum z
= xx
+ yy
;
7513 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7515 else if (SCM_BIGP (y
))
7520 else if (SCM_REALP (y
))
7522 scm_t_inum xx
= SCM_I_INUM (x
);
7523 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7525 else if (SCM_COMPLEXP (y
))
7527 scm_t_inum xx
= SCM_I_INUM (x
);
7528 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7529 SCM_COMPLEX_IMAG (y
));
7531 else if (SCM_FRACTIONP (y
))
7532 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7533 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7534 SCM_FRACTION_DENOMINATOR (y
));
7536 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7537 } else if (SCM_BIGP (x
))
7539 if (SCM_I_INUMP (y
))
7544 inum
= SCM_I_INUM (y
);
7547 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7550 SCM result
= scm_i_mkbig ();
7551 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7552 scm_remember_upto_here_1 (x
);
7553 /* we know the result will have to be a bignum */
7556 return scm_i_normbig (result
);
7560 SCM result
= scm_i_mkbig ();
7561 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7562 scm_remember_upto_here_1 (x
);
7563 /* we know the result will have to be a bignum */
7566 return scm_i_normbig (result
);
7569 else if (SCM_BIGP (y
))
7571 SCM result
= scm_i_mkbig ();
7572 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7573 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7574 mpz_add (SCM_I_BIG_MPZ (result
),
7577 scm_remember_upto_here_2 (x
, y
);
7578 /* we know the result will have to be a bignum */
7581 return scm_i_normbig (result
);
7583 else if (SCM_REALP (y
))
7585 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7586 scm_remember_upto_here_1 (x
);
7587 return scm_i_from_double (result
);
7589 else if (SCM_COMPLEXP (y
))
7591 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7592 + SCM_COMPLEX_REAL (y
));
7593 scm_remember_upto_here_1 (x
);
7594 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7596 else if (SCM_FRACTIONP (y
))
7597 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7598 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7599 SCM_FRACTION_DENOMINATOR (y
));
7601 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7603 else if (SCM_REALP (x
))
7605 if (SCM_I_INUMP (y
))
7606 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7607 else if (SCM_BIGP (y
))
7609 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7610 scm_remember_upto_here_1 (y
);
7611 return scm_i_from_double (result
);
7613 else if (SCM_REALP (y
))
7614 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7615 else if (SCM_COMPLEXP (y
))
7616 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7617 SCM_COMPLEX_IMAG (y
));
7618 else if (SCM_FRACTIONP (y
))
7619 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7621 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7623 else if (SCM_COMPLEXP (x
))
7625 if (SCM_I_INUMP (y
))
7626 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7627 SCM_COMPLEX_IMAG (x
));
7628 else if (SCM_BIGP (y
))
7630 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7631 + SCM_COMPLEX_REAL (x
));
7632 scm_remember_upto_here_1 (y
);
7633 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7635 else if (SCM_REALP (y
))
7636 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7637 SCM_COMPLEX_IMAG (x
));
7638 else if (SCM_COMPLEXP (y
))
7639 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7640 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7641 else if (SCM_FRACTIONP (y
))
7642 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7643 SCM_COMPLEX_IMAG (x
));
7645 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7647 else if (SCM_FRACTIONP (x
))
7649 if (SCM_I_INUMP (y
))
7650 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7651 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7652 SCM_FRACTION_DENOMINATOR (x
));
7653 else if (SCM_BIGP (y
))
7654 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7655 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7656 SCM_FRACTION_DENOMINATOR (x
));
7657 else if (SCM_REALP (y
))
7658 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7659 else if (SCM_COMPLEXP (y
))
7660 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7661 SCM_COMPLEX_IMAG (y
));
7662 else if (SCM_FRACTIONP (y
))
7663 /* a/b + c/d = (ad + bc) / bd */
7664 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7665 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7666 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7668 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7671 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7675 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7677 "Return @math{@var{x}+1}.")
7678 #define FUNC_NAME s_scm_oneplus
7680 return scm_sum (x
, SCM_INUM1
);
7685 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7686 (SCM x
, SCM y
, SCM rest
),
7687 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7688 "the sum of all but the first argument are subtracted from the first\n"
7690 #define FUNC_NAME s_scm_i_difference
7692 while (!scm_is_null (rest
))
7693 { x
= scm_difference (x
, y
);
7695 rest
= scm_cdr (rest
);
7697 return scm_difference (x
, y
);
7701 #define s_difference s_scm_i_difference
7702 #define g_difference g_scm_i_difference
7705 scm_difference (SCM x
, SCM y
)
7706 #define FUNC_NAME s_difference
7708 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7711 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7713 if (SCM_I_INUMP (x
))
7715 scm_t_inum xx
= -SCM_I_INUM (x
);
7716 if (SCM_FIXABLE (xx
))
7717 return SCM_I_MAKINUM (xx
);
7719 return scm_i_inum2big (xx
);
7721 else if (SCM_BIGP (x
))
7722 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7723 bignum, but negating that gives a fixnum. */
7724 return scm_i_normbig (scm_i_clonebig (x
, 0));
7725 else if (SCM_REALP (x
))
7726 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7727 else if (SCM_COMPLEXP (x
))
7728 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7729 -SCM_COMPLEX_IMAG (x
));
7730 else if (SCM_FRACTIONP (x
))
7731 return scm_i_make_ratio_already_reduced
7732 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7733 SCM_FRACTION_DENOMINATOR (x
));
7735 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7738 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7740 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7742 scm_t_inum xx
= SCM_I_INUM (x
);
7743 scm_t_inum yy
= SCM_I_INUM (y
);
7744 scm_t_inum z
= xx
- yy
;
7745 if (SCM_FIXABLE (z
))
7746 return SCM_I_MAKINUM (z
);
7748 return scm_i_inum2big (z
);
7750 else if (SCM_BIGP (y
))
7752 /* inum-x - big-y */
7753 scm_t_inum xx
= SCM_I_INUM (x
);
7757 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7758 bignum, but negating that gives a fixnum. */
7759 return scm_i_normbig (scm_i_clonebig (y
, 0));
7763 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7764 SCM result
= scm_i_mkbig ();
7767 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7770 /* x - y == -(y + -x) */
7771 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7772 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7774 scm_remember_upto_here_1 (y
);
7776 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7777 /* we know the result will have to be a bignum */
7780 return scm_i_normbig (result
);
7783 else if (SCM_REALP (y
))
7785 scm_t_inum xx
= SCM_I_INUM (x
);
7788 * We need to handle x == exact 0
7789 * specially because R6RS states that:
7790 * (- 0.0) ==> -0.0 and
7791 * (- 0.0 0.0) ==> 0.0
7792 * and the scheme compiler changes
7793 * (- 0.0) into (- 0 0.0)
7794 * So we need to treat (- 0 0.0) like (- 0.0).
7795 * At the C level, (-x) is different than (0.0 - x).
7796 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7799 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7801 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7803 else if (SCM_COMPLEXP (y
))
7805 scm_t_inum xx
= SCM_I_INUM (x
);
7807 /* We need to handle x == exact 0 specially.
7808 See the comment above (for SCM_REALP (y)) */
7810 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7811 - SCM_COMPLEX_IMAG (y
));
7813 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7814 - SCM_COMPLEX_IMAG (y
));
7816 else if (SCM_FRACTIONP (y
))
7817 /* a - b/c = (ac - b) / c */
7818 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7819 SCM_FRACTION_NUMERATOR (y
)),
7820 SCM_FRACTION_DENOMINATOR (y
));
7822 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7824 else if (SCM_BIGP (x
))
7826 if (SCM_I_INUMP (y
))
7828 /* big-x - inum-y */
7829 scm_t_inum yy
= SCM_I_INUM (y
);
7830 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7832 scm_remember_upto_here_1 (x
);
7834 return (SCM_FIXABLE (-yy
) ?
7835 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7838 SCM result
= scm_i_mkbig ();
7841 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7843 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7844 scm_remember_upto_here_1 (x
);
7846 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7847 /* we know the result will have to be a bignum */
7850 return scm_i_normbig (result
);
7853 else if (SCM_BIGP (y
))
7855 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7856 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7857 SCM result
= scm_i_mkbig ();
7858 mpz_sub (SCM_I_BIG_MPZ (result
),
7861 scm_remember_upto_here_2 (x
, y
);
7862 /* we know the result will have to be a bignum */
7863 if ((sgn_x
== 1) && (sgn_y
== -1))
7865 if ((sgn_x
== -1) && (sgn_y
== 1))
7867 return scm_i_normbig (result
);
7869 else if (SCM_REALP (y
))
7871 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7872 scm_remember_upto_here_1 (x
);
7873 return scm_i_from_double (result
);
7875 else if (SCM_COMPLEXP (y
))
7877 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7878 - SCM_COMPLEX_REAL (y
));
7879 scm_remember_upto_here_1 (x
);
7880 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7882 else if (SCM_FRACTIONP (y
))
7883 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7884 SCM_FRACTION_NUMERATOR (y
)),
7885 SCM_FRACTION_DENOMINATOR (y
));
7887 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7889 else if (SCM_REALP (x
))
7891 if (SCM_I_INUMP (y
))
7892 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7893 else if (SCM_BIGP (y
))
7895 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7896 scm_remember_upto_here_1 (x
);
7897 return scm_i_from_double (result
);
7899 else if (SCM_REALP (y
))
7900 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7901 else if (SCM_COMPLEXP (y
))
7902 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7903 -SCM_COMPLEX_IMAG (y
));
7904 else if (SCM_FRACTIONP (y
))
7905 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7907 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7909 else if (SCM_COMPLEXP (x
))
7911 if (SCM_I_INUMP (y
))
7912 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7913 SCM_COMPLEX_IMAG (x
));
7914 else if (SCM_BIGP (y
))
7916 double real_part
= (SCM_COMPLEX_REAL (x
)
7917 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7918 scm_remember_upto_here_1 (x
);
7919 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7921 else if (SCM_REALP (y
))
7922 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7923 SCM_COMPLEX_IMAG (x
));
7924 else if (SCM_COMPLEXP (y
))
7925 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7926 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7927 else if (SCM_FRACTIONP (y
))
7928 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7929 SCM_COMPLEX_IMAG (x
));
7931 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7933 else if (SCM_FRACTIONP (x
))
7935 if (SCM_I_INUMP (y
))
7936 /* a/b - c = (a - cb) / b */
7937 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7938 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7939 SCM_FRACTION_DENOMINATOR (x
));
7940 else if (SCM_BIGP (y
))
7941 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7942 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7943 SCM_FRACTION_DENOMINATOR (x
));
7944 else if (SCM_REALP (y
))
7945 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7946 else if (SCM_COMPLEXP (y
))
7947 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7948 -SCM_COMPLEX_IMAG (y
));
7949 else if (SCM_FRACTIONP (y
))
7950 /* a/b - c/d = (ad - bc) / bd */
7951 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7952 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7953 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7955 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7958 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7963 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7965 "Return @math{@var{x}-1}.")
7966 #define FUNC_NAME s_scm_oneminus
7968 return scm_difference (x
, SCM_INUM1
);
7973 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7974 (SCM x
, SCM y
, SCM rest
),
7975 "Return the product of all arguments. If called without arguments,\n"
7977 #define FUNC_NAME s_scm_i_product
7979 while (!scm_is_null (rest
))
7980 { x
= scm_product (x
, y
);
7982 rest
= scm_cdr (rest
);
7984 return scm_product (x
, y
);
7988 #define s_product s_scm_i_product
7989 #define g_product g_scm_i_product
7992 scm_product (SCM x
, SCM y
)
7994 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7997 return SCM_I_MAKINUM (1L);
7998 else if (SCM_NUMBERP (x
))
8001 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
8004 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8009 xx
= SCM_I_INUM (x
);
8014 /* exact1 is the universal multiplicative identity */
8018 /* exact0 times a fixnum is exact0: optimize this case */
8019 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8021 /* if the other argument is inexact, the result is inexact,
8022 and we must do the multiplication in order to handle
8023 infinities and NaNs properly. */
8024 else if (SCM_REALP (y
))
8025 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8026 else if (SCM_COMPLEXP (y
))
8027 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8028 0.0 * SCM_COMPLEX_IMAG (y
));
8029 /* we've already handled inexact numbers,
8030 so y must be exact, and we return exact0 */
8031 else if (SCM_NUMP (y
))
8034 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8038 * This case is important for more than just optimization.
8039 * It handles the case of negating
8040 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8041 * which is a bignum that must be changed back into a fixnum.
8042 * Failure to do so will cause the following to return #f:
8043 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8045 return scm_difference(y
, SCM_UNDEFINED
);
8049 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8051 scm_t_inum yy
= SCM_I_INUM (y
);
8052 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8053 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8054 if (SCM_FIXABLE (kk
))
8055 return SCM_I_MAKINUM (kk
);
8057 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8058 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8059 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8060 return SCM_I_MAKINUM (xx
* yy
);
8064 SCM result
= scm_i_inum2big (xx
);
8065 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8066 return scm_i_normbig (result
);
8069 else if (SCM_BIGP (y
))
8071 SCM result
= scm_i_mkbig ();
8072 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8073 scm_remember_upto_here_1 (y
);
8076 else if (SCM_REALP (y
))
8077 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8078 else if (SCM_COMPLEXP (y
))
8079 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8080 xx
* SCM_COMPLEX_IMAG (y
));
8081 else if (SCM_FRACTIONP (y
))
8082 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8083 SCM_FRACTION_DENOMINATOR (y
));
8085 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8087 else if (SCM_BIGP (x
))
8089 if (SCM_I_INUMP (y
))
8094 else if (SCM_BIGP (y
))
8096 SCM result
= scm_i_mkbig ();
8097 mpz_mul (SCM_I_BIG_MPZ (result
),
8100 scm_remember_upto_here_2 (x
, y
);
8103 else if (SCM_REALP (y
))
8105 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8106 scm_remember_upto_here_1 (x
);
8107 return scm_i_from_double (result
);
8109 else if (SCM_COMPLEXP (y
))
8111 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8112 scm_remember_upto_here_1 (x
);
8113 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8114 z
* SCM_COMPLEX_IMAG (y
));
8116 else if (SCM_FRACTIONP (y
))
8117 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8118 SCM_FRACTION_DENOMINATOR (y
));
8120 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8122 else if (SCM_REALP (x
))
8124 if (SCM_I_INUMP (y
))
8129 else if (SCM_BIGP (y
))
8131 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8132 scm_remember_upto_here_1 (y
);
8133 return scm_i_from_double (result
);
8135 else if (SCM_REALP (y
))
8136 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8137 else if (SCM_COMPLEXP (y
))
8138 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8139 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8140 else if (SCM_FRACTIONP (y
))
8141 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8143 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8145 else if (SCM_COMPLEXP (x
))
8147 if (SCM_I_INUMP (y
))
8152 else if (SCM_BIGP (y
))
8154 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8155 scm_remember_upto_here_1 (y
);
8156 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8157 z
* SCM_COMPLEX_IMAG (x
));
8159 else if (SCM_REALP (y
))
8160 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8161 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8162 else if (SCM_COMPLEXP (y
))
8164 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8165 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8166 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8167 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8169 else if (SCM_FRACTIONP (y
))
8171 double yy
= scm_i_fraction2double (y
);
8172 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8173 yy
* SCM_COMPLEX_IMAG (x
));
8176 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8178 else if (SCM_FRACTIONP (x
))
8180 if (SCM_I_INUMP (y
))
8181 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8182 SCM_FRACTION_DENOMINATOR (x
));
8183 else if (SCM_BIGP (y
))
8184 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8185 SCM_FRACTION_DENOMINATOR (x
));
8186 else if (SCM_REALP (y
))
8187 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8188 else if (SCM_COMPLEXP (y
))
8190 double xx
= scm_i_fraction2double (x
);
8191 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8192 xx
* SCM_COMPLEX_IMAG (y
));
8194 else if (SCM_FRACTIONP (y
))
8195 /* a/b * c/d = ac / bd */
8196 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8197 SCM_FRACTION_NUMERATOR (y
)),
8198 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8199 SCM_FRACTION_DENOMINATOR (y
)));
8201 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8204 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8207 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8208 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8209 #define ALLOW_DIVIDE_BY_ZERO
8210 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8213 /* The code below for complex division is adapted from the GNU
8214 libstdc++, which adapted it from f2c's libF77, and is subject to
8217 /****************************************************************
8218 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8220 Permission to use, copy, modify, and distribute this software
8221 and its documentation for any purpose and without fee is hereby
8222 granted, provided that the above copyright notice appear in all
8223 copies and that both that the copyright notice and this
8224 permission notice and warranty disclaimer appear in supporting
8225 documentation, and that the names of AT&T Bell Laboratories or
8226 Bellcore or any of their entities not be used in advertising or
8227 publicity pertaining to distribution of the software without
8228 specific, written prior permission.
8230 AT&T and Bellcore disclaim all warranties with regard to this
8231 software, including all implied warranties of merchantability
8232 and fitness. In no event shall AT&T or Bellcore be liable for
8233 any special, indirect or consequential damages or any damages
8234 whatsoever resulting from loss of use, data or profits, whether
8235 in an action of contract, negligence or other tortious action,
8236 arising out of or in connection with the use or performance of
8238 ****************************************************************/
8240 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8241 (SCM x
, SCM y
, SCM rest
),
8242 "Divide the first argument by the product of the remaining\n"
8243 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8245 #define FUNC_NAME s_scm_i_divide
8247 while (!scm_is_null (rest
))
8248 { x
= scm_divide (x
, y
);
8250 rest
= scm_cdr (rest
);
8252 return scm_divide (x
, y
);
8256 #define s_divide s_scm_i_divide
8257 #define g_divide g_scm_i_divide
8260 scm_divide (SCM x
, SCM y
)
8261 #define FUNC_NAME s_divide
8265 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8268 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8269 else if (SCM_I_INUMP (x
))
8271 scm_t_inum xx
= SCM_I_INUM (x
);
8272 if (xx
== 1 || xx
== -1)
8274 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8276 scm_num_overflow (s_divide
);
8279 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8281 else if (SCM_BIGP (x
))
8282 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8283 else if (SCM_REALP (x
))
8285 double xx
= SCM_REAL_VALUE (x
);
8286 #ifndef ALLOW_DIVIDE_BY_ZERO
8288 scm_num_overflow (s_divide
);
8291 return scm_i_from_double (1.0 / xx
);
8293 else if (SCM_COMPLEXP (x
))
8295 double r
= SCM_COMPLEX_REAL (x
);
8296 double i
= SCM_COMPLEX_IMAG (x
);
8297 if (fabs(r
) <= fabs(i
))
8300 double d
= i
* (1.0 + t
* t
);
8301 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8306 double d
= r
* (1.0 + t
* t
);
8307 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8310 else if (SCM_FRACTIONP (x
))
8311 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8312 SCM_FRACTION_NUMERATOR (x
));
8314 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8317 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8319 scm_t_inum xx
= SCM_I_INUM (x
);
8320 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8322 scm_t_inum yy
= SCM_I_INUM (y
);
8325 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8326 scm_num_overflow (s_divide
);
8328 return scm_i_from_double ((double) xx
/ (double) yy
);
8331 else if (xx
% yy
!= 0)
8332 return scm_i_make_ratio (x
, y
);
8335 scm_t_inum z
= xx
/ yy
;
8336 if (SCM_FIXABLE (z
))
8337 return SCM_I_MAKINUM (z
);
8339 return scm_i_inum2big (z
);
8342 else if (SCM_BIGP (y
))
8343 return scm_i_make_ratio (x
, y
);
8344 else if (SCM_REALP (y
))
8346 double yy
= SCM_REAL_VALUE (y
);
8347 #ifndef ALLOW_DIVIDE_BY_ZERO
8349 scm_num_overflow (s_divide
);
8352 /* FIXME: Precision may be lost here due to:
8353 (1) The cast from 'scm_t_inum' to 'double'
8354 (2) Double rounding */
8355 return scm_i_from_double ((double) xx
/ yy
);
8357 else if (SCM_COMPLEXP (y
))
8360 complex_div
: /* y _must_ be a complex number */
8362 double r
= SCM_COMPLEX_REAL (y
);
8363 double i
= SCM_COMPLEX_IMAG (y
);
8364 if (fabs(r
) <= fabs(i
))
8367 double d
= i
* (1.0 + t
* t
);
8368 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8373 double d
= r
* (1.0 + t
* t
);
8374 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8378 else if (SCM_FRACTIONP (y
))
8379 /* a / b/c = ac / b */
8380 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8381 SCM_FRACTION_NUMERATOR (y
));
8383 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8385 else if (SCM_BIGP (x
))
8387 if (SCM_I_INUMP (y
))
8389 scm_t_inum yy
= SCM_I_INUM (y
);
8392 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8393 scm_num_overflow (s_divide
);
8395 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8396 scm_remember_upto_here_1 (x
);
8397 return (sgn
== 0) ? scm_nan () : scm_inf ();
8404 /* FIXME: HMM, what are the relative performance issues here?
8405 We need to test. Is it faster on average to test
8406 divisible_p, then perform whichever operation, or is it
8407 faster to perform the integer div opportunistically and
8408 switch to real if there's a remainder? For now we take the
8409 middle ground: test, then if divisible, use the faster div
8412 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8413 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8417 SCM result
= scm_i_mkbig ();
8418 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8419 scm_remember_upto_here_1 (x
);
8421 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8422 return scm_i_normbig (result
);
8425 return scm_i_make_ratio (x
, y
);
8428 else if (SCM_BIGP (y
))
8430 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8434 SCM result
= scm_i_mkbig ();
8435 mpz_divexact (SCM_I_BIG_MPZ (result
),
8438 scm_remember_upto_here_2 (x
, y
);
8439 return scm_i_normbig (result
);
8442 return scm_i_make_ratio (x
, y
);
8444 else if (SCM_REALP (y
))
8446 double yy
= SCM_REAL_VALUE (y
);
8447 #ifndef ALLOW_DIVIDE_BY_ZERO
8449 scm_num_overflow (s_divide
);
8452 /* FIXME: Precision may be lost here due to:
8453 (1) scm_i_big2dbl (2) Double rounding */
8454 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8456 else if (SCM_COMPLEXP (y
))
8458 a
= scm_i_big2dbl (x
);
8461 else if (SCM_FRACTIONP (y
))
8462 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8463 SCM_FRACTION_NUMERATOR (y
));
8465 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8467 else if (SCM_REALP (x
))
8469 double rx
= SCM_REAL_VALUE (x
);
8470 if (SCM_I_INUMP (y
))
8472 scm_t_inum yy
= SCM_I_INUM (y
);
8473 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8475 scm_num_overflow (s_divide
);
8478 /* FIXME: Precision may be lost here due to:
8479 (1) The cast from 'scm_t_inum' to 'double'
8480 (2) Double rounding */
8481 return scm_i_from_double (rx
/ (double) yy
);
8483 else if (SCM_BIGP (y
))
8485 /* FIXME: Precision may be lost here due to:
8486 (1) The conversion from bignum to double
8487 (2) Double rounding */
8488 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8489 scm_remember_upto_here_1 (y
);
8490 return scm_i_from_double (rx
/ dby
);
8492 else if (SCM_REALP (y
))
8494 double yy
= SCM_REAL_VALUE (y
);
8495 #ifndef ALLOW_DIVIDE_BY_ZERO
8497 scm_num_overflow (s_divide
);
8500 return scm_i_from_double (rx
/ yy
);
8502 else if (SCM_COMPLEXP (y
))
8507 else if (SCM_FRACTIONP (y
))
8508 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8510 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8512 else if (SCM_COMPLEXP (x
))
8514 double rx
= SCM_COMPLEX_REAL (x
);
8515 double ix
= SCM_COMPLEX_IMAG (x
);
8516 if (SCM_I_INUMP (y
))
8518 scm_t_inum yy
= SCM_I_INUM (y
);
8519 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8521 scm_num_overflow (s_divide
);
8525 /* FIXME: Precision may be lost here due to:
8526 (1) The conversion from 'scm_t_inum' to double
8527 (2) Double rounding */
8529 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8532 else if (SCM_BIGP (y
))
8534 /* FIXME: Precision may be lost here due to:
8535 (1) The conversion from bignum to double
8536 (2) Double rounding */
8537 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8538 scm_remember_upto_here_1 (y
);
8539 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8541 else if (SCM_REALP (y
))
8543 double yy
= SCM_REAL_VALUE (y
);
8544 #ifndef ALLOW_DIVIDE_BY_ZERO
8546 scm_num_overflow (s_divide
);
8549 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8551 else if (SCM_COMPLEXP (y
))
8553 double ry
= SCM_COMPLEX_REAL (y
);
8554 double iy
= SCM_COMPLEX_IMAG (y
);
8555 if (fabs(ry
) <= fabs(iy
))
8558 double d
= iy
* (1.0 + t
* t
);
8559 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8564 double d
= ry
* (1.0 + t
* t
);
8565 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8568 else if (SCM_FRACTIONP (y
))
8570 /* FIXME: Precision may be lost here due to:
8571 (1) The conversion from fraction to double
8572 (2) Double rounding */
8573 double yy
= scm_i_fraction2double (y
);
8574 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8577 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8579 else if (SCM_FRACTIONP (x
))
8581 if (SCM_I_INUMP (y
))
8583 scm_t_inum yy
= SCM_I_INUM (y
);
8584 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8586 scm_num_overflow (s_divide
);
8589 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8590 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8592 else if (SCM_BIGP (y
))
8594 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8595 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8597 else if (SCM_REALP (y
))
8599 double yy
= SCM_REAL_VALUE (y
);
8600 #ifndef ALLOW_DIVIDE_BY_ZERO
8602 scm_num_overflow (s_divide
);
8605 /* FIXME: Precision may be lost here due to:
8606 (1) The conversion from fraction to double
8607 (2) Double rounding */
8608 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8610 else if (SCM_COMPLEXP (y
))
8612 /* FIXME: Precision may be lost here due to:
8613 (1) The conversion from fraction to double
8614 (2) Double rounding */
8615 a
= scm_i_fraction2double (x
);
8618 else if (SCM_FRACTIONP (y
))
8619 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8620 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8622 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8625 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8631 scm_c_truncate (double x
)
8636 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8637 half-way case (ie. when x is an integer plus 0.5) going upwards.
8638 Then half-way cases are identified and adjusted down if the
8639 round-upwards didn't give the desired even integer.
8641 "plus_half == result" identifies a half-way case. If plus_half, which is
8642 x + 0.5, is an integer then x must be an integer plus 0.5.
8644 An odd "result" value is identified with result/2 != floor(result/2).
8645 This is done with plus_half, since that value is ready for use sooner in
8646 a pipelined cpu, and we're already requiring plus_half == result.
8648 Note however that we need to be careful when x is big and already an
8649 integer. In that case "x+0.5" may round to an adjacent integer, causing
8650 us to return such a value, incorrectly. For instance if the hardware is
8651 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8652 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8653 returned. Or if the hardware is in round-upwards mode, then other bigger
8654 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8655 representable value, 2^128+2^76 (or whatever), again incorrect.
8657 These bad roundings of x+0.5 are avoided by testing at the start whether
8658 x is already an integer. If it is then clearly that's the desired result
8659 already. And if it's not then the exponent must be small enough to allow
8660 an 0.5 to be represented, and hence added without a bad rounding. */
8663 scm_c_round (double x
)
8665 double plus_half
, result
;
8670 plus_half
= x
+ 0.5;
8671 result
= floor (plus_half
);
8672 /* Adjust so that the rounding is towards even. */
8673 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8678 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8680 "Round the number @var{x} towards zero.")
8681 #define FUNC_NAME s_scm_truncate_number
8683 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8685 else if (SCM_REALP (x
))
8686 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8687 else if (SCM_FRACTIONP (x
))
8688 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8689 SCM_FRACTION_DENOMINATOR (x
));
8691 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8692 s_scm_truncate_number
);
8696 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8698 "Round the number @var{x} towards the nearest integer. "
8699 "When it is exactly halfway between two integers, "
8700 "round towards the even one.")
8701 #define FUNC_NAME s_scm_round_number
8703 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8705 else if (SCM_REALP (x
))
8706 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8707 else if (SCM_FRACTIONP (x
))
8708 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8709 SCM_FRACTION_DENOMINATOR (x
));
8711 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8712 s_scm_round_number
);
8716 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8718 "Round the number @var{x} towards minus infinity.")
8719 #define FUNC_NAME s_scm_floor
8721 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8723 else if (SCM_REALP (x
))
8724 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8725 else if (SCM_FRACTIONP (x
))
8726 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8727 SCM_FRACTION_DENOMINATOR (x
));
8729 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8733 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8735 "Round the number @var{x} towards infinity.")
8736 #define FUNC_NAME s_scm_ceiling
8738 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8740 else if (SCM_REALP (x
))
8741 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8742 else if (SCM_FRACTIONP (x
))
8743 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8744 SCM_FRACTION_DENOMINATOR (x
));
8746 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8750 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8752 "Return @var{x} raised to the power of @var{y}.")
8753 #define FUNC_NAME s_scm_expt
8755 if (scm_is_integer (y
))
8757 if (scm_is_true (scm_exact_p (y
)))
8758 return scm_integer_expt (x
, y
);
8761 /* Here we handle the case where the exponent is an inexact
8762 integer. We make the exponent exact in order to use
8763 scm_integer_expt, and thus avoid the spurious imaginary
8764 parts that may result from round-off errors in the general
8765 e^(y log x) method below (for example when squaring a large
8766 negative number). In this case, we must return an inexact
8767 result for correctness. We also make the base inexact so
8768 that scm_integer_expt will use fast inexact arithmetic
8769 internally. Note that making the base inexact is not
8770 sufficient to guarantee an inexact result, because
8771 scm_integer_expt will return an exact 1 when the exponent
8772 is 0, even if the base is inexact. */
8773 return scm_exact_to_inexact
8774 (scm_integer_expt (scm_exact_to_inexact (x
),
8775 scm_inexact_to_exact (y
)));
8778 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8780 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8782 else if (scm_is_complex (x
) && scm_is_complex (y
))
8783 return scm_exp (scm_product (scm_log (x
), y
));
8784 else if (scm_is_complex (x
))
8785 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8787 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8791 /* sin/cos/tan/asin/acos/atan
8792 sinh/cosh/tanh/asinh/acosh/atanh
8793 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8794 Written by Jerry D. Hedden, (C) FSF.
8795 See the file `COPYING' for terms applying to this program. */
8797 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8799 "Compute the sine of @var{z}.")
8800 #define FUNC_NAME s_scm_sin
8802 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8803 return z
; /* sin(exact0) = exact0 */
8804 else if (scm_is_real (z
))
8805 return scm_i_from_double (sin (scm_to_double (z
)));
8806 else if (SCM_COMPLEXP (z
))
8808 x
= SCM_COMPLEX_REAL (z
);
8809 y
= SCM_COMPLEX_IMAG (z
);
8810 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8811 cos (x
) * sinh (y
));
8814 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8818 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8820 "Compute the cosine of @var{z}.")
8821 #define FUNC_NAME s_scm_cos
8823 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8824 return SCM_INUM1
; /* cos(exact0) = exact1 */
8825 else if (scm_is_real (z
))
8826 return scm_i_from_double (cos (scm_to_double (z
)));
8827 else if (SCM_COMPLEXP (z
))
8829 x
= SCM_COMPLEX_REAL (z
);
8830 y
= SCM_COMPLEX_IMAG (z
);
8831 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8832 -sin (x
) * sinh (y
));
8835 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8839 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8841 "Compute the tangent of @var{z}.")
8842 #define FUNC_NAME s_scm_tan
8844 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8845 return z
; /* tan(exact0) = exact0 */
8846 else if (scm_is_real (z
))
8847 return scm_i_from_double (tan (scm_to_double (z
)));
8848 else if (SCM_COMPLEXP (z
))
8850 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8851 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8852 w
= cos (x
) + cosh (y
);
8853 #ifndef ALLOW_DIVIDE_BY_ZERO
8855 scm_num_overflow (s_scm_tan
);
8857 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8860 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8864 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8866 "Compute the hyperbolic sine of @var{z}.")
8867 #define FUNC_NAME s_scm_sinh
8869 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8870 return z
; /* sinh(exact0) = exact0 */
8871 else if (scm_is_real (z
))
8872 return scm_i_from_double (sinh (scm_to_double (z
)));
8873 else if (SCM_COMPLEXP (z
))
8875 x
= SCM_COMPLEX_REAL (z
);
8876 y
= SCM_COMPLEX_IMAG (z
);
8877 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8878 cosh (x
) * sin (y
));
8881 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8885 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8887 "Compute the hyperbolic cosine of @var{z}.")
8888 #define FUNC_NAME s_scm_cosh
8890 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8891 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8892 else if (scm_is_real (z
))
8893 return scm_i_from_double (cosh (scm_to_double (z
)));
8894 else if (SCM_COMPLEXP (z
))
8896 x
= SCM_COMPLEX_REAL (z
);
8897 y
= SCM_COMPLEX_IMAG (z
);
8898 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8899 sinh (x
) * sin (y
));
8902 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8906 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8908 "Compute the hyperbolic tangent of @var{z}.")
8909 #define FUNC_NAME s_scm_tanh
8911 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8912 return z
; /* tanh(exact0) = exact0 */
8913 else if (scm_is_real (z
))
8914 return scm_i_from_double (tanh (scm_to_double (z
)));
8915 else if (SCM_COMPLEXP (z
))
8917 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8918 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8919 w
= cosh (x
) + cos (y
);
8920 #ifndef ALLOW_DIVIDE_BY_ZERO
8922 scm_num_overflow (s_scm_tanh
);
8924 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8927 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8931 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8933 "Compute the arc sine of @var{z}.")
8934 #define FUNC_NAME s_scm_asin
8936 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8937 return z
; /* asin(exact0) = exact0 */
8938 else if (scm_is_real (z
))
8940 double w
= scm_to_double (z
);
8941 if (w
>= -1.0 && w
<= 1.0)
8942 return scm_i_from_double (asin (w
));
8944 return scm_product (scm_c_make_rectangular (0, -1),
8945 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8947 else if (SCM_COMPLEXP (z
))
8949 x
= SCM_COMPLEX_REAL (z
);
8950 y
= SCM_COMPLEX_IMAG (z
);
8951 return scm_product (scm_c_make_rectangular (0, -1),
8952 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8955 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8959 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8961 "Compute the arc cosine of @var{z}.")
8962 #define FUNC_NAME s_scm_acos
8964 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8965 return SCM_INUM0
; /* acos(exact1) = exact0 */
8966 else if (scm_is_real (z
))
8968 double w
= scm_to_double (z
);
8969 if (w
>= -1.0 && w
<= 1.0)
8970 return scm_i_from_double (acos (w
));
8972 return scm_sum (scm_i_from_double (acos (0.0)),
8973 scm_product (scm_c_make_rectangular (0, 1),
8974 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8976 else if (SCM_COMPLEXP (z
))
8978 x
= SCM_COMPLEX_REAL (z
);
8979 y
= SCM_COMPLEX_IMAG (z
);
8980 return scm_sum (scm_i_from_double (acos (0.0)),
8981 scm_product (scm_c_make_rectangular (0, 1),
8982 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8985 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8989 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8991 "With one argument, compute the arc tangent of @var{z}.\n"
8992 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8993 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8994 #define FUNC_NAME s_scm_atan
8998 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8999 return z
; /* atan(exact0) = exact0 */
9000 else if (scm_is_real (z
))
9001 return scm_i_from_double (atan (scm_to_double (z
)));
9002 else if (SCM_COMPLEXP (z
))
9005 v
= SCM_COMPLEX_REAL (z
);
9006 w
= SCM_COMPLEX_IMAG (z
);
9007 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
9008 scm_c_make_rectangular (v
, w
+ 1.0))),
9009 scm_c_make_rectangular (0, 2));
9012 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
9014 else if (scm_is_real (z
))
9016 if (scm_is_real (y
))
9017 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9019 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9022 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9026 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9028 "Compute the inverse hyperbolic sine of @var{z}.")
9029 #define FUNC_NAME s_scm_sys_asinh
9031 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9032 return z
; /* asinh(exact0) = exact0 */
9033 else if (scm_is_real (z
))
9034 return scm_i_from_double (asinh (scm_to_double (z
)));
9035 else if (scm_is_number (z
))
9036 return scm_log (scm_sum (z
,
9037 scm_sqrt (scm_sum (scm_product (z
, z
),
9040 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9044 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9046 "Compute the inverse hyperbolic cosine of @var{z}.")
9047 #define FUNC_NAME s_scm_sys_acosh
9049 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9050 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9051 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9052 return scm_i_from_double (acosh (scm_to_double (z
)));
9053 else if (scm_is_number (z
))
9054 return scm_log (scm_sum (z
,
9055 scm_sqrt (scm_difference (scm_product (z
, z
),
9058 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9062 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9064 "Compute the inverse hyperbolic tangent of @var{z}.")
9065 #define FUNC_NAME s_scm_sys_atanh
9067 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9068 return z
; /* atanh(exact0) = exact0 */
9069 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9070 return scm_i_from_double (atanh (scm_to_double (z
)));
9071 else if (scm_is_number (z
))
9072 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9073 scm_difference (SCM_INUM1
, z
))),
9076 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9081 scm_c_make_rectangular (double re
, double im
)
9085 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9087 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9088 SCM_COMPLEX_REAL (z
) = re
;
9089 SCM_COMPLEX_IMAG (z
) = im
;
9093 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9094 (SCM real_part
, SCM imaginary_part
),
9095 "Return a complex number constructed of the given @var{real_part} "
9096 "and @var{imaginary_part} parts.")
9097 #define FUNC_NAME s_scm_make_rectangular
9099 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9100 SCM_ARG1
, FUNC_NAME
, "real");
9101 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9102 SCM_ARG2
, FUNC_NAME
, "real");
9104 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9105 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9108 return scm_c_make_rectangular (scm_to_double (real_part
),
9109 scm_to_double (imaginary_part
));
9114 scm_c_make_polar (double mag
, double ang
)
9118 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9119 use it on Glibc-based systems that have it (it's a GNU extension). See
9120 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9122 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9123 sincos (ang
, &s
, &c
);
9129 /* If s and c are NaNs, this indicates that the angle is a NaN,
9130 infinite, or perhaps simply too large to determine its value
9131 mod 2*pi. However, we know something that the floating-point
9132 implementation doesn't know: We know that s and c are finite.
9133 Therefore, if the magnitude is zero, return a complex zero.
9135 The reason we check for the NaNs instead of using this case
9136 whenever mag == 0.0 is because when the angle is known, we'd
9137 like to return the correct kind of non-real complex zero:
9138 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9139 on which quadrant the angle is in.
9141 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9142 return scm_c_make_rectangular (0.0, 0.0);
9144 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9147 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9149 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9150 #define FUNC_NAME s_scm_make_polar
9152 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9153 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9155 /* If mag is exact0, return exact0 */
9156 if (scm_is_eq (mag
, SCM_INUM0
))
9158 /* Return a real if ang is exact0 */
9159 else if (scm_is_eq (ang
, SCM_INUM0
))
9162 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9167 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9169 "Return the real part of the number @var{z}.")
9170 #define FUNC_NAME s_scm_real_part
9172 if (SCM_COMPLEXP (z
))
9173 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9174 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9177 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9182 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9184 "Return the imaginary part of the number @var{z}.")
9185 #define FUNC_NAME s_scm_imag_part
9187 if (SCM_COMPLEXP (z
))
9188 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9189 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9192 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9196 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9198 "Return the numerator of the number @var{z}.")
9199 #define FUNC_NAME s_scm_numerator
9201 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9203 else if (SCM_FRACTIONP (z
))
9204 return SCM_FRACTION_NUMERATOR (z
);
9205 else if (SCM_REALP (z
))
9207 double zz
= SCM_REAL_VALUE (z
);
9208 if (zz
== floor (zz
))
9209 /* Handle -0.0 and infinities in accordance with R6RS
9210 flnumerator, and optimize handling of integers. */
9213 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9216 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9221 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9223 "Return the denominator of the number @var{z}.")
9224 #define FUNC_NAME s_scm_denominator
9226 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9228 else if (SCM_FRACTIONP (z
))
9229 return SCM_FRACTION_DENOMINATOR (z
);
9230 else if (SCM_REALP (z
))
9232 double zz
= SCM_REAL_VALUE (z
);
9233 if (zz
== floor (zz
))
9234 /* Handle infinities in accordance with R6RS fldenominator, and
9235 optimize handling of integers. */
9236 return scm_i_from_double (1.0);
9238 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9241 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9247 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9249 "Return the magnitude of the number @var{z}. This is the same as\n"
9250 "@code{abs} for real arguments, but also allows complex numbers.")
9251 #define FUNC_NAME s_scm_magnitude
9253 if (SCM_I_INUMP (z
))
9255 scm_t_inum zz
= SCM_I_INUM (z
);
9258 else if (SCM_POSFIXABLE (-zz
))
9259 return SCM_I_MAKINUM (-zz
);
9261 return scm_i_inum2big (-zz
);
9263 else if (SCM_BIGP (z
))
9265 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9266 scm_remember_upto_here_1 (z
);
9268 return scm_i_clonebig (z
, 0);
9272 else if (SCM_REALP (z
))
9273 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9274 else if (SCM_COMPLEXP (z
))
9275 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9276 else if (SCM_FRACTIONP (z
))
9278 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9280 return scm_i_make_ratio_already_reduced
9281 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9282 SCM_FRACTION_DENOMINATOR (z
));
9285 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9291 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9293 "Return the angle of the complex number @var{z}.")
9294 #define FUNC_NAME s_scm_angle
9296 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9297 flo0 to save allocating a new flonum with scm_i_from_double each time.
9298 But if atan2 follows the floating point rounding mode, then the value
9299 is not a constant. Maybe it'd be close enough though. */
9300 if (SCM_I_INUMP (z
))
9302 if (SCM_I_INUM (z
) >= 0)
9305 return scm_i_from_double (atan2 (0.0, -1.0));
9307 else if (SCM_BIGP (z
))
9309 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9310 scm_remember_upto_here_1 (z
);
9312 return scm_i_from_double (atan2 (0.0, -1.0));
9316 else if (SCM_REALP (z
))
9318 double x
= SCM_REAL_VALUE (z
);
9319 if (copysign (1.0, x
) > 0.0)
9322 return scm_i_from_double (atan2 (0.0, -1.0));
9324 else if (SCM_COMPLEXP (z
))
9325 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9326 else if (SCM_FRACTIONP (z
))
9328 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9330 else return scm_i_from_double (atan2 (0.0, -1.0));
9333 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9338 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9340 "Convert the number @var{z} to its inexact representation.\n")
9341 #define FUNC_NAME s_scm_exact_to_inexact
9343 if (SCM_I_INUMP (z
))
9344 return scm_i_from_double ((double) SCM_I_INUM (z
));
9345 else if (SCM_BIGP (z
))
9346 return scm_i_from_double (scm_i_big2dbl (z
));
9347 else if (SCM_FRACTIONP (z
))
9348 return scm_i_from_double (scm_i_fraction2double (z
));
9349 else if (SCM_INEXACTP (z
))
9352 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9353 s_scm_exact_to_inexact
);
9358 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9360 "Return an exact number that is numerically closest to @var{z}.")
9361 #define FUNC_NAME s_scm_inexact_to_exact
9363 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9370 val
= SCM_REAL_VALUE (z
);
9371 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9372 val
= SCM_COMPLEX_REAL (z
);
9374 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9375 s_scm_inexact_to_exact
);
9377 if (!SCM_LIKELY (isfinite (val
)))
9378 SCM_OUT_OF_RANGE (1, z
);
9379 else if (val
== 0.0)
9386 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9388 expon
-= DBL_MANT_DIG
;
9391 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9395 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9396 SCM_I_BIG_MPZ (numerator
),
9400 numerator
= scm_i_normbig (numerator
);
9402 return scm_i_make_ratio_already_reduced
9403 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9405 return left_shift_exact_integer (numerator
, expon
);
9413 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9415 "Returns the @emph{simplest} rational number differing\n"
9416 "from @var{x} by no more than @var{eps}.\n"
9418 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9419 "exact result when both its arguments are exact. Thus, you might need\n"
9420 "to use @code{inexact->exact} on the arguments.\n"
9423 "(rationalize (inexact->exact 1.2) 1/100)\n"
9426 #define FUNC_NAME s_scm_rationalize
9428 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9429 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9431 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9433 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9435 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9440 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9443 return scm_exact_to_inexact
9444 (scm_rationalize (scm_inexact_to_exact (x
),
9445 scm_inexact_to_exact (eps
)));
9449 /* X and EPS are exact rationals.
9451 The code that follows is equivalent to the following Scheme code:
9453 (define (exact-rationalize x eps)
9454 (let ((n1 (if (negative? x) -1 1))
9457 (let ((lo (- x eps))
9461 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9462 (nhi (numerator hi)) (dhi (denominator hi))
9463 (n1 n1) (d1 0) (n2 0) (d2 1))
9464 (let-values (((qlo rlo) (floor/ nlo dlo))
9465 ((qhi rhi) (floor/ nhi dhi)))
9466 (let ((n0 (+ n2 (* n1 qlo)))
9467 (d0 (+ d2 (* d1 qlo))))
9468 (cond ((zero? rlo) (/ n0 d0))
9469 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9470 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9476 eps
= scm_abs (eps
);
9477 if (scm_is_true (scm_negative_p (x
)))
9480 x
= scm_difference (x
, SCM_UNDEFINED
);
9483 /* X and EPS are non-negative exact rationals. */
9485 lo
= scm_difference (x
, eps
);
9486 hi
= scm_sum (x
, eps
);
9488 if (scm_is_false (scm_positive_p (lo
)))
9489 /* If zero is included in the interval, return it.
9490 It is the simplest rational of all. */
9495 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9496 mpz_t nlo
, dlo
, nhi
, dhi
;
9497 mpz_t qlo
, rlo
, qhi
, rhi
;
9499 /* LO and HI are positive exact rationals. */
9501 /* Our approach here follows the method described by Alan
9502 Bawden in a message entitled "(rationalize x y)" on the
9503 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9505 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9507 In brief, we compute the continued fractions of the two
9508 endpoints of the interval (LO and HI). The continued
9509 fraction of the result consists of the common prefix of the
9510 continued fractions of LO and HI, plus one final term. The
9511 final term of the result is the smallest integer contained
9512 in the interval between the remainders of LO and HI after
9513 the common prefix has been removed.
9515 The following code lazily computes the continued fraction
9516 representations of LO and HI, and simultaneously converts
9517 the continued fraction of the result into a rational
9518 number. We use MPZ functions directly to avoid type
9519 dispatch and GC allocation during the loop. */
9521 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9526 /* The variables N1, D1, N2 and D2 are used to compute the
9527 resulting rational from its continued fraction. At each
9528 step, N2/D2 and N1/D1 are the last two convergents. They
9529 are normally initialized to 0/1 and 1/0, respectively.
9530 However, if we negated X then we must negate the result as
9531 well, and we do that by initializing N1/D1 to -1/0. */
9532 mpz_set_si (n1
, n1_init
);
9537 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9538 compute the continued fraction representations of LO and HI
9539 using Euclid's algorithm. Initially, NLO/DLO == LO and
9541 scm_to_mpz (scm_numerator (lo
), nlo
);
9542 scm_to_mpz (scm_denominator (lo
), dlo
);
9543 scm_to_mpz (scm_numerator (hi
), nhi
);
9544 scm_to_mpz (scm_denominator (hi
), dhi
);
9546 /* As long as we're using exact arithmetic, the following loop
9547 is guaranteed to terminate. */
9550 /* Compute the next terms (QLO and QHI) of the continued
9551 fractions of LO and HI. */
9552 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9553 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9555 /* The next term of the result will be either QLO or
9556 QLO+1. Here we compute the next convergent of the
9557 result based on the assumption that QLO is the next
9558 term. If that turns out to be wrong, we'll adjust
9559 these later by adding N1 to N0 and D1 to D0. */
9560 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9561 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9563 /* We stop iterating when an integer is contained in the
9564 interval between the remainders NLO/DLO and NHI/DHI.
9565 There are two cases to consider: either NLO/DLO == QLO
9566 is an integer (indicated by RLO == 0), or QLO < QHI. */
9567 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9570 /* Efficiently shuffle variables around for the next
9571 iteration. First we shift the recent convergents. */
9572 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9573 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9575 /* The following shuffling is a bit confusing, so some
9576 explanation is in order. Conceptually, we're doing a
9577 couple of things here. After substracting the floor of
9578 NLO/DLO, the remainder is RLO/DLO. The rest of the
9579 continued fraction will represent the remainder's
9580 reciprocal DLO/RLO. Similarly for the HI endpoint.
9581 So in the next iteration, the new endpoints will be
9582 DLO/RLO and DHI/RHI. However, when we take the
9583 reciprocals of these endpoints, their order is
9584 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9585 and NHI/DHI <-- DLO/RLO. */
9586 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9587 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9590 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9591 The last term of the result will be the smallest integer in
9592 that interval, which is ceiling(NLO/DLO). We have already
9593 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9594 equal to the ceiling. */
9595 if (mpz_sgn (rlo
) != 0)
9597 /* If RLO is non-zero, then NLO/DLO is not an integer and
9598 the next term will be QLO+1. QLO was used in the
9599 computation of N0 and D0 above. Here we adjust N0 and
9600 D0 to be based on QLO+1 instead of QLO. */
9601 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9602 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9605 /* The simplest rational in the interval is N0/D0 */
9606 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9608 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9618 /* conversion functions */
9621 scm_is_integer (SCM val
)
9623 return scm_is_true (scm_integer_p (val
));
9627 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9629 if (SCM_I_INUMP (val
))
9631 scm_t_signed_bits n
= SCM_I_INUM (val
);
9632 return n
>= min
&& n
<= max
;
9634 else if (SCM_BIGP (val
))
9636 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9638 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9640 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9642 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9643 return n
>= min
&& n
<= max
;
9653 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9654 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9657 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9658 SCM_I_BIG_MPZ (val
));
9660 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9672 return n
>= min
&& n
<= max
;
9680 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9682 if (SCM_I_INUMP (val
))
9684 scm_t_signed_bits n
= SCM_I_INUM (val
);
9685 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9687 else if (SCM_BIGP (val
))
9689 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9691 else if (max
<= ULONG_MAX
)
9693 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9695 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9696 return n
>= min
&& n
<= max
;
9706 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9709 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9710 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9713 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9714 SCM_I_BIG_MPZ (val
));
9716 return n
>= min
&& n
<= max
;
9724 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9726 scm_error (scm_out_of_range_key
,
9728 "Value out of range ~S to ~S: ~S",
9729 scm_list_3 (min
, max
, bad_val
),
9730 scm_list_1 (bad_val
));
9733 #define TYPE scm_t_intmax
9734 #define TYPE_MIN min
9735 #define TYPE_MAX max
9736 #define SIZEOF_TYPE 0
9737 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9738 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9739 #include "libguile/conv-integer.i.c"
9741 #define TYPE scm_t_uintmax
9742 #define TYPE_MIN min
9743 #define TYPE_MAX max
9744 #define SIZEOF_TYPE 0
9745 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9746 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9747 #include "libguile/conv-uinteger.i.c"
9749 #define TYPE scm_t_int8
9750 #define TYPE_MIN SCM_T_INT8_MIN
9751 #define TYPE_MAX SCM_T_INT8_MAX
9752 #define SIZEOF_TYPE 1
9753 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9754 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9755 #include "libguile/conv-integer.i.c"
9757 #define TYPE scm_t_uint8
9759 #define TYPE_MAX SCM_T_UINT8_MAX
9760 #define SIZEOF_TYPE 1
9761 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9762 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9763 #include "libguile/conv-uinteger.i.c"
9765 #define TYPE scm_t_int16
9766 #define TYPE_MIN SCM_T_INT16_MIN
9767 #define TYPE_MAX SCM_T_INT16_MAX
9768 #define SIZEOF_TYPE 2
9769 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9770 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9771 #include "libguile/conv-integer.i.c"
9773 #define TYPE scm_t_uint16
9775 #define TYPE_MAX SCM_T_UINT16_MAX
9776 #define SIZEOF_TYPE 2
9777 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9778 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9779 #include "libguile/conv-uinteger.i.c"
9781 #define TYPE scm_t_int32
9782 #define TYPE_MIN SCM_T_INT32_MIN
9783 #define TYPE_MAX SCM_T_INT32_MAX
9784 #define SIZEOF_TYPE 4
9785 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9786 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9787 #include "libguile/conv-integer.i.c"
9789 #define TYPE scm_t_uint32
9791 #define TYPE_MAX SCM_T_UINT32_MAX
9792 #define SIZEOF_TYPE 4
9793 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9794 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9795 #include "libguile/conv-uinteger.i.c"
9797 #define TYPE scm_t_wchar
9798 #define TYPE_MIN (scm_t_int32)-1
9799 #define TYPE_MAX (scm_t_int32)0x10ffff
9800 #define SIZEOF_TYPE 4
9801 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9802 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9803 #include "libguile/conv-integer.i.c"
9805 #define TYPE scm_t_int64
9806 #define TYPE_MIN SCM_T_INT64_MIN
9807 #define TYPE_MAX SCM_T_INT64_MAX
9808 #define SIZEOF_TYPE 8
9809 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9810 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9811 #include "libguile/conv-integer.i.c"
9813 #define TYPE scm_t_uint64
9815 #define TYPE_MAX SCM_T_UINT64_MAX
9816 #define SIZEOF_TYPE 8
9817 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9818 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9819 #include "libguile/conv-uinteger.i.c"
9822 scm_to_mpz (SCM val
, mpz_t rop
)
9824 if (SCM_I_INUMP (val
))
9825 mpz_set_si (rop
, SCM_I_INUM (val
));
9826 else if (SCM_BIGP (val
))
9827 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9829 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9833 scm_from_mpz (mpz_t val
)
9835 return scm_i_mpz2num (val
);
9839 scm_is_real (SCM val
)
9841 return scm_is_true (scm_real_p (val
));
9845 scm_is_rational (SCM val
)
9847 return scm_is_true (scm_rational_p (val
));
9851 scm_to_double (SCM val
)
9853 if (SCM_I_INUMP (val
))
9854 return SCM_I_INUM (val
);
9855 else if (SCM_BIGP (val
))
9856 return scm_i_big2dbl (val
);
9857 else if (SCM_FRACTIONP (val
))
9858 return scm_i_fraction2double (val
);
9859 else if (SCM_REALP (val
))
9860 return SCM_REAL_VALUE (val
);
9862 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9866 scm_from_double (double val
)
9868 return scm_i_from_double (val
);
9872 scm_is_complex (SCM val
)
9874 return scm_is_true (scm_complex_p (val
));
9878 scm_c_real_part (SCM z
)
9880 if (SCM_COMPLEXP (z
))
9881 return SCM_COMPLEX_REAL (z
);
9884 /* Use the scm_real_part to get proper error checking and
9887 return scm_to_double (scm_real_part (z
));
9892 scm_c_imag_part (SCM z
)
9894 if (SCM_COMPLEXP (z
))
9895 return SCM_COMPLEX_IMAG (z
);
9898 /* Use the scm_imag_part to get proper error checking and
9899 dispatching. The result will almost always be 0.0, but not
9902 return scm_to_double (scm_imag_part (z
));
9907 scm_c_magnitude (SCM z
)
9909 return scm_to_double (scm_magnitude (z
));
9915 return scm_to_double (scm_angle (z
));
9919 scm_is_number (SCM z
)
9921 return scm_is_true (scm_number_p (z
));
9925 /* Returns log(x * 2^shift) */
9927 log_of_shifted_double (double x
, long shift
)
9929 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9931 if (copysign (1.0, x
) > 0.0)
9932 return scm_i_from_double (ans
);
9934 return scm_c_make_rectangular (ans
, M_PI
);
9937 /* Returns log(n), for exact integer n */
9939 log_of_exact_integer (SCM n
)
9941 if (SCM_I_INUMP (n
))
9942 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9943 else if (SCM_BIGP (n
))
9946 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9947 return log_of_shifted_double (signif
, expon
);
9950 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9953 /* Returns log(n/d), for exact non-zero integers n and d */
9955 log_of_fraction (SCM n
, SCM d
)
9957 long n_size
= scm_to_long (scm_integer_length (n
));
9958 long d_size
= scm_to_long (scm_integer_length (d
));
9960 if (abs (n_size
- d_size
) > 1)
9961 return (scm_difference (log_of_exact_integer (n
),
9962 log_of_exact_integer (d
)));
9963 else if (scm_is_false (scm_negative_p (n
)))
9964 return scm_i_from_double
9965 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9967 return scm_c_make_rectangular
9968 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9974 /* In the following functions we dispatch to the real-arg funcs like log()
9975 when we know the arg is real, instead of just handing everything to
9976 clog() for instance. This is in case clog() doesn't optimize for a
9977 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9978 well use it to go straight to the applicable C func. */
9980 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9982 "Return the natural logarithm of @var{z}.")
9983 #define FUNC_NAME s_scm_log
9985 if (SCM_COMPLEXP (z
))
9987 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9988 && defined (SCM_COMPLEX_VALUE)
9989 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9991 double re
= SCM_COMPLEX_REAL (z
);
9992 double im
= SCM_COMPLEX_IMAG (z
);
9993 return scm_c_make_rectangular (log (hypot (re
, im
)),
9997 else if (SCM_REALP (z
))
9998 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9999 else if (SCM_I_INUMP (z
))
10001 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10002 if (scm_is_eq (z
, SCM_INUM0
))
10003 scm_num_overflow (s_scm_log
);
10005 return log_of_shifted_double (SCM_I_INUM (z
), 0);
10007 else if (SCM_BIGP (z
))
10008 return log_of_exact_integer (z
);
10009 else if (SCM_FRACTIONP (z
))
10010 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10011 SCM_FRACTION_DENOMINATOR (z
));
10013 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
10018 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10020 "Return the base 10 logarithm of @var{z}.")
10021 #define FUNC_NAME s_scm_log10
10023 if (SCM_COMPLEXP (z
))
10025 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10026 clog() and a multiply by M_LOG10E, rather than the fallback
10027 log10+hypot+atan2.) */
10028 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10029 && defined SCM_COMPLEX_VALUE
10030 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10032 double re
= SCM_COMPLEX_REAL (z
);
10033 double im
= SCM_COMPLEX_IMAG (z
);
10034 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10035 M_LOG10E
* atan2 (im
, re
));
10038 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10040 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10041 if (scm_is_eq (z
, SCM_INUM0
))
10042 scm_num_overflow (s_scm_log10
);
10045 double re
= scm_to_double (z
);
10046 double l
= log10 (fabs (re
));
10047 if (copysign (1.0, re
) > 0.0)
10048 return scm_i_from_double (l
);
10050 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10053 else if (SCM_BIGP (z
))
10054 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10055 else if (SCM_FRACTIONP (z
))
10056 return scm_product (flo_log10e
,
10057 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10058 SCM_FRACTION_DENOMINATOR (z
)));
10060 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10065 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10067 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10068 "base of natural logarithms (2.71828@dots{}).")
10069 #define FUNC_NAME s_scm_exp
10071 if (SCM_COMPLEXP (z
))
10073 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10074 && defined (SCM_COMPLEX_VALUE)
10075 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10077 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10078 SCM_COMPLEX_IMAG (z
));
10081 else if (SCM_NUMBERP (z
))
10083 /* When z is a negative bignum the conversion to double overflows,
10084 giving -infinity, but that's ok, the exp is still 0.0. */
10085 return scm_i_from_double (exp (scm_to_double (z
)));
10088 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10093 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10095 "Return two exact non-negative integers @var{s} and @var{r}\n"
10096 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10097 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10098 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10101 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10103 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10107 scm_exact_integer_sqrt (k
, &s
, &r
);
10108 return scm_values (scm_list_2 (s
, r
));
10113 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10115 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10119 if (SCM_I_INUM (k
) < 0)
10120 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10121 "exact non-negative integer");
10122 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10123 mpz_inits (ss
, rr
, NULL
);
10124 mpz_sqrtrem (ss
, rr
, kk
);
10125 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10126 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10127 mpz_clears (kk
, ss
, rr
, NULL
);
10129 else if (SCM_LIKELY (SCM_BIGP (k
)))
10133 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10134 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10135 "exact non-negative integer");
10136 s
= scm_i_mkbig ();
10137 r
= scm_i_mkbig ();
10138 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10139 scm_remember_upto_here_1 (k
);
10140 *sp
= scm_i_normbig (s
);
10141 *rp
= scm_i_normbig (r
);
10144 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10145 "exact non-negative integer");
10148 /* Return true iff K is a perfect square.
10149 K must be an exact integer. */
10151 exact_integer_is_perfect_square (SCM k
)
10155 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10159 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10160 result
= mpz_perfect_square_p (kk
);
10165 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10166 scm_remember_upto_here_1 (k
);
10171 /* Return the floor of the square root of K.
10172 K must be an exact integer. */
10174 exact_integer_floor_square_root (SCM k
)
10176 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10181 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10183 ss
= mpz_get_ui (kk
);
10185 return SCM_I_MAKINUM (ss
);
10191 s
= scm_i_mkbig ();
10192 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10193 scm_remember_upto_here_1 (k
);
10194 return scm_i_normbig (s
);
10199 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10201 "Return the square root of @var{z}. Of the two possible roots\n"
10202 "(positive and negative), the one with positive real part\n"
10203 "is returned, or if that's zero then a positive imaginary part.\n"
10207 "(sqrt 9.0) @result{} 3.0\n"
10208 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10209 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10210 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10212 #define FUNC_NAME s_scm_sqrt
10214 if (SCM_COMPLEXP (z
))
10216 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10217 && defined SCM_COMPLEX_VALUE
10218 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10220 double re
= SCM_COMPLEX_REAL (z
);
10221 double im
= SCM_COMPLEX_IMAG (z
);
10222 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10223 0.5 * atan2 (im
, re
));
10226 else if (SCM_NUMBERP (z
))
10228 if (SCM_I_INUMP (z
))
10230 scm_t_inum x
= SCM_I_INUM (z
);
10232 if (SCM_LIKELY (x
>= 0))
10234 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10235 || x
< (1L << (DBL_MANT_DIG
- 1))))
10237 double root
= sqrt (x
);
10239 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10240 integer, then the result is exact. */
10241 if (root
== floor (root
))
10242 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10244 return scm_i_from_double (root
);
10251 mpz_init_set_ui (xx
, x
);
10252 if (mpz_perfect_square_p (xx
))
10255 root
= mpz_get_ui (xx
);
10257 return SCM_I_MAKINUM (root
);
10264 else if (SCM_BIGP (z
))
10266 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10268 SCM root
= scm_i_mkbig ();
10270 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10271 scm_remember_upto_here_1 (z
);
10272 return scm_i_normbig (root
);
10277 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10285 return scm_c_make_rectangular
10286 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10288 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10291 else if (SCM_FRACTIONP (z
))
10293 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10294 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10296 if (exact_integer_is_perfect_square (n
)
10297 && exact_integer_is_perfect_square (d
))
10298 return scm_i_make_ratio_already_reduced
10299 (exact_integer_floor_square_root (n
),
10300 exact_integer_floor_square_root (d
));
10303 double xx
= scm_i_divide2double (n
, d
);
10304 double abs_xx
= fabs (xx
);
10307 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10309 shift
= (scm_to_long (scm_integer_length (n
))
10310 - scm_to_long (scm_integer_length (d
))) / 2;
10312 d
= left_shift_exact_integer (d
, 2 * shift
);
10314 n
= left_shift_exact_integer (n
, -2 * shift
);
10315 xx
= scm_i_divide2double (n
, d
);
10319 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10321 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10325 /* Fallback method, when the cases above do not apply. */
10327 double xx
= scm_to_double (z
);
10329 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10331 return scm_i_from_double (sqrt (xx
));
10335 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10342 scm_init_numbers ()
10344 if (scm_install_gmp_memory_functions
)
10345 mp_set_memory_functions (custom_gmp_malloc
,
10346 custom_gmp_realloc
,
10349 mpz_init_set_si (z_negative_one
, -1);
10351 /* It may be possible to tune the performance of some algorithms by using
10352 * the following constants to avoid the creation of bignums. Please, before
10353 * using these values, remember the two rules of program optimization:
10354 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10355 scm_c_define ("most-positive-fixnum",
10356 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10357 scm_c_define ("most-negative-fixnum",
10358 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10360 scm_add_feature ("complex");
10361 scm_add_feature ("inexact");
10362 flo0
= scm_i_from_double (0.0);
10363 flo_log10e
= scm_i_from_double (M_LOG10E
);
10365 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10368 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10369 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10370 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10371 scm_i_divide2double_lo2b
,
10372 DBL_MANT_DIG
+ 1); /* 2 b^p */
10373 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10377 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10378 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10379 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10380 dbl_minimum_normal_mantissa
,
10384 #include "libguile/numbers.x"
10389 c-file-style: "gnu"