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 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)". */
4988 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4989 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4991 return SCM_I_MAKINUM (nn
<< count
);
4994 SCM result
= scm_i_inum2big (nn
);
4995 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5000 else if (SCM_BIGP (n
))
5002 SCM result
= scm_i_mkbig ();
5003 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5004 scm_remember_upto_here_1 (n
);
5011 /* Efficiently compute floor (N / 2^COUNT),
5012 where N is an exact integer and COUNT > 0. */
5014 floor_right_shift_exact_integer (SCM n
, long count
)
5016 if (SCM_I_INUMP (n
))
5018 scm_t_inum nn
= SCM_I_INUM (n
);
5020 if (count
>= SCM_I_FIXNUM_BIT
)
5021 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5023 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5025 else if (SCM_BIGP (n
))
5027 SCM result
= scm_i_mkbig ();
5028 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5030 scm_remember_upto_here_1 (n
);
5031 return scm_i_normbig (result
);
5037 /* Efficiently compute round (N / 2^COUNT),
5038 where N is an exact integer and COUNT > 0. */
5040 round_right_shift_exact_integer (SCM n
, long count
)
5042 if (SCM_I_INUMP (n
))
5044 if (count
>= SCM_I_FIXNUM_BIT
)
5048 scm_t_inum nn
= SCM_I_INUM (n
);
5049 scm_t_inum qq
= SCM_SRS (nn
, count
);
5051 if (0 == (nn
& (1L << (count
-1))))
5052 return SCM_I_MAKINUM (qq
); /* round down */
5053 else if (nn
& ((1L << (count
-1)) - 1))
5054 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5056 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5059 else if (SCM_BIGP (n
))
5061 SCM q
= scm_i_mkbig ();
5063 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5064 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5065 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5066 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5067 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5068 scm_remember_upto_here_1 (n
);
5069 return scm_i_normbig (q
);
5075 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5077 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5078 "@var{n} and @var{count} must be exact integers.\n"
5080 "With @var{n} viewed as an infinite-precision twos-complement\n"
5081 "integer, @code{ash} means a left shift introducing zero bits\n"
5082 "when @var{count} is positive, or a right shift dropping bits\n"
5083 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5086 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5087 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5089 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5090 "(ash -23 -2) @result{} -6\n"
5092 #define FUNC_NAME s_scm_ash
5094 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5096 long bits_to_shift
= scm_to_long (count
);
5098 if (bits_to_shift
> 0)
5099 return left_shift_exact_integer (n
, bits_to_shift
);
5100 else if (SCM_LIKELY (bits_to_shift
< 0))
5101 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5106 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5110 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5112 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5113 "@var{n} and @var{count} must be exact integers.\n"
5115 "With @var{n} viewed as an infinite-precision twos-complement\n"
5116 "integer, @code{round-ash} means a left shift introducing zero\n"
5117 "bits when @var{count} is positive, or a right shift rounding\n"
5118 "to the nearest integer (with ties going to the nearest even\n"
5119 "integer) when @var{count} is negative. This is a rounded\n"
5120 "``arithmetic'' shift.\n"
5123 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5124 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5125 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5126 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5127 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5128 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5130 #define FUNC_NAME s_scm_round_ash
5132 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5134 long bits_to_shift
= scm_to_long (count
);
5136 if (bits_to_shift
> 0)
5137 return left_shift_exact_integer (n
, bits_to_shift
);
5138 else if (SCM_LIKELY (bits_to_shift
< 0))
5139 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5144 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5149 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5150 (SCM n
, SCM start
, SCM end
),
5151 "Return the integer composed of the @var{start} (inclusive)\n"
5152 "through @var{end} (exclusive) bits of @var{n}. The\n"
5153 "@var{start}th bit becomes the 0-th bit in the result.\n"
5156 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5157 " @result{} \"1010\"\n"
5158 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5159 " @result{} \"10110\"\n"
5161 #define FUNC_NAME s_scm_bit_extract
5163 unsigned long int istart
, iend
, bits
;
5164 istart
= scm_to_ulong (start
);
5165 iend
= scm_to_ulong (end
);
5166 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5168 /* how many bits to keep */
5169 bits
= iend
- istart
;
5171 if (SCM_I_INUMP (n
))
5173 scm_t_inum in
= SCM_I_INUM (n
);
5175 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5176 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5177 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5179 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5181 /* Since we emulate two's complement encoded numbers, this
5182 * special case requires us to produce a result that has
5183 * more bits than can be stored in a fixnum.
5185 SCM result
= scm_i_inum2big (in
);
5186 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5191 /* mask down to requisite bits */
5192 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5193 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5195 else if (SCM_BIGP (n
))
5200 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5204 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5205 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5206 such bits into a ulong. */
5207 result
= scm_i_mkbig ();
5208 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5209 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5210 result
= scm_i_normbig (result
);
5212 scm_remember_upto_here_1 (n
);
5216 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5221 static const char scm_logtab
[] = {
5222 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5225 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5227 "Return the number of bits in integer @var{n}. If integer is\n"
5228 "positive, the 1-bits in its binary representation are counted.\n"
5229 "If negative, the 0-bits in its two's-complement binary\n"
5230 "representation are counted. If 0, 0 is returned.\n"
5233 "(logcount #b10101010)\n"
5240 #define FUNC_NAME s_scm_logcount
5242 if (SCM_I_INUMP (n
))
5244 unsigned long c
= 0;
5245 scm_t_inum nn
= SCM_I_INUM (n
);
5250 c
+= scm_logtab
[15 & nn
];
5253 return SCM_I_MAKINUM (c
);
5255 else if (SCM_BIGP (n
))
5257 unsigned long count
;
5258 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5259 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5261 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5262 scm_remember_upto_here_1 (n
);
5263 return SCM_I_MAKINUM (count
);
5266 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5271 static const char scm_ilentab
[] = {
5272 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5276 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5278 "Return the number of bits necessary to represent @var{n}.\n"
5281 "(integer-length #b10101010)\n"
5283 "(integer-length 0)\n"
5285 "(integer-length #b1111)\n"
5288 #define FUNC_NAME s_scm_integer_length
5290 if (SCM_I_INUMP (n
))
5292 unsigned long c
= 0;
5294 scm_t_inum nn
= SCM_I_INUM (n
);
5300 l
= scm_ilentab
[15 & nn
];
5303 return SCM_I_MAKINUM (c
- 4 + l
);
5305 else if (SCM_BIGP (n
))
5307 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5308 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5309 1 too big, so check for that and adjust. */
5310 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5311 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5312 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5313 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5315 scm_remember_upto_here_1 (n
);
5316 return SCM_I_MAKINUM (size
);
5319 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5323 /*** NUMBERS -> STRINGS ***/
5324 #define SCM_MAX_DBL_RADIX 36
5326 /* use this array as a way to generate a single digit */
5327 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5329 static mpz_t dbl_minimum_normal_mantissa
;
5332 idbl2str (double dbl
, char *a
, int radix
)
5336 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5337 /* revert to existing behavior */
5342 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5352 else if (dbl
== 0.0)
5354 if (copysign (1.0, dbl
) < 0.0)
5356 strcpy (a
+ ch
, "0.0");
5359 else if (isnan (dbl
))
5361 strcpy (a
, "+nan.0");
5365 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5366 Accurately" by Robert G. Burger and R. Kent Dybvig */
5369 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5370 int f_is_even
, f_is_odd
;
5374 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5375 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5376 if (e
< DBL_MIN_EXP
)
5378 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5383 f_is_even
= !mpz_odd_p (f
);
5384 f_is_odd
= !f_is_even
;
5386 /* Initialize r, s, mplus, and mminus according
5387 to Table 1 from the paper. */
5390 mpz_set_ui (mminus
, 1);
5391 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5392 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5394 mpz_set_ui (mplus
, 1);
5395 mpz_mul_2exp (r
, f
, 1);
5396 mpz_mul_2exp (s
, mminus
, 1 - e
);
5400 mpz_set_ui (mplus
, 2);
5401 mpz_mul_2exp (r
, f
, 2);
5402 mpz_mul_2exp (s
, mminus
, 2 - e
);
5407 mpz_set_ui (mminus
, 1);
5408 mpz_mul_2exp (mminus
, mminus
, e
);
5409 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5411 mpz_set (mplus
, mminus
);
5412 mpz_mul_2exp (r
, f
, 1 + e
);
5417 mpz_mul_2exp (mplus
, mminus
, 1);
5418 mpz_mul_2exp (r
, f
, 2 + e
);
5423 /* Find the smallest k such that:
5424 (r + mplus) / s < radix^k (if f is even)
5425 (r + mplus) / s <= radix^k (if f is odd) */
5427 /* IMPROVE-ME: Make an initial guess to speed this up */
5428 mpz_add (hi
, r
, mplus
);
5430 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5432 mpz_mul_ui (s
, s
, radix
);
5437 mpz_mul_ui (hi
, hi
, radix
);
5438 while (mpz_cmp (hi
, s
) < f_is_odd
)
5440 mpz_mul_ui (r
, r
, radix
);
5441 mpz_mul_ui (mplus
, mplus
, radix
);
5442 mpz_mul_ui (mminus
, mminus
, radix
);
5443 mpz_mul_ui (hi
, hi
, radix
);
5454 /* Use scientific notation */
5462 /* Print leading zeroes */
5465 for (i
= 0; i
> k
; i
--)
5472 int end_1_p
, end_2_p
;
5475 mpz_mul_ui (mplus
, mplus
, radix
);
5476 mpz_mul_ui (mminus
, mminus
, radix
);
5477 mpz_mul_ui (r
, r
, radix
);
5478 mpz_fdiv_qr (digit
, r
, r
, s
);
5479 d
= mpz_get_ui (digit
);
5481 mpz_add (hi
, r
, mplus
);
5482 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5483 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5484 if (end_1_p
|| end_2_p
)
5486 mpz_mul_2exp (r
, r
, 1);
5491 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5493 a
[ch
++] = number_chars
[d
];
5500 a
[ch
++] = number_chars
[d
];
5508 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5510 /* Here we would have to print more than three zeroes
5511 followed by a decimal point and another zero. It
5512 makes more sense to use scientific notation. */
5514 /* Adjust k to what it would have been if we had chosen
5515 scientific notation from the beginning. */
5518 /* k will now be <= 0, with magnitude equal to the number of
5519 digits that we printed which should now be put after the
5522 /* Insert a decimal point */
5523 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5543 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5546 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5553 icmplx2str (double real
, double imag
, char *str
, int radix
)
5558 i
= idbl2str (real
, str
, radix
);
5559 #ifdef HAVE_COPYSIGN
5560 sgn
= copysign (1.0, imag
);
5564 /* Don't output a '+' for negative numbers or for Inf and
5565 NaN. They will provide their own sign. */
5566 if (sgn
>= 0 && isfinite (imag
))
5568 i
+= idbl2str (imag
, &str
[i
], radix
);
5574 iflo2str (SCM flt
, char *str
, int radix
)
5577 if (SCM_REALP (flt
))
5578 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5580 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5585 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5586 characters in the result.
5588 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5590 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5595 return scm_iuint2str (-num
, rad
, p
) + 1;
5598 return scm_iuint2str (num
, rad
, p
);
5601 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5602 characters in the result.
5604 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5606 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5610 scm_t_uintmax n
= num
;
5612 if (rad
< 2 || rad
> 36)
5613 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5615 for (n
/= rad
; n
> 0; n
/= rad
)
5625 p
[i
] = number_chars
[d
];
5630 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5632 "Return a string holding the external representation of the\n"
5633 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5634 "inexact, a radix of 10 will be used.")
5635 #define FUNC_NAME s_scm_number_to_string
5639 if (SCM_UNBNDP (radix
))
5642 base
= scm_to_signed_integer (radix
, 2, 36);
5644 if (SCM_I_INUMP (n
))
5646 char num_buf
[SCM_INTBUFLEN
];
5647 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5648 return scm_from_locale_stringn (num_buf
, length
);
5650 else if (SCM_BIGP (n
))
5652 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5653 size_t len
= strlen (str
);
5654 void (*freefunc
) (void *, size_t);
5656 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5657 scm_remember_upto_here_1 (n
);
5658 ret
= scm_from_latin1_stringn (str
, len
);
5659 freefunc (str
, len
+ 1);
5662 else if (SCM_FRACTIONP (n
))
5664 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5665 scm_from_locale_string ("/"),
5666 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5668 else if (SCM_INEXACTP (n
))
5670 char num_buf
[FLOBUFLEN
];
5671 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5674 SCM_WRONG_TYPE_ARG (1, n
);
5679 /* These print routines used to be stubbed here so that scm_repl.c
5680 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5683 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5685 char num_buf
[FLOBUFLEN
];
5686 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5691 scm_i_print_double (double val
, SCM port
)
5693 char num_buf
[FLOBUFLEN
];
5694 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5698 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5701 char num_buf
[FLOBUFLEN
];
5702 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5707 scm_i_print_complex (double real
, double imag
, SCM port
)
5709 char num_buf
[FLOBUFLEN
];
5710 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5714 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5717 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5718 scm_display (str
, port
);
5719 scm_remember_upto_here_1 (str
);
5724 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5726 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5727 size_t len
= strlen (str
);
5728 void (*freefunc
) (void *, size_t);
5729 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5730 scm_remember_upto_here_1 (exp
);
5731 scm_lfwrite_unlocked (str
, len
, port
);
5732 freefunc (str
, len
+ 1);
5735 /*** END nums->strs ***/
5738 /*** STRINGS -> NUMBERS ***/
5740 /* The following functions implement the conversion from strings to numbers.
5741 * The implementation somehow follows the grammar for numbers as it is given
5742 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5743 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5744 * points should be noted about the implementation:
5746 * * Each function keeps a local index variable 'idx' that points at the
5747 * current position within the parsed string. The global index is only
5748 * updated if the function could parse the corresponding syntactic unit
5751 * * Similarly, the functions keep track of indicators of inexactness ('#',
5752 * '.' or exponents) using local variables ('hash_seen', 'x').
5754 * * Sequences of digits are parsed into temporary variables holding fixnums.
5755 * Only if these fixnums would overflow, the result variables are updated
5756 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5757 * the temporary variables holding the fixnums are cleared, and the process
5758 * starts over again. If for example fixnums were able to store five decimal
5759 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5760 * and the result was computed as 12345 * 100000 + 67890. In other words,
5761 * only every five digits two bignum operations were performed.
5763 * Notes on the handling of exactness specifiers:
5765 * When parsing non-real complex numbers, we apply exactness specifiers on
5766 * per-component basis, as is done in PLT Scheme. For complex numbers
5767 * written in rectangular form, exactness specifiers are applied to the
5768 * real and imaginary parts before calling scm_make_rectangular. For
5769 * complex numbers written in polar form, exactness specifiers are applied
5770 * to the magnitude and angle before calling scm_make_polar.
5772 * There are two kinds of exactness specifiers: forced and implicit. A
5773 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5774 * the entire number, and applies to both components of a complex number.
5775 * "#e" causes each component to be made exact, and "#i" causes each
5776 * component to be made inexact. If no forced exactness specifier is
5777 * present, then the exactness of each component is determined
5778 * independently by the presence or absence of a decimal point or hash mark
5779 * within that component. If a decimal point or hash mark is present, the
5780 * component is made inexact, otherwise it is made exact.
5782 * After the exactness specifiers have been applied to each component, they
5783 * are passed to either scm_make_rectangular or scm_make_polar to produce
5784 * the final result. Note that this will result in a real number if the
5785 * imaginary part, magnitude, or angle is an exact 0.
5787 * For example, (string->number "#i5.0+0i") does the equivalent of:
5789 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5792 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5794 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5796 /* Caller is responsible for checking that the return value is in range
5797 for the given radix, which should be <= 36. */
5799 char_decimal_value (scm_t_uint32 c
)
5801 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5802 that's certainly above any valid decimal, so we take advantage of
5803 that to elide some tests. */
5804 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5806 /* If that failed, try extended hexadecimals, then. Only accept ascii
5811 if (c
>= (scm_t_uint32
) 'a')
5812 d
= c
- (scm_t_uint32
)'a' + 10U;
5817 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5818 in base RADIX. Upon success, return the unsigned integer and update
5819 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5821 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5822 unsigned int radix
, enum t_exactness
*p_exactness
)
5824 unsigned int idx
= *p_idx
;
5825 unsigned int hash_seen
= 0;
5826 scm_t_bits shift
= 1;
5828 unsigned int digit_value
;
5831 size_t len
= scm_i_string_length (mem
);
5836 c
= scm_i_string_ref (mem
, idx
);
5837 digit_value
= char_decimal_value (c
);
5838 if (digit_value
>= radix
)
5842 result
= SCM_I_MAKINUM (digit_value
);
5845 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5855 digit_value
= char_decimal_value (c
);
5856 /* This check catches non-decimals in addition to out-of-range
5858 if (digit_value
>= radix
)
5863 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5865 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5867 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5874 shift
= shift
* radix
;
5875 add
= add
* radix
+ digit_value
;
5880 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5882 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5886 *p_exactness
= INEXACT
;
5892 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5893 * covers the parts of the rules that start at a potential point. The value
5894 * of the digits up to the point have been parsed by the caller and are given
5895 * in variable result. The content of *p_exactness indicates, whether a hash
5896 * has already been seen in the digits before the point.
5899 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5902 mem2decimal_from_point (SCM result
, SCM mem
,
5903 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5905 unsigned int idx
= *p_idx
;
5906 enum t_exactness x
= *p_exactness
;
5907 size_t len
= scm_i_string_length (mem
);
5912 if (scm_i_string_ref (mem
, idx
) == '.')
5914 scm_t_bits shift
= 1;
5916 unsigned int digit_value
;
5917 SCM big_shift
= SCM_INUM1
;
5922 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5923 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5928 digit_value
= DIGIT2UINT (c
);
5939 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5941 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5942 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5944 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5952 add
= add
* 10 + digit_value
;
5958 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5959 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5960 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5963 result
= scm_divide (result
, big_shift
);
5965 /* We've seen a decimal point, thus the value is implicitly inexact. */
5977 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5979 switch (scm_i_string_ref (mem
, idx
))
5991 c
= scm_i_string_ref (mem
, idx
);
5999 c
= scm_i_string_ref (mem
, idx
);
6008 c
= scm_i_string_ref (mem
, idx
);
6013 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6017 exponent
= DIGIT2UINT (c
);
6020 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6021 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6024 if (exponent
<= SCM_MAXEXP
)
6025 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6031 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6033 size_t exp_len
= idx
- start
;
6034 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6035 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6036 scm_out_of_range ("string->number", exp_num
);
6039 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6041 result
= scm_product (result
, e
);
6043 result
= scm_divide (result
, e
);
6045 /* We've seen an exponent, thus the value is implicitly inexact. */
6063 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6066 mem2ureal (SCM mem
, unsigned int *p_idx
,
6067 unsigned int radix
, enum t_exactness forced_x
,
6068 int allow_inf_or_nan
)
6070 unsigned int idx
= *p_idx
;
6072 size_t len
= scm_i_string_length (mem
);
6074 /* Start off believing that the number will be exact. This changes
6075 to INEXACT if we see a decimal point or a hash. */
6076 enum t_exactness implicit_x
= EXACT
;
6081 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6082 switch (scm_i_string_ref (mem
, idx
))
6085 switch (scm_i_string_ref (mem
, idx
+ 1))
6088 switch (scm_i_string_ref (mem
, idx
+ 2))
6091 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6092 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6100 switch (scm_i_string_ref (mem
, idx
+ 1))
6103 switch (scm_i_string_ref (mem
, idx
+ 2))
6106 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6108 /* Cobble up the fractional part. We might want to
6109 set the NaN's mantissa from it. */
6111 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6114 #if SCM_ENABLE_DEPRECATED == 1
6115 scm_c_issue_deprecation_warning
6116 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6129 if (scm_i_string_ref (mem
, idx
) == '.')
6133 else if (idx
+ 1 == len
)
6135 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6138 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6139 p_idx
, &implicit_x
);
6145 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6146 if (scm_is_false (uinteger
))
6151 else if (scm_i_string_ref (mem
, idx
) == '/')
6159 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6160 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6163 /* both are int/big here, I assume */
6164 result
= scm_i_make_ratio (uinteger
, divisor
);
6166 else if (radix
== 10)
6168 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6169 if (scm_is_false (result
))
6181 if (SCM_INEXACTP (result
))
6182 return scm_inexact_to_exact (result
);
6186 if (SCM_INEXACTP (result
))
6189 return scm_exact_to_inexact (result
);
6191 if (implicit_x
== INEXACT
)
6193 if (SCM_INEXACTP (result
))
6196 return scm_exact_to_inexact (result
);
6202 /* We should never get here */
6207 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6210 mem2complex (SCM mem
, unsigned int idx
,
6211 unsigned int radix
, enum t_exactness forced_x
)
6216 size_t len
= scm_i_string_length (mem
);
6221 c
= scm_i_string_ref (mem
, idx
);
6236 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6237 if (scm_is_false (ureal
))
6239 /* input must be either +i or -i */
6244 if (scm_i_string_ref (mem
, idx
) == 'i'
6245 || scm_i_string_ref (mem
, idx
) == 'I')
6251 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6258 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6259 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6264 c
= scm_i_string_ref (mem
, idx
);
6268 /* either +<ureal>i or -<ureal>i */
6275 return scm_make_rectangular (SCM_INUM0
, ureal
);
6278 /* polar input: <real>@<real>. */
6289 c
= scm_i_string_ref (mem
, idx
);
6307 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6308 if (scm_is_false (angle
))
6313 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6314 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6316 result
= scm_make_polar (ureal
, angle
);
6321 /* expecting input matching <real>[+-]<ureal>?i */
6328 int sign
= (c
== '+') ? 1 : -1;
6329 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6331 if (scm_is_false (imag
))
6332 imag
= SCM_I_MAKINUM (sign
);
6333 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6334 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6338 if (scm_i_string_ref (mem
, idx
) != 'i'
6339 && scm_i_string_ref (mem
, idx
) != 'I')
6346 return scm_make_rectangular (ureal
, imag
);
6355 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6357 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6360 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6362 unsigned int idx
= 0;
6363 unsigned int radix
= NO_RADIX
;
6364 enum t_exactness forced_x
= NO_EXACTNESS
;
6365 size_t len
= scm_i_string_length (mem
);
6367 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6368 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6370 switch (scm_i_string_ref (mem
, idx
+ 1))
6373 if (radix
!= NO_RADIX
)
6378 if (radix
!= NO_RADIX
)
6383 if (forced_x
!= NO_EXACTNESS
)
6388 if (forced_x
!= NO_EXACTNESS
)
6393 if (radix
!= NO_RADIX
)
6398 if (radix
!= NO_RADIX
)
6408 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6409 if (radix
== NO_RADIX
)
6410 radix
= default_radix
;
6412 return mem2complex (mem
, idx
, radix
, forced_x
);
6416 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6417 unsigned int default_radix
)
6419 SCM str
= scm_from_locale_stringn (mem
, len
);
6421 return scm_i_string_to_number (str
, default_radix
);
6425 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6426 (SCM string
, SCM radix
),
6427 "Return a number of the maximally precise representation\n"
6428 "expressed by the given @var{string}. @var{radix} must be an\n"
6429 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6430 "is a default radix that may be overridden by an explicit radix\n"
6431 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6432 "supplied, then the default radix is 10. If string is not a\n"
6433 "syntactically valid notation for a number, then\n"
6434 "@code{string->number} returns @code{#f}.")
6435 #define FUNC_NAME s_scm_string_to_number
6439 SCM_VALIDATE_STRING (1, string
);
6441 if (SCM_UNBNDP (radix
))
6444 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6446 answer
= scm_i_string_to_number (string
, base
);
6447 scm_remember_upto_here_1 (string
);
6453 /*** END strs->nums ***/
6456 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6458 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6460 #define FUNC_NAME s_scm_number_p
6462 return scm_from_bool (SCM_NUMBERP (x
));
6466 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6468 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6469 "otherwise. Note that the sets of real, rational and integer\n"
6470 "values form subsets of the set of complex numbers, i. e. the\n"
6471 "predicate will also be fulfilled if @var{x} is a real,\n"
6472 "rational or integer number.")
6473 #define FUNC_NAME s_scm_complex_p
6475 /* all numbers are complex. */
6476 return scm_number_p (x
);
6480 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6482 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6483 "otherwise. Note that the set of integer values forms a subset of\n"
6484 "the set of real numbers, i. e. the predicate will also be\n"
6485 "fulfilled if @var{x} is an integer number.")
6486 #define FUNC_NAME s_scm_real_p
6488 return scm_from_bool
6489 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6493 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6495 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6496 "otherwise. Note that the set of integer values forms a subset of\n"
6497 "the set of rational numbers, i. e. the predicate will also be\n"
6498 "fulfilled if @var{x} is an integer number.")
6499 #define FUNC_NAME s_scm_rational_p
6501 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6503 else if (SCM_REALP (x
))
6504 /* due to their limited precision, finite floating point numbers are
6505 rational as well. (finite means neither infinity nor a NaN) */
6506 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6512 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6514 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6516 #define FUNC_NAME s_scm_integer_p
6518 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6520 else if (SCM_REALP (x
))
6522 double val
= SCM_REAL_VALUE (x
);
6523 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6531 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6532 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6533 (SCM x
, SCM y
, SCM rest
),
6534 "Return @code{#t} if all parameters are numerically equal.")
6535 #define FUNC_NAME s_scm_i_num_eq_p
6537 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6539 while (!scm_is_null (rest
))
6541 if (scm_is_false (scm_num_eq_p (x
, y
)))
6545 rest
= scm_cdr (rest
);
6547 return scm_num_eq_p (x
, y
);
6551 scm_num_eq_p (SCM x
, SCM y
)
6554 if (SCM_I_INUMP (x
))
6556 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6557 if (SCM_I_INUMP (y
))
6559 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6560 return scm_from_bool (xx
== yy
);
6562 else if (SCM_BIGP (y
))
6564 else if (SCM_REALP (y
))
6566 /* On a 32-bit system an inum fits a double, we can cast the inum
6567 to a double and compare.
6569 But on a 64-bit system an inum is bigger than a double and
6570 casting it to a double (call that dxx) will round.
6571 Although dxx will not in general be equal to xx, dxx will
6572 always be an integer and within a factor of 2 of xx, so if
6573 dxx==yy, we know that yy is an integer and fits in
6574 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6575 compare with plain xx.
6577 An alternative (for any size system actually) would be to check
6578 yy is an integer (with floor) and is in range of an inum
6579 (compare against appropriate powers of 2) then test
6580 xx==(scm_t_signed_bits)yy. It's just a matter of which
6581 casts/comparisons might be fastest or easiest for the cpu. */
6583 double yy
= SCM_REAL_VALUE (y
);
6584 return scm_from_bool ((double) xx
== yy
6585 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6586 || xx
== (scm_t_signed_bits
) yy
));
6588 else if (SCM_COMPLEXP (y
))
6590 /* see comments with inum/real above */
6591 double ry
= SCM_COMPLEX_REAL (y
);
6592 return scm_from_bool ((double) xx
== ry
6593 && 0.0 == SCM_COMPLEX_IMAG (y
)
6594 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6595 || xx
== (scm_t_signed_bits
) ry
));
6597 else if (SCM_FRACTIONP (y
))
6600 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6603 else if (SCM_BIGP (x
))
6605 if (SCM_I_INUMP (y
))
6607 else if (SCM_BIGP (y
))
6609 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6610 scm_remember_upto_here_2 (x
, y
);
6611 return scm_from_bool (0 == cmp
);
6613 else if (SCM_REALP (y
))
6616 if (isnan (SCM_REAL_VALUE (y
)))
6618 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6619 scm_remember_upto_here_1 (x
);
6620 return scm_from_bool (0 == cmp
);
6622 else if (SCM_COMPLEXP (y
))
6625 if (0.0 != SCM_COMPLEX_IMAG (y
))
6627 if (isnan (SCM_COMPLEX_REAL (y
)))
6629 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6630 scm_remember_upto_here_1 (x
);
6631 return scm_from_bool (0 == cmp
);
6633 else if (SCM_FRACTIONP (y
))
6636 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6639 else if (SCM_REALP (x
))
6641 double xx
= SCM_REAL_VALUE (x
);
6642 if (SCM_I_INUMP (y
))
6644 /* see comments with inum/real above */
6645 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6646 return scm_from_bool (xx
== (double) yy
6647 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6648 || (scm_t_signed_bits
) xx
== yy
));
6650 else if (SCM_BIGP (y
))
6655 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6656 scm_remember_upto_here_1 (y
);
6657 return scm_from_bool (0 == cmp
);
6659 else if (SCM_REALP (y
))
6660 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6661 else if (SCM_COMPLEXP (y
))
6662 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6663 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6664 else if (SCM_FRACTIONP (y
))
6666 if (isnan (xx
) || isinf (xx
))
6668 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6672 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6675 else if (SCM_COMPLEXP (x
))
6677 if (SCM_I_INUMP (y
))
6679 /* see comments with inum/real above */
6680 double rx
= SCM_COMPLEX_REAL (x
);
6681 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6682 return scm_from_bool (rx
== (double) yy
6683 && 0.0 == SCM_COMPLEX_IMAG (x
)
6684 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6685 || (scm_t_signed_bits
) rx
== yy
));
6687 else if (SCM_BIGP (y
))
6690 if (0.0 != SCM_COMPLEX_IMAG (x
))
6692 if (isnan (SCM_COMPLEX_REAL (x
)))
6694 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6695 scm_remember_upto_here_1 (y
);
6696 return scm_from_bool (0 == cmp
);
6698 else if (SCM_REALP (y
))
6699 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6700 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6701 else if (SCM_COMPLEXP (y
))
6702 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6703 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6704 else if (SCM_FRACTIONP (y
))
6707 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6709 xx
= SCM_COMPLEX_REAL (x
);
6710 if (isnan (xx
) || isinf (xx
))
6712 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6716 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6719 else if (SCM_FRACTIONP (x
))
6721 if (SCM_I_INUMP (y
))
6723 else if (SCM_BIGP (y
))
6725 else if (SCM_REALP (y
))
6727 double yy
= SCM_REAL_VALUE (y
);
6728 if (isnan (yy
) || isinf (yy
))
6730 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6733 else if (SCM_COMPLEXP (y
))
6736 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6738 yy
= SCM_COMPLEX_REAL (y
);
6739 if (isnan (yy
) || isinf(yy
))
6741 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6744 else if (SCM_FRACTIONP (y
))
6745 return scm_i_fraction_equalp (x
, y
);
6747 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6751 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6756 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6757 done are good for inums, but for bignums an answer can almost always be
6758 had by just examining a few high bits of the operands, as done by GMP in
6759 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6760 of the float exponent to take into account. */
6762 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6763 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6764 (SCM x
, SCM y
, SCM rest
),
6765 "Return @code{#t} if the list of parameters is monotonically\n"
6767 #define FUNC_NAME s_scm_i_num_less_p
6769 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6771 while (!scm_is_null (rest
))
6773 if (scm_is_false (scm_less_p (x
, y
)))
6777 rest
= scm_cdr (rest
);
6779 return scm_less_p (x
, y
);
6783 scm_less_p (SCM x
, SCM y
)
6786 if (SCM_I_INUMP (x
))
6788 scm_t_inum xx
= SCM_I_INUM (x
);
6789 if (SCM_I_INUMP (y
))
6791 scm_t_inum yy
= SCM_I_INUM (y
);
6792 return scm_from_bool (xx
< yy
);
6794 else if (SCM_BIGP (y
))
6796 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6797 scm_remember_upto_here_1 (y
);
6798 return scm_from_bool (sgn
> 0);
6800 else if (SCM_REALP (y
))
6802 /* We can safely take the ceiling of y without changing the
6803 result of x<y, given that x is an integer. */
6804 double yy
= ceil (SCM_REAL_VALUE (y
));
6806 /* In the following comparisons, it's important that the right
6807 hand side always be a power of 2, so that it can be
6808 losslessly converted to a double even on 64-bit
6810 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6812 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6813 /* The condition above is carefully written to include the
6814 case where yy==NaN. */
6817 /* yy is a finite integer that fits in an inum. */
6818 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6820 else if (SCM_FRACTIONP (y
))
6822 /* "x < a/b" becomes "x*b < a" */
6824 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6825 y
= SCM_FRACTION_NUMERATOR (y
);
6829 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6830 s_scm_i_num_less_p
);
6832 else if (SCM_BIGP (x
))
6834 if (SCM_I_INUMP (y
))
6836 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6837 scm_remember_upto_here_1 (x
);
6838 return scm_from_bool (sgn
< 0);
6840 else if (SCM_BIGP (y
))
6842 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6843 scm_remember_upto_here_2 (x
, y
);
6844 return scm_from_bool (cmp
< 0);
6846 else if (SCM_REALP (y
))
6849 if (isnan (SCM_REAL_VALUE (y
)))
6851 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6852 scm_remember_upto_here_1 (x
);
6853 return scm_from_bool (cmp
< 0);
6855 else if (SCM_FRACTIONP (y
))
6858 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6859 s_scm_i_num_less_p
);
6861 else if (SCM_REALP (x
))
6863 if (SCM_I_INUMP (y
))
6865 /* We can safely take the floor of x without changing the
6866 result of x<y, given that y is an integer. */
6867 double xx
= floor (SCM_REAL_VALUE (x
));
6869 /* In the following comparisons, it's important that the right
6870 hand side always be a power of 2, so that it can be
6871 losslessly converted to a double even on 64-bit
6873 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6875 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6876 /* The condition above is carefully written to include the
6877 case where xx==NaN. */
6880 /* xx is a finite integer that fits in an inum. */
6881 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6883 else if (SCM_BIGP (y
))
6886 if (isnan (SCM_REAL_VALUE (x
)))
6888 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6889 scm_remember_upto_here_1 (y
);
6890 return scm_from_bool (cmp
> 0);
6892 else if (SCM_REALP (y
))
6893 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6894 else if (SCM_FRACTIONP (y
))
6896 double xx
= SCM_REAL_VALUE (x
);
6900 return scm_from_bool (xx
< 0.0);
6901 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6905 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6906 s_scm_i_num_less_p
);
6908 else if (SCM_FRACTIONP (x
))
6910 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6912 /* "a/b < y" becomes "a < y*b" */
6913 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6914 x
= SCM_FRACTION_NUMERATOR (x
);
6917 else if (SCM_REALP (y
))
6919 double yy
= SCM_REAL_VALUE (y
);
6923 return scm_from_bool (0.0 < yy
);
6924 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6927 else if (SCM_FRACTIONP (y
))
6929 /* "a/b < c/d" becomes "a*d < c*b" */
6930 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6931 SCM_FRACTION_DENOMINATOR (y
));
6932 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6933 SCM_FRACTION_DENOMINATOR (x
));
6939 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6940 s_scm_i_num_less_p
);
6943 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6944 s_scm_i_num_less_p
);
6948 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6949 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6950 (SCM x
, SCM y
, SCM rest
),
6951 "Return @code{#t} if the list of parameters is monotonically\n"
6953 #define FUNC_NAME s_scm_i_num_gr_p
6955 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6957 while (!scm_is_null (rest
))
6959 if (scm_is_false (scm_gr_p (x
, y
)))
6963 rest
= scm_cdr (rest
);
6965 return scm_gr_p (x
, y
);
6968 #define FUNC_NAME s_scm_i_num_gr_p
6970 scm_gr_p (SCM x
, SCM y
)
6972 if (!SCM_NUMBERP (x
))
6973 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6974 else if (!SCM_NUMBERP (y
))
6975 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6977 return scm_less_p (y
, x
);
6982 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6983 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6984 (SCM x
, SCM y
, SCM rest
),
6985 "Return @code{#t} if the list of parameters is monotonically\n"
6987 #define FUNC_NAME s_scm_i_num_leq_p
6989 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6991 while (!scm_is_null (rest
))
6993 if (scm_is_false (scm_leq_p (x
, y
)))
6997 rest
= scm_cdr (rest
);
6999 return scm_leq_p (x
, y
);
7002 #define FUNC_NAME s_scm_i_num_leq_p
7004 scm_leq_p (SCM x
, SCM y
)
7006 if (!SCM_NUMBERP (x
))
7007 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7008 else if (!SCM_NUMBERP (y
))
7009 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7010 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7013 return scm_not (scm_less_p (y
, x
));
7018 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7019 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7020 (SCM x
, SCM y
, SCM rest
),
7021 "Return @code{#t} if the list of parameters is monotonically\n"
7023 #define FUNC_NAME s_scm_i_num_geq_p
7025 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7027 while (!scm_is_null (rest
))
7029 if (scm_is_false (scm_geq_p (x
, y
)))
7033 rest
= scm_cdr (rest
);
7035 return scm_geq_p (x
, y
);
7038 #define FUNC_NAME s_scm_i_num_geq_p
7040 scm_geq_p (SCM x
, SCM y
)
7042 if (!SCM_NUMBERP (x
))
7043 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7044 else if (!SCM_NUMBERP (y
))
7045 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7046 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7049 return scm_not (scm_less_p (x
, y
));
7054 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7056 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7058 #define FUNC_NAME s_scm_zero_p
7060 if (SCM_I_INUMP (z
))
7061 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7062 else if (SCM_BIGP (z
))
7064 else if (SCM_REALP (z
))
7065 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7066 else if (SCM_COMPLEXP (z
))
7067 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7068 && SCM_COMPLEX_IMAG (z
) == 0.0);
7069 else if (SCM_FRACTIONP (z
))
7072 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7077 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7079 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7081 #define FUNC_NAME s_scm_positive_p
7083 if (SCM_I_INUMP (x
))
7084 return scm_from_bool (SCM_I_INUM (x
) > 0);
7085 else if (SCM_BIGP (x
))
7087 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7088 scm_remember_upto_here_1 (x
);
7089 return scm_from_bool (sgn
> 0);
7091 else if (SCM_REALP (x
))
7092 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7093 else if (SCM_FRACTIONP (x
))
7094 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7096 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7101 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7103 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7105 #define FUNC_NAME s_scm_negative_p
7107 if (SCM_I_INUMP (x
))
7108 return scm_from_bool (SCM_I_INUM (x
) < 0);
7109 else if (SCM_BIGP (x
))
7111 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7112 scm_remember_upto_here_1 (x
);
7113 return scm_from_bool (sgn
< 0);
7115 else if (SCM_REALP (x
))
7116 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7117 else if (SCM_FRACTIONP (x
))
7118 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7120 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7125 /* scm_min and scm_max return an inexact when either argument is inexact, as
7126 required by r5rs. On that basis, for exact/inexact combinations the
7127 exact is converted to inexact to compare and possibly return. This is
7128 unlike scm_less_p above which takes some trouble to preserve all bits in
7129 its test, such trouble is not required for min and max. */
7131 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7132 (SCM x
, SCM y
, SCM rest
),
7133 "Return the maximum of all parameter values.")
7134 #define FUNC_NAME s_scm_i_max
7136 while (!scm_is_null (rest
))
7137 { x
= scm_max (x
, y
);
7139 rest
= scm_cdr (rest
);
7141 return scm_max (x
, y
);
7145 #define s_max s_scm_i_max
7146 #define g_max g_scm_i_max
7149 scm_max (SCM x
, SCM y
)
7154 return scm_wta_dispatch_0 (g_max
, s_max
);
7155 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7158 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7161 if (SCM_I_INUMP (x
))
7163 scm_t_inum xx
= SCM_I_INUM (x
);
7164 if (SCM_I_INUMP (y
))
7166 scm_t_inum yy
= SCM_I_INUM (y
);
7167 return (xx
< yy
) ? y
: x
;
7169 else if (SCM_BIGP (y
))
7171 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7172 scm_remember_upto_here_1 (y
);
7173 return (sgn
< 0) ? x
: y
;
7175 else if (SCM_REALP (y
))
7178 double yyd
= SCM_REAL_VALUE (y
);
7181 return scm_i_from_double (xxd
);
7182 /* If y is a NaN, then "==" is false and we return the NaN */
7183 else if (SCM_LIKELY (!(xxd
== yyd
)))
7185 /* Handle signed zeroes properly */
7191 else if (SCM_FRACTIONP (y
))
7194 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7197 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7199 else if (SCM_BIGP (x
))
7201 if (SCM_I_INUMP (y
))
7203 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7204 scm_remember_upto_here_1 (x
);
7205 return (sgn
< 0) ? y
: x
;
7207 else if (SCM_BIGP (y
))
7209 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7210 scm_remember_upto_here_2 (x
, y
);
7211 return (cmp
> 0) ? x
: y
;
7213 else if (SCM_REALP (y
))
7215 /* if y==NaN then xx>yy is false, so we return the NaN y */
7218 xx
= scm_i_big2dbl (x
);
7219 yy
= SCM_REAL_VALUE (y
);
7220 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7222 else if (SCM_FRACTIONP (y
))
7227 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7229 else if (SCM_REALP (x
))
7231 if (SCM_I_INUMP (y
))
7233 scm_t_inum yy
= SCM_I_INUM (y
);
7234 double xxd
= SCM_REAL_VALUE (x
);
7238 return scm_i_from_double (yyd
);
7239 /* If x is a NaN, then "==" is false and we return the NaN */
7240 else if (SCM_LIKELY (!(xxd
== yyd
)))
7242 /* Handle signed zeroes properly */
7248 else if (SCM_BIGP (y
))
7253 else if (SCM_REALP (y
))
7255 double xx
= SCM_REAL_VALUE (x
);
7256 double yy
= SCM_REAL_VALUE (y
);
7258 /* For purposes of max: nan > +inf.0 > everything else,
7259 per the R6RS errata */
7262 else if (SCM_LIKELY (xx
< yy
))
7264 /* If neither (xx > yy) nor (xx < yy), then
7265 either they're equal or one is a NaN */
7266 else if (SCM_UNLIKELY (xx
!= yy
))
7267 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7268 /* xx == yy, but handle signed zeroes properly */
7269 else if (copysign (1.0, yy
) < 0.0)
7274 else if (SCM_FRACTIONP (y
))
7276 double yy
= scm_i_fraction2double (y
);
7277 double xx
= SCM_REAL_VALUE (x
);
7278 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7281 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7283 else if (SCM_FRACTIONP (x
))
7285 if (SCM_I_INUMP (y
))
7289 else if (SCM_BIGP (y
))
7293 else if (SCM_REALP (y
))
7295 double xx
= scm_i_fraction2double (x
);
7296 /* if y==NaN then ">" is false, so we return the NaN y */
7297 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7299 else if (SCM_FRACTIONP (y
))
7304 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7307 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7311 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7312 (SCM x
, SCM y
, SCM rest
),
7313 "Return the minimum of all parameter values.")
7314 #define FUNC_NAME s_scm_i_min
7316 while (!scm_is_null (rest
))
7317 { x
= scm_min (x
, y
);
7319 rest
= scm_cdr (rest
);
7321 return scm_min (x
, y
);
7325 #define s_min s_scm_i_min
7326 #define g_min g_scm_i_min
7329 scm_min (SCM x
, SCM y
)
7334 return scm_wta_dispatch_0 (g_min
, s_min
);
7335 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7338 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7341 if (SCM_I_INUMP (x
))
7343 scm_t_inum xx
= SCM_I_INUM (x
);
7344 if (SCM_I_INUMP (y
))
7346 scm_t_inum yy
= SCM_I_INUM (y
);
7347 return (xx
< yy
) ? x
: y
;
7349 else if (SCM_BIGP (y
))
7351 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7352 scm_remember_upto_here_1 (y
);
7353 return (sgn
< 0) ? y
: x
;
7355 else if (SCM_REALP (y
))
7358 /* if y==NaN then "<" is false and we return NaN */
7359 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7361 else if (SCM_FRACTIONP (y
))
7364 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7367 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7369 else if (SCM_BIGP (x
))
7371 if (SCM_I_INUMP (y
))
7373 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7374 scm_remember_upto_here_1 (x
);
7375 return (sgn
< 0) ? x
: y
;
7377 else if (SCM_BIGP (y
))
7379 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7380 scm_remember_upto_here_2 (x
, y
);
7381 return (cmp
> 0) ? y
: x
;
7383 else if (SCM_REALP (y
))
7385 /* if y==NaN then xx<yy is false, so we return the NaN y */
7388 xx
= scm_i_big2dbl (x
);
7389 yy
= SCM_REAL_VALUE (y
);
7390 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7392 else if (SCM_FRACTIONP (y
))
7397 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7399 else if (SCM_REALP (x
))
7401 if (SCM_I_INUMP (y
))
7403 double z
= SCM_I_INUM (y
);
7404 /* if x==NaN then "<" is false and we return NaN */
7405 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7407 else if (SCM_BIGP (y
))
7412 else if (SCM_REALP (y
))
7414 double xx
= SCM_REAL_VALUE (x
);
7415 double yy
= SCM_REAL_VALUE (y
);
7417 /* For purposes of min: nan < -inf.0 < everything else,
7418 per the R6RS errata */
7421 else if (SCM_LIKELY (xx
> yy
))
7423 /* If neither (xx < yy) nor (xx > yy), then
7424 either they're equal or one is a NaN */
7425 else if (SCM_UNLIKELY (xx
!= yy
))
7426 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7427 /* xx == yy, but handle signed zeroes properly */
7428 else if (copysign (1.0, xx
) < 0.0)
7433 else if (SCM_FRACTIONP (y
))
7435 double yy
= scm_i_fraction2double (y
);
7436 double xx
= SCM_REAL_VALUE (x
);
7437 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7440 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7442 else if (SCM_FRACTIONP (x
))
7444 if (SCM_I_INUMP (y
))
7448 else if (SCM_BIGP (y
))
7452 else if (SCM_REALP (y
))
7454 double xx
= scm_i_fraction2double (x
);
7455 /* if y==NaN then "<" is false, so we return the NaN y */
7456 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7458 else if (SCM_FRACTIONP (y
))
7463 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7466 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7470 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7471 (SCM x
, SCM y
, SCM rest
),
7472 "Return the sum of all parameter values. Return 0 if called without\n"
7474 #define FUNC_NAME s_scm_i_sum
7476 while (!scm_is_null (rest
))
7477 { x
= scm_sum (x
, y
);
7479 rest
= scm_cdr (rest
);
7481 return scm_sum (x
, y
);
7485 #define s_sum s_scm_i_sum
7486 #define g_sum g_scm_i_sum
7489 scm_sum (SCM x
, SCM y
)
7491 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7493 if (SCM_NUMBERP (x
)) return x
;
7494 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7495 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7498 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7500 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7502 scm_t_inum xx
= SCM_I_INUM (x
);
7503 scm_t_inum yy
= SCM_I_INUM (y
);
7504 scm_t_inum z
= xx
+ yy
;
7505 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7507 else if (SCM_BIGP (y
))
7512 else if (SCM_REALP (y
))
7514 scm_t_inum xx
= SCM_I_INUM (x
);
7515 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7517 else if (SCM_COMPLEXP (y
))
7519 scm_t_inum xx
= SCM_I_INUM (x
);
7520 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7521 SCM_COMPLEX_IMAG (y
));
7523 else if (SCM_FRACTIONP (y
))
7524 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7525 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7526 SCM_FRACTION_DENOMINATOR (y
));
7528 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7529 } else if (SCM_BIGP (x
))
7531 if (SCM_I_INUMP (y
))
7536 inum
= SCM_I_INUM (y
);
7539 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7542 SCM result
= scm_i_mkbig ();
7543 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7544 scm_remember_upto_here_1 (x
);
7545 /* we know the result will have to be a bignum */
7548 return scm_i_normbig (result
);
7552 SCM result
= scm_i_mkbig ();
7553 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7554 scm_remember_upto_here_1 (x
);
7555 /* we know the result will have to be a bignum */
7558 return scm_i_normbig (result
);
7561 else if (SCM_BIGP (y
))
7563 SCM result
= scm_i_mkbig ();
7564 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7565 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7566 mpz_add (SCM_I_BIG_MPZ (result
),
7569 scm_remember_upto_here_2 (x
, y
);
7570 /* we know the result will have to be a bignum */
7573 return scm_i_normbig (result
);
7575 else if (SCM_REALP (y
))
7577 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7578 scm_remember_upto_here_1 (x
);
7579 return scm_i_from_double (result
);
7581 else if (SCM_COMPLEXP (y
))
7583 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7584 + SCM_COMPLEX_REAL (y
));
7585 scm_remember_upto_here_1 (x
);
7586 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7588 else if (SCM_FRACTIONP (y
))
7589 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7590 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7591 SCM_FRACTION_DENOMINATOR (y
));
7593 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7595 else if (SCM_REALP (x
))
7597 if (SCM_I_INUMP (y
))
7598 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7599 else if (SCM_BIGP (y
))
7601 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7602 scm_remember_upto_here_1 (y
);
7603 return scm_i_from_double (result
);
7605 else if (SCM_REALP (y
))
7606 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7607 else if (SCM_COMPLEXP (y
))
7608 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7609 SCM_COMPLEX_IMAG (y
));
7610 else if (SCM_FRACTIONP (y
))
7611 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7613 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7615 else if (SCM_COMPLEXP (x
))
7617 if (SCM_I_INUMP (y
))
7618 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7619 SCM_COMPLEX_IMAG (x
));
7620 else if (SCM_BIGP (y
))
7622 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7623 + SCM_COMPLEX_REAL (x
));
7624 scm_remember_upto_here_1 (y
);
7625 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7627 else if (SCM_REALP (y
))
7628 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7629 SCM_COMPLEX_IMAG (x
));
7630 else if (SCM_COMPLEXP (y
))
7631 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7632 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7633 else if (SCM_FRACTIONP (y
))
7634 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7635 SCM_COMPLEX_IMAG (x
));
7637 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7639 else if (SCM_FRACTIONP (x
))
7641 if (SCM_I_INUMP (y
))
7642 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7643 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7644 SCM_FRACTION_DENOMINATOR (x
));
7645 else if (SCM_BIGP (y
))
7646 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7647 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7648 SCM_FRACTION_DENOMINATOR (x
));
7649 else if (SCM_REALP (y
))
7650 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7651 else if (SCM_COMPLEXP (y
))
7652 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7653 SCM_COMPLEX_IMAG (y
));
7654 else if (SCM_FRACTIONP (y
))
7655 /* a/b + c/d = (ad + bc) / bd */
7656 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7657 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7658 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7660 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7663 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7667 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7669 "Return @math{@var{x}+1}.")
7670 #define FUNC_NAME s_scm_oneplus
7672 return scm_sum (x
, SCM_INUM1
);
7677 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7678 (SCM x
, SCM y
, SCM rest
),
7679 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7680 "the sum of all but the first argument are subtracted from the first\n"
7682 #define FUNC_NAME s_scm_i_difference
7684 while (!scm_is_null (rest
))
7685 { x
= scm_difference (x
, y
);
7687 rest
= scm_cdr (rest
);
7689 return scm_difference (x
, y
);
7693 #define s_difference s_scm_i_difference
7694 #define g_difference g_scm_i_difference
7697 scm_difference (SCM x
, SCM y
)
7698 #define FUNC_NAME s_difference
7700 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7703 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7705 if (SCM_I_INUMP (x
))
7707 scm_t_inum xx
= -SCM_I_INUM (x
);
7708 if (SCM_FIXABLE (xx
))
7709 return SCM_I_MAKINUM (xx
);
7711 return scm_i_inum2big (xx
);
7713 else if (SCM_BIGP (x
))
7714 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7715 bignum, but negating that gives a fixnum. */
7716 return scm_i_normbig (scm_i_clonebig (x
, 0));
7717 else if (SCM_REALP (x
))
7718 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7719 else if (SCM_COMPLEXP (x
))
7720 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7721 -SCM_COMPLEX_IMAG (x
));
7722 else if (SCM_FRACTIONP (x
))
7723 return scm_i_make_ratio_already_reduced
7724 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7725 SCM_FRACTION_DENOMINATOR (x
));
7727 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7730 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7732 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7734 scm_t_inum xx
= SCM_I_INUM (x
);
7735 scm_t_inum yy
= SCM_I_INUM (y
);
7736 scm_t_inum z
= xx
- yy
;
7737 if (SCM_FIXABLE (z
))
7738 return SCM_I_MAKINUM (z
);
7740 return scm_i_inum2big (z
);
7742 else if (SCM_BIGP (y
))
7744 /* inum-x - big-y */
7745 scm_t_inum xx
= SCM_I_INUM (x
);
7749 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7750 bignum, but negating that gives a fixnum. */
7751 return scm_i_normbig (scm_i_clonebig (y
, 0));
7755 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7756 SCM result
= scm_i_mkbig ();
7759 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7762 /* x - y == -(y + -x) */
7763 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7764 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7766 scm_remember_upto_here_1 (y
);
7768 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7769 /* we know the result will have to be a bignum */
7772 return scm_i_normbig (result
);
7775 else if (SCM_REALP (y
))
7777 scm_t_inum xx
= SCM_I_INUM (x
);
7780 * We need to handle x == exact 0
7781 * specially because R6RS states that:
7782 * (- 0.0) ==> -0.0 and
7783 * (- 0.0 0.0) ==> 0.0
7784 * and the scheme compiler changes
7785 * (- 0.0) into (- 0 0.0)
7786 * So we need to treat (- 0 0.0) like (- 0.0).
7787 * At the C level, (-x) is different than (0.0 - x).
7788 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7791 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7793 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7795 else if (SCM_COMPLEXP (y
))
7797 scm_t_inum xx
= SCM_I_INUM (x
);
7799 /* We need to handle x == exact 0 specially.
7800 See the comment above (for SCM_REALP (y)) */
7802 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7803 - SCM_COMPLEX_IMAG (y
));
7805 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7806 - SCM_COMPLEX_IMAG (y
));
7808 else if (SCM_FRACTIONP (y
))
7809 /* a - b/c = (ac - b) / c */
7810 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7811 SCM_FRACTION_NUMERATOR (y
)),
7812 SCM_FRACTION_DENOMINATOR (y
));
7814 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7816 else if (SCM_BIGP (x
))
7818 if (SCM_I_INUMP (y
))
7820 /* big-x - inum-y */
7821 scm_t_inum yy
= SCM_I_INUM (y
);
7822 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7824 scm_remember_upto_here_1 (x
);
7826 return (SCM_FIXABLE (-yy
) ?
7827 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7830 SCM result
= scm_i_mkbig ();
7833 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7835 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7836 scm_remember_upto_here_1 (x
);
7838 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7839 /* we know the result will have to be a bignum */
7842 return scm_i_normbig (result
);
7845 else if (SCM_BIGP (y
))
7847 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7848 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7849 SCM result
= scm_i_mkbig ();
7850 mpz_sub (SCM_I_BIG_MPZ (result
),
7853 scm_remember_upto_here_2 (x
, y
);
7854 /* we know the result will have to be a bignum */
7855 if ((sgn_x
== 1) && (sgn_y
== -1))
7857 if ((sgn_x
== -1) && (sgn_y
== 1))
7859 return scm_i_normbig (result
);
7861 else if (SCM_REALP (y
))
7863 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7864 scm_remember_upto_here_1 (x
);
7865 return scm_i_from_double (result
);
7867 else if (SCM_COMPLEXP (y
))
7869 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7870 - SCM_COMPLEX_REAL (y
));
7871 scm_remember_upto_here_1 (x
);
7872 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7874 else if (SCM_FRACTIONP (y
))
7875 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7876 SCM_FRACTION_NUMERATOR (y
)),
7877 SCM_FRACTION_DENOMINATOR (y
));
7879 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7881 else if (SCM_REALP (x
))
7883 if (SCM_I_INUMP (y
))
7884 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7885 else if (SCM_BIGP (y
))
7887 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7888 scm_remember_upto_here_1 (x
);
7889 return scm_i_from_double (result
);
7891 else if (SCM_REALP (y
))
7892 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7893 else if (SCM_COMPLEXP (y
))
7894 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7895 -SCM_COMPLEX_IMAG (y
));
7896 else if (SCM_FRACTIONP (y
))
7897 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7899 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7901 else if (SCM_COMPLEXP (x
))
7903 if (SCM_I_INUMP (y
))
7904 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7905 SCM_COMPLEX_IMAG (x
));
7906 else if (SCM_BIGP (y
))
7908 double real_part
= (SCM_COMPLEX_REAL (x
)
7909 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7910 scm_remember_upto_here_1 (x
);
7911 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7913 else if (SCM_REALP (y
))
7914 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7915 SCM_COMPLEX_IMAG (x
));
7916 else if (SCM_COMPLEXP (y
))
7917 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7918 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7919 else if (SCM_FRACTIONP (y
))
7920 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7921 SCM_COMPLEX_IMAG (x
));
7923 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7925 else if (SCM_FRACTIONP (x
))
7927 if (SCM_I_INUMP (y
))
7928 /* a/b - c = (a - cb) / b */
7929 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7930 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7931 SCM_FRACTION_DENOMINATOR (x
));
7932 else if (SCM_BIGP (y
))
7933 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7934 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7935 SCM_FRACTION_DENOMINATOR (x
));
7936 else if (SCM_REALP (y
))
7937 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7938 else if (SCM_COMPLEXP (y
))
7939 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7940 -SCM_COMPLEX_IMAG (y
));
7941 else if (SCM_FRACTIONP (y
))
7942 /* a/b - c/d = (ad - bc) / bd */
7943 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7944 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7945 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7947 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7950 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7955 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7957 "Return @math{@var{x}-1}.")
7958 #define FUNC_NAME s_scm_oneminus
7960 return scm_difference (x
, SCM_INUM1
);
7965 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7966 (SCM x
, SCM y
, SCM rest
),
7967 "Return the product of all arguments. If called without arguments,\n"
7969 #define FUNC_NAME s_scm_i_product
7971 while (!scm_is_null (rest
))
7972 { x
= scm_product (x
, y
);
7974 rest
= scm_cdr (rest
);
7976 return scm_product (x
, y
);
7980 #define s_product s_scm_i_product
7981 #define g_product g_scm_i_product
7984 scm_product (SCM x
, SCM y
)
7986 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7989 return SCM_I_MAKINUM (1L);
7990 else if (SCM_NUMBERP (x
))
7993 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7996 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8001 xx
= SCM_I_INUM (x
);
8006 /* exact1 is the universal multiplicative identity */
8010 /* exact0 times a fixnum is exact0: optimize this case */
8011 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8013 /* if the other argument is inexact, the result is inexact,
8014 and we must do the multiplication in order to handle
8015 infinities and NaNs properly. */
8016 else if (SCM_REALP (y
))
8017 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8018 else if (SCM_COMPLEXP (y
))
8019 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8020 0.0 * SCM_COMPLEX_IMAG (y
));
8021 /* we've already handled inexact numbers,
8022 so y must be exact, and we return exact0 */
8023 else if (SCM_NUMP (y
))
8026 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8030 * This case is important for more than just optimization.
8031 * It handles the case of negating
8032 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8033 * which is a bignum that must be changed back into a fixnum.
8034 * Failure to do so will cause the following to return #f:
8035 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8037 return scm_difference(y
, SCM_UNDEFINED
);
8041 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8043 scm_t_inum yy
= SCM_I_INUM (y
);
8044 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8045 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8046 if (SCM_FIXABLE (kk
))
8047 return SCM_I_MAKINUM (kk
);
8049 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8050 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8051 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8052 return SCM_I_MAKINUM (xx
* yy
);
8056 SCM result
= scm_i_inum2big (xx
);
8057 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8058 return scm_i_normbig (result
);
8061 else if (SCM_BIGP (y
))
8063 SCM result
= scm_i_mkbig ();
8064 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8065 scm_remember_upto_here_1 (y
);
8068 else if (SCM_REALP (y
))
8069 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8070 else if (SCM_COMPLEXP (y
))
8071 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8072 xx
* SCM_COMPLEX_IMAG (y
));
8073 else if (SCM_FRACTIONP (y
))
8074 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8075 SCM_FRACTION_DENOMINATOR (y
));
8077 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8079 else if (SCM_BIGP (x
))
8081 if (SCM_I_INUMP (y
))
8086 else if (SCM_BIGP (y
))
8088 SCM result
= scm_i_mkbig ();
8089 mpz_mul (SCM_I_BIG_MPZ (result
),
8092 scm_remember_upto_here_2 (x
, y
);
8095 else if (SCM_REALP (y
))
8097 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8098 scm_remember_upto_here_1 (x
);
8099 return scm_i_from_double (result
);
8101 else if (SCM_COMPLEXP (y
))
8103 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8104 scm_remember_upto_here_1 (x
);
8105 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8106 z
* SCM_COMPLEX_IMAG (y
));
8108 else if (SCM_FRACTIONP (y
))
8109 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8110 SCM_FRACTION_DENOMINATOR (y
));
8112 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8114 else if (SCM_REALP (x
))
8116 if (SCM_I_INUMP (y
))
8121 else if (SCM_BIGP (y
))
8123 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8124 scm_remember_upto_here_1 (y
);
8125 return scm_i_from_double (result
);
8127 else if (SCM_REALP (y
))
8128 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8129 else if (SCM_COMPLEXP (y
))
8130 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8131 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8132 else if (SCM_FRACTIONP (y
))
8133 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8135 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8137 else if (SCM_COMPLEXP (x
))
8139 if (SCM_I_INUMP (y
))
8144 else if (SCM_BIGP (y
))
8146 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8147 scm_remember_upto_here_1 (y
);
8148 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8149 z
* SCM_COMPLEX_IMAG (x
));
8151 else if (SCM_REALP (y
))
8152 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8153 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8154 else if (SCM_COMPLEXP (y
))
8156 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8157 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8158 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8159 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8161 else if (SCM_FRACTIONP (y
))
8163 double yy
= scm_i_fraction2double (y
);
8164 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8165 yy
* SCM_COMPLEX_IMAG (x
));
8168 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8170 else if (SCM_FRACTIONP (x
))
8172 if (SCM_I_INUMP (y
))
8173 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8174 SCM_FRACTION_DENOMINATOR (x
));
8175 else if (SCM_BIGP (y
))
8176 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8177 SCM_FRACTION_DENOMINATOR (x
));
8178 else if (SCM_REALP (y
))
8179 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8180 else if (SCM_COMPLEXP (y
))
8182 double xx
= scm_i_fraction2double (x
);
8183 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8184 xx
* SCM_COMPLEX_IMAG (y
));
8186 else if (SCM_FRACTIONP (y
))
8187 /* a/b * c/d = ac / bd */
8188 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8189 SCM_FRACTION_NUMERATOR (y
)),
8190 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8191 SCM_FRACTION_DENOMINATOR (y
)));
8193 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8196 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8199 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8200 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8201 #define ALLOW_DIVIDE_BY_ZERO
8202 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8205 /* The code below for complex division is adapted from the GNU
8206 libstdc++, which adapted it from f2c's libF77, and is subject to
8209 /****************************************************************
8210 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8212 Permission to use, copy, modify, and distribute this software
8213 and its documentation for any purpose and without fee is hereby
8214 granted, provided that the above copyright notice appear in all
8215 copies and that both that the copyright notice and this
8216 permission notice and warranty disclaimer appear in supporting
8217 documentation, and that the names of AT&T Bell Laboratories or
8218 Bellcore or any of their entities not be used in advertising or
8219 publicity pertaining to distribution of the software without
8220 specific, written prior permission.
8222 AT&T and Bellcore disclaim all warranties with regard to this
8223 software, including all implied warranties of merchantability
8224 and fitness. In no event shall AT&T or Bellcore be liable for
8225 any special, indirect or consequential damages or any damages
8226 whatsoever resulting from loss of use, data or profits, whether
8227 in an action of contract, negligence or other tortious action,
8228 arising out of or in connection with the use or performance of
8230 ****************************************************************/
8232 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8233 (SCM x
, SCM y
, SCM rest
),
8234 "Divide the first argument by the product of the remaining\n"
8235 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8237 #define FUNC_NAME s_scm_i_divide
8239 while (!scm_is_null (rest
))
8240 { x
= scm_divide (x
, y
);
8242 rest
= scm_cdr (rest
);
8244 return scm_divide (x
, y
);
8248 #define s_divide s_scm_i_divide
8249 #define g_divide g_scm_i_divide
8252 scm_divide (SCM x
, SCM y
)
8253 #define FUNC_NAME s_divide
8257 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8260 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8261 else if (SCM_I_INUMP (x
))
8263 scm_t_inum xx
= SCM_I_INUM (x
);
8264 if (xx
== 1 || xx
== -1)
8266 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8268 scm_num_overflow (s_divide
);
8271 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8273 else if (SCM_BIGP (x
))
8274 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8275 else if (SCM_REALP (x
))
8277 double xx
= SCM_REAL_VALUE (x
);
8278 #ifndef ALLOW_DIVIDE_BY_ZERO
8280 scm_num_overflow (s_divide
);
8283 return scm_i_from_double (1.0 / xx
);
8285 else if (SCM_COMPLEXP (x
))
8287 double r
= SCM_COMPLEX_REAL (x
);
8288 double i
= SCM_COMPLEX_IMAG (x
);
8289 if (fabs(r
) <= fabs(i
))
8292 double d
= i
* (1.0 + t
* t
);
8293 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8298 double d
= r
* (1.0 + t
* t
);
8299 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8302 else if (SCM_FRACTIONP (x
))
8303 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8304 SCM_FRACTION_NUMERATOR (x
));
8306 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8309 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8311 scm_t_inum xx
= SCM_I_INUM (x
);
8312 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8314 scm_t_inum yy
= SCM_I_INUM (y
);
8317 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8318 scm_num_overflow (s_divide
);
8320 return scm_i_from_double ((double) xx
/ (double) yy
);
8323 else if (xx
% yy
!= 0)
8324 return scm_i_make_ratio (x
, y
);
8327 scm_t_inum z
= xx
/ yy
;
8328 if (SCM_FIXABLE (z
))
8329 return SCM_I_MAKINUM (z
);
8331 return scm_i_inum2big (z
);
8334 else if (SCM_BIGP (y
))
8335 return scm_i_make_ratio (x
, y
);
8336 else if (SCM_REALP (y
))
8338 double yy
= SCM_REAL_VALUE (y
);
8339 #ifndef ALLOW_DIVIDE_BY_ZERO
8341 scm_num_overflow (s_divide
);
8344 /* FIXME: Precision may be lost here due to:
8345 (1) The cast from 'scm_t_inum' to 'double'
8346 (2) Double rounding */
8347 return scm_i_from_double ((double) xx
/ yy
);
8349 else if (SCM_COMPLEXP (y
))
8352 complex_div
: /* y _must_ be a complex number */
8354 double r
= SCM_COMPLEX_REAL (y
);
8355 double i
= SCM_COMPLEX_IMAG (y
);
8356 if (fabs(r
) <= fabs(i
))
8359 double d
= i
* (1.0 + t
* t
);
8360 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8365 double d
= r
* (1.0 + t
* t
);
8366 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8370 else if (SCM_FRACTIONP (y
))
8371 /* a / b/c = ac / b */
8372 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8373 SCM_FRACTION_NUMERATOR (y
));
8375 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8377 else if (SCM_BIGP (x
))
8379 if (SCM_I_INUMP (y
))
8381 scm_t_inum yy
= SCM_I_INUM (y
);
8384 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8385 scm_num_overflow (s_divide
);
8387 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8388 scm_remember_upto_here_1 (x
);
8389 return (sgn
== 0) ? scm_nan () : scm_inf ();
8396 /* FIXME: HMM, what are the relative performance issues here?
8397 We need to test. Is it faster on average to test
8398 divisible_p, then perform whichever operation, or is it
8399 faster to perform the integer div opportunistically and
8400 switch to real if there's a remainder? For now we take the
8401 middle ground: test, then if divisible, use the faster div
8404 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8405 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8409 SCM result
= scm_i_mkbig ();
8410 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8411 scm_remember_upto_here_1 (x
);
8413 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8414 return scm_i_normbig (result
);
8417 return scm_i_make_ratio (x
, y
);
8420 else if (SCM_BIGP (y
))
8422 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8426 SCM result
= scm_i_mkbig ();
8427 mpz_divexact (SCM_I_BIG_MPZ (result
),
8430 scm_remember_upto_here_2 (x
, y
);
8431 return scm_i_normbig (result
);
8434 return scm_i_make_ratio (x
, y
);
8436 else if (SCM_REALP (y
))
8438 double yy
= SCM_REAL_VALUE (y
);
8439 #ifndef ALLOW_DIVIDE_BY_ZERO
8441 scm_num_overflow (s_divide
);
8444 /* FIXME: Precision may be lost here due to:
8445 (1) scm_i_big2dbl (2) Double rounding */
8446 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8448 else if (SCM_COMPLEXP (y
))
8450 a
= scm_i_big2dbl (x
);
8453 else if (SCM_FRACTIONP (y
))
8454 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8455 SCM_FRACTION_NUMERATOR (y
));
8457 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8459 else if (SCM_REALP (x
))
8461 double rx
= SCM_REAL_VALUE (x
);
8462 if (SCM_I_INUMP (y
))
8464 scm_t_inum yy
= SCM_I_INUM (y
);
8465 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8467 scm_num_overflow (s_divide
);
8470 /* FIXME: Precision may be lost here due to:
8471 (1) The cast from 'scm_t_inum' to 'double'
8472 (2) Double rounding */
8473 return scm_i_from_double (rx
/ (double) yy
);
8475 else if (SCM_BIGP (y
))
8477 /* FIXME: Precision may be lost here due to:
8478 (1) The conversion from bignum to double
8479 (2) Double rounding */
8480 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8481 scm_remember_upto_here_1 (y
);
8482 return scm_i_from_double (rx
/ dby
);
8484 else if (SCM_REALP (y
))
8486 double yy
= SCM_REAL_VALUE (y
);
8487 #ifndef ALLOW_DIVIDE_BY_ZERO
8489 scm_num_overflow (s_divide
);
8492 return scm_i_from_double (rx
/ yy
);
8494 else if (SCM_COMPLEXP (y
))
8499 else if (SCM_FRACTIONP (y
))
8500 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8502 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8504 else if (SCM_COMPLEXP (x
))
8506 double rx
= SCM_COMPLEX_REAL (x
);
8507 double ix
= SCM_COMPLEX_IMAG (x
);
8508 if (SCM_I_INUMP (y
))
8510 scm_t_inum yy
= SCM_I_INUM (y
);
8511 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8513 scm_num_overflow (s_divide
);
8517 /* FIXME: Precision may be lost here due to:
8518 (1) The conversion from 'scm_t_inum' to double
8519 (2) Double rounding */
8521 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8524 else if (SCM_BIGP (y
))
8526 /* FIXME: Precision may be lost here due to:
8527 (1) The conversion from bignum to double
8528 (2) Double rounding */
8529 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8530 scm_remember_upto_here_1 (y
);
8531 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8533 else if (SCM_REALP (y
))
8535 double yy
= SCM_REAL_VALUE (y
);
8536 #ifndef ALLOW_DIVIDE_BY_ZERO
8538 scm_num_overflow (s_divide
);
8541 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8543 else if (SCM_COMPLEXP (y
))
8545 double ry
= SCM_COMPLEX_REAL (y
);
8546 double iy
= SCM_COMPLEX_IMAG (y
);
8547 if (fabs(ry
) <= fabs(iy
))
8550 double d
= iy
* (1.0 + t
* t
);
8551 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8556 double d
= ry
* (1.0 + t
* t
);
8557 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8560 else if (SCM_FRACTIONP (y
))
8562 /* FIXME: Precision may be lost here due to:
8563 (1) The conversion from fraction to double
8564 (2) Double rounding */
8565 double yy
= scm_i_fraction2double (y
);
8566 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8569 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8571 else if (SCM_FRACTIONP (x
))
8573 if (SCM_I_INUMP (y
))
8575 scm_t_inum yy
= SCM_I_INUM (y
);
8576 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8578 scm_num_overflow (s_divide
);
8581 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8582 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8584 else if (SCM_BIGP (y
))
8586 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8587 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8589 else if (SCM_REALP (y
))
8591 double yy
= SCM_REAL_VALUE (y
);
8592 #ifndef ALLOW_DIVIDE_BY_ZERO
8594 scm_num_overflow (s_divide
);
8597 /* FIXME: Precision may be lost here due to:
8598 (1) The conversion from fraction to double
8599 (2) Double rounding */
8600 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8602 else if (SCM_COMPLEXP (y
))
8604 /* FIXME: Precision may be lost here due to:
8605 (1) The conversion from fraction to double
8606 (2) Double rounding */
8607 a
= scm_i_fraction2double (x
);
8610 else if (SCM_FRACTIONP (y
))
8611 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8612 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8614 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8617 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8623 scm_c_truncate (double x
)
8628 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8629 half-way case (ie. when x is an integer plus 0.5) going upwards.
8630 Then half-way cases are identified and adjusted down if the
8631 round-upwards didn't give the desired even integer.
8633 "plus_half == result" identifies a half-way case. If plus_half, which is
8634 x + 0.5, is an integer then x must be an integer plus 0.5.
8636 An odd "result" value is identified with result/2 != floor(result/2).
8637 This is done with plus_half, since that value is ready for use sooner in
8638 a pipelined cpu, and we're already requiring plus_half == result.
8640 Note however that we need to be careful when x is big and already an
8641 integer. In that case "x+0.5" may round to an adjacent integer, causing
8642 us to return such a value, incorrectly. For instance if the hardware is
8643 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8644 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8645 returned. Or if the hardware is in round-upwards mode, then other bigger
8646 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8647 representable value, 2^128+2^76 (or whatever), again incorrect.
8649 These bad roundings of x+0.5 are avoided by testing at the start whether
8650 x is already an integer. If it is then clearly that's the desired result
8651 already. And if it's not then the exponent must be small enough to allow
8652 an 0.5 to be represented, and hence added without a bad rounding. */
8655 scm_c_round (double x
)
8657 double plus_half
, result
;
8662 plus_half
= x
+ 0.5;
8663 result
= floor (plus_half
);
8664 /* Adjust so that the rounding is towards even. */
8665 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8670 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8672 "Round the number @var{x} towards zero.")
8673 #define FUNC_NAME s_scm_truncate_number
8675 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8677 else if (SCM_REALP (x
))
8678 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8679 else if (SCM_FRACTIONP (x
))
8680 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8681 SCM_FRACTION_DENOMINATOR (x
));
8683 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8684 s_scm_truncate_number
);
8688 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8690 "Round the number @var{x} towards the nearest integer. "
8691 "When it is exactly halfway between two integers, "
8692 "round towards the even one.")
8693 #define FUNC_NAME s_scm_round_number
8695 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8697 else if (SCM_REALP (x
))
8698 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8699 else if (SCM_FRACTIONP (x
))
8700 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8701 SCM_FRACTION_DENOMINATOR (x
));
8703 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8704 s_scm_round_number
);
8708 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8710 "Round the number @var{x} towards minus infinity.")
8711 #define FUNC_NAME s_scm_floor
8713 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8715 else if (SCM_REALP (x
))
8716 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8717 else if (SCM_FRACTIONP (x
))
8718 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8719 SCM_FRACTION_DENOMINATOR (x
));
8721 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8725 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8727 "Round the number @var{x} towards infinity.")
8728 #define FUNC_NAME s_scm_ceiling
8730 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8732 else if (SCM_REALP (x
))
8733 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8734 else if (SCM_FRACTIONP (x
))
8735 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8736 SCM_FRACTION_DENOMINATOR (x
));
8738 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8742 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8744 "Return @var{x} raised to the power of @var{y}.")
8745 #define FUNC_NAME s_scm_expt
8747 if (scm_is_integer (y
))
8749 if (scm_is_true (scm_exact_p (y
)))
8750 return scm_integer_expt (x
, y
);
8753 /* Here we handle the case where the exponent is an inexact
8754 integer. We make the exponent exact in order to use
8755 scm_integer_expt, and thus avoid the spurious imaginary
8756 parts that may result from round-off errors in the general
8757 e^(y log x) method below (for example when squaring a large
8758 negative number). In this case, we must return an inexact
8759 result for correctness. We also make the base inexact so
8760 that scm_integer_expt will use fast inexact arithmetic
8761 internally. Note that making the base inexact is not
8762 sufficient to guarantee an inexact result, because
8763 scm_integer_expt will return an exact 1 when the exponent
8764 is 0, even if the base is inexact. */
8765 return scm_exact_to_inexact
8766 (scm_integer_expt (scm_exact_to_inexact (x
),
8767 scm_inexact_to_exact (y
)));
8770 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8772 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8774 else if (scm_is_complex (x
) && scm_is_complex (y
))
8775 return scm_exp (scm_product (scm_log (x
), y
));
8776 else if (scm_is_complex (x
))
8777 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8779 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8783 /* sin/cos/tan/asin/acos/atan
8784 sinh/cosh/tanh/asinh/acosh/atanh
8785 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8786 Written by Jerry D. Hedden, (C) FSF.
8787 See the file `COPYING' for terms applying to this program. */
8789 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8791 "Compute the sine of @var{z}.")
8792 #define FUNC_NAME s_scm_sin
8794 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8795 return z
; /* sin(exact0) = exact0 */
8796 else if (scm_is_real (z
))
8797 return scm_i_from_double (sin (scm_to_double (z
)));
8798 else if (SCM_COMPLEXP (z
))
8800 x
= SCM_COMPLEX_REAL (z
);
8801 y
= SCM_COMPLEX_IMAG (z
);
8802 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8803 cos (x
) * sinh (y
));
8806 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8810 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8812 "Compute the cosine of @var{z}.")
8813 #define FUNC_NAME s_scm_cos
8815 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8816 return SCM_INUM1
; /* cos(exact0) = exact1 */
8817 else if (scm_is_real (z
))
8818 return scm_i_from_double (cos (scm_to_double (z
)));
8819 else if (SCM_COMPLEXP (z
))
8821 x
= SCM_COMPLEX_REAL (z
);
8822 y
= SCM_COMPLEX_IMAG (z
);
8823 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8824 -sin (x
) * sinh (y
));
8827 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8831 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8833 "Compute the tangent of @var{z}.")
8834 #define FUNC_NAME s_scm_tan
8836 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8837 return z
; /* tan(exact0) = exact0 */
8838 else if (scm_is_real (z
))
8839 return scm_i_from_double (tan (scm_to_double (z
)));
8840 else if (SCM_COMPLEXP (z
))
8842 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8843 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8844 w
= cos (x
) + cosh (y
);
8845 #ifndef ALLOW_DIVIDE_BY_ZERO
8847 scm_num_overflow (s_scm_tan
);
8849 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8852 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8856 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8858 "Compute the hyperbolic sine of @var{z}.")
8859 #define FUNC_NAME s_scm_sinh
8861 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8862 return z
; /* sinh(exact0) = exact0 */
8863 else if (scm_is_real (z
))
8864 return scm_i_from_double (sinh (scm_to_double (z
)));
8865 else if (SCM_COMPLEXP (z
))
8867 x
= SCM_COMPLEX_REAL (z
);
8868 y
= SCM_COMPLEX_IMAG (z
);
8869 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8870 cosh (x
) * sin (y
));
8873 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8877 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8879 "Compute the hyperbolic cosine of @var{z}.")
8880 #define FUNC_NAME s_scm_cosh
8882 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8883 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8884 else if (scm_is_real (z
))
8885 return scm_i_from_double (cosh (scm_to_double (z
)));
8886 else if (SCM_COMPLEXP (z
))
8888 x
= SCM_COMPLEX_REAL (z
);
8889 y
= SCM_COMPLEX_IMAG (z
);
8890 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8891 sinh (x
) * sin (y
));
8894 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8898 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8900 "Compute the hyperbolic tangent of @var{z}.")
8901 #define FUNC_NAME s_scm_tanh
8903 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8904 return z
; /* tanh(exact0) = exact0 */
8905 else if (scm_is_real (z
))
8906 return scm_i_from_double (tanh (scm_to_double (z
)));
8907 else if (SCM_COMPLEXP (z
))
8909 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8910 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8911 w
= cosh (x
) + cos (y
);
8912 #ifndef ALLOW_DIVIDE_BY_ZERO
8914 scm_num_overflow (s_scm_tanh
);
8916 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8919 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8923 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8925 "Compute the arc sine of @var{z}.")
8926 #define FUNC_NAME s_scm_asin
8928 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8929 return z
; /* asin(exact0) = exact0 */
8930 else if (scm_is_real (z
))
8932 double w
= scm_to_double (z
);
8933 if (w
>= -1.0 && w
<= 1.0)
8934 return scm_i_from_double (asin (w
));
8936 return scm_product (scm_c_make_rectangular (0, -1),
8937 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8939 else if (SCM_COMPLEXP (z
))
8941 x
= SCM_COMPLEX_REAL (z
);
8942 y
= SCM_COMPLEX_IMAG (z
);
8943 return scm_product (scm_c_make_rectangular (0, -1),
8944 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8947 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8951 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8953 "Compute the arc cosine of @var{z}.")
8954 #define FUNC_NAME s_scm_acos
8956 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8957 return SCM_INUM0
; /* acos(exact1) = exact0 */
8958 else if (scm_is_real (z
))
8960 double w
= scm_to_double (z
);
8961 if (w
>= -1.0 && w
<= 1.0)
8962 return scm_i_from_double (acos (w
));
8964 return scm_sum (scm_i_from_double (acos (0.0)),
8965 scm_product (scm_c_make_rectangular (0, 1),
8966 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8968 else if (SCM_COMPLEXP (z
))
8970 x
= SCM_COMPLEX_REAL (z
);
8971 y
= SCM_COMPLEX_IMAG (z
);
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 (-y
, x
))));
8977 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8981 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8983 "With one argument, compute the arc tangent of @var{z}.\n"
8984 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8985 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8986 #define FUNC_NAME s_scm_atan
8990 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8991 return z
; /* atan(exact0) = exact0 */
8992 else if (scm_is_real (z
))
8993 return scm_i_from_double (atan (scm_to_double (z
)));
8994 else if (SCM_COMPLEXP (z
))
8997 v
= SCM_COMPLEX_REAL (z
);
8998 w
= SCM_COMPLEX_IMAG (z
);
8999 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
9000 scm_c_make_rectangular (v
, w
+ 1.0))),
9001 scm_c_make_rectangular (0, 2));
9004 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
9006 else if (scm_is_real (z
))
9008 if (scm_is_real (y
))
9009 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9011 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9014 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9018 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9020 "Compute the inverse hyperbolic sine of @var{z}.")
9021 #define FUNC_NAME s_scm_sys_asinh
9023 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9024 return z
; /* asinh(exact0) = exact0 */
9025 else if (scm_is_real (z
))
9026 return scm_i_from_double (asinh (scm_to_double (z
)));
9027 else if (scm_is_number (z
))
9028 return scm_log (scm_sum (z
,
9029 scm_sqrt (scm_sum (scm_product (z
, z
),
9032 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9036 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9038 "Compute the inverse hyperbolic cosine of @var{z}.")
9039 #define FUNC_NAME s_scm_sys_acosh
9041 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9042 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9043 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9044 return scm_i_from_double (acosh (scm_to_double (z
)));
9045 else if (scm_is_number (z
))
9046 return scm_log (scm_sum (z
,
9047 scm_sqrt (scm_difference (scm_product (z
, z
),
9050 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9054 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9056 "Compute the inverse hyperbolic tangent of @var{z}.")
9057 #define FUNC_NAME s_scm_sys_atanh
9059 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9060 return z
; /* atanh(exact0) = exact0 */
9061 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9062 return scm_i_from_double (atanh (scm_to_double (z
)));
9063 else if (scm_is_number (z
))
9064 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9065 scm_difference (SCM_INUM1
, z
))),
9068 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9073 scm_c_make_rectangular (double re
, double im
)
9077 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9079 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9080 SCM_COMPLEX_REAL (z
) = re
;
9081 SCM_COMPLEX_IMAG (z
) = im
;
9085 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9086 (SCM real_part
, SCM imaginary_part
),
9087 "Return a complex number constructed of the given @var{real_part} "
9088 "and @var{imaginary_part} parts.")
9089 #define FUNC_NAME s_scm_make_rectangular
9091 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9092 SCM_ARG1
, FUNC_NAME
, "real");
9093 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9094 SCM_ARG2
, FUNC_NAME
, "real");
9096 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9097 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9100 return scm_c_make_rectangular (scm_to_double (real_part
),
9101 scm_to_double (imaginary_part
));
9106 scm_c_make_polar (double mag
, double ang
)
9110 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9111 use it on Glibc-based systems that have it (it's a GNU extension). See
9112 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9114 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9115 sincos (ang
, &s
, &c
);
9121 /* If s and c are NaNs, this indicates that the angle is a NaN,
9122 infinite, or perhaps simply too large to determine its value
9123 mod 2*pi. However, we know something that the floating-point
9124 implementation doesn't know: We know that s and c are finite.
9125 Therefore, if the magnitude is zero, return a complex zero.
9127 The reason we check for the NaNs instead of using this case
9128 whenever mag == 0.0 is because when the angle is known, we'd
9129 like to return the correct kind of non-real complex zero:
9130 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9131 on which quadrant the angle is in.
9133 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9134 return scm_c_make_rectangular (0.0, 0.0);
9136 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9139 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9141 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9142 #define FUNC_NAME s_scm_make_polar
9144 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9145 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9147 /* If mag is exact0, return exact0 */
9148 if (scm_is_eq (mag
, SCM_INUM0
))
9150 /* Return a real if ang is exact0 */
9151 else if (scm_is_eq (ang
, SCM_INUM0
))
9154 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9159 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9161 "Return the real part of the number @var{z}.")
9162 #define FUNC_NAME s_scm_real_part
9164 if (SCM_COMPLEXP (z
))
9165 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9166 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9169 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9174 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9176 "Return the imaginary part of the number @var{z}.")
9177 #define FUNC_NAME s_scm_imag_part
9179 if (SCM_COMPLEXP (z
))
9180 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9181 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9184 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9188 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9190 "Return the numerator of the number @var{z}.")
9191 #define FUNC_NAME s_scm_numerator
9193 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9195 else if (SCM_FRACTIONP (z
))
9196 return SCM_FRACTION_NUMERATOR (z
);
9197 else if (SCM_REALP (z
))
9199 double zz
= SCM_REAL_VALUE (z
);
9200 if (zz
== floor (zz
))
9201 /* Handle -0.0 and infinities in accordance with R6RS
9202 flnumerator, and optimize handling of integers. */
9205 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9208 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9213 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9215 "Return the denominator of the number @var{z}.")
9216 #define FUNC_NAME s_scm_denominator
9218 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9220 else if (SCM_FRACTIONP (z
))
9221 return SCM_FRACTION_DENOMINATOR (z
);
9222 else if (SCM_REALP (z
))
9224 double zz
= SCM_REAL_VALUE (z
);
9225 if (zz
== floor (zz
))
9226 /* Handle infinities in accordance with R6RS fldenominator, and
9227 optimize handling of integers. */
9228 return scm_i_from_double (1.0);
9230 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9233 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9239 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9241 "Return the magnitude of the number @var{z}. This is the same as\n"
9242 "@code{abs} for real arguments, but also allows complex numbers.")
9243 #define FUNC_NAME s_scm_magnitude
9245 if (SCM_I_INUMP (z
))
9247 scm_t_inum zz
= SCM_I_INUM (z
);
9250 else if (SCM_POSFIXABLE (-zz
))
9251 return SCM_I_MAKINUM (-zz
);
9253 return scm_i_inum2big (-zz
);
9255 else if (SCM_BIGP (z
))
9257 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9258 scm_remember_upto_here_1 (z
);
9260 return scm_i_clonebig (z
, 0);
9264 else if (SCM_REALP (z
))
9265 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9266 else if (SCM_COMPLEXP (z
))
9267 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9268 else if (SCM_FRACTIONP (z
))
9270 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9272 return scm_i_make_ratio_already_reduced
9273 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9274 SCM_FRACTION_DENOMINATOR (z
));
9277 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9283 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9285 "Return the angle of the complex number @var{z}.")
9286 #define FUNC_NAME s_scm_angle
9288 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9289 flo0 to save allocating a new flonum with scm_i_from_double each time.
9290 But if atan2 follows the floating point rounding mode, then the value
9291 is not a constant. Maybe it'd be close enough though. */
9292 if (SCM_I_INUMP (z
))
9294 if (SCM_I_INUM (z
) >= 0)
9297 return scm_i_from_double (atan2 (0.0, -1.0));
9299 else if (SCM_BIGP (z
))
9301 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9302 scm_remember_upto_here_1 (z
);
9304 return scm_i_from_double (atan2 (0.0, -1.0));
9308 else if (SCM_REALP (z
))
9310 double x
= SCM_REAL_VALUE (z
);
9311 if (copysign (1.0, x
) > 0.0)
9314 return scm_i_from_double (atan2 (0.0, -1.0));
9316 else if (SCM_COMPLEXP (z
))
9317 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9318 else if (SCM_FRACTIONP (z
))
9320 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9322 else return scm_i_from_double (atan2 (0.0, -1.0));
9325 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9330 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9332 "Convert the number @var{z} to its inexact representation.\n")
9333 #define FUNC_NAME s_scm_exact_to_inexact
9335 if (SCM_I_INUMP (z
))
9336 return scm_i_from_double ((double) SCM_I_INUM (z
));
9337 else if (SCM_BIGP (z
))
9338 return scm_i_from_double (scm_i_big2dbl (z
));
9339 else if (SCM_FRACTIONP (z
))
9340 return scm_i_from_double (scm_i_fraction2double (z
));
9341 else if (SCM_INEXACTP (z
))
9344 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9345 s_scm_exact_to_inexact
);
9350 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9352 "Return an exact number that is numerically closest to @var{z}.")
9353 #define FUNC_NAME s_scm_inexact_to_exact
9355 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9362 val
= SCM_REAL_VALUE (z
);
9363 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9364 val
= SCM_COMPLEX_REAL (z
);
9366 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9367 s_scm_inexact_to_exact
);
9369 if (!SCM_LIKELY (isfinite (val
)))
9370 SCM_OUT_OF_RANGE (1, z
);
9371 else if (val
== 0.0)
9378 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9380 expon
-= DBL_MANT_DIG
;
9383 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9387 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9388 SCM_I_BIG_MPZ (numerator
),
9392 numerator
= scm_i_normbig (numerator
);
9394 return scm_i_make_ratio_already_reduced
9395 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9397 return left_shift_exact_integer (numerator
, expon
);
9405 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9407 "Returns the @emph{simplest} rational number differing\n"
9408 "from @var{x} by no more than @var{eps}.\n"
9410 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9411 "exact result when both its arguments are exact. Thus, you might need\n"
9412 "to use @code{inexact->exact} on the arguments.\n"
9415 "(rationalize (inexact->exact 1.2) 1/100)\n"
9418 #define FUNC_NAME s_scm_rationalize
9420 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9421 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9423 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9425 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9427 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9432 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9435 return scm_exact_to_inexact
9436 (scm_rationalize (scm_inexact_to_exact (x
),
9437 scm_inexact_to_exact (eps
)));
9441 /* X and EPS are exact rationals.
9443 The code that follows is equivalent to the following Scheme code:
9445 (define (exact-rationalize x eps)
9446 (let ((n1 (if (negative? x) -1 1))
9449 (let ((lo (- x eps))
9453 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9454 (nhi (numerator hi)) (dhi (denominator hi))
9455 (n1 n1) (d1 0) (n2 0) (d2 1))
9456 (let-values (((qlo rlo) (floor/ nlo dlo))
9457 ((qhi rhi) (floor/ nhi dhi)))
9458 (let ((n0 (+ n2 (* n1 qlo)))
9459 (d0 (+ d2 (* d1 qlo))))
9460 (cond ((zero? rlo) (/ n0 d0))
9461 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9462 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9468 eps
= scm_abs (eps
);
9469 if (scm_is_true (scm_negative_p (x
)))
9472 x
= scm_difference (x
, SCM_UNDEFINED
);
9475 /* X and EPS are non-negative exact rationals. */
9477 lo
= scm_difference (x
, eps
);
9478 hi
= scm_sum (x
, eps
);
9480 if (scm_is_false (scm_positive_p (lo
)))
9481 /* If zero is included in the interval, return it.
9482 It is the simplest rational of all. */
9487 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9488 mpz_t nlo
, dlo
, nhi
, dhi
;
9489 mpz_t qlo
, rlo
, qhi
, rhi
;
9491 /* LO and HI are positive exact rationals. */
9493 /* Our approach here follows the method described by Alan
9494 Bawden in a message entitled "(rationalize x y)" on the
9495 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9497 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9499 In brief, we compute the continued fractions of the two
9500 endpoints of the interval (LO and HI). The continued
9501 fraction of the result consists of the common prefix of the
9502 continued fractions of LO and HI, plus one final term. The
9503 final term of the result is the smallest integer contained
9504 in the interval between the remainders of LO and HI after
9505 the common prefix has been removed.
9507 The following code lazily computes the continued fraction
9508 representations of LO and HI, and simultaneously converts
9509 the continued fraction of the result into a rational
9510 number. We use MPZ functions directly to avoid type
9511 dispatch and GC allocation during the loop. */
9513 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9518 /* The variables N1, D1, N2 and D2 are used to compute the
9519 resulting rational from its continued fraction. At each
9520 step, N2/D2 and N1/D1 are the last two convergents. They
9521 are normally initialized to 0/1 and 1/0, respectively.
9522 However, if we negated X then we must negate the result as
9523 well, and we do that by initializing N1/D1 to -1/0. */
9524 mpz_set_si (n1
, n1_init
);
9529 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9530 compute the continued fraction representations of LO and HI
9531 using Euclid's algorithm. Initially, NLO/DLO == LO and
9533 scm_to_mpz (scm_numerator (lo
), nlo
);
9534 scm_to_mpz (scm_denominator (lo
), dlo
);
9535 scm_to_mpz (scm_numerator (hi
), nhi
);
9536 scm_to_mpz (scm_denominator (hi
), dhi
);
9538 /* As long as we're using exact arithmetic, the following loop
9539 is guaranteed to terminate. */
9542 /* Compute the next terms (QLO and QHI) of the continued
9543 fractions of LO and HI. */
9544 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9545 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9547 /* The next term of the result will be either QLO or
9548 QLO+1. Here we compute the next convergent of the
9549 result based on the assumption that QLO is the next
9550 term. If that turns out to be wrong, we'll adjust
9551 these later by adding N1 to N0 and D1 to D0. */
9552 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9553 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9555 /* We stop iterating when an integer is contained in the
9556 interval between the remainders NLO/DLO and NHI/DHI.
9557 There are two cases to consider: either NLO/DLO == QLO
9558 is an integer (indicated by RLO == 0), or QLO < QHI. */
9559 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9562 /* Efficiently shuffle variables around for the next
9563 iteration. First we shift the recent convergents. */
9564 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9565 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9567 /* The following shuffling is a bit confusing, so some
9568 explanation is in order. Conceptually, we're doing a
9569 couple of things here. After substracting the floor of
9570 NLO/DLO, the remainder is RLO/DLO. The rest of the
9571 continued fraction will represent the remainder's
9572 reciprocal DLO/RLO. Similarly for the HI endpoint.
9573 So in the next iteration, the new endpoints will be
9574 DLO/RLO and DHI/RHI. However, when we take the
9575 reciprocals of these endpoints, their order is
9576 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9577 and NHI/DHI <-- DLO/RLO. */
9578 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9579 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9582 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9583 The last term of the result will be the smallest integer in
9584 that interval, which is ceiling(NLO/DLO). We have already
9585 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9586 equal to the ceiling. */
9587 if (mpz_sgn (rlo
) != 0)
9589 /* If RLO is non-zero, then NLO/DLO is not an integer and
9590 the next term will be QLO+1. QLO was used in the
9591 computation of N0 and D0 above. Here we adjust N0 and
9592 D0 to be based on QLO+1 instead of QLO. */
9593 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9594 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9597 /* The simplest rational in the interval is N0/D0 */
9598 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9600 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9610 /* conversion functions */
9613 scm_is_integer (SCM val
)
9615 return scm_is_true (scm_integer_p (val
));
9619 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9621 if (SCM_I_INUMP (val
))
9623 scm_t_signed_bits n
= SCM_I_INUM (val
);
9624 return n
>= min
&& n
<= max
;
9626 else if (SCM_BIGP (val
))
9628 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9630 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9632 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9634 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9635 return n
>= min
&& n
<= max
;
9645 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9646 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9649 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9650 SCM_I_BIG_MPZ (val
));
9652 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9664 return n
>= min
&& n
<= max
;
9672 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9674 if (SCM_I_INUMP (val
))
9676 scm_t_signed_bits n
= SCM_I_INUM (val
);
9677 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9679 else if (SCM_BIGP (val
))
9681 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9683 else if (max
<= ULONG_MAX
)
9685 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9687 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9688 return n
>= min
&& n
<= max
;
9698 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9701 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9702 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9705 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9706 SCM_I_BIG_MPZ (val
));
9708 return n
>= min
&& n
<= max
;
9716 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9718 scm_error (scm_out_of_range_key
,
9720 "Value out of range ~S to ~S: ~S",
9721 scm_list_3 (min
, max
, bad_val
),
9722 scm_list_1 (bad_val
));
9725 #define TYPE scm_t_intmax
9726 #define TYPE_MIN min
9727 #define TYPE_MAX max
9728 #define SIZEOF_TYPE 0
9729 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9730 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9731 #include "libguile/conv-integer.i.c"
9733 #define TYPE scm_t_uintmax
9734 #define TYPE_MIN min
9735 #define TYPE_MAX max
9736 #define SIZEOF_TYPE 0
9737 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9738 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9739 #include "libguile/conv-uinteger.i.c"
9741 #define TYPE scm_t_int8
9742 #define TYPE_MIN SCM_T_INT8_MIN
9743 #define TYPE_MAX SCM_T_INT8_MAX
9744 #define SIZEOF_TYPE 1
9745 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9746 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9747 #include "libguile/conv-integer.i.c"
9749 #define TYPE scm_t_uint8
9751 #define TYPE_MAX SCM_T_UINT8_MAX
9752 #define SIZEOF_TYPE 1
9753 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9754 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9755 #include "libguile/conv-uinteger.i.c"
9757 #define TYPE scm_t_int16
9758 #define TYPE_MIN SCM_T_INT16_MIN
9759 #define TYPE_MAX SCM_T_INT16_MAX
9760 #define SIZEOF_TYPE 2
9761 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9762 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9763 #include "libguile/conv-integer.i.c"
9765 #define TYPE scm_t_uint16
9767 #define TYPE_MAX SCM_T_UINT16_MAX
9768 #define SIZEOF_TYPE 2
9769 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9770 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9771 #include "libguile/conv-uinteger.i.c"
9773 #define TYPE scm_t_int32
9774 #define TYPE_MIN SCM_T_INT32_MIN
9775 #define TYPE_MAX SCM_T_INT32_MAX
9776 #define SIZEOF_TYPE 4
9777 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9778 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9779 #include "libguile/conv-integer.i.c"
9781 #define TYPE scm_t_uint32
9783 #define TYPE_MAX SCM_T_UINT32_MAX
9784 #define SIZEOF_TYPE 4
9785 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9786 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9787 #include "libguile/conv-uinteger.i.c"
9789 #define TYPE scm_t_wchar
9790 #define TYPE_MIN (scm_t_int32)-1
9791 #define TYPE_MAX (scm_t_int32)0x10ffff
9792 #define SIZEOF_TYPE 4
9793 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9794 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9795 #include "libguile/conv-integer.i.c"
9797 #define TYPE scm_t_int64
9798 #define TYPE_MIN SCM_T_INT64_MIN
9799 #define TYPE_MAX SCM_T_INT64_MAX
9800 #define SIZEOF_TYPE 8
9801 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9802 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9803 #include "libguile/conv-integer.i.c"
9805 #define TYPE scm_t_uint64
9807 #define TYPE_MAX SCM_T_UINT64_MAX
9808 #define SIZEOF_TYPE 8
9809 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9810 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9811 #include "libguile/conv-uinteger.i.c"
9814 scm_to_mpz (SCM val
, mpz_t rop
)
9816 if (SCM_I_INUMP (val
))
9817 mpz_set_si (rop
, SCM_I_INUM (val
));
9818 else if (SCM_BIGP (val
))
9819 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9821 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9825 scm_from_mpz (mpz_t val
)
9827 return scm_i_mpz2num (val
);
9831 scm_is_real (SCM val
)
9833 return scm_is_true (scm_real_p (val
));
9837 scm_is_rational (SCM val
)
9839 return scm_is_true (scm_rational_p (val
));
9843 scm_to_double (SCM val
)
9845 if (SCM_I_INUMP (val
))
9846 return SCM_I_INUM (val
);
9847 else if (SCM_BIGP (val
))
9848 return scm_i_big2dbl (val
);
9849 else if (SCM_FRACTIONP (val
))
9850 return scm_i_fraction2double (val
);
9851 else if (SCM_REALP (val
))
9852 return SCM_REAL_VALUE (val
);
9854 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9858 scm_from_double (double val
)
9860 return scm_i_from_double (val
);
9864 scm_is_complex (SCM val
)
9866 return scm_is_true (scm_complex_p (val
));
9870 scm_c_real_part (SCM z
)
9872 if (SCM_COMPLEXP (z
))
9873 return SCM_COMPLEX_REAL (z
);
9876 /* Use the scm_real_part to get proper error checking and
9879 return scm_to_double (scm_real_part (z
));
9884 scm_c_imag_part (SCM z
)
9886 if (SCM_COMPLEXP (z
))
9887 return SCM_COMPLEX_IMAG (z
);
9890 /* Use the scm_imag_part to get proper error checking and
9891 dispatching. The result will almost always be 0.0, but not
9894 return scm_to_double (scm_imag_part (z
));
9899 scm_c_magnitude (SCM z
)
9901 return scm_to_double (scm_magnitude (z
));
9907 return scm_to_double (scm_angle (z
));
9911 scm_is_number (SCM z
)
9913 return scm_is_true (scm_number_p (z
));
9917 /* Returns log(x * 2^shift) */
9919 log_of_shifted_double (double x
, long shift
)
9921 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9923 if (copysign (1.0, x
) > 0.0)
9924 return scm_i_from_double (ans
);
9926 return scm_c_make_rectangular (ans
, M_PI
);
9929 /* Returns log(n), for exact integer n */
9931 log_of_exact_integer (SCM n
)
9933 if (SCM_I_INUMP (n
))
9934 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9935 else if (SCM_BIGP (n
))
9938 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9939 return log_of_shifted_double (signif
, expon
);
9942 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9945 /* Returns log(n/d), for exact non-zero integers n and d */
9947 log_of_fraction (SCM n
, SCM d
)
9949 long n_size
= scm_to_long (scm_integer_length (n
));
9950 long d_size
= scm_to_long (scm_integer_length (d
));
9952 if (abs (n_size
- d_size
) > 1)
9953 return (scm_difference (log_of_exact_integer (n
),
9954 log_of_exact_integer (d
)));
9955 else if (scm_is_false (scm_negative_p (n
)))
9956 return scm_i_from_double
9957 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9959 return scm_c_make_rectangular
9960 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9966 /* In the following functions we dispatch to the real-arg funcs like log()
9967 when we know the arg is real, instead of just handing everything to
9968 clog() for instance. This is in case clog() doesn't optimize for a
9969 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9970 well use it to go straight to the applicable C func. */
9972 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9974 "Return the natural logarithm of @var{z}.")
9975 #define FUNC_NAME s_scm_log
9977 if (SCM_COMPLEXP (z
))
9979 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9980 && defined (SCM_COMPLEX_VALUE)
9981 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9983 double re
= SCM_COMPLEX_REAL (z
);
9984 double im
= SCM_COMPLEX_IMAG (z
);
9985 return scm_c_make_rectangular (log (hypot (re
, im
)),
9989 else if (SCM_REALP (z
))
9990 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9991 else if (SCM_I_INUMP (z
))
9993 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9994 if (scm_is_eq (z
, SCM_INUM0
))
9995 scm_num_overflow (s_scm_log
);
9997 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9999 else if (SCM_BIGP (z
))
10000 return log_of_exact_integer (z
);
10001 else if (SCM_FRACTIONP (z
))
10002 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10003 SCM_FRACTION_DENOMINATOR (z
));
10005 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
10010 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10012 "Return the base 10 logarithm of @var{z}.")
10013 #define FUNC_NAME s_scm_log10
10015 if (SCM_COMPLEXP (z
))
10017 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10018 clog() and a multiply by M_LOG10E, rather than the fallback
10019 log10+hypot+atan2.) */
10020 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10021 && defined SCM_COMPLEX_VALUE
10022 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10024 double re
= SCM_COMPLEX_REAL (z
);
10025 double im
= SCM_COMPLEX_IMAG (z
);
10026 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10027 M_LOG10E
* atan2 (im
, re
));
10030 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10032 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10033 if (scm_is_eq (z
, SCM_INUM0
))
10034 scm_num_overflow (s_scm_log10
);
10037 double re
= scm_to_double (z
);
10038 double l
= log10 (fabs (re
));
10039 if (copysign (1.0, re
) > 0.0)
10040 return scm_i_from_double (l
);
10042 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10045 else if (SCM_BIGP (z
))
10046 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10047 else if (SCM_FRACTIONP (z
))
10048 return scm_product (flo_log10e
,
10049 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10050 SCM_FRACTION_DENOMINATOR (z
)));
10052 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10057 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10059 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10060 "base of natural logarithms (2.71828@dots{}).")
10061 #define FUNC_NAME s_scm_exp
10063 if (SCM_COMPLEXP (z
))
10065 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10066 && defined (SCM_COMPLEX_VALUE)
10067 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10069 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10070 SCM_COMPLEX_IMAG (z
));
10073 else if (SCM_NUMBERP (z
))
10075 /* When z is a negative bignum the conversion to double overflows,
10076 giving -infinity, but that's ok, the exp is still 0.0. */
10077 return scm_i_from_double (exp (scm_to_double (z
)));
10080 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10085 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10087 "Return two exact non-negative integers @var{s} and @var{r}\n"
10088 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10089 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10090 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10093 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10095 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10099 scm_exact_integer_sqrt (k
, &s
, &r
);
10100 return scm_values (scm_list_2 (s
, r
));
10105 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10107 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10111 if (SCM_I_INUM (k
) < 0)
10112 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10113 "exact non-negative integer");
10114 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10115 mpz_inits (ss
, rr
, NULL
);
10116 mpz_sqrtrem (ss
, rr
, kk
);
10117 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10118 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10119 mpz_clears (kk
, ss
, rr
, NULL
);
10121 else if (SCM_LIKELY (SCM_BIGP (k
)))
10125 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10126 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10127 "exact non-negative integer");
10128 s
= scm_i_mkbig ();
10129 r
= scm_i_mkbig ();
10130 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10131 scm_remember_upto_here_1 (k
);
10132 *sp
= scm_i_normbig (s
);
10133 *rp
= scm_i_normbig (r
);
10136 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10137 "exact non-negative integer");
10140 /* Return true iff K is a perfect square.
10141 K must be an exact integer. */
10143 exact_integer_is_perfect_square (SCM k
)
10147 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10151 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10152 result
= mpz_perfect_square_p (kk
);
10157 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10158 scm_remember_upto_here_1 (k
);
10163 /* Return the floor of the square root of K.
10164 K must be an exact integer. */
10166 exact_integer_floor_square_root (SCM k
)
10168 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10173 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10175 ss
= mpz_get_ui (kk
);
10177 return SCM_I_MAKINUM (ss
);
10183 s
= scm_i_mkbig ();
10184 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10185 scm_remember_upto_here_1 (k
);
10186 return scm_i_normbig (s
);
10191 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10193 "Return the square root of @var{z}. Of the two possible roots\n"
10194 "(positive and negative), the one with positive real part\n"
10195 "is returned, or if that's zero then a positive imaginary part.\n"
10199 "(sqrt 9.0) @result{} 3.0\n"
10200 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10201 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10202 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10204 #define FUNC_NAME s_scm_sqrt
10206 if (SCM_COMPLEXP (z
))
10208 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10209 && defined SCM_COMPLEX_VALUE
10210 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10212 double re
= SCM_COMPLEX_REAL (z
);
10213 double im
= SCM_COMPLEX_IMAG (z
);
10214 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10215 0.5 * atan2 (im
, re
));
10218 else if (SCM_NUMBERP (z
))
10220 if (SCM_I_INUMP (z
))
10222 scm_t_inum x
= SCM_I_INUM (z
);
10224 if (SCM_LIKELY (x
>= 0))
10226 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10227 || x
< (1L << (DBL_MANT_DIG
- 1))))
10229 double root
= sqrt (x
);
10231 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10232 integer, then the result is exact. */
10233 if (root
== floor (root
))
10234 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10236 return scm_i_from_double (root
);
10243 mpz_init_set_ui (xx
, x
);
10244 if (mpz_perfect_square_p (xx
))
10247 root
= mpz_get_ui (xx
);
10249 return SCM_I_MAKINUM (root
);
10256 else if (SCM_BIGP (z
))
10258 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10260 SCM root
= scm_i_mkbig ();
10262 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10263 scm_remember_upto_here_1 (z
);
10264 return scm_i_normbig (root
);
10269 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10277 return scm_c_make_rectangular
10278 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10280 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10283 else if (SCM_FRACTIONP (z
))
10285 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10286 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10288 if (exact_integer_is_perfect_square (n
)
10289 && exact_integer_is_perfect_square (d
))
10290 return scm_i_make_ratio_already_reduced
10291 (exact_integer_floor_square_root (n
),
10292 exact_integer_floor_square_root (d
));
10295 double xx
= scm_i_divide2double (n
, d
);
10296 double abs_xx
= fabs (xx
);
10299 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10301 shift
= (scm_to_long (scm_integer_length (n
))
10302 - scm_to_long (scm_integer_length (d
))) / 2;
10304 d
= left_shift_exact_integer (d
, 2 * shift
);
10306 n
= left_shift_exact_integer (n
, -2 * shift
);
10307 xx
= scm_i_divide2double (n
, d
);
10311 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10313 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10317 /* Fallback method, when the cases above do not apply. */
10319 double xx
= scm_to_double (z
);
10321 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10323 return scm_i_from_double (sqrt (xx
));
10327 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10334 scm_init_numbers ()
10336 if (scm_install_gmp_memory_functions
)
10337 mp_set_memory_functions (custom_gmp_malloc
,
10338 custom_gmp_realloc
,
10341 mpz_init_set_si (z_negative_one
, -1);
10343 /* It may be possible to tune the performance of some algorithms by using
10344 * the following constants to avoid the creation of bignums. Please, before
10345 * using these values, remember the two rules of program optimization:
10346 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10347 scm_c_define ("most-positive-fixnum",
10348 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10349 scm_c_define ("most-negative-fixnum",
10350 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10352 scm_add_feature ("complex");
10353 scm_add_feature ("inexact");
10354 flo0
= scm_i_from_double (0.0);
10355 flo_log10e
= scm_i_from_double (M_LOG10E
);
10357 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10360 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10361 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10362 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10363 scm_i_divide2double_lo2b
,
10364 DBL_MANT_DIG
+ 1); /* 2 b^p */
10365 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10369 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10370 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10371 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10372 dbl_minimum_normal_mantissa
,
10376 #include "libguile/numbers.x"
10381 c-file-style: "gnu"