1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
3 * 2013 Free Software Foundation, Inc.
5 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
6 * and Bellcore. See scm_divide.
9 * This library is free software; you can redistribute it and/or
10 * modify it under the terms of the GNU Lesser General Public License
11 * as published by the Free Software Foundation; either version 3 of
12 * the License, or (at your option) any later version.
14 * This library is distributed in the hope that it will be useful, but
15 * WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * Lesser General Public License for more details.
19 * You should have received a copy of the GNU Lesser General Public
20 * License along with this library; if not, write to the Free Software
21 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 /* General assumptions:
27 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
28 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
29 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
30 * XXX What about infinities? They are equal to their own floor! -mhw
31 * All objects satisfying SCM_FRACTIONP are never an integer.
36 - see if special casing bignums and reals in integer-exponent when
37 possible (to use mpz_pow and mpf_pow_ui) is faster.
39 - look in to better short-circuiting of common cases in
40 integer-expt and elsewhere.
42 - see if direct mpz operations can help in ash and elsewhere.
64 #include "libguile/_scm.h"
65 #include "libguile/feature.h"
66 #include "libguile/ports.h"
67 #include "libguile/root.h"
68 #include "libguile/smob.h"
69 #include "libguile/strings.h"
70 #include "libguile/bdw-gc.h"
72 #include "libguile/validate.h"
73 #include "libguile/numbers.h"
74 #include "libguile/deprecation.h"
76 #include "libguile/eq.h"
78 /* values per glibc, if not already defined */
80 #define M_LOG10E 0.43429448190325182765
83 #define M_LN2 0.69314718055994530942
86 #define M_PI 3.14159265358979323846
89 /* FIXME: We assume that FLT_RADIX is 2 */
90 verify (FLT_RADIX
== 2);
92 typedef scm_t_signed_bits scm_t_inum
;
93 #define scm_from_inum(x) (scm_from_signed_integer (x))
95 /* Test an inum to see if it can be converted to a double without loss
96 of precision. Note that this will sometimes return 0 even when 1
97 could have been returned, e.g. for large powers of 2. It is designed
98 to be a fast check to optimize common cases. */
99 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
100 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
101 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
103 #if ! HAVE_DECL_MPZ_INITS
105 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
107 #define VARARG_MPZ_ITERATOR(func) \
109 func ## s (mpz_t x, ...) \
117 x = va_arg (ap, mpz_ptr); \
122 VARARG_MPZ_ITERATOR (mpz_init
)
123 VARARG_MPZ_ITERATOR (mpz_clear
)
130 Wonder if this might be faster for some of our code? A switch on
131 the numtag would jump directly to the right case, and the
132 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
134 #define SCM_I_NUMTAG_NOTNUM 0
135 #define SCM_I_NUMTAG_INUM 1
136 #define SCM_I_NUMTAG_BIG scm_tc16_big
137 #define SCM_I_NUMTAG_REAL scm_tc16_real
138 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
139 #define SCM_I_NUMTAG(x) \
140 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
141 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
142 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
143 : SCM_I_NUMTAG_NOTNUM)))
145 /* the macro above will not work as is with fractions */
148 /* Default to 1, because as we used to hard-code `free' as the
149 deallocator, we know that overriding these functions with
150 instrumented `malloc' / `free' is OK. */
151 int scm_install_gmp_memory_functions
= 1;
153 static SCM exactly_one_half
;
154 static SCM flo_log10e
;
156 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
158 /* FLOBUFLEN is the maximum number of characters neccessary for the
159 * printed or scm_string representation of an inexact number.
161 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
164 #if !defined (HAVE_ASINH)
165 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
167 #if !defined (HAVE_ACOSH)
168 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
170 #if !defined (HAVE_ATANH)
171 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
174 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
175 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
176 in March 2006), mpz_cmp_d now handles infinities properly. */
178 #define xmpz_cmp_d(z, d) \
179 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
181 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
185 #if defined (GUILE_I)
186 #if defined HAVE_COMPLEX_DOUBLE
188 /* For an SCM object Z which is a complex number (ie. satisfies
189 SCM_COMPLEXP), return its value as a C level "complex double". */
190 #define SCM_COMPLEX_VALUE(z) \
191 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
193 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
195 /* Convert a C "complex double" to an SCM value. */
197 scm_from_complex_double (complex double z
)
199 return scm_c_make_rectangular (creal (z
), cimag (z
));
202 #endif /* HAVE_COMPLEX_DOUBLE */
207 static mpz_t z_negative_one
;
211 /* Clear the `mpz_t' embedded in bignum PTR. */
213 finalize_bignum (void *ptr
, void *data
)
217 bignum
= PTR2SCM (ptr
);
218 mpz_clear (SCM_I_BIG_MPZ (bignum
));
221 /* The next three functions (custom_libgmp_*) are passed to
222 mp_set_memory_functions (in GMP) so that memory used by the digits
223 themselves is known to the garbage collector. This is needed so
224 that GC will be run at appropriate times. Otherwise, a program which
225 creates many large bignums would malloc a huge amount of memory
226 before the GC runs. */
228 custom_gmp_malloc (size_t alloc_size
)
230 return scm_malloc (alloc_size
);
234 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
236 return scm_realloc (old_ptr
, new_size
);
240 custom_gmp_free (void *ptr
, size_t size
)
246 /* Return a new uninitialized bignum. */
252 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
253 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
257 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
266 /* Return a newly created bignum. */
267 SCM z
= make_bignum ();
268 mpz_init (SCM_I_BIG_MPZ (z
));
273 scm_i_inum2big (scm_t_inum x
)
275 /* Return a newly created bignum initialized to X. */
276 SCM z
= make_bignum ();
277 #if SIZEOF_VOID_P == SIZEOF_LONG
278 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
280 /* Note that in this case, you'll also have to check all mpz_*_ui and
281 mpz_*_si invocations in Guile. */
282 #error creation of mpz not implemented for this inum size
288 scm_i_long2big (long x
)
290 /* Return a newly created bignum initialized to X. */
291 SCM z
= make_bignum ();
292 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
297 scm_i_ulong2big (unsigned long x
)
299 /* Return a newly created bignum initialized to X. */
300 SCM z
= make_bignum ();
301 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
306 scm_i_clonebig (SCM src_big
, int same_sign_p
)
308 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
309 SCM z
= make_bignum ();
310 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
312 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
317 scm_i_bigcmp (SCM x
, SCM y
)
319 /* Return neg if x < y, pos if x > y, and 0 if x == y */
320 /* presume we already know x and y are bignums */
321 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
322 scm_remember_upto_here_2 (x
, y
);
327 scm_i_dbl2big (double d
)
329 /* results are only defined if d is an integer */
330 SCM z
= make_bignum ();
331 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
335 /* Convert a integer in double representation to a SCM number. */
338 scm_i_dbl2num (double u
)
340 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
341 powers of 2, so there's no rounding when making "double" values
342 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
343 get rounded on a 64-bit machine, hence the "+1".
345 The use of floor() to force to an integer value ensures we get a
346 "numerically closest" value without depending on how a
347 double->long cast or how mpz_set_d will round. For reference,
348 double->long probably follows the hardware rounding mode,
349 mpz_set_d truncates towards zero. */
351 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
352 representable as a double? */
354 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
355 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
356 return SCM_I_MAKINUM ((scm_t_inum
) u
);
358 return scm_i_dbl2big (u
);
361 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
363 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
364 bignum b into a normalized significand and exponent such that
365 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
366 The return value is the significand rounded to the closest
367 representable double, and the exponent is placed into *expon_p.
368 If b is zero, then the returned exponent and significand are both
372 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
374 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
377 if (bits
> DBL_MANT_DIG
)
379 shift
= bits
- DBL_MANT_DIG
;
380 b
= round_right_shift_exact_integer (b
, shift
);
384 double signif
= frexp (SCM_I_INUM (b
), &expon
);
385 *expon_p
= expon
+ shift
;
392 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
393 scm_remember_upto_here_1 (b
);
394 *expon_p
= expon
+ shift
;
399 /* scm_i_big2dbl() rounds to the closest representable double,
400 in accordance with R5RS exact->inexact. */
402 scm_i_big2dbl (SCM b
)
405 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
406 return ldexp (signif
, expon
);
410 scm_i_normbig (SCM b
)
412 /* convert a big back to a fixnum if it'll fit */
413 /* presume b is a bignum */
414 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
416 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
417 if (SCM_FIXABLE (val
))
418 b
= SCM_I_MAKINUM (val
);
423 static SCM_C_INLINE_KEYWORD SCM
424 scm_i_mpz2num (mpz_t b
)
426 /* convert a mpz number to a SCM number. */
427 if (mpz_fits_slong_p (b
))
429 scm_t_inum val
= mpz_get_si (b
);
430 if (SCM_FIXABLE (val
))
431 return SCM_I_MAKINUM (val
);
435 SCM z
= make_bignum ();
436 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
441 /* Make the ratio NUMERATOR/DENOMINATOR, where:
442 1. NUMERATOR and DENOMINATOR are exact integers
443 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
445 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
447 /* Flip signs so that the denominator is positive. */
448 if (scm_is_false (scm_positive_p (denominator
)))
450 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
451 scm_num_overflow ("make-ratio");
454 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
455 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
459 /* Check for the integer case */
460 if (scm_is_eq (denominator
, SCM_INUM1
))
463 return scm_double_cell (scm_tc16_fraction
,
464 SCM_UNPACK (numerator
),
465 SCM_UNPACK (denominator
), 0);
468 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
470 /* Make the ratio NUMERATOR/DENOMINATOR */
472 scm_i_make_ratio (SCM numerator
, SCM denominator
)
473 #define FUNC_NAME "make-ratio"
475 /* Make sure the arguments are proper */
476 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
477 SCM_WRONG_TYPE_ARG (1, numerator
);
478 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
479 SCM_WRONG_TYPE_ARG (2, denominator
);
482 SCM the_gcd
= scm_gcd (numerator
, denominator
);
483 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
485 /* Reduce to lowest terms */
486 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
487 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
489 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
494 static mpz_t scm_i_divide2double_lo2b
;
496 /* Return the double that is closest to the exact rational N/D, with
497 ties rounded toward even mantissas. N and D must be exact
500 scm_i_divide2double (SCM n
, SCM d
)
503 mpz_t nn
, dd
, lo
, hi
, x
;
506 if (SCM_LIKELY (SCM_I_INUMP (d
)))
510 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n
))
511 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d
))))
512 /* If both N and D can be losslessly converted to doubles, then
513 we can rely on IEEE floating point to do proper rounding much
514 faster than we can. */
515 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
517 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
519 if (scm_is_true (scm_positive_p (n
)))
521 else if (scm_is_true (scm_negative_p (n
)))
527 mpz_init_set_si (dd
, SCM_I_INUM (d
));
530 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
533 mpz_init_set_si (nn
, SCM_I_INUM (n
));
535 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
537 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
541 /* Now we need to find the value of e such that:
544 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
545 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
546 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
549 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
550 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
551 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
553 where: p = DBL_MANT_DIG
554 b = FLT_RADIX (here assumed to be 2)
556 After rounding, the mantissa must be an integer between b^{p-1} and
557 (b^p - 1), except for subnormal numbers. In the inequations [1A]
558 and [1B], the middle expression represents the mantissa *before*
559 rounding, and therefore is bounded by the range of values that will
560 round to a floating-point number with the exponent e. The upper
561 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
562 ties will round up to the next power of b. The lower bound is
563 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
564 this power of b. Here we subtract 1/2b instead of 1/2 because it
565 is in the range of the next smaller exponent, where the
566 representable numbers are closer together by a factor of b.
568 Inequations [2A] and [2B] are derived from [1A] and [1B] by
569 multiplying by 2b, and in [3A] and [3B] we multiply by the
570 denominator of the middle value to obtain integer expressions.
572 In the code below, we refer to the three expressions in [3A] or
573 [3B] as lo, x, and hi. If the number is normalizable, we will
574 achieve the goal: lo <= x < hi */
576 /* Make an initial guess for e */
577 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
578 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
579 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
581 /* Compute the initial values of lo, x, and hi
582 based on the initial guess of e */
583 mpz_inits (lo
, hi
, x
, NULL
);
584 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
585 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
587 mpz_mul_2exp (lo
, lo
, e
);
588 mpz_mul_2exp (hi
, lo
, 1);
590 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
591 (but without making e less then the minimum exponent) */
592 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
594 mpz_mul_2exp (x
, x
, 1);
597 while (mpz_cmp (x
, hi
) >= 0)
599 /* If we ever used lo's value again,
600 we would need to double lo here. */
601 mpz_mul_2exp (hi
, hi
, 1);
605 /* Now compute the rounded mantissa:
606 n / b^e d (if e >= 0)
607 n b^-e / d (if e <= 0) */
613 mpz_mul_2exp (nn
, nn
, -e
);
615 mpz_mul_2exp (dd
, dd
, e
);
617 /* mpz does not directly support rounded right
618 shifts, so we have to do it the hard way.
619 For efficiency, we reuse lo and hi.
620 hi == quotient, lo == remainder */
621 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
623 /* The fractional part of the unrounded mantissa would be
624 remainder/dividend, i.e. lo/dd. So we have a tie if
625 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
626 integer expression 2*lo = dd. Here we do that comparison
627 to decide whether to round up or down. */
628 mpz_mul_2exp (lo
, lo
, 1);
629 cmp
= mpz_cmp (lo
, dd
);
630 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
631 mpz_add_ui (hi
, hi
, 1);
633 result
= ldexp (mpz_get_d (hi
), e
);
637 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
643 scm_i_fraction2double (SCM z
)
645 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
646 SCM_FRACTION_DENOMINATOR (z
));
650 scm_i_from_double (double val
)
654 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
656 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
657 SCM_REAL_VALUE (z
) = val
;
662 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
664 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
666 #define FUNC_NAME s_scm_exact_p
668 if (SCM_INEXACTP (x
))
670 else if (SCM_NUMBERP (x
))
673 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
678 scm_is_exact (SCM val
)
680 return scm_is_true (scm_exact_p (val
));
683 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
685 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
687 #define FUNC_NAME s_scm_inexact_p
689 if (SCM_INEXACTP (x
))
691 else if (SCM_NUMBERP (x
))
694 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
699 scm_is_inexact (SCM val
)
701 return scm_is_true (scm_inexact_p (val
));
704 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
706 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
708 #define FUNC_NAME s_scm_odd_p
712 scm_t_inum val
= SCM_I_INUM (n
);
713 return scm_from_bool ((val
& 1L) != 0);
715 else if (SCM_BIGP (n
))
717 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
718 scm_remember_upto_here_1 (n
);
719 return scm_from_bool (odd_p
);
721 else if (SCM_REALP (n
))
723 double val
= SCM_REAL_VALUE (n
);
726 double rem
= fabs (fmod (val
, 2.0));
733 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
738 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
740 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
742 #define FUNC_NAME s_scm_even_p
746 scm_t_inum val
= SCM_I_INUM (n
);
747 return scm_from_bool ((val
& 1L) == 0);
749 else if (SCM_BIGP (n
))
751 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
752 scm_remember_upto_here_1 (n
);
753 return scm_from_bool (even_p
);
755 else if (SCM_REALP (n
))
757 double val
= SCM_REAL_VALUE (n
);
760 double rem
= fabs (fmod (val
, 2.0));
767 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
771 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
773 "Return @code{#t} if the real number @var{x} is neither\n"
774 "infinite nor a NaN, @code{#f} otherwise.")
775 #define FUNC_NAME s_scm_finite_p
778 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
779 else if (scm_is_real (x
))
782 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
786 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
788 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
789 "@samp{-inf.0}. Otherwise return @code{#f}.")
790 #define FUNC_NAME s_scm_inf_p
793 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
794 else if (scm_is_real (x
))
797 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
801 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
803 "Return @code{#t} if the real number @var{x} is a NaN,\n"
804 "or @code{#f} otherwise.")
805 #define FUNC_NAME s_scm_nan_p
808 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
809 else if (scm_is_real (x
))
812 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
816 /* Guile's idea of infinity. */
817 static double guile_Inf
;
819 /* Guile's idea of not a number. */
820 static double guile_NaN
;
823 guile_ieee_init (void)
825 /* Some version of gcc on some old version of Linux used to crash when
826 trying to make Inf and NaN. */
829 /* C99 INFINITY, when available.
830 FIXME: The standard allows for INFINITY to be something that overflows
831 at compile time. We ought to have a configure test to check for that
832 before trying to use it. (But in practice we believe this is not a
833 problem on any system guile is likely to target.) */
834 guile_Inf
= INFINITY
;
835 #elif defined HAVE_DINFINITY
837 extern unsigned int DINFINITY
[2];
838 guile_Inf
= (*((double *) (DINFINITY
)));
845 if (guile_Inf
== tmp
)
852 /* C99 NAN, when available */
854 #elif defined HAVE_DQNAN
857 extern unsigned int DQNAN
[2];
858 guile_NaN
= (*((double *)(DQNAN
)));
861 guile_NaN
= guile_Inf
/ guile_Inf
;
865 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
868 #define FUNC_NAME s_scm_inf
870 static int initialized
= 0;
876 return scm_i_from_double (guile_Inf
);
880 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
883 #define FUNC_NAME s_scm_nan
885 static int initialized
= 0;
891 return scm_i_from_double (guile_NaN
);
896 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
898 "Return the absolute value of @var{x}.")
899 #define FUNC_NAME s_scm_abs
903 scm_t_inum xx
= SCM_I_INUM (x
);
906 else if (SCM_POSFIXABLE (-xx
))
907 return SCM_I_MAKINUM (-xx
);
909 return scm_i_inum2big (-xx
);
911 else if (SCM_LIKELY (SCM_REALP (x
)))
913 double xx
= SCM_REAL_VALUE (x
);
914 /* If x is a NaN then xx<0 is false so we return x unchanged */
916 return scm_i_from_double (-xx
);
917 /* Handle signed zeroes properly */
918 else if (SCM_UNLIKELY (xx
== 0.0))
923 else if (SCM_BIGP (x
))
925 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
927 return scm_i_clonebig (x
, 0);
931 else if (SCM_FRACTIONP (x
))
933 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
935 return scm_i_make_ratio_already_reduced
936 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
937 SCM_FRACTION_DENOMINATOR (x
));
940 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
945 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
947 "Return the quotient of the numbers @var{x} and @var{y}.")
948 #define FUNC_NAME s_scm_quotient
950 if (SCM_LIKELY (scm_is_integer (x
)))
952 if (SCM_LIKELY (scm_is_integer (y
)))
953 return scm_truncate_quotient (x
, y
);
955 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
958 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
962 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
964 "Return the remainder of the numbers @var{x} and @var{y}.\n"
966 "(remainder 13 4) @result{} 1\n"
967 "(remainder -13 4) @result{} -1\n"
969 #define FUNC_NAME s_scm_remainder
971 if (SCM_LIKELY (scm_is_integer (x
)))
973 if (SCM_LIKELY (scm_is_integer (y
)))
974 return scm_truncate_remainder (x
, y
);
976 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
979 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
984 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
986 "Return the modulo of the numbers @var{x} and @var{y}.\n"
988 "(modulo 13 4) @result{} 1\n"
989 "(modulo -13 4) @result{} 3\n"
991 #define FUNC_NAME s_scm_modulo
993 if (SCM_LIKELY (scm_is_integer (x
)))
995 if (SCM_LIKELY (scm_is_integer (y
)))
996 return scm_floor_remainder (x
, y
);
998 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
1001 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1005 /* Return the exact integer q such that n = q*d, for exact integers n
1006 and d, where d is known in advance to divide n evenly (with zero
1007 remainder). For large integers, this can be computed more
1008 efficiently than when the remainder is unknown. */
1010 scm_exact_integer_quotient (SCM n
, SCM d
)
1011 #define FUNC_NAME "exact-integer-quotient"
1013 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1015 scm_t_inum nn
= SCM_I_INUM (n
);
1016 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1018 scm_t_inum dd
= SCM_I_INUM (d
);
1019 if (SCM_UNLIKELY (dd
== 0))
1020 scm_num_overflow ("exact-integer-quotient");
1023 scm_t_inum qq
= nn
/ dd
;
1024 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1025 return SCM_I_MAKINUM (qq
);
1027 return scm_i_inum2big (qq
);
1030 else if (SCM_LIKELY (SCM_BIGP (d
)))
1032 /* n is an inum and d is a bignum. Given that d is known to
1033 divide n evenly, there are only two possibilities: n is 0,
1034 or else n is fixnum-min and d is abs(fixnum-min). */
1038 return SCM_I_MAKINUM (-1);
1041 SCM_WRONG_TYPE_ARG (2, d
);
1043 else if (SCM_LIKELY (SCM_BIGP (n
)))
1045 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1047 scm_t_inum dd
= SCM_I_INUM (d
);
1048 if (SCM_UNLIKELY (dd
== 0))
1049 scm_num_overflow ("exact-integer-quotient");
1050 else if (SCM_UNLIKELY (dd
== 1))
1054 SCM q
= scm_i_mkbig ();
1056 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1059 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1060 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1062 scm_remember_upto_here_1 (n
);
1063 return scm_i_normbig (q
);
1066 else if (SCM_LIKELY (SCM_BIGP (d
)))
1068 SCM q
= scm_i_mkbig ();
1069 mpz_divexact (SCM_I_BIG_MPZ (q
),
1072 scm_remember_upto_here_2 (n
, d
);
1073 return scm_i_normbig (q
);
1076 SCM_WRONG_TYPE_ARG (2, d
);
1079 SCM_WRONG_TYPE_ARG (1, n
);
1083 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1084 two-valued functions. It is called from primitive generics that take
1085 two arguments and return two values, when the core procedure is
1086 unable to handle the given argument types. If there are GOOPS
1087 methods for this primitive generic, it dispatches to GOOPS and, if
1088 successful, expects two values to be returned, which are placed in
1089 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1090 wrong-type-arg exception.
1092 FIXME: This obviously belongs somewhere else, but until we decide on
1093 the right API, it is here as a static function, because it is needed
1094 by the *_divide functions below.
1097 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1098 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1100 if (SCM_UNPACK (gf
))
1101 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
1103 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1106 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1108 "Return the integer @var{q} such that\n"
1109 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1110 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1112 "(euclidean-quotient 123 10) @result{} 12\n"
1113 "(euclidean-quotient 123 -10) @result{} -12\n"
1114 "(euclidean-quotient -123 10) @result{} -13\n"
1115 "(euclidean-quotient -123 -10) @result{} 13\n"
1116 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1117 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1119 #define FUNC_NAME s_scm_euclidean_quotient
1121 if (scm_is_false (scm_negative_p (y
)))
1122 return scm_floor_quotient (x
, y
);
1124 return scm_ceiling_quotient (x
, y
);
1128 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1130 "Return the real number @var{r} such that\n"
1131 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1132 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1133 "for some integer @var{q}.\n"
1135 "(euclidean-remainder 123 10) @result{} 3\n"
1136 "(euclidean-remainder 123 -10) @result{} 3\n"
1137 "(euclidean-remainder -123 10) @result{} 7\n"
1138 "(euclidean-remainder -123 -10) @result{} 7\n"
1139 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1140 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1142 #define FUNC_NAME s_scm_euclidean_remainder
1144 if (scm_is_false (scm_negative_p (y
)))
1145 return scm_floor_remainder (x
, y
);
1147 return scm_ceiling_remainder (x
, y
);
1151 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1153 "Return the integer @var{q} and the real number @var{r}\n"
1154 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1155 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1157 "(euclidean/ 123 10) @result{} 12 and 3\n"
1158 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1159 "(euclidean/ -123 10) @result{} -13 and 7\n"
1160 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1161 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1162 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1164 #define FUNC_NAME s_scm_i_euclidean_divide
1166 if (scm_is_false (scm_negative_p (y
)))
1167 return scm_i_floor_divide (x
, y
);
1169 return scm_i_ceiling_divide (x
, y
);
1174 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1176 if (scm_is_false (scm_negative_p (y
)))
1177 return scm_floor_divide (x
, y
, qp
, rp
);
1179 return scm_ceiling_divide (x
, y
, qp
, rp
);
1182 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1183 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1185 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1187 "Return the floor of @math{@var{x} / @var{y}}.\n"
1189 "(floor-quotient 123 10) @result{} 12\n"
1190 "(floor-quotient 123 -10) @result{} -13\n"
1191 "(floor-quotient -123 10) @result{} -13\n"
1192 "(floor-quotient -123 -10) @result{} 12\n"
1193 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1194 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1196 #define FUNC_NAME s_scm_floor_quotient
1198 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1200 scm_t_inum xx
= SCM_I_INUM (x
);
1201 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1203 scm_t_inum yy
= SCM_I_INUM (y
);
1204 scm_t_inum xx1
= xx
;
1206 if (SCM_LIKELY (yy
> 0))
1208 if (SCM_UNLIKELY (xx
< 0))
1211 else if (SCM_UNLIKELY (yy
== 0))
1212 scm_num_overflow (s_scm_floor_quotient
);
1216 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1217 return SCM_I_MAKINUM (qq
);
1219 return scm_i_inum2big (qq
);
1221 else if (SCM_BIGP (y
))
1223 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1224 scm_remember_upto_here_1 (y
);
1226 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1228 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1230 else if (SCM_REALP (y
))
1231 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1232 else if (SCM_FRACTIONP (y
))
1233 return scm_i_exact_rational_floor_quotient (x
, y
);
1235 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1236 s_scm_floor_quotient
);
1238 else if (SCM_BIGP (x
))
1240 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1242 scm_t_inum yy
= SCM_I_INUM (y
);
1243 if (SCM_UNLIKELY (yy
== 0))
1244 scm_num_overflow (s_scm_floor_quotient
);
1245 else if (SCM_UNLIKELY (yy
== 1))
1249 SCM q
= scm_i_mkbig ();
1251 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1254 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1255 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1257 scm_remember_upto_here_1 (x
);
1258 return scm_i_normbig (q
);
1261 else if (SCM_BIGP (y
))
1263 SCM q
= scm_i_mkbig ();
1264 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1267 scm_remember_upto_here_2 (x
, y
);
1268 return scm_i_normbig (q
);
1270 else if (SCM_REALP (y
))
1271 return scm_i_inexact_floor_quotient
1272 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1273 else if (SCM_FRACTIONP (y
))
1274 return scm_i_exact_rational_floor_quotient (x
, y
);
1276 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1277 s_scm_floor_quotient
);
1279 else if (SCM_REALP (x
))
1281 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1282 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1283 return scm_i_inexact_floor_quotient
1284 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1286 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1287 s_scm_floor_quotient
);
1289 else if (SCM_FRACTIONP (x
))
1292 return scm_i_inexact_floor_quotient
1293 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1294 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1295 return scm_i_exact_rational_floor_quotient (x
, y
);
1297 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1298 s_scm_floor_quotient
);
1301 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1302 s_scm_floor_quotient
);
1307 scm_i_inexact_floor_quotient (double x
, double y
)
1309 if (SCM_UNLIKELY (y
== 0))
1310 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1312 return scm_i_from_double (floor (x
/ y
));
1316 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1318 return scm_floor_quotient
1319 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1320 scm_product (scm_numerator (y
), scm_denominator (x
)));
1323 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1324 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1326 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1328 "Return the real number @var{r} such that\n"
1329 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1330 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1332 "(floor-remainder 123 10) @result{} 3\n"
1333 "(floor-remainder 123 -10) @result{} -7\n"
1334 "(floor-remainder -123 10) @result{} 7\n"
1335 "(floor-remainder -123 -10) @result{} -3\n"
1336 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1337 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1339 #define FUNC_NAME s_scm_floor_remainder
1341 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1343 scm_t_inum xx
= SCM_I_INUM (x
);
1344 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1346 scm_t_inum yy
= SCM_I_INUM (y
);
1347 if (SCM_UNLIKELY (yy
== 0))
1348 scm_num_overflow (s_scm_floor_remainder
);
1351 scm_t_inum rr
= xx
% yy
;
1352 int needs_adjustment
;
1354 if (SCM_LIKELY (yy
> 0))
1355 needs_adjustment
= (rr
< 0);
1357 needs_adjustment
= (rr
> 0);
1359 if (needs_adjustment
)
1361 return SCM_I_MAKINUM (rr
);
1364 else if (SCM_BIGP (y
))
1366 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1367 scm_remember_upto_here_1 (y
);
1372 SCM r
= scm_i_mkbig ();
1373 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1374 scm_remember_upto_here_1 (y
);
1375 return scm_i_normbig (r
);
1384 SCM r
= scm_i_mkbig ();
1385 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1386 scm_remember_upto_here_1 (y
);
1387 return scm_i_normbig (r
);
1390 else if (SCM_REALP (y
))
1391 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1392 else if (SCM_FRACTIONP (y
))
1393 return scm_i_exact_rational_floor_remainder (x
, y
);
1395 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1396 s_scm_floor_remainder
);
1398 else if (SCM_BIGP (x
))
1400 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1402 scm_t_inum yy
= SCM_I_INUM (y
);
1403 if (SCM_UNLIKELY (yy
== 0))
1404 scm_num_overflow (s_scm_floor_remainder
);
1409 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1411 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1412 scm_remember_upto_here_1 (x
);
1413 return SCM_I_MAKINUM (rr
);
1416 else if (SCM_BIGP (y
))
1418 SCM r
= scm_i_mkbig ();
1419 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1422 scm_remember_upto_here_2 (x
, y
);
1423 return scm_i_normbig (r
);
1425 else if (SCM_REALP (y
))
1426 return scm_i_inexact_floor_remainder
1427 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1428 else if (SCM_FRACTIONP (y
))
1429 return scm_i_exact_rational_floor_remainder (x
, y
);
1431 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1432 s_scm_floor_remainder
);
1434 else if (SCM_REALP (x
))
1436 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1437 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1438 return scm_i_inexact_floor_remainder
1439 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1441 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1442 s_scm_floor_remainder
);
1444 else if (SCM_FRACTIONP (x
))
1447 return scm_i_inexact_floor_remainder
1448 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1449 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1450 return scm_i_exact_rational_floor_remainder (x
, y
);
1452 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1453 s_scm_floor_remainder
);
1456 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1457 s_scm_floor_remainder
);
1462 scm_i_inexact_floor_remainder (double x
, double y
)
1464 /* Although it would be more efficient to use fmod here, we can't
1465 because it would in some cases produce results inconsistent with
1466 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1467 close). In particular, when x is very close to a multiple of y,
1468 then r might be either 0.0 or y, but those two cases must
1469 correspond to different choices of q. If r = 0.0 then q must be
1470 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1471 and remainder chooses the other, it would be bad. */
1472 if (SCM_UNLIKELY (y
== 0))
1473 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1475 return scm_i_from_double (x
- y
* floor (x
/ y
));
1479 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1481 SCM xd
= scm_denominator (x
);
1482 SCM yd
= scm_denominator (y
);
1483 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1484 scm_product (scm_numerator (y
), xd
));
1485 return scm_divide (r1
, scm_product (xd
, yd
));
1489 static void scm_i_inexact_floor_divide (double x
, double y
,
1491 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1494 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1496 "Return the integer @var{q} and the real number @var{r}\n"
1497 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1498 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1500 "(floor/ 123 10) @result{} 12 and 3\n"
1501 "(floor/ 123 -10) @result{} -13 and -7\n"
1502 "(floor/ -123 10) @result{} -13 and 7\n"
1503 "(floor/ -123 -10) @result{} 12 and -3\n"
1504 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1505 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1507 #define FUNC_NAME s_scm_i_floor_divide
1511 scm_floor_divide(x
, y
, &q
, &r
);
1512 return scm_values (scm_list_2 (q
, r
));
1516 #define s_scm_floor_divide s_scm_i_floor_divide
1517 #define g_scm_floor_divide g_scm_i_floor_divide
1520 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1522 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1524 scm_t_inum xx
= SCM_I_INUM (x
);
1525 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1527 scm_t_inum yy
= SCM_I_INUM (y
);
1528 if (SCM_UNLIKELY (yy
== 0))
1529 scm_num_overflow (s_scm_floor_divide
);
1532 scm_t_inum qq
= xx
/ yy
;
1533 scm_t_inum rr
= xx
% yy
;
1534 int needs_adjustment
;
1536 if (SCM_LIKELY (yy
> 0))
1537 needs_adjustment
= (rr
< 0);
1539 needs_adjustment
= (rr
> 0);
1541 if (needs_adjustment
)
1547 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1548 *qp
= SCM_I_MAKINUM (qq
);
1550 *qp
= scm_i_inum2big (qq
);
1551 *rp
= SCM_I_MAKINUM (rr
);
1555 else if (SCM_BIGP (y
))
1557 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1558 scm_remember_upto_here_1 (y
);
1563 SCM r
= scm_i_mkbig ();
1564 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1565 scm_remember_upto_here_1 (y
);
1566 *qp
= SCM_I_MAKINUM (-1);
1567 *rp
= scm_i_normbig (r
);
1582 SCM r
= scm_i_mkbig ();
1583 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1584 scm_remember_upto_here_1 (y
);
1585 *qp
= SCM_I_MAKINUM (-1);
1586 *rp
= scm_i_normbig (r
);
1590 else if (SCM_REALP (y
))
1591 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1592 else if (SCM_FRACTIONP (y
))
1593 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1595 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1596 s_scm_floor_divide
, qp
, rp
);
1598 else if (SCM_BIGP (x
))
1600 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1602 scm_t_inum yy
= SCM_I_INUM (y
);
1603 if (SCM_UNLIKELY (yy
== 0))
1604 scm_num_overflow (s_scm_floor_divide
);
1607 SCM q
= scm_i_mkbig ();
1608 SCM r
= scm_i_mkbig ();
1610 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1611 SCM_I_BIG_MPZ (x
), yy
);
1614 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1615 SCM_I_BIG_MPZ (x
), -yy
);
1616 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1618 scm_remember_upto_here_1 (x
);
1619 *qp
= scm_i_normbig (q
);
1620 *rp
= scm_i_normbig (r
);
1624 else if (SCM_BIGP (y
))
1626 SCM q
= scm_i_mkbig ();
1627 SCM r
= scm_i_mkbig ();
1628 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1629 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1630 scm_remember_upto_here_2 (x
, y
);
1631 *qp
= scm_i_normbig (q
);
1632 *rp
= scm_i_normbig (r
);
1635 else if (SCM_REALP (y
))
1636 return scm_i_inexact_floor_divide
1637 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1638 else if (SCM_FRACTIONP (y
))
1639 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1641 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1642 s_scm_floor_divide
, qp
, rp
);
1644 else if (SCM_REALP (x
))
1646 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1647 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1648 return scm_i_inexact_floor_divide
1649 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1651 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1652 s_scm_floor_divide
, qp
, rp
);
1654 else if (SCM_FRACTIONP (x
))
1657 return scm_i_inexact_floor_divide
1658 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1659 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1660 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1662 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1663 s_scm_floor_divide
, qp
, rp
);
1666 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1667 s_scm_floor_divide
, qp
, rp
);
1671 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1673 if (SCM_UNLIKELY (y
== 0))
1674 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1677 double q
= floor (x
/ y
);
1678 double r
= x
- q
* y
;
1679 *qp
= scm_i_from_double (q
);
1680 *rp
= scm_i_from_double (r
);
1685 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1688 SCM xd
= scm_denominator (x
);
1689 SCM yd
= scm_denominator (y
);
1691 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1692 scm_product (scm_numerator (y
), xd
),
1694 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1697 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1698 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1700 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1702 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1704 "(ceiling-quotient 123 10) @result{} 13\n"
1705 "(ceiling-quotient 123 -10) @result{} -12\n"
1706 "(ceiling-quotient -123 10) @result{} -12\n"
1707 "(ceiling-quotient -123 -10) @result{} 13\n"
1708 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1709 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1711 #define FUNC_NAME s_scm_ceiling_quotient
1713 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1715 scm_t_inum xx
= SCM_I_INUM (x
);
1716 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1718 scm_t_inum yy
= SCM_I_INUM (y
);
1719 if (SCM_UNLIKELY (yy
== 0))
1720 scm_num_overflow (s_scm_ceiling_quotient
);
1723 scm_t_inum xx1
= xx
;
1725 if (SCM_LIKELY (yy
> 0))
1727 if (SCM_LIKELY (xx
>= 0))
1733 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1734 return SCM_I_MAKINUM (qq
);
1736 return scm_i_inum2big (qq
);
1739 else if (SCM_BIGP (y
))
1741 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1742 scm_remember_upto_here_1 (y
);
1743 if (SCM_LIKELY (sign
> 0))
1745 if (SCM_LIKELY (xx
> 0))
1747 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1748 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1749 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1751 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1752 scm_remember_upto_here_1 (y
);
1753 return SCM_I_MAKINUM (-1);
1763 else if (SCM_REALP (y
))
1764 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1765 else if (SCM_FRACTIONP (y
))
1766 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1768 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1769 s_scm_ceiling_quotient
);
1771 else if (SCM_BIGP (x
))
1773 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1775 scm_t_inum yy
= SCM_I_INUM (y
);
1776 if (SCM_UNLIKELY (yy
== 0))
1777 scm_num_overflow (s_scm_ceiling_quotient
);
1778 else if (SCM_UNLIKELY (yy
== 1))
1782 SCM q
= scm_i_mkbig ();
1784 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1787 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1788 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1790 scm_remember_upto_here_1 (x
);
1791 return scm_i_normbig (q
);
1794 else if (SCM_BIGP (y
))
1796 SCM q
= scm_i_mkbig ();
1797 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1800 scm_remember_upto_here_2 (x
, y
);
1801 return scm_i_normbig (q
);
1803 else if (SCM_REALP (y
))
1804 return scm_i_inexact_ceiling_quotient
1805 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1806 else if (SCM_FRACTIONP (y
))
1807 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1809 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1810 s_scm_ceiling_quotient
);
1812 else if (SCM_REALP (x
))
1814 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1815 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1816 return scm_i_inexact_ceiling_quotient
1817 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1819 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1820 s_scm_ceiling_quotient
);
1822 else if (SCM_FRACTIONP (x
))
1825 return scm_i_inexact_ceiling_quotient
1826 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1827 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1828 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1830 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1831 s_scm_ceiling_quotient
);
1834 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1835 s_scm_ceiling_quotient
);
1840 scm_i_inexact_ceiling_quotient (double x
, double y
)
1842 if (SCM_UNLIKELY (y
== 0))
1843 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1845 return scm_i_from_double (ceil (x
/ y
));
1849 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1851 return scm_ceiling_quotient
1852 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1853 scm_product (scm_numerator (y
), scm_denominator (x
)));
1856 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1857 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1859 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1861 "Return the real number @var{r} such that\n"
1862 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1863 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1865 "(ceiling-remainder 123 10) @result{} -7\n"
1866 "(ceiling-remainder 123 -10) @result{} 3\n"
1867 "(ceiling-remainder -123 10) @result{} -3\n"
1868 "(ceiling-remainder -123 -10) @result{} 7\n"
1869 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1870 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1872 #define FUNC_NAME s_scm_ceiling_remainder
1874 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1876 scm_t_inum xx
= SCM_I_INUM (x
);
1877 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1879 scm_t_inum yy
= SCM_I_INUM (y
);
1880 if (SCM_UNLIKELY (yy
== 0))
1881 scm_num_overflow (s_scm_ceiling_remainder
);
1884 scm_t_inum rr
= xx
% yy
;
1885 int needs_adjustment
;
1887 if (SCM_LIKELY (yy
> 0))
1888 needs_adjustment
= (rr
> 0);
1890 needs_adjustment
= (rr
< 0);
1892 if (needs_adjustment
)
1894 return SCM_I_MAKINUM (rr
);
1897 else if (SCM_BIGP (y
))
1899 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1900 scm_remember_upto_here_1 (y
);
1901 if (SCM_LIKELY (sign
> 0))
1903 if (SCM_LIKELY (xx
> 0))
1905 SCM r
= scm_i_mkbig ();
1906 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1907 scm_remember_upto_here_1 (y
);
1908 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1909 return scm_i_normbig (r
);
1911 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1912 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1913 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1915 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1916 scm_remember_upto_here_1 (y
);
1926 SCM r
= scm_i_mkbig ();
1927 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1928 scm_remember_upto_here_1 (y
);
1929 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1930 return scm_i_normbig (r
);
1933 else if (SCM_REALP (y
))
1934 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1935 else if (SCM_FRACTIONP (y
))
1936 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1938 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1939 s_scm_ceiling_remainder
);
1941 else if (SCM_BIGP (x
))
1943 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1945 scm_t_inum yy
= SCM_I_INUM (y
);
1946 if (SCM_UNLIKELY (yy
== 0))
1947 scm_num_overflow (s_scm_ceiling_remainder
);
1952 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1954 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1955 scm_remember_upto_here_1 (x
);
1956 return SCM_I_MAKINUM (rr
);
1959 else if (SCM_BIGP (y
))
1961 SCM r
= scm_i_mkbig ();
1962 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1965 scm_remember_upto_here_2 (x
, y
);
1966 return scm_i_normbig (r
);
1968 else if (SCM_REALP (y
))
1969 return scm_i_inexact_ceiling_remainder
1970 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1971 else if (SCM_FRACTIONP (y
))
1972 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1974 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1975 s_scm_ceiling_remainder
);
1977 else if (SCM_REALP (x
))
1979 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1980 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1981 return scm_i_inexact_ceiling_remainder
1982 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1984 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1985 s_scm_ceiling_remainder
);
1987 else if (SCM_FRACTIONP (x
))
1990 return scm_i_inexact_ceiling_remainder
1991 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1992 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1993 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1995 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1996 s_scm_ceiling_remainder
);
1999 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
2000 s_scm_ceiling_remainder
);
2005 scm_i_inexact_ceiling_remainder (double x
, double y
)
2007 /* Although it would be more efficient to use fmod here, we can't
2008 because it would in some cases produce results inconsistent with
2009 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2010 close). In particular, when x is very close to a multiple of y,
2011 then r might be either 0.0 or -y, but those two cases must
2012 correspond to different choices of q. If r = 0.0 then q must be
2013 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2014 and remainder chooses the other, it would be bad. */
2015 if (SCM_UNLIKELY (y
== 0))
2016 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2018 return scm_i_from_double (x
- y
* ceil (x
/ y
));
2022 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2024 SCM xd
= scm_denominator (x
);
2025 SCM yd
= scm_denominator (y
);
2026 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2027 scm_product (scm_numerator (y
), xd
));
2028 return scm_divide (r1
, scm_product (xd
, yd
));
2031 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2033 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2036 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2038 "Return the integer @var{q} and the real number @var{r}\n"
2039 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2040 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2042 "(ceiling/ 123 10) @result{} 13 and -7\n"
2043 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2044 "(ceiling/ -123 10) @result{} -12 and -3\n"
2045 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2046 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2047 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2049 #define FUNC_NAME s_scm_i_ceiling_divide
2053 scm_ceiling_divide(x
, y
, &q
, &r
);
2054 return scm_values (scm_list_2 (q
, r
));
2058 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2059 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2062 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2064 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2066 scm_t_inum xx
= SCM_I_INUM (x
);
2067 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2069 scm_t_inum yy
= SCM_I_INUM (y
);
2070 if (SCM_UNLIKELY (yy
== 0))
2071 scm_num_overflow (s_scm_ceiling_divide
);
2074 scm_t_inum qq
= xx
/ yy
;
2075 scm_t_inum rr
= xx
% yy
;
2076 int needs_adjustment
;
2078 if (SCM_LIKELY (yy
> 0))
2079 needs_adjustment
= (rr
> 0);
2081 needs_adjustment
= (rr
< 0);
2083 if (needs_adjustment
)
2088 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2089 *qp
= SCM_I_MAKINUM (qq
);
2091 *qp
= scm_i_inum2big (qq
);
2092 *rp
= SCM_I_MAKINUM (rr
);
2096 else if (SCM_BIGP (y
))
2098 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2099 scm_remember_upto_here_1 (y
);
2100 if (SCM_LIKELY (sign
> 0))
2102 if (SCM_LIKELY (xx
> 0))
2104 SCM r
= scm_i_mkbig ();
2105 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2106 scm_remember_upto_here_1 (y
);
2107 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2109 *rp
= scm_i_normbig (r
);
2111 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2112 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2113 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2115 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2116 scm_remember_upto_here_1 (y
);
2117 *qp
= SCM_I_MAKINUM (-1);
2133 SCM r
= scm_i_mkbig ();
2134 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2135 scm_remember_upto_here_1 (y
);
2136 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2138 *rp
= scm_i_normbig (r
);
2142 else if (SCM_REALP (y
))
2143 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2144 else if (SCM_FRACTIONP (y
))
2145 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2147 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2148 s_scm_ceiling_divide
, qp
, rp
);
2150 else if (SCM_BIGP (x
))
2152 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2154 scm_t_inum yy
= SCM_I_INUM (y
);
2155 if (SCM_UNLIKELY (yy
== 0))
2156 scm_num_overflow (s_scm_ceiling_divide
);
2159 SCM q
= scm_i_mkbig ();
2160 SCM r
= scm_i_mkbig ();
2162 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2163 SCM_I_BIG_MPZ (x
), yy
);
2166 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2167 SCM_I_BIG_MPZ (x
), -yy
);
2168 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2170 scm_remember_upto_here_1 (x
);
2171 *qp
= scm_i_normbig (q
);
2172 *rp
= scm_i_normbig (r
);
2176 else if (SCM_BIGP (y
))
2178 SCM q
= scm_i_mkbig ();
2179 SCM r
= scm_i_mkbig ();
2180 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2181 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2182 scm_remember_upto_here_2 (x
, y
);
2183 *qp
= scm_i_normbig (q
);
2184 *rp
= scm_i_normbig (r
);
2187 else if (SCM_REALP (y
))
2188 return scm_i_inexact_ceiling_divide
2189 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2190 else if (SCM_FRACTIONP (y
))
2191 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2193 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2194 s_scm_ceiling_divide
, qp
, rp
);
2196 else if (SCM_REALP (x
))
2198 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2199 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2200 return scm_i_inexact_ceiling_divide
2201 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2203 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2204 s_scm_ceiling_divide
, qp
, rp
);
2206 else if (SCM_FRACTIONP (x
))
2209 return scm_i_inexact_ceiling_divide
2210 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2211 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2212 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2214 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2215 s_scm_ceiling_divide
, qp
, rp
);
2218 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2219 s_scm_ceiling_divide
, qp
, rp
);
2223 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2225 if (SCM_UNLIKELY (y
== 0))
2226 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2229 double q
= ceil (x
/ y
);
2230 double r
= x
- q
* y
;
2231 *qp
= scm_i_from_double (q
);
2232 *rp
= scm_i_from_double (r
);
2237 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2240 SCM xd
= scm_denominator (x
);
2241 SCM yd
= scm_denominator (y
);
2243 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2244 scm_product (scm_numerator (y
), xd
),
2246 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2249 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2250 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2252 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2254 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2256 "(truncate-quotient 123 10) @result{} 12\n"
2257 "(truncate-quotient 123 -10) @result{} -12\n"
2258 "(truncate-quotient -123 10) @result{} -12\n"
2259 "(truncate-quotient -123 -10) @result{} 12\n"
2260 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2261 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2263 #define FUNC_NAME s_scm_truncate_quotient
2265 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2267 scm_t_inum xx
= SCM_I_INUM (x
);
2268 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2270 scm_t_inum yy
= SCM_I_INUM (y
);
2271 if (SCM_UNLIKELY (yy
== 0))
2272 scm_num_overflow (s_scm_truncate_quotient
);
2275 scm_t_inum qq
= xx
/ yy
;
2276 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2277 return SCM_I_MAKINUM (qq
);
2279 return scm_i_inum2big (qq
);
2282 else if (SCM_BIGP (y
))
2284 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2285 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2286 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2288 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2289 scm_remember_upto_here_1 (y
);
2290 return SCM_I_MAKINUM (-1);
2295 else if (SCM_REALP (y
))
2296 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2297 else if (SCM_FRACTIONP (y
))
2298 return scm_i_exact_rational_truncate_quotient (x
, y
);
2300 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2301 s_scm_truncate_quotient
);
2303 else if (SCM_BIGP (x
))
2305 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2307 scm_t_inum yy
= SCM_I_INUM (y
);
2308 if (SCM_UNLIKELY (yy
== 0))
2309 scm_num_overflow (s_scm_truncate_quotient
);
2310 else if (SCM_UNLIKELY (yy
== 1))
2314 SCM q
= scm_i_mkbig ();
2316 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2319 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2320 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2322 scm_remember_upto_here_1 (x
);
2323 return scm_i_normbig (q
);
2326 else if (SCM_BIGP (y
))
2328 SCM q
= scm_i_mkbig ();
2329 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2332 scm_remember_upto_here_2 (x
, y
);
2333 return scm_i_normbig (q
);
2335 else if (SCM_REALP (y
))
2336 return scm_i_inexact_truncate_quotient
2337 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2338 else if (SCM_FRACTIONP (y
))
2339 return scm_i_exact_rational_truncate_quotient (x
, y
);
2341 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2342 s_scm_truncate_quotient
);
2344 else if (SCM_REALP (x
))
2346 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2347 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2348 return scm_i_inexact_truncate_quotient
2349 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2351 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2352 s_scm_truncate_quotient
);
2354 else if (SCM_FRACTIONP (x
))
2357 return scm_i_inexact_truncate_quotient
2358 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2359 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2360 return scm_i_exact_rational_truncate_quotient (x
, y
);
2362 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2363 s_scm_truncate_quotient
);
2366 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2367 s_scm_truncate_quotient
);
2372 scm_i_inexact_truncate_quotient (double x
, double y
)
2374 if (SCM_UNLIKELY (y
== 0))
2375 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2377 return scm_i_from_double (trunc (x
/ y
));
2381 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2383 return scm_truncate_quotient
2384 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2385 scm_product (scm_numerator (y
), scm_denominator (x
)));
2388 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2389 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2391 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2393 "Return the real number @var{r} such that\n"
2394 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2395 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2397 "(truncate-remainder 123 10) @result{} 3\n"
2398 "(truncate-remainder 123 -10) @result{} 3\n"
2399 "(truncate-remainder -123 10) @result{} -3\n"
2400 "(truncate-remainder -123 -10) @result{} -3\n"
2401 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2402 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2404 #define FUNC_NAME s_scm_truncate_remainder
2406 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2408 scm_t_inum xx
= SCM_I_INUM (x
);
2409 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2411 scm_t_inum yy
= SCM_I_INUM (y
);
2412 if (SCM_UNLIKELY (yy
== 0))
2413 scm_num_overflow (s_scm_truncate_remainder
);
2415 return SCM_I_MAKINUM (xx
% yy
);
2417 else if (SCM_BIGP (y
))
2419 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2420 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2421 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2423 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2424 scm_remember_upto_here_1 (y
);
2430 else if (SCM_REALP (y
))
2431 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2432 else if (SCM_FRACTIONP (y
))
2433 return scm_i_exact_rational_truncate_remainder (x
, y
);
2435 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2436 s_scm_truncate_remainder
);
2438 else if (SCM_BIGP (x
))
2440 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2442 scm_t_inum yy
= SCM_I_INUM (y
);
2443 if (SCM_UNLIKELY (yy
== 0))
2444 scm_num_overflow (s_scm_truncate_remainder
);
2447 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2448 (yy
> 0) ? yy
: -yy
)
2449 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2450 scm_remember_upto_here_1 (x
);
2451 return SCM_I_MAKINUM (rr
);
2454 else if (SCM_BIGP (y
))
2456 SCM r
= scm_i_mkbig ();
2457 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2460 scm_remember_upto_here_2 (x
, y
);
2461 return scm_i_normbig (r
);
2463 else if (SCM_REALP (y
))
2464 return scm_i_inexact_truncate_remainder
2465 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2466 else if (SCM_FRACTIONP (y
))
2467 return scm_i_exact_rational_truncate_remainder (x
, y
);
2469 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2470 s_scm_truncate_remainder
);
2472 else if (SCM_REALP (x
))
2474 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2475 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2476 return scm_i_inexact_truncate_remainder
2477 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2479 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2480 s_scm_truncate_remainder
);
2482 else if (SCM_FRACTIONP (x
))
2485 return scm_i_inexact_truncate_remainder
2486 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2487 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2488 return scm_i_exact_rational_truncate_remainder (x
, y
);
2490 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2491 s_scm_truncate_remainder
);
2494 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2495 s_scm_truncate_remainder
);
2500 scm_i_inexact_truncate_remainder (double x
, double y
)
2502 /* Although it would be more efficient to use fmod here, we can't
2503 because it would in some cases produce results inconsistent with
2504 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2505 close). In particular, when x is very close to a multiple of y,
2506 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2507 correspond to different choices of q. If quotient chooses one and
2508 remainder chooses the other, it would be bad. */
2509 if (SCM_UNLIKELY (y
== 0))
2510 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2512 return scm_i_from_double (x
- y
* trunc (x
/ y
));
2516 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2518 SCM xd
= scm_denominator (x
);
2519 SCM yd
= scm_denominator (y
);
2520 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2521 scm_product (scm_numerator (y
), xd
));
2522 return scm_divide (r1
, scm_product (xd
, yd
));
2526 static void scm_i_inexact_truncate_divide (double x
, double y
,
2528 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2531 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2533 "Return the integer @var{q} and the real number @var{r}\n"
2534 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2535 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2537 "(truncate/ 123 10) @result{} 12 and 3\n"
2538 "(truncate/ 123 -10) @result{} -12 and 3\n"
2539 "(truncate/ -123 10) @result{} -12 and -3\n"
2540 "(truncate/ -123 -10) @result{} 12 and -3\n"
2541 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2542 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2544 #define FUNC_NAME s_scm_i_truncate_divide
2548 scm_truncate_divide(x
, y
, &q
, &r
);
2549 return scm_values (scm_list_2 (q
, r
));
2553 #define s_scm_truncate_divide s_scm_i_truncate_divide
2554 #define g_scm_truncate_divide g_scm_i_truncate_divide
2557 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2559 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2561 scm_t_inum xx
= SCM_I_INUM (x
);
2562 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2564 scm_t_inum yy
= SCM_I_INUM (y
);
2565 if (SCM_UNLIKELY (yy
== 0))
2566 scm_num_overflow (s_scm_truncate_divide
);
2569 scm_t_inum qq
= xx
/ yy
;
2570 scm_t_inum rr
= xx
% yy
;
2571 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2572 *qp
= SCM_I_MAKINUM (qq
);
2574 *qp
= scm_i_inum2big (qq
);
2575 *rp
= SCM_I_MAKINUM (rr
);
2579 else if (SCM_BIGP (y
))
2581 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2582 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2583 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2585 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2586 scm_remember_upto_here_1 (y
);
2587 *qp
= SCM_I_MAKINUM (-1);
2597 else if (SCM_REALP (y
))
2598 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2599 else if (SCM_FRACTIONP (y
))
2600 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2602 return two_valued_wta_dispatch_2
2603 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2604 s_scm_truncate_divide
, qp
, rp
);
2606 else if (SCM_BIGP (x
))
2608 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2610 scm_t_inum yy
= SCM_I_INUM (y
);
2611 if (SCM_UNLIKELY (yy
== 0))
2612 scm_num_overflow (s_scm_truncate_divide
);
2615 SCM q
= scm_i_mkbig ();
2618 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2619 SCM_I_BIG_MPZ (x
), yy
);
2622 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2623 SCM_I_BIG_MPZ (x
), -yy
);
2624 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2626 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2627 scm_remember_upto_here_1 (x
);
2628 *qp
= scm_i_normbig (q
);
2629 *rp
= SCM_I_MAKINUM (rr
);
2633 else if (SCM_BIGP (y
))
2635 SCM q
= scm_i_mkbig ();
2636 SCM r
= scm_i_mkbig ();
2637 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2638 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2639 scm_remember_upto_here_2 (x
, y
);
2640 *qp
= scm_i_normbig (q
);
2641 *rp
= scm_i_normbig (r
);
2643 else if (SCM_REALP (y
))
2644 return scm_i_inexact_truncate_divide
2645 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2646 else if (SCM_FRACTIONP (y
))
2647 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2649 return two_valued_wta_dispatch_2
2650 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2651 s_scm_truncate_divide
, qp
, rp
);
2653 else if (SCM_REALP (x
))
2655 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2656 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2657 return scm_i_inexact_truncate_divide
2658 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2660 return two_valued_wta_dispatch_2
2661 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2662 s_scm_truncate_divide
, qp
, rp
);
2664 else if (SCM_FRACTIONP (x
))
2667 return scm_i_inexact_truncate_divide
2668 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2669 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2670 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2672 return two_valued_wta_dispatch_2
2673 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2674 s_scm_truncate_divide
, qp
, rp
);
2677 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2678 s_scm_truncate_divide
, qp
, rp
);
2682 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2684 if (SCM_UNLIKELY (y
== 0))
2685 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2688 double q
= trunc (x
/ y
);
2689 double r
= x
- q
* y
;
2690 *qp
= scm_i_from_double (q
);
2691 *rp
= scm_i_from_double (r
);
2696 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2699 SCM xd
= scm_denominator (x
);
2700 SCM yd
= scm_denominator (y
);
2702 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2703 scm_product (scm_numerator (y
), xd
),
2705 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2708 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2709 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2710 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2712 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2714 "Return the integer @var{q} such that\n"
2715 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2716 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2718 "(centered-quotient 123 10) @result{} 12\n"
2719 "(centered-quotient 123 -10) @result{} -12\n"
2720 "(centered-quotient -123 10) @result{} -12\n"
2721 "(centered-quotient -123 -10) @result{} 12\n"
2722 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2723 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2725 #define FUNC_NAME s_scm_centered_quotient
2727 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2729 scm_t_inum xx
= SCM_I_INUM (x
);
2730 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2732 scm_t_inum yy
= SCM_I_INUM (y
);
2733 if (SCM_UNLIKELY (yy
== 0))
2734 scm_num_overflow (s_scm_centered_quotient
);
2737 scm_t_inum qq
= xx
/ yy
;
2738 scm_t_inum rr
= xx
% yy
;
2739 if (SCM_LIKELY (xx
> 0))
2741 if (SCM_LIKELY (yy
> 0))
2743 if (rr
>= (yy
+ 1) / 2)
2748 if (rr
>= (1 - yy
) / 2)
2754 if (SCM_LIKELY (yy
> 0))
2765 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2766 return SCM_I_MAKINUM (qq
);
2768 return scm_i_inum2big (qq
);
2771 else if (SCM_BIGP (y
))
2773 /* Pass a denormalized bignum version of x (even though it
2774 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2775 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2777 else if (SCM_REALP (y
))
2778 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2779 else if (SCM_FRACTIONP (y
))
2780 return scm_i_exact_rational_centered_quotient (x
, y
);
2782 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2783 s_scm_centered_quotient
);
2785 else if (SCM_BIGP (x
))
2787 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2789 scm_t_inum yy
= SCM_I_INUM (y
);
2790 if (SCM_UNLIKELY (yy
== 0))
2791 scm_num_overflow (s_scm_centered_quotient
);
2792 else if (SCM_UNLIKELY (yy
== 1))
2796 SCM q
= scm_i_mkbig ();
2798 /* Arrange for rr to initially be non-positive,
2799 because that simplifies the test to see
2800 if it is within the needed bounds. */
2803 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2804 SCM_I_BIG_MPZ (x
), yy
);
2805 scm_remember_upto_here_1 (x
);
2807 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2808 SCM_I_BIG_MPZ (q
), 1);
2812 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2813 SCM_I_BIG_MPZ (x
), -yy
);
2814 scm_remember_upto_here_1 (x
);
2815 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2817 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2818 SCM_I_BIG_MPZ (q
), 1);
2820 return scm_i_normbig (q
);
2823 else if (SCM_BIGP (y
))
2824 return scm_i_bigint_centered_quotient (x
, y
);
2825 else if (SCM_REALP (y
))
2826 return scm_i_inexact_centered_quotient
2827 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2828 else if (SCM_FRACTIONP (y
))
2829 return scm_i_exact_rational_centered_quotient (x
, y
);
2831 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2832 s_scm_centered_quotient
);
2834 else if (SCM_REALP (x
))
2836 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2837 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2838 return scm_i_inexact_centered_quotient
2839 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2841 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2842 s_scm_centered_quotient
);
2844 else if (SCM_FRACTIONP (x
))
2847 return scm_i_inexact_centered_quotient
2848 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2849 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2850 return scm_i_exact_rational_centered_quotient (x
, y
);
2852 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2853 s_scm_centered_quotient
);
2856 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2857 s_scm_centered_quotient
);
2862 scm_i_inexact_centered_quotient (double x
, double y
)
2864 if (SCM_LIKELY (y
> 0))
2865 return scm_i_from_double (floor (x
/y
+ 0.5));
2866 else if (SCM_LIKELY (y
< 0))
2867 return scm_i_from_double (ceil (x
/y
- 0.5));
2869 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2874 /* Assumes that both x and y are bigints, though
2875 x might be able to fit into a fixnum. */
2877 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2881 /* Note that x might be small enough to fit into a
2882 fixnum, so we must not let it escape into the wild */
2886 /* min_r will eventually become -abs(y)/2 */
2887 min_r
= scm_i_mkbig ();
2888 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2889 SCM_I_BIG_MPZ (y
), 1);
2891 /* Arrange for rr to initially be non-positive,
2892 because that simplifies the test to see
2893 if it is within the needed bounds. */
2894 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2896 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2897 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2898 scm_remember_upto_here_2 (x
, y
);
2899 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2900 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2901 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2902 SCM_I_BIG_MPZ (q
), 1);
2906 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2907 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2908 scm_remember_upto_here_2 (x
, y
);
2909 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2910 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2911 SCM_I_BIG_MPZ (q
), 1);
2913 scm_remember_upto_here_2 (r
, min_r
);
2914 return scm_i_normbig (q
);
2918 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2920 return scm_centered_quotient
2921 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2922 scm_product (scm_numerator (y
), scm_denominator (x
)));
2925 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2926 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2927 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2929 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2931 "Return the real number @var{r} such that\n"
2932 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2933 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2934 "for some integer @var{q}.\n"
2936 "(centered-remainder 123 10) @result{} 3\n"
2937 "(centered-remainder 123 -10) @result{} 3\n"
2938 "(centered-remainder -123 10) @result{} -3\n"
2939 "(centered-remainder -123 -10) @result{} -3\n"
2940 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2941 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2943 #define FUNC_NAME s_scm_centered_remainder
2945 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2947 scm_t_inum xx
= SCM_I_INUM (x
);
2948 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2950 scm_t_inum yy
= SCM_I_INUM (y
);
2951 if (SCM_UNLIKELY (yy
== 0))
2952 scm_num_overflow (s_scm_centered_remainder
);
2955 scm_t_inum rr
= xx
% yy
;
2956 if (SCM_LIKELY (xx
> 0))
2958 if (SCM_LIKELY (yy
> 0))
2960 if (rr
>= (yy
+ 1) / 2)
2965 if (rr
>= (1 - yy
) / 2)
2971 if (SCM_LIKELY (yy
> 0))
2982 return SCM_I_MAKINUM (rr
);
2985 else if (SCM_BIGP (y
))
2987 /* Pass a denormalized bignum version of x (even though it
2988 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2989 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2991 else if (SCM_REALP (y
))
2992 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2993 else if (SCM_FRACTIONP (y
))
2994 return scm_i_exact_rational_centered_remainder (x
, y
);
2996 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2997 s_scm_centered_remainder
);
2999 else if (SCM_BIGP (x
))
3001 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3003 scm_t_inum yy
= SCM_I_INUM (y
);
3004 if (SCM_UNLIKELY (yy
== 0))
3005 scm_num_overflow (s_scm_centered_remainder
);
3009 /* Arrange for rr to initially be non-positive,
3010 because that simplifies the test to see
3011 if it is within the needed bounds. */
3014 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3015 scm_remember_upto_here_1 (x
);
3021 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3022 scm_remember_upto_here_1 (x
);
3026 return SCM_I_MAKINUM (rr
);
3029 else if (SCM_BIGP (y
))
3030 return scm_i_bigint_centered_remainder (x
, y
);
3031 else if (SCM_REALP (y
))
3032 return scm_i_inexact_centered_remainder
3033 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3034 else if (SCM_FRACTIONP (y
))
3035 return scm_i_exact_rational_centered_remainder (x
, y
);
3037 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3038 s_scm_centered_remainder
);
3040 else if (SCM_REALP (x
))
3042 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3043 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3044 return scm_i_inexact_centered_remainder
3045 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3047 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3048 s_scm_centered_remainder
);
3050 else if (SCM_FRACTIONP (x
))
3053 return scm_i_inexact_centered_remainder
3054 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3055 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3056 return scm_i_exact_rational_centered_remainder (x
, y
);
3058 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3059 s_scm_centered_remainder
);
3062 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3063 s_scm_centered_remainder
);
3068 scm_i_inexact_centered_remainder (double x
, double y
)
3072 /* Although it would be more efficient to use fmod here, we can't
3073 because it would in some cases produce results inconsistent with
3074 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3075 close). In particular, when x-y/2 is very close to a multiple of
3076 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3077 two cases must correspond to different choices of q. If quotient
3078 chooses one and remainder chooses the other, it would be bad. */
3079 if (SCM_LIKELY (y
> 0))
3080 q
= floor (x
/y
+ 0.5);
3081 else if (SCM_LIKELY (y
< 0))
3082 q
= ceil (x
/y
- 0.5);
3084 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3087 return scm_i_from_double (x
- q
* y
);
3090 /* Assumes that both x and y are bigints, though
3091 x might be able to fit into a fixnum. */
3093 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3097 /* Note that x might be small enough to fit into a
3098 fixnum, so we must not let it escape into the wild */
3101 /* min_r will eventually become -abs(y)/2 */
3102 min_r
= scm_i_mkbig ();
3103 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3104 SCM_I_BIG_MPZ (y
), 1);
3106 /* Arrange for rr to initially be non-positive,
3107 because that simplifies the test to see
3108 if it is within the needed bounds. */
3109 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3111 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3112 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3113 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3114 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3115 mpz_add (SCM_I_BIG_MPZ (r
),
3121 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3122 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3123 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3124 mpz_sub (SCM_I_BIG_MPZ (r
),
3128 scm_remember_upto_here_2 (x
, y
);
3129 return scm_i_normbig (r
);
3133 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3135 SCM xd
= scm_denominator (x
);
3136 SCM yd
= scm_denominator (y
);
3137 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3138 scm_product (scm_numerator (y
), xd
));
3139 return scm_divide (r1
, scm_product (xd
, yd
));
3143 static void scm_i_inexact_centered_divide (double x
, double y
,
3145 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3146 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3149 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3151 "Return the integer @var{q} and the real number @var{r}\n"
3152 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3153 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3155 "(centered/ 123 10) @result{} 12 and 3\n"
3156 "(centered/ 123 -10) @result{} -12 and 3\n"
3157 "(centered/ -123 10) @result{} -12 and -3\n"
3158 "(centered/ -123 -10) @result{} 12 and -3\n"
3159 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3160 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3162 #define FUNC_NAME s_scm_i_centered_divide
3166 scm_centered_divide(x
, y
, &q
, &r
);
3167 return scm_values (scm_list_2 (q
, r
));
3171 #define s_scm_centered_divide s_scm_i_centered_divide
3172 #define g_scm_centered_divide g_scm_i_centered_divide
3175 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3177 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3179 scm_t_inum xx
= SCM_I_INUM (x
);
3180 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3182 scm_t_inum yy
= SCM_I_INUM (y
);
3183 if (SCM_UNLIKELY (yy
== 0))
3184 scm_num_overflow (s_scm_centered_divide
);
3187 scm_t_inum qq
= xx
/ yy
;
3188 scm_t_inum rr
= xx
% yy
;
3189 if (SCM_LIKELY (xx
> 0))
3191 if (SCM_LIKELY (yy
> 0))
3193 if (rr
>= (yy
+ 1) / 2)
3198 if (rr
>= (1 - yy
) / 2)
3204 if (SCM_LIKELY (yy
> 0))
3215 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3216 *qp
= SCM_I_MAKINUM (qq
);
3218 *qp
= scm_i_inum2big (qq
);
3219 *rp
= SCM_I_MAKINUM (rr
);
3223 else if (SCM_BIGP (y
))
3225 /* Pass a denormalized bignum version of x (even though it
3226 can fit in a fixnum) to scm_i_bigint_centered_divide */
3227 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3229 else if (SCM_REALP (y
))
3230 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3231 else if (SCM_FRACTIONP (y
))
3232 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3234 return two_valued_wta_dispatch_2
3235 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3236 s_scm_centered_divide
, qp
, rp
);
3238 else if (SCM_BIGP (x
))
3240 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3242 scm_t_inum yy
= SCM_I_INUM (y
);
3243 if (SCM_UNLIKELY (yy
== 0))
3244 scm_num_overflow (s_scm_centered_divide
);
3247 SCM q
= scm_i_mkbig ();
3249 /* Arrange for rr to initially be non-positive,
3250 because that simplifies the test to see
3251 if it is within the needed bounds. */
3254 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3255 SCM_I_BIG_MPZ (x
), yy
);
3256 scm_remember_upto_here_1 (x
);
3259 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3260 SCM_I_BIG_MPZ (q
), 1);
3266 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3267 SCM_I_BIG_MPZ (x
), -yy
);
3268 scm_remember_upto_here_1 (x
);
3269 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3272 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3273 SCM_I_BIG_MPZ (q
), 1);
3277 *qp
= scm_i_normbig (q
);
3278 *rp
= SCM_I_MAKINUM (rr
);
3282 else if (SCM_BIGP (y
))
3283 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3284 else if (SCM_REALP (y
))
3285 return scm_i_inexact_centered_divide
3286 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3287 else if (SCM_FRACTIONP (y
))
3288 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3290 return two_valued_wta_dispatch_2
3291 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3292 s_scm_centered_divide
, qp
, rp
);
3294 else if (SCM_REALP (x
))
3296 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3297 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3298 return scm_i_inexact_centered_divide
3299 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3301 return two_valued_wta_dispatch_2
3302 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3303 s_scm_centered_divide
, qp
, rp
);
3305 else if (SCM_FRACTIONP (x
))
3308 return scm_i_inexact_centered_divide
3309 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3310 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3311 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3313 return two_valued_wta_dispatch_2
3314 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3315 s_scm_centered_divide
, qp
, rp
);
3318 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3319 s_scm_centered_divide
, qp
, rp
);
3323 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3327 if (SCM_LIKELY (y
> 0))
3328 q
= floor (x
/y
+ 0.5);
3329 else if (SCM_LIKELY (y
< 0))
3330 q
= ceil (x
/y
- 0.5);
3332 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3336 *qp
= scm_i_from_double (q
);
3337 *rp
= scm_i_from_double (r
);
3340 /* Assumes that both x and y are bigints, though
3341 x might be able to fit into a fixnum. */
3343 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3347 /* Note that x might be small enough to fit into a
3348 fixnum, so we must not let it escape into the wild */
3352 /* min_r will eventually become -abs(y/2) */
3353 min_r
= scm_i_mkbig ();
3354 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3355 SCM_I_BIG_MPZ (y
), 1);
3357 /* Arrange for rr to initially be non-positive,
3358 because that simplifies the test to see
3359 if it is within the needed bounds. */
3360 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3362 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3363 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3364 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3365 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3367 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3368 SCM_I_BIG_MPZ (q
), 1);
3369 mpz_add (SCM_I_BIG_MPZ (r
),
3376 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3377 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3378 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3380 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3381 SCM_I_BIG_MPZ (q
), 1);
3382 mpz_sub (SCM_I_BIG_MPZ (r
),
3387 scm_remember_upto_here_2 (x
, y
);
3388 *qp
= scm_i_normbig (q
);
3389 *rp
= scm_i_normbig (r
);
3393 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3396 SCM xd
= scm_denominator (x
);
3397 SCM yd
= scm_denominator (y
);
3399 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3400 scm_product (scm_numerator (y
), xd
),
3402 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3405 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3406 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3407 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3409 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3411 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3412 "with ties going to the nearest even integer.\n"
3414 "(round-quotient 123 10) @result{} 12\n"
3415 "(round-quotient 123 -10) @result{} -12\n"
3416 "(round-quotient -123 10) @result{} -12\n"
3417 "(round-quotient -123 -10) @result{} 12\n"
3418 "(round-quotient 125 10) @result{} 12\n"
3419 "(round-quotient 127 10) @result{} 13\n"
3420 "(round-quotient 135 10) @result{} 14\n"
3421 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3422 "(round-quotient 16/3 -10/7) @result{} -4\n"
3424 #define FUNC_NAME s_scm_round_quotient
3426 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3428 scm_t_inum xx
= SCM_I_INUM (x
);
3429 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3431 scm_t_inum yy
= SCM_I_INUM (y
);
3432 if (SCM_UNLIKELY (yy
== 0))
3433 scm_num_overflow (s_scm_round_quotient
);
3436 scm_t_inum qq
= xx
/ yy
;
3437 scm_t_inum rr
= xx
% yy
;
3439 scm_t_inum r2
= 2 * rr
;
3441 if (SCM_LIKELY (yy
< 0))
3461 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3462 return SCM_I_MAKINUM (qq
);
3464 return scm_i_inum2big (qq
);
3467 else if (SCM_BIGP (y
))
3469 /* Pass a denormalized bignum version of x (even though it
3470 can fit in a fixnum) to scm_i_bigint_round_quotient */
3471 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3473 else if (SCM_REALP (y
))
3474 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3475 else if (SCM_FRACTIONP (y
))
3476 return scm_i_exact_rational_round_quotient (x
, y
);
3478 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3479 s_scm_round_quotient
);
3481 else if (SCM_BIGP (x
))
3483 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3485 scm_t_inum yy
= SCM_I_INUM (y
);
3486 if (SCM_UNLIKELY (yy
== 0))
3487 scm_num_overflow (s_scm_round_quotient
);
3488 else if (SCM_UNLIKELY (yy
== 1))
3492 SCM q
= scm_i_mkbig ();
3494 int needs_adjustment
;
3498 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3499 SCM_I_BIG_MPZ (x
), yy
);
3500 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3501 needs_adjustment
= (2*rr
>= yy
);
3503 needs_adjustment
= (2*rr
> yy
);
3507 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3508 SCM_I_BIG_MPZ (x
), -yy
);
3509 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3510 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3511 needs_adjustment
= (2*rr
<= yy
);
3513 needs_adjustment
= (2*rr
< yy
);
3515 scm_remember_upto_here_1 (x
);
3516 if (needs_adjustment
)
3517 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3518 return scm_i_normbig (q
);
3521 else if (SCM_BIGP (y
))
3522 return scm_i_bigint_round_quotient (x
, y
);
3523 else if (SCM_REALP (y
))
3524 return scm_i_inexact_round_quotient
3525 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3526 else if (SCM_FRACTIONP (y
))
3527 return scm_i_exact_rational_round_quotient (x
, y
);
3529 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3530 s_scm_round_quotient
);
3532 else if (SCM_REALP (x
))
3534 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3535 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3536 return scm_i_inexact_round_quotient
3537 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3539 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3540 s_scm_round_quotient
);
3542 else if (SCM_FRACTIONP (x
))
3545 return scm_i_inexact_round_quotient
3546 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3547 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3548 return scm_i_exact_rational_round_quotient (x
, y
);
3550 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3551 s_scm_round_quotient
);
3554 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3555 s_scm_round_quotient
);
3560 scm_i_inexact_round_quotient (double x
, double y
)
3562 if (SCM_UNLIKELY (y
== 0))
3563 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3565 return scm_i_from_double (scm_c_round (x
/ y
));
3568 /* Assumes that both x and y are bigints, though
3569 x might be able to fit into a fixnum. */
3571 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3574 int cmp
, needs_adjustment
;
3576 /* Note that x might be small enough to fit into a
3577 fixnum, so we must not let it escape into the wild */
3580 r2
= scm_i_mkbig ();
3582 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3583 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3584 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3585 scm_remember_upto_here_2 (x
, r
);
3587 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3588 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3589 needs_adjustment
= (cmp
>= 0);
3591 needs_adjustment
= (cmp
> 0);
3592 scm_remember_upto_here_2 (r2
, y
);
3594 if (needs_adjustment
)
3595 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3597 return scm_i_normbig (q
);
3601 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3603 return scm_round_quotient
3604 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3605 scm_product (scm_numerator (y
), scm_denominator (x
)));
3608 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3609 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3610 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3612 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3614 "Return the real number @var{r} such that\n"
3615 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3616 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3617 "nearest integer, with ties going to the nearest\n"
3620 "(round-remainder 123 10) @result{} 3\n"
3621 "(round-remainder 123 -10) @result{} 3\n"
3622 "(round-remainder -123 10) @result{} -3\n"
3623 "(round-remainder -123 -10) @result{} -3\n"
3624 "(round-remainder 125 10) @result{} 5\n"
3625 "(round-remainder 127 10) @result{} -3\n"
3626 "(round-remainder 135 10) @result{} -5\n"
3627 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3628 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3630 #define FUNC_NAME s_scm_round_remainder
3632 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3634 scm_t_inum xx
= SCM_I_INUM (x
);
3635 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3637 scm_t_inum yy
= SCM_I_INUM (y
);
3638 if (SCM_UNLIKELY (yy
== 0))
3639 scm_num_overflow (s_scm_round_remainder
);
3642 scm_t_inum qq
= xx
/ yy
;
3643 scm_t_inum rr
= xx
% yy
;
3645 scm_t_inum r2
= 2 * rr
;
3647 if (SCM_LIKELY (yy
< 0))
3667 return SCM_I_MAKINUM (rr
);
3670 else if (SCM_BIGP (y
))
3672 /* Pass a denormalized bignum version of x (even though it
3673 can fit in a fixnum) to scm_i_bigint_round_remainder */
3674 return scm_i_bigint_round_remainder
3675 (scm_i_long2big (xx
), y
);
3677 else if (SCM_REALP (y
))
3678 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3679 else if (SCM_FRACTIONP (y
))
3680 return scm_i_exact_rational_round_remainder (x
, y
);
3682 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3683 s_scm_round_remainder
);
3685 else if (SCM_BIGP (x
))
3687 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3689 scm_t_inum yy
= SCM_I_INUM (y
);
3690 if (SCM_UNLIKELY (yy
== 0))
3691 scm_num_overflow (s_scm_round_remainder
);
3694 SCM q
= scm_i_mkbig ();
3696 int needs_adjustment
;
3700 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3701 SCM_I_BIG_MPZ (x
), yy
);
3702 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3703 needs_adjustment
= (2*rr
>= yy
);
3705 needs_adjustment
= (2*rr
> yy
);
3709 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3710 SCM_I_BIG_MPZ (x
), -yy
);
3711 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3712 needs_adjustment
= (2*rr
<= yy
);
3714 needs_adjustment
= (2*rr
< yy
);
3716 scm_remember_upto_here_2 (x
, q
);
3717 if (needs_adjustment
)
3719 return SCM_I_MAKINUM (rr
);
3722 else if (SCM_BIGP (y
))
3723 return scm_i_bigint_round_remainder (x
, y
);
3724 else if (SCM_REALP (y
))
3725 return scm_i_inexact_round_remainder
3726 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3727 else if (SCM_FRACTIONP (y
))
3728 return scm_i_exact_rational_round_remainder (x
, y
);
3730 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3731 s_scm_round_remainder
);
3733 else if (SCM_REALP (x
))
3735 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3736 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3737 return scm_i_inexact_round_remainder
3738 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3740 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3741 s_scm_round_remainder
);
3743 else if (SCM_FRACTIONP (x
))
3746 return scm_i_inexact_round_remainder
3747 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3748 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3749 return scm_i_exact_rational_round_remainder (x
, y
);
3751 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3752 s_scm_round_remainder
);
3755 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3756 s_scm_round_remainder
);
3761 scm_i_inexact_round_remainder (double x
, double y
)
3763 /* Although it would be more efficient to use fmod here, we can't
3764 because it would in some cases produce results inconsistent with
3765 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3766 close). In particular, when x-y/2 is very close to a multiple of
3767 y, then r might be either -abs(y/2) or abs(y/2), but those two
3768 cases must correspond to different choices of q. If quotient
3769 chooses one and remainder chooses the other, it would be bad. */
3771 if (SCM_UNLIKELY (y
== 0))
3772 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3775 double q
= scm_c_round (x
/ y
);
3776 return scm_i_from_double (x
- q
* y
);
3780 /* Assumes that both x and y are bigints, though
3781 x might be able to fit into a fixnum. */
3783 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3786 int cmp
, needs_adjustment
;
3788 /* Note that x might be small enough to fit into a
3789 fixnum, so we must not let it escape into the wild */
3792 r2
= scm_i_mkbig ();
3794 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3795 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3796 scm_remember_upto_here_1 (x
);
3797 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3799 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3800 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3801 needs_adjustment
= (cmp
>= 0);
3803 needs_adjustment
= (cmp
> 0);
3804 scm_remember_upto_here_2 (q
, r2
);
3806 if (needs_adjustment
)
3807 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3809 scm_remember_upto_here_1 (y
);
3810 return scm_i_normbig (r
);
3814 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3816 SCM xd
= scm_denominator (x
);
3817 SCM yd
= scm_denominator (y
);
3818 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3819 scm_product (scm_numerator (y
), xd
));
3820 return scm_divide (r1
, scm_product (xd
, yd
));
3824 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3825 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3826 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3828 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3830 "Return the integer @var{q} and the real number @var{r}\n"
3831 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3832 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3833 "nearest integer, with ties going to the nearest even integer.\n"
3835 "(round/ 123 10) @result{} 12 and 3\n"
3836 "(round/ 123 -10) @result{} -12 and 3\n"
3837 "(round/ -123 10) @result{} -12 and -3\n"
3838 "(round/ -123 -10) @result{} 12 and -3\n"
3839 "(round/ 125 10) @result{} 12 and 5\n"
3840 "(round/ 127 10) @result{} 13 and -3\n"
3841 "(round/ 135 10) @result{} 14 and -5\n"
3842 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3843 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3845 #define FUNC_NAME s_scm_i_round_divide
3849 scm_round_divide(x
, y
, &q
, &r
);
3850 return scm_values (scm_list_2 (q
, r
));
3854 #define s_scm_round_divide s_scm_i_round_divide
3855 #define g_scm_round_divide g_scm_i_round_divide
3858 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3860 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3862 scm_t_inum xx
= SCM_I_INUM (x
);
3863 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3865 scm_t_inum yy
= SCM_I_INUM (y
);
3866 if (SCM_UNLIKELY (yy
== 0))
3867 scm_num_overflow (s_scm_round_divide
);
3870 scm_t_inum qq
= xx
/ yy
;
3871 scm_t_inum rr
= xx
% yy
;
3873 scm_t_inum r2
= 2 * rr
;
3875 if (SCM_LIKELY (yy
< 0))
3895 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3896 *qp
= SCM_I_MAKINUM (qq
);
3898 *qp
= scm_i_inum2big (qq
);
3899 *rp
= SCM_I_MAKINUM (rr
);
3903 else if (SCM_BIGP (y
))
3905 /* Pass a denormalized bignum version of x (even though it
3906 can fit in a fixnum) to scm_i_bigint_round_divide */
3907 return scm_i_bigint_round_divide
3908 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3910 else if (SCM_REALP (y
))
3911 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3912 else if (SCM_FRACTIONP (y
))
3913 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3915 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3916 s_scm_round_divide
, qp
, rp
);
3918 else if (SCM_BIGP (x
))
3920 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3922 scm_t_inum yy
= SCM_I_INUM (y
);
3923 if (SCM_UNLIKELY (yy
== 0))
3924 scm_num_overflow (s_scm_round_divide
);
3927 SCM q
= scm_i_mkbig ();
3929 int needs_adjustment
;
3933 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3934 SCM_I_BIG_MPZ (x
), yy
);
3935 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3936 needs_adjustment
= (2*rr
>= yy
);
3938 needs_adjustment
= (2*rr
> yy
);
3942 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3943 SCM_I_BIG_MPZ (x
), -yy
);
3944 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3945 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3946 needs_adjustment
= (2*rr
<= yy
);
3948 needs_adjustment
= (2*rr
< yy
);
3950 scm_remember_upto_here_1 (x
);
3951 if (needs_adjustment
)
3953 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3956 *qp
= scm_i_normbig (q
);
3957 *rp
= SCM_I_MAKINUM (rr
);
3961 else if (SCM_BIGP (y
))
3962 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3963 else if (SCM_REALP (y
))
3964 return scm_i_inexact_round_divide
3965 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3966 else if (SCM_FRACTIONP (y
))
3967 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3969 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3970 s_scm_round_divide
, qp
, rp
);
3972 else if (SCM_REALP (x
))
3974 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3975 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3976 return scm_i_inexact_round_divide
3977 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3979 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3980 s_scm_round_divide
, qp
, rp
);
3982 else if (SCM_FRACTIONP (x
))
3985 return scm_i_inexact_round_divide
3986 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3987 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3988 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3990 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3991 s_scm_round_divide
, qp
, rp
);
3994 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3995 s_scm_round_divide
, qp
, rp
);
3999 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
4001 if (SCM_UNLIKELY (y
== 0))
4002 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4005 double q
= scm_c_round (x
/ y
);
4006 double r
= x
- q
* y
;
4007 *qp
= scm_i_from_double (q
);
4008 *rp
= scm_i_from_double (r
);
4012 /* Assumes that both x and y are bigints, though
4013 x might be able to fit into a fixnum. */
4015 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4018 int cmp
, needs_adjustment
;
4020 /* Note that x might be small enough to fit into a
4021 fixnum, so we must not let it escape into the wild */
4024 r2
= scm_i_mkbig ();
4026 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4027 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4028 scm_remember_upto_here_1 (x
);
4029 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4031 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4032 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4033 needs_adjustment
= (cmp
>= 0);
4035 needs_adjustment
= (cmp
> 0);
4037 if (needs_adjustment
)
4039 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4040 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4043 scm_remember_upto_here_2 (r2
, y
);
4044 *qp
= scm_i_normbig (q
);
4045 *rp
= scm_i_normbig (r
);
4049 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4052 SCM xd
= scm_denominator (x
);
4053 SCM yd
= scm_denominator (y
);
4055 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4056 scm_product (scm_numerator (y
), xd
),
4058 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4062 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4063 (SCM x
, SCM y
, SCM rest
),
4064 "Return the greatest common divisor of all parameter values.\n"
4065 "If called without arguments, 0 is returned.")
4066 #define FUNC_NAME s_scm_i_gcd
4068 while (!scm_is_null (rest
))
4069 { x
= scm_gcd (x
, y
);
4071 rest
= scm_cdr (rest
);
4073 return scm_gcd (x
, y
);
4077 #define s_gcd s_scm_i_gcd
4078 #define g_gcd g_scm_i_gcd
4081 scm_gcd (SCM x
, SCM y
)
4083 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4084 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4086 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4088 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4090 scm_t_inum xx
= SCM_I_INUM (x
);
4091 scm_t_inum yy
= SCM_I_INUM (y
);
4092 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4093 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4095 if (SCM_UNLIKELY (xx
== 0))
4097 else if (SCM_UNLIKELY (yy
== 0))
4102 /* Determine a common factor 2^k */
4103 while (((u
| v
) & 1) == 0)
4109 /* Now, any factor 2^n can be eliminated */
4111 while ((u
& 1) == 0)
4114 while ((v
& 1) == 0)
4116 /* Both u and v are now odd. Subtract the smaller one
4117 from the larger one to produce an even number, remove
4118 more factors of two, and repeat. */
4124 while ((u
& 1) == 0)
4130 while ((v
& 1) == 0)
4136 return (SCM_POSFIXABLE (result
)
4137 ? SCM_I_MAKINUM (result
)
4138 : scm_i_inum2big (result
));
4140 else if (SCM_BIGP (y
))
4145 else if (SCM_REALP (y
) && scm_is_integer (y
))
4146 goto handle_inexacts
;
4148 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4150 else if (SCM_BIGP (x
))
4152 if (SCM_I_INUMP (y
))
4157 yy
= SCM_I_INUM (y
);
4162 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4163 scm_remember_upto_here_1 (x
);
4164 return (SCM_POSFIXABLE (result
)
4165 ? SCM_I_MAKINUM (result
)
4166 : scm_from_unsigned_integer (result
));
4168 else if (SCM_BIGP (y
))
4170 SCM result
= scm_i_mkbig ();
4171 mpz_gcd (SCM_I_BIG_MPZ (result
),
4174 scm_remember_upto_here_2 (x
, y
);
4175 return scm_i_normbig (result
);
4177 else if (SCM_REALP (y
) && scm_is_integer (y
))
4178 goto handle_inexacts
;
4180 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4182 else if (SCM_REALP (x
) && scm_is_integer (x
))
4184 if (SCM_I_INUMP (y
) || SCM_BIGP (y
)
4185 || (SCM_REALP (y
) && scm_is_integer (y
)))
4188 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x
),
4189 scm_inexact_to_exact (y
)));
4192 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4195 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4198 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4199 (SCM x
, SCM y
, SCM rest
),
4200 "Return the least common multiple of the arguments.\n"
4201 "If called without arguments, 1 is returned.")
4202 #define FUNC_NAME s_scm_i_lcm
4204 while (!scm_is_null (rest
))
4205 { x
= scm_lcm (x
, y
);
4207 rest
= scm_cdr (rest
);
4209 return scm_lcm (x
, y
);
4213 #define s_lcm s_scm_i_lcm
4214 #define g_lcm g_scm_i_lcm
4217 scm_lcm (SCM n1
, SCM n2
)
4219 if (SCM_UNLIKELY (SCM_UNBNDP (n2
)))
4220 return SCM_UNBNDP (n1
) ? SCM_INUM1
: scm_abs (n1
);
4222 if (SCM_LIKELY (SCM_I_INUMP (n1
)))
4224 if (SCM_LIKELY (SCM_I_INUMP (n2
)))
4226 SCM d
= scm_gcd (n1
, n2
);
4227 if (scm_is_eq (d
, SCM_INUM0
))
4230 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4232 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4234 /* inum n1, big n2 */
4237 SCM result
= scm_i_mkbig ();
4238 scm_t_inum nn1
= SCM_I_INUM (n1
);
4239 if (nn1
== 0) return SCM_INUM0
;
4240 if (nn1
< 0) nn1
= - nn1
;
4241 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4242 scm_remember_upto_here_1 (n2
);
4246 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4247 goto handle_inexacts
;
4249 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4251 else if (SCM_LIKELY (SCM_BIGP (n1
)))
4254 if (SCM_I_INUMP (n2
))
4259 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4261 SCM result
= scm_i_mkbig ();
4262 mpz_lcm(SCM_I_BIG_MPZ (result
),
4264 SCM_I_BIG_MPZ (n2
));
4265 scm_remember_upto_here_2(n1
, n2
);
4266 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4269 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4270 goto handle_inexacts
;
4272 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4274 else if (SCM_REALP (n1
) && scm_is_integer (n1
))
4276 if (SCM_I_INUMP (n2
) || SCM_BIGP (n2
)
4277 || (SCM_REALP (n2
) && scm_is_integer (n2
)))
4280 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1
),
4281 scm_inexact_to_exact (n2
)));
4284 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4287 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4290 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4295 + + + x (map digit:logand X Y)
4296 + - + x (map digit:logand X (lognot (+ -1 Y)))
4297 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4298 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4303 + + + (map digit:logior X Y)
4304 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4305 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4306 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4311 + + + (map digit:logxor X Y)
4312 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4313 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4314 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4319 + + (any digit:logand X Y)
4320 + - (any digit:logand X (lognot (+ -1 Y)))
4321 - + (any digit:logand (lognot (+ -1 X)) Y)
4326 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4327 (SCM x
, SCM y
, SCM rest
),
4328 "Return the bitwise AND of the integer arguments.\n\n"
4330 "(logand) @result{} -1\n"
4331 "(logand 7) @result{} 7\n"
4332 "(logand #b111 #b011 #b001) @result{} 1\n"
4334 #define FUNC_NAME s_scm_i_logand
4336 while (!scm_is_null (rest
))
4337 { x
= scm_logand (x
, y
);
4339 rest
= scm_cdr (rest
);
4341 return scm_logand (x
, y
);
4345 #define s_scm_logand s_scm_i_logand
4347 SCM
scm_logand (SCM n1
, SCM n2
)
4348 #define FUNC_NAME s_scm_logand
4352 if (SCM_UNBNDP (n2
))
4354 if (SCM_UNBNDP (n1
))
4355 return SCM_I_MAKINUM (-1);
4356 else if (!SCM_NUMBERP (n1
))
4357 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4358 else if (SCM_NUMBERP (n1
))
4361 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4364 if (SCM_I_INUMP (n1
))
4366 nn1
= SCM_I_INUM (n1
);
4367 if (SCM_I_INUMP (n2
))
4369 scm_t_inum nn2
= SCM_I_INUM (n2
);
4370 return SCM_I_MAKINUM (nn1
& nn2
);
4372 else if SCM_BIGP (n2
)
4378 SCM result_z
= scm_i_mkbig ();
4380 mpz_init_set_si (nn1_z
, nn1
);
4381 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4382 scm_remember_upto_here_1 (n2
);
4384 return scm_i_normbig (result_z
);
4388 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4390 else if (SCM_BIGP (n1
))
4392 if (SCM_I_INUMP (n2
))
4395 nn1
= SCM_I_INUM (n1
);
4398 else if (SCM_BIGP (n2
))
4400 SCM result_z
= scm_i_mkbig ();
4401 mpz_and (SCM_I_BIG_MPZ (result_z
),
4403 SCM_I_BIG_MPZ (n2
));
4404 scm_remember_upto_here_2 (n1
, n2
);
4405 return scm_i_normbig (result_z
);
4408 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4411 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4416 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4417 (SCM x
, SCM y
, SCM rest
),
4418 "Return the bitwise OR of the integer arguments.\n\n"
4420 "(logior) @result{} 0\n"
4421 "(logior 7) @result{} 7\n"
4422 "(logior #b000 #b001 #b011) @result{} 3\n"
4424 #define FUNC_NAME s_scm_i_logior
4426 while (!scm_is_null (rest
))
4427 { x
= scm_logior (x
, y
);
4429 rest
= scm_cdr (rest
);
4431 return scm_logior (x
, y
);
4435 #define s_scm_logior s_scm_i_logior
4437 SCM
scm_logior (SCM n1
, SCM n2
)
4438 #define FUNC_NAME s_scm_logior
4442 if (SCM_UNBNDP (n2
))
4444 if (SCM_UNBNDP (n1
))
4446 else if (SCM_NUMBERP (n1
))
4449 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4452 if (SCM_I_INUMP (n1
))
4454 nn1
= SCM_I_INUM (n1
);
4455 if (SCM_I_INUMP (n2
))
4457 long nn2
= SCM_I_INUM (n2
);
4458 return SCM_I_MAKINUM (nn1
| nn2
);
4460 else if (SCM_BIGP (n2
))
4466 SCM result_z
= scm_i_mkbig ();
4468 mpz_init_set_si (nn1_z
, nn1
);
4469 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4470 scm_remember_upto_here_1 (n2
);
4472 return scm_i_normbig (result_z
);
4476 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4478 else if (SCM_BIGP (n1
))
4480 if (SCM_I_INUMP (n2
))
4483 nn1
= SCM_I_INUM (n1
);
4486 else if (SCM_BIGP (n2
))
4488 SCM result_z
= scm_i_mkbig ();
4489 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4491 SCM_I_BIG_MPZ (n2
));
4492 scm_remember_upto_here_2 (n1
, n2
);
4493 return scm_i_normbig (result_z
);
4496 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4499 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4504 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4505 (SCM x
, SCM y
, SCM rest
),
4506 "Return the bitwise XOR of the integer arguments. A bit is\n"
4507 "set in the result if it is set in an odd number of arguments.\n"
4509 "(logxor) @result{} 0\n"
4510 "(logxor 7) @result{} 7\n"
4511 "(logxor #b000 #b001 #b011) @result{} 2\n"
4512 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4514 #define FUNC_NAME s_scm_i_logxor
4516 while (!scm_is_null (rest
))
4517 { x
= scm_logxor (x
, y
);
4519 rest
= scm_cdr (rest
);
4521 return scm_logxor (x
, y
);
4525 #define s_scm_logxor s_scm_i_logxor
4527 SCM
scm_logxor (SCM n1
, SCM n2
)
4528 #define FUNC_NAME s_scm_logxor
4532 if (SCM_UNBNDP (n2
))
4534 if (SCM_UNBNDP (n1
))
4536 else if (SCM_NUMBERP (n1
))
4539 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4542 if (SCM_I_INUMP (n1
))
4544 nn1
= SCM_I_INUM (n1
);
4545 if (SCM_I_INUMP (n2
))
4547 scm_t_inum nn2
= SCM_I_INUM (n2
);
4548 return SCM_I_MAKINUM (nn1
^ nn2
);
4550 else if (SCM_BIGP (n2
))
4554 SCM result_z
= scm_i_mkbig ();
4556 mpz_init_set_si (nn1_z
, nn1
);
4557 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4558 scm_remember_upto_here_1 (n2
);
4560 return scm_i_normbig (result_z
);
4564 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4566 else if (SCM_BIGP (n1
))
4568 if (SCM_I_INUMP (n2
))
4571 nn1
= SCM_I_INUM (n1
);
4574 else if (SCM_BIGP (n2
))
4576 SCM result_z
= scm_i_mkbig ();
4577 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4579 SCM_I_BIG_MPZ (n2
));
4580 scm_remember_upto_here_2 (n1
, n2
);
4581 return scm_i_normbig (result_z
);
4584 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4587 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4592 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4594 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4595 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4596 "without actually calculating the @code{logand}, just testing\n"
4600 "(logtest #b0100 #b1011) @result{} #f\n"
4601 "(logtest #b0100 #b0111) @result{} #t\n"
4603 #define FUNC_NAME s_scm_logtest
4607 if (SCM_I_INUMP (j
))
4609 nj
= SCM_I_INUM (j
);
4610 if (SCM_I_INUMP (k
))
4612 scm_t_inum nk
= SCM_I_INUM (k
);
4613 return scm_from_bool (nj
& nk
);
4615 else if (SCM_BIGP (k
))
4623 mpz_init_set_si (nj_z
, nj
);
4624 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4625 scm_remember_upto_here_1 (k
);
4626 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4632 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4634 else if (SCM_BIGP (j
))
4636 if (SCM_I_INUMP (k
))
4639 nj
= SCM_I_INUM (j
);
4642 else if (SCM_BIGP (k
))
4646 mpz_init (result_z
);
4650 scm_remember_upto_here_2 (j
, k
);
4651 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4652 mpz_clear (result_z
);
4656 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4659 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4664 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4666 "Test whether bit number @var{index} in @var{j} is set.\n"
4667 "@var{index} starts from 0 for the least significant bit.\n"
4670 "(logbit? 0 #b1101) @result{} #t\n"
4671 "(logbit? 1 #b1101) @result{} #f\n"
4672 "(logbit? 2 #b1101) @result{} #t\n"
4673 "(logbit? 3 #b1101) @result{} #t\n"
4674 "(logbit? 4 #b1101) @result{} #f\n"
4676 #define FUNC_NAME s_scm_logbit_p
4678 unsigned long int iindex
;
4679 iindex
= scm_to_ulong (index
);
4681 if (SCM_I_INUMP (j
))
4683 /* bits above what's in an inum follow the sign bit */
4684 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4685 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4687 else if (SCM_BIGP (j
))
4689 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4690 scm_remember_upto_here_1 (j
);
4691 return scm_from_bool (val
);
4694 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4699 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4701 "Return the integer which is the ones-complement of the integer\n"
4705 "(number->string (lognot #b10000000) 2)\n"
4706 " @result{} \"-10000001\"\n"
4707 "(number->string (lognot #b0) 2)\n"
4708 " @result{} \"-1\"\n"
4710 #define FUNC_NAME s_scm_lognot
4712 if (SCM_I_INUMP (n
)) {
4713 /* No overflow here, just need to toggle all the bits making up the inum.
4714 Enhancement: No need to strip the tag and add it back, could just xor
4715 a block of 1 bits, if that worked with the various debug versions of
4717 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4719 } else if (SCM_BIGP (n
)) {
4720 SCM result
= scm_i_mkbig ();
4721 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4722 scm_remember_upto_here_1 (n
);
4726 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4731 /* returns 0 if IN is not an integer. OUT must already be
4734 coerce_to_big (SCM in
, mpz_t out
)
4737 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4738 else if (SCM_I_INUMP (in
))
4739 mpz_set_si (out
, SCM_I_INUM (in
));
4746 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4747 (SCM n
, SCM k
, SCM m
),
4748 "Return @var{n} raised to the integer exponent\n"
4749 "@var{k}, modulo @var{m}.\n"
4752 "(modulo-expt 2 3 5)\n"
4755 #define FUNC_NAME s_scm_modulo_expt
4761 /* There are two classes of error we might encounter --
4762 1) Math errors, which we'll report by calling scm_num_overflow,
4764 2) wrong-type errors, which of course we'll report by calling
4766 We don't report those errors immediately, however; instead we do
4767 some cleanup first. These variables tell us which error (if
4768 any) we should report after cleaning up.
4770 int report_overflow
= 0;
4772 int position_of_wrong_type
= 0;
4773 SCM value_of_wrong_type
= SCM_INUM0
;
4775 SCM result
= SCM_UNDEFINED
;
4781 if (scm_is_eq (m
, SCM_INUM0
))
4783 report_overflow
= 1;
4787 if (!coerce_to_big (n
, n_tmp
))
4789 value_of_wrong_type
= n
;
4790 position_of_wrong_type
= 1;
4794 if (!coerce_to_big (k
, k_tmp
))
4796 value_of_wrong_type
= k
;
4797 position_of_wrong_type
= 2;
4801 if (!coerce_to_big (m
, m_tmp
))
4803 value_of_wrong_type
= m
;
4804 position_of_wrong_type
= 3;
4808 /* if the exponent K is negative, and we simply call mpz_powm, we
4809 will get a divide-by-zero exception when an inverse 1/n mod m
4810 doesn't exist (or is not unique). Since exceptions are hard to
4811 handle, we'll attempt the inversion "by hand" -- that way, we get
4812 a simple failure code, which is easy to handle. */
4814 if (-1 == mpz_sgn (k_tmp
))
4816 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4818 report_overflow
= 1;
4821 mpz_neg (k_tmp
, k_tmp
);
4824 result
= scm_i_mkbig ();
4825 mpz_powm (SCM_I_BIG_MPZ (result
),
4830 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4831 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4838 if (report_overflow
)
4839 scm_num_overflow (FUNC_NAME
);
4841 if (position_of_wrong_type
)
4842 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4843 value_of_wrong_type
);
4845 return scm_i_normbig (result
);
4849 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4851 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4852 "exact integer, @var{n} can be any number.\n"
4854 "Negative @var{k} is supported, and results in\n"
4855 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4856 "@math{@var{n}^0} is 1, as usual, and that\n"
4857 "includes @math{0^0} is 1.\n"
4860 "(integer-expt 2 5) @result{} 32\n"
4861 "(integer-expt -3 3) @result{} -27\n"
4862 "(integer-expt 5 -3) @result{} 1/125\n"
4863 "(integer-expt 0 0) @result{} 1\n"
4865 #define FUNC_NAME s_scm_integer_expt
4868 SCM z_i2
= SCM_BOOL_F
;
4870 SCM acc
= SCM_I_MAKINUM (1L);
4872 /* Specifically refrain from checking the type of the first argument.
4873 This allows us to exponentiate any object that can be multiplied.
4874 If we must raise to a negative power, we must also be able to
4875 take its reciprocal. */
4876 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4877 SCM_WRONG_TYPE_ARG (2, k
);
4879 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4880 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4881 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4882 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4883 /* The next check is necessary only because R6RS specifies different
4884 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4885 we simply skip this case and move on. */
4886 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4888 /* k cannot be 0 at this point, because we
4889 have already checked for that case above */
4890 if (scm_is_true (scm_positive_p (k
)))
4892 else /* return NaN for (0 ^ k) for negative k per R6RS */
4895 else if (SCM_FRACTIONP (n
))
4897 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4898 needless reduction of intermediate products to lowest terms.
4899 If a and b have no common factors, then a^k and b^k have no
4900 common factors. Use 'scm_i_make_ratio_already_reduced' to
4901 construct the final result, so that no gcd computations are
4902 needed to exponentiate a fraction. */
4903 if (scm_is_true (scm_positive_p (k
)))
4904 return scm_i_make_ratio_already_reduced
4905 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4906 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4909 k
= scm_difference (k
, SCM_UNDEFINED
);
4910 return scm_i_make_ratio_already_reduced
4911 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4912 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4916 if (SCM_I_INUMP (k
))
4917 i2
= SCM_I_INUM (k
);
4918 else if (SCM_BIGP (k
))
4920 z_i2
= scm_i_clonebig (k
, 1);
4921 scm_remember_upto_here_1 (k
);
4925 SCM_WRONG_TYPE_ARG (2, k
);
4929 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4931 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4932 n
= scm_divide (n
, SCM_UNDEFINED
);
4936 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4940 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4942 return scm_product (acc
, n
);
4944 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4945 acc
= scm_product (acc
, n
);
4946 n
= scm_product (n
, n
);
4947 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4955 n
= scm_divide (n
, SCM_UNDEFINED
);
4962 return scm_product (acc
, n
);
4964 acc
= scm_product (acc
, n
);
4965 n
= scm_product (n
, n
);
4972 /* Efficiently compute (N * 2^COUNT),
4973 where N is an exact integer, and COUNT > 0. */
4975 left_shift_exact_integer (SCM n
, long count
)
4977 if (SCM_I_INUMP (n
))
4979 scm_t_inum nn
= SCM_I_INUM (n
);
4981 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
4982 overflow a non-zero fixnum. For smaller shifts we check the
4983 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4984 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4985 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
4987 [*] There's one exception:
4988 (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
4992 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4993 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4995 return SCM_I_MAKINUM (nn
<< count
);
4998 SCM result
= scm_i_inum2big (nn
);
4999 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5001 return scm_i_normbig (result
);
5004 else if (SCM_BIGP (n
))
5006 SCM result
= scm_i_mkbig ();
5007 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5008 scm_remember_upto_here_1 (n
);
5015 /* Efficiently compute floor (N / 2^COUNT),
5016 where N is an exact integer and COUNT > 0. */
5018 floor_right_shift_exact_integer (SCM n
, long count
)
5020 if (SCM_I_INUMP (n
))
5022 scm_t_inum nn
= SCM_I_INUM (n
);
5024 if (count
>= SCM_I_FIXNUM_BIT
)
5025 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5027 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5029 else if (SCM_BIGP (n
))
5031 SCM result
= scm_i_mkbig ();
5032 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5034 scm_remember_upto_here_1 (n
);
5035 return scm_i_normbig (result
);
5041 /* Efficiently compute round (N / 2^COUNT),
5042 where N is an exact integer and COUNT > 0. */
5044 round_right_shift_exact_integer (SCM n
, long count
)
5046 if (SCM_I_INUMP (n
))
5048 if (count
>= SCM_I_FIXNUM_BIT
)
5052 scm_t_inum nn
= SCM_I_INUM (n
);
5053 scm_t_inum qq
= SCM_SRS (nn
, count
);
5055 if (0 == (nn
& (1L << (count
-1))))
5056 return SCM_I_MAKINUM (qq
); /* round down */
5057 else if (nn
& ((1L << (count
-1)) - 1))
5058 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5060 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5063 else if (SCM_BIGP (n
))
5065 SCM q
= scm_i_mkbig ();
5067 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5068 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5069 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5070 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5071 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5072 scm_remember_upto_here_1 (n
);
5073 return scm_i_normbig (q
);
5079 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5081 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5082 "@var{n} and @var{count} must be exact integers.\n"
5084 "With @var{n} viewed as an infinite-precision twos-complement\n"
5085 "integer, @code{ash} means a left shift introducing zero bits\n"
5086 "when @var{count} is positive, or a right shift dropping bits\n"
5087 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5090 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5091 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5093 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5094 "(ash -23 -2) @result{} -6\n"
5096 #define FUNC_NAME s_scm_ash
5098 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5100 long bits_to_shift
= scm_to_long (count
);
5102 if (bits_to_shift
> 0)
5103 return left_shift_exact_integer (n
, bits_to_shift
);
5104 else if (SCM_LIKELY (bits_to_shift
< 0))
5105 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5110 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5114 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5116 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5117 "@var{n} and @var{count} must be exact integers.\n"
5119 "With @var{n} viewed as an infinite-precision twos-complement\n"
5120 "integer, @code{round-ash} means a left shift introducing zero\n"
5121 "bits when @var{count} is positive, or a right shift rounding\n"
5122 "to the nearest integer (with ties going to the nearest even\n"
5123 "integer) when @var{count} is negative. This is a rounded\n"
5124 "``arithmetic'' shift.\n"
5127 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5128 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5129 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5130 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5131 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5132 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5134 #define FUNC_NAME s_scm_round_ash
5136 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5138 long bits_to_shift
= scm_to_long (count
);
5140 if (bits_to_shift
> 0)
5141 return left_shift_exact_integer (n
, bits_to_shift
);
5142 else if (SCM_LIKELY (bits_to_shift
< 0))
5143 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5148 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5153 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5154 (SCM n
, SCM start
, SCM end
),
5155 "Return the integer composed of the @var{start} (inclusive)\n"
5156 "through @var{end} (exclusive) bits of @var{n}. The\n"
5157 "@var{start}th bit becomes the 0-th bit in the result.\n"
5160 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5161 " @result{} \"1010\"\n"
5162 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5163 " @result{} \"10110\"\n"
5165 #define FUNC_NAME s_scm_bit_extract
5167 unsigned long int istart
, iend
, bits
;
5168 istart
= scm_to_ulong (start
);
5169 iend
= scm_to_ulong (end
);
5170 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5172 /* how many bits to keep */
5173 bits
= iend
- istart
;
5175 if (SCM_I_INUMP (n
))
5177 scm_t_inum in
= SCM_I_INUM (n
);
5179 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5180 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5181 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5183 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5185 /* Since we emulate two's complement encoded numbers, this
5186 * special case requires us to produce a result that has
5187 * more bits than can be stored in a fixnum.
5189 SCM result
= scm_i_inum2big (in
);
5190 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5195 /* mask down to requisite bits */
5196 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5197 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5199 else if (SCM_BIGP (n
))
5204 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5208 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5209 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5210 such bits into a ulong. */
5211 result
= scm_i_mkbig ();
5212 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5213 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5214 result
= scm_i_normbig (result
);
5216 scm_remember_upto_here_1 (n
);
5220 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5225 static const char scm_logtab
[] = {
5226 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5229 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5231 "Return the number of bits in integer @var{n}. If integer is\n"
5232 "positive, the 1-bits in its binary representation are counted.\n"
5233 "If negative, the 0-bits in its two's-complement binary\n"
5234 "representation are counted. If 0, 0 is returned.\n"
5237 "(logcount #b10101010)\n"
5244 #define FUNC_NAME s_scm_logcount
5246 if (SCM_I_INUMP (n
))
5248 unsigned long c
= 0;
5249 scm_t_inum nn
= SCM_I_INUM (n
);
5254 c
+= scm_logtab
[15 & nn
];
5257 return SCM_I_MAKINUM (c
);
5259 else if (SCM_BIGP (n
))
5261 unsigned long count
;
5262 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5263 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5265 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5266 scm_remember_upto_here_1 (n
);
5267 return SCM_I_MAKINUM (count
);
5270 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5275 static const char scm_ilentab
[] = {
5276 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5280 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5282 "Return the number of bits necessary to represent @var{n}.\n"
5285 "(integer-length #b10101010)\n"
5287 "(integer-length 0)\n"
5289 "(integer-length #b1111)\n"
5292 #define FUNC_NAME s_scm_integer_length
5294 if (SCM_I_INUMP (n
))
5296 unsigned long c
= 0;
5298 scm_t_inum nn
= SCM_I_INUM (n
);
5304 l
= scm_ilentab
[15 & nn
];
5307 return SCM_I_MAKINUM (c
- 4 + l
);
5309 else if (SCM_BIGP (n
))
5311 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5312 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5313 1 too big, so check for that and adjust. */
5314 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5315 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5316 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5317 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5319 scm_remember_upto_here_1 (n
);
5320 return SCM_I_MAKINUM (size
);
5323 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5327 /*** NUMBERS -> STRINGS ***/
5328 #define SCM_MAX_DBL_RADIX 36
5330 /* use this array as a way to generate a single digit */
5331 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5333 static mpz_t dbl_minimum_normal_mantissa
;
5336 idbl2str (double dbl
, char *a
, int radix
)
5340 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5341 /* revert to existing behavior */
5346 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5356 else if (dbl
== 0.0)
5358 if (copysign (1.0, dbl
) < 0.0)
5360 strcpy (a
+ ch
, "0.0");
5363 else if (isnan (dbl
))
5365 strcpy (a
, "+nan.0");
5369 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5370 Accurately" by Robert G. Burger and R. Kent Dybvig */
5373 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5374 int f_is_even
, f_is_odd
;
5378 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5379 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5380 if (e
< DBL_MIN_EXP
)
5382 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5387 f_is_even
= !mpz_odd_p (f
);
5388 f_is_odd
= !f_is_even
;
5390 /* Initialize r, s, mplus, and mminus according
5391 to Table 1 from the paper. */
5394 mpz_set_ui (mminus
, 1);
5395 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5396 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5398 mpz_set_ui (mplus
, 1);
5399 mpz_mul_2exp (r
, f
, 1);
5400 mpz_mul_2exp (s
, mminus
, 1 - e
);
5404 mpz_set_ui (mplus
, 2);
5405 mpz_mul_2exp (r
, f
, 2);
5406 mpz_mul_2exp (s
, mminus
, 2 - e
);
5411 mpz_set_ui (mminus
, 1);
5412 mpz_mul_2exp (mminus
, mminus
, e
);
5413 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5415 mpz_set (mplus
, mminus
);
5416 mpz_mul_2exp (r
, f
, 1 + e
);
5421 mpz_mul_2exp (mplus
, mminus
, 1);
5422 mpz_mul_2exp (r
, f
, 2 + e
);
5427 /* Find the smallest k such that:
5428 (r + mplus) / s < radix^k (if f is even)
5429 (r + mplus) / s <= radix^k (if f is odd) */
5431 /* IMPROVE-ME: Make an initial guess to speed this up */
5432 mpz_add (hi
, r
, mplus
);
5434 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5436 mpz_mul_ui (s
, s
, radix
);
5441 mpz_mul_ui (hi
, hi
, radix
);
5442 while (mpz_cmp (hi
, s
) < f_is_odd
)
5444 mpz_mul_ui (r
, r
, radix
);
5445 mpz_mul_ui (mplus
, mplus
, radix
);
5446 mpz_mul_ui (mminus
, mminus
, radix
);
5447 mpz_mul_ui (hi
, hi
, radix
);
5458 /* Use scientific notation */
5466 /* Print leading zeroes */
5469 for (i
= 0; i
> k
; i
--)
5476 int end_1_p
, end_2_p
;
5479 mpz_mul_ui (mplus
, mplus
, radix
);
5480 mpz_mul_ui (mminus
, mminus
, radix
);
5481 mpz_mul_ui (r
, r
, radix
);
5482 mpz_fdiv_qr (digit
, r
, r
, s
);
5483 d
= mpz_get_ui (digit
);
5485 mpz_add (hi
, r
, mplus
);
5486 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5487 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5488 if (end_1_p
|| end_2_p
)
5490 mpz_mul_2exp (r
, r
, 1);
5495 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5497 a
[ch
++] = number_chars
[d
];
5504 a
[ch
++] = number_chars
[d
];
5512 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5514 /* Here we would have to print more than three zeroes
5515 followed by a decimal point and another zero. It
5516 makes more sense to use scientific notation. */
5518 /* Adjust k to what it would have been if we had chosen
5519 scientific notation from the beginning. */
5522 /* k will now be <= 0, with magnitude equal to the number of
5523 digits that we printed which should now be put after the
5526 /* Insert a decimal point */
5527 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5547 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5550 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5557 icmplx2str (double real
, double imag
, char *str
, int radix
)
5562 i
= idbl2str (real
, str
, radix
);
5563 #ifdef HAVE_COPYSIGN
5564 sgn
= copysign (1.0, imag
);
5568 /* Don't output a '+' for negative numbers or for Inf and
5569 NaN. They will provide their own sign. */
5570 if (sgn
>= 0 && isfinite (imag
))
5572 i
+= idbl2str (imag
, &str
[i
], radix
);
5578 iflo2str (SCM flt
, char *str
, int radix
)
5581 if (SCM_REALP (flt
))
5582 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5584 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5589 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5590 characters in the result.
5592 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5594 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5599 return scm_iuint2str (-num
, rad
, p
) + 1;
5602 return scm_iuint2str (num
, rad
, p
);
5605 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5606 characters in the result.
5608 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5610 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5614 scm_t_uintmax n
= num
;
5616 if (rad
< 2 || rad
> 36)
5617 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5619 for (n
/= rad
; n
> 0; n
/= rad
)
5629 p
[i
] = number_chars
[d
];
5634 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5636 "Return a string holding the external representation of the\n"
5637 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5638 "inexact, a radix of 10 will be used.")
5639 #define FUNC_NAME s_scm_number_to_string
5643 if (SCM_UNBNDP (radix
))
5646 base
= scm_to_signed_integer (radix
, 2, 36);
5648 if (SCM_I_INUMP (n
))
5650 char num_buf
[SCM_INTBUFLEN
];
5651 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5652 return scm_from_locale_stringn (num_buf
, length
);
5654 else if (SCM_BIGP (n
))
5656 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5657 size_t len
= strlen (str
);
5658 void (*freefunc
) (void *, size_t);
5660 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5661 scm_remember_upto_here_1 (n
);
5662 ret
= scm_from_latin1_stringn (str
, len
);
5663 freefunc (str
, len
+ 1);
5666 else if (SCM_FRACTIONP (n
))
5668 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5669 scm_from_locale_string ("/"),
5670 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5672 else if (SCM_INEXACTP (n
))
5674 char num_buf
[FLOBUFLEN
];
5675 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5678 SCM_WRONG_TYPE_ARG (1, n
);
5683 /* These print routines used to be stubbed here so that scm_repl.c
5684 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5687 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5689 char num_buf
[FLOBUFLEN
];
5690 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5695 scm_i_print_double (double val
, SCM port
)
5697 char num_buf
[FLOBUFLEN
];
5698 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5702 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5705 char num_buf
[FLOBUFLEN
];
5706 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5711 scm_i_print_complex (double real
, double imag
, SCM port
)
5713 char num_buf
[FLOBUFLEN
];
5714 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5718 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5721 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5722 scm_display (str
, port
);
5723 scm_remember_upto_here_1 (str
);
5728 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5730 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5731 size_t len
= strlen (str
);
5732 void (*freefunc
) (void *, size_t);
5733 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5734 scm_remember_upto_here_1 (exp
);
5735 scm_lfwrite (str
, len
, port
);
5736 freefunc (str
, len
+ 1);
5739 /*** END nums->strs ***/
5742 /*** STRINGS -> NUMBERS ***/
5744 /* The following functions implement the conversion from strings to numbers.
5745 * The implementation somehow follows the grammar for numbers as it is given
5746 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5747 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5748 * points should be noted about the implementation:
5750 * * Each function keeps a local index variable 'idx' that points at the
5751 * current position within the parsed string. The global index is only
5752 * updated if the function could parse the corresponding syntactic unit
5755 * * Similarly, the functions keep track of indicators of inexactness ('#',
5756 * '.' or exponents) using local variables ('hash_seen', 'x').
5758 * * Sequences of digits are parsed into temporary variables holding fixnums.
5759 * Only if these fixnums would overflow, the result variables are updated
5760 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5761 * the temporary variables holding the fixnums are cleared, and the process
5762 * starts over again. If for example fixnums were able to store five decimal
5763 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5764 * and the result was computed as 12345 * 100000 + 67890. In other words,
5765 * only every five digits two bignum operations were performed.
5767 * Notes on the handling of exactness specifiers:
5769 * When parsing non-real complex numbers, we apply exactness specifiers on
5770 * per-component basis, as is done in PLT Scheme. For complex numbers
5771 * written in rectangular form, exactness specifiers are applied to the
5772 * real and imaginary parts before calling scm_make_rectangular. For
5773 * complex numbers written in polar form, exactness specifiers are applied
5774 * to the magnitude and angle before calling scm_make_polar.
5776 * There are two kinds of exactness specifiers: forced and implicit. A
5777 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5778 * the entire number, and applies to both components of a complex number.
5779 * "#e" causes each component to be made exact, and "#i" causes each
5780 * component to be made inexact. If no forced exactness specifier is
5781 * present, then the exactness of each component is determined
5782 * independently by the presence or absence of a decimal point or hash mark
5783 * within that component. If a decimal point or hash mark is present, the
5784 * component is made inexact, otherwise it is made exact.
5786 * After the exactness specifiers have been applied to each component, they
5787 * are passed to either scm_make_rectangular or scm_make_polar to produce
5788 * the final result. Note that this will result in a real number if the
5789 * imaginary part, magnitude, or angle is an exact 0.
5791 * For example, (string->number "#i5.0+0i") does the equivalent of:
5793 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5796 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5798 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5800 /* Caller is responsible for checking that the return value is in range
5801 for the given radix, which should be <= 36. */
5803 char_decimal_value (scm_t_uint32 c
)
5805 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5806 that's certainly above any valid decimal, so we take advantage of
5807 that to elide some tests. */
5808 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5810 /* If that failed, try extended hexadecimals, then. Only accept ascii
5815 if (c
>= (scm_t_uint32
) 'a')
5816 d
= c
- (scm_t_uint32
)'a' + 10U;
5821 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5822 in base RADIX. Upon success, return the unsigned integer and update
5823 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5825 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5826 unsigned int radix
, enum t_exactness
*p_exactness
)
5828 unsigned int idx
= *p_idx
;
5829 unsigned int hash_seen
= 0;
5830 scm_t_bits shift
= 1;
5832 unsigned int digit_value
;
5835 size_t len
= scm_i_string_length (mem
);
5840 c
= scm_i_string_ref (mem
, idx
);
5841 digit_value
= char_decimal_value (c
);
5842 if (digit_value
>= radix
)
5846 result
= SCM_I_MAKINUM (digit_value
);
5849 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5859 digit_value
= char_decimal_value (c
);
5860 /* This check catches non-decimals in addition to out-of-range
5862 if (digit_value
>= radix
)
5867 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5869 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5871 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5878 shift
= shift
* radix
;
5879 add
= add
* radix
+ digit_value
;
5884 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5886 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5890 *p_exactness
= INEXACT
;
5896 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5897 * covers the parts of the rules that start at a potential point. The value
5898 * of the digits up to the point have been parsed by the caller and are given
5899 * in variable result. The content of *p_exactness indicates, whether a hash
5900 * has already been seen in the digits before the point.
5903 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5906 mem2decimal_from_point (SCM result
, SCM mem
,
5907 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5909 unsigned int idx
= *p_idx
;
5910 enum t_exactness x
= *p_exactness
;
5911 size_t len
= scm_i_string_length (mem
);
5916 if (scm_i_string_ref (mem
, idx
) == '.')
5918 scm_t_bits shift
= 1;
5920 unsigned int digit_value
;
5921 SCM big_shift
= SCM_INUM1
;
5926 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5927 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5932 digit_value
= DIGIT2UINT (c
);
5943 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5945 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5946 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5948 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5956 add
= add
* 10 + digit_value
;
5962 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5963 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5964 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5967 result
= scm_divide (result
, big_shift
);
5969 /* We've seen a decimal point, thus the value is implicitly inexact. */
5981 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5983 switch (scm_i_string_ref (mem
, idx
))
5995 c
= scm_i_string_ref (mem
, idx
);
6003 c
= scm_i_string_ref (mem
, idx
);
6012 c
= scm_i_string_ref (mem
, idx
);
6017 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6021 exponent
= DIGIT2UINT (c
);
6024 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6025 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6028 if (exponent
<= SCM_MAXEXP
)
6029 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6035 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6037 size_t exp_len
= idx
- start
;
6038 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6039 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6040 scm_out_of_range ("string->number", exp_num
);
6043 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6045 result
= scm_product (result
, e
);
6047 result
= scm_divide (result
, e
);
6049 /* We've seen an exponent, thus the value is implicitly inexact. */
6067 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6070 mem2ureal (SCM mem
, unsigned int *p_idx
,
6071 unsigned int radix
, enum t_exactness forced_x
,
6072 int allow_inf_or_nan
)
6074 unsigned int idx
= *p_idx
;
6076 size_t len
= scm_i_string_length (mem
);
6078 /* Start off believing that the number will be exact. This changes
6079 to INEXACT if we see a decimal point or a hash. */
6080 enum t_exactness implicit_x
= EXACT
;
6085 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6086 switch (scm_i_string_ref (mem
, idx
))
6089 switch (scm_i_string_ref (mem
, idx
+ 1))
6092 switch (scm_i_string_ref (mem
, idx
+ 2))
6095 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6096 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6104 switch (scm_i_string_ref (mem
, idx
+ 1))
6107 switch (scm_i_string_ref (mem
, idx
+ 2))
6110 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6112 /* Cobble up the fractional part. We might want to
6113 set the NaN's mantissa from it. */
6115 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6118 #if SCM_ENABLE_DEPRECATED == 1
6119 scm_c_issue_deprecation_warning
6120 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6133 if (scm_i_string_ref (mem
, idx
) == '.')
6137 else if (idx
+ 1 == len
)
6139 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6142 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6143 p_idx
, &implicit_x
);
6149 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6150 if (scm_is_false (uinteger
))
6155 else if (scm_i_string_ref (mem
, idx
) == '/')
6163 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6164 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6167 /* both are int/big here, I assume */
6168 result
= scm_i_make_ratio (uinteger
, divisor
);
6170 else if (radix
== 10)
6172 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6173 if (scm_is_false (result
))
6185 if (SCM_INEXACTP (result
))
6186 return scm_inexact_to_exact (result
);
6190 if (SCM_INEXACTP (result
))
6193 return scm_exact_to_inexact (result
);
6195 if (implicit_x
== INEXACT
)
6197 if (SCM_INEXACTP (result
))
6200 return scm_exact_to_inexact (result
);
6206 /* We should never get here */
6211 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6214 mem2complex (SCM mem
, unsigned int idx
,
6215 unsigned int radix
, enum t_exactness forced_x
)
6220 size_t len
= scm_i_string_length (mem
);
6225 c
= scm_i_string_ref (mem
, idx
);
6240 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6241 if (scm_is_false (ureal
))
6243 /* input must be either +i or -i */
6248 if (scm_i_string_ref (mem
, idx
) == 'i'
6249 || scm_i_string_ref (mem
, idx
) == 'I')
6255 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6262 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6263 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6268 c
= scm_i_string_ref (mem
, idx
);
6272 /* either +<ureal>i or -<ureal>i */
6279 return scm_make_rectangular (SCM_INUM0
, ureal
);
6282 /* polar input: <real>@<real>. */
6293 c
= scm_i_string_ref (mem
, idx
);
6311 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6312 if (scm_is_false (angle
))
6317 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6318 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6320 result
= scm_make_polar (ureal
, angle
);
6325 /* expecting input matching <real>[+-]<ureal>?i */
6332 int sign
= (c
== '+') ? 1 : -1;
6333 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6335 if (scm_is_false (imag
))
6336 imag
= SCM_I_MAKINUM (sign
);
6337 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6338 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6342 if (scm_i_string_ref (mem
, idx
) != 'i'
6343 && scm_i_string_ref (mem
, idx
) != 'I')
6350 return scm_make_rectangular (ureal
, imag
);
6359 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6361 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6364 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6366 unsigned int idx
= 0;
6367 unsigned int radix
= NO_RADIX
;
6368 enum t_exactness forced_x
= NO_EXACTNESS
;
6369 size_t len
= scm_i_string_length (mem
);
6371 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6372 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6374 switch (scm_i_string_ref (mem
, idx
+ 1))
6377 if (radix
!= NO_RADIX
)
6382 if (radix
!= NO_RADIX
)
6387 if (forced_x
!= NO_EXACTNESS
)
6392 if (forced_x
!= NO_EXACTNESS
)
6397 if (radix
!= NO_RADIX
)
6402 if (radix
!= NO_RADIX
)
6412 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6413 if (radix
== NO_RADIX
)
6414 radix
= default_radix
;
6416 return mem2complex (mem
, idx
, radix
, forced_x
);
6420 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6421 unsigned int default_radix
)
6423 SCM str
= scm_from_locale_stringn (mem
, len
);
6425 return scm_i_string_to_number (str
, default_radix
);
6429 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6430 (SCM string
, SCM radix
),
6431 "Return a number of the maximally precise representation\n"
6432 "expressed by the given @var{string}. @var{radix} must be an\n"
6433 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6434 "is a default radix that may be overridden by an explicit radix\n"
6435 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6436 "supplied, then the default radix is 10. If string is not a\n"
6437 "syntactically valid notation for a number, then\n"
6438 "@code{string->number} returns @code{#f}.")
6439 #define FUNC_NAME s_scm_string_to_number
6443 SCM_VALIDATE_STRING (1, string
);
6445 if (SCM_UNBNDP (radix
))
6448 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6450 answer
= scm_i_string_to_number (string
, base
);
6451 scm_remember_upto_here_1 (string
);
6457 /*** END strs->nums ***/
6460 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6462 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6464 #define FUNC_NAME s_scm_number_p
6466 return scm_from_bool (SCM_NUMBERP (x
));
6470 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6472 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6473 "otherwise. Note that the sets of real, rational and integer\n"
6474 "values form subsets of the set of complex numbers, i. e. the\n"
6475 "predicate will also be fulfilled if @var{x} is a real,\n"
6476 "rational or integer number.")
6477 #define FUNC_NAME s_scm_complex_p
6479 /* all numbers are complex. */
6480 return scm_number_p (x
);
6484 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6486 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6487 "otherwise. Note that the set of integer values forms a subset of\n"
6488 "the set of real numbers, i. e. the predicate will also be\n"
6489 "fulfilled if @var{x} is an integer number.")
6490 #define FUNC_NAME s_scm_real_p
6492 return scm_from_bool
6493 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6497 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6499 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6500 "otherwise. Note that the set of integer values forms a subset of\n"
6501 "the set of rational numbers, i. e. the predicate will also be\n"
6502 "fulfilled if @var{x} is an integer number.")
6503 #define FUNC_NAME s_scm_rational_p
6505 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6507 else if (SCM_REALP (x
))
6508 /* due to their limited precision, finite floating point numbers are
6509 rational as well. (finite means neither infinity nor a NaN) */
6510 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6516 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6518 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6520 #define FUNC_NAME s_scm_integer_p
6522 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6524 else if (SCM_REALP (x
))
6526 double val
= SCM_REAL_VALUE (x
);
6527 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6535 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6536 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6537 (SCM x
, SCM y
, SCM rest
),
6538 "Return @code{#t} if all parameters are numerically equal.")
6539 #define FUNC_NAME s_scm_i_num_eq_p
6541 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6543 while (!scm_is_null (rest
))
6545 if (scm_is_false (scm_num_eq_p (x
, y
)))
6549 rest
= scm_cdr (rest
);
6551 return scm_num_eq_p (x
, y
);
6555 scm_num_eq_p (SCM x
, SCM y
)
6558 if (SCM_I_INUMP (x
))
6560 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6561 if (SCM_I_INUMP (y
))
6563 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6564 return scm_from_bool (xx
== yy
);
6566 else if (SCM_BIGP (y
))
6568 else if (SCM_REALP (y
))
6570 /* On a 32-bit system an inum fits a double, we can cast the inum
6571 to a double and compare.
6573 But on a 64-bit system an inum is bigger than a double and
6574 casting it to a double (call that dxx) will round.
6575 Although dxx will not in general be equal to xx, dxx will
6576 always be an integer and within a factor of 2 of xx, so if
6577 dxx==yy, we know that yy is an integer and fits in
6578 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6579 compare with plain xx.
6581 An alternative (for any size system actually) would be to check
6582 yy is an integer (with floor) and is in range of an inum
6583 (compare against appropriate powers of 2) then test
6584 xx==(scm_t_signed_bits)yy. It's just a matter of which
6585 casts/comparisons might be fastest or easiest for the cpu. */
6587 double yy
= SCM_REAL_VALUE (y
);
6588 return scm_from_bool ((double) xx
== yy
6589 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6590 || xx
== (scm_t_signed_bits
) yy
));
6592 else if (SCM_COMPLEXP (y
))
6594 /* see comments with inum/real above */
6595 double ry
= SCM_COMPLEX_REAL (y
);
6596 return scm_from_bool ((double) xx
== ry
6597 && 0.0 == SCM_COMPLEX_IMAG (y
)
6598 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6599 || xx
== (scm_t_signed_bits
) ry
));
6601 else if (SCM_FRACTIONP (y
))
6604 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6606 else if (SCM_BIGP (x
))
6608 if (SCM_I_INUMP (y
))
6610 else if (SCM_BIGP (y
))
6612 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6613 scm_remember_upto_here_2 (x
, y
);
6614 return scm_from_bool (0 == cmp
);
6616 else if (SCM_REALP (y
))
6619 if (isnan (SCM_REAL_VALUE (y
)))
6621 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6622 scm_remember_upto_here_1 (x
);
6623 return scm_from_bool (0 == cmp
);
6625 else if (SCM_COMPLEXP (y
))
6628 if (0.0 != SCM_COMPLEX_IMAG (y
))
6630 if (isnan (SCM_COMPLEX_REAL (y
)))
6632 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6633 scm_remember_upto_here_1 (x
);
6634 return scm_from_bool (0 == cmp
);
6636 else if (SCM_FRACTIONP (y
))
6639 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6641 else if (SCM_REALP (x
))
6643 double xx
= SCM_REAL_VALUE (x
);
6644 if (SCM_I_INUMP (y
))
6646 /* see comments with inum/real above */
6647 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6648 return scm_from_bool (xx
== (double) yy
6649 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6650 || (scm_t_signed_bits
) xx
== yy
));
6652 else if (SCM_BIGP (y
))
6657 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6658 scm_remember_upto_here_1 (y
);
6659 return scm_from_bool (0 == cmp
);
6661 else if (SCM_REALP (y
))
6662 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6663 else if (SCM_COMPLEXP (y
))
6664 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6665 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6666 else if (SCM_FRACTIONP (y
))
6668 if (isnan (xx
) || isinf (xx
))
6670 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6674 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6676 else if (SCM_COMPLEXP (x
))
6678 if (SCM_I_INUMP (y
))
6680 /* see comments with inum/real above */
6681 double rx
= SCM_COMPLEX_REAL (x
);
6682 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6683 return scm_from_bool (rx
== (double) yy
6684 && 0.0 == SCM_COMPLEX_IMAG (x
)
6685 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6686 || (scm_t_signed_bits
) rx
== yy
));
6688 else if (SCM_BIGP (y
))
6691 if (0.0 != SCM_COMPLEX_IMAG (x
))
6693 if (isnan (SCM_COMPLEX_REAL (x
)))
6695 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6696 scm_remember_upto_here_1 (y
);
6697 return scm_from_bool (0 == cmp
);
6699 else if (SCM_REALP (y
))
6700 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6701 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6702 else if (SCM_COMPLEXP (y
))
6703 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6704 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6705 else if (SCM_FRACTIONP (y
))
6708 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6710 xx
= SCM_COMPLEX_REAL (x
);
6711 if (isnan (xx
) || isinf (xx
))
6713 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6717 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6719 else if (SCM_FRACTIONP (x
))
6721 if (SCM_I_INUMP (y
))
6723 else if (SCM_BIGP (y
))
6725 else if (SCM_REALP (y
))
6727 double yy
= SCM_REAL_VALUE (y
);
6728 if (isnan (yy
) || isinf (yy
))
6730 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6733 else if (SCM_COMPLEXP (y
))
6736 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6738 yy
= SCM_COMPLEX_REAL (y
);
6739 if (isnan (yy
) || isinf(yy
))
6741 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6744 else if (SCM_FRACTIONP (y
))
6745 return scm_i_fraction_equalp (x
, y
);
6747 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6750 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6754 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6755 done are good for inums, but for bignums an answer can almost always be
6756 had by just examining a few high bits of the operands, as done by GMP in
6757 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6758 of the float exponent to take into account. */
6760 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6761 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6762 (SCM x
, SCM y
, SCM rest
),
6763 "Return @code{#t} if the list of parameters is monotonically\n"
6765 #define FUNC_NAME s_scm_i_num_less_p
6767 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6769 while (!scm_is_null (rest
))
6771 if (scm_is_false (scm_less_p (x
, y
)))
6775 rest
= scm_cdr (rest
);
6777 return scm_less_p (x
, y
);
6781 scm_less_p (SCM x
, SCM y
)
6784 if (SCM_I_INUMP (x
))
6786 scm_t_inum xx
= SCM_I_INUM (x
);
6787 if (SCM_I_INUMP (y
))
6789 scm_t_inum yy
= SCM_I_INUM (y
);
6790 return scm_from_bool (xx
< yy
);
6792 else if (SCM_BIGP (y
))
6794 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6795 scm_remember_upto_here_1 (y
);
6796 return scm_from_bool (sgn
> 0);
6798 else if (SCM_REALP (y
))
6800 /* We can safely take the ceiling of y without changing the
6801 result of x<y, given that x is an integer. */
6802 double yy
= ceil (SCM_REAL_VALUE (y
));
6804 /* In the following comparisons, it's important that the right
6805 hand side always be a power of 2, so that it can be
6806 losslessly converted to a double even on 64-bit
6808 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6810 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6811 /* The condition above is carefully written to include the
6812 case where yy==NaN. */
6815 /* yy is a finite integer that fits in an inum. */
6816 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6818 else if (SCM_FRACTIONP (y
))
6820 /* "x < a/b" becomes "x*b < a" */
6822 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6823 y
= SCM_FRACTION_NUMERATOR (y
);
6827 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6829 else if (SCM_BIGP (x
))
6831 if (SCM_I_INUMP (y
))
6833 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6834 scm_remember_upto_here_1 (x
);
6835 return scm_from_bool (sgn
< 0);
6837 else if (SCM_BIGP (y
))
6839 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6840 scm_remember_upto_here_2 (x
, y
);
6841 return scm_from_bool (cmp
< 0);
6843 else if (SCM_REALP (y
))
6846 if (isnan (SCM_REAL_VALUE (y
)))
6848 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6849 scm_remember_upto_here_1 (x
);
6850 return scm_from_bool (cmp
< 0);
6852 else if (SCM_FRACTIONP (y
))
6855 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6857 else if (SCM_REALP (x
))
6859 if (SCM_I_INUMP (y
))
6861 /* We can safely take the floor of x without changing the
6862 result of x<y, given that y is an integer. */
6863 double xx
= floor (SCM_REAL_VALUE (x
));
6865 /* In the following comparisons, it's important that the right
6866 hand side always be a power of 2, so that it can be
6867 losslessly converted to a double even on 64-bit
6869 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6871 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6872 /* The condition above is carefully written to include the
6873 case where xx==NaN. */
6876 /* xx is a finite integer that fits in an inum. */
6877 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6879 else if (SCM_BIGP (y
))
6882 if (isnan (SCM_REAL_VALUE (x
)))
6884 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6885 scm_remember_upto_here_1 (y
);
6886 return scm_from_bool (cmp
> 0);
6888 else if (SCM_REALP (y
))
6889 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6890 else if (SCM_FRACTIONP (y
))
6892 double xx
= SCM_REAL_VALUE (x
);
6896 return scm_from_bool (xx
< 0.0);
6897 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6901 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6903 else if (SCM_FRACTIONP (x
))
6905 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6907 /* "a/b < y" becomes "a < y*b" */
6908 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6909 x
= SCM_FRACTION_NUMERATOR (x
);
6912 else if (SCM_REALP (y
))
6914 double yy
= SCM_REAL_VALUE (y
);
6918 return scm_from_bool (0.0 < yy
);
6919 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6922 else if (SCM_FRACTIONP (y
))
6924 /* "a/b < c/d" becomes "a*d < c*b" */
6925 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6926 SCM_FRACTION_DENOMINATOR (y
));
6927 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6928 SCM_FRACTION_DENOMINATOR (x
));
6934 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6937 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6941 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6942 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6943 (SCM x
, SCM y
, SCM rest
),
6944 "Return @code{#t} if the list of parameters is monotonically\n"
6946 #define FUNC_NAME s_scm_i_num_gr_p
6948 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6950 while (!scm_is_null (rest
))
6952 if (scm_is_false (scm_gr_p (x
, y
)))
6956 rest
= scm_cdr (rest
);
6958 return scm_gr_p (x
, y
);
6961 #define FUNC_NAME s_scm_i_num_gr_p
6963 scm_gr_p (SCM x
, SCM y
)
6965 if (!SCM_NUMBERP (x
))
6966 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6967 else if (!SCM_NUMBERP (y
))
6968 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6970 return scm_less_p (y
, x
);
6975 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6976 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6977 (SCM x
, SCM y
, SCM rest
),
6978 "Return @code{#t} if the list of parameters is monotonically\n"
6980 #define FUNC_NAME s_scm_i_num_leq_p
6982 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6984 while (!scm_is_null (rest
))
6986 if (scm_is_false (scm_leq_p (x
, y
)))
6990 rest
= scm_cdr (rest
);
6992 return scm_leq_p (x
, y
);
6995 #define FUNC_NAME s_scm_i_num_leq_p
6997 scm_leq_p (SCM x
, SCM y
)
6999 if (!SCM_NUMBERP (x
))
7000 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7001 else if (!SCM_NUMBERP (y
))
7002 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7003 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7006 return scm_not (scm_less_p (y
, x
));
7011 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7012 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7013 (SCM x
, SCM y
, SCM rest
),
7014 "Return @code{#t} if the list of parameters is monotonically\n"
7016 #define FUNC_NAME s_scm_i_num_geq_p
7018 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7020 while (!scm_is_null (rest
))
7022 if (scm_is_false (scm_geq_p (x
, y
)))
7026 rest
= scm_cdr (rest
);
7028 return scm_geq_p (x
, y
);
7031 #define FUNC_NAME s_scm_i_num_geq_p
7033 scm_geq_p (SCM x
, SCM y
)
7035 if (!SCM_NUMBERP (x
))
7036 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7037 else if (!SCM_NUMBERP (y
))
7038 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7039 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7042 return scm_not (scm_less_p (x
, y
));
7047 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7049 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7051 #define FUNC_NAME s_scm_zero_p
7053 if (SCM_I_INUMP (z
))
7054 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7055 else if (SCM_BIGP (z
))
7057 else if (SCM_REALP (z
))
7058 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7059 else if (SCM_COMPLEXP (z
))
7060 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7061 && SCM_COMPLEX_IMAG (z
) == 0.0);
7062 else if (SCM_FRACTIONP (z
))
7065 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7070 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7072 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7074 #define FUNC_NAME s_scm_positive_p
7076 if (SCM_I_INUMP (x
))
7077 return scm_from_bool (SCM_I_INUM (x
) > 0);
7078 else if (SCM_BIGP (x
))
7080 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7081 scm_remember_upto_here_1 (x
);
7082 return scm_from_bool (sgn
> 0);
7084 else if (SCM_REALP (x
))
7085 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7086 else if (SCM_FRACTIONP (x
))
7087 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7089 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7094 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7096 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7098 #define FUNC_NAME s_scm_negative_p
7100 if (SCM_I_INUMP (x
))
7101 return scm_from_bool (SCM_I_INUM (x
) < 0);
7102 else if (SCM_BIGP (x
))
7104 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7105 scm_remember_upto_here_1 (x
);
7106 return scm_from_bool (sgn
< 0);
7108 else if (SCM_REALP (x
))
7109 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7110 else if (SCM_FRACTIONP (x
))
7111 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7113 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7118 /* scm_min and scm_max return an inexact when either argument is inexact, as
7119 required by r5rs. On that basis, for exact/inexact combinations the
7120 exact is converted to inexact to compare and possibly return. This is
7121 unlike scm_less_p above which takes some trouble to preserve all bits in
7122 its test, such trouble is not required for min and max. */
7124 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7125 (SCM x
, SCM y
, SCM rest
),
7126 "Return the maximum of all parameter values.")
7127 #define FUNC_NAME s_scm_i_max
7129 while (!scm_is_null (rest
))
7130 { x
= scm_max (x
, y
);
7132 rest
= scm_cdr (rest
);
7134 return scm_max (x
, y
);
7138 #define s_max s_scm_i_max
7139 #define g_max g_scm_i_max
7142 scm_max (SCM x
, SCM y
)
7147 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7148 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7151 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7154 if (SCM_I_INUMP (x
))
7156 scm_t_inum xx
= SCM_I_INUM (x
);
7157 if (SCM_I_INUMP (y
))
7159 scm_t_inum yy
= SCM_I_INUM (y
);
7160 return (xx
< yy
) ? y
: x
;
7162 else if (SCM_BIGP (y
))
7164 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7165 scm_remember_upto_here_1 (y
);
7166 return (sgn
< 0) ? x
: y
;
7168 else if (SCM_REALP (y
))
7171 double yyd
= SCM_REAL_VALUE (y
);
7174 return scm_i_from_double (xxd
);
7175 /* If y is a NaN, then "==" is false and we return the NaN */
7176 else if (SCM_LIKELY (!(xxd
== yyd
)))
7178 /* Handle signed zeroes properly */
7184 else if (SCM_FRACTIONP (y
))
7187 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7190 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7192 else if (SCM_BIGP (x
))
7194 if (SCM_I_INUMP (y
))
7196 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7197 scm_remember_upto_here_1 (x
);
7198 return (sgn
< 0) ? y
: x
;
7200 else if (SCM_BIGP (y
))
7202 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7203 scm_remember_upto_here_2 (x
, y
);
7204 return (cmp
> 0) ? x
: y
;
7206 else if (SCM_REALP (y
))
7208 /* if y==NaN then xx>yy is false, so we return the NaN y */
7211 xx
= scm_i_big2dbl (x
);
7212 yy
= SCM_REAL_VALUE (y
);
7213 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7215 else if (SCM_FRACTIONP (y
))
7220 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7222 else if (SCM_REALP (x
))
7224 if (SCM_I_INUMP (y
))
7226 scm_t_inum yy
= SCM_I_INUM (y
);
7227 double xxd
= SCM_REAL_VALUE (x
);
7231 return scm_i_from_double (yyd
);
7232 /* If x is a NaN, then "==" is false and we return the NaN */
7233 else if (SCM_LIKELY (!(xxd
== yyd
)))
7235 /* Handle signed zeroes properly */
7241 else if (SCM_BIGP (y
))
7246 else if (SCM_REALP (y
))
7248 double xx
= SCM_REAL_VALUE (x
);
7249 double yy
= SCM_REAL_VALUE (y
);
7251 /* For purposes of max: nan > +inf.0 > everything else,
7252 per the R6RS errata */
7255 else if (SCM_LIKELY (xx
< yy
))
7257 /* If neither (xx > yy) nor (xx < yy), then
7258 either they're equal or one is a NaN */
7259 else if (SCM_UNLIKELY (xx
!= yy
))
7260 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7261 /* xx == yy, but handle signed zeroes properly */
7262 else if (copysign (1.0, yy
) < 0.0)
7267 else if (SCM_FRACTIONP (y
))
7269 double yy
= scm_i_fraction2double (y
);
7270 double xx
= SCM_REAL_VALUE (x
);
7271 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7274 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7276 else if (SCM_FRACTIONP (x
))
7278 if (SCM_I_INUMP (y
))
7282 else if (SCM_BIGP (y
))
7286 else if (SCM_REALP (y
))
7288 double xx
= scm_i_fraction2double (x
);
7289 /* if y==NaN then ">" is false, so we return the NaN y */
7290 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7292 else if (SCM_FRACTIONP (y
))
7297 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7300 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7304 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7305 (SCM x
, SCM y
, SCM rest
),
7306 "Return the minimum of all parameter values.")
7307 #define FUNC_NAME s_scm_i_min
7309 while (!scm_is_null (rest
))
7310 { x
= scm_min (x
, y
);
7312 rest
= scm_cdr (rest
);
7314 return scm_min (x
, y
);
7318 #define s_min s_scm_i_min
7319 #define g_min g_scm_i_min
7322 scm_min (SCM x
, SCM y
)
7327 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7328 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7331 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7334 if (SCM_I_INUMP (x
))
7336 scm_t_inum xx
= SCM_I_INUM (x
);
7337 if (SCM_I_INUMP (y
))
7339 scm_t_inum yy
= SCM_I_INUM (y
);
7340 return (xx
< yy
) ? x
: y
;
7342 else if (SCM_BIGP (y
))
7344 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7345 scm_remember_upto_here_1 (y
);
7346 return (sgn
< 0) ? y
: x
;
7348 else if (SCM_REALP (y
))
7351 /* if y==NaN then "<" is false and we return NaN */
7352 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7354 else if (SCM_FRACTIONP (y
))
7357 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7360 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7362 else if (SCM_BIGP (x
))
7364 if (SCM_I_INUMP (y
))
7366 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7367 scm_remember_upto_here_1 (x
);
7368 return (sgn
< 0) ? x
: y
;
7370 else if (SCM_BIGP (y
))
7372 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7373 scm_remember_upto_here_2 (x
, y
);
7374 return (cmp
> 0) ? y
: x
;
7376 else if (SCM_REALP (y
))
7378 /* if y==NaN then xx<yy is false, so we return the NaN y */
7381 xx
= scm_i_big2dbl (x
);
7382 yy
= SCM_REAL_VALUE (y
);
7383 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7385 else if (SCM_FRACTIONP (y
))
7390 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7392 else if (SCM_REALP (x
))
7394 if (SCM_I_INUMP (y
))
7396 double z
= SCM_I_INUM (y
);
7397 /* if x==NaN then "<" is false and we return NaN */
7398 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7400 else if (SCM_BIGP (y
))
7405 else if (SCM_REALP (y
))
7407 double xx
= SCM_REAL_VALUE (x
);
7408 double yy
= SCM_REAL_VALUE (y
);
7410 /* For purposes of min: nan < -inf.0 < everything else,
7411 per the R6RS errata */
7414 else if (SCM_LIKELY (xx
> yy
))
7416 /* If neither (xx < yy) nor (xx > yy), then
7417 either they're equal or one is a NaN */
7418 else if (SCM_UNLIKELY (xx
!= yy
))
7419 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7420 /* xx == yy, but handle signed zeroes properly */
7421 else if (copysign (1.0, xx
) < 0.0)
7426 else if (SCM_FRACTIONP (y
))
7428 double yy
= scm_i_fraction2double (y
);
7429 double xx
= SCM_REAL_VALUE (x
);
7430 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7433 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7435 else if (SCM_FRACTIONP (x
))
7437 if (SCM_I_INUMP (y
))
7441 else if (SCM_BIGP (y
))
7445 else if (SCM_REALP (y
))
7447 double xx
= scm_i_fraction2double (x
);
7448 /* if y==NaN then "<" is false, so we return the NaN y */
7449 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7451 else if (SCM_FRACTIONP (y
))
7456 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7459 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7463 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7464 (SCM x
, SCM y
, SCM rest
),
7465 "Return the sum of all parameter values. Return 0 if called without\n"
7467 #define FUNC_NAME s_scm_i_sum
7469 while (!scm_is_null (rest
))
7470 { x
= scm_sum (x
, y
);
7472 rest
= scm_cdr (rest
);
7474 return scm_sum (x
, y
);
7478 #define s_sum s_scm_i_sum
7479 #define g_sum g_scm_i_sum
7482 scm_sum (SCM x
, SCM y
)
7484 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7486 if (SCM_NUMBERP (x
)) return x
;
7487 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7488 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7491 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7493 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7495 scm_t_inum xx
= SCM_I_INUM (x
);
7496 scm_t_inum yy
= SCM_I_INUM (y
);
7497 scm_t_inum z
= xx
+ yy
;
7498 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7500 else if (SCM_BIGP (y
))
7505 else if (SCM_REALP (y
))
7507 scm_t_inum xx
= SCM_I_INUM (x
);
7508 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7510 else if (SCM_COMPLEXP (y
))
7512 scm_t_inum xx
= SCM_I_INUM (x
);
7513 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7514 SCM_COMPLEX_IMAG (y
));
7516 else if (SCM_FRACTIONP (y
))
7517 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7518 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7519 SCM_FRACTION_DENOMINATOR (y
));
7521 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7522 } else if (SCM_BIGP (x
))
7524 if (SCM_I_INUMP (y
))
7529 inum
= SCM_I_INUM (y
);
7532 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7535 SCM result
= scm_i_mkbig ();
7536 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7537 scm_remember_upto_here_1 (x
);
7538 /* we know the result will have to be a bignum */
7541 return scm_i_normbig (result
);
7545 SCM result
= scm_i_mkbig ();
7546 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7547 scm_remember_upto_here_1 (x
);
7548 /* we know the result will have to be a bignum */
7551 return scm_i_normbig (result
);
7554 else if (SCM_BIGP (y
))
7556 SCM result
= scm_i_mkbig ();
7557 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7558 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7559 mpz_add (SCM_I_BIG_MPZ (result
),
7562 scm_remember_upto_here_2 (x
, y
);
7563 /* we know the result will have to be a bignum */
7566 return scm_i_normbig (result
);
7568 else if (SCM_REALP (y
))
7570 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7571 scm_remember_upto_here_1 (x
);
7572 return scm_i_from_double (result
);
7574 else if (SCM_COMPLEXP (y
))
7576 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7577 + SCM_COMPLEX_REAL (y
));
7578 scm_remember_upto_here_1 (x
);
7579 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7581 else if (SCM_FRACTIONP (y
))
7582 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7583 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7584 SCM_FRACTION_DENOMINATOR (y
));
7586 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7588 else if (SCM_REALP (x
))
7590 if (SCM_I_INUMP (y
))
7591 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7592 else if (SCM_BIGP (y
))
7594 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7595 scm_remember_upto_here_1 (y
);
7596 return scm_i_from_double (result
);
7598 else if (SCM_REALP (y
))
7599 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7600 else if (SCM_COMPLEXP (y
))
7601 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7602 SCM_COMPLEX_IMAG (y
));
7603 else if (SCM_FRACTIONP (y
))
7604 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7606 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7608 else if (SCM_COMPLEXP (x
))
7610 if (SCM_I_INUMP (y
))
7611 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7612 SCM_COMPLEX_IMAG (x
));
7613 else if (SCM_BIGP (y
))
7615 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7616 + SCM_COMPLEX_REAL (x
));
7617 scm_remember_upto_here_1 (y
);
7618 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7620 else if (SCM_REALP (y
))
7621 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7622 SCM_COMPLEX_IMAG (x
));
7623 else if (SCM_COMPLEXP (y
))
7624 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7625 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7626 else if (SCM_FRACTIONP (y
))
7627 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7628 SCM_COMPLEX_IMAG (x
));
7630 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7632 else if (SCM_FRACTIONP (x
))
7634 if (SCM_I_INUMP (y
))
7635 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7636 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7637 SCM_FRACTION_DENOMINATOR (x
));
7638 else if (SCM_BIGP (y
))
7639 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7640 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7641 SCM_FRACTION_DENOMINATOR (x
));
7642 else if (SCM_REALP (y
))
7643 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7644 else if (SCM_COMPLEXP (y
))
7645 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7646 SCM_COMPLEX_IMAG (y
));
7647 else if (SCM_FRACTIONP (y
))
7648 /* a/b + c/d = (ad + bc) / bd */
7649 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7650 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7651 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7653 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7656 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7660 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7662 "Return @math{@var{x}+1}.")
7663 #define FUNC_NAME s_scm_oneplus
7665 return scm_sum (x
, SCM_INUM1
);
7670 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7671 (SCM x
, SCM y
, SCM rest
),
7672 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7673 "the sum of all but the first argument are subtracted from the first\n"
7675 #define FUNC_NAME s_scm_i_difference
7677 while (!scm_is_null (rest
))
7678 { x
= scm_difference (x
, y
);
7680 rest
= scm_cdr (rest
);
7682 return scm_difference (x
, y
);
7686 #define s_difference s_scm_i_difference
7687 #define g_difference g_scm_i_difference
7690 scm_difference (SCM x
, SCM y
)
7691 #define FUNC_NAME s_difference
7693 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7696 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7698 if (SCM_I_INUMP (x
))
7700 scm_t_inum xx
= -SCM_I_INUM (x
);
7701 if (SCM_FIXABLE (xx
))
7702 return SCM_I_MAKINUM (xx
);
7704 return scm_i_inum2big (xx
);
7706 else if (SCM_BIGP (x
))
7707 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7708 bignum, but negating that gives a fixnum. */
7709 return scm_i_normbig (scm_i_clonebig (x
, 0));
7710 else if (SCM_REALP (x
))
7711 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7712 else if (SCM_COMPLEXP (x
))
7713 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7714 -SCM_COMPLEX_IMAG (x
));
7715 else if (SCM_FRACTIONP (x
))
7716 return scm_i_make_ratio_already_reduced
7717 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7718 SCM_FRACTION_DENOMINATOR (x
));
7720 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7723 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7725 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7727 scm_t_inum xx
= SCM_I_INUM (x
);
7728 scm_t_inum yy
= SCM_I_INUM (y
);
7729 scm_t_inum z
= xx
- yy
;
7730 if (SCM_FIXABLE (z
))
7731 return SCM_I_MAKINUM (z
);
7733 return scm_i_inum2big (z
);
7735 else if (SCM_BIGP (y
))
7737 /* inum-x - big-y */
7738 scm_t_inum xx
= SCM_I_INUM (x
);
7742 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7743 bignum, but negating that gives a fixnum. */
7744 return scm_i_normbig (scm_i_clonebig (y
, 0));
7748 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7749 SCM result
= scm_i_mkbig ();
7752 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7755 /* x - y == -(y + -x) */
7756 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7757 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7759 scm_remember_upto_here_1 (y
);
7761 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7762 /* we know the result will have to be a bignum */
7765 return scm_i_normbig (result
);
7768 else if (SCM_REALP (y
))
7770 scm_t_inum xx
= SCM_I_INUM (x
);
7773 * We need to handle x == exact 0
7774 * specially because R6RS states that:
7775 * (- 0.0) ==> -0.0 and
7776 * (- 0.0 0.0) ==> 0.0
7777 * and the scheme compiler changes
7778 * (- 0.0) into (- 0 0.0)
7779 * So we need to treat (- 0 0.0) like (- 0.0).
7780 * At the C level, (-x) is different than (0.0 - x).
7781 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7784 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7786 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7788 else if (SCM_COMPLEXP (y
))
7790 scm_t_inum xx
= SCM_I_INUM (x
);
7792 /* We need to handle x == exact 0 specially.
7793 See the comment above (for SCM_REALP (y)) */
7795 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7796 - SCM_COMPLEX_IMAG (y
));
7798 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7799 - SCM_COMPLEX_IMAG (y
));
7801 else if (SCM_FRACTIONP (y
))
7802 /* a - b/c = (ac - b) / c */
7803 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7804 SCM_FRACTION_NUMERATOR (y
)),
7805 SCM_FRACTION_DENOMINATOR (y
));
7807 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7809 else if (SCM_BIGP (x
))
7811 if (SCM_I_INUMP (y
))
7813 /* big-x - inum-y */
7814 scm_t_inum yy
= SCM_I_INUM (y
);
7815 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7817 scm_remember_upto_here_1 (x
);
7819 return (SCM_FIXABLE (-yy
) ?
7820 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7823 SCM result
= scm_i_mkbig ();
7826 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7828 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7829 scm_remember_upto_here_1 (x
);
7831 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7832 /* we know the result will have to be a bignum */
7835 return scm_i_normbig (result
);
7838 else if (SCM_BIGP (y
))
7840 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7841 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7842 SCM result
= scm_i_mkbig ();
7843 mpz_sub (SCM_I_BIG_MPZ (result
),
7846 scm_remember_upto_here_2 (x
, y
);
7847 /* we know the result will have to be a bignum */
7848 if ((sgn_x
== 1) && (sgn_y
== -1))
7850 if ((sgn_x
== -1) && (sgn_y
== 1))
7852 return scm_i_normbig (result
);
7854 else if (SCM_REALP (y
))
7856 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7857 scm_remember_upto_here_1 (x
);
7858 return scm_i_from_double (result
);
7860 else if (SCM_COMPLEXP (y
))
7862 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7863 - SCM_COMPLEX_REAL (y
));
7864 scm_remember_upto_here_1 (x
);
7865 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7867 else if (SCM_FRACTIONP (y
))
7868 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7869 SCM_FRACTION_NUMERATOR (y
)),
7870 SCM_FRACTION_DENOMINATOR (y
));
7871 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7873 else if (SCM_REALP (x
))
7875 if (SCM_I_INUMP (y
))
7876 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7877 else if (SCM_BIGP (y
))
7879 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7880 scm_remember_upto_here_1 (x
);
7881 return scm_i_from_double (result
);
7883 else if (SCM_REALP (y
))
7884 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7885 else if (SCM_COMPLEXP (y
))
7886 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7887 -SCM_COMPLEX_IMAG (y
));
7888 else if (SCM_FRACTIONP (y
))
7889 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7891 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7893 else if (SCM_COMPLEXP (x
))
7895 if (SCM_I_INUMP (y
))
7896 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7897 SCM_COMPLEX_IMAG (x
));
7898 else if (SCM_BIGP (y
))
7900 double real_part
= (SCM_COMPLEX_REAL (x
)
7901 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7902 scm_remember_upto_here_1 (x
);
7903 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7905 else if (SCM_REALP (y
))
7906 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7907 SCM_COMPLEX_IMAG (x
));
7908 else if (SCM_COMPLEXP (y
))
7909 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7910 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7911 else if (SCM_FRACTIONP (y
))
7912 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7913 SCM_COMPLEX_IMAG (x
));
7915 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7917 else if (SCM_FRACTIONP (x
))
7919 if (SCM_I_INUMP (y
))
7920 /* a/b - c = (a - cb) / b */
7921 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7922 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7923 SCM_FRACTION_DENOMINATOR (x
));
7924 else if (SCM_BIGP (y
))
7925 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7926 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7927 SCM_FRACTION_DENOMINATOR (x
));
7928 else if (SCM_REALP (y
))
7929 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7930 else if (SCM_COMPLEXP (y
))
7931 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7932 -SCM_COMPLEX_IMAG (y
));
7933 else if (SCM_FRACTIONP (y
))
7934 /* a/b - c/d = (ad - bc) / bd */
7935 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7936 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7937 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7939 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7942 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7947 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7949 "Return @math{@var{x}-1}.")
7950 #define FUNC_NAME s_scm_oneminus
7952 return scm_difference (x
, SCM_INUM1
);
7957 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7958 (SCM x
, SCM y
, SCM rest
),
7959 "Return the product of all arguments. If called without arguments,\n"
7961 #define FUNC_NAME s_scm_i_product
7963 while (!scm_is_null (rest
))
7964 { x
= scm_product (x
, y
);
7966 rest
= scm_cdr (rest
);
7968 return scm_product (x
, y
);
7972 #define s_product s_scm_i_product
7973 #define g_product g_scm_i_product
7976 scm_product (SCM x
, SCM y
)
7978 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7981 return SCM_I_MAKINUM (1L);
7982 else if (SCM_NUMBERP (x
))
7985 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7988 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7993 xx
= SCM_I_INUM (x
);
7998 /* exact1 is the universal multiplicative identity */
8002 /* exact0 times a fixnum is exact0: optimize this case */
8003 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8005 /* if the other argument is inexact, the result is inexact,
8006 and we must do the multiplication in order to handle
8007 infinities and NaNs properly. */
8008 else if (SCM_REALP (y
))
8009 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8010 else if (SCM_COMPLEXP (y
))
8011 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8012 0.0 * SCM_COMPLEX_IMAG (y
));
8013 /* we've already handled inexact numbers,
8014 so y must be exact, and we return exact0 */
8015 else if (SCM_NUMP (y
))
8018 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8022 * This case is important for more than just optimization.
8023 * It handles the case of negating
8024 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8025 * which is a bignum that must be changed back into a fixnum.
8026 * Failure to do so will cause the following to return #f:
8027 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8029 return scm_difference(y
, SCM_UNDEFINED
);
8033 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8035 scm_t_inum yy
= SCM_I_INUM (y
);
8036 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8037 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8038 if (SCM_FIXABLE (kk
))
8039 return SCM_I_MAKINUM (kk
);
8041 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8042 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8043 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8044 return SCM_I_MAKINUM (xx
* yy
);
8048 SCM result
= scm_i_inum2big (xx
);
8049 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8050 return scm_i_normbig (result
);
8053 else if (SCM_BIGP (y
))
8055 SCM result
= scm_i_mkbig ();
8056 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8057 scm_remember_upto_here_1 (y
);
8060 else if (SCM_REALP (y
))
8061 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8062 else if (SCM_COMPLEXP (y
))
8063 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8064 xx
* SCM_COMPLEX_IMAG (y
));
8065 else if (SCM_FRACTIONP (y
))
8066 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8067 SCM_FRACTION_DENOMINATOR (y
));
8069 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8071 else if (SCM_BIGP (x
))
8073 if (SCM_I_INUMP (y
))
8078 else if (SCM_BIGP (y
))
8080 SCM result
= scm_i_mkbig ();
8081 mpz_mul (SCM_I_BIG_MPZ (result
),
8084 scm_remember_upto_here_2 (x
, y
);
8087 else if (SCM_REALP (y
))
8089 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8090 scm_remember_upto_here_1 (x
);
8091 return scm_i_from_double (result
);
8093 else if (SCM_COMPLEXP (y
))
8095 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8096 scm_remember_upto_here_1 (x
);
8097 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8098 z
* SCM_COMPLEX_IMAG (y
));
8100 else if (SCM_FRACTIONP (y
))
8101 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8102 SCM_FRACTION_DENOMINATOR (y
));
8104 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8106 else if (SCM_REALP (x
))
8108 if (SCM_I_INUMP (y
))
8113 else if (SCM_BIGP (y
))
8115 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8116 scm_remember_upto_here_1 (y
);
8117 return scm_i_from_double (result
);
8119 else if (SCM_REALP (y
))
8120 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8121 else if (SCM_COMPLEXP (y
))
8122 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8123 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8124 else if (SCM_FRACTIONP (y
))
8125 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8127 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8129 else if (SCM_COMPLEXP (x
))
8131 if (SCM_I_INUMP (y
))
8136 else if (SCM_BIGP (y
))
8138 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8139 scm_remember_upto_here_1 (y
);
8140 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8141 z
* SCM_COMPLEX_IMAG (x
));
8143 else if (SCM_REALP (y
))
8144 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8145 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8146 else if (SCM_COMPLEXP (y
))
8148 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8149 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8150 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8151 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8153 else if (SCM_FRACTIONP (y
))
8155 double yy
= scm_i_fraction2double (y
);
8156 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8157 yy
* SCM_COMPLEX_IMAG (x
));
8160 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8162 else if (SCM_FRACTIONP (x
))
8164 if (SCM_I_INUMP (y
))
8165 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8166 SCM_FRACTION_DENOMINATOR (x
));
8167 else if (SCM_BIGP (y
))
8168 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8169 SCM_FRACTION_DENOMINATOR (x
));
8170 else if (SCM_REALP (y
))
8171 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8172 else if (SCM_COMPLEXP (y
))
8174 double xx
= scm_i_fraction2double (x
);
8175 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8176 xx
* SCM_COMPLEX_IMAG (y
));
8178 else if (SCM_FRACTIONP (y
))
8179 /* a/b * c/d = ac / bd */
8180 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8181 SCM_FRACTION_NUMERATOR (y
)),
8182 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8183 SCM_FRACTION_DENOMINATOR (y
)));
8185 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8188 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8191 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8192 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8193 #define ALLOW_DIVIDE_BY_ZERO
8194 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8197 /* The code below for complex division is adapted from the GNU
8198 libstdc++, which adapted it from f2c's libF77, and is subject to
8201 /****************************************************************
8202 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8204 Permission to use, copy, modify, and distribute this software
8205 and its documentation for any purpose and without fee is hereby
8206 granted, provided that the above copyright notice appear in all
8207 copies and that both that the copyright notice and this
8208 permission notice and warranty disclaimer appear in supporting
8209 documentation, and that the names of AT&T Bell Laboratories or
8210 Bellcore or any of their entities not be used in advertising or
8211 publicity pertaining to distribution of the software without
8212 specific, written prior permission.
8214 AT&T and Bellcore disclaim all warranties with regard to this
8215 software, including all implied warranties of merchantability
8216 and fitness. In no event shall AT&T or Bellcore be liable for
8217 any special, indirect or consequential damages or any damages
8218 whatsoever resulting from loss of use, data or profits, whether
8219 in an action of contract, negligence or other tortious action,
8220 arising out of or in connection with the use or performance of
8222 ****************************************************************/
8224 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8225 (SCM x
, SCM y
, SCM rest
),
8226 "Divide the first argument by the product of the remaining\n"
8227 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8229 #define FUNC_NAME s_scm_i_divide
8231 while (!scm_is_null (rest
))
8232 { x
= scm_divide (x
, y
);
8234 rest
= scm_cdr (rest
);
8236 return scm_divide (x
, y
);
8240 #define s_divide s_scm_i_divide
8241 #define g_divide g_scm_i_divide
8244 scm_divide (SCM x
, SCM y
)
8245 #define FUNC_NAME s_divide
8249 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8252 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8253 else if (SCM_I_INUMP (x
))
8255 scm_t_inum xx
= SCM_I_INUM (x
);
8256 if (xx
== 1 || xx
== -1)
8258 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8260 scm_num_overflow (s_divide
);
8263 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8265 else if (SCM_BIGP (x
))
8266 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8267 else if (SCM_REALP (x
))
8269 double xx
= SCM_REAL_VALUE (x
);
8270 #ifndef ALLOW_DIVIDE_BY_ZERO
8272 scm_num_overflow (s_divide
);
8275 return scm_i_from_double (1.0 / xx
);
8277 else if (SCM_COMPLEXP (x
))
8279 double r
= SCM_COMPLEX_REAL (x
);
8280 double i
= SCM_COMPLEX_IMAG (x
);
8281 if (fabs(r
) <= fabs(i
))
8284 double d
= i
* (1.0 + t
* t
);
8285 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8290 double d
= r
* (1.0 + t
* t
);
8291 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8294 else if (SCM_FRACTIONP (x
))
8295 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8296 SCM_FRACTION_NUMERATOR (x
));
8298 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8301 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8303 scm_t_inum xx
= SCM_I_INUM (x
);
8304 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8306 scm_t_inum yy
= SCM_I_INUM (y
);
8309 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8310 scm_num_overflow (s_divide
);
8312 return scm_i_from_double ((double) xx
/ (double) yy
);
8315 else if (xx
% yy
!= 0)
8316 return scm_i_make_ratio (x
, y
);
8319 scm_t_inum z
= xx
/ yy
;
8320 if (SCM_FIXABLE (z
))
8321 return SCM_I_MAKINUM (z
);
8323 return scm_i_inum2big (z
);
8326 else if (SCM_BIGP (y
))
8327 return scm_i_make_ratio (x
, y
);
8328 else if (SCM_REALP (y
))
8330 double yy
= SCM_REAL_VALUE (y
);
8331 #ifndef ALLOW_DIVIDE_BY_ZERO
8333 scm_num_overflow (s_divide
);
8336 /* FIXME: Precision may be lost here due to:
8337 (1) The cast from 'scm_t_inum' to 'double'
8338 (2) Double rounding */
8339 return scm_i_from_double ((double) xx
/ yy
);
8341 else if (SCM_COMPLEXP (y
))
8344 complex_div
: /* y _must_ be a complex number */
8346 double r
= SCM_COMPLEX_REAL (y
);
8347 double i
= SCM_COMPLEX_IMAG (y
);
8348 if (fabs(r
) <= fabs(i
))
8351 double d
= i
* (1.0 + t
* t
);
8352 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8357 double d
= r
* (1.0 + t
* t
);
8358 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8362 else if (SCM_FRACTIONP (y
))
8363 /* a / b/c = ac / b */
8364 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8365 SCM_FRACTION_NUMERATOR (y
));
8367 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8369 else if (SCM_BIGP (x
))
8371 if (SCM_I_INUMP (y
))
8373 scm_t_inum yy
= SCM_I_INUM (y
);
8376 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8377 scm_num_overflow (s_divide
);
8379 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8380 scm_remember_upto_here_1 (x
);
8381 return (sgn
== 0) ? scm_nan () : scm_inf ();
8388 /* FIXME: HMM, what are the relative performance issues here?
8389 We need to test. Is it faster on average to test
8390 divisible_p, then perform whichever operation, or is it
8391 faster to perform the integer div opportunistically and
8392 switch to real if there's a remainder? For now we take the
8393 middle ground: test, then if divisible, use the faster div
8396 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8397 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8401 SCM result
= scm_i_mkbig ();
8402 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8403 scm_remember_upto_here_1 (x
);
8405 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8406 return scm_i_normbig (result
);
8409 return scm_i_make_ratio (x
, y
);
8412 else if (SCM_BIGP (y
))
8414 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8418 SCM result
= scm_i_mkbig ();
8419 mpz_divexact (SCM_I_BIG_MPZ (result
),
8422 scm_remember_upto_here_2 (x
, y
);
8423 return scm_i_normbig (result
);
8426 return scm_i_make_ratio (x
, y
);
8428 else if (SCM_REALP (y
))
8430 double yy
= SCM_REAL_VALUE (y
);
8431 #ifndef ALLOW_DIVIDE_BY_ZERO
8433 scm_num_overflow (s_divide
);
8436 /* FIXME: Precision may be lost here due to:
8437 (1) scm_i_big2dbl (2) Double rounding */
8438 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8440 else if (SCM_COMPLEXP (y
))
8442 a
= scm_i_big2dbl (x
);
8445 else if (SCM_FRACTIONP (y
))
8446 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8447 SCM_FRACTION_NUMERATOR (y
));
8449 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8451 else if (SCM_REALP (x
))
8453 double rx
= SCM_REAL_VALUE (x
);
8454 if (SCM_I_INUMP (y
))
8456 scm_t_inum yy
= SCM_I_INUM (y
);
8457 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8459 scm_num_overflow (s_divide
);
8462 /* FIXME: Precision may be lost here due to:
8463 (1) The cast from 'scm_t_inum' to 'double'
8464 (2) Double rounding */
8465 return scm_i_from_double (rx
/ (double) yy
);
8467 else if (SCM_BIGP (y
))
8469 /* FIXME: Precision may be lost here due to:
8470 (1) The conversion from bignum to double
8471 (2) Double rounding */
8472 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8473 scm_remember_upto_here_1 (y
);
8474 return scm_i_from_double (rx
/ dby
);
8476 else if (SCM_REALP (y
))
8478 double yy
= SCM_REAL_VALUE (y
);
8479 #ifndef ALLOW_DIVIDE_BY_ZERO
8481 scm_num_overflow (s_divide
);
8484 return scm_i_from_double (rx
/ yy
);
8486 else if (SCM_COMPLEXP (y
))
8491 else if (SCM_FRACTIONP (y
))
8492 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8494 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8496 else if (SCM_COMPLEXP (x
))
8498 double rx
= SCM_COMPLEX_REAL (x
);
8499 double ix
= SCM_COMPLEX_IMAG (x
);
8500 if (SCM_I_INUMP (y
))
8502 scm_t_inum yy
= SCM_I_INUM (y
);
8503 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8505 scm_num_overflow (s_divide
);
8509 /* FIXME: Precision may be lost here due to:
8510 (1) The conversion from 'scm_t_inum' to double
8511 (2) Double rounding */
8513 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8516 else if (SCM_BIGP (y
))
8518 /* FIXME: Precision may be lost here due to:
8519 (1) The conversion from bignum to double
8520 (2) Double rounding */
8521 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8522 scm_remember_upto_here_1 (y
);
8523 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8525 else if (SCM_REALP (y
))
8527 double yy
= SCM_REAL_VALUE (y
);
8528 #ifndef ALLOW_DIVIDE_BY_ZERO
8530 scm_num_overflow (s_divide
);
8533 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8535 else if (SCM_COMPLEXP (y
))
8537 double ry
= SCM_COMPLEX_REAL (y
);
8538 double iy
= SCM_COMPLEX_IMAG (y
);
8539 if (fabs(ry
) <= fabs(iy
))
8542 double d
= iy
* (1.0 + t
* t
);
8543 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8548 double d
= ry
* (1.0 + t
* t
);
8549 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8552 else if (SCM_FRACTIONP (y
))
8554 /* FIXME: Precision may be lost here due to:
8555 (1) The conversion from fraction to double
8556 (2) Double rounding */
8557 double yy
= scm_i_fraction2double (y
);
8558 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8561 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8563 else if (SCM_FRACTIONP (x
))
8565 if (SCM_I_INUMP (y
))
8567 scm_t_inum yy
= SCM_I_INUM (y
);
8568 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8570 scm_num_overflow (s_divide
);
8573 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8574 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8576 else if (SCM_BIGP (y
))
8578 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8579 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8581 else if (SCM_REALP (y
))
8583 double yy
= SCM_REAL_VALUE (y
);
8584 #ifndef ALLOW_DIVIDE_BY_ZERO
8586 scm_num_overflow (s_divide
);
8589 /* FIXME: Precision may be lost here due to:
8590 (1) The conversion from fraction to double
8591 (2) Double rounding */
8592 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8594 else if (SCM_COMPLEXP (y
))
8596 /* FIXME: Precision may be lost here due to:
8597 (1) The conversion from fraction to double
8598 (2) Double rounding */
8599 a
= scm_i_fraction2double (x
);
8602 else if (SCM_FRACTIONP (y
))
8603 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8604 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8606 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8609 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8615 scm_c_truncate (double x
)
8620 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8621 half-way case (ie. when x is an integer plus 0.5) going upwards.
8622 Then half-way cases are identified and adjusted down if the
8623 round-upwards didn't give the desired even integer.
8625 "plus_half == result" identifies a half-way case. If plus_half, which is
8626 x + 0.5, is an integer then x must be an integer plus 0.5.
8628 An odd "result" value is identified with result/2 != floor(result/2).
8629 This is done with plus_half, since that value is ready for use sooner in
8630 a pipelined cpu, and we're already requiring plus_half == result.
8632 Note however that we need to be careful when x is big and already an
8633 integer. In that case "x+0.5" may round to an adjacent integer, causing
8634 us to return such a value, incorrectly. For instance if the hardware is
8635 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8636 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8637 returned. Or if the hardware is in round-upwards mode, then other bigger
8638 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8639 representable value, 2^128+2^76 (or whatever), again incorrect.
8641 These bad roundings of x+0.5 are avoided by testing at the start whether
8642 x is already an integer. If it is then clearly that's the desired result
8643 already. And if it's not then the exponent must be small enough to allow
8644 an 0.5 to be represented, and hence added without a bad rounding. */
8647 scm_c_round (double x
)
8649 double plus_half
, result
;
8654 plus_half
= x
+ 0.5;
8655 result
= floor (plus_half
);
8656 /* Adjust so that the rounding is towards even. */
8657 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8662 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8664 "Round the number @var{x} towards zero.")
8665 #define FUNC_NAME s_scm_truncate_number
8667 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8669 else if (SCM_REALP (x
))
8670 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8671 else if (SCM_FRACTIONP (x
))
8672 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8673 SCM_FRACTION_DENOMINATOR (x
));
8675 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8676 s_scm_truncate_number
);
8680 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8682 "Round the number @var{x} towards the nearest integer. "
8683 "When it is exactly halfway between two integers, "
8684 "round towards the even one.")
8685 #define FUNC_NAME s_scm_round_number
8687 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8689 else if (SCM_REALP (x
))
8690 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8691 else if (SCM_FRACTIONP (x
))
8692 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8693 SCM_FRACTION_DENOMINATOR (x
));
8695 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8696 s_scm_round_number
);
8700 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8702 "Round the number @var{x} towards minus infinity.")
8703 #define FUNC_NAME s_scm_floor
8705 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8707 else if (SCM_REALP (x
))
8708 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8709 else if (SCM_FRACTIONP (x
))
8710 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8711 SCM_FRACTION_DENOMINATOR (x
));
8713 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8717 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8719 "Round the number @var{x} towards infinity.")
8720 #define FUNC_NAME s_scm_ceiling
8722 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8724 else if (SCM_REALP (x
))
8725 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8726 else if (SCM_FRACTIONP (x
))
8727 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8728 SCM_FRACTION_DENOMINATOR (x
));
8730 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8734 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8736 "Return @var{x} raised to the power of @var{y}.")
8737 #define FUNC_NAME s_scm_expt
8739 if (scm_is_integer (y
))
8741 if (scm_is_true (scm_exact_p (y
)))
8742 return scm_integer_expt (x
, y
);
8745 /* Here we handle the case where the exponent is an inexact
8746 integer. We make the exponent exact in order to use
8747 scm_integer_expt, and thus avoid the spurious imaginary
8748 parts that may result from round-off errors in the general
8749 e^(y log x) method below (for example when squaring a large
8750 negative number). In this case, we must return an inexact
8751 result for correctness. We also make the base inexact so
8752 that scm_integer_expt will use fast inexact arithmetic
8753 internally. Note that making the base inexact is not
8754 sufficient to guarantee an inexact result, because
8755 scm_integer_expt will return an exact 1 when the exponent
8756 is 0, even if the base is inexact. */
8757 return scm_exact_to_inexact
8758 (scm_integer_expt (scm_exact_to_inexact (x
),
8759 scm_inexact_to_exact (y
)));
8762 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8764 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8766 else if (scm_is_complex (x
) && scm_is_complex (y
))
8767 return scm_exp (scm_product (scm_log (x
), y
));
8768 else if (scm_is_complex (x
))
8769 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8771 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8775 /* sin/cos/tan/asin/acos/atan
8776 sinh/cosh/tanh/asinh/acosh/atanh
8777 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8778 Written by Jerry D. Hedden, (C) FSF.
8779 See the file `COPYING' for terms applying to this program. */
8781 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8783 "Compute the sine of @var{z}.")
8784 #define FUNC_NAME s_scm_sin
8786 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8787 return z
; /* sin(exact0) = exact0 */
8788 else if (scm_is_real (z
))
8789 return scm_i_from_double (sin (scm_to_double (z
)));
8790 else if (SCM_COMPLEXP (z
))
8792 x
= SCM_COMPLEX_REAL (z
);
8793 y
= SCM_COMPLEX_IMAG (z
);
8794 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8795 cos (x
) * sinh (y
));
8798 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8802 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8804 "Compute the cosine of @var{z}.")
8805 #define FUNC_NAME s_scm_cos
8807 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8808 return SCM_INUM1
; /* cos(exact0) = exact1 */
8809 else if (scm_is_real (z
))
8810 return scm_i_from_double (cos (scm_to_double (z
)));
8811 else if (SCM_COMPLEXP (z
))
8813 x
= SCM_COMPLEX_REAL (z
);
8814 y
= SCM_COMPLEX_IMAG (z
);
8815 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8816 -sin (x
) * sinh (y
));
8819 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8823 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8825 "Compute the tangent of @var{z}.")
8826 #define FUNC_NAME s_scm_tan
8828 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8829 return z
; /* tan(exact0) = exact0 */
8830 else if (scm_is_real (z
))
8831 return scm_i_from_double (tan (scm_to_double (z
)));
8832 else if (SCM_COMPLEXP (z
))
8834 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8835 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8836 w
= cos (x
) + cosh (y
);
8837 #ifndef ALLOW_DIVIDE_BY_ZERO
8839 scm_num_overflow (s_scm_tan
);
8841 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8844 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8848 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8850 "Compute the hyperbolic sine of @var{z}.")
8851 #define FUNC_NAME s_scm_sinh
8853 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8854 return z
; /* sinh(exact0) = exact0 */
8855 else if (scm_is_real (z
))
8856 return scm_i_from_double (sinh (scm_to_double (z
)));
8857 else if (SCM_COMPLEXP (z
))
8859 x
= SCM_COMPLEX_REAL (z
);
8860 y
= SCM_COMPLEX_IMAG (z
);
8861 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8862 cosh (x
) * sin (y
));
8865 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8869 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8871 "Compute the hyperbolic cosine of @var{z}.")
8872 #define FUNC_NAME s_scm_cosh
8874 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8875 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8876 else if (scm_is_real (z
))
8877 return scm_i_from_double (cosh (scm_to_double (z
)));
8878 else if (SCM_COMPLEXP (z
))
8880 x
= SCM_COMPLEX_REAL (z
);
8881 y
= SCM_COMPLEX_IMAG (z
);
8882 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8883 sinh (x
) * sin (y
));
8886 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8890 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8892 "Compute the hyperbolic tangent of @var{z}.")
8893 #define FUNC_NAME s_scm_tanh
8895 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8896 return z
; /* tanh(exact0) = exact0 */
8897 else if (scm_is_real (z
))
8898 return scm_i_from_double (tanh (scm_to_double (z
)));
8899 else if (SCM_COMPLEXP (z
))
8901 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8902 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8903 w
= cosh (x
) + cos (y
);
8904 #ifndef ALLOW_DIVIDE_BY_ZERO
8906 scm_num_overflow (s_scm_tanh
);
8908 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8911 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8915 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8917 "Compute the arc sine of @var{z}.")
8918 #define FUNC_NAME s_scm_asin
8920 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8921 return z
; /* asin(exact0) = exact0 */
8922 else if (scm_is_real (z
))
8924 double w
= scm_to_double (z
);
8925 if (w
>= -1.0 && w
<= 1.0)
8926 return scm_i_from_double (asin (w
));
8928 return scm_product (scm_c_make_rectangular (0, -1),
8929 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8931 else if (SCM_COMPLEXP (z
))
8933 x
= SCM_COMPLEX_REAL (z
);
8934 y
= SCM_COMPLEX_IMAG (z
);
8935 return scm_product (scm_c_make_rectangular (0, -1),
8936 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8939 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8943 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8945 "Compute the arc cosine of @var{z}.")
8946 #define FUNC_NAME s_scm_acos
8948 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8949 return SCM_INUM0
; /* acos(exact1) = exact0 */
8950 else if (scm_is_real (z
))
8952 double w
= scm_to_double (z
);
8953 if (w
>= -1.0 && w
<= 1.0)
8954 return scm_i_from_double (acos (w
));
8956 return scm_sum (scm_i_from_double (acos (0.0)),
8957 scm_product (scm_c_make_rectangular (0, 1),
8958 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8960 else if (SCM_COMPLEXP (z
))
8962 x
= SCM_COMPLEX_REAL (z
);
8963 y
= SCM_COMPLEX_IMAG (z
);
8964 return scm_sum (scm_i_from_double (acos (0.0)),
8965 scm_product (scm_c_make_rectangular (0, 1),
8966 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8969 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8973 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8975 "With one argument, compute the arc tangent of @var{z}.\n"
8976 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8977 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8978 #define FUNC_NAME s_scm_atan
8982 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8983 return z
; /* atan(exact0) = exact0 */
8984 else if (scm_is_real (z
))
8985 return scm_i_from_double (atan (scm_to_double (z
)));
8986 else if (SCM_COMPLEXP (z
))
8989 v
= SCM_COMPLEX_REAL (z
);
8990 w
= SCM_COMPLEX_IMAG (z
);
8991 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8992 scm_c_make_rectangular (v
, w
+ 1.0))),
8993 scm_c_make_rectangular (0, 2));
8996 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8998 else if (scm_is_real (z
))
9000 if (scm_is_real (y
))
9001 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9003 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9006 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9010 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9012 "Compute the inverse hyperbolic sine of @var{z}.")
9013 #define FUNC_NAME s_scm_sys_asinh
9015 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9016 return z
; /* asinh(exact0) = exact0 */
9017 else if (scm_is_real (z
))
9018 return scm_i_from_double (asinh (scm_to_double (z
)));
9019 else if (scm_is_number (z
))
9020 return scm_log (scm_sum (z
,
9021 scm_sqrt (scm_sum (scm_product (z
, z
),
9024 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9028 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9030 "Compute the inverse hyperbolic cosine of @var{z}.")
9031 #define FUNC_NAME s_scm_sys_acosh
9033 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9034 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9035 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9036 return scm_i_from_double (acosh (scm_to_double (z
)));
9037 else if (scm_is_number (z
))
9038 return scm_log (scm_sum (z
,
9039 scm_sqrt (scm_difference (scm_product (z
, z
),
9042 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9046 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9048 "Compute the inverse hyperbolic tangent of @var{z}.")
9049 #define FUNC_NAME s_scm_sys_atanh
9051 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9052 return z
; /* atanh(exact0) = exact0 */
9053 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9054 return scm_i_from_double (atanh (scm_to_double (z
)));
9055 else if (scm_is_number (z
))
9056 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9057 scm_difference (SCM_INUM1
, z
))),
9060 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9065 scm_c_make_rectangular (double re
, double im
)
9069 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9071 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9072 SCM_COMPLEX_REAL (z
) = re
;
9073 SCM_COMPLEX_IMAG (z
) = im
;
9077 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9078 (SCM real_part
, SCM imaginary_part
),
9079 "Return a complex number constructed of the given @var{real_part} "
9080 "and @var{imaginary_part} parts.")
9081 #define FUNC_NAME s_scm_make_rectangular
9083 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9084 SCM_ARG1
, FUNC_NAME
, "real");
9085 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9086 SCM_ARG2
, FUNC_NAME
, "real");
9088 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9089 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9092 return scm_c_make_rectangular (scm_to_double (real_part
),
9093 scm_to_double (imaginary_part
));
9098 scm_c_make_polar (double mag
, double ang
)
9102 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9103 use it on Glibc-based systems that have it (it's a GNU extension). See
9104 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9106 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9107 sincos (ang
, &s
, &c
);
9113 /* If s and c are NaNs, this indicates that the angle is a NaN,
9114 infinite, or perhaps simply too large to determine its value
9115 mod 2*pi. However, we know something that the floating-point
9116 implementation doesn't know: We know that s and c are finite.
9117 Therefore, if the magnitude is zero, return a complex zero.
9119 The reason we check for the NaNs instead of using this case
9120 whenever mag == 0.0 is because when the angle is known, we'd
9121 like to return the correct kind of non-real complex zero:
9122 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9123 on which quadrant the angle is in.
9125 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9126 return scm_c_make_rectangular (0.0, 0.0);
9128 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9131 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9133 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9134 #define FUNC_NAME s_scm_make_polar
9136 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9137 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9139 /* If mag is exact0, return exact0 */
9140 if (scm_is_eq (mag
, SCM_INUM0
))
9142 /* Return a real if ang is exact0 */
9143 else if (scm_is_eq (ang
, SCM_INUM0
))
9146 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9151 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9153 "Return the real part of the number @var{z}.")
9154 #define FUNC_NAME s_scm_real_part
9156 if (SCM_COMPLEXP (z
))
9157 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9158 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9161 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9166 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9168 "Return the imaginary part of the number @var{z}.")
9169 #define FUNC_NAME s_scm_imag_part
9171 if (SCM_COMPLEXP (z
))
9172 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9173 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9176 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9180 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9182 "Return the numerator of the number @var{z}.")
9183 #define FUNC_NAME s_scm_numerator
9185 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9187 else if (SCM_FRACTIONP (z
))
9188 return SCM_FRACTION_NUMERATOR (z
);
9189 else if (SCM_REALP (z
))
9191 double zz
= SCM_REAL_VALUE (z
);
9192 if (zz
== floor (zz
))
9193 /* Handle -0.0 and infinities in accordance with R6RS
9194 flnumerator, and optimize handling of integers. */
9197 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9200 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9205 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9207 "Return the denominator of the number @var{z}.")
9208 #define FUNC_NAME s_scm_denominator
9210 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9212 else if (SCM_FRACTIONP (z
))
9213 return SCM_FRACTION_DENOMINATOR (z
);
9214 else if (SCM_REALP (z
))
9216 double zz
= SCM_REAL_VALUE (z
);
9217 if (zz
== floor (zz
))
9218 /* Handle infinities in accordance with R6RS fldenominator, and
9219 optimize handling of integers. */
9220 return scm_i_from_double (1.0);
9222 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9225 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9230 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9232 "Return the magnitude of the number @var{z}. This is the same as\n"
9233 "@code{abs} for real arguments, but also allows complex numbers.")
9234 #define FUNC_NAME s_scm_magnitude
9236 if (SCM_I_INUMP (z
))
9238 scm_t_inum zz
= SCM_I_INUM (z
);
9241 else if (SCM_POSFIXABLE (-zz
))
9242 return SCM_I_MAKINUM (-zz
);
9244 return scm_i_inum2big (-zz
);
9246 else if (SCM_BIGP (z
))
9248 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9249 scm_remember_upto_here_1 (z
);
9251 return scm_i_clonebig (z
, 0);
9255 else if (SCM_REALP (z
))
9256 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9257 else if (SCM_COMPLEXP (z
))
9258 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9259 else if (SCM_FRACTIONP (z
))
9261 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9263 return scm_i_make_ratio_already_reduced
9264 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9265 SCM_FRACTION_DENOMINATOR (z
));
9268 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9273 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9275 "Return the angle of the complex number @var{z}.")
9276 #define FUNC_NAME s_scm_angle
9278 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9279 flo0 to save allocating a new flonum with scm_i_from_double each time.
9280 But if atan2 follows the floating point rounding mode, then the value
9281 is not a constant. Maybe it'd be close enough though. */
9282 if (SCM_I_INUMP (z
))
9284 if (SCM_I_INUM (z
) >= 0)
9287 return scm_i_from_double (atan2 (0.0, -1.0));
9289 else if (SCM_BIGP (z
))
9291 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9292 scm_remember_upto_here_1 (z
);
9294 return scm_i_from_double (atan2 (0.0, -1.0));
9298 else if (SCM_REALP (z
))
9300 double x
= SCM_REAL_VALUE (z
);
9301 if (copysign (1.0, x
) > 0.0)
9304 return scm_i_from_double (atan2 (0.0, -1.0));
9306 else if (SCM_COMPLEXP (z
))
9307 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9308 else if (SCM_FRACTIONP (z
))
9310 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9312 else return scm_i_from_double (atan2 (0.0, -1.0));
9315 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9320 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9322 "Convert the number @var{z} to its inexact representation.\n")
9323 #define FUNC_NAME s_scm_exact_to_inexact
9325 if (SCM_I_INUMP (z
))
9326 return scm_i_from_double ((double) SCM_I_INUM (z
));
9327 else if (SCM_BIGP (z
))
9328 return scm_i_from_double (scm_i_big2dbl (z
));
9329 else if (SCM_FRACTIONP (z
))
9330 return scm_i_from_double (scm_i_fraction2double (z
));
9331 else if (SCM_INEXACTP (z
))
9334 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9339 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9341 "Return an exact number that is numerically closest to @var{z}.")
9342 #define FUNC_NAME s_scm_inexact_to_exact
9344 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9351 val
= SCM_REAL_VALUE (z
);
9352 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9353 val
= SCM_COMPLEX_REAL (z
);
9355 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9357 if (!SCM_LIKELY (isfinite (val
)))
9358 SCM_OUT_OF_RANGE (1, z
);
9359 else if (val
== 0.0)
9366 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9368 expon
-= DBL_MANT_DIG
;
9371 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9375 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9376 SCM_I_BIG_MPZ (numerator
),
9380 numerator
= scm_i_normbig (numerator
);
9382 return scm_i_make_ratio_already_reduced
9383 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9385 return left_shift_exact_integer (numerator
, expon
);
9393 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9395 "Returns the @emph{simplest} rational number differing\n"
9396 "from @var{x} by no more than @var{eps}.\n"
9398 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9399 "exact result when both its arguments are exact. Thus, you might need\n"
9400 "to use @code{inexact->exact} on the arguments.\n"
9403 "(rationalize (inexact->exact 1.2) 1/100)\n"
9406 #define FUNC_NAME s_scm_rationalize
9408 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9409 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9411 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9413 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9415 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9420 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9423 return scm_exact_to_inexact
9424 (scm_rationalize (scm_inexact_to_exact (x
),
9425 scm_inexact_to_exact (eps
)));
9429 /* X and EPS are exact rationals.
9431 The code that follows is equivalent to the following Scheme code:
9433 (define (exact-rationalize x eps)
9434 (let ((n1 (if (negative? x) -1 1))
9437 (let ((lo (- x eps))
9441 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9442 (nhi (numerator hi)) (dhi (denominator hi))
9443 (n1 n1) (d1 0) (n2 0) (d2 1))
9444 (let-values (((qlo rlo) (floor/ nlo dlo))
9445 ((qhi rhi) (floor/ nhi dhi)))
9446 (let ((n0 (+ n2 (* n1 qlo)))
9447 (d0 (+ d2 (* d1 qlo))))
9448 (cond ((zero? rlo) (/ n0 d0))
9449 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9450 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9456 eps
= scm_abs (eps
);
9457 if (scm_is_true (scm_negative_p (x
)))
9460 x
= scm_difference (x
, SCM_UNDEFINED
);
9463 /* X and EPS are non-negative exact rationals. */
9465 lo
= scm_difference (x
, eps
);
9466 hi
= scm_sum (x
, eps
);
9468 if (scm_is_false (scm_positive_p (lo
)))
9469 /* If zero is included in the interval, return it.
9470 It is the simplest rational of all. */
9475 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9476 mpz_t nlo
, dlo
, nhi
, dhi
;
9477 mpz_t qlo
, rlo
, qhi
, rhi
;
9479 /* LO and HI are positive exact rationals. */
9481 /* Our approach here follows the method described by Alan
9482 Bawden in a message entitled "(rationalize x y)" on the
9483 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9485 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9487 In brief, we compute the continued fractions of the two
9488 endpoints of the interval (LO and HI). The continued
9489 fraction of the result consists of the common prefix of the
9490 continued fractions of LO and HI, plus one final term. The
9491 final term of the result is the smallest integer contained
9492 in the interval between the remainders of LO and HI after
9493 the common prefix has been removed.
9495 The following code lazily computes the continued fraction
9496 representations of LO and HI, and simultaneously converts
9497 the continued fraction of the result into a rational
9498 number. We use MPZ functions directly to avoid type
9499 dispatch and GC allocation during the loop. */
9501 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9506 /* The variables N1, D1, N2 and D2 are used to compute the
9507 resulting rational from its continued fraction. At each
9508 step, N2/D2 and N1/D1 are the last two convergents. They
9509 are normally initialized to 0/1 and 1/0, respectively.
9510 However, if we negated X then we must negate the result as
9511 well, and we do that by initializing N1/D1 to -1/0. */
9512 mpz_set_si (n1
, n1_init
);
9517 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9518 compute the continued fraction representations of LO and HI
9519 using Euclid's algorithm. Initially, NLO/DLO == LO and
9521 scm_to_mpz (scm_numerator (lo
), nlo
);
9522 scm_to_mpz (scm_denominator (lo
), dlo
);
9523 scm_to_mpz (scm_numerator (hi
), nhi
);
9524 scm_to_mpz (scm_denominator (hi
), dhi
);
9526 /* As long as we're using exact arithmetic, the following loop
9527 is guaranteed to terminate. */
9530 /* Compute the next terms (QLO and QHI) of the continued
9531 fractions of LO and HI. */
9532 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9533 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9535 /* The next term of the result will be either QLO or
9536 QLO+1. Here we compute the next convergent of the
9537 result based on the assumption that QLO is the next
9538 term. If that turns out to be wrong, we'll adjust
9539 these later by adding N1 to N0 and D1 to D0. */
9540 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9541 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9543 /* We stop iterating when an integer is contained in the
9544 interval between the remainders NLO/DLO and NHI/DHI.
9545 There are two cases to consider: either NLO/DLO == QLO
9546 is an integer (indicated by RLO == 0), or QLO < QHI. */
9547 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9550 /* Efficiently shuffle variables around for the next
9551 iteration. First we shift the recent convergents. */
9552 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9553 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9555 /* The following shuffling is a bit confusing, so some
9556 explanation is in order. Conceptually, we're doing a
9557 couple of things here. After substracting the floor of
9558 NLO/DLO, the remainder is RLO/DLO. The rest of the
9559 continued fraction will represent the remainder's
9560 reciprocal DLO/RLO. Similarly for the HI endpoint.
9561 So in the next iteration, the new endpoints will be
9562 DLO/RLO and DHI/RHI. However, when we take the
9563 reciprocals of these endpoints, their order is
9564 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9565 and NHI/DHI <-- DLO/RLO. */
9566 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9567 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9570 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9571 The last term of the result will be the smallest integer in
9572 that interval, which is ceiling(NLO/DLO). We have already
9573 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9574 equal to the ceiling. */
9575 if (mpz_sgn (rlo
) != 0)
9577 /* If RLO is non-zero, then NLO/DLO is not an integer and
9578 the next term will be QLO+1. QLO was used in the
9579 computation of N0 and D0 above. Here we adjust N0 and
9580 D0 to be based on QLO+1 instead of QLO. */
9581 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9582 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9585 /* The simplest rational in the interval is N0/D0 */
9586 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9588 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9598 /* conversion functions */
9601 scm_is_integer (SCM val
)
9603 return scm_is_true (scm_integer_p (val
));
9607 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9609 if (SCM_I_INUMP (val
))
9611 scm_t_signed_bits n
= SCM_I_INUM (val
);
9612 return n
>= min
&& n
<= max
;
9614 else if (SCM_BIGP (val
))
9616 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9618 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9620 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9622 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9623 return n
>= min
&& n
<= max
;
9633 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9634 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9637 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9638 SCM_I_BIG_MPZ (val
));
9640 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9652 return n
>= min
&& n
<= max
;
9660 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9662 if (SCM_I_INUMP (val
))
9664 scm_t_signed_bits n
= SCM_I_INUM (val
);
9665 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9667 else if (SCM_BIGP (val
))
9669 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9671 else if (max
<= ULONG_MAX
)
9673 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9675 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9676 return n
>= min
&& n
<= max
;
9686 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9689 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9690 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9693 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9694 SCM_I_BIG_MPZ (val
));
9696 return n
>= min
&& n
<= max
;
9704 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9706 scm_error (scm_out_of_range_key
,
9708 "Value out of range ~S to ~S: ~S",
9709 scm_list_3 (min
, max
, bad_val
),
9710 scm_list_1 (bad_val
));
9713 #define TYPE scm_t_intmax
9714 #define TYPE_MIN min
9715 #define TYPE_MAX max
9716 #define SIZEOF_TYPE 0
9717 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9718 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9719 #include "libguile/conv-integer.i.c"
9721 #define TYPE scm_t_uintmax
9722 #define TYPE_MIN min
9723 #define TYPE_MAX max
9724 #define SIZEOF_TYPE 0
9725 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9726 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9727 #include "libguile/conv-uinteger.i.c"
9729 #define TYPE scm_t_int8
9730 #define TYPE_MIN SCM_T_INT8_MIN
9731 #define TYPE_MAX SCM_T_INT8_MAX
9732 #define SIZEOF_TYPE 1
9733 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9734 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9735 #include "libguile/conv-integer.i.c"
9737 #define TYPE scm_t_uint8
9739 #define TYPE_MAX SCM_T_UINT8_MAX
9740 #define SIZEOF_TYPE 1
9741 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9742 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9743 #include "libguile/conv-uinteger.i.c"
9745 #define TYPE scm_t_int16
9746 #define TYPE_MIN SCM_T_INT16_MIN
9747 #define TYPE_MAX SCM_T_INT16_MAX
9748 #define SIZEOF_TYPE 2
9749 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9750 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9751 #include "libguile/conv-integer.i.c"
9753 #define TYPE scm_t_uint16
9755 #define TYPE_MAX SCM_T_UINT16_MAX
9756 #define SIZEOF_TYPE 2
9757 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9758 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9759 #include "libguile/conv-uinteger.i.c"
9761 #define TYPE scm_t_int32
9762 #define TYPE_MIN SCM_T_INT32_MIN
9763 #define TYPE_MAX SCM_T_INT32_MAX
9764 #define SIZEOF_TYPE 4
9765 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9766 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9767 #include "libguile/conv-integer.i.c"
9769 #define TYPE scm_t_uint32
9771 #define TYPE_MAX SCM_T_UINT32_MAX
9772 #define SIZEOF_TYPE 4
9773 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9774 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9775 #include "libguile/conv-uinteger.i.c"
9777 #define TYPE scm_t_wchar
9778 #define TYPE_MIN (scm_t_int32)-1
9779 #define TYPE_MAX (scm_t_int32)0x10ffff
9780 #define SIZEOF_TYPE 4
9781 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9782 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9783 #include "libguile/conv-integer.i.c"
9785 #define TYPE scm_t_int64
9786 #define TYPE_MIN SCM_T_INT64_MIN
9787 #define TYPE_MAX SCM_T_INT64_MAX
9788 #define SIZEOF_TYPE 8
9789 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9790 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9791 #include "libguile/conv-integer.i.c"
9793 #define TYPE scm_t_uint64
9795 #define TYPE_MAX SCM_T_UINT64_MAX
9796 #define SIZEOF_TYPE 8
9797 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9798 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9799 #include "libguile/conv-uinteger.i.c"
9802 scm_to_mpz (SCM val
, mpz_t rop
)
9804 if (SCM_I_INUMP (val
))
9805 mpz_set_si (rop
, SCM_I_INUM (val
));
9806 else if (SCM_BIGP (val
))
9807 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9809 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9813 scm_from_mpz (mpz_t val
)
9815 return scm_i_mpz2num (val
);
9819 scm_is_real (SCM val
)
9821 return scm_is_true (scm_real_p (val
));
9825 scm_is_rational (SCM val
)
9827 return scm_is_true (scm_rational_p (val
));
9831 scm_to_double (SCM val
)
9833 if (SCM_I_INUMP (val
))
9834 return SCM_I_INUM (val
);
9835 else if (SCM_BIGP (val
))
9836 return scm_i_big2dbl (val
);
9837 else if (SCM_FRACTIONP (val
))
9838 return scm_i_fraction2double (val
);
9839 else if (SCM_REALP (val
))
9840 return SCM_REAL_VALUE (val
);
9842 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9846 scm_from_double (double val
)
9848 return scm_i_from_double (val
);
9851 #if SCM_ENABLE_DEPRECATED == 1
9854 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9856 scm_c_issue_deprecation_warning
9857 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9861 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9865 scm_out_of_range (NULL
, num
);
9868 return scm_to_double (num
);
9872 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9874 scm_c_issue_deprecation_warning
9875 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9879 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9883 scm_out_of_range (NULL
, num
);
9886 return scm_to_double (num
);
9892 scm_is_complex (SCM val
)
9894 return scm_is_true (scm_complex_p (val
));
9898 scm_c_real_part (SCM z
)
9900 if (SCM_COMPLEXP (z
))
9901 return SCM_COMPLEX_REAL (z
);
9904 /* Use the scm_real_part to get proper error checking and
9907 return scm_to_double (scm_real_part (z
));
9912 scm_c_imag_part (SCM z
)
9914 if (SCM_COMPLEXP (z
))
9915 return SCM_COMPLEX_IMAG (z
);
9918 /* Use the scm_imag_part to get proper error checking and
9919 dispatching. The result will almost always be 0.0, but not
9922 return scm_to_double (scm_imag_part (z
));
9927 scm_c_magnitude (SCM z
)
9929 return scm_to_double (scm_magnitude (z
));
9935 return scm_to_double (scm_angle (z
));
9939 scm_is_number (SCM z
)
9941 return scm_is_true (scm_number_p (z
));
9945 /* Returns log(x * 2^shift) */
9947 log_of_shifted_double (double x
, long shift
)
9949 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9951 if (copysign (1.0, x
) > 0.0)
9952 return scm_i_from_double (ans
);
9954 return scm_c_make_rectangular (ans
, M_PI
);
9957 /* Returns log(n), for exact integer n */
9959 log_of_exact_integer (SCM n
)
9961 if (SCM_I_INUMP (n
))
9962 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9963 else if (SCM_BIGP (n
))
9966 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9967 return log_of_shifted_double (signif
, expon
);
9970 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9973 /* Returns log(n/d), for exact non-zero integers n and d */
9975 log_of_fraction (SCM n
, SCM d
)
9977 long n_size
= scm_to_long (scm_integer_length (n
));
9978 long d_size
= scm_to_long (scm_integer_length (d
));
9980 if (abs (n_size
- d_size
) > 1)
9981 return (scm_difference (log_of_exact_integer (n
),
9982 log_of_exact_integer (d
)));
9983 else if (scm_is_false (scm_negative_p (n
)))
9984 return scm_i_from_double
9985 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9987 return scm_c_make_rectangular
9988 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9994 /* In the following functions we dispatch to the real-arg funcs like log()
9995 when we know the arg is real, instead of just handing everything to
9996 clog() for instance. This is in case clog() doesn't optimize for a
9997 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9998 well use it to go straight to the applicable C func. */
10000 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
10002 "Return the natural logarithm of @var{z}.")
10003 #define FUNC_NAME s_scm_log
10005 if (SCM_COMPLEXP (z
))
10007 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
10008 && defined (SCM_COMPLEX_VALUE)
10009 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
10011 double re
= SCM_COMPLEX_REAL (z
);
10012 double im
= SCM_COMPLEX_IMAG (z
);
10013 return scm_c_make_rectangular (log (hypot (re
, im
)),
10017 else if (SCM_REALP (z
))
10018 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
10019 else if (SCM_I_INUMP (z
))
10021 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10022 if (scm_is_eq (z
, SCM_INUM0
))
10023 scm_num_overflow (s_scm_log
);
10025 return log_of_shifted_double (SCM_I_INUM (z
), 0);
10027 else if (SCM_BIGP (z
))
10028 return log_of_exact_integer (z
);
10029 else if (SCM_FRACTIONP (z
))
10030 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10031 SCM_FRACTION_DENOMINATOR (z
));
10033 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
10038 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10040 "Return the base 10 logarithm of @var{z}.")
10041 #define FUNC_NAME s_scm_log10
10043 if (SCM_COMPLEXP (z
))
10045 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10046 clog() and a multiply by M_LOG10E, rather than the fallback
10047 log10+hypot+atan2.) */
10048 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10049 && defined SCM_COMPLEX_VALUE
10050 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10052 double re
= SCM_COMPLEX_REAL (z
);
10053 double im
= SCM_COMPLEX_IMAG (z
);
10054 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10055 M_LOG10E
* atan2 (im
, re
));
10058 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10060 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10061 if (scm_is_eq (z
, SCM_INUM0
))
10062 scm_num_overflow (s_scm_log10
);
10065 double re
= scm_to_double (z
);
10066 double l
= log10 (fabs (re
));
10067 if (copysign (1.0, re
) > 0.0)
10068 return scm_i_from_double (l
);
10070 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10073 else if (SCM_BIGP (z
))
10074 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10075 else if (SCM_FRACTIONP (z
))
10076 return scm_product (flo_log10e
,
10077 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10078 SCM_FRACTION_DENOMINATOR (z
)));
10080 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10085 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10087 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10088 "base of natural logarithms (2.71828@dots{}).")
10089 #define FUNC_NAME s_scm_exp
10091 if (SCM_COMPLEXP (z
))
10093 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10094 && defined (SCM_COMPLEX_VALUE)
10095 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10097 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10098 SCM_COMPLEX_IMAG (z
));
10101 else if (SCM_NUMBERP (z
))
10103 /* When z is a negative bignum the conversion to double overflows,
10104 giving -infinity, but that's ok, the exp is still 0.0. */
10105 return scm_i_from_double (exp (scm_to_double (z
)));
10108 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10113 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10115 "Return two exact non-negative integers @var{s} and @var{r}\n"
10116 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10117 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10118 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10121 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10123 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10127 scm_exact_integer_sqrt (k
, &s
, &r
);
10128 return scm_values (scm_list_2 (s
, r
));
10133 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10135 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10139 if (SCM_I_INUM (k
) < 0)
10140 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10141 "exact non-negative integer");
10142 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10143 mpz_inits (ss
, rr
, NULL
);
10144 mpz_sqrtrem (ss
, rr
, kk
);
10145 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10146 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10147 mpz_clears (kk
, ss
, rr
, NULL
);
10149 else if (SCM_LIKELY (SCM_BIGP (k
)))
10153 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10154 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10155 "exact non-negative integer");
10156 s
= scm_i_mkbig ();
10157 r
= scm_i_mkbig ();
10158 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10159 scm_remember_upto_here_1 (k
);
10160 *sp
= scm_i_normbig (s
);
10161 *rp
= scm_i_normbig (r
);
10164 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10165 "exact non-negative integer");
10168 /* Return true iff K is a perfect square.
10169 K must be an exact integer. */
10171 exact_integer_is_perfect_square (SCM k
)
10175 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10179 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10180 result
= mpz_perfect_square_p (kk
);
10185 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10186 scm_remember_upto_here_1 (k
);
10191 /* Return the floor of the square root of K.
10192 K must be an exact integer. */
10194 exact_integer_floor_square_root (SCM k
)
10196 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10201 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10203 ss
= mpz_get_ui (kk
);
10205 return SCM_I_MAKINUM (ss
);
10211 s
= scm_i_mkbig ();
10212 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10213 scm_remember_upto_here_1 (k
);
10214 return scm_i_normbig (s
);
10219 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10221 "Return the square root of @var{z}. Of the two possible roots\n"
10222 "(positive and negative), the one with positive real part\n"
10223 "is returned, or if that's zero then a positive imaginary part.\n"
10227 "(sqrt 9.0) @result{} 3.0\n"
10228 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10229 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10230 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10232 #define FUNC_NAME s_scm_sqrt
10234 if (SCM_COMPLEXP (z
))
10236 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10237 && defined SCM_COMPLEX_VALUE
10238 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10240 double re
= SCM_COMPLEX_REAL (z
);
10241 double im
= SCM_COMPLEX_IMAG (z
);
10242 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10243 0.5 * atan2 (im
, re
));
10246 else if (SCM_NUMBERP (z
))
10248 if (SCM_I_INUMP (z
))
10250 scm_t_inum x
= SCM_I_INUM (z
);
10252 if (SCM_LIKELY (x
>= 0))
10254 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10255 || x
< (1L << (DBL_MANT_DIG
- 1))))
10257 double root
= sqrt (x
);
10259 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10260 integer, then the result is exact. */
10261 if (root
== floor (root
))
10262 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10264 return scm_i_from_double (root
);
10271 mpz_init_set_ui (xx
, x
);
10272 if (mpz_perfect_square_p (xx
))
10275 root
= mpz_get_ui (xx
);
10277 return SCM_I_MAKINUM (root
);
10284 else if (SCM_BIGP (z
))
10286 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10288 SCM root
= scm_i_mkbig ();
10290 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10291 scm_remember_upto_here_1 (z
);
10292 return scm_i_normbig (root
);
10297 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10305 return scm_c_make_rectangular
10306 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10308 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10311 else if (SCM_FRACTIONP (z
))
10313 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10314 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10316 if (exact_integer_is_perfect_square (n
)
10317 && exact_integer_is_perfect_square (d
))
10318 return scm_i_make_ratio_already_reduced
10319 (exact_integer_floor_square_root (n
),
10320 exact_integer_floor_square_root (d
));
10323 double xx
= scm_i_divide2double (n
, d
);
10324 double abs_xx
= fabs (xx
);
10327 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10329 shift
= (scm_to_long (scm_integer_length (n
))
10330 - scm_to_long (scm_integer_length (d
))) / 2;
10332 d
= left_shift_exact_integer (d
, 2 * shift
);
10334 n
= left_shift_exact_integer (n
, -2 * shift
);
10335 xx
= scm_i_divide2double (n
, d
);
10339 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10341 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10345 /* Fallback method, when the cases above do not apply. */
10347 double xx
= scm_to_double (z
);
10349 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10351 return scm_i_from_double (sqrt (xx
));
10355 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10362 scm_init_numbers ()
10364 if (scm_install_gmp_memory_functions
)
10365 mp_set_memory_functions (custom_gmp_malloc
,
10366 custom_gmp_realloc
,
10369 mpz_init_set_si (z_negative_one
, -1);
10371 /* It may be possible to tune the performance of some algorithms by using
10372 * the following constants to avoid the creation of bignums. Please, before
10373 * using these values, remember the two rules of program optimization:
10374 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10375 scm_c_define ("most-positive-fixnum",
10376 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10377 scm_c_define ("most-negative-fixnum",
10378 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10380 scm_add_feature ("complex");
10381 scm_add_feature ("inexact");
10382 flo0
= scm_i_from_double (0.0);
10383 flo_log10e
= scm_i_from_double (M_LOG10E
);
10385 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10388 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10389 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10390 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10391 scm_i_divide2double_lo2b
,
10392 DBL_MANT_DIG
+ 1); /* 2 b^p */
10393 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10397 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10398 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10399 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10400 dbl_minimum_normal_mantissa
,
10404 #include "libguile/numbers.x"
10409 c-file-style: "gnu"