1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
3 * 2013 Free Software Foundation, Inc.
5 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
6 * and Bellcore. See scm_divide.
9 * This library is free software; you can redistribute it and/or
10 * modify it under the terms of the GNU Lesser General Public License
11 * as published by the Free Software Foundation; either version 3 of
12 * the License, or (at your option) any later version.
14 * This library is distributed in the hope that it will be useful, but
15 * WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * Lesser General Public License for more details.
19 * You should have received a copy of the GNU Lesser General Public
20 * License along with this library; if not, write to the Free Software
21 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 /* General assumptions:
27 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
28 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
29 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
30 * XXX What about infinities? They are equal to their own floor! -mhw
31 * All objects satisfying SCM_FRACTIONP are never an integer.
36 - see if special casing bignums and reals in integer-exponent when
37 possible (to use mpz_pow and mpf_pow_ui) is faster.
39 - look in to better short-circuiting of common cases in
40 integer-expt and elsewhere.
42 - see if direct mpz operations can help in ash and elsewhere.
63 #include "libguile/_scm.h"
64 #include "libguile/feature.h"
65 #include "libguile/ports.h"
66 #include "libguile/root.h"
67 #include "libguile/smob.h"
68 #include "libguile/strings.h"
69 #include "libguile/bdw-gc.h"
71 #include "libguile/validate.h"
72 #include "libguile/numbers.h"
73 #include "libguile/deprecation.h"
75 #include "libguile/eq.h"
77 /* values per glibc, if not already defined */
79 #define M_LOG10E 0.43429448190325182765
82 #define M_LN2 0.69314718055994530942
85 #define M_PI 3.14159265358979323846
88 /* FIXME: We assume that FLT_RADIX is 2 */
89 verify (FLT_RADIX
== 2);
91 typedef scm_t_signed_bits scm_t_inum
;
92 #define scm_from_inum(x) (scm_from_signed_integer (x))
94 /* Test an inum to see if it can be converted to a double without loss
95 of precision. Note that this will sometimes return 0 even when 1
96 could have been returned, e.g. for large powers of 2. It is designed
97 to be a fast check to optimize common cases. */
98 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
99 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
100 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
102 #if ! HAVE_DECL_MPZ_INITS
104 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
106 #define VARARG_MPZ_ITERATOR(func) \
108 func ## s (mpz_t x, ...) \
116 x = va_arg (ap, mpz_ptr); \
121 VARARG_MPZ_ITERATOR (mpz_init
)
122 VARARG_MPZ_ITERATOR (mpz_clear
)
129 Wonder if this might be faster for some of our code? A switch on
130 the numtag would jump directly to the right case, and the
131 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
133 #define SCM_I_NUMTAG_NOTNUM 0
134 #define SCM_I_NUMTAG_INUM 1
135 #define SCM_I_NUMTAG_BIG scm_tc16_big
136 #define SCM_I_NUMTAG_REAL scm_tc16_real
137 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
138 #define SCM_I_NUMTAG(x) \
139 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
140 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
141 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
142 : SCM_I_NUMTAG_NOTNUM)))
144 /* the macro above will not work as is with fractions */
147 /* Default to 1, because as we used to hard-code `free' as the
148 deallocator, we know that overriding these functions with
149 instrumented `malloc' / `free' is OK. */
150 int scm_install_gmp_memory_functions
= 1;
152 static SCM exactly_one_half
;
153 static SCM flo_log10e
;
155 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
157 /* FLOBUFLEN is the maximum number of characters neccessary for the
158 * printed or scm_string representation of an inexact number.
160 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
163 #if !defined (HAVE_ASINH)
164 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
166 #if !defined (HAVE_ACOSH)
167 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
169 #if !defined (HAVE_ATANH)
170 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
173 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
174 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
175 in March 2006), mpz_cmp_d now handles infinities properly. */
177 #define xmpz_cmp_d(z, d) \
178 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
180 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
184 #if defined (GUILE_I)
185 #if defined HAVE_COMPLEX_DOUBLE
187 /* For an SCM object Z which is a complex number (ie. satisfies
188 SCM_COMPLEXP), return its value as a C level "complex double". */
189 #define SCM_COMPLEX_VALUE(z) \
190 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
192 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
194 /* Convert a C "complex double" to an SCM value. */
196 scm_from_complex_double (complex double z
)
198 return scm_c_make_rectangular (creal (z
), cimag (z
));
201 #endif /* HAVE_COMPLEX_DOUBLE */
206 static mpz_t z_negative_one
;
210 /* Clear the `mpz_t' embedded in bignum PTR. */
212 finalize_bignum (void *ptr
, void *data
)
216 bignum
= SCM_PACK_POINTER (ptr
);
217 mpz_clear (SCM_I_BIG_MPZ (bignum
));
220 /* The next three functions (custom_libgmp_*) are passed to
221 mp_set_memory_functions (in GMP) so that memory used by the digits
222 themselves is known to the garbage collector. This is needed so
223 that GC will be run at appropriate times. Otherwise, a program which
224 creates many large bignums would malloc a huge amount of memory
225 before the GC runs. */
227 custom_gmp_malloc (size_t alloc_size
)
229 return scm_malloc (alloc_size
);
233 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
235 return scm_realloc (old_ptr
, new_size
);
239 custom_gmp_free (void *ptr
, size_t size
)
245 /* Return a new uninitialized bignum. */
251 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
252 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
256 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
265 /* Return a newly created bignum. */
266 SCM z
= make_bignum ();
267 mpz_init (SCM_I_BIG_MPZ (z
));
272 scm_i_inum2big (scm_t_inum x
)
274 /* Return a newly created bignum initialized to X. */
275 SCM z
= make_bignum ();
276 #if SIZEOF_VOID_P == SIZEOF_LONG
277 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
279 /* Note that in this case, you'll also have to check all mpz_*_ui and
280 mpz_*_si invocations in Guile. */
281 #error creation of mpz not implemented for this inum size
287 scm_i_long2big (long x
)
289 /* Return a newly created bignum initialized to X. */
290 SCM z
= make_bignum ();
291 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
296 scm_i_ulong2big (unsigned long x
)
298 /* Return a newly created bignum initialized to X. */
299 SCM z
= make_bignum ();
300 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
305 scm_i_clonebig (SCM src_big
, int same_sign_p
)
307 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
308 SCM z
= make_bignum ();
309 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
311 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
316 scm_i_bigcmp (SCM x
, SCM y
)
318 /* Return neg if x < y, pos if x > y, and 0 if x == y */
319 /* presume we already know x and y are bignums */
320 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
321 scm_remember_upto_here_2 (x
, y
);
326 scm_i_dbl2big (double d
)
328 /* results are only defined if d is an integer */
329 SCM z
= make_bignum ();
330 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
334 /* Convert a integer in double representation to a SCM number. */
337 scm_i_dbl2num (double u
)
339 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
340 powers of 2, so there's no rounding when making "double" values
341 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
342 get rounded on a 64-bit machine, hence the "+1".
344 The use of floor() to force to an integer value ensures we get a
345 "numerically closest" value without depending on how a
346 double->long cast or how mpz_set_d will round. For reference,
347 double->long probably follows the hardware rounding mode,
348 mpz_set_d truncates towards zero. */
350 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
351 representable as a double? */
353 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
354 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
355 return SCM_I_MAKINUM ((scm_t_inum
) u
);
357 return scm_i_dbl2big (u
);
360 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
362 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
363 bignum b into a normalized significand and exponent such that
364 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
365 The return value is the significand rounded to the closest
366 representable double, and the exponent is placed into *expon_p.
367 If b is zero, then the returned exponent and significand are both
371 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
373 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
376 if (bits
> DBL_MANT_DIG
)
378 shift
= bits
- DBL_MANT_DIG
;
379 b
= round_right_shift_exact_integer (b
, shift
);
383 double signif
= frexp (SCM_I_INUM (b
), &expon
);
384 *expon_p
= expon
+ shift
;
391 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
392 scm_remember_upto_here_1 (b
);
393 *expon_p
= expon
+ shift
;
398 /* scm_i_big2dbl() rounds to the closest representable double,
399 in accordance with R5RS exact->inexact. */
401 scm_i_big2dbl (SCM b
)
404 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
405 return ldexp (signif
, expon
);
409 scm_i_normbig (SCM b
)
411 /* convert a big back to a fixnum if it'll fit */
412 /* presume b is a bignum */
413 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
415 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
416 if (SCM_FIXABLE (val
))
417 b
= SCM_I_MAKINUM (val
);
422 static SCM_C_INLINE_KEYWORD SCM
423 scm_i_mpz2num (mpz_t b
)
425 /* convert a mpz number to a SCM number. */
426 if (mpz_fits_slong_p (b
))
428 scm_t_inum val
= mpz_get_si (b
);
429 if (SCM_FIXABLE (val
))
430 return SCM_I_MAKINUM (val
);
434 SCM z
= make_bignum ();
435 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
440 /* Make the ratio NUMERATOR/DENOMINATOR, where:
441 1. NUMERATOR and DENOMINATOR are exact integers
442 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
444 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
446 /* Flip signs so that the denominator is positive. */
447 if (scm_is_false (scm_positive_p (denominator
)))
449 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
450 scm_num_overflow ("make-ratio");
453 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
454 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
458 /* Check for the integer case */
459 if (scm_is_eq (denominator
, SCM_INUM1
))
462 return scm_double_cell (scm_tc16_fraction
,
463 SCM_UNPACK (numerator
),
464 SCM_UNPACK (denominator
), 0);
467 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
469 /* Make the ratio NUMERATOR/DENOMINATOR */
471 scm_i_make_ratio (SCM numerator
, SCM denominator
)
472 #define FUNC_NAME "make-ratio"
474 /* Make sure the arguments are proper */
475 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
476 SCM_WRONG_TYPE_ARG (1, numerator
);
477 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
478 SCM_WRONG_TYPE_ARG (2, denominator
);
481 SCM the_gcd
= scm_gcd (numerator
, denominator
);
482 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
484 /* Reduce to lowest terms */
485 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
486 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
488 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
493 static mpz_t scm_i_divide2double_lo2b
;
495 /* Return the double that is closest to the exact rational N/D, with
496 ties rounded toward even mantissas. N and D must be exact
499 scm_i_divide2double (SCM n
, SCM d
)
502 mpz_t nn
, dd
, lo
, hi
, x
;
505 if (SCM_LIKELY (SCM_I_INUMP (d
)))
509 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n
))
510 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d
))))
511 /* If both N and D can be losslessly converted to doubles, then
512 we can rely on IEEE floating point to do proper rounding much
513 faster than we can. */
514 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
516 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
518 if (scm_is_true (scm_positive_p (n
)))
520 else if (scm_is_true (scm_negative_p (n
)))
526 mpz_init_set_si (dd
, SCM_I_INUM (d
));
529 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
532 mpz_init_set_si (nn
, SCM_I_INUM (n
));
534 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
536 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
540 /* Now we need to find the value of e such that:
543 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
544 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
545 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
548 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
549 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
550 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
552 where: p = DBL_MANT_DIG
553 b = FLT_RADIX (here assumed to be 2)
555 After rounding, the mantissa must be an integer between b^{p-1} and
556 (b^p - 1), except for subnormal numbers. In the inequations [1A]
557 and [1B], the middle expression represents the mantissa *before*
558 rounding, and therefore is bounded by the range of values that will
559 round to a floating-point number with the exponent e. The upper
560 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
561 ties will round up to the next power of b. The lower bound is
562 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
563 this power of b. Here we subtract 1/2b instead of 1/2 because it
564 is in the range of the next smaller exponent, where the
565 representable numbers are closer together by a factor of b.
567 Inequations [2A] and [2B] are derived from [1A] and [1B] by
568 multiplying by 2b, and in [3A] and [3B] we multiply by the
569 denominator of the middle value to obtain integer expressions.
571 In the code below, we refer to the three expressions in [3A] or
572 [3B] as lo, x, and hi. If the number is normalizable, we will
573 achieve the goal: lo <= x < hi */
575 /* Make an initial guess for e */
576 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
577 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
578 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
580 /* Compute the initial values of lo, x, and hi
581 based on the initial guess of e */
582 mpz_inits (lo
, hi
, x
, NULL
);
583 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
584 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
586 mpz_mul_2exp (lo
, lo
, e
);
587 mpz_mul_2exp (hi
, lo
, 1);
589 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
590 (but without making e less then the minimum exponent) */
591 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
593 mpz_mul_2exp (x
, x
, 1);
596 while (mpz_cmp (x
, hi
) >= 0)
598 /* If we ever used lo's value again,
599 we would need to double lo here. */
600 mpz_mul_2exp (hi
, hi
, 1);
604 /* Now compute the rounded mantissa:
605 n / b^e d (if e >= 0)
606 n b^-e / d (if e <= 0) */
612 mpz_mul_2exp (nn
, nn
, -e
);
614 mpz_mul_2exp (dd
, dd
, e
);
616 /* mpz does not directly support rounded right
617 shifts, so we have to do it the hard way.
618 For efficiency, we reuse lo and hi.
619 hi == quotient, lo == remainder */
620 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
622 /* The fractional part of the unrounded mantissa would be
623 remainder/dividend, i.e. lo/dd. So we have a tie if
624 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
625 integer expression 2*lo = dd. Here we do that comparison
626 to decide whether to round up or down. */
627 mpz_mul_2exp (lo
, lo
, 1);
628 cmp
= mpz_cmp (lo
, dd
);
629 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
630 mpz_add_ui (hi
, hi
, 1);
632 result
= ldexp (mpz_get_d (hi
), e
);
636 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
642 scm_i_fraction2double (SCM z
)
644 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
645 SCM_FRACTION_DENOMINATOR (z
));
649 scm_i_from_double (double val
)
653 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
655 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
656 SCM_REAL_VALUE (z
) = val
;
661 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
663 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
665 #define FUNC_NAME s_scm_exact_p
667 if (SCM_INEXACTP (x
))
669 else if (SCM_NUMBERP (x
))
672 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
677 scm_is_exact (SCM val
)
679 return scm_is_true (scm_exact_p (val
));
682 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
684 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
686 #define FUNC_NAME s_scm_inexact_p
688 if (SCM_INEXACTP (x
))
690 else if (SCM_NUMBERP (x
))
693 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
698 scm_is_inexact (SCM val
)
700 return scm_is_true (scm_inexact_p (val
));
703 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
705 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
707 #define FUNC_NAME s_scm_odd_p
711 scm_t_inum val
= SCM_I_INUM (n
);
712 return scm_from_bool ((val
& 1L) != 0);
714 else if (SCM_BIGP (n
))
716 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
717 scm_remember_upto_here_1 (n
);
718 return scm_from_bool (odd_p
);
720 else if (SCM_REALP (n
))
722 double val
= SCM_REAL_VALUE (n
);
725 double rem
= fabs (fmod (val
, 2.0));
732 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
737 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
739 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
741 #define FUNC_NAME s_scm_even_p
745 scm_t_inum val
= SCM_I_INUM (n
);
746 return scm_from_bool ((val
& 1L) == 0);
748 else if (SCM_BIGP (n
))
750 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
751 scm_remember_upto_here_1 (n
);
752 return scm_from_bool (even_p
);
754 else if (SCM_REALP (n
))
756 double val
= SCM_REAL_VALUE (n
);
759 double rem
= fabs (fmod (val
, 2.0));
766 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
770 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
772 "Return @code{#t} if the real number @var{x} is neither\n"
773 "infinite nor a NaN, @code{#f} otherwise.")
774 #define FUNC_NAME s_scm_finite_p
777 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
778 else if (scm_is_real (x
))
781 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
785 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
787 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
788 "@samp{-inf.0}. Otherwise return @code{#f}.")
789 #define FUNC_NAME s_scm_inf_p
792 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
793 else if (scm_is_real (x
))
796 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
800 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
802 "Return @code{#t} if the real number @var{x} is a NaN,\n"
803 "or @code{#f} otherwise.")
804 #define FUNC_NAME s_scm_nan_p
807 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
808 else if (scm_is_real (x
))
811 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
815 /* Guile's idea of infinity. */
816 static double guile_Inf
;
818 /* Guile's idea of not a number. */
819 static double guile_NaN
;
822 guile_ieee_init (void)
824 /* Some version of gcc on some old version of Linux used to crash when
825 trying to make Inf and NaN. */
828 /* C99 INFINITY, when available.
829 FIXME: The standard allows for INFINITY to be something that overflows
830 at compile time. We ought to have a configure test to check for that
831 before trying to use it. (But in practice we believe this is not a
832 problem on any system guile is likely to target.) */
833 guile_Inf
= INFINITY
;
834 #elif defined HAVE_DINFINITY
836 extern unsigned int DINFINITY
[2];
837 guile_Inf
= (*((double *) (DINFINITY
)));
844 if (guile_Inf
== tmp
)
851 /* C99 NAN, when available */
853 #elif defined HAVE_DQNAN
856 extern unsigned int DQNAN
[2];
857 guile_NaN
= (*((double *)(DQNAN
)));
860 guile_NaN
= guile_Inf
/ guile_Inf
;
864 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
867 #define FUNC_NAME s_scm_inf
869 static int initialized
= 0;
875 return scm_i_from_double (guile_Inf
);
879 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
882 #define FUNC_NAME s_scm_nan
884 static int initialized
= 0;
890 return scm_i_from_double (guile_NaN
);
895 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
897 "Return the absolute value of @var{x}.")
898 #define FUNC_NAME s_scm_abs
902 scm_t_inum xx
= SCM_I_INUM (x
);
905 else if (SCM_POSFIXABLE (-xx
))
906 return SCM_I_MAKINUM (-xx
);
908 return scm_i_inum2big (-xx
);
910 else if (SCM_LIKELY (SCM_REALP (x
)))
912 double xx
= SCM_REAL_VALUE (x
);
913 /* If x is a NaN then xx<0 is false so we return x unchanged */
915 return scm_i_from_double (-xx
);
916 /* Handle signed zeroes properly */
917 else if (SCM_UNLIKELY (xx
== 0.0))
922 else if (SCM_BIGP (x
))
924 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
926 return scm_i_clonebig (x
, 0);
930 else if (SCM_FRACTIONP (x
))
932 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
934 return scm_i_make_ratio_already_reduced
935 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
936 SCM_FRACTION_DENOMINATOR (x
));
939 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
944 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
946 "Return the quotient of the numbers @var{x} and @var{y}.")
947 #define FUNC_NAME s_scm_quotient
949 if (SCM_LIKELY (scm_is_integer (x
)))
951 if (SCM_LIKELY (scm_is_integer (y
)))
952 return scm_truncate_quotient (x
, y
);
954 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
957 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
961 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
963 "Return the remainder of the numbers @var{x} and @var{y}.\n"
965 "(remainder 13 4) @result{} 1\n"
966 "(remainder -13 4) @result{} -1\n"
968 #define FUNC_NAME s_scm_remainder
970 if (SCM_LIKELY (scm_is_integer (x
)))
972 if (SCM_LIKELY (scm_is_integer (y
)))
973 return scm_truncate_remainder (x
, y
);
975 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
978 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
983 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
985 "Return the modulo of the numbers @var{x} and @var{y}.\n"
987 "(modulo 13 4) @result{} 1\n"
988 "(modulo -13 4) @result{} 3\n"
990 #define FUNC_NAME s_scm_modulo
992 if (SCM_LIKELY (scm_is_integer (x
)))
994 if (SCM_LIKELY (scm_is_integer (y
)))
995 return scm_floor_remainder (x
, y
);
997 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
1000 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1004 /* Return the exact integer q such that n = q*d, for exact integers n
1005 and d, where d is known in advance to divide n evenly (with zero
1006 remainder). For large integers, this can be computed more
1007 efficiently than when the remainder is unknown. */
1009 scm_exact_integer_quotient (SCM n
, SCM d
)
1010 #define FUNC_NAME "exact-integer-quotient"
1012 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1014 scm_t_inum nn
= SCM_I_INUM (n
);
1015 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1017 scm_t_inum dd
= SCM_I_INUM (d
);
1018 if (SCM_UNLIKELY (dd
== 0))
1019 scm_num_overflow ("exact-integer-quotient");
1022 scm_t_inum qq
= nn
/ dd
;
1023 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1024 return SCM_I_MAKINUM (qq
);
1026 return scm_i_inum2big (qq
);
1029 else if (SCM_LIKELY (SCM_BIGP (d
)))
1031 /* n is an inum and d is a bignum. Given that d is known to
1032 divide n evenly, there are only two possibilities: n is 0,
1033 or else n is fixnum-min and d is abs(fixnum-min). */
1037 return SCM_I_MAKINUM (-1);
1040 SCM_WRONG_TYPE_ARG (2, d
);
1042 else if (SCM_LIKELY (SCM_BIGP (n
)))
1044 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1046 scm_t_inum dd
= SCM_I_INUM (d
);
1047 if (SCM_UNLIKELY (dd
== 0))
1048 scm_num_overflow ("exact-integer-quotient");
1049 else if (SCM_UNLIKELY (dd
== 1))
1053 SCM q
= scm_i_mkbig ();
1055 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1058 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1059 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1061 scm_remember_upto_here_1 (n
);
1062 return scm_i_normbig (q
);
1065 else if (SCM_LIKELY (SCM_BIGP (d
)))
1067 SCM q
= scm_i_mkbig ();
1068 mpz_divexact (SCM_I_BIG_MPZ (q
),
1071 scm_remember_upto_here_2 (n
, d
);
1072 return scm_i_normbig (q
);
1075 SCM_WRONG_TYPE_ARG (2, d
);
1078 SCM_WRONG_TYPE_ARG (1, n
);
1082 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1083 two-valued functions. It is called from primitive generics that take
1084 two arguments and return two values, when the core procedure is
1085 unable to handle the given argument types. If there are GOOPS
1086 methods for this primitive generic, it dispatches to GOOPS and, if
1087 successful, expects two values to be returned, which are placed in
1088 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1089 wrong-type-arg exception.
1091 FIXME: This obviously belongs somewhere else, but until we decide on
1092 the right API, it is here as a static function, because it is needed
1093 by the *_divide functions below.
1096 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1097 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1099 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
1101 scm_i_extract_values_2 (vals
, rp1
, rp2
);
1104 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1106 "Return the integer @var{q} such that\n"
1107 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1108 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1110 "(euclidean-quotient 123 10) @result{} 12\n"
1111 "(euclidean-quotient 123 -10) @result{} -12\n"
1112 "(euclidean-quotient -123 10) @result{} -13\n"
1113 "(euclidean-quotient -123 -10) @result{} 13\n"
1114 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1115 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1117 #define FUNC_NAME s_scm_euclidean_quotient
1119 if (scm_is_false (scm_negative_p (y
)))
1120 return scm_floor_quotient (x
, y
);
1122 return scm_ceiling_quotient (x
, y
);
1126 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1128 "Return the real number @var{r} such that\n"
1129 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1130 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1131 "for some integer @var{q}.\n"
1133 "(euclidean-remainder 123 10) @result{} 3\n"
1134 "(euclidean-remainder 123 -10) @result{} 3\n"
1135 "(euclidean-remainder -123 10) @result{} 7\n"
1136 "(euclidean-remainder -123 -10) @result{} 7\n"
1137 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1138 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1140 #define FUNC_NAME s_scm_euclidean_remainder
1142 if (scm_is_false (scm_negative_p (y
)))
1143 return scm_floor_remainder (x
, y
);
1145 return scm_ceiling_remainder (x
, y
);
1149 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1151 "Return the integer @var{q} and the real number @var{r}\n"
1152 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1153 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1155 "(euclidean/ 123 10) @result{} 12 and 3\n"
1156 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1157 "(euclidean/ -123 10) @result{} -13 and 7\n"
1158 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1159 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1160 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1162 #define FUNC_NAME s_scm_i_euclidean_divide
1164 if (scm_is_false (scm_negative_p (y
)))
1165 return scm_i_floor_divide (x
, y
);
1167 return scm_i_ceiling_divide (x
, y
);
1172 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1174 if (scm_is_false (scm_negative_p (y
)))
1175 return scm_floor_divide (x
, y
, qp
, rp
);
1177 return scm_ceiling_divide (x
, y
, qp
, rp
);
1180 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1181 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1183 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1185 "Return the floor of @math{@var{x} / @var{y}}.\n"
1187 "(floor-quotient 123 10) @result{} 12\n"
1188 "(floor-quotient 123 -10) @result{} -13\n"
1189 "(floor-quotient -123 10) @result{} -13\n"
1190 "(floor-quotient -123 -10) @result{} 12\n"
1191 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1192 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1194 #define FUNC_NAME s_scm_floor_quotient
1196 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1198 scm_t_inum xx
= SCM_I_INUM (x
);
1199 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1201 scm_t_inum yy
= SCM_I_INUM (y
);
1202 scm_t_inum xx1
= xx
;
1204 if (SCM_LIKELY (yy
> 0))
1206 if (SCM_UNLIKELY (xx
< 0))
1209 else if (SCM_UNLIKELY (yy
== 0))
1210 scm_num_overflow (s_scm_floor_quotient
);
1214 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1215 return SCM_I_MAKINUM (qq
);
1217 return scm_i_inum2big (qq
);
1219 else if (SCM_BIGP (y
))
1221 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1222 scm_remember_upto_here_1 (y
);
1224 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1226 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1228 else if (SCM_REALP (y
))
1229 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1230 else if (SCM_FRACTIONP (y
))
1231 return scm_i_exact_rational_floor_quotient (x
, y
);
1233 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1234 s_scm_floor_quotient
);
1236 else if (SCM_BIGP (x
))
1238 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1240 scm_t_inum yy
= SCM_I_INUM (y
);
1241 if (SCM_UNLIKELY (yy
== 0))
1242 scm_num_overflow (s_scm_floor_quotient
);
1243 else if (SCM_UNLIKELY (yy
== 1))
1247 SCM q
= scm_i_mkbig ();
1249 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1252 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1253 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1255 scm_remember_upto_here_1 (x
);
1256 return scm_i_normbig (q
);
1259 else if (SCM_BIGP (y
))
1261 SCM q
= scm_i_mkbig ();
1262 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1265 scm_remember_upto_here_2 (x
, y
);
1266 return scm_i_normbig (q
);
1268 else if (SCM_REALP (y
))
1269 return scm_i_inexact_floor_quotient
1270 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1271 else if (SCM_FRACTIONP (y
))
1272 return scm_i_exact_rational_floor_quotient (x
, y
);
1274 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1275 s_scm_floor_quotient
);
1277 else if (SCM_REALP (x
))
1279 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1280 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1281 return scm_i_inexact_floor_quotient
1282 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1284 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1285 s_scm_floor_quotient
);
1287 else if (SCM_FRACTIONP (x
))
1290 return scm_i_inexact_floor_quotient
1291 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1292 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1293 return scm_i_exact_rational_floor_quotient (x
, y
);
1295 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1296 s_scm_floor_quotient
);
1299 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1300 s_scm_floor_quotient
);
1305 scm_i_inexact_floor_quotient (double x
, double y
)
1307 if (SCM_UNLIKELY (y
== 0))
1308 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1310 return scm_i_from_double (floor (x
/ y
));
1314 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1316 return scm_floor_quotient
1317 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1318 scm_product (scm_numerator (y
), scm_denominator (x
)));
1321 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1322 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1324 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1326 "Return the real number @var{r} such that\n"
1327 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1328 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1330 "(floor-remainder 123 10) @result{} 3\n"
1331 "(floor-remainder 123 -10) @result{} -7\n"
1332 "(floor-remainder -123 10) @result{} 7\n"
1333 "(floor-remainder -123 -10) @result{} -3\n"
1334 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1335 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1337 #define FUNC_NAME s_scm_floor_remainder
1339 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1341 scm_t_inum xx
= SCM_I_INUM (x
);
1342 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1344 scm_t_inum yy
= SCM_I_INUM (y
);
1345 if (SCM_UNLIKELY (yy
== 0))
1346 scm_num_overflow (s_scm_floor_remainder
);
1349 scm_t_inum rr
= xx
% yy
;
1350 int needs_adjustment
;
1352 if (SCM_LIKELY (yy
> 0))
1353 needs_adjustment
= (rr
< 0);
1355 needs_adjustment
= (rr
> 0);
1357 if (needs_adjustment
)
1359 return SCM_I_MAKINUM (rr
);
1362 else if (SCM_BIGP (y
))
1364 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1365 scm_remember_upto_here_1 (y
);
1370 SCM r
= scm_i_mkbig ();
1371 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1372 scm_remember_upto_here_1 (y
);
1373 return scm_i_normbig (r
);
1382 SCM r
= scm_i_mkbig ();
1383 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1384 scm_remember_upto_here_1 (y
);
1385 return scm_i_normbig (r
);
1388 else if (SCM_REALP (y
))
1389 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1390 else if (SCM_FRACTIONP (y
))
1391 return scm_i_exact_rational_floor_remainder (x
, y
);
1393 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1394 s_scm_floor_remainder
);
1396 else if (SCM_BIGP (x
))
1398 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1400 scm_t_inum yy
= SCM_I_INUM (y
);
1401 if (SCM_UNLIKELY (yy
== 0))
1402 scm_num_overflow (s_scm_floor_remainder
);
1407 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1409 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1410 scm_remember_upto_here_1 (x
);
1411 return SCM_I_MAKINUM (rr
);
1414 else if (SCM_BIGP (y
))
1416 SCM r
= scm_i_mkbig ();
1417 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1420 scm_remember_upto_here_2 (x
, y
);
1421 return scm_i_normbig (r
);
1423 else if (SCM_REALP (y
))
1424 return scm_i_inexact_floor_remainder
1425 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1426 else if (SCM_FRACTIONP (y
))
1427 return scm_i_exact_rational_floor_remainder (x
, y
);
1429 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1430 s_scm_floor_remainder
);
1432 else if (SCM_REALP (x
))
1434 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1435 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1436 return scm_i_inexact_floor_remainder
1437 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1439 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1440 s_scm_floor_remainder
);
1442 else if (SCM_FRACTIONP (x
))
1445 return scm_i_inexact_floor_remainder
1446 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1447 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1448 return scm_i_exact_rational_floor_remainder (x
, y
);
1450 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1451 s_scm_floor_remainder
);
1454 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1455 s_scm_floor_remainder
);
1460 scm_i_inexact_floor_remainder (double x
, double y
)
1462 /* Although it would be more efficient to use fmod here, we can't
1463 because it would in some cases produce results inconsistent with
1464 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1465 close). In particular, when x is very close to a multiple of y,
1466 then r might be either 0.0 or y, but those two cases must
1467 correspond to different choices of q. If r = 0.0 then q must be
1468 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1469 and remainder chooses the other, it would be bad. */
1470 if (SCM_UNLIKELY (y
== 0))
1471 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1473 return scm_i_from_double (x
- y
* floor (x
/ y
));
1477 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1479 SCM xd
= scm_denominator (x
);
1480 SCM yd
= scm_denominator (y
);
1481 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1482 scm_product (scm_numerator (y
), xd
));
1483 return scm_divide (r1
, scm_product (xd
, yd
));
1487 static void scm_i_inexact_floor_divide (double x
, double y
,
1489 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1492 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1494 "Return the integer @var{q} and the real number @var{r}\n"
1495 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1496 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1498 "(floor/ 123 10) @result{} 12 and 3\n"
1499 "(floor/ 123 -10) @result{} -13 and -7\n"
1500 "(floor/ -123 10) @result{} -13 and 7\n"
1501 "(floor/ -123 -10) @result{} 12 and -3\n"
1502 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1503 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1505 #define FUNC_NAME s_scm_i_floor_divide
1509 scm_floor_divide(x
, y
, &q
, &r
);
1510 return scm_values (scm_list_2 (q
, r
));
1514 #define s_scm_floor_divide s_scm_i_floor_divide
1515 #define g_scm_floor_divide g_scm_i_floor_divide
1518 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1520 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1522 scm_t_inum xx
= SCM_I_INUM (x
);
1523 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1525 scm_t_inum yy
= SCM_I_INUM (y
);
1526 if (SCM_UNLIKELY (yy
== 0))
1527 scm_num_overflow (s_scm_floor_divide
);
1530 scm_t_inum qq
= xx
/ yy
;
1531 scm_t_inum rr
= xx
% yy
;
1532 int needs_adjustment
;
1534 if (SCM_LIKELY (yy
> 0))
1535 needs_adjustment
= (rr
< 0);
1537 needs_adjustment
= (rr
> 0);
1539 if (needs_adjustment
)
1545 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1546 *qp
= SCM_I_MAKINUM (qq
);
1548 *qp
= scm_i_inum2big (qq
);
1549 *rp
= SCM_I_MAKINUM (rr
);
1553 else if (SCM_BIGP (y
))
1555 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1556 scm_remember_upto_here_1 (y
);
1561 SCM r
= scm_i_mkbig ();
1562 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1563 scm_remember_upto_here_1 (y
);
1564 *qp
= SCM_I_MAKINUM (-1);
1565 *rp
= scm_i_normbig (r
);
1580 SCM r
= scm_i_mkbig ();
1581 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1582 scm_remember_upto_here_1 (y
);
1583 *qp
= SCM_I_MAKINUM (-1);
1584 *rp
= scm_i_normbig (r
);
1588 else if (SCM_REALP (y
))
1589 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1590 else if (SCM_FRACTIONP (y
))
1591 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1593 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1594 s_scm_floor_divide
, qp
, rp
);
1596 else if (SCM_BIGP (x
))
1598 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1600 scm_t_inum yy
= SCM_I_INUM (y
);
1601 if (SCM_UNLIKELY (yy
== 0))
1602 scm_num_overflow (s_scm_floor_divide
);
1605 SCM q
= scm_i_mkbig ();
1606 SCM r
= scm_i_mkbig ();
1608 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1609 SCM_I_BIG_MPZ (x
), yy
);
1612 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1613 SCM_I_BIG_MPZ (x
), -yy
);
1614 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1616 scm_remember_upto_here_1 (x
);
1617 *qp
= scm_i_normbig (q
);
1618 *rp
= scm_i_normbig (r
);
1622 else if (SCM_BIGP (y
))
1624 SCM q
= scm_i_mkbig ();
1625 SCM r
= scm_i_mkbig ();
1626 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1627 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1628 scm_remember_upto_here_2 (x
, y
);
1629 *qp
= scm_i_normbig (q
);
1630 *rp
= scm_i_normbig (r
);
1633 else if (SCM_REALP (y
))
1634 return scm_i_inexact_floor_divide
1635 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1636 else if (SCM_FRACTIONP (y
))
1637 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1639 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1640 s_scm_floor_divide
, qp
, rp
);
1642 else if (SCM_REALP (x
))
1644 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1645 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1646 return scm_i_inexact_floor_divide
1647 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1649 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1650 s_scm_floor_divide
, qp
, rp
);
1652 else if (SCM_FRACTIONP (x
))
1655 return scm_i_inexact_floor_divide
1656 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1657 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1658 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1660 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1661 s_scm_floor_divide
, qp
, rp
);
1664 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1665 s_scm_floor_divide
, qp
, rp
);
1669 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1671 if (SCM_UNLIKELY (y
== 0))
1672 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1675 double q
= floor (x
/ y
);
1676 double r
= x
- q
* y
;
1677 *qp
= scm_i_from_double (q
);
1678 *rp
= scm_i_from_double (r
);
1683 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1686 SCM xd
= scm_denominator (x
);
1687 SCM yd
= scm_denominator (y
);
1689 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1690 scm_product (scm_numerator (y
), xd
),
1692 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1695 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1696 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1698 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1700 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1702 "(ceiling-quotient 123 10) @result{} 13\n"
1703 "(ceiling-quotient 123 -10) @result{} -12\n"
1704 "(ceiling-quotient -123 10) @result{} -12\n"
1705 "(ceiling-quotient -123 -10) @result{} 13\n"
1706 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1707 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1709 #define FUNC_NAME s_scm_ceiling_quotient
1711 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1713 scm_t_inum xx
= SCM_I_INUM (x
);
1714 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1716 scm_t_inum yy
= SCM_I_INUM (y
);
1717 if (SCM_UNLIKELY (yy
== 0))
1718 scm_num_overflow (s_scm_ceiling_quotient
);
1721 scm_t_inum xx1
= xx
;
1723 if (SCM_LIKELY (yy
> 0))
1725 if (SCM_LIKELY (xx
>= 0))
1731 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1732 return SCM_I_MAKINUM (qq
);
1734 return scm_i_inum2big (qq
);
1737 else if (SCM_BIGP (y
))
1739 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1740 scm_remember_upto_here_1 (y
);
1741 if (SCM_LIKELY (sign
> 0))
1743 if (SCM_LIKELY (xx
> 0))
1745 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1746 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1747 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1749 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1750 scm_remember_upto_here_1 (y
);
1751 return SCM_I_MAKINUM (-1);
1761 else if (SCM_REALP (y
))
1762 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1763 else if (SCM_FRACTIONP (y
))
1764 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1766 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1767 s_scm_ceiling_quotient
);
1769 else if (SCM_BIGP (x
))
1771 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1773 scm_t_inum yy
= SCM_I_INUM (y
);
1774 if (SCM_UNLIKELY (yy
== 0))
1775 scm_num_overflow (s_scm_ceiling_quotient
);
1776 else if (SCM_UNLIKELY (yy
== 1))
1780 SCM q
= scm_i_mkbig ();
1782 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1785 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1786 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1788 scm_remember_upto_here_1 (x
);
1789 return scm_i_normbig (q
);
1792 else if (SCM_BIGP (y
))
1794 SCM q
= scm_i_mkbig ();
1795 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1798 scm_remember_upto_here_2 (x
, y
);
1799 return scm_i_normbig (q
);
1801 else if (SCM_REALP (y
))
1802 return scm_i_inexact_ceiling_quotient
1803 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1804 else if (SCM_FRACTIONP (y
))
1805 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1807 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1808 s_scm_ceiling_quotient
);
1810 else if (SCM_REALP (x
))
1812 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1813 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1814 return scm_i_inexact_ceiling_quotient
1815 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1817 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1818 s_scm_ceiling_quotient
);
1820 else if (SCM_FRACTIONP (x
))
1823 return scm_i_inexact_ceiling_quotient
1824 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1825 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1826 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1828 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1829 s_scm_ceiling_quotient
);
1832 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1833 s_scm_ceiling_quotient
);
1838 scm_i_inexact_ceiling_quotient (double x
, double y
)
1840 if (SCM_UNLIKELY (y
== 0))
1841 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1843 return scm_i_from_double (ceil (x
/ y
));
1847 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1849 return scm_ceiling_quotient
1850 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1851 scm_product (scm_numerator (y
), scm_denominator (x
)));
1854 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1855 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1857 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1859 "Return the real number @var{r} such that\n"
1860 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1861 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1863 "(ceiling-remainder 123 10) @result{} -7\n"
1864 "(ceiling-remainder 123 -10) @result{} 3\n"
1865 "(ceiling-remainder -123 10) @result{} -3\n"
1866 "(ceiling-remainder -123 -10) @result{} 7\n"
1867 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1868 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1870 #define FUNC_NAME s_scm_ceiling_remainder
1872 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1874 scm_t_inum xx
= SCM_I_INUM (x
);
1875 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1877 scm_t_inum yy
= SCM_I_INUM (y
);
1878 if (SCM_UNLIKELY (yy
== 0))
1879 scm_num_overflow (s_scm_ceiling_remainder
);
1882 scm_t_inum rr
= xx
% yy
;
1883 int needs_adjustment
;
1885 if (SCM_LIKELY (yy
> 0))
1886 needs_adjustment
= (rr
> 0);
1888 needs_adjustment
= (rr
< 0);
1890 if (needs_adjustment
)
1892 return SCM_I_MAKINUM (rr
);
1895 else if (SCM_BIGP (y
))
1897 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1898 scm_remember_upto_here_1 (y
);
1899 if (SCM_LIKELY (sign
> 0))
1901 if (SCM_LIKELY (xx
> 0))
1903 SCM r
= scm_i_mkbig ();
1904 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1905 scm_remember_upto_here_1 (y
);
1906 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1907 return scm_i_normbig (r
);
1909 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1910 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1911 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1913 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1914 scm_remember_upto_here_1 (y
);
1924 SCM r
= scm_i_mkbig ();
1925 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1926 scm_remember_upto_here_1 (y
);
1927 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1928 return scm_i_normbig (r
);
1931 else if (SCM_REALP (y
))
1932 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1933 else if (SCM_FRACTIONP (y
))
1934 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1936 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1937 s_scm_ceiling_remainder
);
1939 else if (SCM_BIGP (x
))
1941 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1943 scm_t_inum yy
= SCM_I_INUM (y
);
1944 if (SCM_UNLIKELY (yy
== 0))
1945 scm_num_overflow (s_scm_ceiling_remainder
);
1950 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1952 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1953 scm_remember_upto_here_1 (x
);
1954 return SCM_I_MAKINUM (rr
);
1957 else if (SCM_BIGP (y
))
1959 SCM r
= scm_i_mkbig ();
1960 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1963 scm_remember_upto_here_2 (x
, y
);
1964 return scm_i_normbig (r
);
1966 else if (SCM_REALP (y
))
1967 return scm_i_inexact_ceiling_remainder
1968 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1969 else if (SCM_FRACTIONP (y
))
1970 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1972 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1973 s_scm_ceiling_remainder
);
1975 else if (SCM_REALP (x
))
1977 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1978 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1979 return scm_i_inexact_ceiling_remainder
1980 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1982 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1983 s_scm_ceiling_remainder
);
1985 else if (SCM_FRACTIONP (x
))
1988 return scm_i_inexact_ceiling_remainder
1989 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1990 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1991 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1993 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1994 s_scm_ceiling_remainder
);
1997 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1998 s_scm_ceiling_remainder
);
2003 scm_i_inexact_ceiling_remainder (double x
, double y
)
2005 /* Although it would be more efficient to use fmod here, we can't
2006 because it would in some cases produce results inconsistent with
2007 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2008 close). In particular, when x is very close to a multiple of y,
2009 then r might be either 0.0 or -y, but those two cases must
2010 correspond to different choices of q. If r = 0.0 then q must be
2011 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2012 and remainder chooses the other, it would be bad. */
2013 if (SCM_UNLIKELY (y
== 0))
2014 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2016 return scm_i_from_double (x
- y
* ceil (x
/ y
));
2020 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2022 SCM xd
= scm_denominator (x
);
2023 SCM yd
= scm_denominator (y
);
2024 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2025 scm_product (scm_numerator (y
), xd
));
2026 return scm_divide (r1
, scm_product (xd
, yd
));
2029 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2031 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2034 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2036 "Return the integer @var{q} and the real number @var{r}\n"
2037 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2038 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2040 "(ceiling/ 123 10) @result{} 13 and -7\n"
2041 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2042 "(ceiling/ -123 10) @result{} -12 and -3\n"
2043 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2044 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2045 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2047 #define FUNC_NAME s_scm_i_ceiling_divide
2051 scm_ceiling_divide(x
, y
, &q
, &r
);
2052 return scm_values (scm_list_2 (q
, r
));
2056 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2057 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2060 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2062 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2064 scm_t_inum xx
= SCM_I_INUM (x
);
2065 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2067 scm_t_inum yy
= SCM_I_INUM (y
);
2068 if (SCM_UNLIKELY (yy
== 0))
2069 scm_num_overflow (s_scm_ceiling_divide
);
2072 scm_t_inum qq
= xx
/ yy
;
2073 scm_t_inum rr
= xx
% yy
;
2074 int needs_adjustment
;
2076 if (SCM_LIKELY (yy
> 0))
2077 needs_adjustment
= (rr
> 0);
2079 needs_adjustment
= (rr
< 0);
2081 if (needs_adjustment
)
2086 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2087 *qp
= SCM_I_MAKINUM (qq
);
2089 *qp
= scm_i_inum2big (qq
);
2090 *rp
= SCM_I_MAKINUM (rr
);
2094 else if (SCM_BIGP (y
))
2096 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2097 scm_remember_upto_here_1 (y
);
2098 if (SCM_LIKELY (sign
> 0))
2100 if (SCM_LIKELY (xx
> 0))
2102 SCM r
= scm_i_mkbig ();
2103 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2104 scm_remember_upto_here_1 (y
);
2105 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2107 *rp
= scm_i_normbig (r
);
2109 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2110 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2111 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2113 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2114 scm_remember_upto_here_1 (y
);
2115 *qp
= SCM_I_MAKINUM (-1);
2131 SCM r
= scm_i_mkbig ();
2132 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2133 scm_remember_upto_here_1 (y
);
2134 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2136 *rp
= scm_i_normbig (r
);
2140 else if (SCM_REALP (y
))
2141 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2142 else if (SCM_FRACTIONP (y
))
2143 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2145 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2146 s_scm_ceiling_divide
, qp
, rp
);
2148 else if (SCM_BIGP (x
))
2150 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2152 scm_t_inum yy
= SCM_I_INUM (y
);
2153 if (SCM_UNLIKELY (yy
== 0))
2154 scm_num_overflow (s_scm_ceiling_divide
);
2157 SCM q
= scm_i_mkbig ();
2158 SCM r
= scm_i_mkbig ();
2160 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2161 SCM_I_BIG_MPZ (x
), yy
);
2164 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2165 SCM_I_BIG_MPZ (x
), -yy
);
2166 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2168 scm_remember_upto_here_1 (x
);
2169 *qp
= scm_i_normbig (q
);
2170 *rp
= scm_i_normbig (r
);
2174 else if (SCM_BIGP (y
))
2176 SCM q
= scm_i_mkbig ();
2177 SCM r
= scm_i_mkbig ();
2178 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2179 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2180 scm_remember_upto_here_2 (x
, y
);
2181 *qp
= scm_i_normbig (q
);
2182 *rp
= scm_i_normbig (r
);
2185 else if (SCM_REALP (y
))
2186 return scm_i_inexact_ceiling_divide
2187 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2188 else if (SCM_FRACTIONP (y
))
2189 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2191 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2192 s_scm_ceiling_divide
, qp
, rp
);
2194 else if (SCM_REALP (x
))
2196 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2197 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2198 return scm_i_inexact_ceiling_divide
2199 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2201 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2202 s_scm_ceiling_divide
, qp
, rp
);
2204 else if (SCM_FRACTIONP (x
))
2207 return scm_i_inexact_ceiling_divide
2208 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2209 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2210 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2212 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2213 s_scm_ceiling_divide
, qp
, rp
);
2216 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2217 s_scm_ceiling_divide
, qp
, rp
);
2221 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2223 if (SCM_UNLIKELY (y
== 0))
2224 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2227 double q
= ceil (x
/ y
);
2228 double r
= x
- q
* y
;
2229 *qp
= scm_i_from_double (q
);
2230 *rp
= scm_i_from_double (r
);
2235 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2238 SCM xd
= scm_denominator (x
);
2239 SCM yd
= scm_denominator (y
);
2241 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2242 scm_product (scm_numerator (y
), xd
),
2244 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2247 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2248 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2250 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2252 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2254 "(truncate-quotient 123 10) @result{} 12\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.2 -63.5) @result{} 1.0\n"
2259 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2261 #define FUNC_NAME s_scm_truncate_quotient
2263 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2265 scm_t_inum xx
= SCM_I_INUM (x
);
2266 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2268 scm_t_inum yy
= SCM_I_INUM (y
);
2269 if (SCM_UNLIKELY (yy
== 0))
2270 scm_num_overflow (s_scm_truncate_quotient
);
2273 scm_t_inum qq
= xx
/ yy
;
2274 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2275 return SCM_I_MAKINUM (qq
);
2277 return scm_i_inum2big (qq
);
2280 else if (SCM_BIGP (y
))
2282 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2283 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2284 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2286 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2287 scm_remember_upto_here_1 (y
);
2288 return SCM_I_MAKINUM (-1);
2293 else if (SCM_REALP (y
))
2294 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2295 else if (SCM_FRACTIONP (y
))
2296 return scm_i_exact_rational_truncate_quotient (x
, y
);
2298 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2299 s_scm_truncate_quotient
);
2301 else if (SCM_BIGP (x
))
2303 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2305 scm_t_inum yy
= SCM_I_INUM (y
);
2306 if (SCM_UNLIKELY (yy
== 0))
2307 scm_num_overflow (s_scm_truncate_quotient
);
2308 else if (SCM_UNLIKELY (yy
== 1))
2312 SCM q
= scm_i_mkbig ();
2314 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2317 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2318 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2320 scm_remember_upto_here_1 (x
);
2321 return scm_i_normbig (q
);
2324 else if (SCM_BIGP (y
))
2326 SCM q
= scm_i_mkbig ();
2327 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2330 scm_remember_upto_here_2 (x
, y
);
2331 return scm_i_normbig (q
);
2333 else if (SCM_REALP (y
))
2334 return scm_i_inexact_truncate_quotient
2335 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2336 else if (SCM_FRACTIONP (y
))
2337 return scm_i_exact_rational_truncate_quotient (x
, y
);
2339 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2340 s_scm_truncate_quotient
);
2342 else if (SCM_REALP (x
))
2344 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2345 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2346 return scm_i_inexact_truncate_quotient
2347 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2349 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2350 s_scm_truncate_quotient
);
2352 else if (SCM_FRACTIONP (x
))
2355 return scm_i_inexact_truncate_quotient
2356 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2357 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2358 return scm_i_exact_rational_truncate_quotient (x
, y
);
2360 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2361 s_scm_truncate_quotient
);
2364 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2365 s_scm_truncate_quotient
);
2370 scm_i_inexact_truncate_quotient (double x
, double y
)
2372 if (SCM_UNLIKELY (y
== 0))
2373 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2375 return scm_i_from_double (trunc (x
/ y
));
2379 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2381 return scm_truncate_quotient
2382 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2383 scm_product (scm_numerator (y
), scm_denominator (x
)));
2386 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2387 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2389 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2391 "Return the real number @var{r} such that\n"
2392 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2393 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2395 "(truncate-remainder 123 10) @result{} 3\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.2 -63.5) @result{} -59.7\n"
2400 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2402 #define FUNC_NAME s_scm_truncate_remainder
2404 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2406 scm_t_inum xx
= SCM_I_INUM (x
);
2407 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2409 scm_t_inum yy
= SCM_I_INUM (y
);
2410 if (SCM_UNLIKELY (yy
== 0))
2411 scm_num_overflow (s_scm_truncate_remainder
);
2413 return SCM_I_MAKINUM (xx
% yy
);
2415 else if (SCM_BIGP (y
))
2417 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2418 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2419 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2421 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2422 scm_remember_upto_here_1 (y
);
2428 else if (SCM_REALP (y
))
2429 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2430 else if (SCM_FRACTIONP (y
))
2431 return scm_i_exact_rational_truncate_remainder (x
, y
);
2433 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2434 s_scm_truncate_remainder
);
2436 else if (SCM_BIGP (x
))
2438 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2440 scm_t_inum yy
= SCM_I_INUM (y
);
2441 if (SCM_UNLIKELY (yy
== 0))
2442 scm_num_overflow (s_scm_truncate_remainder
);
2445 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2446 (yy
> 0) ? yy
: -yy
)
2447 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2448 scm_remember_upto_here_1 (x
);
2449 return SCM_I_MAKINUM (rr
);
2452 else if (SCM_BIGP (y
))
2454 SCM r
= scm_i_mkbig ();
2455 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2458 scm_remember_upto_here_2 (x
, y
);
2459 return scm_i_normbig (r
);
2461 else if (SCM_REALP (y
))
2462 return scm_i_inexact_truncate_remainder
2463 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2464 else if (SCM_FRACTIONP (y
))
2465 return scm_i_exact_rational_truncate_remainder (x
, y
);
2467 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2468 s_scm_truncate_remainder
);
2470 else if (SCM_REALP (x
))
2472 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2473 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2474 return scm_i_inexact_truncate_remainder
2475 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2477 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2478 s_scm_truncate_remainder
);
2480 else if (SCM_FRACTIONP (x
))
2483 return scm_i_inexact_truncate_remainder
2484 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2485 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2486 return scm_i_exact_rational_truncate_remainder (x
, y
);
2488 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2489 s_scm_truncate_remainder
);
2492 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2493 s_scm_truncate_remainder
);
2498 scm_i_inexact_truncate_remainder (double x
, double y
)
2500 /* Although it would be more efficient to use fmod here, we can't
2501 because it would in some cases produce results inconsistent with
2502 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2503 close). In particular, when x is very close to a multiple of y,
2504 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2505 correspond to different choices of q. If quotient chooses one and
2506 remainder chooses the other, it would be bad. */
2507 if (SCM_UNLIKELY (y
== 0))
2508 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2510 return scm_i_from_double (x
- y
* trunc (x
/ y
));
2514 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2516 SCM xd
= scm_denominator (x
);
2517 SCM yd
= scm_denominator (y
);
2518 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2519 scm_product (scm_numerator (y
), xd
));
2520 return scm_divide (r1
, scm_product (xd
, yd
));
2524 static void scm_i_inexact_truncate_divide (double x
, double y
,
2526 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2529 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2531 "Return the integer @var{q} and the real number @var{r}\n"
2532 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2533 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2535 "(truncate/ 123 10) @result{} 12 and 3\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.2 -63.5) @result{} 1.0 and -59.7\n"
2540 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2542 #define FUNC_NAME s_scm_i_truncate_divide
2546 scm_truncate_divide(x
, y
, &q
, &r
);
2547 return scm_values (scm_list_2 (q
, r
));
2551 #define s_scm_truncate_divide s_scm_i_truncate_divide
2552 #define g_scm_truncate_divide g_scm_i_truncate_divide
2555 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2557 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2559 scm_t_inum xx
= SCM_I_INUM (x
);
2560 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2562 scm_t_inum yy
= SCM_I_INUM (y
);
2563 if (SCM_UNLIKELY (yy
== 0))
2564 scm_num_overflow (s_scm_truncate_divide
);
2567 scm_t_inum qq
= xx
/ yy
;
2568 scm_t_inum rr
= xx
% yy
;
2569 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2570 *qp
= SCM_I_MAKINUM (qq
);
2572 *qp
= scm_i_inum2big (qq
);
2573 *rp
= SCM_I_MAKINUM (rr
);
2577 else if (SCM_BIGP (y
))
2579 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2580 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2581 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2583 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2584 scm_remember_upto_here_1 (y
);
2585 *qp
= SCM_I_MAKINUM (-1);
2595 else if (SCM_REALP (y
))
2596 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2597 else if (SCM_FRACTIONP (y
))
2598 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2600 return two_valued_wta_dispatch_2
2601 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2602 s_scm_truncate_divide
, qp
, rp
);
2604 else if (SCM_BIGP (x
))
2606 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2608 scm_t_inum yy
= SCM_I_INUM (y
);
2609 if (SCM_UNLIKELY (yy
== 0))
2610 scm_num_overflow (s_scm_truncate_divide
);
2613 SCM q
= scm_i_mkbig ();
2616 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2617 SCM_I_BIG_MPZ (x
), yy
);
2620 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2621 SCM_I_BIG_MPZ (x
), -yy
);
2622 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2624 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2625 scm_remember_upto_here_1 (x
);
2626 *qp
= scm_i_normbig (q
);
2627 *rp
= SCM_I_MAKINUM (rr
);
2631 else if (SCM_BIGP (y
))
2633 SCM q
= scm_i_mkbig ();
2634 SCM r
= scm_i_mkbig ();
2635 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2636 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2637 scm_remember_upto_here_2 (x
, y
);
2638 *qp
= scm_i_normbig (q
);
2639 *rp
= scm_i_normbig (r
);
2641 else if (SCM_REALP (y
))
2642 return scm_i_inexact_truncate_divide
2643 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2644 else if (SCM_FRACTIONP (y
))
2645 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2647 return two_valued_wta_dispatch_2
2648 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2649 s_scm_truncate_divide
, qp
, rp
);
2651 else if (SCM_REALP (x
))
2653 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2654 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2655 return scm_i_inexact_truncate_divide
2656 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2658 return two_valued_wta_dispatch_2
2659 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2660 s_scm_truncate_divide
, qp
, rp
);
2662 else if (SCM_FRACTIONP (x
))
2665 return scm_i_inexact_truncate_divide
2666 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2667 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2668 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2670 return two_valued_wta_dispatch_2
2671 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2672 s_scm_truncate_divide
, qp
, rp
);
2675 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2676 s_scm_truncate_divide
, qp
, rp
);
2680 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2682 if (SCM_UNLIKELY (y
== 0))
2683 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2686 double q
= trunc (x
/ y
);
2687 double r
= x
- q
* y
;
2688 *qp
= scm_i_from_double (q
);
2689 *rp
= scm_i_from_double (r
);
2694 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2697 SCM xd
= scm_denominator (x
);
2698 SCM yd
= scm_denominator (y
);
2700 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2701 scm_product (scm_numerator (y
), xd
),
2703 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2706 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2707 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2708 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2710 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2712 "Return the integer @var{q} such that\n"
2713 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2714 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2716 "(centered-quotient 123 10) @result{} 12\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.2 -63.5) @result{} 2.0\n"
2721 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2723 #define FUNC_NAME s_scm_centered_quotient
2725 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2727 scm_t_inum xx
= SCM_I_INUM (x
);
2728 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2730 scm_t_inum yy
= SCM_I_INUM (y
);
2731 if (SCM_UNLIKELY (yy
== 0))
2732 scm_num_overflow (s_scm_centered_quotient
);
2735 scm_t_inum qq
= xx
/ yy
;
2736 scm_t_inum rr
= xx
% yy
;
2737 if (SCM_LIKELY (xx
> 0))
2739 if (SCM_LIKELY (yy
> 0))
2741 if (rr
>= (yy
+ 1) / 2)
2746 if (rr
>= (1 - yy
) / 2)
2752 if (SCM_LIKELY (yy
> 0))
2763 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2764 return SCM_I_MAKINUM (qq
);
2766 return scm_i_inum2big (qq
);
2769 else if (SCM_BIGP (y
))
2771 /* Pass a denormalized bignum version of x (even though it
2772 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2773 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2775 else if (SCM_REALP (y
))
2776 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2777 else if (SCM_FRACTIONP (y
))
2778 return scm_i_exact_rational_centered_quotient (x
, y
);
2780 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2781 s_scm_centered_quotient
);
2783 else if (SCM_BIGP (x
))
2785 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2787 scm_t_inum yy
= SCM_I_INUM (y
);
2788 if (SCM_UNLIKELY (yy
== 0))
2789 scm_num_overflow (s_scm_centered_quotient
);
2790 else if (SCM_UNLIKELY (yy
== 1))
2794 SCM q
= scm_i_mkbig ();
2796 /* Arrange for rr to initially be non-positive,
2797 because that simplifies the test to see
2798 if it is within the needed bounds. */
2801 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2802 SCM_I_BIG_MPZ (x
), yy
);
2803 scm_remember_upto_here_1 (x
);
2805 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2806 SCM_I_BIG_MPZ (q
), 1);
2810 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2811 SCM_I_BIG_MPZ (x
), -yy
);
2812 scm_remember_upto_here_1 (x
);
2813 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2815 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2816 SCM_I_BIG_MPZ (q
), 1);
2818 return scm_i_normbig (q
);
2821 else if (SCM_BIGP (y
))
2822 return scm_i_bigint_centered_quotient (x
, y
);
2823 else if (SCM_REALP (y
))
2824 return scm_i_inexact_centered_quotient
2825 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2826 else if (SCM_FRACTIONP (y
))
2827 return scm_i_exact_rational_centered_quotient (x
, y
);
2829 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2830 s_scm_centered_quotient
);
2832 else if (SCM_REALP (x
))
2834 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2835 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2836 return scm_i_inexact_centered_quotient
2837 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2839 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2840 s_scm_centered_quotient
);
2842 else if (SCM_FRACTIONP (x
))
2845 return scm_i_inexact_centered_quotient
2846 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2847 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2848 return scm_i_exact_rational_centered_quotient (x
, y
);
2850 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2851 s_scm_centered_quotient
);
2854 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2855 s_scm_centered_quotient
);
2860 scm_i_inexact_centered_quotient (double x
, double y
)
2862 if (SCM_LIKELY (y
> 0))
2863 return scm_i_from_double (floor (x
/y
+ 0.5));
2864 else if (SCM_LIKELY (y
< 0))
2865 return scm_i_from_double (ceil (x
/y
- 0.5));
2867 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2872 /* Assumes that both x and y are bigints, though
2873 x might be able to fit into a fixnum. */
2875 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2879 /* Note that x might be small enough to fit into a
2880 fixnum, so we must not let it escape into the wild */
2884 /* min_r will eventually become -abs(y)/2 */
2885 min_r
= scm_i_mkbig ();
2886 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2887 SCM_I_BIG_MPZ (y
), 1);
2889 /* Arrange for rr to initially be non-positive,
2890 because that simplifies the test to see
2891 if it is within the needed bounds. */
2892 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2894 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2895 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2896 scm_remember_upto_here_2 (x
, y
);
2897 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2898 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2899 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2900 SCM_I_BIG_MPZ (q
), 1);
2904 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2905 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2906 scm_remember_upto_here_2 (x
, y
);
2907 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2908 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2909 SCM_I_BIG_MPZ (q
), 1);
2911 scm_remember_upto_here_2 (r
, min_r
);
2912 return scm_i_normbig (q
);
2916 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2918 return scm_centered_quotient
2919 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2920 scm_product (scm_numerator (y
), scm_denominator (x
)));
2923 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2924 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2925 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2927 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2929 "Return the real number @var{r} such that\n"
2930 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2931 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2932 "for some integer @var{q}.\n"
2934 "(centered-remainder 123 10) @result{} 3\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.2 -63.5) @result{} 3.8\n"
2939 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2941 #define FUNC_NAME s_scm_centered_remainder
2943 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2945 scm_t_inum xx
= SCM_I_INUM (x
);
2946 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2948 scm_t_inum yy
= SCM_I_INUM (y
);
2949 if (SCM_UNLIKELY (yy
== 0))
2950 scm_num_overflow (s_scm_centered_remainder
);
2953 scm_t_inum rr
= xx
% yy
;
2954 if (SCM_LIKELY (xx
> 0))
2956 if (SCM_LIKELY (yy
> 0))
2958 if (rr
>= (yy
+ 1) / 2)
2963 if (rr
>= (1 - yy
) / 2)
2969 if (SCM_LIKELY (yy
> 0))
2980 return SCM_I_MAKINUM (rr
);
2983 else if (SCM_BIGP (y
))
2985 /* Pass a denormalized bignum version of x (even though it
2986 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2987 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2989 else if (SCM_REALP (y
))
2990 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2991 else if (SCM_FRACTIONP (y
))
2992 return scm_i_exact_rational_centered_remainder (x
, y
);
2994 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2995 s_scm_centered_remainder
);
2997 else if (SCM_BIGP (x
))
2999 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3001 scm_t_inum yy
= SCM_I_INUM (y
);
3002 if (SCM_UNLIKELY (yy
== 0))
3003 scm_num_overflow (s_scm_centered_remainder
);
3007 /* Arrange for rr to initially be non-positive,
3008 because that simplifies the test to see
3009 if it is within the needed bounds. */
3012 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3013 scm_remember_upto_here_1 (x
);
3019 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3020 scm_remember_upto_here_1 (x
);
3024 return SCM_I_MAKINUM (rr
);
3027 else if (SCM_BIGP (y
))
3028 return scm_i_bigint_centered_remainder (x
, y
);
3029 else if (SCM_REALP (y
))
3030 return scm_i_inexact_centered_remainder
3031 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3032 else if (SCM_FRACTIONP (y
))
3033 return scm_i_exact_rational_centered_remainder (x
, y
);
3035 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3036 s_scm_centered_remainder
);
3038 else if (SCM_REALP (x
))
3040 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3041 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3042 return scm_i_inexact_centered_remainder
3043 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3045 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3046 s_scm_centered_remainder
);
3048 else if (SCM_FRACTIONP (x
))
3051 return scm_i_inexact_centered_remainder
3052 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3053 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3054 return scm_i_exact_rational_centered_remainder (x
, y
);
3056 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3057 s_scm_centered_remainder
);
3060 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3061 s_scm_centered_remainder
);
3066 scm_i_inexact_centered_remainder (double x
, double y
)
3070 /* Although it would be more efficient to use fmod here, we can't
3071 because it would in some cases produce results inconsistent with
3072 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3073 close). In particular, when x-y/2 is very close to a multiple of
3074 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3075 two cases must correspond to different choices of q. If quotient
3076 chooses one and remainder chooses the other, it would be bad. */
3077 if (SCM_LIKELY (y
> 0))
3078 q
= floor (x
/y
+ 0.5);
3079 else if (SCM_LIKELY (y
< 0))
3080 q
= ceil (x
/y
- 0.5);
3082 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3085 return scm_i_from_double (x
- q
* y
);
3088 /* Assumes that both x and y are bigints, though
3089 x might be able to fit into a fixnum. */
3091 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3095 /* Note that x might be small enough to fit into a
3096 fixnum, so we must not let it escape into the wild */
3099 /* min_r will eventually become -abs(y)/2 */
3100 min_r
= scm_i_mkbig ();
3101 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3102 SCM_I_BIG_MPZ (y
), 1);
3104 /* Arrange for rr to initially be non-positive,
3105 because that simplifies the test to see
3106 if it is within the needed bounds. */
3107 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3109 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3110 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3111 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3112 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3113 mpz_add (SCM_I_BIG_MPZ (r
),
3119 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3120 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3121 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3122 mpz_sub (SCM_I_BIG_MPZ (r
),
3126 scm_remember_upto_here_2 (x
, y
);
3127 return scm_i_normbig (r
);
3131 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3133 SCM xd
= scm_denominator (x
);
3134 SCM yd
= scm_denominator (y
);
3135 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3136 scm_product (scm_numerator (y
), xd
));
3137 return scm_divide (r1
, scm_product (xd
, yd
));
3141 static void scm_i_inexact_centered_divide (double x
, double y
,
3143 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3144 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3147 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3149 "Return the integer @var{q} and the real number @var{r}\n"
3150 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3151 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3153 "(centered/ 123 10) @result{} 12 and 3\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.2 -63.5) @result{} 2.0 and 3.8\n"
3158 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3160 #define FUNC_NAME s_scm_i_centered_divide
3164 scm_centered_divide(x
, y
, &q
, &r
);
3165 return scm_values (scm_list_2 (q
, r
));
3169 #define s_scm_centered_divide s_scm_i_centered_divide
3170 #define g_scm_centered_divide g_scm_i_centered_divide
3173 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3175 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3177 scm_t_inum xx
= SCM_I_INUM (x
);
3178 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3180 scm_t_inum yy
= SCM_I_INUM (y
);
3181 if (SCM_UNLIKELY (yy
== 0))
3182 scm_num_overflow (s_scm_centered_divide
);
3185 scm_t_inum qq
= xx
/ yy
;
3186 scm_t_inum rr
= xx
% yy
;
3187 if (SCM_LIKELY (xx
> 0))
3189 if (SCM_LIKELY (yy
> 0))
3191 if (rr
>= (yy
+ 1) / 2)
3196 if (rr
>= (1 - yy
) / 2)
3202 if (SCM_LIKELY (yy
> 0))
3213 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3214 *qp
= SCM_I_MAKINUM (qq
);
3216 *qp
= scm_i_inum2big (qq
);
3217 *rp
= SCM_I_MAKINUM (rr
);
3221 else if (SCM_BIGP (y
))
3223 /* Pass a denormalized bignum version of x (even though it
3224 can fit in a fixnum) to scm_i_bigint_centered_divide */
3225 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3227 else if (SCM_REALP (y
))
3228 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3229 else if (SCM_FRACTIONP (y
))
3230 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3232 return two_valued_wta_dispatch_2
3233 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3234 s_scm_centered_divide
, qp
, rp
);
3236 else if (SCM_BIGP (x
))
3238 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3240 scm_t_inum yy
= SCM_I_INUM (y
);
3241 if (SCM_UNLIKELY (yy
== 0))
3242 scm_num_overflow (s_scm_centered_divide
);
3245 SCM q
= scm_i_mkbig ();
3247 /* Arrange for rr to initially be non-positive,
3248 because that simplifies the test to see
3249 if it is within the needed bounds. */
3252 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3253 SCM_I_BIG_MPZ (x
), yy
);
3254 scm_remember_upto_here_1 (x
);
3257 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3258 SCM_I_BIG_MPZ (q
), 1);
3264 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3265 SCM_I_BIG_MPZ (x
), -yy
);
3266 scm_remember_upto_here_1 (x
);
3267 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3270 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3271 SCM_I_BIG_MPZ (q
), 1);
3275 *qp
= scm_i_normbig (q
);
3276 *rp
= SCM_I_MAKINUM (rr
);
3280 else if (SCM_BIGP (y
))
3281 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3282 else if (SCM_REALP (y
))
3283 return scm_i_inexact_centered_divide
3284 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3285 else if (SCM_FRACTIONP (y
))
3286 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3288 return two_valued_wta_dispatch_2
3289 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3290 s_scm_centered_divide
, qp
, rp
);
3292 else if (SCM_REALP (x
))
3294 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3295 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3296 return scm_i_inexact_centered_divide
3297 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3299 return two_valued_wta_dispatch_2
3300 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3301 s_scm_centered_divide
, qp
, rp
);
3303 else if (SCM_FRACTIONP (x
))
3306 return scm_i_inexact_centered_divide
3307 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3308 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3309 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3311 return two_valued_wta_dispatch_2
3312 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3313 s_scm_centered_divide
, qp
, rp
);
3316 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3317 s_scm_centered_divide
, qp
, rp
);
3321 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3325 if (SCM_LIKELY (y
> 0))
3326 q
= floor (x
/y
+ 0.5);
3327 else if (SCM_LIKELY (y
< 0))
3328 q
= ceil (x
/y
- 0.5);
3330 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3334 *qp
= scm_i_from_double (q
);
3335 *rp
= scm_i_from_double (r
);
3338 /* Assumes that both x and y are bigints, though
3339 x might be able to fit into a fixnum. */
3341 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3345 /* Note that x might be small enough to fit into a
3346 fixnum, so we must not let it escape into the wild */
3350 /* min_r will eventually become -abs(y/2) */
3351 min_r
= scm_i_mkbig ();
3352 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3353 SCM_I_BIG_MPZ (y
), 1);
3355 /* Arrange for rr to initially be non-positive,
3356 because that simplifies the test to see
3357 if it is within the needed bounds. */
3358 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3360 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3361 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3362 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3363 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3365 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3366 SCM_I_BIG_MPZ (q
), 1);
3367 mpz_add (SCM_I_BIG_MPZ (r
),
3374 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3375 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3376 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3378 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3379 SCM_I_BIG_MPZ (q
), 1);
3380 mpz_sub (SCM_I_BIG_MPZ (r
),
3385 scm_remember_upto_here_2 (x
, y
);
3386 *qp
= scm_i_normbig (q
);
3387 *rp
= scm_i_normbig (r
);
3391 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3394 SCM xd
= scm_denominator (x
);
3395 SCM yd
= scm_denominator (y
);
3397 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3398 scm_product (scm_numerator (y
), xd
),
3400 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3403 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3404 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3405 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3407 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3409 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3410 "with ties going to the nearest even integer.\n"
3412 "(round-quotient 123 10) @result{} 12\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 125 10) @result{} 12\n"
3417 "(round-quotient 127 10) @result{} 13\n"
3418 "(round-quotient 135 10) @result{} 14\n"
3419 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3420 "(round-quotient 16/3 -10/7) @result{} -4\n"
3422 #define FUNC_NAME s_scm_round_quotient
3424 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3426 scm_t_inum xx
= SCM_I_INUM (x
);
3427 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3429 scm_t_inum yy
= SCM_I_INUM (y
);
3430 if (SCM_UNLIKELY (yy
== 0))
3431 scm_num_overflow (s_scm_round_quotient
);
3434 scm_t_inum qq
= xx
/ yy
;
3435 scm_t_inum rr
= xx
% yy
;
3437 scm_t_inum r2
= 2 * rr
;
3439 if (SCM_LIKELY (yy
< 0))
3459 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3460 return SCM_I_MAKINUM (qq
);
3462 return scm_i_inum2big (qq
);
3465 else if (SCM_BIGP (y
))
3467 /* Pass a denormalized bignum version of x (even though it
3468 can fit in a fixnum) to scm_i_bigint_round_quotient */
3469 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3471 else if (SCM_REALP (y
))
3472 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3473 else if (SCM_FRACTIONP (y
))
3474 return scm_i_exact_rational_round_quotient (x
, y
);
3476 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3477 s_scm_round_quotient
);
3479 else if (SCM_BIGP (x
))
3481 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3483 scm_t_inum yy
= SCM_I_INUM (y
);
3484 if (SCM_UNLIKELY (yy
== 0))
3485 scm_num_overflow (s_scm_round_quotient
);
3486 else if (SCM_UNLIKELY (yy
== 1))
3490 SCM q
= scm_i_mkbig ();
3492 int needs_adjustment
;
3496 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3497 SCM_I_BIG_MPZ (x
), yy
);
3498 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3499 needs_adjustment
= (2*rr
>= yy
);
3501 needs_adjustment
= (2*rr
> yy
);
3505 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3506 SCM_I_BIG_MPZ (x
), -yy
);
3507 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3508 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3509 needs_adjustment
= (2*rr
<= yy
);
3511 needs_adjustment
= (2*rr
< yy
);
3513 scm_remember_upto_here_1 (x
);
3514 if (needs_adjustment
)
3515 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3516 return scm_i_normbig (q
);
3519 else if (SCM_BIGP (y
))
3520 return scm_i_bigint_round_quotient (x
, y
);
3521 else if (SCM_REALP (y
))
3522 return scm_i_inexact_round_quotient
3523 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3524 else if (SCM_FRACTIONP (y
))
3525 return scm_i_exact_rational_round_quotient (x
, y
);
3527 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3528 s_scm_round_quotient
);
3530 else if (SCM_REALP (x
))
3532 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3533 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3534 return scm_i_inexact_round_quotient
3535 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3537 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3538 s_scm_round_quotient
);
3540 else if (SCM_FRACTIONP (x
))
3543 return scm_i_inexact_round_quotient
3544 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3545 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3546 return scm_i_exact_rational_round_quotient (x
, y
);
3548 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3549 s_scm_round_quotient
);
3552 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3553 s_scm_round_quotient
);
3558 scm_i_inexact_round_quotient (double x
, double y
)
3560 if (SCM_UNLIKELY (y
== 0))
3561 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3563 return scm_i_from_double (scm_c_round (x
/ y
));
3566 /* Assumes that both x and y are bigints, though
3567 x might be able to fit into a fixnum. */
3569 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3572 int cmp
, needs_adjustment
;
3574 /* Note that x might be small enough to fit into a
3575 fixnum, so we must not let it escape into the wild */
3578 r2
= scm_i_mkbig ();
3580 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3581 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3582 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3583 scm_remember_upto_here_2 (x
, r
);
3585 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3586 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3587 needs_adjustment
= (cmp
>= 0);
3589 needs_adjustment
= (cmp
> 0);
3590 scm_remember_upto_here_2 (r2
, y
);
3592 if (needs_adjustment
)
3593 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3595 return scm_i_normbig (q
);
3599 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3601 return scm_round_quotient
3602 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3603 scm_product (scm_numerator (y
), scm_denominator (x
)));
3606 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3607 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3608 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3610 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3612 "Return the real number @var{r} such that\n"
3613 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3614 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3615 "nearest integer, with ties going to the nearest\n"
3618 "(round-remainder 123 10) @result{} 3\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 125 10) @result{} 5\n"
3623 "(round-remainder 127 10) @result{} -3\n"
3624 "(round-remainder 135 10) @result{} -5\n"
3625 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3626 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3628 #define FUNC_NAME s_scm_round_remainder
3630 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3632 scm_t_inum xx
= SCM_I_INUM (x
);
3633 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3635 scm_t_inum yy
= SCM_I_INUM (y
);
3636 if (SCM_UNLIKELY (yy
== 0))
3637 scm_num_overflow (s_scm_round_remainder
);
3640 scm_t_inum qq
= xx
/ yy
;
3641 scm_t_inum rr
= xx
% yy
;
3643 scm_t_inum r2
= 2 * rr
;
3645 if (SCM_LIKELY (yy
< 0))
3665 return SCM_I_MAKINUM (rr
);
3668 else if (SCM_BIGP (y
))
3670 /* Pass a denormalized bignum version of x (even though it
3671 can fit in a fixnum) to scm_i_bigint_round_remainder */
3672 return scm_i_bigint_round_remainder
3673 (scm_i_long2big (xx
), y
);
3675 else if (SCM_REALP (y
))
3676 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3677 else if (SCM_FRACTIONP (y
))
3678 return scm_i_exact_rational_round_remainder (x
, y
);
3680 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3681 s_scm_round_remainder
);
3683 else if (SCM_BIGP (x
))
3685 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3687 scm_t_inum yy
= SCM_I_INUM (y
);
3688 if (SCM_UNLIKELY (yy
== 0))
3689 scm_num_overflow (s_scm_round_remainder
);
3692 SCM q
= scm_i_mkbig ();
3694 int needs_adjustment
;
3698 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3699 SCM_I_BIG_MPZ (x
), yy
);
3700 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3701 needs_adjustment
= (2*rr
>= yy
);
3703 needs_adjustment
= (2*rr
> yy
);
3707 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3708 SCM_I_BIG_MPZ (x
), -yy
);
3709 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3710 needs_adjustment
= (2*rr
<= yy
);
3712 needs_adjustment
= (2*rr
< yy
);
3714 scm_remember_upto_here_2 (x
, q
);
3715 if (needs_adjustment
)
3717 return SCM_I_MAKINUM (rr
);
3720 else if (SCM_BIGP (y
))
3721 return scm_i_bigint_round_remainder (x
, y
);
3722 else if (SCM_REALP (y
))
3723 return scm_i_inexact_round_remainder
3724 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3725 else if (SCM_FRACTIONP (y
))
3726 return scm_i_exact_rational_round_remainder (x
, y
);
3728 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3729 s_scm_round_remainder
);
3731 else if (SCM_REALP (x
))
3733 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3734 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3735 return scm_i_inexact_round_remainder
3736 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3738 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3739 s_scm_round_remainder
);
3741 else if (SCM_FRACTIONP (x
))
3744 return scm_i_inexact_round_remainder
3745 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3746 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3747 return scm_i_exact_rational_round_remainder (x
, y
);
3749 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3750 s_scm_round_remainder
);
3753 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3754 s_scm_round_remainder
);
3759 scm_i_inexact_round_remainder (double x
, double y
)
3761 /* Although it would be more efficient to use fmod here, we can't
3762 because it would in some cases produce results inconsistent with
3763 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3764 close). In particular, when x-y/2 is very close to a multiple of
3765 y, then r might be either -abs(y/2) or abs(y/2), but those two
3766 cases must correspond to different choices of q. If quotient
3767 chooses one and remainder chooses the other, it would be bad. */
3769 if (SCM_UNLIKELY (y
== 0))
3770 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3773 double q
= scm_c_round (x
/ y
);
3774 return scm_i_from_double (x
- q
* y
);
3778 /* Assumes that both x and y are bigints, though
3779 x might be able to fit into a fixnum. */
3781 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3784 int cmp
, needs_adjustment
;
3786 /* Note that x might be small enough to fit into a
3787 fixnum, so we must not let it escape into the wild */
3790 r2
= scm_i_mkbig ();
3792 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3793 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3794 scm_remember_upto_here_1 (x
);
3795 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3797 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3798 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3799 needs_adjustment
= (cmp
>= 0);
3801 needs_adjustment
= (cmp
> 0);
3802 scm_remember_upto_here_2 (q
, r2
);
3804 if (needs_adjustment
)
3805 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3807 scm_remember_upto_here_1 (y
);
3808 return scm_i_normbig (r
);
3812 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3814 SCM xd
= scm_denominator (x
);
3815 SCM yd
= scm_denominator (y
);
3816 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3817 scm_product (scm_numerator (y
), xd
));
3818 return scm_divide (r1
, scm_product (xd
, yd
));
3822 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3823 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3824 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3826 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3828 "Return the integer @var{q} and the real number @var{r}\n"
3829 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3830 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3831 "nearest integer, with ties going to the nearest even integer.\n"
3833 "(round/ 123 10) @result{} 12 and 3\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/ 125 10) @result{} 12 and 5\n"
3838 "(round/ 127 10) @result{} 13 and -3\n"
3839 "(round/ 135 10) @result{} 14 and -5\n"
3840 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3841 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3843 #define FUNC_NAME s_scm_i_round_divide
3847 scm_round_divide(x
, y
, &q
, &r
);
3848 return scm_values (scm_list_2 (q
, r
));
3852 #define s_scm_round_divide s_scm_i_round_divide
3853 #define g_scm_round_divide g_scm_i_round_divide
3856 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3858 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3860 scm_t_inum xx
= SCM_I_INUM (x
);
3861 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3863 scm_t_inum yy
= SCM_I_INUM (y
);
3864 if (SCM_UNLIKELY (yy
== 0))
3865 scm_num_overflow (s_scm_round_divide
);
3868 scm_t_inum qq
= xx
/ yy
;
3869 scm_t_inum rr
= xx
% yy
;
3871 scm_t_inum r2
= 2 * rr
;
3873 if (SCM_LIKELY (yy
< 0))
3893 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3894 *qp
= SCM_I_MAKINUM (qq
);
3896 *qp
= scm_i_inum2big (qq
);
3897 *rp
= SCM_I_MAKINUM (rr
);
3901 else if (SCM_BIGP (y
))
3903 /* Pass a denormalized bignum version of x (even though it
3904 can fit in a fixnum) to scm_i_bigint_round_divide */
3905 return scm_i_bigint_round_divide
3906 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3908 else if (SCM_REALP (y
))
3909 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3910 else if (SCM_FRACTIONP (y
))
3911 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3913 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3914 s_scm_round_divide
, qp
, rp
);
3916 else if (SCM_BIGP (x
))
3918 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3920 scm_t_inum yy
= SCM_I_INUM (y
);
3921 if (SCM_UNLIKELY (yy
== 0))
3922 scm_num_overflow (s_scm_round_divide
);
3925 SCM q
= scm_i_mkbig ();
3927 int needs_adjustment
;
3931 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3932 SCM_I_BIG_MPZ (x
), yy
);
3933 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3934 needs_adjustment
= (2*rr
>= yy
);
3936 needs_adjustment
= (2*rr
> yy
);
3940 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3941 SCM_I_BIG_MPZ (x
), -yy
);
3942 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3943 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3944 needs_adjustment
= (2*rr
<= yy
);
3946 needs_adjustment
= (2*rr
< yy
);
3948 scm_remember_upto_here_1 (x
);
3949 if (needs_adjustment
)
3951 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3954 *qp
= scm_i_normbig (q
);
3955 *rp
= SCM_I_MAKINUM (rr
);
3959 else if (SCM_BIGP (y
))
3960 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3961 else if (SCM_REALP (y
))
3962 return scm_i_inexact_round_divide
3963 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3964 else if (SCM_FRACTIONP (y
))
3965 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3967 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3968 s_scm_round_divide
, qp
, rp
);
3970 else if (SCM_REALP (x
))
3972 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3973 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3974 return scm_i_inexact_round_divide
3975 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3977 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3978 s_scm_round_divide
, qp
, rp
);
3980 else if (SCM_FRACTIONP (x
))
3983 return scm_i_inexact_round_divide
3984 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3985 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3986 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3988 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3989 s_scm_round_divide
, qp
, rp
);
3992 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3993 s_scm_round_divide
, qp
, rp
);
3997 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3999 if (SCM_UNLIKELY (y
== 0))
4000 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4003 double q
= scm_c_round (x
/ y
);
4004 double r
= x
- q
* y
;
4005 *qp
= scm_i_from_double (q
);
4006 *rp
= scm_i_from_double (r
);
4010 /* Assumes that both x and y are bigints, though
4011 x might be able to fit into a fixnum. */
4013 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4016 int cmp
, needs_adjustment
;
4018 /* Note that x might be small enough to fit into a
4019 fixnum, so we must not let it escape into the wild */
4022 r2
= scm_i_mkbig ();
4024 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4025 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4026 scm_remember_upto_here_1 (x
);
4027 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4029 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4030 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4031 needs_adjustment
= (cmp
>= 0);
4033 needs_adjustment
= (cmp
> 0);
4035 if (needs_adjustment
)
4037 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4038 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4041 scm_remember_upto_here_2 (r2
, y
);
4042 *qp
= scm_i_normbig (q
);
4043 *rp
= scm_i_normbig (r
);
4047 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4050 SCM xd
= scm_denominator (x
);
4051 SCM yd
= scm_denominator (y
);
4053 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4054 scm_product (scm_numerator (y
), xd
),
4056 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4060 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4061 (SCM x
, SCM y
, SCM rest
),
4062 "Return the greatest common divisor of all parameter values.\n"
4063 "If called without arguments, 0 is returned.")
4064 #define FUNC_NAME s_scm_i_gcd
4066 while (!scm_is_null (rest
))
4067 { x
= scm_gcd (x
, y
);
4069 rest
= scm_cdr (rest
);
4071 return scm_gcd (x
, y
);
4075 #define s_gcd s_scm_i_gcd
4076 #define g_gcd g_scm_i_gcd
4079 scm_gcd (SCM x
, SCM y
)
4081 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4082 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4084 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4086 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4088 scm_t_inum xx
= SCM_I_INUM (x
);
4089 scm_t_inum yy
= SCM_I_INUM (y
);
4090 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4091 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4093 if (SCM_UNLIKELY (xx
== 0))
4095 else if (SCM_UNLIKELY (yy
== 0))
4100 /* Determine a common factor 2^k */
4101 while (((u
| v
) & 1) == 0)
4107 /* Now, any factor 2^n can be eliminated */
4109 while ((u
& 1) == 0)
4112 while ((v
& 1) == 0)
4114 /* Both u and v are now odd. Subtract the smaller one
4115 from the larger one to produce an even number, remove
4116 more factors of two, and repeat. */
4122 while ((u
& 1) == 0)
4128 while ((v
& 1) == 0)
4134 return (SCM_POSFIXABLE (result
)
4135 ? SCM_I_MAKINUM (result
)
4136 : scm_i_inum2big (result
));
4138 else if (SCM_BIGP (y
))
4143 else if (SCM_REALP (y
) && scm_is_integer (y
))
4144 goto handle_inexacts
;
4146 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4148 else if (SCM_BIGP (x
))
4150 if (SCM_I_INUMP (y
))
4155 yy
= SCM_I_INUM (y
);
4160 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4161 scm_remember_upto_here_1 (x
);
4162 return (SCM_POSFIXABLE (result
)
4163 ? SCM_I_MAKINUM (result
)
4164 : scm_from_unsigned_integer (result
));
4166 else if (SCM_BIGP (y
))
4168 SCM result
= scm_i_mkbig ();
4169 mpz_gcd (SCM_I_BIG_MPZ (result
),
4172 scm_remember_upto_here_2 (x
, y
);
4173 return scm_i_normbig (result
);
4175 else if (SCM_REALP (y
) && scm_is_integer (y
))
4176 goto handle_inexacts
;
4178 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4180 else if (SCM_REALP (x
) && scm_is_integer (x
))
4182 if (SCM_I_INUMP (y
) || SCM_BIGP (y
)
4183 || (SCM_REALP (y
) && scm_is_integer (y
)))
4186 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x
),
4187 scm_inexact_to_exact (y
)));
4190 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4193 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4196 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4197 (SCM x
, SCM y
, SCM rest
),
4198 "Return the least common multiple of the arguments.\n"
4199 "If called without arguments, 1 is returned.")
4200 #define FUNC_NAME s_scm_i_lcm
4202 while (!scm_is_null (rest
))
4203 { x
= scm_lcm (x
, y
);
4205 rest
= scm_cdr (rest
);
4207 return scm_lcm (x
, y
);
4211 #define s_lcm s_scm_i_lcm
4212 #define g_lcm g_scm_i_lcm
4215 scm_lcm (SCM n1
, SCM n2
)
4217 if (SCM_UNLIKELY (SCM_UNBNDP (n2
)))
4218 return SCM_UNBNDP (n1
) ? SCM_INUM1
: scm_abs (n1
);
4220 if (SCM_LIKELY (SCM_I_INUMP (n1
)))
4222 if (SCM_LIKELY (SCM_I_INUMP (n2
)))
4224 SCM d
= scm_gcd (n1
, n2
);
4225 if (scm_is_eq (d
, SCM_INUM0
))
4228 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4230 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4232 /* inum n1, big n2 */
4235 SCM result
= scm_i_mkbig ();
4236 scm_t_inum nn1
= SCM_I_INUM (n1
);
4237 if (nn1
== 0) return SCM_INUM0
;
4238 if (nn1
< 0) nn1
= - nn1
;
4239 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4240 scm_remember_upto_here_1 (n2
);
4244 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4245 goto handle_inexacts
;
4247 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4249 else if (SCM_LIKELY (SCM_BIGP (n1
)))
4252 if (SCM_I_INUMP (n2
))
4257 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4259 SCM result
= scm_i_mkbig ();
4260 mpz_lcm(SCM_I_BIG_MPZ (result
),
4262 SCM_I_BIG_MPZ (n2
));
4263 scm_remember_upto_here_2(n1
, n2
);
4264 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4267 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4268 goto handle_inexacts
;
4270 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4272 else if (SCM_REALP (n1
) && scm_is_integer (n1
))
4274 if (SCM_I_INUMP (n2
) || SCM_BIGP (n2
)
4275 || (SCM_REALP (n2
) && scm_is_integer (n2
)))
4278 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1
),
4279 scm_inexact_to_exact (n2
)));
4282 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4285 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4288 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4293 + + + x (map digit:logand X Y)
4294 + - + x (map digit:logand X (lognot (+ -1 Y)))
4295 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4296 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4301 + + + (map digit:logior X Y)
4302 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4303 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4304 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4309 + + + (map digit:logxor X Y)
4310 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4311 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4312 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4317 + + (any digit:logand X Y)
4318 + - (any digit:logand X (lognot (+ -1 Y)))
4319 - + (any digit:logand (lognot (+ -1 X)) Y)
4324 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4325 (SCM x
, SCM y
, SCM rest
),
4326 "Return the bitwise AND of the integer arguments.\n\n"
4328 "(logand) @result{} -1\n"
4329 "(logand 7) @result{} 7\n"
4330 "(logand #b111 #b011 #b001) @result{} 1\n"
4332 #define FUNC_NAME s_scm_i_logand
4334 while (!scm_is_null (rest
))
4335 { x
= scm_logand (x
, y
);
4337 rest
= scm_cdr (rest
);
4339 return scm_logand (x
, y
);
4343 #define s_scm_logand s_scm_i_logand
4345 SCM
scm_logand (SCM n1
, SCM n2
)
4346 #define FUNC_NAME s_scm_logand
4350 if (SCM_UNBNDP (n2
))
4352 if (SCM_UNBNDP (n1
))
4353 return SCM_I_MAKINUM (-1);
4354 else if (!SCM_NUMBERP (n1
))
4355 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4356 else if (SCM_NUMBERP (n1
))
4359 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4362 if (SCM_I_INUMP (n1
))
4364 nn1
= SCM_I_INUM (n1
);
4365 if (SCM_I_INUMP (n2
))
4367 scm_t_inum nn2
= SCM_I_INUM (n2
);
4368 return SCM_I_MAKINUM (nn1
& nn2
);
4370 else if SCM_BIGP (n2
)
4376 SCM result_z
= scm_i_mkbig ();
4378 mpz_init_set_si (nn1_z
, nn1
);
4379 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4380 scm_remember_upto_here_1 (n2
);
4382 return scm_i_normbig (result_z
);
4386 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4388 else if (SCM_BIGP (n1
))
4390 if (SCM_I_INUMP (n2
))
4393 nn1
= SCM_I_INUM (n1
);
4396 else if (SCM_BIGP (n2
))
4398 SCM result_z
= scm_i_mkbig ();
4399 mpz_and (SCM_I_BIG_MPZ (result_z
),
4401 SCM_I_BIG_MPZ (n2
));
4402 scm_remember_upto_here_2 (n1
, n2
);
4403 return scm_i_normbig (result_z
);
4406 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4409 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4414 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4415 (SCM x
, SCM y
, SCM rest
),
4416 "Return the bitwise OR of the integer arguments.\n\n"
4418 "(logior) @result{} 0\n"
4419 "(logior 7) @result{} 7\n"
4420 "(logior #b000 #b001 #b011) @result{} 3\n"
4422 #define FUNC_NAME s_scm_i_logior
4424 while (!scm_is_null (rest
))
4425 { x
= scm_logior (x
, y
);
4427 rest
= scm_cdr (rest
);
4429 return scm_logior (x
, y
);
4433 #define s_scm_logior s_scm_i_logior
4435 SCM
scm_logior (SCM n1
, SCM n2
)
4436 #define FUNC_NAME s_scm_logior
4440 if (SCM_UNBNDP (n2
))
4442 if (SCM_UNBNDP (n1
))
4444 else if (SCM_NUMBERP (n1
))
4447 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4450 if (SCM_I_INUMP (n1
))
4452 nn1
= SCM_I_INUM (n1
);
4453 if (SCM_I_INUMP (n2
))
4455 long nn2
= SCM_I_INUM (n2
);
4456 return SCM_I_MAKINUM (nn1
| nn2
);
4458 else if (SCM_BIGP (n2
))
4464 SCM result_z
= scm_i_mkbig ();
4466 mpz_init_set_si (nn1_z
, nn1
);
4467 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4468 scm_remember_upto_here_1 (n2
);
4470 return scm_i_normbig (result_z
);
4474 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4476 else if (SCM_BIGP (n1
))
4478 if (SCM_I_INUMP (n2
))
4481 nn1
= SCM_I_INUM (n1
);
4484 else if (SCM_BIGP (n2
))
4486 SCM result_z
= scm_i_mkbig ();
4487 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4489 SCM_I_BIG_MPZ (n2
));
4490 scm_remember_upto_here_2 (n1
, n2
);
4491 return scm_i_normbig (result_z
);
4494 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4497 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4502 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4503 (SCM x
, SCM y
, SCM rest
),
4504 "Return the bitwise XOR of the integer arguments. A bit is\n"
4505 "set in the result if it is set in an odd number of arguments.\n"
4507 "(logxor) @result{} 0\n"
4508 "(logxor 7) @result{} 7\n"
4509 "(logxor #b000 #b001 #b011) @result{} 2\n"
4510 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4512 #define FUNC_NAME s_scm_i_logxor
4514 while (!scm_is_null (rest
))
4515 { x
= scm_logxor (x
, y
);
4517 rest
= scm_cdr (rest
);
4519 return scm_logxor (x
, y
);
4523 #define s_scm_logxor s_scm_i_logxor
4525 SCM
scm_logxor (SCM n1
, SCM n2
)
4526 #define FUNC_NAME s_scm_logxor
4530 if (SCM_UNBNDP (n2
))
4532 if (SCM_UNBNDP (n1
))
4534 else if (SCM_NUMBERP (n1
))
4537 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4540 if (SCM_I_INUMP (n1
))
4542 nn1
= SCM_I_INUM (n1
);
4543 if (SCM_I_INUMP (n2
))
4545 scm_t_inum nn2
= SCM_I_INUM (n2
);
4546 return SCM_I_MAKINUM (nn1
^ nn2
);
4548 else if (SCM_BIGP (n2
))
4552 SCM result_z
= scm_i_mkbig ();
4554 mpz_init_set_si (nn1_z
, nn1
);
4555 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4556 scm_remember_upto_here_1 (n2
);
4558 return scm_i_normbig (result_z
);
4562 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4564 else if (SCM_BIGP (n1
))
4566 if (SCM_I_INUMP (n2
))
4569 nn1
= SCM_I_INUM (n1
);
4572 else if (SCM_BIGP (n2
))
4574 SCM result_z
= scm_i_mkbig ();
4575 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4577 SCM_I_BIG_MPZ (n2
));
4578 scm_remember_upto_here_2 (n1
, n2
);
4579 return scm_i_normbig (result_z
);
4582 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4585 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4590 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4592 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4593 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4594 "without actually calculating the @code{logand}, just testing\n"
4598 "(logtest #b0100 #b1011) @result{} #f\n"
4599 "(logtest #b0100 #b0111) @result{} #t\n"
4601 #define FUNC_NAME s_scm_logtest
4605 if (SCM_I_INUMP (j
))
4607 nj
= SCM_I_INUM (j
);
4608 if (SCM_I_INUMP (k
))
4610 scm_t_inum nk
= SCM_I_INUM (k
);
4611 return scm_from_bool (nj
& nk
);
4613 else if (SCM_BIGP (k
))
4621 mpz_init_set_si (nj_z
, nj
);
4622 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4623 scm_remember_upto_here_1 (k
);
4624 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4630 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4632 else if (SCM_BIGP (j
))
4634 if (SCM_I_INUMP (k
))
4637 nj
= SCM_I_INUM (j
);
4640 else if (SCM_BIGP (k
))
4644 mpz_init (result_z
);
4648 scm_remember_upto_here_2 (j
, k
);
4649 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4650 mpz_clear (result_z
);
4654 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4657 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4662 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4664 "Test whether bit number @var{index} in @var{j} is set.\n"
4665 "@var{index} starts from 0 for the least significant bit.\n"
4668 "(logbit? 0 #b1101) @result{} #t\n"
4669 "(logbit? 1 #b1101) @result{} #f\n"
4670 "(logbit? 2 #b1101) @result{} #t\n"
4671 "(logbit? 3 #b1101) @result{} #t\n"
4672 "(logbit? 4 #b1101) @result{} #f\n"
4674 #define FUNC_NAME s_scm_logbit_p
4676 unsigned long int iindex
;
4677 iindex
= scm_to_ulong (index
);
4679 if (SCM_I_INUMP (j
))
4681 /* bits above what's in an inum follow the sign bit */
4682 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4683 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4685 else if (SCM_BIGP (j
))
4687 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4688 scm_remember_upto_here_1 (j
);
4689 return scm_from_bool (val
);
4692 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4697 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4699 "Return the integer which is the ones-complement of the integer\n"
4703 "(number->string (lognot #b10000000) 2)\n"
4704 " @result{} \"-10000001\"\n"
4705 "(number->string (lognot #b0) 2)\n"
4706 " @result{} \"-1\"\n"
4708 #define FUNC_NAME s_scm_lognot
4710 if (SCM_I_INUMP (n
)) {
4711 /* No overflow here, just need to toggle all the bits making up the inum.
4712 Enhancement: No need to strip the tag and add it back, could just xor
4713 a block of 1 bits, if that worked with the various debug versions of
4715 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4717 } else if (SCM_BIGP (n
)) {
4718 SCM result
= scm_i_mkbig ();
4719 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4720 scm_remember_upto_here_1 (n
);
4724 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4729 /* returns 0 if IN is not an integer. OUT must already be
4732 coerce_to_big (SCM in
, mpz_t out
)
4735 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4736 else if (SCM_I_INUMP (in
))
4737 mpz_set_si (out
, SCM_I_INUM (in
));
4744 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4745 (SCM n
, SCM k
, SCM m
),
4746 "Return @var{n} raised to the integer exponent\n"
4747 "@var{k}, modulo @var{m}.\n"
4750 "(modulo-expt 2 3 5)\n"
4753 #define FUNC_NAME s_scm_modulo_expt
4759 /* There are two classes of error we might encounter --
4760 1) Math errors, which we'll report by calling scm_num_overflow,
4762 2) wrong-type errors, which of course we'll report by calling
4764 We don't report those errors immediately, however; instead we do
4765 some cleanup first. These variables tell us which error (if
4766 any) we should report after cleaning up.
4768 int report_overflow
= 0;
4770 int position_of_wrong_type
= 0;
4771 SCM value_of_wrong_type
= SCM_INUM0
;
4773 SCM result
= SCM_UNDEFINED
;
4779 if (scm_is_eq (m
, SCM_INUM0
))
4781 report_overflow
= 1;
4785 if (!coerce_to_big (n
, n_tmp
))
4787 value_of_wrong_type
= n
;
4788 position_of_wrong_type
= 1;
4792 if (!coerce_to_big (k
, k_tmp
))
4794 value_of_wrong_type
= k
;
4795 position_of_wrong_type
= 2;
4799 if (!coerce_to_big (m
, m_tmp
))
4801 value_of_wrong_type
= m
;
4802 position_of_wrong_type
= 3;
4806 /* if the exponent K is negative, and we simply call mpz_powm, we
4807 will get a divide-by-zero exception when an inverse 1/n mod m
4808 doesn't exist (or is not unique). Since exceptions are hard to
4809 handle, we'll attempt the inversion "by hand" -- that way, we get
4810 a simple failure code, which is easy to handle. */
4812 if (-1 == mpz_sgn (k_tmp
))
4814 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4816 report_overflow
= 1;
4819 mpz_neg (k_tmp
, k_tmp
);
4822 result
= scm_i_mkbig ();
4823 mpz_powm (SCM_I_BIG_MPZ (result
),
4828 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4829 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4836 if (report_overflow
)
4837 scm_num_overflow (FUNC_NAME
);
4839 if (position_of_wrong_type
)
4840 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4841 value_of_wrong_type
);
4843 return scm_i_normbig (result
);
4847 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4849 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4850 "exact integer, @var{n} can be any number.\n"
4852 "Negative @var{k} is supported, and results in\n"
4853 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4854 "@math{@var{n}^0} is 1, as usual, and that\n"
4855 "includes @math{0^0} is 1.\n"
4858 "(integer-expt 2 5) @result{} 32\n"
4859 "(integer-expt -3 3) @result{} -27\n"
4860 "(integer-expt 5 -3) @result{} 1/125\n"
4861 "(integer-expt 0 0) @result{} 1\n"
4863 #define FUNC_NAME s_scm_integer_expt
4866 SCM z_i2
= SCM_BOOL_F
;
4868 SCM acc
= SCM_I_MAKINUM (1L);
4870 /* Specifically refrain from checking the type of the first argument.
4871 This allows us to exponentiate any object that can be multiplied.
4872 If we must raise to a negative power, we must also be able to
4873 take its reciprocal. */
4874 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4875 SCM_WRONG_TYPE_ARG (2, k
);
4877 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4878 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4879 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4880 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4881 /* The next check is necessary only because R6RS specifies different
4882 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4883 we simply skip this case and move on. */
4884 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4886 /* k cannot be 0 at this point, because we
4887 have already checked for that case above */
4888 if (scm_is_true (scm_positive_p (k
)))
4890 else /* return NaN for (0 ^ k) for negative k per R6RS */
4893 else if (SCM_FRACTIONP (n
))
4895 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4896 needless reduction of intermediate products to lowest terms.
4897 If a and b have no common factors, then a^k and b^k have no
4898 common factors. Use 'scm_i_make_ratio_already_reduced' to
4899 construct the final result, so that no gcd computations are
4900 needed to exponentiate a fraction. */
4901 if (scm_is_true (scm_positive_p (k
)))
4902 return scm_i_make_ratio_already_reduced
4903 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4904 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4907 k
= scm_difference (k
, SCM_UNDEFINED
);
4908 return scm_i_make_ratio_already_reduced
4909 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4910 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4914 if (SCM_I_INUMP (k
))
4915 i2
= SCM_I_INUM (k
);
4916 else if (SCM_BIGP (k
))
4918 z_i2
= scm_i_clonebig (k
, 1);
4919 scm_remember_upto_here_1 (k
);
4923 SCM_WRONG_TYPE_ARG (2, k
);
4927 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4929 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4930 n
= scm_divide (n
, SCM_UNDEFINED
);
4934 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4938 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4940 return scm_product (acc
, n
);
4942 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4943 acc
= scm_product (acc
, n
);
4944 n
= scm_product (n
, n
);
4945 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4953 n
= scm_divide (n
, SCM_UNDEFINED
);
4960 return scm_product (acc
, n
);
4962 acc
= scm_product (acc
, n
);
4963 n
= scm_product (n
, n
);
4970 /* Efficiently compute (N * 2^COUNT),
4971 where N is an exact integer, and COUNT > 0. */
4973 left_shift_exact_integer (SCM n
, long count
)
4975 if (SCM_I_INUMP (n
))
4977 scm_t_inum nn
= SCM_I_INUM (n
);
4979 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4980 overflow a non-zero fixnum. For smaller shifts we check the
4981 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4982 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4983 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4987 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4988 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4990 return SCM_I_MAKINUM (nn
<< count
);
4993 SCM result
= scm_i_inum2big (nn
);
4994 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4999 else if (SCM_BIGP (n
))
5001 SCM result
= scm_i_mkbig ();
5002 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5003 scm_remember_upto_here_1 (n
);
5007 scm_syserror ("left_shift_exact_integer");
5010 /* Efficiently compute floor (N / 2^COUNT),
5011 where N is an exact integer and COUNT > 0. */
5013 floor_right_shift_exact_integer (SCM n
, long count
)
5015 if (SCM_I_INUMP (n
))
5017 scm_t_inum nn
= SCM_I_INUM (n
);
5019 if (count
>= SCM_I_FIXNUM_BIT
)
5020 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5022 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5024 else if (SCM_BIGP (n
))
5026 SCM result
= scm_i_mkbig ();
5027 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5029 scm_remember_upto_here_1 (n
);
5030 return scm_i_normbig (result
);
5033 scm_syserror ("floor_right_shift_exact_integer");
5036 /* Efficiently compute round (N / 2^COUNT),
5037 where N is an exact integer and COUNT > 0. */
5039 round_right_shift_exact_integer (SCM n
, long count
)
5041 if (SCM_I_INUMP (n
))
5043 if (count
>= SCM_I_FIXNUM_BIT
)
5047 scm_t_inum nn
= SCM_I_INUM (n
);
5048 scm_t_inum qq
= SCM_SRS (nn
, count
);
5050 if (0 == (nn
& (1L << (count
-1))))
5051 return SCM_I_MAKINUM (qq
); /* round down */
5052 else if (nn
& ((1L << (count
-1)) - 1))
5053 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5055 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5058 else if (SCM_BIGP (n
))
5060 SCM q
= scm_i_mkbig ();
5062 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5063 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5064 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5065 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5066 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5067 scm_remember_upto_here_1 (n
);
5068 return scm_i_normbig (q
);
5071 scm_syserror ("round_right_shift_exact_integer");
5074 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5076 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5077 "@var{n} and @var{count} must be exact integers.\n"
5079 "With @var{n} viewed as an infinite-precision twos-complement\n"
5080 "integer, @code{ash} means a left shift introducing zero bits\n"
5081 "when @var{count} is positive, or a right shift dropping bits\n"
5082 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5085 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5086 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5088 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5089 "(ash -23 -2) @result{} -6\n"
5091 #define FUNC_NAME s_scm_ash
5093 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5095 long bits_to_shift
= scm_to_long (count
);
5097 if (bits_to_shift
> 0)
5098 return left_shift_exact_integer (n
, bits_to_shift
);
5099 else if (SCM_LIKELY (bits_to_shift
< 0))
5100 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5105 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5109 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5111 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5112 "@var{n} and @var{count} must be exact integers.\n"
5114 "With @var{n} viewed as an infinite-precision twos-complement\n"
5115 "integer, @code{round-ash} means a left shift introducing zero\n"
5116 "bits when @var{count} is positive, or a right shift rounding\n"
5117 "to the nearest integer (with ties going to the nearest even\n"
5118 "integer) when @var{count} is negative. This is a rounded\n"
5119 "``arithmetic'' shift.\n"
5122 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5123 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5124 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5125 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5126 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5127 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5129 #define FUNC_NAME s_scm_round_ash
5131 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5133 long bits_to_shift
= scm_to_long (count
);
5135 if (bits_to_shift
> 0)
5136 return left_shift_exact_integer (n
, bits_to_shift
);
5137 else if (SCM_LIKELY (bits_to_shift
< 0))
5138 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5143 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5148 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5149 (SCM n
, SCM start
, SCM end
),
5150 "Return the integer composed of the @var{start} (inclusive)\n"
5151 "through @var{end} (exclusive) bits of @var{n}. The\n"
5152 "@var{start}th bit becomes the 0-th bit in the result.\n"
5155 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5156 " @result{} \"1010\"\n"
5157 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5158 " @result{} \"10110\"\n"
5160 #define FUNC_NAME s_scm_bit_extract
5162 unsigned long int istart
, iend
, bits
;
5163 istart
= scm_to_ulong (start
);
5164 iend
= scm_to_ulong (end
);
5165 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5167 /* how many bits to keep */
5168 bits
= iend
- istart
;
5170 if (SCM_I_INUMP (n
))
5172 scm_t_inum in
= SCM_I_INUM (n
);
5174 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5175 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5176 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5178 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5180 /* Since we emulate two's complement encoded numbers, this
5181 * special case requires us to produce a result that has
5182 * more bits than can be stored in a fixnum.
5184 SCM result
= scm_i_inum2big (in
);
5185 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5190 /* mask down to requisite bits */
5191 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5192 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5194 else if (SCM_BIGP (n
))
5199 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5203 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5204 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5205 such bits into a ulong. */
5206 result
= scm_i_mkbig ();
5207 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5208 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5209 result
= scm_i_normbig (result
);
5211 scm_remember_upto_here_1 (n
);
5215 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5220 static const char scm_logtab
[] = {
5221 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5224 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5226 "Return the number of bits in integer @var{n}. If integer is\n"
5227 "positive, the 1-bits in its binary representation are counted.\n"
5228 "If negative, the 0-bits in its two's-complement binary\n"
5229 "representation are counted. If 0, 0 is returned.\n"
5232 "(logcount #b10101010)\n"
5239 #define FUNC_NAME s_scm_logcount
5241 if (SCM_I_INUMP (n
))
5243 unsigned long c
= 0;
5244 scm_t_inum nn
= SCM_I_INUM (n
);
5249 c
+= scm_logtab
[15 & nn
];
5252 return SCM_I_MAKINUM (c
);
5254 else if (SCM_BIGP (n
))
5256 unsigned long count
;
5257 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5258 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5260 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5261 scm_remember_upto_here_1 (n
);
5262 return SCM_I_MAKINUM (count
);
5265 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5270 static const char scm_ilentab
[] = {
5271 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5275 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5277 "Return the number of bits necessary to represent @var{n}.\n"
5280 "(integer-length #b10101010)\n"
5282 "(integer-length 0)\n"
5284 "(integer-length #b1111)\n"
5287 #define FUNC_NAME s_scm_integer_length
5289 if (SCM_I_INUMP (n
))
5291 unsigned long c
= 0;
5293 scm_t_inum nn
= SCM_I_INUM (n
);
5299 l
= scm_ilentab
[15 & nn
];
5302 return SCM_I_MAKINUM (c
- 4 + l
);
5304 else if (SCM_BIGP (n
))
5306 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5307 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5308 1 too big, so check for that and adjust. */
5309 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5310 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5311 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5312 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5314 scm_remember_upto_here_1 (n
);
5315 return SCM_I_MAKINUM (size
);
5318 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5322 /*** NUMBERS -> STRINGS ***/
5323 #define SCM_MAX_DBL_RADIX 36
5325 /* use this array as a way to generate a single digit */
5326 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5328 static mpz_t dbl_minimum_normal_mantissa
;
5331 idbl2str (double dbl
, char *a
, int radix
)
5335 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5336 /* revert to existing behavior */
5341 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5351 else if (dbl
== 0.0)
5353 if (copysign (1.0, dbl
) < 0.0)
5355 strcpy (a
+ ch
, "0.0");
5358 else if (isnan (dbl
))
5360 strcpy (a
, "+nan.0");
5364 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5365 Accurately" by Robert G. Burger and R. Kent Dybvig */
5368 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5369 int f_is_even
, f_is_odd
;
5373 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5374 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5375 if (e
< DBL_MIN_EXP
)
5377 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5382 f_is_even
= !mpz_odd_p (f
);
5383 f_is_odd
= !f_is_even
;
5385 /* Initialize r, s, mplus, and mminus according
5386 to Table 1 from the paper. */
5389 mpz_set_ui (mminus
, 1);
5390 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5391 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5393 mpz_set_ui (mplus
, 1);
5394 mpz_mul_2exp (r
, f
, 1);
5395 mpz_mul_2exp (s
, mminus
, 1 - e
);
5399 mpz_set_ui (mplus
, 2);
5400 mpz_mul_2exp (r
, f
, 2);
5401 mpz_mul_2exp (s
, mminus
, 2 - e
);
5406 mpz_set_ui (mminus
, 1);
5407 mpz_mul_2exp (mminus
, mminus
, e
);
5408 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5410 mpz_set (mplus
, mminus
);
5411 mpz_mul_2exp (r
, f
, 1 + e
);
5416 mpz_mul_2exp (mplus
, mminus
, 1);
5417 mpz_mul_2exp (r
, f
, 2 + e
);
5422 /* Find the smallest k such that:
5423 (r + mplus) / s < radix^k (if f is even)
5424 (r + mplus) / s <= radix^k (if f is odd) */
5426 /* IMPROVE-ME: Make an initial guess to speed this up */
5427 mpz_add (hi
, r
, mplus
);
5429 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5431 mpz_mul_ui (s
, s
, radix
);
5436 mpz_mul_ui (hi
, hi
, radix
);
5437 while (mpz_cmp (hi
, s
) < f_is_odd
)
5439 mpz_mul_ui (r
, r
, radix
);
5440 mpz_mul_ui (mplus
, mplus
, radix
);
5441 mpz_mul_ui (mminus
, mminus
, radix
);
5442 mpz_mul_ui (hi
, hi
, radix
);
5453 /* Use scientific notation */
5461 /* Print leading zeroes */
5464 for (i
= 0; i
> k
; i
--)
5471 int end_1_p
, end_2_p
;
5474 mpz_mul_ui (mplus
, mplus
, radix
);
5475 mpz_mul_ui (mminus
, mminus
, radix
);
5476 mpz_mul_ui (r
, r
, radix
);
5477 mpz_fdiv_qr (digit
, r
, r
, s
);
5478 d
= mpz_get_ui (digit
);
5480 mpz_add (hi
, r
, mplus
);
5481 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5482 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5483 if (end_1_p
|| end_2_p
)
5485 mpz_mul_2exp (r
, r
, 1);
5490 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5492 a
[ch
++] = number_chars
[d
];
5499 a
[ch
++] = number_chars
[d
];
5507 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5509 /* Here we would have to print more than three zeroes
5510 followed by a decimal point and another zero. It
5511 makes more sense to use scientific notation. */
5513 /* Adjust k to what it would have been if we had chosen
5514 scientific notation from the beginning. */
5517 /* k will now be <= 0, with magnitude equal to the number of
5518 digits that we printed which should now be put after the
5521 /* Insert a decimal point */
5522 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5542 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5545 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5552 icmplx2str (double real
, double imag
, char *str
, int radix
)
5557 i
= idbl2str (real
, str
, radix
);
5558 #ifdef HAVE_COPYSIGN
5559 sgn
= copysign (1.0, imag
);
5563 /* Don't output a '+' for negative numbers or for Inf and
5564 NaN. They will provide their own sign. */
5565 if (sgn
>= 0 && isfinite (imag
))
5567 i
+= idbl2str (imag
, &str
[i
], radix
);
5573 iflo2str (SCM flt
, char *str
, int radix
)
5576 if (SCM_REALP (flt
))
5577 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5579 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5584 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5585 characters in the result.
5587 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5589 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5594 return scm_iuint2str (-num
, rad
, p
) + 1;
5597 return scm_iuint2str (num
, rad
, p
);
5600 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5601 characters in the result.
5603 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5605 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5609 scm_t_uintmax n
= num
;
5611 if (rad
< 2 || rad
> 36)
5612 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5614 for (n
/= rad
; n
> 0; n
/= rad
)
5624 p
[i
] = number_chars
[d
];
5629 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5631 "Return a string holding the external representation of the\n"
5632 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5633 "inexact, a radix of 10 will be used.")
5634 #define FUNC_NAME s_scm_number_to_string
5638 if (SCM_UNBNDP (radix
))
5641 base
= scm_to_signed_integer (radix
, 2, 36);
5643 if (SCM_I_INUMP (n
))
5645 char num_buf
[SCM_INTBUFLEN
];
5646 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5647 return scm_from_locale_stringn (num_buf
, length
);
5649 else if (SCM_BIGP (n
))
5651 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5652 size_t len
= strlen (str
);
5653 void (*freefunc
) (void *, size_t);
5655 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5656 scm_remember_upto_here_1 (n
);
5657 ret
= scm_from_latin1_stringn (str
, len
);
5658 freefunc (str
, len
+ 1);
5661 else if (SCM_FRACTIONP (n
))
5663 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5664 scm_from_locale_string ("/"),
5665 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5667 else if (SCM_INEXACTP (n
))
5669 char num_buf
[FLOBUFLEN
];
5670 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5673 SCM_WRONG_TYPE_ARG (1, n
);
5678 /* These print routines used to be stubbed here so that scm_repl.c
5679 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5682 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5684 char num_buf
[FLOBUFLEN
];
5685 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5690 scm_i_print_double (double val
, SCM port
)
5692 char num_buf
[FLOBUFLEN
];
5693 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5697 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5700 char num_buf
[FLOBUFLEN
];
5701 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5706 scm_i_print_complex (double real
, double imag
, SCM port
)
5708 char num_buf
[FLOBUFLEN
];
5709 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5713 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5716 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5717 scm_display (str
, port
);
5718 scm_remember_upto_here_1 (str
);
5723 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5725 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5726 size_t len
= strlen (str
);
5727 void (*freefunc
) (void *, size_t);
5728 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5729 scm_remember_upto_here_1 (exp
);
5730 scm_lfwrite_unlocked (str
, len
, port
);
5731 freefunc (str
, len
+ 1);
5734 /*** END nums->strs ***/
5737 /*** STRINGS -> NUMBERS ***/
5739 /* The following functions implement the conversion from strings to numbers.
5740 * The implementation somehow follows the grammar for numbers as it is given
5741 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5742 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5743 * points should be noted about the implementation:
5745 * * Each function keeps a local index variable 'idx' that points at the
5746 * current position within the parsed string. The global index is only
5747 * updated if the function could parse the corresponding syntactic unit
5750 * * Similarly, the functions keep track of indicators of inexactness ('#',
5751 * '.' or exponents) using local variables ('hash_seen', 'x').
5753 * * Sequences of digits are parsed into temporary variables holding fixnums.
5754 * Only if these fixnums would overflow, the result variables are updated
5755 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5756 * the temporary variables holding the fixnums are cleared, and the process
5757 * starts over again. If for example fixnums were able to store five decimal
5758 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5759 * and the result was computed as 12345 * 100000 + 67890. In other words,
5760 * only every five digits two bignum operations were performed.
5762 * Notes on the handling of exactness specifiers:
5764 * When parsing non-real complex numbers, we apply exactness specifiers on
5765 * per-component basis, as is done in PLT Scheme. For complex numbers
5766 * written in rectangular form, exactness specifiers are applied to the
5767 * real and imaginary parts before calling scm_make_rectangular. For
5768 * complex numbers written in polar form, exactness specifiers are applied
5769 * to the magnitude and angle before calling scm_make_polar.
5771 * There are two kinds of exactness specifiers: forced and implicit. A
5772 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5773 * the entire number, and applies to both components of a complex number.
5774 * "#e" causes each component to be made exact, and "#i" causes each
5775 * component to be made inexact. If no forced exactness specifier is
5776 * present, then the exactness of each component is determined
5777 * independently by the presence or absence of a decimal point or hash mark
5778 * within that component. If a decimal point or hash mark is present, the
5779 * component is made inexact, otherwise it is made exact.
5781 * After the exactness specifiers have been applied to each component, they
5782 * are passed to either scm_make_rectangular or scm_make_polar to produce
5783 * the final result. Note that this will result in a real number if the
5784 * imaginary part, magnitude, or angle is an exact 0.
5786 * For example, (string->number "#i5.0+0i") does the equivalent of:
5788 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5791 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5793 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5795 /* Caller is responsible for checking that the return value is in range
5796 for the given radix, which should be <= 36. */
5798 char_decimal_value (scm_t_uint32 c
)
5800 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5801 that's certainly above any valid decimal, so we take advantage of
5802 that to elide some tests. */
5803 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5805 /* If that failed, try extended hexadecimals, then. Only accept ascii
5810 if (c
>= (scm_t_uint32
) 'a')
5811 d
= c
- (scm_t_uint32
)'a' + 10U;
5816 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5817 in base RADIX. Upon success, return the unsigned integer and update
5818 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5820 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5821 unsigned int radix
, enum t_exactness
*p_exactness
)
5823 unsigned int idx
= *p_idx
;
5824 unsigned int hash_seen
= 0;
5825 scm_t_bits shift
= 1;
5827 unsigned int digit_value
;
5830 size_t len
= scm_i_string_length (mem
);
5835 c
= scm_i_string_ref (mem
, idx
);
5836 digit_value
= char_decimal_value (c
);
5837 if (digit_value
>= radix
)
5841 result
= SCM_I_MAKINUM (digit_value
);
5844 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5854 digit_value
= char_decimal_value (c
);
5855 /* This check catches non-decimals in addition to out-of-range
5857 if (digit_value
>= radix
)
5862 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5864 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5866 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5873 shift
= shift
* radix
;
5874 add
= add
* radix
+ digit_value
;
5879 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5881 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5885 *p_exactness
= INEXACT
;
5891 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5892 * covers the parts of the rules that start at a potential point. The value
5893 * of the digits up to the point have been parsed by the caller and are given
5894 * in variable result. The content of *p_exactness indicates, whether a hash
5895 * has already been seen in the digits before the point.
5898 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5901 mem2decimal_from_point (SCM result
, SCM mem
,
5902 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5904 unsigned int idx
= *p_idx
;
5905 enum t_exactness x
= *p_exactness
;
5906 size_t len
= scm_i_string_length (mem
);
5911 if (scm_i_string_ref (mem
, idx
) == '.')
5913 scm_t_bits shift
= 1;
5915 unsigned int digit_value
;
5916 SCM big_shift
= SCM_INUM1
;
5921 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5922 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5927 digit_value
= DIGIT2UINT (c
);
5938 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5940 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5941 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5943 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5951 add
= add
* 10 + digit_value
;
5957 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5958 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5959 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5962 result
= scm_divide (result
, big_shift
);
5964 /* We've seen a decimal point, thus the value is implicitly inexact. */
5976 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5978 switch (scm_i_string_ref (mem
, idx
))
5990 c
= scm_i_string_ref (mem
, idx
);
5998 c
= scm_i_string_ref (mem
, idx
);
6007 c
= scm_i_string_ref (mem
, idx
);
6012 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6016 exponent
= DIGIT2UINT (c
);
6019 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6020 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6023 if (exponent
<= SCM_MAXEXP
)
6024 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6030 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6032 size_t exp_len
= idx
- start
;
6033 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6034 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6035 scm_out_of_range ("string->number", exp_num
);
6038 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6040 result
= scm_product (result
, e
);
6042 result
= scm_divide (result
, e
);
6044 /* We've seen an exponent, thus the value is implicitly inexact. */
6062 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6065 mem2ureal (SCM mem
, unsigned int *p_idx
,
6066 unsigned int radix
, enum t_exactness forced_x
,
6067 int allow_inf_or_nan
)
6069 unsigned int idx
= *p_idx
;
6071 size_t len
= scm_i_string_length (mem
);
6073 /* Start off believing that the number will be exact. This changes
6074 to INEXACT if we see a decimal point or a hash. */
6075 enum t_exactness implicit_x
= EXACT
;
6080 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6081 switch (scm_i_string_ref (mem
, idx
))
6084 switch (scm_i_string_ref (mem
, idx
+ 1))
6087 switch (scm_i_string_ref (mem
, idx
+ 2))
6090 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6091 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6099 switch (scm_i_string_ref (mem
, idx
+ 1))
6102 switch (scm_i_string_ref (mem
, idx
+ 2))
6105 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6107 /* Cobble up the fractional part. We might want to
6108 set the NaN's mantissa from it. */
6110 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6113 #if SCM_ENABLE_DEPRECATED == 1
6114 scm_c_issue_deprecation_warning
6115 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6128 if (scm_i_string_ref (mem
, idx
) == '.')
6132 else if (idx
+ 1 == len
)
6134 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6137 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6138 p_idx
, &implicit_x
);
6144 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6145 if (scm_is_false (uinteger
))
6150 else if (scm_i_string_ref (mem
, idx
) == '/')
6158 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6159 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6162 /* both are int/big here, I assume */
6163 result
= scm_i_make_ratio (uinteger
, divisor
);
6165 else if (radix
== 10)
6167 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6168 if (scm_is_false (result
))
6180 if (SCM_INEXACTP (result
))
6181 return scm_inexact_to_exact (result
);
6185 if (SCM_INEXACTP (result
))
6188 return scm_exact_to_inexact (result
);
6190 if (implicit_x
== INEXACT
)
6192 if (SCM_INEXACTP (result
))
6195 return scm_exact_to_inexact (result
);
6201 /* We should never get here */
6202 scm_syserror ("mem2ureal");
6206 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6209 mem2complex (SCM mem
, unsigned int idx
,
6210 unsigned int radix
, enum t_exactness forced_x
)
6215 size_t len
= scm_i_string_length (mem
);
6220 c
= scm_i_string_ref (mem
, idx
);
6235 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6236 if (scm_is_false (ureal
))
6238 /* input must be either +i or -i */
6243 if (scm_i_string_ref (mem
, idx
) == 'i'
6244 || scm_i_string_ref (mem
, idx
) == 'I')
6250 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6257 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6258 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6263 c
= scm_i_string_ref (mem
, idx
);
6267 /* either +<ureal>i or -<ureal>i */
6274 return scm_make_rectangular (SCM_INUM0
, ureal
);
6277 /* polar input: <real>@<real>. */
6288 c
= scm_i_string_ref (mem
, idx
);
6306 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6307 if (scm_is_false (angle
))
6312 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6313 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6315 result
= scm_make_polar (ureal
, angle
);
6320 /* expecting input matching <real>[+-]<ureal>?i */
6327 int sign
= (c
== '+') ? 1 : -1;
6328 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6330 if (scm_is_false (imag
))
6331 imag
= SCM_I_MAKINUM (sign
);
6332 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6333 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6337 if (scm_i_string_ref (mem
, idx
) != 'i'
6338 && scm_i_string_ref (mem
, idx
) != 'I')
6345 return scm_make_rectangular (ureal
, imag
);
6354 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6356 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6359 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6361 unsigned int idx
= 0;
6362 unsigned int radix
= NO_RADIX
;
6363 enum t_exactness forced_x
= NO_EXACTNESS
;
6364 size_t len
= scm_i_string_length (mem
);
6366 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6367 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6369 switch (scm_i_string_ref (mem
, idx
+ 1))
6372 if (radix
!= NO_RADIX
)
6377 if (radix
!= NO_RADIX
)
6382 if (forced_x
!= NO_EXACTNESS
)
6387 if (forced_x
!= NO_EXACTNESS
)
6392 if (radix
!= NO_RADIX
)
6397 if (radix
!= NO_RADIX
)
6407 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6408 if (radix
== NO_RADIX
)
6409 radix
= default_radix
;
6411 return mem2complex (mem
, idx
, radix
, forced_x
);
6415 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6416 unsigned int default_radix
)
6418 SCM str
= scm_from_locale_stringn (mem
, len
);
6420 return scm_i_string_to_number (str
, default_radix
);
6424 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6425 (SCM string
, SCM radix
),
6426 "Return a number of the maximally precise representation\n"
6427 "expressed by the given @var{string}. @var{radix} must be an\n"
6428 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6429 "is a default radix that may be overridden by an explicit radix\n"
6430 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6431 "supplied, then the default radix is 10. If string is not a\n"
6432 "syntactically valid notation for a number, then\n"
6433 "@code{string->number} returns @code{#f}.")
6434 #define FUNC_NAME s_scm_string_to_number
6438 SCM_VALIDATE_STRING (1, string
);
6440 if (SCM_UNBNDP (radix
))
6443 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6445 answer
= scm_i_string_to_number (string
, base
);
6446 scm_remember_upto_here_1 (string
);
6452 /*** END strs->nums ***/
6455 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6457 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6459 #define FUNC_NAME s_scm_number_p
6461 return scm_from_bool (SCM_NUMBERP (x
));
6465 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6467 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6468 "otherwise. Note that the sets of real, rational and integer\n"
6469 "values form subsets of the set of complex numbers, i. e. the\n"
6470 "predicate will also be fulfilled if @var{x} is a real,\n"
6471 "rational or integer number.")
6472 #define FUNC_NAME s_scm_complex_p
6474 /* all numbers are complex. */
6475 return scm_number_p (x
);
6479 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6481 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6482 "otherwise. Note that the set of integer values forms a subset of\n"
6483 "the set of real numbers, i. e. the predicate will also be\n"
6484 "fulfilled if @var{x} is an integer number.")
6485 #define FUNC_NAME s_scm_real_p
6487 return scm_from_bool
6488 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6492 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6494 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6495 "otherwise. Note that the set of integer values forms a subset of\n"
6496 "the set of rational numbers, i. e. the predicate will also be\n"
6497 "fulfilled if @var{x} is an integer number.")
6498 #define FUNC_NAME s_scm_rational_p
6500 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6502 else if (SCM_REALP (x
))
6503 /* due to their limited precision, finite floating point numbers are
6504 rational as well. (finite means neither infinity nor a NaN) */
6505 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6511 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6513 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6515 #define FUNC_NAME s_scm_integer_p
6517 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6519 else if (SCM_REALP (x
))
6521 double val
= SCM_REAL_VALUE (x
);
6522 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6530 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6531 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6532 (SCM x
, SCM y
, SCM rest
),
6533 "Return @code{#t} if all parameters are numerically equal.")
6534 #define FUNC_NAME s_scm_i_num_eq_p
6536 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6538 while (!scm_is_null (rest
))
6540 if (scm_is_false (scm_num_eq_p (x
, y
)))
6544 rest
= scm_cdr (rest
);
6546 return scm_num_eq_p (x
, y
);
6550 scm_num_eq_p (SCM x
, SCM y
)
6553 if (SCM_I_INUMP (x
))
6555 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6556 if (SCM_I_INUMP (y
))
6558 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6559 return scm_from_bool (xx
== yy
);
6561 else if (SCM_BIGP (y
))
6563 else if (SCM_REALP (y
))
6565 /* On a 32-bit system an inum fits a double, we can cast the inum
6566 to a double and compare.
6568 But on a 64-bit system an inum is bigger than a double and
6569 casting it to a double (call that dxx) will round.
6570 Although dxx will not in general be equal to xx, dxx will
6571 always be an integer and within a factor of 2 of xx, so if
6572 dxx==yy, we know that yy is an integer and fits in
6573 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6574 compare with plain xx.
6576 An alternative (for any size system actually) would be to check
6577 yy is an integer (with floor) and is in range of an inum
6578 (compare against appropriate powers of 2) then test
6579 xx==(scm_t_signed_bits)yy. It's just a matter of which
6580 casts/comparisons might be fastest or easiest for the cpu. */
6582 double yy
= SCM_REAL_VALUE (y
);
6583 return scm_from_bool ((double) xx
== yy
6584 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6585 || xx
== (scm_t_signed_bits
) yy
));
6587 else if (SCM_COMPLEXP (y
))
6589 /* see comments with inum/real above */
6590 double ry
= SCM_COMPLEX_REAL (y
);
6591 return scm_from_bool ((double) xx
== ry
6592 && 0.0 == SCM_COMPLEX_IMAG (y
)
6593 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6594 || xx
== (scm_t_signed_bits
) ry
));
6596 else if (SCM_FRACTIONP (y
))
6599 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6602 else if (SCM_BIGP (x
))
6604 if (SCM_I_INUMP (y
))
6606 else if (SCM_BIGP (y
))
6608 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6609 scm_remember_upto_here_2 (x
, y
);
6610 return scm_from_bool (0 == cmp
);
6612 else if (SCM_REALP (y
))
6615 if (isnan (SCM_REAL_VALUE (y
)))
6617 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6618 scm_remember_upto_here_1 (x
);
6619 return scm_from_bool (0 == cmp
);
6621 else if (SCM_COMPLEXP (y
))
6624 if (0.0 != SCM_COMPLEX_IMAG (y
))
6626 if (isnan (SCM_COMPLEX_REAL (y
)))
6628 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6629 scm_remember_upto_here_1 (x
);
6630 return scm_from_bool (0 == cmp
);
6632 else if (SCM_FRACTIONP (y
))
6635 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6638 else if (SCM_REALP (x
))
6640 double xx
= SCM_REAL_VALUE (x
);
6641 if (SCM_I_INUMP (y
))
6643 /* see comments with inum/real above */
6644 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6645 return scm_from_bool (xx
== (double) yy
6646 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6647 || (scm_t_signed_bits
) xx
== yy
));
6649 else if (SCM_BIGP (y
))
6654 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6655 scm_remember_upto_here_1 (y
);
6656 return scm_from_bool (0 == cmp
);
6658 else if (SCM_REALP (y
))
6659 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6660 else if (SCM_COMPLEXP (y
))
6661 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6662 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6663 else if (SCM_FRACTIONP (y
))
6665 if (isnan (xx
) || isinf (xx
))
6667 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6671 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6674 else if (SCM_COMPLEXP (x
))
6676 if (SCM_I_INUMP (y
))
6678 /* see comments with inum/real above */
6679 double rx
= SCM_COMPLEX_REAL (x
);
6680 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6681 return scm_from_bool (rx
== (double) yy
6682 && 0.0 == SCM_COMPLEX_IMAG (x
)
6683 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6684 || (scm_t_signed_bits
) rx
== yy
));
6686 else if (SCM_BIGP (y
))
6689 if (0.0 != SCM_COMPLEX_IMAG (x
))
6691 if (isnan (SCM_COMPLEX_REAL (x
)))
6693 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6694 scm_remember_upto_here_1 (y
);
6695 return scm_from_bool (0 == cmp
);
6697 else if (SCM_REALP (y
))
6698 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6699 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6700 else if (SCM_COMPLEXP (y
))
6701 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6702 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6703 else if (SCM_FRACTIONP (y
))
6706 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6708 xx
= SCM_COMPLEX_REAL (x
);
6709 if (isnan (xx
) || isinf (xx
))
6711 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6715 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6718 else if (SCM_FRACTIONP (x
))
6720 if (SCM_I_INUMP (y
))
6722 else if (SCM_BIGP (y
))
6724 else if (SCM_REALP (y
))
6726 double yy
= SCM_REAL_VALUE (y
);
6727 if (isnan (yy
) || isinf (yy
))
6729 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6732 else if (SCM_COMPLEXP (y
))
6735 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6737 yy
= SCM_COMPLEX_REAL (y
);
6738 if (isnan (yy
) || isinf(yy
))
6740 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6743 else if (SCM_FRACTIONP (y
))
6744 return scm_i_fraction_equalp (x
, y
);
6746 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6750 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6755 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6756 done are good for inums, but for bignums an answer can almost always be
6757 had by just examining a few high bits of the operands, as done by GMP in
6758 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6759 of the float exponent to take into account. */
6761 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6762 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6763 (SCM x
, SCM y
, SCM rest
),
6764 "Return @code{#t} if the list of parameters is monotonically\n"
6766 #define FUNC_NAME s_scm_i_num_less_p
6768 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6770 while (!scm_is_null (rest
))
6772 if (scm_is_false (scm_less_p (x
, y
)))
6776 rest
= scm_cdr (rest
);
6778 return scm_less_p (x
, y
);
6782 scm_less_p (SCM x
, SCM y
)
6785 if (SCM_I_INUMP (x
))
6787 scm_t_inum xx
= SCM_I_INUM (x
);
6788 if (SCM_I_INUMP (y
))
6790 scm_t_inum yy
= SCM_I_INUM (y
);
6791 return scm_from_bool (xx
< yy
);
6793 else if (SCM_BIGP (y
))
6795 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6796 scm_remember_upto_here_1 (y
);
6797 return scm_from_bool (sgn
> 0);
6799 else if (SCM_REALP (y
))
6801 /* We can safely take the ceiling of y without changing the
6802 result of x<y, given that x is an integer. */
6803 double yy
= ceil (SCM_REAL_VALUE (y
));
6805 /* In the following comparisons, it's important that the right
6806 hand side always be a power of 2, so that it can be
6807 losslessly converted to a double even on 64-bit
6809 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6811 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6812 /* The condition above is carefully written to include the
6813 case where yy==NaN. */
6816 /* yy is a finite integer that fits in an inum. */
6817 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6819 else if (SCM_FRACTIONP (y
))
6821 /* "x < a/b" becomes "x*b < a" */
6823 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6824 y
= SCM_FRACTION_NUMERATOR (y
);
6828 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6829 s_scm_i_num_less_p
);
6831 else if (SCM_BIGP (x
))
6833 if (SCM_I_INUMP (y
))
6835 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6836 scm_remember_upto_here_1 (x
);
6837 return scm_from_bool (sgn
< 0);
6839 else if (SCM_BIGP (y
))
6841 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6842 scm_remember_upto_here_2 (x
, y
);
6843 return scm_from_bool (cmp
< 0);
6845 else if (SCM_REALP (y
))
6848 if (isnan (SCM_REAL_VALUE (y
)))
6850 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6851 scm_remember_upto_here_1 (x
);
6852 return scm_from_bool (cmp
< 0);
6854 else if (SCM_FRACTIONP (y
))
6857 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6858 s_scm_i_num_less_p
);
6860 else if (SCM_REALP (x
))
6862 if (SCM_I_INUMP (y
))
6864 /* We can safely take the floor of x without changing the
6865 result of x<y, given that y is an integer. */
6866 double xx
= floor (SCM_REAL_VALUE (x
));
6868 /* In the following comparisons, it's important that the right
6869 hand side always be a power of 2, so that it can be
6870 losslessly converted to a double even on 64-bit
6872 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6874 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6875 /* The condition above is carefully written to include the
6876 case where xx==NaN. */
6879 /* xx is a finite integer that fits in an inum. */
6880 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6882 else if (SCM_BIGP (y
))
6885 if (isnan (SCM_REAL_VALUE (x
)))
6887 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6888 scm_remember_upto_here_1 (y
);
6889 return scm_from_bool (cmp
> 0);
6891 else if (SCM_REALP (y
))
6892 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6893 else if (SCM_FRACTIONP (y
))
6895 double xx
= SCM_REAL_VALUE (x
);
6899 return scm_from_bool (xx
< 0.0);
6900 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6904 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6905 s_scm_i_num_less_p
);
6907 else if (SCM_FRACTIONP (x
))
6909 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6911 /* "a/b < y" becomes "a < y*b" */
6912 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6913 x
= SCM_FRACTION_NUMERATOR (x
);
6916 else if (SCM_REALP (y
))
6918 double yy
= SCM_REAL_VALUE (y
);
6922 return scm_from_bool (0.0 < yy
);
6923 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6926 else if (SCM_FRACTIONP (y
))
6928 /* "a/b < c/d" becomes "a*d < c*b" */
6929 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6930 SCM_FRACTION_DENOMINATOR (y
));
6931 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6932 SCM_FRACTION_DENOMINATOR (x
));
6938 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6939 s_scm_i_num_less_p
);
6942 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6943 s_scm_i_num_less_p
);
6947 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6948 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6949 (SCM x
, SCM y
, SCM rest
),
6950 "Return @code{#t} if the list of parameters is monotonically\n"
6952 #define FUNC_NAME s_scm_i_num_gr_p
6954 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6956 while (!scm_is_null (rest
))
6958 if (scm_is_false (scm_gr_p (x
, y
)))
6962 rest
= scm_cdr (rest
);
6964 return scm_gr_p (x
, y
);
6967 #define FUNC_NAME s_scm_i_num_gr_p
6969 scm_gr_p (SCM x
, SCM y
)
6971 if (!SCM_NUMBERP (x
))
6972 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6973 else if (!SCM_NUMBERP (y
))
6974 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6976 return scm_less_p (y
, x
);
6981 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6982 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6983 (SCM x
, SCM y
, SCM rest
),
6984 "Return @code{#t} if the list of parameters is monotonically\n"
6986 #define FUNC_NAME s_scm_i_num_leq_p
6988 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6990 while (!scm_is_null (rest
))
6992 if (scm_is_false (scm_leq_p (x
, y
)))
6996 rest
= scm_cdr (rest
);
6998 return scm_leq_p (x
, y
);
7001 #define FUNC_NAME s_scm_i_num_leq_p
7003 scm_leq_p (SCM x
, SCM y
)
7005 if (!SCM_NUMBERP (x
))
7006 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7007 else if (!SCM_NUMBERP (y
))
7008 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7009 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7012 return scm_not (scm_less_p (y
, x
));
7017 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7018 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7019 (SCM x
, SCM y
, SCM rest
),
7020 "Return @code{#t} if the list of parameters is monotonically\n"
7022 #define FUNC_NAME s_scm_i_num_geq_p
7024 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7026 while (!scm_is_null (rest
))
7028 if (scm_is_false (scm_geq_p (x
, y
)))
7032 rest
= scm_cdr (rest
);
7034 return scm_geq_p (x
, y
);
7037 #define FUNC_NAME s_scm_i_num_geq_p
7039 scm_geq_p (SCM x
, SCM y
)
7041 if (!SCM_NUMBERP (x
))
7042 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7043 else if (!SCM_NUMBERP (y
))
7044 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7045 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7048 return scm_not (scm_less_p (x
, y
));
7053 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7055 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7057 #define FUNC_NAME s_scm_zero_p
7059 if (SCM_I_INUMP (z
))
7060 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7061 else if (SCM_BIGP (z
))
7063 else if (SCM_REALP (z
))
7064 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7065 else if (SCM_COMPLEXP (z
))
7066 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7067 && SCM_COMPLEX_IMAG (z
) == 0.0);
7068 else if (SCM_FRACTIONP (z
))
7071 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7076 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7078 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7080 #define FUNC_NAME s_scm_positive_p
7082 if (SCM_I_INUMP (x
))
7083 return scm_from_bool (SCM_I_INUM (x
) > 0);
7084 else if (SCM_BIGP (x
))
7086 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7087 scm_remember_upto_here_1 (x
);
7088 return scm_from_bool (sgn
> 0);
7090 else if (SCM_REALP (x
))
7091 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7092 else if (SCM_FRACTIONP (x
))
7093 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7095 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7100 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7102 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7104 #define FUNC_NAME s_scm_negative_p
7106 if (SCM_I_INUMP (x
))
7107 return scm_from_bool (SCM_I_INUM (x
) < 0);
7108 else if (SCM_BIGP (x
))
7110 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7111 scm_remember_upto_here_1 (x
);
7112 return scm_from_bool (sgn
< 0);
7114 else if (SCM_REALP (x
))
7115 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7116 else if (SCM_FRACTIONP (x
))
7117 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7119 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7124 /* scm_min and scm_max return an inexact when either argument is inexact, as
7125 required by r5rs. On that basis, for exact/inexact combinations the
7126 exact is converted to inexact to compare and possibly return. This is
7127 unlike scm_less_p above which takes some trouble to preserve all bits in
7128 its test, such trouble is not required for min and max. */
7130 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7131 (SCM x
, SCM y
, SCM rest
),
7132 "Return the maximum of all parameter values.")
7133 #define FUNC_NAME s_scm_i_max
7135 while (!scm_is_null (rest
))
7136 { x
= scm_max (x
, y
);
7138 rest
= scm_cdr (rest
);
7140 return scm_max (x
, y
);
7144 #define s_max s_scm_i_max
7145 #define g_max g_scm_i_max
7148 scm_max (SCM x
, SCM y
)
7153 return scm_wta_dispatch_0 (g_max
, s_max
);
7154 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7157 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7160 if (SCM_I_INUMP (x
))
7162 scm_t_inum xx
= SCM_I_INUM (x
);
7163 if (SCM_I_INUMP (y
))
7165 scm_t_inum yy
= SCM_I_INUM (y
);
7166 return (xx
< yy
) ? y
: x
;
7168 else if (SCM_BIGP (y
))
7170 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7171 scm_remember_upto_here_1 (y
);
7172 return (sgn
< 0) ? x
: y
;
7174 else if (SCM_REALP (y
))
7177 double yyd
= SCM_REAL_VALUE (y
);
7180 return scm_i_from_double (xxd
);
7181 /* If y is a NaN, then "==" is false and we return the NaN */
7182 else if (SCM_LIKELY (!(xxd
== yyd
)))
7184 /* Handle signed zeroes properly */
7190 else if (SCM_FRACTIONP (y
))
7193 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7196 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7198 else if (SCM_BIGP (x
))
7200 if (SCM_I_INUMP (y
))
7202 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7203 scm_remember_upto_here_1 (x
);
7204 return (sgn
< 0) ? y
: x
;
7206 else if (SCM_BIGP (y
))
7208 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7209 scm_remember_upto_here_2 (x
, y
);
7210 return (cmp
> 0) ? x
: y
;
7212 else if (SCM_REALP (y
))
7214 /* if y==NaN then xx>yy is false, so we return the NaN y */
7217 xx
= scm_i_big2dbl (x
);
7218 yy
= SCM_REAL_VALUE (y
);
7219 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7221 else if (SCM_FRACTIONP (y
))
7226 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7228 else if (SCM_REALP (x
))
7230 if (SCM_I_INUMP (y
))
7232 scm_t_inum yy
= SCM_I_INUM (y
);
7233 double xxd
= SCM_REAL_VALUE (x
);
7237 return scm_i_from_double (yyd
);
7238 /* If x is a NaN, then "==" is false and we return the NaN */
7239 else if (SCM_LIKELY (!(xxd
== yyd
)))
7241 /* Handle signed zeroes properly */
7247 else if (SCM_BIGP (y
))
7252 else if (SCM_REALP (y
))
7254 double xx
= SCM_REAL_VALUE (x
);
7255 double yy
= SCM_REAL_VALUE (y
);
7257 /* For purposes of max: nan > +inf.0 > everything else,
7258 per the R6RS errata */
7261 else if (SCM_LIKELY (xx
< yy
))
7263 /* If neither (xx > yy) nor (xx < yy), then
7264 either they're equal or one is a NaN */
7265 else if (SCM_UNLIKELY (xx
!= yy
))
7266 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7267 /* xx == yy, but handle signed zeroes properly */
7268 else if (copysign (1.0, yy
) < 0.0)
7273 else if (SCM_FRACTIONP (y
))
7275 double yy
= scm_i_fraction2double (y
);
7276 double xx
= SCM_REAL_VALUE (x
);
7277 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7280 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7282 else if (SCM_FRACTIONP (x
))
7284 if (SCM_I_INUMP (y
))
7288 else if (SCM_BIGP (y
))
7292 else if (SCM_REALP (y
))
7294 double xx
= scm_i_fraction2double (x
);
7295 /* if y==NaN then ">" is false, so we return the NaN y */
7296 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7298 else if (SCM_FRACTIONP (y
))
7303 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7306 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7310 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7311 (SCM x
, SCM y
, SCM rest
),
7312 "Return the minimum of all parameter values.")
7313 #define FUNC_NAME s_scm_i_min
7315 while (!scm_is_null (rest
))
7316 { x
= scm_min (x
, y
);
7318 rest
= scm_cdr (rest
);
7320 return scm_min (x
, y
);
7324 #define s_min s_scm_i_min
7325 #define g_min g_scm_i_min
7328 scm_min (SCM x
, SCM y
)
7333 return scm_wta_dispatch_0 (g_min
, s_min
);
7334 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7337 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7340 if (SCM_I_INUMP (x
))
7342 scm_t_inum xx
= SCM_I_INUM (x
);
7343 if (SCM_I_INUMP (y
))
7345 scm_t_inum yy
= SCM_I_INUM (y
);
7346 return (xx
< yy
) ? x
: y
;
7348 else if (SCM_BIGP (y
))
7350 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7351 scm_remember_upto_here_1 (y
);
7352 return (sgn
< 0) ? y
: x
;
7354 else if (SCM_REALP (y
))
7357 /* if y==NaN then "<" is false and we return NaN */
7358 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7360 else if (SCM_FRACTIONP (y
))
7363 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7366 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7368 else if (SCM_BIGP (x
))
7370 if (SCM_I_INUMP (y
))
7372 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7373 scm_remember_upto_here_1 (x
);
7374 return (sgn
< 0) ? x
: y
;
7376 else if (SCM_BIGP (y
))
7378 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7379 scm_remember_upto_here_2 (x
, y
);
7380 return (cmp
> 0) ? y
: x
;
7382 else if (SCM_REALP (y
))
7384 /* if y==NaN then xx<yy is false, so we return the NaN y */
7387 xx
= scm_i_big2dbl (x
);
7388 yy
= SCM_REAL_VALUE (y
);
7389 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7391 else if (SCM_FRACTIONP (y
))
7396 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7398 else if (SCM_REALP (x
))
7400 if (SCM_I_INUMP (y
))
7402 double z
= SCM_I_INUM (y
);
7403 /* if x==NaN then "<" is false and we return NaN */
7404 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7406 else if (SCM_BIGP (y
))
7411 else if (SCM_REALP (y
))
7413 double xx
= SCM_REAL_VALUE (x
);
7414 double yy
= SCM_REAL_VALUE (y
);
7416 /* For purposes of min: nan < -inf.0 < everything else,
7417 per the R6RS errata */
7420 else if (SCM_LIKELY (xx
> yy
))
7422 /* If neither (xx < yy) nor (xx > yy), then
7423 either they're equal or one is a NaN */
7424 else if (SCM_UNLIKELY (xx
!= yy
))
7425 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7426 /* xx == yy, but handle signed zeroes properly */
7427 else if (copysign (1.0, xx
) < 0.0)
7432 else if (SCM_FRACTIONP (y
))
7434 double yy
= scm_i_fraction2double (y
);
7435 double xx
= SCM_REAL_VALUE (x
);
7436 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7439 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7441 else if (SCM_FRACTIONP (x
))
7443 if (SCM_I_INUMP (y
))
7447 else if (SCM_BIGP (y
))
7451 else if (SCM_REALP (y
))
7453 double xx
= scm_i_fraction2double (x
);
7454 /* if y==NaN then "<" is false, so we return the NaN y */
7455 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7457 else if (SCM_FRACTIONP (y
))
7462 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7465 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7469 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7470 (SCM x
, SCM y
, SCM rest
),
7471 "Return the sum of all parameter values. Return 0 if called without\n"
7473 #define FUNC_NAME s_scm_i_sum
7475 while (!scm_is_null (rest
))
7476 { x
= scm_sum (x
, y
);
7478 rest
= scm_cdr (rest
);
7480 return scm_sum (x
, y
);
7484 #define s_sum s_scm_i_sum
7485 #define g_sum g_scm_i_sum
7488 scm_sum (SCM x
, SCM y
)
7490 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7492 if (SCM_NUMBERP (x
)) return x
;
7493 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7494 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7497 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7499 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7501 scm_t_inum xx
= SCM_I_INUM (x
);
7502 scm_t_inum yy
= SCM_I_INUM (y
);
7503 scm_t_inum z
= xx
+ yy
;
7504 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7506 else if (SCM_BIGP (y
))
7511 else if (SCM_REALP (y
))
7513 scm_t_inum xx
= SCM_I_INUM (x
);
7514 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7516 else if (SCM_COMPLEXP (y
))
7518 scm_t_inum xx
= SCM_I_INUM (x
);
7519 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7520 SCM_COMPLEX_IMAG (y
));
7522 else if (SCM_FRACTIONP (y
))
7523 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7524 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7525 SCM_FRACTION_DENOMINATOR (y
));
7527 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7528 } else if (SCM_BIGP (x
))
7530 if (SCM_I_INUMP (y
))
7535 inum
= SCM_I_INUM (y
);
7538 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7541 SCM result
= scm_i_mkbig ();
7542 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7543 scm_remember_upto_here_1 (x
);
7544 /* we know the result will have to be a bignum */
7547 return scm_i_normbig (result
);
7551 SCM result
= scm_i_mkbig ();
7552 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7553 scm_remember_upto_here_1 (x
);
7554 /* we know the result will have to be a bignum */
7557 return scm_i_normbig (result
);
7560 else if (SCM_BIGP (y
))
7562 SCM result
= scm_i_mkbig ();
7563 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7564 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7565 mpz_add (SCM_I_BIG_MPZ (result
),
7568 scm_remember_upto_here_2 (x
, y
);
7569 /* we know the result will have to be a bignum */
7572 return scm_i_normbig (result
);
7574 else if (SCM_REALP (y
))
7576 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7577 scm_remember_upto_here_1 (x
);
7578 return scm_i_from_double (result
);
7580 else if (SCM_COMPLEXP (y
))
7582 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7583 + SCM_COMPLEX_REAL (y
));
7584 scm_remember_upto_here_1 (x
);
7585 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7587 else if (SCM_FRACTIONP (y
))
7588 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7589 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7590 SCM_FRACTION_DENOMINATOR (y
));
7592 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7594 else if (SCM_REALP (x
))
7596 if (SCM_I_INUMP (y
))
7597 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7598 else if (SCM_BIGP (y
))
7600 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7601 scm_remember_upto_here_1 (y
);
7602 return scm_i_from_double (result
);
7604 else if (SCM_REALP (y
))
7605 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7606 else if (SCM_COMPLEXP (y
))
7607 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7608 SCM_COMPLEX_IMAG (y
));
7609 else if (SCM_FRACTIONP (y
))
7610 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7612 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7614 else if (SCM_COMPLEXP (x
))
7616 if (SCM_I_INUMP (y
))
7617 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7618 SCM_COMPLEX_IMAG (x
));
7619 else if (SCM_BIGP (y
))
7621 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7622 + SCM_COMPLEX_REAL (x
));
7623 scm_remember_upto_here_1 (y
);
7624 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7626 else if (SCM_REALP (y
))
7627 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7628 SCM_COMPLEX_IMAG (x
));
7629 else if (SCM_COMPLEXP (y
))
7630 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7631 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7632 else if (SCM_FRACTIONP (y
))
7633 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7634 SCM_COMPLEX_IMAG (x
));
7636 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7638 else if (SCM_FRACTIONP (x
))
7640 if (SCM_I_INUMP (y
))
7641 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7642 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7643 SCM_FRACTION_DENOMINATOR (x
));
7644 else if (SCM_BIGP (y
))
7645 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7646 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7647 SCM_FRACTION_DENOMINATOR (x
));
7648 else if (SCM_REALP (y
))
7649 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7650 else if (SCM_COMPLEXP (y
))
7651 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7652 SCM_COMPLEX_IMAG (y
));
7653 else if (SCM_FRACTIONP (y
))
7654 /* a/b + c/d = (ad + bc) / bd */
7655 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7656 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7657 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7659 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7662 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7666 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7668 "Return @math{@var{x}+1}.")
7669 #define FUNC_NAME s_scm_oneplus
7671 return scm_sum (x
, SCM_INUM1
);
7676 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7677 (SCM x
, SCM y
, SCM rest
),
7678 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7679 "the sum of all but the first argument are subtracted from the first\n"
7681 #define FUNC_NAME s_scm_i_difference
7683 while (!scm_is_null (rest
))
7684 { x
= scm_difference (x
, y
);
7686 rest
= scm_cdr (rest
);
7688 return scm_difference (x
, y
);
7692 #define s_difference s_scm_i_difference
7693 #define g_difference g_scm_i_difference
7696 scm_difference (SCM x
, SCM y
)
7697 #define FUNC_NAME s_difference
7699 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7702 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7704 if (SCM_I_INUMP (x
))
7706 scm_t_inum xx
= -SCM_I_INUM (x
);
7707 if (SCM_FIXABLE (xx
))
7708 return SCM_I_MAKINUM (xx
);
7710 return scm_i_inum2big (xx
);
7712 else if (SCM_BIGP (x
))
7713 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7714 bignum, but negating that gives a fixnum. */
7715 return scm_i_normbig (scm_i_clonebig (x
, 0));
7716 else if (SCM_REALP (x
))
7717 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7718 else if (SCM_COMPLEXP (x
))
7719 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7720 -SCM_COMPLEX_IMAG (x
));
7721 else if (SCM_FRACTIONP (x
))
7722 return scm_i_make_ratio_already_reduced
7723 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7724 SCM_FRACTION_DENOMINATOR (x
));
7726 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7729 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7731 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7733 scm_t_inum xx
= SCM_I_INUM (x
);
7734 scm_t_inum yy
= SCM_I_INUM (y
);
7735 scm_t_inum z
= xx
- yy
;
7736 if (SCM_FIXABLE (z
))
7737 return SCM_I_MAKINUM (z
);
7739 return scm_i_inum2big (z
);
7741 else if (SCM_BIGP (y
))
7743 /* inum-x - big-y */
7744 scm_t_inum xx
= SCM_I_INUM (x
);
7748 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7749 bignum, but negating that gives a fixnum. */
7750 return scm_i_normbig (scm_i_clonebig (y
, 0));
7754 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7755 SCM result
= scm_i_mkbig ();
7758 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7761 /* x - y == -(y + -x) */
7762 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7763 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7765 scm_remember_upto_here_1 (y
);
7767 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7768 /* we know the result will have to be a bignum */
7771 return scm_i_normbig (result
);
7774 else if (SCM_REALP (y
))
7776 scm_t_inum xx
= SCM_I_INUM (x
);
7779 * We need to handle x == exact 0
7780 * specially because R6RS states that:
7781 * (- 0.0) ==> -0.0 and
7782 * (- 0.0 0.0) ==> 0.0
7783 * and the scheme compiler changes
7784 * (- 0.0) into (- 0 0.0)
7785 * So we need to treat (- 0 0.0) like (- 0.0).
7786 * At the C level, (-x) is different than (0.0 - x).
7787 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7790 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7792 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7794 else if (SCM_COMPLEXP (y
))
7796 scm_t_inum xx
= SCM_I_INUM (x
);
7798 /* We need to handle x == exact 0 specially.
7799 See the comment above (for SCM_REALP (y)) */
7801 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7802 - SCM_COMPLEX_IMAG (y
));
7804 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7805 - SCM_COMPLEX_IMAG (y
));
7807 else if (SCM_FRACTIONP (y
))
7808 /* a - b/c = (ac - b) / c */
7809 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7810 SCM_FRACTION_NUMERATOR (y
)),
7811 SCM_FRACTION_DENOMINATOR (y
));
7813 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7815 else if (SCM_BIGP (x
))
7817 if (SCM_I_INUMP (y
))
7819 /* big-x - inum-y */
7820 scm_t_inum yy
= SCM_I_INUM (y
);
7821 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7823 scm_remember_upto_here_1 (x
);
7825 return (SCM_FIXABLE (-yy
) ?
7826 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7829 SCM result
= scm_i_mkbig ();
7832 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7834 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7835 scm_remember_upto_here_1 (x
);
7837 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7838 /* we know the result will have to be a bignum */
7841 return scm_i_normbig (result
);
7844 else if (SCM_BIGP (y
))
7846 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7847 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7848 SCM result
= scm_i_mkbig ();
7849 mpz_sub (SCM_I_BIG_MPZ (result
),
7852 scm_remember_upto_here_2 (x
, y
);
7853 /* we know the result will have to be a bignum */
7854 if ((sgn_x
== 1) && (sgn_y
== -1))
7856 if ((sgn_x
== -1) && (sgn_y
== 1))
7858 return scm_i_normbig (result
);
7860 else if (SCM_REALP (y
))
7862 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7863 scm_remember_upto_here_1 (x
);
7864 return scm_i_from_double (result
);
7866 else if (SCM_COMPLEXP (y
))
7868 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7869 - SCM_COMPLEX_REAL (y
));
7870 scm_remember_upto_here_1 (x
);
7871 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7873 else if (SCM_FRACTIONP (y
))
7874 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7875 SCM_FRACTION_NUMERATOR (y
)),
7876 SCM_FRACTION_DENOMINATOR (y
));
7878 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7880 else if (SCM_REALP (x
))
7882 if (SCM_I_INUMP (y
))
7883 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7884 else if (SCM_BIGP (y
))
7886 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7887 scm_remember_upto_here_1 (x
);
7888 return scm_i_from_double (result
);
7890 else if (SCM_REALP (y
))
7891 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7892 else if (SCM_COMPLEXP (y
))
7893 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7894 -SCM_COMPLEX_IMAG (y
));
7895 else if (SCM_FRACTIONP (y
))
7896 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7898 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7900 else if (SCM_COMPLEXP (x
))
7902 if (SCM_I_INUMP (y
))
7903 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7904 SCM_COMPLEX_IMAG (x
));
7905 else if (SCM_BIGP (y
))
7907 double real_part
= (SCM_COMPLEX_REAL (x
)
7908 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7909 scm_remember_upto_here_1 (x
);
7910 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7912 else if (SCM_REALP (y
))
7913 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7914 SCM_COMPLEX_IMAG (x
));
7915 else if (SCM_COMPLEXP (y
))
7916 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7917 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7918 else if (SCM_FRACTIONP (y
))
7919 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7920 SCM_COMPLEX_IMAG (x
));
7922 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7924 else if (SCM_FRACTIONP (x
))
7926 if (SCM_I_INUMP (y
))
7927 /* a/b - c = (a - cb) / b */
7928 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7929 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7930 SCM_FRACTION_DENOMINATOR (x
));
7931 else if (SCM_BIGP (y
))
7932 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7933 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7934 SCM_FRACTION_DENOMINATOR (x
));
7935 else if (SCM_REALP (y
))
7936 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7937 else if (SCM_COMPLEXP (y
))
7938 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7939 -SCM_COMPLEX_IMAG (y
));
7940 else if (SCM_FRACTIONP (y
))
7941 /* a/b - c/d = (ad - bc) / bd */
7942 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7943 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7944 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7946 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7949 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7954 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7956 "Return @math{@var{x}-1}.")
7957 #define FUNC_NAME s_scm_oneminus
7959 return scm_difference (x
, SCM_INUM1
);
7964 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7965 (SCM x
, SCM y
, SCM rest
),
7966 "Return the product of all arguments. If called without arguments,\n"
7968 #define FUNC_NAME s_scm_i_product
7970 while (!scm_is_null (rest
))
7971 { x
= scm_product (x
, y
);
7973 rest
= scm_cdr (rest
);
7975 return scm_product (x
, y
);
7979 #define s_product s_scm_i_product
7980 #define g_product g_scm_i_product
7983 scm_product (SCM x
, SCM y
)
7985 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7988 return SCM_I_MAKINUM (1L);
7989 else if (SCM_NUMBERP (x
))
7992 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7995 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8000 xx
= SCM_I_INUM (x
);
8005 /* exact1 is the universal multiplicative identity */
8009 /* exact0 times a fixnum is exact0: optimize this case */
8010 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8012 /* if the other argument is inexact, the result is inexact,
8013 and we must do the multiplication in order to handle
8014 infinities and NaNs properly. */
8015 else if (SCM_REALP (y
))
8016 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8017 else if (SCM_COMPLEXP (y
))
8018 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8019 0.0 * SCM_COMPLEX_IMAG (y
));
8020 /* we've already handled inexact numbers,
8021 so y must be exact, and we return exact0 */
8022 else if (SCM_NUMP (y
))
8025 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8029 * This case is important for more than just optimization.
8030 * It handles the case of negating
8031 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8032 * which is a bignum that must be changed back into a fixnum.
8033 * Failure to do so will cause the following to return #f:
8034 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8036 return scm_difference(y
, SCM_UNDEFINED
);
8040 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8042 scm_t_inum yy
= SCM_I_INUM (y
);
8043 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8044 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8045 if (SCM_FIXABLE (kk
))
8046 return SCM_I_MAKINUM (kk
);
8048 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8049 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8050 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8051 return SCM_I_MAKINUM (xx
* yy
);
8055 SCM result
= scm_i_inum2big (xx
);
8056 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8057 return scm_i_normbig (result
);
8060 else if (SCM_BIGP (y
))
8062 SCM result
= scm_i_mkbig ();
8063 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8064 scm_remember_upto_here_1 (y
);
8067 else if (SCM_REALP (y
))
8068 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8069 else if (SCM_COMPLEXP (y
))
8070 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8071 xx
* SCM_COMPLEX_IMAG (y
));
8072 else if (SCM_FRACTIONP (y
))
8073 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8074 SCM_FRACTION_DENOMINATOR (y
));
8076 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8078 else if (SCM_BIGP (x
))
8080 if (SCM_I_INUMP (y
))
8085 else if (SCM_BIGP (y
))
8087 SCM result
= scm_i_mkbig ();
8088 mpz_mul (SCM_I_BIG_MPZ (result
),
8091 scm_remember_upto_here_2 (x
, y
);
8094 else if (SCM_REALP (y
))
8096 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8097 scm_remember_upto_here_1 (x
);
8098 return scm_i_from_double (result
);
8100 else if (SCM_COMPLEXP (y
))
8102 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8103 scm_remember_upto_here_1 (x
);
8104 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8105 z
* SCM_COMPLEX_IMAG (y
));
8107 else if (SCM_FRACTIONP (y
))
8108 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8109 SCM_FRACTION_DENOMINATOR (y
));
8111 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8113 else if (SCM_REALP (x
))
8115 if (SCM_I_INUMP (y
))
8120 else if (SCM_BIGP (y
))
8122 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8123 scm_remember_upto_here_1 (y
);
8124 return scm_i_from_double (result
);
8126 else if (SCM_REALP (y
))
8127 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8128 else if (SCM_COMPLEXP (y
))
8129 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8130 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8131 else if (SCM_FRACTIONP (y
))
8132 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8134 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8136 else if (SCM_COMPLEXP (x
))
8138 if (SCM_I_INUMP (y
))
8143 else if (SCM_BIGP (y
))
8145 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8146 scm_remember_upto_here_1 (y
);
8147 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8148 z
* SCM_COMPLEX_IMAG (x
));
8150 else if (SCM_REALP (y
))
8151 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8152 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8153 else if (SCM_COMPLEXP (y
))
8155 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8156 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8157 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8158 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8160 else if (SCM_FRACTIONP (y
))
8162 double yy
= scm_i_fraction2double (y
);
8163 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8164 yy
* SCM_COMPLEX_IMAG (x
));
8167 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8169 else if (SCM_FRACTIONP (x
))
8171 if (SCM_I_INUMP (y
))
8172 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8173 SCM_FRACTION_DENOMINATOR (x
));
8174 else if (SCM_BIGP (y
))
8175 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8176 SCM_FRACTION_DENOMINATOR (x
));
8177 else if (SCM_REALP (y
))
8178 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8179 else if (SCM_COMPLEXP (y
))
8181 double xx
= scm_i_fraction2double (x
);
8182 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8183 xx
* SCM_COMPLEX_IMAG (y
));
8185 else if (SCM_FRACTIONP (y
))
8186 /* a/b * c/d = ac / bd */
8187 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8188 SCM_FRACTION_NUMERATOR (y
)),
8189 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8190 SCM_FRACTION_DENOMINATOR (y
)));
8192 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8195 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8198 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8199 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8200 #define ALLOW_DIVIDE_BY_ZERO
8201 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8204 /* The code below for complex division is adapted from the GNU
8205 libstdc++, which adapted it from f2c's libF77, and is subject to
8208 /****************************************************************
8209 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8211 Permission to use, copy, modify, and distribute this software
8212 and its documentation for any purpose and without fee is hereby
8213 granted, provided that the above copyright notice appear in all
8214 copies and that both that the copyright notice and this
8215 permission notice and warranty disclaimer appear in supporting
8216 documentation, and that the names of AT&T Bell Laboratories or
8217 Bellcore or any of their entities not be used in advertising or
8218 publicity pertaining to distribution of the software without
8219 specific, written prior permission.
8221 AT&T and Bellcore disclaim all warranties with regard to this
8222 software, including all implied warranties of merchantability
8223 and fitness. In no event shall AT&T or Bellcore be liable for
8224 any special, indirect or consequential damages or any damages
8225 whatsoever resulting from loss of use, data or profits, whether
8226 in an action of contract, negligence or other tortious action,
8227 arising out of or in connection with the use or performance of
8229 ****************************************************************/
8231 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8232 (SCM x
, SCM y
, SCM rest
),
8233 "Divide the first argument by the product of the remaining\n"
8234 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8236 #define FUNC_NAME s_scm_i_divide
8238 while (!scm_is_null (rest
))
8239 { x
= scm_divide (x
, y
);
8241 rest
= scm_cdr (rest
);
8243 return scm_divide (x
, y
);
8247 #define s_divide s_scm_i_divide
8248 #define g_divide g_scm_i_divide
8251 scm_divide (SCM x
, SCM y
)
8252 #define FUNC_NAME s_divide
8256 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8259 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8260 else if (SCM_I_INUMP (x
))
8262 scm_t_inum xx
= SCM_I_INUM (x
);
8263 if (xx
== 1 || xx
== -1)
8265 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8267 scm_num_overflow (s_divide
);
8270 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8272 else if (SCM_BIGP (x
))
8273 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8274 else if (SCM_REALP (x
))
8276 double xx
= SCM_REAL_VALUE (x
);
8277 #ifndef ALLOW_DIVIDE_BY_ZERO
8279 scm_num_overflow (s_divide
);
8282 return scm_i_from_double (1.0 / xx
);
8284 else if (SCM_COMPLEXP (x
))
8286 double r
= SCM_COMPLEX_REAL (x
);
8287 double i
= SCM_COMPLEX_IMAG (x
);
8288 if (fabs(r
) <= fabs(i
))
8291 double d
= i
* (1.0 + t
* t
);
8292 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8297 double d
= r
* (1.0 + t
* t
);
8298 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8301 else if (SCM_FRACTIONP (x
))
8302 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8303 SCM_FRACTION_NUMERATOR (x
));
8305 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8308 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8310 scm_t_inum xx
= SCM_I_INUM (x
);
8311 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8313 scm_t_inum yy
= SCM_I_INUM (y
);
8316 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8317 scm_num_overflow (s_divide
);
8319 return scm_i_from_double ((double) xx
/ (double) yy
);
8322 else if (xx
% yy
!= 0)
8323 return scm_i_make_ratio (x
, y
);
8326 scm_t_inum z
= xx
/ yy
;
8327 if (SCM_FIXABLE (z
))
8328 return SCM_I_MAKINUM (z
);
8330 return scm_i_inum2big (z
);
8333 else if (SCM_BIGP (y
))
8334 return scm_i_make_ratio (x
, y
);
8335 else if (SCM_REALP (y
))
8337 double yy
= SCM_REAL_VALUE (y
);
8338 #ifndef ALLOW_DIVIDE_BY_ZERO
8340 scm_num_overflow (s_divide
);
8343 /* FIXME: Precision may be lost here due to:
8344 (1) The cast from 'scm_t_inum' to 'double'
8345 (2) Double rounding */
8346 return scm_i_from_double ((double) xx
/ yy
);
8348 else if (SCM_COMPLEXP (y
))
8351 complex_div
: /* y _must_ be a complex number */
8353 double r
= SCM_COMPLEX_REAL (y
);
8354 double i
= SCM_COMPLEX_IMAG (y
);
8355 if (fabs(r
) <= fabs(i
))
8358 double d
= i
* (1.0 + t
* t
);
8359 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8364 double d
= r
* (1.0 + t
* t
);
8365 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8369 else if (SCM_FRACTIONP (y
))
8370 /* a / b/c = ac / b */
8371 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8372 SCM_FRACTION_NUMERATOR (y
));
8374 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8376 else if (SCM_BIGP (x
))
8378 if (SCM_I_INUMP (y
))
8380 scm_t_inum yy
= SCM_I_INUM (y
);
8383 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8384 scm_num_overflow (s_divide
);
8386 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8387 scm_remember_upto_here_1 (x
);
8388 return (sgn
== 0) ? scm_nan () : scm_inf ();
8395 /* FIXME: HMM, what are the relative performance issues here?
8396 We need to test. Is it faster on average to test
8397 divisible_p, then perform whichever operation, or is it
8398 faster to perform the integer div opportunistically and
8399 switch to real if there's a remainder? For now we take the
8400 middle ground: test, then if divisible, use the faster div
8403 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8404 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8408 SCM result
= scm_i_mkbig ();
8409 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8410 scm_remember_upto_here_1 (x
);
8412 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8413 return scm_i_normbig (result
);
8416 return scm_i_make_ratio (x
, y
);
8419 else if (SCM_BIGP (y
))
8421 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8425 SCM result
= scm_i_mkbig ();
8426 mpz_divexact (SCM_I_BIG_MPZ (result
),
8429 scm_remember_upto_here_2 (x
, y
);
8430 return scm_i_normbig (result
);
8433 return scm_i_make_ratio (x
, y
);
8435 else if (SCM_REALP (y
))
8437 double yy
= SCM_REAL_VALUE (y
);
8438 #ifndef ALLOW_DIVIDE_BY_ZERO
8440 scm_num_overflow (s_divide
);
8443 /* FIXME: Precision may be lost here due to:
8444 (1) scm_i_big2dbl (2) Double rounding */
8445 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8447 else if (SCM_COMPLEXP (y
))
8449 a
= scm_i_big2dbl (x
);
8452 else if (SCM_FRACTIONP (y
))
8453 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8454 SCM_FRACTION_NUMERATOR (y
));
8456 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8458 else if (SCM_REALP (x
))
8460 double rx
= SCM_REAL_VALUE (x
);
8461 if (SCM_I_INUMP (y
))
8463 scm_t_inum yy
= SCM_I_INUM (y
);
8464 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8466 scm_num_overflow (s_divide
);
8469 /* FIXME: Precision may be lost here due to:
8470 (1) The cast from 'scm_t_inum' to 'double'
8471 (2) Double rounding */
8472 return scm_i_from_double (rx
/ (double) yy
);
8474 else if (SCM_BIGP (y
))
8476 /* FIXME: Precision may be lost here due to:
8477 (1) The conversion from bignum to double
8478 (2) Double rounding */
8479 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8480 scm_remember_upto_here_1 (y
);
8481 return scm_i_from_double (rx
/ dby
);
8483 else if (SCM_REALP (y
))
8485 double yy
= SCM_REAL_VALUE (y
);
8486 #ifndef ALLOW_DIVIDE_BY_ZERO
8488 scm_num_overflow (s_divide
);
8491 return scm_i_from_double (rx
/ yy
);
8493 else if (SCM_COMPLEXP (y
))
8498 else if (SCM_FRACTIONP (y
))
8499 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8501 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8503 else if (SCM_COMPLEXP (x
))
8505 double rx
= SCM_COMPLEX_REAL (x
);
8506 double ix
= SCM_COMPLEX_IMAG (x
);
8507 if (SCM_I_INUMP (y
))
8509 scm_t_inum yy
= SCM_I_INUM (y
);
8510 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8512 scm_num_overflow (s_divide
);
8516 /* FIXME: Precision may be lost here due to:
8517 (1) The conversion from 'scm_t_inum' to double
8518 (2) Double rounding */
8520 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8523 else if (SCM_BIGP (y
))
8525 /* FIXME: Precision may be lost here due to:
8526 (1) The conversion from bignum to double
8527 (2) Double rounding */
8528 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8529 scm_remember_upto_here_1 (y
);
8530 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8532 else if (SCM_REALP (y
))
8534 double yy
= SCM_REAL_VALUE (y
);
8535 #ifndef ALLOW_DIVIDE_BY_ZERO
8537 scm_num_overflow (s_divide
);
8540 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8542 else if (SCM_COMPLEXP (y
))
8544 double ry
= SCM_COMPLEX_REAL (y
);
8545 double iy
= SCM_COMPLEX_IMAG (y
);
8546 if (fabs(ry
) <= fabs(iy
))
8549 double d
= iy
* (1.0 + t
* t
);
8550 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8555 double d
= ry
* (1.0 + t
* t
);
8556 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8559 else if (SCM_FRACTIONP (y
))
8561 /* FIXME: Precision may be lost here due to:
8562 (1) The conversion from fraction to double
8563 (2) Double rounding */
8564 double yy
= scm_i_fraction2double (y
);
8565 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8568 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8570 else if (SCM_FRACTIONP (x
))
8572 if (SCM_I_INUMP (y
))
8574 scm_t_inum yy
= SCM_I_INUM (y
);
8575 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8577 scm_num_overflow (s_divide
);
8580 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8581 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8583 else if (SCM_BIGP (y
))
8585 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8586 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8588 else if (SCM_REALP (y
))
8590 double yy
= SCM_REAL_VALUE (y
);
8591 #ifndef ALLOW_DIVIDE_BY_ZERO
8593 scm_num_overflow (s_divide
);
8596 /* FIXME: Precision may be lost here due to:
8597 (1) The conversion from fraction to double
8598 (2) Double rounding */
8599 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8601 else if (SCM_COMPLEXP (y
))
8603 /* FIXME: Precision may be lost here due to:
8604 (1) The conversion from fraction to double
8605 (2) Double rounding */
8606 a
= scm_i_fraction2double (x
);
8609 else if (SCM_FRACTIONP (y
))
8610 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8611 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8613 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8616 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8622 scm_c_truncate (double x
)
8627 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8628 half-way case (ie. when x is an integer plus 0.5) going upwards.
8629 Then half-way cases are identified and adjusted down if the
8630 round-upwards didn't give the desired even integer.
8632 "plus_half == result" identifies a half-way case. If plus_half, which is
8633 x + 0.5, is an integer then x must be an integer plus 0.5.
8635 An odd "result" value is identified with result/2 != floor(result/2).
8636 This is done with plus_half, since that value is ready for use sooner in
8637 a pipelined cpu, and we're already requiring plus_half == result.
8639 Note however that we need to be careful when x is big and already an
8640 integer. In that case "x+0.5" may round to an adjacent integer, causing
8641 us to return such a value, incorrectly. For instance if the hardware is
8642 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8643 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8644 returned. Or if the hardware is in round-upwards mode, then other bigger
8645 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8646 representable value, 2^128+2^76 (or whatever), again incorrect.
8648 These bad roundings of x+0.5 are avoided by testing at the start whether
8649 x is already an integer. If it is then clearly that's the desired result
8650 already. And if it's not then the exponent must be small enough to allow
8651 an 0.5 to be represented, and hence added without a bad rounding. */
8654 scm_c_round (double x
)
8656 double plus_half
, result
;
8661 plus_half
= x
+ 0.5;
8662 result
= floor (plus_half
);
8663 /* Adjust so that the rounding is towards even. */
8664 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8669 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8671 "Round the number @var{x} towards zero.")
8672 #define FUNC_NAME s_scm_truncate_number
8674 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8676 else if (SCM_REALP (x
))
8677 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8678 else if (SCM_FRACTIONP (x
))
8679 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8680 SCM_FRACTION_DENOMINATOR (x
));
8682 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8683 s_scm_truncate_number
);
8687 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8689 "Round the number @var{x} towards the nearest integer. "
8690 "When it is exactly halfway between two integers, "
8691 "round towards the even one.")
8692 #define FUNC_NAME s_scm_round_number
8694 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8696 else if (SCM_REALP (x
))
8697 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8698 else if (SCM_FRACTIONP (x
))
8699 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8700 SCM_FRACTION_DENOMINATOR (x
));
8702 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8703 s_scm_round_number
);
8707 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8709 "Round the number @var{x} towards minus infinity.")
8710 #define FUNC_NAME s_scm_floor
8712 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8714 else if (SCM_REALP (x
))
8715 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8716 else if (SCM_FRACTIONP (x
))
8717 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8718 SCM_FRACTION_DENOMINATOR (x
));
8720 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8724 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8726 "Round the number @var{x} towards infinity.")
8727 #define FUNC_NAME s_scm_ceiling
8729 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8731 else if (SCM_REALP (x
))
8732 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8733 else if (SCM_FRACTIONP (x
))
8734 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8735 SCM_FRACTION_DENOMINATOR (x
));
8737 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8741 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8743 "Return @var{x} raised to the power of @var{y}.")
8744 #define FUNC_NAME s_scm_expt
8746 if (scm_is_integer (y
))
8748 if (scm_is_true (scm_exact_p (y
)))
8749 return scm_integer_expt (x
, y
);
8752 /* Here we handle the case where the exponent is an inexact
8753 integer. We make the exponent exact in order to use
8754 scm_integer_expt, and thus avoid the spurious imaginary
8755 parts that may result from round-off errors in the general
8756 e^(y log x) method below (for example when squaring a large
8757 negative number). In this case, we must return an inexact
8758 result for correctness. We also make the base inexact so
8759 that scm_integer_expt will use fast inexact arithmetic
8760 internally. Note that making the base inexact is not
8761 sufficient to guarantee an inexact result, because
8762 scm_integer_expt will return an exact 1 when the exponent
8763 is 0, even if the base is inexact. */
8764 return scm_exact_to_inexact
8765 (scm_integer_expt (scm_exact_to_inexact (x
),
8766 scm_inexact_to_exact (y
)));
8769 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8771 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8773 else if (scm_is_complex (x
) && scm_is_complex (y
))
8774 return scm_exp (scm_product (scm_log (x
), y
));
8775 else if (scm_is_complex (x
))
8776 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8778 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8782 /* sin/cos/tan/asin/acos/atan
8783 sinh/cosh/tanh/asinh/acosh/atanh
8784 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8785 Written by Jerry D. Hedden, (C) FSF.
8786 See the file `COPYING' for terms applying to this program. */
8788 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8790 "Compute the sine of @var{z}.")
8791 #define FUNC_NAME s_scm_sin
8793 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8794 return z
; /* sin(exact0) = exact0 */
8795 else if (scm_is_real (z
))
8796 return scm_i_from_double (sin (scm_to_double (z
)));
8797 else if (SCM_COMPLEXP (z
))
8799 x
= SCM_COMPLEX_REAL (z
);
8800 y
= SCM_COMPLEX_IMAG (z
);
8801 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8802 cos (x
) * sinh (y
));
8805 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8809 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8811 "Compute the cosine of @var{z}.")
8812 #define FUNC_NAME s_scm_cos
8814 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8815 return SCM_INUM1
; /* cos(exact0) = exact1 */
8816 else if (scm_is_real (z
))
8817 return scm_i_from_double (cos (scm_to_double (z
)));
8818 else if (SCM_COMPLEXP (z
))
8820 x
= SCM_COMPLEX_REAL (z
);
8821 y
= SCM_COMPLEX_IMAG (z
);
8822 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8823 -sin (x
) * sinh (y
));
8826 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8830 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8832 "Compute the tangent of @var{z}.")
8833 #define FUNC_NAME s_scm_tan
8835 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8836 return z
; /* tan(exact0) = exact0 */
8837 else if (scm_is_real (z
))
8838 return scm_i_from_double (tan (scm_to_double (z
)));
8839 else if (SCM_COMPLEXP (z
))
8841 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8842 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8843 w
= cos (x
) + cosh (y
);
8844 #ifndef ALLOW_DIVIDE_BY_ZERO
8846 scm_num_overflow (s_scm_tan
);
8848 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8851 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8855 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8857 "Compute the hyperbolic sine of @var{z}.")
8858 #define FUNC_NAME s_scm_sinh
8860 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8861 return z
; /* sinh(exact0) = exact0 */
8862 else if (scm_is_real (z
))
8863 return scm_i_from_double (sinh (scm_to_double (z
)));
8864 else if (SCM_COMPLEXP (z
))
8866 x
= SCM_COMPLEX_REAL (z
);
8867 y
= SCM_COMPLEX_IMAG (z
);
8868 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8869 cosh (x
) * sin (y
));
8872 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8876 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8878 "Compute the hyperbolic cosine of @var{z}.")
8879 #define FUNC_NAME s_scm_cosh
8881 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8882 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8883 else if (scm_is_real (z
))
8884 return scm_i_from_double (cosh (scm_to_double (z
)));
8885 else if (SCM_COMPLEXP (z
))
8887 x
= SCM_COMPLEX_REAL (z
);
8888 y
= SCM_COMPLEX_IMAG (z
);
8889 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8890 sinh (x
) * sin (y
));
8893 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8897 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8899 "Compute the hyperbolic tangent of @var{z}.")
8900 #define FUNC_NAME s_scm_tanh
8902 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8903 return z
; /* tanh(exact0) = exact0 */
8904 else if (scm_is_real (z
))
8905 return scm_i_from_double (tanh (scm_to_double (z
)));
8906 else if (SCM_COMPLEXP (z
))
8908 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8909 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8910 w
= cosh (x
) + cos (y
);
8911 #ifndef ALLOW_DIVIDE_BY_ZERO
8913 scm_num_overflow (s_scm_tanh
);
8915 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8918 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8922 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8924 "Compute the arc sine of @var{z}.")
8925 #define FUNC_NAME s_scm_asin
8927 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8928 return z
; /* asin(exact0) = exact0 */
8929 else if (scm_is_real (z
))
8931 double w
= scm_to_double (z
);
8932 if (w
>= -1.0 && w
<= 1.0)
8933 return scm_i_from_double (asin (w
));
8935 return scm_product (scm_c_make_rectangular (0, -1),
8936 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8938 else if (SCM_COMPLEXP (z
))
8940 x
= SCM_COMPLEX_REAL (z
);
8941 y
= SCM_COMPLEX_IMAG (z
);
8942 return scm_product (scm_c_make_rectangular (0, -1),
8943 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8946 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8950 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8952 "Compute the arc cosine of @var{z}.")
8953 #define FUNC_NAME s_scm_acos
8955 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8956 return SCM_INUM0
; /* acos(exact1) = exact0 */
8957 else if (scm_is_real (z
))
8959 double w
= scm_to_double (z
);
8960 if (w
>= -1.0 && w
<= 1.0)
8961 return scm_i_from_double (acos (w
));
8963 return scm_sum (scm_i_from_double (acos (0.0)),
8964 scm_product (scm_c_make_rectangular (0, 1),
8965 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8967 else if (SCM_COMPLEXP (z
))
8969 x
= SCM_COMPLEX_REAL (z
);
8970 y
= SCM_COMPLEX_IMAG (z
);
8971 return scm_sum (scm_i_from_double (acos (0.0)),
8972 scm_product (scm_c_make_rectangular (0, 1),
8973 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8976 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8980 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8982 "With one argument, compute the arc tangent of @var{z}.\n"
8983 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8984 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8985 #define FUNC_NAME s_scm_atan
8989 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8990 return z
; /* atan(exact0) = exact0 */
8991 else if (scm_is_real (z
))
8992 return scm_i_from_double (atan (scm_to_double (z
)));
8993 else if (SCM_COMPLEXP (z
))
8996 v
= SCM_COMPLEX_REAL (z
);
8997 w
= SCM_COMPLEX_IMAG (z
);
8998 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8999 scm_c_make_rectangular (v
, w
+ 1.0))),
9000 scm_c_make_rectangular (0, 2));
9003 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
9005 else if (scm_is_real (z
))
9007 if (scm_is_real (y
))
9008 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9010 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9013 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9017 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9019 "Compute the inverse hyperbolic sine of @var{z}.")
9020 #define FUNC_NAME s_scm_sys_asinh
9022 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9023 return z
; /* asinh(exact0) = exact0 */
9024 else if (scm_is_real (z
))
9025 return scm_i_from_double (asinh (scm_to_double (z
)));
9026 else if (scm_is_number (z
))
9027 return scm_log (scm_sum (z
,
9028 scm_sqrt (scm_sum (scm_product (z
, z
),
9031 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9035 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9037 "Compute the inverse hyperbolic cosine of @var{z}.")
9038 #define FUNC_NAME s_scm_sys_acosh
9040 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9041 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9042 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9043 return scm_i_from_double (acosh (scm_to_double (z
)));
9044 else if (scm_is_number (z
))
9045 return scm_log (scm_sum (z
,
9046 scm_sqrt (scm_difference (scm_product (z
, z
),
9049 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9053 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9055 "Compute the inverse hyperbolic tangent of @var{z}.")
9056 #define FUNC_NAME s_scm_sys_atanh
9058 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9059 return z
; /* atanh(exact0) = exact0 */
9060 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9061 return scm_i_from_double (atanh (scm_to_double (z
)));
9062 else if (scm_is_number (z
))
9063 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9064 scm_difference (SCM_INUM1
, z
))),
9067 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9072 scm_c_make_rectangular (double re
, double im
)
9076 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9078 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9079 SCM_COMPLEX_REAL (z
) = re
;
9080 SCM_COMPLEX_IMAG (z
) = im
;
9084 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9085 (SCM real_part
, SCM imaginary_part
),
9086 "Return a complex number constructed of the given @var{real_part} "
9087 "and @var{imaginary_part} parts.")
9088 #define FUNC_NAME s_scm_make_rectangular
9090 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9091 SCM_ARG1
, FUNC_NAME
, "real");
9092 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9093 SCM_ARG2
, FUNC_NAME
, "real");
9095 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9096 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9099 return scm_c_make_rectangular (scm_to_double (real_part
),
9100 scm_to_double (imaginary_part
));
9105 scm_c_make_polar (double mag
, double ang
)
9109 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9110 use it on Glibc-based systems that have it (it's a GNU extension). See
9111 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9113 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9114 sincos (ang
, &s
, &c
);
9120 /* If s and c are NaNs, this indicates that the angle is a NaN,
9121 infinite, or perhaps simply too large to determine its value
9122 mod 2*pi. However, we know something that the floating-point
9123 implementation doesn't know: We know that s and c are finite.
9124 Therefore, if the magnitude is zero, return a complex zero.
9126 The reason we check for the NaNs instead of using this case
9127 whenever mag == 0.0 is because when the angle is known, we'd
9128 like to return the correct kind of non-real complex zero:
9129 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9130 on which quadrant the angle is in.
9132 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9133 return scm_c_make_rectangular (0.0, 0.0);
9135 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9138 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9140 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9141 #define FUNC_NAME s_scm_make_polar
9143 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9144 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9146 /* If mag is exact0, return exact0 */
9147 if (scm_is_eq (mag
, SCM_INUM0
))
9149 /* Return a real if ang is exact0 */
9150 else if (scm_is_eq (ang
, SCM_INUM0
))
9153 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9158 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9160 "Return the real part of the number @var{z}.")
9161 #define FUNC_NAME s_scm_real_part
9163 if (SCM_COMPLEXP (z
))
9164 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9165 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9168 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9173 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9175 "Return the imaginary part of the number @var{z}.")
9176 #define FUNC_NAME s_scm_imag_part
9178 if (SCM_COMPLEXP (z
))
9179 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9180 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9183 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9187 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9189 "Return the numerator of the number @var{z}.")
9190 #define FUNC_NAME s_scm_numerator
9192 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9194 else if (SCM_FRACTIONP (z
))
9195 return SCM_FRACTION_NUMERATOR (z
);
9196 else if (SCM_REALP (z
))
9197 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9199 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9204 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9206 "Return the denominator of the number @var{z}.")
9207 #define FUNC_NAME s_scm_denominator
9209 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9211 else if (SCM_FRACTIONP (z
))
9212 return SCM_FRACTION_DENOMINATOR (z
);
9213 else if (SCM_REALP (z
))
9214 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9216 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9222 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9224 "Return the magnitude of the number @var{z}. This is the same as\n"
9225 "@code{abs} for real arguments, but also allows complex numbers.")
9226 #define FUNC_NAME s_scm_magnitude
9228 if (SCM_I_INUMP (z
))
9230 scm_t_inum zz
= SCM_I_INUM (z
);
9233 else if (SCM_POSFIXABLE (-zz
))
9234 return SCM_I_MAKINUM (-zz
);
9236 return scm_i_inum2big (-zz
);
9238 else if (SCM_BIGP (z
))
9240 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9241 scm_remember_upto_here_1 (z
);
9243 return scm_i_clonebig (z
, 0);
9247 else if (SCM_REALP (z
))
9248 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9249 else if (SCM_COMPLEXP (z
))
9250 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9251 else if (SCM_FRACTIONP (z
))
9253 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9255 return scm_i_make_ratio_already_reduced
9256 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9257 SCM_FRACTION_DENOMINATOR (z
));
9260 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9266 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9268 "Return the angle of the complex number @var{z}.")
9269 #define FUNC_NAME s_scm_angle
9271 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9272 flo0 to save allocating a new flonum with scm_i_from_double each time.
9273 But if atan2 follows the floating point rounding mode, then the value
9274 is not a constant. Maybe it'd be close enough though. */
9275 if (SCM_I_INUMP (z
))
9277 if (SCM_I_INUM (z
) >= 0)
9280 return scm_i_from_double (atan2 (0.0, -1.0));
9282 else if (SCM_BIGP (z
))
9284 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9285 scm_remember_upto_here_1 (z
);
9287 return scm_i_from_double (atan2 (0.0, -1.0));
9291 else if (SCM_REALP (z
))
9293 double x
= SCM_REAL_VALUE (z
);
9294 if (copysign (1.0, x
) > 0.0)
9297 return scm_i_from_double (atan2 (0.0, -1.0));
9299 else if (SCM_COMPLEXP (z
))
9300 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9301 else if (SCM_FRACTIONP (z
))
9303 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9305 else return scm_i_from_double (atan2 (0.0, -1.0));
9308 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9313 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9315 "Convert the number @var{z} to its inexact representation.\n")
9316 #define FUNC_NAME s_scm_exact_to_inexact
9318 if (SCM_I_INUMP (z
))
9319 return scm_i_from_double ((double) SCM_I_INUM (z
));
9320 else if (SCM_BIGP (z
))
9321 return scm_i_from_double (scm_i_big2dbl (z
));
9322 else if (SCM_FRACTIONP (z
))
9323 return scm_i_from_double (scm_i_fraction2double (z
));
9324 else if (SCM_INEXACTP (z
))
9327 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9328 s_scm_exact_to_inexact
);
9333 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9335 "Return an exact number that is numerically closest to @var{z}.")
9336 #define FUNC_NAME s_scm_inexact_to_exact
9338 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9345 val
= SCM_REAL_VALUE (z
);
9346 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9347 val
= SCM_COMPLEX_REAL (z
);
9349 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9350 s_scm_inexact_to_exact
);
9352 if (!SCM_LIKELY (isfinite (val
)))
9353 SCM_OUT_OF_RANGE (1, z
);
9354 else if (val
== 0.0)
9361 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9363 expon
-= DBL_MANT_DIG
;
9366 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9370 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9371 SCM_I_BIG_MPZ (numerator
),
9375 numerator
= scm_i_normbig (numerator
);
9377 return scm_i_make_ratio_already_reduced
9378 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9380 return left_shift_exact_integer (numerator
, expon
);
9388 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9390 "Returns the @emph{simplest} rational number differing\n"
9391 "from @var{x} by no more than @var{eps}.\n"
9393 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9394 "exact result when both its arguments are exact. Thus, you might need\n"
9395 "to use @code{inexact->exact} on the arguments.\n"
9398 "(rationalize (inexact->exact 1.2) 1/100)\n"
9401 #define FUNC_NAME s_scm_rationalize
9403 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9404 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9406 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9408 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9410 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9415 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9418 return scm_exact_to_inexact
9419 (scm_rationalize (scm_inexact_to_exact (x
),
9420 scm_inexact_to_exact (eps
)));
9424 /* X and EPS are exact rationals.
9426 The code that follows is equivalent to the following Scheme code:
9428 (define (exact-rationalize x eps)
9429 (let ((n1 (if (negative? x) -1 1))
9432 (let ((lo (- x eps))
9436 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9437 (nhi (numerator hi)) (dhi (denominator hi))
9438 (n1 n1) (d1 0) (n2 0) (d2 1))
9439 (let-values (((qlo rlo) (floor/ nlo dlo))
9440 ((qhi rhi) (floor/ nhi dhi)))
9441 (let ((n0 (+ n2 (* n1 qlo)))
9442 (d0 (+ d2 (* d1 qlo))))
9443 (cond ((zero? rlo) (/ n0 d0))
9444 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9445 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9451 eps
= scm_abs (eps
);
9452 if (scm_is_true (scm_negative_p (x
)))
9455 x
= scm_difference (x
, SCM_UNDEFINED
);
9458 /* X and EPS are non-negative exact rationals. */
9460 lo
= scm_difference (x
, eps
);
9461 hi
= scm_sum (x
, eps
);
9463 if (scm_is_false (scm_positive_p (lo
)))
9464 /* If zero is included in the interval, return it.
9465 It is the simplest rational of all. */
9470 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9471 mpz_t nlo
, dlo
, nhi
, dhi
;
9472 mpz_t qlo
, rlo
, qhi
, rhi
;
9474 /* LO and HI are positive exact rationals. */
9476 /* Our approach here follows the method described by Alan
9477 Bawden in a message entitled "(rationalize x y)" on the
9478 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9480 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9482 In brief, we compute the continued fractions of the two
9483 endpoints of the interval (LO and HI). The continued
9484 fraction of the result consists of the common prefix of the
9485 continued fractions of LO and HI, plus one final term. The
9486 final term of the result is the smallest integer contained
9487 in the interval between the remainders of LO and HI after
9488 the common prefix has been removed.
9490 The following code lazily computes the continued fraction
9491 representations of LO and HI, and simultaneously converts
9492 the continued fraction of the result into a rational
9493 number. We use MPZ functions directly to avoid type
9494 dispatch and GC allocation during the loop. */
9496 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9501 /* The variables N1, D1, N2 and D2 are used to compute the
9502 resulting rational from its continued fraction. At each
9503 step, N2/D2 and N1/D1 are the last two convergents. They
9504 are normally initialized to 0/1 and 1/0, respectively.
9505 However, if we negated X then we must negate the result as
9506 well, and we do that by initializing N1/D1 to -1/0. */
9507 mpz_set_si (n1
, n1_init
);
9512 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9513 compute the continued fraction representations of LO and HI
9514 using Euclid's algorithm. Initially, NLO/DLO == LO and
9516 scm_to_mpz (scm_numerator (lo
), nlo
);
9517 scm_to_mpz (scm_denominator (lo
), dlo
);
9518 scm_to_mpz (scm_numerator (hi
), nhi
);
9519 scm_to_mpz (scm_denominator (hi
), dhi
);
9521 /* As long as we're using exact arithmetic, the following loop
9522 is guaranteed to terminate. */
9525 /* Compute the next terms (QLO and QHI) of the continued
9526 fractions of LO and HI. */
9527 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9528 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9530 /* The next term of the result will be either QLO or
9531 QLO+1. Here we compute the next convergent of the
9532 result based on the assumption that QLO is the next
9533 term. If that turns out to be wrong, we'll adjust
9534 these later by adding N1 to N0 and D1 to D0. */
9535 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9536 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9538 /* We stop iterating when an integer is contained in the
9539 interval between the remainders NLO/DLO and NHI/DHI.
9540 There are two cases to consider: either NLO/DLO == QLO
9541 is an integer (indicated by RLO == 0), or QLO < QHI. */
9542 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9545 /* Efficiently shuffle variables around for the next
9546 iteration. First we shift the recent convergents. */
9547 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9548 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9550 /* The following shuffling is a bit confusing, so some
9551 explanation is in order. Conceptually, we're doing a
9552 couple of things here. After substracting the floor of
9553 NLO/DLO, the remainder is RLO/DLO. The rest of the
9554 continued fraction will represent the remainder's
9555 reciprocal DLO/RLO. Similarly for the HI endpoint.
9556 So in the next iteration, the new endpoints will be
9557 DLO/RLO and DHI/RHI. However, when we take the
9558 reciprocals of these endpoints, their order is
9559 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9560 and NHI/DHI <-- DLO/RLO. */
9561 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9562 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9565 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9566 The last term of the result will be the smallest integer in
9567 that interval, which is ceiling(NLO/DLO). We have already
9568 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9569 equal to the ceiling. */
9570 if (mpz_sgn (rlo
) != 0)
9572 /* If RLO is non-zero, then NLO/DLO is not an integer and
9573 the next term will be QLO+1. QLO was used in the
9574 computation of N0 and D0 above. Here we adjust N0 and
9575 D0 to be based on QLO+1 instead of QLO. */
9576 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9577 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9580 /* The simplest rational in the interval is N0/D0 */
9581 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9583 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9593 /* conversion functions */
9596 scm_is_integer (SCM val
)
9598 return scm_is_true (scm_integer_p (val
));
9602 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9604 if (SCM_I_INUMP (val
))
9606 scm_t_signed_bits n
= SCM_I_INUM (val
);
9607 return n
>= min
&& n
<= max
;
9609 else if (SCM_BIGP (val
))
9611 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9613 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9615 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9617 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9618 return n
>= min
&& n
<= max
;
9628 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9629 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9632 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9633 SCM_I_BIG_MPZ (val
));
9635 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9647 return n
>= min
&& n
<= max
;
9655 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9657 if (SCM_I_INUMP (val
))
9659 scm_t_signed_bits n
= SCM_I_INUM (val
);
9660 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9662 else if (SCM_BIGP (val
))
9664 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9666 else if (max
<= ULONG_MAX
)
9668 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9670 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9671 return n
>= min
&& n
<= max
;
9681 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9684 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9685 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9688 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9689 SCM_I_BIG_MPZ (val
));
9691 return n
>= min
&& n
<= max
;
9699 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9701 scm_error (scm_out_of_range_key
,
9703 "Value out of range ~S to ~S: ~S",
9704 scm_list_3 (min
, max
, bad_val
),
9705 scm_list_1 (bad_val
));
9708 #define TYPE scm_t_intmax
9709 #define TYPE_MIN min
9710 #define TYPE_MAX max
9711 #define SIZEOF_TYPE 0
9712 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9713 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9714 #include "libguile/conv-integer.i.c"
9716 #define TYPE scm_t_uintmax
9717 #define TYPE_MIN min
9718 #define TYPE_MAX max
9719 #define SIZEOF_TYPE 0
9720 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9721 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9722 #include "libguile/conv-uinteger.i.c"
9724 #define TYPE scm_t_int8
9725 #define TYPE_MIN SCM_T_INT8_MIN
9726 #define TYPE_MAX SCM_T_INT8_MAX
9727 #define SIZEOF_TYPE 1
9728 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9729 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9730 #include "libguile/conv-integer.i.c"
9732 #define TYPE scm_t_uint8
9734 #define TYPE_MAX SCM_T_UINT8_MAX
9735 #define SIZEOF_TYPE 1
9736 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9737 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9738 #include "libguile/conv-uinteger.i.c"
9740 #define TYPE scm_t_int16
9741 #define TYPE_MIN SCM_T_INT16_MIN
9742 #define TYPE_MAX SCM_T_INT16_MAX
9743 #define SIZEOF_TYPE 2
9744 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9745 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9746 #include "libguile/conv-integer.i.c"
9748 #define TYPE scm_t_uint16
9750 #define TYPE_MAX SCM_T_UINT16_MAX
9751 #define SIZEOF_TYPE 2
9752 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9753 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9754 #include "libguile/conv-uinteger.i.c"
9756 #define TYPE scm_t_int32
9757 #define TYPE_MIN SCM_T_INT32_MIN
9758 #define TYPE_MAX SCM_T_INT32_MAX
9759 #define SIZEOF_TYPE 4
9760 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9761 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9762 #include "libguile/conv-integer.i.c"
9764 #define TYPE scm_t_uint32
9766 #define TYPE_MAX SCM_T_UINT32_MAX
9767 #define SIZEOF_TYPE 4
9768 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9769 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9770 #include "libguile/conv-uinteger.i.c"
9772 #define TYPE scm_t_wchar
9773 #define TYPE_MIN (scm_t_int32)-1
9774 #define TYPE_MAX (scm_t_int32)0x10ffff
9775 #define SIZEOF_TYPE 4
9776 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9777 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9778 #include "libguile/conv-integer.i.c"
9780 #define TYPE scm_t_int64
9781 #define TYPE_MIN SCM_T_INT64_MIN
9782 #define TYPE_MAX SCM_T_INT64_MAX
9783 #define SIZEOF_TYPE 8
9784 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9785 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9786 #include "libguile/conv-integer.i.c"
9788 #define TYPE scm_t_uint64
9790 #define TYPE_MAX SCM_T_UINT64_MAX
9791 #define SIZEOF_TYPE 8
9792 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9793 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9794 #include "libguile/conv-uinteger.i.c"
9797 scm_to_mpz (SCM val
, mpz_t rop
)
9799 if (SCM_I_INUMP (val
))
9800 mpz_set_si (rop
, SCM_I_INUM (val
));
9801 else if (SCM_BIGP (val
))
9802 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9804 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9808 scm_from_mpz (mpz_t val
)
9810 return scm_i_mpz2num (val
);
9814 scm_is_real (SCM val
)
9816 return scm_is_true (scm_real_p (val
));
9820 scm_is_rational (SCM val
)
9822 return scm_is_true (scm_rational_p (val
));
9826 scm_to_double (SCM val
)
9828 if (SCM_I_INUMP (val
))
9829 return SCM_I_INUM (val
);
9830 else if (SCM_BIGP (val
))
9831 return scm_i_big2dbl (val
);
9832 else if (SCM_FRACTIONP (val
))
9833 return scm_i_fraction2double (val
);
9834 else if (SCM_REALP (val
))
9835 return SCM_REAL_VALUE (val
);
9837 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9841 scm_from_double (double val
)
9843 return scm_i_from_double (val
);
9847 scm_is_complex (SCM val
)
9849 return scm_is_true (scm_complex_p (val
));
9853 scm_c_real_part (SCM z
)
9855 if (SCM_COMPLEXP (z
))
9856 return SCM_COMPLEX_REAL (z
);
9859 /* Use the scm_real_part to get proper error checking and
9862 return scm_to_double (scm_real_part (z
));
9867 scm_c_imag_part (SCM z
)
9869 if (SCM_COMPLEXP (z
))
9870 return SCM_COMPLEX_IMAG (z
);
9873 /* Use the scm_imag_part to get proper error checking and
9874 dispatching. The result will almost always be 0.0, but not
9877 return scm_to_double (scm_imag_part (z
));
9882 scm_c_magnitude (SCM z
)
9884 return scm_to_double (scm_magnitude (z
));
9890 return scm_to_double (scm_angle (z
));
9894 scm_is_number (SCM z
)
9896 return scm_is_true (scm_number_p (z
));
9900 /* Returns log(x * 2^shift) */
9902 log_of_shifted_double (double x
, long shift
)
9904 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9906 if (copysign (1.0, x
) > 0.0)
9907 return scm_i_from_double (ans
);
9909 return scm_c_make_rectangular (ans
, M_PI
);
9912 /* Returns log(n), for exact integer n */
9914 log_of_exact_integer (SCM n
)
9916 if (SCM_I_INUMP (n
))
9917 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9918 else if (SCM_BIGP (n
))
9921 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9922 return log_of_shifted_double (signif
, expon
);
9925 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9928 /* Returns log(n/d), for exact non-zero integers n and d */
9930 log_of_fraction (SCM n
, SCM d
)
9932 long n_size
= scm_to_long (scm_integer_length (n
));
9933 long d_size
= scm_to_long (scm_integer_length (d
));
9935 if (abs (n_size
- d_size
) > 1)
9936 return (scm_difference (log_of_exact_integer (n
),
9937 log_of_exact_integer (d
)));
9938 else if (scm_is_false (scm_negative_p (n
)))
9939 return scm_i_from_double
9940 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9942 return scm_c_make_rectangular
9943 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9949 /* In the following functions we dispatch to the real-arg funcs like log()
9950 when we know the arg is real, instead of just handing everything to
9951 clog() for instance. This is in case clog() doesn't optimize for a
9952 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9953 well use it to go straight to the applicable C func. */
9955 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9957 "Return the natural logarithm of @var{z}.")
9958 #define FUNC_NAME s_scm_log
9960 if (SCM_COMPLEXP (z
))
9962 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9963 && defined (SCM_COMPLEX_VALUE)
9964 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9966 double re
= SCM_COMPLEX_REAL (z
);
9967 double im
= SCM_COMPLEX_IMAG (z
);
9968 return scm_c_make_rectangular (log (hypot (re
, im
)),
9972 else if (SCM_REALP (z
))
9973 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9974 else if (SCM_I_INUMP (z
))
9976 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9977 if (scm_is_eq (z
, SCM_INUM0
))
9978 scm_num_overflow (s_scm_log
);
9980 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9982 else if (SCM_BIGP (z
))
9983 return log_of_exact_integer (z
);
9984 else if (SCM_FRACTIONP (z
))
9985 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9986 SCM_FRACTION_DENOMINATOR (z
));
9988 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9993 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9995 "Return the base 10 logarithm of @var{z}.")
9996 #define FUNC_NAME s_scm_log10
9998 if (SCM_COMPLEXP (z
))
10000 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10001 clog() and a multiply by M_LOG10E, rather than the fallback
10002 log10+hypot+atan2.) */
10003 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10004 && defined SCM_COMPLEX_VALUE
10005 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10007 double re
= SCM_COMPLEX_REAL (z
);
10008 double im
= SCM_COMPLEX_IMAG (z
);
10009 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10010 M_LOG10E
* atan2 (im
, re
));
10013 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10015 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10016 if (scm_is_eq (z
, SCM_INUM0
))
10017 scm_num_overflow (s_scm_log10
);
10020 double re
= scm_to_double (z
);
10021 double l
= log10 (fabs (re
));
10022 if (copysign (1.0, re
) > 0.0)
10023 return scm_i_from_double (l
);
10025 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10028 else if (SCM_BIGP (z
))
10029 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10030 else if (SCM_FRACTIONP (z
))
10031 return scm_product (flo_log10e
,
10032 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10033 SCM_FRACTION_DENOMINATOR (z
)));
10035 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10040 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10042 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10043 "base of natural logarithms (2.71828@dots{}).")
10044 #define FUNC_NAME s_scm_exp
10046 if (SCM_COMPLEXP (z
))
10048 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10049 && defined (SCM_COMPLEX_VALUE)
10050 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10052 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10053 SCM_COMPLEX_IMAG (z
));
10056 else if (SCM_NUMBERP (z
))
10058 /* When z is a negative bignum the conversion to double overflows,
10059 giving -infinity, but that's ok, the exp is still 0.0. */
10060 return scm_i_from_double (exp (scm_to_double (z
)));
10063 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10068 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10070 "Return two exact non-negative integers @var{s} and @var{r}\n"
10071 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10072 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10073 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10076 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10078 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10082 scm_exact_integer_sqrt (k
, &s
, &r
);
10083 return scm_values (scm_list_2 (s
, r
));
10088 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10090 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10094 if (SCM_I_INUM (k
) < 0)
10095 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10096 "exact non-negative integer");
10097 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10098 mpz_inits (ss
, rr
, NULL
);
10099 mpz_sqrtrem (ss
, rr
, kk
);
10100 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10101 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10102 mpz_clears (kk
, ss
, rr
, NULL
);
10104 else if (SCM_LIKELY (SCM_BIGP (k
)))
10108 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10109 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10110 "exact non-negative integer");
10111 s
= scm_i_mkbig ();
10112 r
= scm_i_mkbig ();
10113 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10114 scm_remember_upto_here_1 (k
);
10115 *sp
= scm_i_normbig (s
);
10116 *rp
= scm_i_normbig (r
);
10119 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10120 "exact non-negative integer");
10123 /* Return true iff K is a perfect square.
10124 K must be an exact integer. */
10126 exact_integer_is_perfect_square (SCM k
)
10130 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10134 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10135 result
= mpz_perfect_square_p (kk
);
10140 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10141 scm_remember_upto_here_1 (k
);
10146 /* Return the floor of the square root of K.
10147 K must be an exact integer. */
10149 exact_integer_floor_square_root (SCM k
)
10151 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10156 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10158 ss
= mpz_get_ui (kk
);
10160 return SCM_I_MAKINUM (ss
);
10166 s
= scm_i_mkbig ();
10167 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10168 scm_remember_upto_here_1 (k
);
10169 return scm_i_normbig (s
);
10174 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10176 "Return the square root of @var{z}. Of the two possible roots\n"
10177 "(positive and negative), the one with positive real part\n"
10178 "is returned, or if that's zero then a positive imaginary part.\n"
10182 "(sqrt 9.0) @result{} 3.0\n"
10183 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10184 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10185 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10187 #define FUNC_NAME s_scm_sqrt
10189 if (SCM_COMPLEXP (z
))
10191 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10192 && defined SCM_COMPLEX_VALUE
10193 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10195 double re
= SCM_COMPLEX_REAL (z
);
10196 double im
= SCM_COMPLEX_IMAG (z
);
10197 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10198 0.5 * atan2 (im
, re
));
10201 else if (SCM_NUMBERP (z
))
10203 if (SCM_I_INUMP (z
))
10205 scm_t_inum x
= SCM_I_INUM (z
);
10207 if (SCM_LIKELY (x
>= 0))
10209 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10210 || x
< (1L << (DBL_MANT_DIG
- 1))))
10212 double root
= sqrt (x
);
10214 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10215 integer, then the result is exact. */
10216 if (root
== floor (root
))
10217 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10219 return scm_i_from_double (root
);
10226 mpz_init_set_ui (xx
, x
);
10227 if (mpz_perfect_square_p (xx
))
10230 root
= mpz_get_ui (xx
);
10232 return SCM_I_MAKINUM (root
);
10239 else if (SCM_BIGP (z
))
10241 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10243 SCM root
= scm_i_mkbig ();
10245 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10246 scm_remember_upto_here_1 (z
);
10247 return scm_i_normbig (root
);
10252 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10260 return scm_c_make_rectangular
10261 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10263 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10266 else if (SCM_FRACTIONP (z
))
10268 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10269 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10271 if (exact_integer_is_perfect_square (n
)
10272 && exact_integer_is_perfect_square (d
))
10273 return scm_i_make_ratio_already_reduced
10274 (exact_integer_floor_square_root (n
),
10275 exact_integer_floor_square_root (d
));
10278 double xx
= scm_i_divide2double (n
, d
);
10279 double abs_xx
= fabs (xx
);
10282 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10284 shift
= (scm_to_long (scm_integer_length (n
))
10285 - scm_to_long (scm_integer_length (d
))) / 2;
10287 d
= left_shift_exact_integer (d
, 2 * shift
);
10289 n
= left_shift_exact_integer (n
, -2 * shift
);
10290 xx
= scm_i_divide2double (n
, d
);
10294 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10296 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10300 /* Fallback method, when the cases above do not apply. */
10302 double xx
= scm_to_double (z
);
10304 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10306 return scm_i_from_double (sqrt (xx
));
10310 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10317 scm_init_numbers ()
10319 if (scm_install_gmp_memory_functions
)
10320 mp_set_memory_functions (custom_gmp_malloc
,
10321 custom_gmp_realloc
,
10324 mpz_init_set_si (z_negative_one
, -1);
10326 /* It may be possible to tune the performance of some algorithms by using
10327 * the following constants to avoid the creation of bignums. Please, before
10328 * using these values, remember the two rules of program optimization:
10329 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10330 scm_c_define ("most-positive-fixnum",
10331 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10332 scm_c_define ("most-negative-fixnum",
10333 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10335 scm_add_feature ("complex");
10336 scm_add_feature ("inexact");
10337 flo0
= scm_i_from_double (0.0);
10338 flo_log10e
= scm_i_from_double (M_LOG10E
);
10340 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10343 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10344 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10345 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10346 scm_i_divide2double_lo2b
,
10347 DBL_MANT_DIG
+ 1); /* 2 b^p */
10348 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10352 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10353 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10354 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10355 dbl_minimum_normal_mantissa
,
10359 #include "libguile/numbers.x"
10364 c-file-style: "gnu"