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 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)". */
4989 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4990 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4992 return SCM_I_MAKINUM (nn
<< count
);
4995 SCM result
= scm_i_inum2big (nn
);
4996 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5001 else if (SCM_BIGP (n
))
5003 SCM result
= scm_i_mkbig ();
5004 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5005 scm_remember_upto_here_1 (n
);
5012 /* Efficiently compute floor (N / 2^COUNT),
5013 where N is an exact integer and COUNT > 0. */
5015 floor_right_shift_exact_integer (SCM n
, long count
)
5017 if (SCM_I_INUMP (n
))
5019 scm_t_inum nn
= SCM_I_INUM (n
);
5021 if (count
>= SCM_I_FIXNUM_BIT
)
5022 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5024 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5026 else if (SCM_BIGP (n
))
5028 SCM result
= scm_i_mkbig ();
5029 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5031 scm_remember_upto_here_1 (n
);
5032 return scm_i_normbig (result
);
5038 /* Efficiently compute round (N / 2^COUNT),
5039 where N is an exact integer and COUNT > 0. */
5041 round_right_shift_exact_integer (SCM n
, long count
)
5043 if (SCM_I_INUMP (n
))
5045 if (count
>= SCM_I_FIXNUM_BIT
)
5049 scm_t_inum nn
= SCM_I_INUM (n
);
5050 scm_t_inum qq
= SCM_SRS (nn
, count
);
5052 if (0 == (nn
& (1L << (count
-1))))
5053 return SCM_I_MAKINUM (qq
); /* round down */
5054 else if (nn
& ((1L << (count
-1)) - 1))
5055 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5057 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5060 else if (SCM_BIGP (n
))
5062 SCM q
= scm_i_mkbig ();
5064 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5065 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5066 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5067 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5068 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5069 scm_remember_upto_here_1 (n
);
5070 return scm_i_normbig (q
);
5076 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5078 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5079 "@var{n} and @var{count} must be exact integers.\n"
5081 "With @var{n} viewed as an infinite-precision twos-complement\n"
5082 "integer, @code{ash} means a left shift introducing zero bits\n"
5083 "when @var{count} is positive, or a right shift dropping bits\n"
5084 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5087 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5088 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5090 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5091 "(ash -23 -2) @result{} -6\n"
5093 #define FUNC_NAME s_scm_ash
5095 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5097 long bits_to_shift
= scm_to_long (count
);
5099 if (bits_to_shift
> 0)
5100 return left_shift_exact_integer (n
, bits_to_shift
);
5101 else if (SCM_LIKELY (bits_to_shift
< 0))
5102 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5107 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5111 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5113 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5114 "@var{n} and @var{count} must be exact integers.\n"
5116 "With @var{n} viewed as an infinite-precision twos-complement\n"
5117 "integer, @code{round-ash} means a left shift introducing zero\n"
5118 "bits when @var{count} is positive, or a right shift rounding\n"
5119 "to the nearest integer (with ties going to the nearest even\n"
5120 "integer) when @var{count} is negative. This is a rounded\n"
5121 "``arithmetic'' shift.\n"
5124 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5125 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5126 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5127 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5128 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5129 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5131 #define FUNC_NAME s_scm_round_ash
5133 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5135 long bits_to_shift
= scm_to_long (count
);
5137 if (bits_to_shift
> 0)
5138 return left_shift_exact_integer (n
, bits_to_shift
);
5139 else if (SCM_LIKELY (bits_to_shift
< 0))
5140 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5145 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5150 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5151 (SCM n
, SCM start
, SCM end
),
5152 "Return the integer composed of the @var{start} (inclusive)\n"
5153 "through @var{end} (exclusive) bits of @var{n}. The\n"
5154 "@var{start}th bit becomes the 0-th bit in the result.\n"
5157 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5158 " @result{} \"1010\"\n"
5159 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5160 " @result{} \"10110\"\n"
5162 #define FUNC_NAME s_scm_bit_extract
5164 unsigned long int istart
, iend
, bits
;
5165 istart
= scm_to_ulong (start
);
5166 iend
= scm_to_ulong (end
);
5167 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5169 /* how many bits to keep */
5170 bits
= iend
- istart
;
5172 if (SCM_I_INUMP (n
))
5174 scm_t_inum in
= SCM_I_INUM (n
);
5176 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5177 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5178 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5180 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5182 /* Since we emulate two's complement encoded numbers, this
5183 * special case requires us to produce a result that has
5184 * more bits than can be stored in a fixnum.
5186 SCM result
= scm_i_inum2big (in
);
5187 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5192 /* mask down to requisite bits */
5193 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5194 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5196 else if (SCM_BIGP (n
))
5201 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5205 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5206 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5207 such bits into a ulong. */
5208 result
= scm_i_mkbig ();
5209 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5210 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5211 result
= scm_i_normbig (result
);
5213 scm_remember_upto_here_1 (n
);
5217 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5222 static const char scm_logtab
[] = {
5223 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5226 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5228 "Return the number of bits in integer @var{n}. If integer is\n"
5229 "positive, the 1-bits in its binary representation are counted.\n"
5230 "If negative, the 0-bits in its two's-complement binary\n"
5231 "representation are counted. If 0, 0 is returned.\n"
5234 "(logcount #b10101010)\n"
5241 #define FUNC_NAME s_scm_logcount
5243 if (SCM_I_INUMP (n
))
5245 unsigned long c
= 0;
5246 scm_t_inum nn
= SCM_I_INUM (n
);
5251 c
+= scm_logtab
[15 & nn
];
5254 return SCM_I_MAKINUM (c
);
5256 else if (SCM_BIGP (n
))
5258 unsigned long count
;
5259 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5260 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5262 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5263 scm_remember_upto_here_1 (n
);
5264 return SCM_I_MAKINUM (count
);
5267 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5272 static const char scm_ilentab
[] = {
5273 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5277 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5279 "Return the number of bits necessary to represent @var{n}.\n"
5282 "(integer-length #b10101010)\n"
5284 "(integer-length 0)\n"
5286 "(integer-length #b1111)\n"
5289 #define FUNC_NAME s_scm_integer_length
5291 if (SCM_I_INUMP (n
))
5293 unsigned long c
= 0;
5295 scm_t_inum nn
= SCM_I_INUM (n
);
5301 l
= scm_ilentab
[15 & nn
];
5304 return SCM_I_MAKINUM (c
- 4 + l
);
5306 else if (SCM_BIGP (n
))
5308 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5309 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5310 1 too big, so check for that and adjust. */
5311 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5312 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5313 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5314 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5316 scm_remember_upto_here_1 (n
);
5317 return SCM_I_MAKINUM (size
);
5320 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5324 /*** NUMBERS -> STRINGS ***/
5325 #define SCM_MAX_DBL_RADIX 36
5327 /* use this array as a way to generate a single digit */
5328 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5330 static mpz_t dbl_minimum_normal_mantissa
;
5333 idbl2str (double dbl
, char *a
, int radix
)
5337 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5338 /* revert to existing behavior */
5343 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5353 else if (dbl
== 0.0)
5355 if (copysign (1.0, dbl
) < 0.0)
5357 strcpy (a
+ ch
, "0.0");
5360 else if (isnan (dbl
))
5362 strcpy (a
, "+nan.0");
5366 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5367 Accurately" by Robert G. Burger and R. Kent Dybvig */
5370 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5371 int f_is_even
, f_is_odd
;
5375 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5376 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5377 if (e
< DBL_MIN_EXP
)
5379 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5384 f_is_even
= !mpz_odd_p (f
);
5385 f_is_odd
= !f_is_even
;
5387 /* Initialize r, s, mplus, and mminus according
5388 to Table 1 from the paper. */
5391 mpz_set_ui (mminus
, 1);
5392 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5393 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5395 mpz_set_ui (mplus
, 1);
5396 mpz_mul_2exp (r
, f
, 1);
5397 mpz_mul_2exp (s
, mminus
, 1 - e
);
5401 mpz_set_ui (mplus
, 2);
5402 mpz_mul_2exp (r
, f
, 2);
5403 mpz_mul_2exp (s
, mminus
, 2 - e
);
5408 mpz_set_ui (mminus
, 1);
5409 mpz_mul_2exp (mminus
, mminus
, e
);
5410 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5412 mpz_set (mplus
, mminus
);
5413 mpz_mul_2exp (r
, f
, 1 + e
);
5418 mpz_mul_2exp (mplus
, mminus
, 1);
5419 mpz_mul_2exp (r
, f
, 2 + e
);
5424 /* Find the smallest k such that:
5425 (r + mplus) / s < radix^k (if f is even)
5426 (r + mplus) / s <= radix^k (if f is odd) */
5428 /* IMPROVE-ME: Make an initial guess to speed this up */
5429 mpz_add (hi
, r
, mplus
);
5431 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5433 mpz_mul_ui (s
, s
, radix
);
5438 mpz_mul_ui (hi
, hi
, radix
);
5439 while (mpz_cmp (hi
, s
) < f_is_odd
)
5441 mpz_mul_ui (r
, r
, radix
);
5442 mpz_mul_ui (mplus
, mplus
, radix
);
5443 mpz_mul_ui (mminus
, mminus
, radix
);
5444 mpz_mul_ui (hi
, hi
, radix
);
5455 /* Use scientific notation */
5463 /* Print leading zeroes */
5466 for (i
= 0; i
> k
; i
--)
5473 int end_1_p
, end_2_p
;
5476 mpz_mul_ui (mplus
, mplus
, radix
);
5477 mpz_mul_ui (mminus
, mminus
, radix
);
5478 mpz_mul_ui (r
, r
, radix
);
5479 mpz_fdiv_qr (digit
, r
, r
, s
);
5480 d
= mpz_get_ui (digit
);
5482 mpz_add (hi
, r
, mplus
);
5483 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5484 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5485 if (end_1_p
|| end_2_p
)
5487 mpz_mul_2exp (r
, r
, 1);
5492 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5494 a
[ch
++] = number_chars
[d
];
5501 a
[ch
++] = number_chars
[d
];
5509 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5511 /* Here we would have to print more than three zeroes
5512 followed by a decimal point and another zero. It
5513 makes more sense to use scientific notation. */
5515 /* Adjust k to what it would have been if we had chosen
5516 scientific notation from the beginning. */
5519 /* k will now be <= 0, with magnitude equal to the number of
5520 digits that we printed which should now be put after the
5523 /* Insert a decimal point */
5524 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5544 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5547 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5554 icmplx2str (double real
, double imag
, char *str
, int radix
)
5559 i
= idbl2str (real
, str
, radix
);
5560 #ifdef HAVE_COPYSIGN
5561 sgn
= copysign (1.0, imag
);
5565 /* Don't output a '+' for negative numbers or for Inf and
5566 NaN. They will provide their own sign. */
5567 if (sgn
>= 0 && isfinite (imag
))
5569 i
+= idbl2str (imag
, &str
[i
], radix
);
5575 iflo2str (SCM flt
, char *str
, int radix
)
5578 if (SCM_REALP (flt
))
5579 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5581 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5586 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5587 characters in the result.
5589 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5591 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5596 return scm_iuint2str (-num
, rad
, p
) + 1;
5599 return scm_iuint2str (num
, rad
, p
);
5602 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5603 characters in the result.
5605 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5607 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5611 scm_t_uintmax n
= num
;
5613 if (rad
< 2 || rad
> 36)
5614 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5616 for (n
/= rad
; n
> 0; n
/= rad
)
5626 p
[i
] = number_chars
[d
];
5631 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5633 "Return a string holding the external representation of the\n"
5634 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5635 "inexact, a radix of 10 will be used.")
5636 #define FUNC_NAME s_scm_number_to_string
5640 if (SCM_UNBNDP (radix
))
5643 base
= scm_to_signed_integer (radix
, 2, 36);
5645 if (SCM_I_INUMP (n
))
5647 char num_buf
[SCM_INTBUFLEN
];
5648 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5649 return scm_from_locale_stringn (num_buf
, length
);
5651 else if (SCM_BIGP (n
))
5653 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5654 size_t len
= strlen (str
);
5655 void (*freefunc
) (void *, size_t);
5657 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5658 scm_remember_upto_here_1 (n
);
5659 ret
= scm_from_latin1_stringn (str
, len
);
5660 freefunc (str
, len
+ 1);
5663 else if (SCM_FRACTIONP (n
))
5665 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5666 scm_from_locale_string ("/"),
5667 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5669 else if (SCM_INEXACTP (n
))
5671 char num_buf
[FLOBUFLEN
];
5672 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5675 SCM_WRONG_TYPE_ARG (1, n
);
5680 /* These print routines used to be stubbed here so that scm_repl.c
5681 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5684 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5686 char num_buf
[FLOBUFLEN
];
5687 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5692 scm_i_print_double (double val
, SCM port
)
5694 char num_buf
[FLOBUFLEN
];
5695 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5699 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5702 char num_buf
[FLOBUFLEN
];
5703 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5708 scm_i_print_complex (double real
, double imag
, SCM port
)
5710 char num_buf
[FLOBUFLEN
];
5711 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5715 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5718 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5719 scm_display (str
, port
);
5720 scm_remember_upto_here_1 (str
);
5725 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5727 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5728 size_t len
= strlen (str
);
5729 void (*freefunc
) (void *, size_t);
5730 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5731 scm_remember_upto_here_1 (exp
);
5732 scm_lfwrite (str
, len
, port
);
5733 freefunc (str
, len
+ 1);
5736 /*** END nums->strs ***/
5739 /*** STRINGS -> NUMBERS ***/
5741 /* The following functions implement the conversion from strings to numbers.
5742 * The implementation somehow follows the grammar for numbers as it is given
5743 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5744 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5745 * points should be noted about the implementation:
5747 * * Each function keeps a local index variable 'idx' that points at the
5748 * current position within the parsed string. The global index is only
5749 * updated if the function could parse the corresponding syntactic unit
5752 * * Similarly, the functions keep track of indicators of inexactness ('#',
5753 * '.' or exponents) using local variables ('hash_seen', 'x').
5755 * * Sequences of digits are parsed into temporary variables holding fixnums.
5756 * Only if these fixnums would overflow, the result variables are updated
5757 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5758 * the temporary variables holding the fixnums are cleared, and the process
5759 * starts over again. If for example fixnums were able to store five decimal
5760 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5761 * and the result was computed as 12345 * 100000 + 67890. In other words,
5762 * only every five digits two bignum operations were performed.
5764 * Notes on the handling of exactness specifiers:
5766 * When parsing non-real complex numbers, we apply exactness specifiers on
5767 * per-component basis, as is done in PLT Scheme. For complex numbers
5768 * written in rectangular form, exactness specifiers are applied to the
5769 * real and imaginary parts before calling scm_make_rectangular. For
5770 * complex numbers written in polar form, exactness specifiers are applied
5771 * to the magnitude and angle before calling scm_make_polar.
5773 * There are two kinds of exactness specifiers: forced and implicit. A
5774 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5775 * the entire number, and applies to both components of a complex number.
5776 * "#e" causes each component to be made exact, and "#i" causes each
5777 * component to be made inexact. If no forced exactness specifier is
5778 * present, then the exactness of each component is determined
5779 * independently by the presence or absence of a decimal point or hash mark
5780 * within that component. If a decimal point or hash mark is present, the
5781 * component is made inexact, otherwise it is made exact.
5783 * After the exactness specifiers have been applied to each component, they
5784 * are passed to either scm_make_rectangular or scm_make_polar to produce
5785 * the final result. Note that this will result in a real number if the
5786 * imaginary part, magnitude, or angle is an exact 0.
5788 * For example, (string->number "#i5.0+0i") does the equivalent of:
5790 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5793 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5795 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5797 /* Caller is responsible for checking that the return value is in range
5798 for the given radix, which should be <= 36. */
5800 char_decimal_value (scm_t_uint32 c
)
5802 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5803 that's certainly above any valid decimal, so we take advantage of
5804 that to elide some tests. */
5805 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5807 /* If that failed, try extended hexadecimals, then. Only accept ascii
5812 if (c
>= (scm_t_uint32
) 'a')
5813 d
= c
- (scm_t_uint32
)'a' + 10U;
5818 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5819 in base RADIX. Upon success, return the unsigned integer and update
5820 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5822 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5823 unsigned int radix
, enum t_exactness
*p_exactness
)
5825 unsigned int idx
= *p_idx
;
5826 unsigned int hash_seen
= 0;
5827 scm_t_bits shift
= 1;
5829 unsigned int digit_value
;
5832 size_t len
= scm_i_string_length (mem
);
5837 c
= scm_i_string_ref (mem
, idx
);
5838 digit_value
= char_decimal_value (c
);
5839 if (digit_value
>= radix
)
5843 result
= SCM_I_MAKINUM (digit_value
);
5846 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5856 digit_value
= char_decimal_value (c
);
5857 /* This check catches non-decimals in addition to out-of-range
5859 if (digit_value
>= radix
)
5864 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5866 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5868 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5875 shift
= shift
* radix
;
5876 add
= add
* radix
+ digit_value
;
5881 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5883 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5887 *p_exactness
= INEXACT
;
5893 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5894 * covers the parts of the rules that start at a potential point. The value
5895 * of the digits up to the point have been parsed by the caller and are given
5896 * in variable result. The content of *p_exactness indicates, whether a hash
5897 * has already been seen in the digits before the point.
5900 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5903 mem2decimal_from_point (SCM result
, SCM mem
,
5904 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5906 unsigned int idx
= *p_idx
;
5907 enum t_exactness x
= *p_exactness
;
5908 size_t len
= scm_i_string_length (mem
);
5913 if (scm_i_string_ref (mem
, idx
) == '.')
5915 scm_t_bits shift
= 1;
5917 unsigned int digit_value
;
5918 SCM big_shift
= SCM_INUM1
;
5923 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5924 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5929 digit_value
= DIGIT2UINT (c
);
5940 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5942 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5943 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5945 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5953 add
= add
* 10 + digit_value
;
5959 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5960 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5961 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5964 result
= scm_divide (result
, big_shift
);
5966 /* We've seen a decimal point, thus the value is implicitly inexact. */
5978 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5980 switch (scm_i_string_ref (mem
, idx
))
5992 c
= scm_i_string_ref (mem
, idx
);
6000 c
= scm_i_string_ref (mem
, idx
);
6009 c
= scm_i_string_ref (mem
, idx
);
6014 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6018 exponent
= DIGIT2UINT (c
);
6021 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6022 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6025 if (exponent
<= SCM_MAXEXP
)
6026 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6032 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6034 size_t exp_len
= idx
- start
;
6035 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6036 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6037 scm_out_of_range ("string->number", exp_num
);
6040 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6042 result
= scm_product (result
, e
);
6044 result
= scm_divide (result
, e
);
6046 /* We've seen an exponent, thus the value is implicitly inexact. */
6064 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6067 mem2ureal (SCM mem
, unsigned int *p_idx
,
6068 unsigned int radix
, enum t_exactness forced_x
,
6069 int allow_inf_or_nan
)
6071 unsigned int idx
= *p_idx
;
6073 size_t len
= scm_i_string_length (mem
);
6075 /* Start off believing that the number will be exact. This changes
6076 to INEXACT if we see a decimal point or a hash. */
6077 enum t_exactness implicit_x
= EXACT
;
6082 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6083 switch (scm_i_string_ref (mem
, idx
))
6086 switch (scm_i_string_ref (mem
, idx
+ 1))
6089 switch (scm_i_string_ref (mem
, idx
+ 2))
6092 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6093 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6101 switch (scm_i_string_ref (mem
, idx
+ 1))
6104 switch (scm_i_string_ref (mem
, idx
+ 2))
6107 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6109 /* Cobble up the fractional part. We might want to
6110 set the NaN's mantissa from it. */
6112 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6115 #if SCM_ENABLE_DEPRECATED == 1
6116 scm_c_issue_deprecation_warning
6117 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6130 if (scm_i_string_ref (mem
, idx
) == '.')
6134 else if (idx
+ 1 == len
)
6136 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6139 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6140 p_idx
, &implicit_x
);
6146 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6147 if (scm_is_false (uinteger
))
6152 else if (scm_i_string_ref (mem
, idx
) == '/')
6160 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6161 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6164 /* both are int/big here, I assume */
6165 result
= scm_i_make_ratio (uinteger
, divisor
);
6167 else if (radix
== 10)
6169 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6170 if (scm_is_false (result
))
6182 if (SCM_INEXACTP (result
))
6183 return scm_inexact_to_exact (result
);
6187 if (SCM_INEXACTP (result
))
6190 return scm_exact_to_inexact (result
);
6192 if (implicit_x
== INEXACT
)
6194 if (SCM_INEXACTP (result
))
6197 return scm_exact_to_inexact (result
);
6203 /* We should never get here */
6208 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6211 mem2complex (SCM mem
, unsigned int idx
,
6212 unsigned int radix
, enum t_exactness forced_x
)
6217 size_t len
= scm_i_string_length (mem
);
6222 c
= scm_i_string_ref (mem
, idx
);
6237 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6238 if (scm_is_false (ureal
))
6240 /* input must be either +i or -i */
6245 if (scm_i_string_ref (mem
, idx
) == 'i'
6246 || scm_i_string_ref (mem
, idx
) == 'I')
6252 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6259 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6260 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6265 c
= scm_i_string_ref (mem
, idx
);
6269 /* either +<ureal>i or -<ureal>i */
6276 return scm_make_rectangular (SCM_INUM0
, ureal
);
6279 /* polar input: <real>@<real>. */
6290 c
= scm_i_string_ref (mem
, idx
);
6308 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6309 if (scm_is_false (angle
))
6314 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6315 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6317 result
= scm_make_polar (ureal
, angle
);
6322 /* expecting input matching <real>[+-]<ureal>?i */
6329 int sign
= (c
== '+') ? 1 : -1;
6330 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6332 if (scm_is_false (imag
))
6333 imag
= SCM_I_MAKINUM (sign
);
6334 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6335 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6339 if (scm_i_string_ref (mem
, idx
) != 'i'
6340 && scm_i_string_ref (mem
, idx
) != 'I')
6347 return scm_make_rectangular (ureal
, imag
);
6356 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6358 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6361 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6363 unsigned int idx
= 0;
6364 unsigned int radix
= NO_RADIX
;
6365 enum t_exactness forced_x
= NO_EXACTNESS
;
6366 size_t len
= scm_i_string_length (mem
);
6368 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6369 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6371 switch (scm_i_string_ref (mem
, idx
+ 1))
6374 if (radix
!= NO_RADIX
)
6379 if (radix
!= NO_RADIX
)
6384 if (forced_x
!= NO_EXACTNESS
)
6389 if (forced_x
!= NO_EXACTNESS
)
6394 if (radix
!= NO_RADIX
)
6399 if (radix
!= NO_RADIX
)
6409 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6410 if (radix
== NO_RADIX
)
6411 radix
= default_radix
;
6413 return mem2complex (mem
, idx
, radix
, forced_x
);
6417 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6418 unsigned int default_radix
)
6420 SCM str
= scm_from_locale_stringn (mem
, len
);
6422 return scm_i_string_to_number (str
, default_radix
);
6426 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6427 (SCM string
, SCM radix
),
6428 "Return a number of the maximally precise representation\n"
6429 "expressed by the given @var{string}. @var{radix} must be an\n"
6430 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6431 "is a default radix that may be overridden by an explicit radix\n"
6432 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6433 "supplied, then the default radix is 10. If string is not a\n"
6434 "syntactically valid notation for a number, then\n"
6435 "@code{string->number} returns @code{#f}.")
6436 #define FUNC_NAME s_scm_string_to_number
6440 SCM_VALIDATE_STRING (1, string
);
6442 if (SCM_UNBNDP (radix
))
6445 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6447 answer
= scm_i_string_to_number (string
, base
);
6448 scm_remember_upto_here_1 (string
);
6454 /*** END strs->nums ***/
6457 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6459 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6461 #define FUNC_NAME s_scm_number_p
6463 return scm_from_bool (SCM_NUMBERP (x
));
6467 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6469 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6470 "otherwise. Note that the sets of real, rational and integer\n"
6471 "values form subsets of the set of complex numbers, i. e. the\n"
6472 "predicate will also be fulfilled if @var{x} is a real,\n"
6473 "rational or integer number.")
6474 #define FUNC_NAME s_scm_complex_p
6476 /* all numbers are complex. */
6477 return scm_number_p (x
);
6481 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6483 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6484 "otherwise. Note that the set of integer values forms a subset of\n"
6485 "the set of real numbers, i. e. the predicate will also be\n"
6486 "fulfilled if @var{x} is an integer number.")
6487 #define FUNC_NAME s_scm_real_p
6489 return scm_from_bool
6490 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6494 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6496 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6497 "otherwise. Note that the set of integer values forms a subset of\n"
6498 "the set of rational numbers, i. e. the predicate will also be\n"
6499 "fulfilled if @var{x} is an integer number.")
6500 #define FUNC_NAME s_scm_rational_p
6502 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6504 else if (SCM_REALP (x
))
6505 /* due to their limited precision, finite floating point numbers are
6506 rational as well. (finite means neither infinity nor a NaN) */
6507 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6513 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6515 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6517 #define FUNC_NAME s_scm_integer_p
6519 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6521 else if (SCM_REALP (x
))
6523 double val
= SCM_REAL_VALUE (x
);
6524 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6532 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6533 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6534 (SCM x
, SCM y
, SCM rest
),
6535 "Return @code{#t} if all parameters are numerically equal.")
6536 #define FUNC_NAME s_scm_i_num_eq_p
6538 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6540 while (!scm_is_null (rest
))
6542 if (scm_is_false (scm_num_eq_p (x
, y
)))
6546 rest
= scm_cdr (rest
);
6548 return scm_num_eq_p (x
, y
);
6552 scm_num_eq_p (SCM x
, SCM y
)
6555 if (SCM_I_INUMP (x
))
6557 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6558 if (SCM_I_INUMP (y
))
6560 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6561 return scm_from_bool (xx
== yy
);
6563 else if (SCM_BIGP (y
))
6565 else if (SCM_REALP (y
))
6567 /* On a 32-bit system an inum fits a double, we can cast the inum
6568 to a double and compare.
6570 But on a 64-bit system an inum is bigger than a double and
6571 casting it to a double (call that dxx) will round.
6572 Although dxx will not in general be equal to xx, dxx will
6573 always be an integer and within a factor of 2 of xx, so if
6574 dxx==yy, we know that yy is an integer and fits in
6575 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6576 compare with plain xx.
6578 An alternative (for any size system actually) would be to check
6579 yy is an integer (with floor) and is in range of an inum
6580 (compare against appropriate powers of 2) then test
6581 xx==(scm_t_signed_bits)yy. It's just a matter of which
6582 casts/comparisons might be fastest or easiest for the cpu. */
6584 double yy
= SCM_REAL_VALUE (y
);
6585 return scm_from_bool ((double) xx
== yy
6586 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6587 || xx
== (scm_t_signed_bits
) yy
));
6589 else if (SCM_COMPLEXP (y
))
6591 /* see comments with inum/real above */
6592 double ry
= SCM_COMPLEX_REAL (y
);
6593 return scm_from_bool ((double) xx
== ry
6594 && 0.0 == SCM_COMPLEX_IMAG (y
)
6595 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6596 || xx
== (scm_t_signed_bits
) ry
));
6598 else if (SCM_FRACTIONP (y
))
6601 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6603 else if (SCM_BIGP (x
))
6605 if (SCM_I_INUMP (y
))
6607 else if (SCM_BIGP (y
))
6609 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6610 scm_remember_upto_here_2 (x
, y
);
6611 return scm_from_bool (0 == cmp
);
6613 else if (SCM_REALP (y
))
6616 if (isnan (SCM_REAL_VALUE (y
)))
6618 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6619 scm_remember_upto_here_1 (x
);
6620 return scm_from_bool (0 == cmp
);
6622 else if (SCM_COMPLEXP (y
))
6625 if (0.0 != SCM_COMPLEX_IMAG (y
))
6627 if (isnan (SCM_COMPLEX_REAL (y
)))
6629 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6630 scm_remember_upto_here_1 (x
);
6631 return scm_from_bool (0 == cmp
);
6633 else if (SCM_FRACTIONP (y
))
6636 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6638 else if (SCM_REALP (x
))
6640 double xx
= SCM_REAL_VALUE (x
);
6641 if (SCM_I_INUMP (y
))
6643 /* see comments with inum/real above */
6644 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6645 return scm_from_bool (xx
== (double) yy
6646 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6647 || (scm_t_signed_bits
) xx
== yy
));
6649 else if (SCM_BIGP (y
))
6654 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6655 scm_remember_upto_here_1 (y
);
6656 return scm_from_bool (0 == cmp
);
6658 else if (SCM_REALP (y
))
6659 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6660 else if (SCM_COMPLEXP (y
))
6661 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6662 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6663 else if (SCM_FRACTIONP (y
))
6665 if (isnan (xx
) || isinf (xx
))
6667 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6671 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6673 else if (SCM_COMPLEXP (x
))
6675 if (SCM_I_INUMP (y
))
6677 /* see comments with inum/real above */
6678 double rx
= SCM_COMPLEX_REAL (x
);
6679 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6680 return scm_from_bool (rx
== (double) yy
6681 && 0.0 == SCM_COMPLEX_IMAG (x
)
6682 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6683 || (scm_t_signed_bits
) rx
== yy
));
6685 else if (SCM_BIGP (y
))
6688 if (0.0 != SCM_COMPLEX_IMAG (x
))
6690 if (isnan (SCM_COMPLEX_REAL (x
)))
6692 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6693 scm_remember_upto_here_1 (y
);
6694 return scm_from_bool (0 == cmp
);
6696 else if (SCM_REALP (y
))
6697 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6698 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6699 else if (SCM_COMPLEXP (y
))
6700 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6701 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6702 else if (SCM_FRACTIONP (y
))
6705 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6707 xx
= SCM_COMPLEX_REAL (x
);
6708 if (isnan (xx
) || isinf (xx
))
6710 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6714 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6716 else if (SCM_FRACTIONP (x
))
6718 if (SCM_I_INUMP (y
))
6720 else if (SCM_BIGP (y
))
6722 else if (SCM_REALP (y
))
6724 double yy
= SCM_REAL_VALUE (y
);
6725 if (isnan (yy
) || isinf (yy
))
6727 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6730 else if (SCM_COMPLEXP (y
))
6733 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6735 yy
= SCM_COMPLEX_REAL (y
);
6736 if (isnan (yy
) || isinf(yy
))
6738 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6741 else if (SCM_FRACTIONP (y
))
6742 return scm_i_fraction_equalp (x
, y
);
6744 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6747 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6751 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6752 done are good for inums, but for bignums an answer can almost always be
6753 had by just examining a few high bits of the operands, as done by GMP in
6754 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6755 of the float exponent to take into account. */
6757 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6758 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6759 (SCM x
, SCM y
, SCM rest
),
6760 "Return @code{#t} if the list of parameters is monotonically\n"
6762 #define FUNC_NAME s_scm_i_num_less_p
6764 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6766 while (!scm_is_null (rest
))
6768 if (scm_is_false (scm_less_p (x
, y
)))
6772 rest
= scm_cdr (rest
);
6774 return scm_less_p (x
, y
);
6778 scm_less_p (SCM x
, SCM y
)
6781 if (SCM_I_INUMP (x
))
6783 scm_t_inum xx
= SCM_I_INUM (x
);
6784 if (SCM_I_INUMP (y
))
6786 scm_t_inum yy
= SCM_I_INUM (y
);
6787 return scm_from_bool (xx
< yy
);
6789 else if (SCM_BIGP (y
))
6791 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6792 scm_remember_upto_here_1 (y
);
6793 return scm_from_bool (sgn
> 0);
6795 else if (SCM_REALP (y
))
6797 /* We can safely take the ceiling of y without changing the
6798 result of x<y, given that x is an integer. */
6799 double yy
= ceil (SCM_REAL_VALUE (y
));
6801 /* In the following comparisons, it's important that the right
6802 hand side always be a power of 2, so that it can be
6803 losslessly converted to a double even on 64-bit
6805 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6807 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6808 /* The condition above is carefully written to include the
6809 case where yy==NaN. */
6812 /* yy is a finite integer that fits in an inum. */
6813 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6815 else if (SCM_FRACTIONP (y
))
6817 /* "x < a/b" becomes "x*b < a" */
6819 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6820 y
= SCM_FRACTION_NUMERATOR (y
);
6824 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6826 else if (SCM_BIGP (x
))
6828 if (SCM_I_INUMP (y
))
6830 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6831 scm_remember_upto_here_1 (x
);
6832 return scm_from_bool (sgn
< 0);
6834 else if (SCM_BIGP (y
))
6836 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6837 scm_remember_upto_here_2 (x
, y
);
6838 return scm_from_bool (cmp
< 0);
6840 else if (SCM_REALP (y
))
6843 if (isnan (SCM_REAL_VALUE (y
)))
6845 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6846 scm_remember_upto_here_1 (x
);
6847 return scm_from_bool (cmp
< 0);
6849 else if (SCM_FRACTIONP (y
))
6852 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6854 else if (SCM_REALP (x
))
6856 if (SCM_I_INUMP (y
))
6858 /* We can safely take the floor of x without changing the
6859 result of x<y, given that y is an integer. */
6860 double xx
= floor (SCM_REAL_VALUE (x
));
6862 /* In the following comparisons, it's important that the right
6863 hand side always be a power of 2, so that it can be
6864 losslessly converted to a double even on 64-bit
6866 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6868 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6869 /* The condition above is carefully written to include the
6870 case where xx==NaN. */
6873 /* xx is a finite integer that fits in an inum. */
6874 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6876 else if (SCM_BIGP (y
))
6879 if (isnan (SCM_REAL_VALUE (x
)))
6881 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6882 scm_remember_upto_here_1 (y
);
6883 return scm_from_bool (cmp
> 0);
6885 else if (SCM_REALP (y
))
6886 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6887 else if (SCM_FRACTIONP (y
))
6889 double xx
= SCM_REAL_VALUE (x
);
6893 return scm_from_bool (xx
< 0.0);
6894 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6898 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6900 else if (SCM_FRACTIONP (x
))
6902 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6904 /* "a/b < y" becomes "a < y*b" */
6905 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6906 x
= SCM_FRACTION_NUMERATOR (x
);
6909 else if (SCM_REALP (y
))
6911 double yy
= SCM_REAL_VALUE (y
);
6915 return scm_from_bool (0.0 < yy
);
6916 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6919 else if (SCM_FRACTIONP (y
))
6921 /* "a/b < c/d" becomes "a*d < c*b" */
6922 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6923 SCM_FRACTION_DENOMINATOR (y
));
6924 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6925 SCM_FRACTION_DENOMINATOR (x
));
6931 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6934 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6938 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6939 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6940 (SCM x
, SCM y
, SCM rest
),
6941 "Return @code{#t} if the list of parameters is monotonically\n"
6943 #define FUNC_NAME s_scm_i_num_gr_p
6945 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6947 while (!scm_is_null (rest
))
6949 if (scm_is_false (scm_gr_p (x
, y
)))
6953 rest
= scm_cdr (rest
);
6955 return scm_gr_p (x
, y
);
6958 #define FUNC_NAME s_scm_i_num_gr_p
6960 scm_gr_p (SCM x
, SCM y
)
6962 if (!SCM_NUMBERP (x
))
6963 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6964 else if (!SCM_NUMBERP (y
))
6965 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6967 return scm_less_p (y
, x
);
6972 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6973 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6974 (SCM x
, SCM y
, SCM rest
),
6975 "Return @code{#t} if the list of parameters is monotonically\n"
6977 #define FUNC_NAME s_scm_i_num_leq_p
6979 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6981 while (!scm_is_null (rest
))
6983 if (scm_is_false (scm_leq_p (x
, y
)))
6987 rest
= scm_cdr (rest
);
6989 return scm_leq_p (x
, y
);
6992 #define FUNC_NAME s_scm_i_num_leq_p
6994 scm_leq_p (SCM x
, SCM y
)
6996 if (!SCM_NUMBERP (x
))
6997 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6998 else if (!SCM_NUMBERP (y
))
6999 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7000 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7003 return scm_not (scm_less_p (y
, x
));
7008 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7009 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7010 (SCM x
, SCM y
, SCM rest
),
7011 "Return @code{#t} if the list of parameters is monotonically\n"
7013 #define FUNC_NAME s_scm_i_num_geq_p
7015 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7017 while (!scm_is_null (rest
))
7019 if (scm_is_false (scm_geq_p (x
, y
)))
7023 rest
= scm_cdr (rest
);
7025 return scm_geq_p (x
, y
);
7028 #define FUNC_NAME s_scm_i_num_geq_p
7030 scm_geq_p (SCM x
, SCM y
)
7032 if (!SCM_NUMBERP (x
))
7033 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7034 else if (!SCM_NUMBERP (y
))
7035 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7036 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7039 return scm_not (scm_less_p (x
, y
));
7044 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7046 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7048 #define FUNC_NAME s_scm_zero_p
7050 if (SCM_I_INUMP (z
))
7051 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7052 else if (SCM_BIGP (z
))
7054 else if (SCM_REALP (z
))
7055 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7056 else if (SCM_COMPLEXP (z
))
7057 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7058 && SCM_COMPLEX_IMAG (z
) == 0.0);
7059 else if (SCM_FRACTIONP (z
))
7062 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7067 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7069 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7071 #define FUNC_NAME s_scm_positive_p
7073 if (SCM_I_INUMP (x
))
7074 return scm_from_bool (SCM_I_INUM (x
) > 0);
7075 else if (SCM_BIGP (x
))
7077 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7078 scm_remember_upto_here_1 (x
);
7079 return scm_from_bool (sgn
> 0);
7081 else if (SCM_REALP (x
))
7082 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7083 else if (SCM_FRACTIONP (x
))
7084 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7086 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7091 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7093 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7095 #define FUNC_NAME s_scm_negative_p
7097 if (SCM_I_INUMP (x
))
7098 return scm_from_bool (SCM_I_INUM (x
) < 0);
7099 else if (SCM_BIGP (x
))
7101 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7102 scm_remember_upto_here_1 (x
);
7103 return scm_from_bool (sgn
< 0);
7105 else if (SCM_REALP (x
))
7106 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7107 else if (SCM_FRACTIONP (x
))
7108 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7110 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7115 /* scm_min and scm_max return an inexact when either argument is inexact, as
7116 required by r5rs. On that basis, for exact/inexact combinations the
7117 exact is converted to inexact to compare and possibly return. This is
7118 unlike scm_less_p above which takes some trouble to preserve all bits in
7119 its test, such trouble is not required for min and max. */
7121 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7122 (SCM x
, SCM y
, SCM rest
),
7123 "Return the maximum of all parameter values.")
7124 #define FUNC_NAME s_scm_i_max
7126 while (!scm_is_null (rest
))
7127 { x
= scm_max (x
, y
);
7129 rest
= scm_cdr (rest
);
7131 return scm_max (x
, y
);
7135 #define s_max s_scm_i_max
7136 #define g_max g_scm_i_max
7139 scm_max (SCM x
, SCM y
)
7144 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7145 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7148 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7151 if (SCM_I_INUMP (x
))
7153 scm_t_inum xx
= SCM_I_INUM (x
);
7154 if (SCM_I_INUMP (y
))
7156 scm_t_inum yy
= SCM_I_INUM (y
);
7157 return (xx
< yy
) ? y
: x
;
7159 else if (SCM_BIGP (y
))
7161 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7162 scm_remember_upto_here_1 (y
);
7163 return (sgn
< 0) ? x
: y
;
7165 else if (SCM_REALP (y
))
7168 double yyd
= SCM_REAL_VALUE (y
);
7171 return scm_i_from_double (xxd
);
7172 /* If y is a NaN, then "==" is false and we return the NaN */
7173 else if (SCM_LIKELY (!(xxd
== yyd
)))
7175 /* Handle signed zeroes properly */
7181 else if (SCM_FRACTIONP (y
))
7184 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7187 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7189 else if (SCM_BIGP (x
))
7191 if (SCM_I_INUMP (y
))
7193 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7194 scm_remember_upto_here_1 (x
);
7195 return (sgn
< 0) ? y
: x
;
7197 else if (SCM_BIGP (y
))
7199 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7200 scm_remember_upto_here_2 (x
, y
);
7201 return (cmp
> 0) ? x
: y
;
7203 else if (SCM_REALP (y
))
7205 /* if y==NaN then xx>yy is false, so we return the NaN y */
7208 xx
= scm_i_big2dbl (x
);
7209 yy
= SCM_REAL_VALUE (y
);
7210 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7212 else if (SCM_FRACTIONP (y
))
7217 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7219 else if (SCM_REALP (x
))
7221 if (SCM_I_INUMP (y
))
7223 scm_t_inum yy
= SCM_I_INUM (y
);
7224 double xxd
= SCM_REAL_VALUE (x
);
7228 return scm_i_from_double (yyd
);
7229 /* If x is a NaN, then "==" is false and we return the NaN */
7230 else if (SCM_LIKELY (!(xxd
== yyd
)))
7232 /* Handle signed zeroes properly */
7238 else if (SCM_BIGP (y
))
7243 else if (SCM_REALP (y
))
7245 double xx
= SCM_REAL_VALUE (x
);
7246 double yy
= SCM_REAL_VALUE (y
);
7248 /* For purposes of max: nan > +inf.0 > everything else,
7249 per the R6RS errata */
7252 else if (SCM_LIKELY (xx
< yy
))
7254 /* If neither (xx > yy) nor (xx < yy), then
7255 either they're equal or one is a NaN */
7256 else if (SCM_UNLIKELY (xx
!= yy
))
7257 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7258 /* xx == yy, but handle signed zeroes properly */
7259 else if (copysign (1.0, yy
) < 0.0)
7264 else if (SCM_FRACTIONP (y
))
7266 double yy
= scm_i_fraction2double (y
);
7267 double xx
= SCM_REAL_VALUE (x
);
7268 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7271 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7273 else if (SCM_FRACTIONP (x
))
7275 if (SCM_I_INUMP (y
))
7279 else if (SCM_BIGP (y
))
7283 else if (SCM_REALP (y
))
7285 double xx
= scm_i_fraction2double (x
);
7286 /* if y==NaN then ">" is false, so we return the NaN y */
7287 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7289 else if (SCM_FRACTIONP (y
))
7294 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7297 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7301 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7302 (SCM x
, SCM y
, SCM rest
),
7303 "Return the minimum of all parameter values.")
7304 #define FUNC_NAME s_scm_i_min
7306 while (!scm_is_null (rest
))
7307 { x
= scm_min (x
, y
);
7309 rest
= scm_cdr (rest
);
7311 return scm_min (x
, y
);
7315 #define s_min s_scm_i_min
7316 #define g_min g_scm_i_min
7319 scm_min (SCM x
, SCM y
)
7324 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7325 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7328 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7331 if (SCM_I_INUMP (x
))
7333 scm_t_inum xx
= SCM_I_INUM (x
);
7334 if (SCM_I_INUMP (y
))
7336 scm_t_inum yy
= SCM_I_INUM (y
);
7337 return (xx
< yy
) ? x
: y
;
7339 else if (SCM_BIGP (y
))
7341 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7342 scm_remember_upto_here_1 (y
);
7343 return (sgn
< 0) ? y
: x
;
7345 else if (SCM_REALP (y
))
7348 /* if y==NaN then "<" is false and we return NaN */
7349 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7351 else if (SCM_FRACTIONP (y
))
7354 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7357 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7359 else if (SCM_BIGP (x
))
7361 if (SCM_I_INUMP (y
))
7363 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7364 scm_remember_upto_here_1 (x
);
7365 return (sgn
< 0) ? x
: y
;
7367 else if (SCM_BIGP (y
))
7369 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7370 scm_remember_upto_here_2 (x
, y
);
7371 return (cmp
> 0) ? y
: x
;
7373 else if (SCM_REALP (y
))
7375 /* if y==NaN then xx<yy is false, so we return the NaN y */
7378 xx
= scm_i_big2dbl (x
);
7379 yy
= SCM_REAL_VALUE (y
);
7380 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7382 else if (SCM_FRACTIONP (y
))
7387 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7389 else if (SCM_REALP (x
))
7391 if (SCM_I_INUMP (y
))
7393 double z
= SCM_I_INUM (y
);
7394 /* if x==NaN then "<" is false and we return NaN */
7395 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7397 else if (SCM_BIGP (y
))
7402 else if (SCM_REALP (y
))
7404 double xx
= SCM_REAL_VALUE (x
);
7405 double yy
= SCM_REAL_VALUE (y
);
7407 /* For purposes of min: nan < -inf.0 < everything else,
7408 per the R6RS errata */
7411 else if (SCM_LIKELY (xx
> yy
))
7413 /* If neither (xx < yy) nor (xx > yy), then
7414 either they're equal or one is a NaN */
7415 else if (SCM_UNLIKELY (xx
!= yy
))
7416 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7417 /* xx == yy, but handle signed zeroes properly */
7418 else if (copysign (1.0, xx
) < 0.0)
7423 else if (SCM_FRACTIONP (y
))
7425 double yy
= scm_i_fraction2double (y
);
7426 double xx
= SCM_REAL_VALUE (x
);
7427 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7430 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7432 else if (SCM_FRACTIONP (x
))
7434 if (SCM_I_INUMP (y
))
7438 else if (SCM_BIGP (y
))
7442 else if (SCM_REALP (y
))
7444 double xx
= scm_i_fraction2double (x
);
7445 /* if y==NaN then "<" is false, so we return the NaN y */
7446 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7448 else if (SCM_FRACTIONP (y
))
7453 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7456 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7460 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7461 (SCM x
, SCM y
, SCM rest
),
7462 "Return the sum of all parameter values. Return 0 if called without\n"
7464 #define FUNC_NAME s_scm_i_sum
7466 while (!scm_is_null (rest
))
7467 { x
= scm_sum (x
, y
);
7469 rest
= scm_cdr (rest
);
7471 return scm_sum (x
, y
);
7475 #define s_sum s_scm_i_sum
7476 #define g_sum g_scm_i_sum
7479 scm_sum (SCM x
, SCM y
)
7481 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7483 if (SCM_NUMBERP (x
)) return x
;
7484 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7485 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7488 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7490 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7492 scm_t_inum xx
= SCM_I_INUM (x
);
7493 scm_t_inum yy
= SCM_I_INUM (y
);
7494 scm_t_inum z
= xx
+ yy
;
7495 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7497 else if (SCM_BIGP (y
))
7502 else if (SCM_REALP (y
))
7504 scm_t_inum xx
= SCM_I_INUM (x
);
7505 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7507 else if (SCM_COMPLEXP (y
))
7509 scm_t_inum xx
= SCM_I_INUM (x
);
7510 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7511 SCM_COMPLEX_IMAG (y
));
7513 else if (SCM_FRACTIONP (y
))
7514 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7515 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7516 SCM_FRACTION_DENOMINATOR (y
));
7518 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7519 } else if (SCM_BIGP (x
))
7521 if (SCM_I_INUMP (y
))
7526 inum
= SCM_I_INUM (y
);
7529 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7532 SCM result
= scm_i_mkbig ();
7533 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7534 scm_remember_upto_here_1 (x
);
7535 /* we know the result will have to be a bignum */
7538 return scm_i_normbig (result
);
7542 SCM result
= scm_i_mkbig ();
7543 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7544 scm_remember_upto_here_1 (x
);
7545 /* we know the result will have to be a bignum */
7548 return scm_i_normbig (result
);
7551 else if (SCM_BIGP (y
))
7553 SCM result
= scm_i_mkbig ();
7554 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7555 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7556 mpz_add (SCM_I_BIG_MPZ (result
),
7559 scm_remember_upto_here_2 (x
, y
);
7560 /* we know the result will have to be a bignum */
7563 return scm_i_normbig (result
);
7565 else if (SCM_REALP (y
))
7567 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7568 scm_remember_upto_here_1 (x
);
7569 return scm_i_from_double (result
);
7571 else if (SCM_COMPLEXP (y
))
7573 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7574 + SCM_COMPLEX_REAL (y
));
7575 scm_remember_upto_here_1 (x
);
7576 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7578 else if (SCM_FRACTIONP (y
))
7579 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7580 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7581 SCM_FRACTION_DENOMINATOR (y
));
7583 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7585 else if (SCM_REALP (x
))
7587 if (SCM_I_INUMP (y
))
7588 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7589 else if (SCM_BIGP (y
))
7591 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7592 scm_remember_upto_here_1 (y
);
7593 return scm_i_from_double (result
);
7595 else if (SCM_REALP (y
))
7596 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7597 else if (SCM_COMPLEXP (y
))
7598 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7599 SCM_COMPLEX_IMAG (y
));
7600 else if (SCM_FRACTIONP (y
))
7601 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7603 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7605 else if (SCM_COMPLEXP (x
))
7607 if (SCM_I_INUMP (y
))
7608 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7609 SCM_COMPLEX_IMAG (x
));
7610 else if (SCM_BIGP (y
))
7612 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7613 + SCM_COMPLEX_REAL (x
));
7614 scm_remember_upto_here_1 (y
);
7615 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7617 else if (SCM_REALP (y
))
7618 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7619 SCM_COMPLEX_IMAG (x
));
7620 else if (SCM_COMPLEXP (y
))
7621 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7622 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7623 else if (SCM_FRACTIONP (y
))
7624 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7625 SCM_COMPLEX_IMAG (x
));
7627 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7629 else if (SCM_FRACTIONP (x
))
7631 if (SCM_I_INUMP (y
))
7632 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7633 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7634 SCM_FRACTION_DENOMINATOR (x
));
7635 else if (SCM_BIGP (y
))
7636 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7637 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7638 SCM_FRACTION_DENOMINATOR (x
));
7639 else if (SCM_REALP (y
))
7640 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7641 else if (SCM_COMPLEXP (y
))
7642 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7643 SCM_COMPLEX_IMAG (y
));
7644 else if (SCM_FRACTIONP (y
))
7645 /* a/b + c/d = (ad + bc) / bd */
7646 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7647 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7648 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7650 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7653 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7657 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7659 "Return @math{@var{x}+1}.")
7660 #define FUNC_NAME s_scm_oneplus
7662 return scm_sum (x
, SCM_INUM1
);
7667 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7668 (SCM x
, SCM y
, SCM rest
),
7669 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7670 "the sum of all but the first argument are subtracted from the first\n"
7672 #define FUNC_NAME s_scm_i_difference
7674 while (!scm_is_null (rest
))
7675 { x
= scm_difference (x
, y
);
7677 rest
= scm_cdr (rest
);
7679 return scm_difference (x
, y
);
7683 #define s_difference s_scm_i_difference
7684 #define g_difference g_scm_i_difference
7687 scm_difference (SCM x
, SCM y
)
7688 #define FUNC_NAME s_difference
7690 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7693 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7695 if (SCM_I_INUMP (x
))
7697 scm_t_inum xx
= -SCM_I_INUM (x
);
7698 if (SCM_FIXABLE (xx
))
7699 return SCM_I_MAKINUM (xx
);
7701 return scm_i_inum2big (xx
);
7703 else if (SCM_BIGP (x
))
7704 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7705 bignum, but negating that gives a fixnum. */
7706 return scm_i_normbig (scm_i_clonebig (x
, 0));
7707 else if (SCM_REALP (x
))
7708 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7709 else if (SCM_COMPLEXP (x
))
7710 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7711 -SCM_COMPLEX_IMAG (x
));
7712 else if (SCM_FRACTIONP (x
))
7713 return scm_i_make_ratio_already_reduced
7714 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7715 SCM_FRACTION_DENOMINATOR (x
));
7717 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7720 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7722 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7724 scm_t_inum xx
= SCM_I_INUM (x
);
7725 scm_t_inum yy
= SCM_I_INUM (y
);
7726 scm_t_inum z
= xx
- yy
;
7727 if (SCM_FIXABLE (z
))
7728 return SCM_I_MAKINUM (z
);
7730 return scm_i_inum2big (z
);
7732 else if (SCM_BIGP (y
))
7734 /* inum-x - big-y */
7735 scm_t_inum xx
= SCM_I_INUM (x
);
7739 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7740 bignum, but negating that gives a fixnum. */
7741 return scm_i_normbig (scm_i_clonebig (y
, 0));
7745 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7746 SCM result
= scm_i_mkbig ();
7749 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7752 /* x - y == -(y + -x) */
7753 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7754 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7756 scm_remember_upto_here_1 (y
);
7758 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7759 /* we know the result will have to be a bignum */
7762 return scm_i_normbig (result
);
7765 else if (SCM_REALP (y
))
7767 scm_t_inum xx
= SCM_I_INUM (x
);
7770 * We need to handle x == exact 0
7771 * specially because R6RS states that:
7772 * (- 0.0) ==> -0.0 and
7773 * (- 0.0 0.0) ==> 0.0
7774 * and the scheme compiler changes
7775 * (- 0.0) into (- 0 0.0)
7776 * So we need to treat (- 0 0.0) like (- 0.0).
7777 * At the C level, (-x) is different than (0.0 - x).
7778 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7781 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7783 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7785 else if (SCM_COMPLEXP (y
))
7787 scm_t_inum xx
= SCM_I_INUM (x
);
7789 /* We need to handle x == exact 0 specially.
7790 See the comment above (for SCM_REALP (y)) */
7792 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7793 - SCM_COMPLEX_IMAG (y
));
7795 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7796 - SCM_COMPLEX_IMAG (y
));
7798 else if (SCM_FRACTIONP (y
))
7799 /* a - b/c = (ac - b) / c */
7800 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7801 SCM_FRACTION_NUMERATOR (y
)),
7802 SCM_FRACTION_DENOMINATOR (y
));
7804 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7806 else if (SCM_BIGP (x
))
7808 if (SCM_I_INUMP (y
))
7810 /* big-x - inum-y */
7811 scm_t_inum yy
= SCM_I_INUM (y
);
7812 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7814 scm_remember_upto_here_1 (x
);
7816 return (SCM_FIXABLE (-yy
) ?
7817 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7820 SCM result
= scm_i_mkbig ();
7823 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7825 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7826 scm_remember_upto_here_1 (x
);
7828 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7829 /* we know the result will have to be a bignum */
7832 return scm_i_normbig (result
);
7835 else if (SCM_BIGP (y
))
7837 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7838 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7839 SCM result
= scm_i_mkbig ();
7840 mpz_sub (SCM_I_BIG_MPZ (result
),
7843 scm_remember_upto_here_2 (x
, y
);
7844 /* we know the result will have to be a bignum */
7845 if ((sgn_x
== 1) && (sgn_y
== -1))
7847 if ((sgn_x
== -1) && (sgn_y
== 1))
7849 return scm_i_normbig (result
);
7851 else if (SCM_REALP (y
))
7853 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7854 scm_remember_upto_here_1 (x
);
7855 return scm_i_from_double (result
);
7857 else if (SCM_COMPLEXP (y
))
7859 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7860 - SCM_COMPLEX_REAL (y
));
7861 scm_remember_upto_here_1 (x
);
7862 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7864 else if (SCM_FRACTIONP (y
))
7865 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7866 SCM_FRACTION_NUMERATOR (y
)),
7867 SCM_FRACTION_DENOMINATOR (y
));
7868 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7870 else if (SCM_REALP (x
))
7872 if (SCM_I_INUMP (y
))
7873 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7874 else if (SCM_BIGP (y
))
7876 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7877 scm_remember_upto_here_1 (x
);
7878 return scm_i_from_double (result
);
7880 else if (SCM_REALP (y
))
7881 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7882 else if (SCM_COMPLEXP (y
))
7883 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7884 -SCM_COMPLEX_IMAG (y
));
7885 else if (SCM_FRACTIONP (y
))
7886 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7888 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7890 else if (SCM_COMPLEXP (x
))
7892 if (SCM_I_INUMP (y
))
7893 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7894 SCM_COMPLEX_IMAG (x
));
7895 else if (SCM_BIGP (y
))
7897 double real_part
= (SCM_COMPLEX_REAL (x
)
7898 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7899 scm_remember_upto_here_1 (x
);
7900 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7902 else if (SCM_REALP (y
))
7903 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7904 SCM_COMPLEX_IMAG (x
));
7905 else if (SCM_COMPLEXP (y
))
7906 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7907 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7908 else if (SCM_FRACTIONP (y
))
7909 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7910 SCM_COMPLEX_IMAG (x
));
7912 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7914 else if (SCM_FRACTIONP (x
))
7916 if (SCM_I_INUMP (y
))
7917 /* a/b - c = (a - cb) / b */
7918 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7919 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7920 SCM_FRACTION_DENOMINATOR (x
));
7921 else if (SCM_BIGP (y
))
7922 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7923 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7924 SCM_FRACTION_DENOMINATOR (x
));
7925 else if (SCM_REALP (y
))
7926 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7927 else if (SCM_COMPLEXP (y
))
7928 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7929 -SCM_COMPLEX_IMAG (y
));
7930 else if (SCM_FRACTIONP (y
))
7931 /* a/b - c/d = (ad - bc) / bd */
7932 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7933 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7934 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7936 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7939 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7944 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7946 "Return @math{@var{x}-1}.")
7947 #define FUNC_NAME s_scm_oneminus
7949 return scm_difference (x
, SCM_INUM1
);
7954 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7955 (SCM x
, SCM y
, SCM rest
),
7956 "Return the product of all arguments. If called without arguments,\n"
7958 #define FUNC_NAME s_scm_i_product
7960 while (!scm_is_null (rest
))
7961 { x
= scm_product (x
, y
);
7963 rest
= scm_cdr (rest
);
7965 return scm_product (x
, y
);
7969 #define s_product s_scm_i_product
7970 #define g_product g_scm_i_product
7973 scm_product (SCM x
, SCM y
)
7975 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7978 return SCM_I_MAKINUM (1L);
7979 else if (SCM_NUMBERP (x
))
7982 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7985 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7990 xx
= SCM_I_INUM (x
);
7995 /* exact1 is the universal multiplicative identity */
7999 /* exact0 times a fixnum is exact0: optimize this case */
8000 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8002 /* if the other argument is inexact, the result is inexact,
8003 and we must do the multiplication in order to handle
8004 infinities and NaNs properly. */
8005 else if (SCM_REALP (y
))
8006 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8007 else if (SCM_COMPLEXP (y
))
8008 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8009 0.0 * SCM_COMPLEX_IMAG (y
));
8010 /* we've already handled inexact numbers,
8011 so y must be exact, and we return exact0 */
8012 else if (SCM_NUMP (y
))
8015 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8019 * This case is important for more than just optimization.
8020 * It handles the case of negating
8021 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8022 * which is a bignum that must be changed back into a fixnum.
8023 * Failure to do so will cause the following to return #f:
8024 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8026 return scm_difference(y
, SCM_UNDEFINED
);
8030 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8032 scm_t_inum yy
= SCM_I_INUM (y
);
8033 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8034 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8035 if (SCM_FIXABLE (kk
))
8036 return SCM_I_MAKINUM (kk
);
8038 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8039 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8040 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8041 return SCM_I_MAKINUM (xx
* yy
);
8045 SCM result
= scm_i_inum2big (xx
);
8046 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8047 return scm_i_normbig (result
);
8050 else if (SCM_BIGP (y
))
8052 SCM result
= scm_i_mkbig ();
8053 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8054 scm_remember_upto_here_1 (y
);
8057 else if (SCM_REALP (y
))
8058 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8059 else if (SCM_COMPLEXP (y
))
8060 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8061 xx
* SCM_COMPLEX_IMAG (y
));
8062 else if (SCM_FRACTIONP (y
))
8063 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8064 SCM_FRACTION_DENOMINATOR (y
));
8066 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8068 else if (SCM_BIGP (x
))
8070 if (SCM_I_INUMP (y
))
8075 else if (SCM_BIGP (y
))
8077 SCM result
= scm_i_mkbig ();
8078 mpz_mul (SCM_I_BIG_MPZ (result
),
8081 scm_remember_upto_here_2 (x
, y
);
8084 else if (SCM_REALP (y
))
8086 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8087 scm_remember_upto_here_1 (x
);
8088 return scm_i_from_double (result
);
8090 else if (SCM_COMPLEXP (y
))
8092 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8093 scm_remember_upto_here_1 (x
);
8094 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8095 z
* SCM_COMPLEX_IMAG (y
));
8097 else if (SCM_FRACTIONP (y
))
8098 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8099 SCM_FRACTION_DENOMINATOR (y
));
8101 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8103 else if (SCM_REALP (x
))
8105 if (SCM_I_INUMP (y
))
8110 else if (SCM_BIGP (y
))
8112 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8113 scm_remember_upto_here_1 (y
);
8114 return scm_i_from_double (result
);
8116 else if (SCM_REALP (y
))
8117 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8118 else if (SCM_COMPLEXP (y
))
8119 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8120 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8121 else if (SCM_FRACTIONP (y
))
8122 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8124 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8126 else if (SCM_COMPLEXP (x
))
8128 if (SCM_I_INUMP (y
))
8133 else if (SCM_BIGP (y
))
8135 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8136 scm_remember_upto_here_1 (y
);
8137 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8138 z
* SCM_COMPLEX_IMAG (x
));
8140 else if (SCM_REALP (y
))
8141 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8142 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8143 else if (SCM_COMPLEXP (y
))
8145 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8146 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8147 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8148 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8150 else if (SCM_FRACTIONP (y
))
8152 double yy
= scm_i_fraction2double (y
);
8153 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8154 yy
* SCM_COMPLEX_IMAG (x
));
8157 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8159 else if (SCM_FRACTIONP (x
))
8161 if (SCM_I_INUMP (y
))
8162 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8163 SCM_FRACTION_DENOMINATOR (x
));
8164 else if (SCM_BIGP (y
))
8165 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8166 SCM_FRACTION_DENOMINATOR (x
));
8167 else if (SCM_REALP (y
))
8168 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8169 else if (SCM_COMPLEXP (y
))
8171 double xx
= scm_i_fraction2double (x
);
8172 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8173 xx
* SCM_COMPLEX_IMAG (y
));
8175 else if (SCM_FRACTIONP (y
))
8176 /* a/b * c/d = ac / bd */
8177 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8178 SCM_FRACTION_NUMERATOR (y
)),
8179 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8180 SCM_FRACTION_DENOMINATOR (y
)));
8182 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8185 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8188 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8189 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8190 #define ALLOW_DIVIDE_BY_ZERO
8191 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8194 /* The code below for complex division is adapted from the GNU
8195 libstdc++, which adapted it from f2c's libF77, and is subject to
8198 /****************************************************************
8199 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8201 Permission to use, copy, modify, and distribute this software
8202 and its documentation for any purpose and without fee is hereby
8203 granted, provided that the above copyright notice appear in all
8204 copies and that both that the copyright notice and this
8205 permission notice and warranty disclaimer appear in supporting
8206 documentation, and that the names of AT&T Bell Laboratories or
8207 Bellcore or any of their entities not be used in advertising or
8208 publicity pertaining to distribution of the software without
8209 specific, written prior permission.
8211 AT&T and Bellcore disclaim all warranties with regard to this
8212 software, including all implied warranties of merchantability
8213 and fitness. In no event shall AT&T or Bellcore be liable for
8214 any special, indirect or consequential damages or any damages
8215 whatsoever resulting from loss of use, data or profits, whether
8216 in an action of contract, negligence or other tortious action,
8217 arising out of or in connection with the use or performance of
8219 ****************************************************************/
8221 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8222 (SCM x
, SCM y
, SCM rest
),
8223 "Divide the first argument by the product of the remaining\n"
8224 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8226 #define FUNC_NAME s_scm_i_divide
8228 while (!scm_is_null (rest
))
8229 { x
= scm_divide (x
, y
);
8231 rest
= scm_cdr (rest
);
8233 return scm_divide (x
, y
);
8237 #define s_divide s_scm_i_divide
8238 #define g_divide g_scm_i_divide
8241 scm_divide (SCM x
, SCM y
)
8242 #define FUNC_NAME s_divide
8246 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8249 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8250 else if (SCM_I_INUMP (x
))
8252 scm_t_inum xx
= SCM_I_INUM (x
);
8253 if (xx
== 1 || xx
== -1)
8255 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8257 scm_num_overflow (s_divide
);
8260 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8262 else if (SCM_BIGP (x
))
8263 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8264 else if (SCM_REALP (x
))
8266 double xx
= SCM_REAL_VALUE (x
);
8267 #ifndef ALLOW_DIVIDE_BY_ZERO
8269 scm_num_overflow (s_divide
);
8272 return scm_i_from_double (1.0 / xx
);
8274 else if (SCM_COMPLEXP (x
))
8276 double r
= SCM_COMPLEX_REAL (x
);
8277 double i
= SCM_COMPLEX_IMAG (x
);
8278 if (fabs(r
) <= fabs(i
))
8281 double d
= i
* (1.0 + t
* t
);
8282 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8287 double d
= r
* (1.0 + t
* t
);
8288 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8291 else if (SCM_FRACTIONP (x
))
8292 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8293 SCM_FRACTION_NUMERATOR (x
));
8295 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8298 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8300 scm_t_inum xx
= SCM_I_INUM (x
);
8301 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8303 scm_t_inum yy
= SCM_I_INUM (y
);
8306 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8307 scm_num_overflow (s_divide
);
8309 return scm_i_from_double ((double) xx
/ (double) yy
);
8312 else if (xx
% yy
!= 0)
8313 return scm_i_make_ratio (x
, y
);
8316 scm_t_inum z
= xx
/ yy
;
8317 if (SCM_FIXABLE (z
))
8318 return SCM_I_MAKINUM (z
);
8320 return scm_i_inum2big (z
);
8323 else if (SCM_BIGP (y
))
8324 return scm_i_make_ratio (x
, y
);
8325 else if (SCM_REALP (y
))
8327 double yy
= SCM_REAL_VALUE (y
);
8328 #ifndef ALLOW_DIVIDE_BY_ZERO
8330 scm_num_overflow (s_divide
);
8333 /* FIXME: Precision may be lost here due to:
8334 (1) The cast from 'scm_t_inum' to 'double'
8335 (2) Double rounding */
8336 return scm_i_from_double ((double) xx
/ yy
);
8338 else if (SCM_COMPLEXP (y
))
8341 complex_div
: /* y _must_ be a complex number */
8343 double r
= SCM_COMPLEX_REAL (y
);
8344 double i
= SCM_COMPLEX_IMAG (y
);
8345 if (fabs(r
) <= fabs(i
))
8348 double d
= i
* (1.0 + t
* t
);
8349 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8354 double d
= r
* (1.0 + t
* t
);
8355 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8359 else if (SCM_FRACTIONP (y
))
8360 /* a / b/c = ac / b */
8361 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8362 SCM_FRACTION_NUMERATOR (y
));
8364 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8366 else if (SCM_BIGP (x
))
8368 if (SCM_I_INUMP (y
))
8370 scm_t_inum yy
= SCM_I_INUM (y
);
8373 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8374 scm_num_overflow (s_divide
);
8376 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8377 scm_remember_upto_here_1 (x
);
8378 return (sgn
== 0) ? scm_nan () : scm_inf ();
8385 /* FIXME: HMM, what are the relative performance issues here?
8386 We need to test. Is it faster on average to test
8387 divisible_p, then perform whichever operation, or is it
8388 faster to perform the integer div opportunistically and
8389 switch to real if there's a remainder? For now we take the
8390 middle ground: test, then if divisible, use the faster div
8393 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8394 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8398 SCM result
= scm_i_mkbig ();
8399 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8400 scm_remember_upto_here_1 (x
);
8402 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8403 return scm_i_normbig (result
);
8406 return scm_i_make_ratio (x
, y
);
8409 else if (SCM_BIGP (y
))
8411 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8415 SCM result
= scm_i_mkbig ();
8416 mpz_divexact (SCM_I_BIG_MPZ (result
),
8419 scm_remember_upto_here_2 (x
, y
);
8420 return scm_i_normbig (result
);
8423 return scm_i_make_ratio (x
, y
);
8425 else if (SCM_REALP (y
))
8427 double yy
= SCM_REAL_VALUE (y
);
8428 #ifndef ALLOW_DIVIDE_BY_ZERO
8430 scm_num_overflow (s_divide
);
8433 /* FIXME: Precision may be lost here due to:
8434 (1) scm_i_big2dbl (2) Double rounding */
8435 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8437 else if (SCM_COMPLEXP (y
))
8439 a
= scm_i_big2dbl (x
);
8442 else if (SCM_FRACTIONP (y
))
8443 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8444 SCM_FRACTION_NUMERATOR (y
));
8446 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8448 else if (SCM_REALP (x
))
8450 double rx
= SCM_REAL_VALUE (x
);
8451 if (SCM_I_INUMP (y
))
8453 scm_t_inum yy
= SCM_I_INUM (y
);
8454 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8456 scm_num_overflow (s_divide
);
8459 /* FIXME: Precision may be lost here due to:
8460 (1) The cast from 'scm_t_inum' to 'double'
8461 (2) Double rounding */
8462 return scm_i_from_double (rx
/ (double) yy
);
8464 else if (SCM_BIGP (y
))
8466 /* FIXME: Precision may be lost here due to:
8467 (1) The conversion from bignum to double
8468 (2) Double rounding */
8469 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8470 scm_remember_upto_here_1 (y
);
8471 return scm_i_from_double (rx
/ dby
);
8473 else if (SCM_REALP (y
))
8475 double yy
= SCM_REAL_VALUE (y
);
8476 #ifndef ALLOW_DIVIDE_BY_ZERO
8478 scm_num_overflow (s_divide
);
8481 return scm_i_from_double (rx
/ yy
);
8483 else if (SCM_COMPLEXP (y
))
8488 else if (SCM_FRACTIONP (y
))
8489 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8491 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8493 else if (SCM_COMPLEXP (x
))
8495 double rx
= SCM_COMPLEX_REAL (x
);
8496 double ix
= SCM_COMPLEX_IMAG (x
);
8497 if (SCM_I_INUMP (y
))
8499 scm_t_inum yy
= SCM_I_INUM (y
);
8500 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8502 scm_num_overflow (s_divide
);
8506 /* FIXME: Precision may be lost here due to:
8507 (1) The conversion from 'scm_t_inum' to double
8508 (2) Double rounding */
8510 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8513 else if (SCM_BIGP (y
))
8515 /* FIXME: Precision may be lost here due to:
8516 (1) The conversion from bignum to double
8517 (2) Double rounding */
8518 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8519 scm_remember_upto_here_1 (y
);
8520 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8522 else if (SCM_REALP (y
))
8524 double yy
= SCM_REAL_VALUE (y
);
8525 #ifndef ALLOW_DIVIDE_BY_ZERO
8527 scm_num_overflow (s_divide
);
8530 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8532 else if (SCM_COMPLEXP (y
))
8534 double ry
= SCM_COMPLEX_REAL (y
);
8535 double iy
= SCM_COMPLEX_IMAG (y
);
8536 if (fabs(ry
) <= fabs(iy
))
8539 double d
= iy
* (1.0 + t
* t
);
8540 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8545 double d
= ry
* (1.0 + t
* t
);
8546 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8549 else if (SCM_FRACTIONP (y
))
8551 /* FIXME: Precision may be lost here due to:
8552 (1) The conversion from fraction to double
8553 (2) Double rounding */
8554 double yy
= scm_i_fraction2double (y
);
8555 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8558 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8560 else if (SCM_FRACTIONP (x
))
8562 if (SCM_I_INUMP (y
))
8564 scm_t_inum yy
= SCM_I_INUM (y
);
8565 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8567 scm_num_overflow (s_divide
);
8570 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8571 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8573 else if (SCM_BIGP (y
))
8575 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8576 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8578 else if (SCM_REALP (y
))
8580 double yy
= SCM_REAL_VALUE (y
);
8581 #ifndef ALLOW_DIVIDE_BY_ZERO
8583 scm_num_overflow (s_divide
);
8586 /* FIXME: Precision may be lost here due to:
8587 (1) The conversion from fraction to double
8588 (2) Double rounding */
8589 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8591 else if (SCM_COMPLEXP (y
))
8593 /* FIXME: Precision may be lost here due to:
8594 (1) The conversion from fraction to double
8595 (2) Double rounding */
8596 a
= scm_i_fraction2double (x
);
8599 else if (SCM_FRACTIONP (y
))
8600 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8601 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8603 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8606 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8612 scm_c_truncate (double x
)
8617 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8618 half-way case (ie. when x is an integer plus 0.5) going upwards.
8619 Then half-way cases are identified and adjusted down if the
8620 round-upwards didn't give the desired even integer.
8622 "plus_half == result" identifies a half-way case. If plus_half, which is
8623 x + 0.5, is an integer then x must be an integer plus 0.5.
8625 An odd "result" value is identified with result/2 != floor(result/2).
8626 This is done with plus_half, since that value is ready for use sooner in
8627 a pipelined cpu, and we're already requiring plus_half == result.
8629 Note however that we need to be careful when x is big and already an
8630 integer. In that case "x+0.5" may round to an adjacent integer, causing
8631 us to return such a value, incorrectly. For instance if the hardware is
8632 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8633 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8634 returned. Or if the hardware is in round-upwards mode, then other bigger
8635 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8636 representable value, 2^128+2^76 (or whatever), again incorrect.
8638 These bad roundings of x+0.5 are avoided by testing at the start whether
8639 x is already an integer. If it is then clearly that's the desired result
8640 already. And if it's not then the exponent must be small enough to allow
8641 an 0.5 to be represented, and hence added without a bad rounding. */
8644 scm_c_round (double x
)
8646 double plus_half
, result
;
8651 plus_half
= x
+ 0.5;
8652 result
= floor (plus_half
);
8653 /* Adjust so that the rounding is towards even. */
8654 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8659 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8661 "Round the number @var{x} towards zero.")
8662 #define FUNC_NAME s_scm_truncate_number
8664 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8666 else if (SCM_REALP (x
))
8667 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8668 else if (SCM_FRACTIONP (x
))
8669 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8670 SCM_FRACTION_DENOMINATOR (x
));
8672 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8673 s_scm_truncate_number
);
8677 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8679 "Round the number @var{x} towards the nearest integer. "
8680 "When it is exactly halfway between two integers, "
8681 "round towards the even one.")
8682 #define FUNC_NAME s_scm_round_number
8684 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8686 else if (SCM_REALP (x
))
8687 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8688 else if (SCM_FRACTIONP (x
))
8689 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8690 SCM_FRACTION_DENOMINATOR (x
));
8692 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8693 s_scm_round_number
);
8697 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8699 "Round the number @var{x} towards minus infinity.")
8700 #define FUNC_NAME s_scm_floor
8702 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8704 else if (SCM_REALP (x
))
8705 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8706 else if (SCM_FRACTIONP (x
))
8707 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8708 SCM_FRACTION_DENOMINATOR (x
));
8710 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8714 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8716 "Round the number @var{x} towards infinity.")
8717 #define FUNC_NAME s_scm_ceiling
8719 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8721 else if (SCM_REALP (x
))
8722 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8723 else if (SCM_FRACTIONP (x
))
8724 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8725 SCM_FRACTION_DENOMINATOR (x
));
8727 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8731 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8733 "Return @var{x} raised to the power of @var{y}.")
8734 #define FUNC_NAME s_scm_expt
8736 if (scm_is_integer (y
))
8738 if (scm_is_true (scm_exact_p (y
)))
8739 return scm_integer_expt (x
, y
);
8742 /* Here we handle the case where the exponent is an inexact
8743 integer. We make the exponent exact in order to use
8744 scm_integer_expt, and thus avoid the spurious imaginary
8745 parts that may result from round-off errors in the general
8746 e^(y log x) method below (for example when squaring a large
8747 negative number). In this case, we must return an inexact
8748 result for correctness. We also make the base inexact so
8749 that scm_integer_expt will use fast inexact arithmetic
8750 internally. Note that making the base inexact is not
8751 sufficient to guarantee an inexact result, because
8752 scm_integer_expt will return an exact 1 when the exponent
8753 is 0, even if the base is inexact. */
8754 return scm_exact_to_inexact
8755 (scm_integer_expt (scm_exact_to_inexact (x
),
8756 scm_inexact_to_exact (y
)));
8759 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8761 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8763 else if (scm_is_complex (x
) && scm_is_complex (y
))
8764 return scm_exp (scm_product (scm_log (x
), y
));
8765 else if (scm_is_complex (x
))
8766 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8768 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8772 /* sin/cos/tan/asin/acos/atan
8773 sinh/cosh/tanh/asinh/acosh/atanh
8774 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8775 Written by Jerry D. Hedden, (C) FSF.
8776 See the file `COPYING' for terms applying to this program. */
8778 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8780 "Compute the sine of @var{z}.")
8781 #define FUNC_NAME s_scm_sin
8783 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8784 return z
; /* sin(exact0) = exact0 */
8785 else if (scm_is_real (z
))
8786 return scm_i_from_double (sin (scm_to_double (z
)));
8787 else if (SCM_COMPLEXP (z
))
8789 x
= SCM_COMPLEX_REAL (z
);
8790 y
= SCM_COMPLEX_IMAG (z
);
8791 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8792 cos (x
) * sinh (y
));
8795 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8799 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8801 "Compute the cosine of @var{z}.")
8802 #define FUNC_NAME s_scm_cos
8804 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8805 return SCM_INUM1
; /* cos(exact0) = exact1 */
8806 else if (scm_is_real (z
))
8807 return scm_i_from_double (cos (scm_to_double (z
)));
8808 else if (SCM_COMPLEXP (z
))
8810 x
= SCM_COMPLEX_REAL (z
);
8811 y
= SCM_COMPLEX_IMAG (z
);
8812 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8813 -sin (x
) * sinh (y
));
8816 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8820 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8822 "Compute the tangent of @var{z}.")
8823 #define FUNC_NAME s_scm_tan
8825 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8826 return z
; /* tan(exact0) = exact0 */
8827 else if (scm_is_real (z
))
8828 return scm_i_from_double (tan (scm_to_double (z
)));
8829 else if (SCM_COMPLEXP (z
))
8831 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8832 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8833 w
= cos (x
) + cosh (y
);
8834 #ifndef ALLOW_DIVIDE_BY_ZERO
8836 scm_num_overflow (s_scm_tan
);
8838 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8841 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8845 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8847 "Compute the hyperbolic sine of @var{z}.")
8848 #define FUNC_NAME s_scm_sinh
8850 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8851 return z
; /* sinh(exact0) = exact0 */
8852 else if (scm_is_real (z
))
8853 return scm_i_from_double (sinh (scm_to_double (z
)));
8854 else if (SCM_COMPLEXP (z
))
8856 x
= SCM_COMPLEX_REAL (z
);
8857 y
= SCM_COMPLEX_IMAG (z
);
8858 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8859 cosh (x
) * sin (y
));
8862 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8866 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8868 "Compute the hyperbolic cosine of @var{z}.")
8869 #define FUNC_NAME s_scm_cosh
8871 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8872 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8873 else if (scm_is_real (z
))
8874 return scm_i_from_double (cosh (scm_to_double (z
)));
8875 else if (SCM_COMPLEXP (z
))
8877 x
= SCM_COMPLEX_REAL (z
);
8878 y
= SCM_COMPLEX_IMAG (z
);
8879 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8880 sinh (x
) * sin (y
));
8883 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8887 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8889 "Compute the hyperbolic tangent of @var{z}.")
8890 #define FUNC_NAME s_scm_tanh
8892 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8893 return z
; /* tanh(exact0) = exact0 */
8894 else if (scm_is_real (z
))
8895 return scm_i_from_double (tanh (scm_to_double (z
)));
8896 else if (SCM_COMPLEXP (z
))
8898 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8899 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8900 w
= cosh (x
) + cos (y
);
8901 #ifndef ALLOW_DIVIDE_BY_ZERO
8903 scm_num_overflow (s_scm_tanh
);
8905 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8908 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8912 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8914 "Compute the arc sine of @var{z}.")
8915 #define FUNC_NAME s_scm_asin
8917 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8918 return z
; /* asin(exact0) = exact0 */
8919 else if (scm_is_real (z
))
8921 double w
= scm_to_double (z
);
8922 if (w
>= -1.0 && w
<= 1.0)
8923 return scm_i_from_double (asin (w
));
8925 return scm_product (scm_c_make_rectangular (0, -1),
8926 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8928 else if (SCM_COMPLEXP (z
))
8930 x
= SCM_COMPLEX_REAL (z
);
8931 y
= SCM_COMPLEX_IMAG (z
);
8932 return scm_product (scm_c_make_rectangular (0, -1),
8933 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8936 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8940 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8942 "Compute the arc cosine of @var{z}.")
8943 #define FUNC_NAME s_scm_acos
8945 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8946 return SCM_INUM0
; /* acos(exact1) = exact0 */
8947 else if (scm_is_real (z
))
8949 double w
= scm_to_double (z
);
8950 if (w
>= -1.0 && w
<= 1.0)
8951 return scm_i_from_double (acos (w
));
8953 return scm_sum (scm_i_from_double (acos (0.0)),
8954 scm_product (scm_c_make_rectangular (0, 1),
8955 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8957 else if (SCM_COMPLEXP (z
))
8959 x
= SCM_COMPLEX_REAL (z
);
8960 y
= SCM_COMPLEX_IMAG (z
);
8961 return scm_sum (scm_i_from_double (acos (0.0)),
8962 scm_product (scm_c_make_rectangular (0, 1),
8963 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8966 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8970 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8972 "With one argument, compute the arc tangent of @var{z}.\n"
8973 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8974 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8975 #define FUNC_NAME s_scm_atan
8979 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8980 return z
; /* atan(exact0) = exact0 */
8981 else if (scm_is_real (z
))
8982 return scm_i_from_double (atan (scm_to_double (z
)));
8983 else if (SCM_COMPLEXP (z
))
8986 v
= SCM_COMPLEX_REAL (z
);
8987 w
= SCM_COMPLEX_IMAG (z
);
8988 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8989 scm_c_make_rectangular (v
, w
+ 1.0))),
8990 scm_c_make_rectangular (0, 2));
8993 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8995 else if (scm_is_real (z
))
8997 if (scm_is_real (y
))
8998 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9000 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9003 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9007 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9009 "Compute the inverse hyperbolic sine of @var{z}.")
9010 #define FUNC_NAME s_scm_sys_asinh
9012 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9013 return z
; /* asinh(exact0) = exact0 */
9014 else if (scm_is_real (z
))
9015 return scm_i_from_double (asinh (scm_to_double (z
)));
9016 else if (scm_is_number (z
))
9017 return scm_log (scm_sum (z
,
9018 scm_sqrt (scm_sum (scm_product (z
, z
),
9021 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9025 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9027 "Compute the inverse hyperbolic cosine of @var{z}.")
9028 #define FUNC_NAME s_scm_sys_acosh
9030 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9031 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9032 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9033 return scm_i_from_double (acosh (scm_to_double (z
)));
9034 else if (scm_is_number (z
))
9035 return scm_log (scm_sum (z
,
9036 scm_sqrt (scm_difference (scm_product (z
, z
),
9039 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9043 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9045 "Compute the inverse hyperbolic tangent of @var{z}.")
9046 #define FUNC_NAME s_scm_sys_atanh
9048 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9049 return z
; /* atanh(exact0) = exact0 */
9050 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9051 return scm_i_from_double (atanh (scm_to_double (z
)));
9052 else if (scm_is_number (z
))
9053 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9054 scm_difference (SCM_INUM1
, z
))),
9057 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9062 scm_c_make_rectangular (double re
, double im
)
9066 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9068 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9069 SCM_COMPLEX_REAL (z
) = re
;
9070 SCM_COMPLEX_IMAG (z
) = im
;
9074 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9075 (SCM real_part
, SCM imaginary_part
),
9076 "Return a complex number constructed of the given @var{real_part} "
9077 "and @var{imaginary_part} parts.")
9078 #define FUNC_NAME s_scm_make_rectangular
9080 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9081 SCM_ARG1
, FUNC_NAME
, "real");
9082 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9083 SCM_ARG2
, FUNC_NAME
, "real");
9085 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9086 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9089 return scm_c_make_rectangular (scm_to_double (real_part
),
9090 scm_to_double (imaginary_part
));
9095 scm_c_make_polar (double mag
, double ang
)
9099 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9100 use it on Glibc-based systems that have it (it's a GNU extension). See
9101 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9103 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9104 sincos (ang
, &s
, &c
);
9110 /* If s and c are NaNs, this indicates that the angle is a NaN,
9111 infinite, or perhaps simply too large to determine its value
9112 mod 2*pi. However, we know something that the floating-point
9113 implementation doesn't know: We know that s and c are finite.
9114 Therefore, if the magnitude is zero, return a complex zero.
9116 The reason we check for the NaNs instead of using this case
9117 whenever mag == 0.0 is because when the angle is known, we'd
9118 like to return the correct kind of non-real complex zero:
9119 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9120 on which quadrant the angle is in.
9122 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9123 return scm_c_make_rectangular (0.0, 0.0);
9125 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9128 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9130 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9131 #define FUNC_NAME s_scm_make_polar
9133 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9134 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9136 /* If mag is exact0, return exact0 */
9137 if (scm_is_eq (mag
, SCM_INUM0
))
9139 /* Return a real if ang is exact0 */
9140 else if (scm_is_eq (ang
, SCM_INUM0
))
9143 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9148 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9150 "Return the real part of the number @var{z}.")
9151 #define FUNC_NAME s_scm_real_part
9153 if (SCM_COMPLEXP (z
))
9154 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9155 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9158 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9163 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9165 "Return the imaginary part of the number @var{z}.")
9166 #define FUNC_NAME s_scm_imag_part
9168 if (SCM_COMPLEXP (z
))
9169 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9170 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9173 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9177 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9179 "Return the numerator of the number @var{z}.")
9180 #define FUNC_NAME s_scm_numerator
9182 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9184 else if (SCM_FRACTIONP (z
))
9185 return SCM_FRACTION_NUMERATOR (z
);
9186 else if (SCM_REALP (z
))
9188 double zz
= SCM_REAL_VALUE (z
);
9189 if (zz
== floor (zz
))
9190 /* Handle -0.0 and infinities in accordance with R6RS
9191 flnumerator, and optimize handling of integers. */
9194 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9197 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9202 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9204 "Return the denominator of the number @var{z}.")
9205 #define FUNC_NAME s_scm_denominator
9207 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9209 else if (SCM_FRACTIONP (z
))
9210 return SCM_FRACTION_DENOMINATOR (z
);
9211 else if (SCM_REALP (z
))
9213 double zz
= SCM_REAL_VALUE (z
);
9214 if (zz
== floor (zz
))
9215 /* Handle infinities in accordance with R6RS fldenominator, and
9216 optimize handling of integers. */
9217 return scm_i_from_double (1.0);
9219 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9222 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9227 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9229 "Return the magnitude of the number @var{z}. This is the same as\n"
9230 "@code{abs} for real arguments, but also allows complex numbers.")
9231 #define FUNC_NAME s_scm_magnitude
9233 if (SCM_I_INUMP (z
))
9235 scm_t_inum zz
= SCM_I_INUM (z
);
9238 else if (SCM_POSFIXABLE (-zz
))
9239 return SCM_I_MAKINUM (-zz
);
9241 return scm_i_inum2big (-zz
);
9243 else if (SCM_BIGP (z
))
9245 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9246 scm_remember_upto_here_1 (z
);
9248 return scm_i_clonebig (z
, 0);
9252 else if (SCM_REALP (z
))
9253 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9254 else if (SCM_COMPLEXP (z
))
9255 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9256 else if (SCM_FRACTIONP (z
))
9258 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9260 return scm_i_make_ratio_already_reduced
9261 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9262 SCM_FRACTION_DENOMINATOR (z
));
9265 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9270 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9272 "Return the angle of the complex number @var{z}.")
9273 #define FUNC_NAME s_scm_angle
9275 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9276 flo0 to save allocating a new flonum with scm_i_from_double each time.
9277 But if atan2 follows the floating point rounding mode, then the value
9278 is not a constant. Maybe it'd be close enough though. */
9279 if (SCM_I_INUMP (z
))
9281 if (SCM_I_INUM (z
) >= 0)
9284 return scm_i_from_double (atan2 (0.0, -1.0));
9286 else if (SCM_BIGP (z
))
9288 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9289 scm_remember_upto_here_1 (z
);
9291 return scm_i_from_double (atan2 (0.0, -1.0));
9295 else if (SCM_REALP (z
))
9297 double x
= SCM_REAL_VALUE (z
);
9298 if (copysign (1.0, x
) > 0.0)
9301 return scm_i_from_double (atan2 (0.0, -1.0));
9303 else if (SCM_COMPLEXP (z
))
9304 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9305 else if (SCM_FRACTIONP (z
))
9307 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9309 else return scm_i_from_double (atan2 (0.0, -1.0));
9312 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9317 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9319 "Convert the number @var{z} to its inexact representation.\n")
9320 #define FUNC_NAME s_scm_exact_to_inexact
9322 if (SCM_I_INUMP (z
))
9323 return scm_i_from_double ((double) SCM_I_INUM (z
));
9324 else if (SCM_BIGP (z
))
9325 return scm_i_from_double (scm_i_big2dbl (z
));
9326 else if (SCM_FRACTIONP (z
))
9327 return scm_i_from_double (scm_i_fraction2double (z
));
9328 else if (SCM_INEXACTP (z
))
9331 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9336 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9338 "Return an exact number that is numerically closest to @var{z}.")
9339 #define FUNC_NAME s_scm_inexact_to_exact
9341 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9348 val
= SCM_REAL_VALUE (z
);
9349 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9350 val
= SCM_COMPLEX_REAL (z
);
9352 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9354 if (!SCM_LIKELY (isfinite (val
)))
9355 SCM_OUT_OF_RANGE (1, z
);
9356 else if (val
== 0.0)
9363 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9365 expon
-= DBL_MANT_DIG
;
9368 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9372 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9373 SCM_I_BIG_MPZ (numerator
),
9377 numerator
= scm_i_normbig (numerator
);
9379 return scm_i_make_ratio_already_reduced
9380 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9382 return left_shift_exact_integer (numerator
, expon
);
9390 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9392 "Returns the @emph{simplest} rational number differing\n"
9393 "from @var{x} by no more than @var{eps}.\n"
9395 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9396 "exact result when both its arguments are exact. Thus, you might need\n"
9397 "to use @code{inexact->exact} on the arguments.\n"
9400 "(rationalize (inexact->exact 1.2) 1/100)\n"
9403 #define FUNC_NAME s_scm_rationalize
9405 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9406 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9408 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9410 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9412 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9417 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9420 return scm_exact_to_inexact
9421 (scm_rationalize (scm_inexact_to_exact (x
),
9422 scm_inexact_to_exact (eps
)));
9426 /* X and EPS are exact rationals.
9428 The code that follows is equivalent to the following Scheme code:
9430 (define (exact-rationalize x eps)
9431 (let ((n1 (if (negative? x) -1 1))
9434 (let ((lo (- x eps))
9438 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9439 (nhi (numerator hi)) (dhi (denominator hi))
9440 (n1 n1) (d1 0) (n2 0) (d2 1))
9441 (let-values (((qlo rlo) (floor/ nlo dlo))
9442 ((qhi rhi) (floor/ nhi dhi)))
9443 (let ((n0 (+ n2 (* n1 qlo)))
9444 (d0 (+ d2 (* d1 qlo))))
9445 (cond ((zero? rlo) (/ n0 d0))
9446 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9447 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9453 eps
= scm_abs (eps
);
9454 if (scm_is_true (scm_negative_p (x
)))
9457 x
= scm_difference (x
, SCM_UNDEFINED
);
9460 /* X and EPS are non-negative exact rationals. */
9462 lo
= scm_difference (x
, eps
);
9463 hi
= scm_sum (x
, eps
);
9465 if (scm_is_false (scm_positive_p (lo
)))
9466 /* If zero is included in the interval, return it.
9467 It is the simplest rational of all. */
9472 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9473 mpz_t nlo
, dlo
, nhi
, dhi
;
9474 mpz_t qlo
, rlo
, qhi
, rhi
;
9476 /* LO and HI are positive exact rationals. */
9478 /* Our approach here follows the method described by Alan
9479 Bawden in a message entitled "(rationalize x y)" on the
9480 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9482 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9484 In brief, we compute the continued fractions of the two
9485 endpoints of the interval (LO and HI). The continued
9486 fraction of the result consists of the common prefix of the
9487 continued fractions of LO and HI, plus one final term. The
9488 final term of the result is the smallest integer contained
9489 in the interval between the remainders of LO and HI after
9490 the common prefix has been removed.
9492 The following code lazily computes the continued fraction
9493 representations of LO and HI, and simultaneously converts
9494 the continued fraction of the result into a rational
9495 number. We use MPZ functions directly to avoid type
9496 dispatch and GC allocation during the loop. */
9498 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9503 /* The variables N1, D1, N2 and D2 are used to compute the
9504 resulting rational from its continued fraction. At each
9505 step, N2/D2 and N1/D1 are the last two convergents. They
9506 are normally initialized to 0/1 and 1/0, respectively.
9507 However, if we negated X then we must negate the result as
9508 well, and we do that by initializing N1/D1 to -1/0. */
9509 mpz_set_si (n1
, n1_init
);
9514 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9515 compute the continued fraction representations of LO and HI
9516 using Euclid's algorithm. Initially, NLO/DLO == LO and
9518 scm_to_mpz (scm_numerator (lo
), nlo
);
9519 scm_to_mpz (scm_denominator (lo
), dlo
);
9520 scm_to_mpz (scm_numerator (hi
), nhi
);
9521 scm_to_mpz (scm_denominator (hi
), dhi
);
9523 /* As long as we're using exact arithmetic, the following loop
9524 is guaranteed to terminate. */
9527 /* Compute the next terms (QLO and QHI) of the continued
9528 fractions of LO and HI. */
9529 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9530 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9532 /* The next term of the result will be either QLO or
9533 QLO+1. Here we compute the next convergent of the
9534 result based on the assumption that QLO is the next
9535 term. If that turns out to be wrong, we'll adjust
9536 these later by adding N1 to N0 and D1 to D0. */
9537 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9538 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9540 /* We stop iterating when an integer is contained in the
9541 interval between the remainders NLO/DLO and NHI/DHI.
9542 There are two cases to consider: either NLO/DLO == QLO
9543 is an integer (indicated by RLO == 0), or QLO < QHI. */
9544 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9547 /* Efficiently shuffle variables around for the next
9548 iteration. First we shift the recent convergents. */
9549 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9550 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9552 /* The following shuffling is a bit confusing, so some
9553 explanation is in order. Conceptually, we're doing a
9554 couple of things here. After substracting the floor of
9555 NLO/DLO, the remainder is RLO/DLO. The rest of the
9556 continued fraction will represent the remainder's
9557 reciprocal DLO/RLO. Similarly for the HI endpoint.
9558 So in the next iteration, the new endpoints will be
9559 DLO/RLO and DHI/RHI. However, when we take the
9560 reciprocals of these endpoints, their order is
9561 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9562 and NHI/DHI <-- DLO/RLO. */
9563 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9564 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9567 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9568 The last term of the result will be the smallest integer in
9569 that interval, which is ceiling(NLO/DLO). We have already
9570 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9571 equal to the ceiling. */
9572 if (mpz_sgn (rlo
) != 0)
9574 /* If RLO is non-zero, then NLO/DLO is not an integer and
9575 the next term will be QLO+1. QLO was used in the
9576 computation of N0 and D0 above. Here we adjust N0 and
9577 D0 to be based on QLO+1 instead of QLO. */
9578 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9579 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9582 /* The simplest rational in the interval is N0/D0 */
9583 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9585 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9595 /* conversion functions */
9598 scm_is_integer (SCM val
)
9600 return scm_is_true (scm_integer_p (val
));
9604 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9606 if (SCM_I_INUMP (val
))
9608 scm_t_signed_bits n
= SCM_I_INUM (val
);
9609 return n
>= min
&& n
<= max
;
9611 else if (SCM_BIGP (val
))
9613 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9615 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9617 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9619 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9620 return n
>= min
&& n
<= max
;
9630 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9631 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9634 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9635 SCM_I_BIG_MPZ (val
));
9637 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9649 return n
>= min
&& n
<= max
;
9657 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9659 if (SCM_I_INUMP (val
))
9661 scm_t_signed_bits n
= SCM_I_INUM (val
);
9662 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9664 else if (SCM_BIGP (val
))
9666 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9668 else if (max
<= ULONG_MAX
)
9670 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9672 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9673 return n
>= min
&& n
<= max
;
9683 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9686 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9687 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9690 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9691 SCM_I_BIG_MPZ (val
));
9693 return n
>= min
&& n
<= max
;
9701 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9703 scm_error (scm_out_of_range_key
,
9705 "Value out of range ~S to ~S: ~S",
9706 scm_list_3 (min
, max
, bad_val
),
9707 scm_list_1 (bad_val
));
9710 #define TYPE scm_t_intmax
9711 #define TYPE_MIN min
9712 #define TYPE_MAX max
9713 #define SIZEOF_TYPE 0
9714 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9715 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9716 #include "libguile/conv-integer.i.c"
9718 #define TYPE scm_t_uintmax
9719 #define TYPE_MIN min
9720 #define TYPE_MAX max
9721 #define SIZEOF_TYPE 0
9722 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9723 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9724 #include "libguile/conv-uinteger.i.c"
9726 #define TYPE scm_t_int8
9727 #define TYPE_MIN SCM_T_INT8_MIN
9728 #define TYPE_MAX SCM_T_INT8_MAX
9729 #define SIZEOF_TYPE 1
9730 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9731 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9732 #include "libguile/conv-integer.i.c"
9734 #define TYPE scm_t_uint8
9736 #define TYPE_MAX SCM_T_UINT8_MAX
9737 #define SIZEOF_TYPE 1
9738 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9739 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9740 #include "libguile/conv-uinteger.i.c"
9742 #define TYPE scm_t_int16
9743 #define TYPE_MIN SCM_T_INT16_MIN
9744 #define TYPE_MAX SCM_T_INT16_MAX
9745 #define SIZEOF_TYPE 2
9746 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9747 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9748 #include "libguile/conv-integer.i.c"
9750 #define TYPE scm_t_uint16
9752 #define TYPE_MAX SCM_T_UINT16_MAX
9753 #define SIZEOF_TYPE 2
9754 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9755 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9756 #include "libguile/conv-uinteger.i.c"
9758 #define TYPE scm_t_int32
9759 #define TYPE_MIN SCM_T_INT32_MIN
9760 #define TYPE_MAX SCM_T_INT32_MAX
9761 #define SIZEOF_TYPE 4
9762 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9763 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9764 #include "libguile/conv-integer.i.c"
9766 #define TYPE scm_t_uint32
9768 #define TYPE_MAX SCM_T_UINT32_MAX
9769 #define SIZEOF_TYPE 4
9770 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9771 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9772 #include "libguile/conv-uinteger.i.c"
9774 #define TYPE scm_t_wchar
9775 #define TYPE_MIN (scm_t_int32)-1
9776 #define TYPE_MAX (scm_t_int32)0x10ffff
9777 #define SIZEOF_TYPE 4
9778 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9779 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9780 #include "libguile/conv-integer.i.c"
9782 #define TYPE scm_t_int64
9783 #define TYPE_MIN SCM_T_INT64_MIN
9784 #define TYPE_MAX SCM_T_INT64_MAX
9785 #define SIZEOF_TYPE 8
9786 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9787 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9788 #include "libguile/conv-integer.i.c"
9790 #define TYPE scm_t_uint64
9792 #define TYPE_MAX SCM_T_UINT64_MAX
9793 #define SIZEOF_TYPE 8
9794 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9795 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9796 #include "libguile/conv-uinteger.i.c"
9799 scm_to_mpz (SCM val
, mpz_t rop
)
9801 if (SCM_I_INUMP (val
))
9802 mpz_set_si (rop
, SCM_I_INUM (val
));
9803 else if (SCM_BIGP (val
))
9804 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9806 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9810 scm_from_mpz (mpz_t val
)
9812 return scm_i_mpz2num (val
);
9816 scm_is_real (SCM val
)
9818 return scm_is_true (scm_real_p (val
));
9822 scm_is_rational (SCM val
)
9824 return scm_is_true (scm_rational_p (val
));
9828 scm_to_double (SCM val
)
9830 if (SCM_I_INUMP (val
))
9831 return SCM_I_INUM (val
);
9832 else if (SCM_BIGP (val
))
9833 return scm_i_big2dbl (val
);
9834 else if (SCM_FRACTIONP (val
))
9835 return scm_i_fraction2double (val
);
9836 else if (SCM_REALP (val
))
9837 return SCM_REAL_VALUE (val
);
9839 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9843 scm_from_double (double val
)
9845 return scm_i_from_double (val
);
9848 #if SCM_ENABLE_DEPRECATED == 1
9851 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9853 scm_c_issue_deprecation_warning
9854 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9858 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9862 scm_out_of_range (NULL
, num
);
9865 return scm_to_double (num
);
9869 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9871 scm_c_issue_deprecation_warning
9872 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9876 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9880 scm_out_of_range (NULL
, num
);
9883 return scm_to_double (num
);
9889 scm_is_complex (SCM val
)
9891 return scm_is_true (scm_complex_p (val
));
9895 scm_c_real_part (SCM z
)
9897 if (SCM_COMPLEXP (z
))
9898 return SCM_COMPLEX_REAL (z
);
9901 /* Use the scm_real_part to get proper error checking and
9904 return scm_to_double (scm_real_part (z
));
9909 scm_c_imag_part (SCM z
)
9911 if (SCM_COMPLEXP (z
))
9912 return SCM_COMPLEX_IMAG (z
);
9915 /* Use the scm_imag_part to get proper error checking and
9916 dispatching. The result will almost always be 0.0, but not
9919 return scm_to_double (scm_imag_part (z
));
9924 scm_c_magnitude (SCM z
)
9926 return scm_to_double (scm_magnitude (z
));
9932 return scm_to_double (scm_angle (z
));
9936 scm_is_number (SCM z
)
9938 return scm_is_true (scm_number_p (z
));
9942 /* Returns log(x * 2^shift) */
9944 log_of_shifted_double (double x
, long shift
)
9946 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9948 if (copysign (1.0, x
) > 0.0)
9949 return scm_i_from_double (ans
);
9951 return scm_c_make_rectangular (ans
, M_PI
);
9954 /* Returns log(n), for exact integer n */
9956 log_of_exact_integer (SCM n
)
9958 if (SCM_I_INUMP (n
))
9959 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9960 else if (SCM_BIGP (n
))
9963 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9964 return log_of_shifted_double (signif
, expon
);
9967 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9970 /* Returns log(n/d), for exact non-zero integers n and d */
9972 log_of_fraction (SCM n
, SCM d
)
9974 long n_size
= scm_to_long (scm_integer_length (n
));
9975 long d_size
= scm_to_long (scm_integer_length (d
));
9977 if (abs (n_size
- d_size
) > 1)
9978 return (scm_difference (log_of_exact_integer (n
),
9979 log_of_exact_integer (d
)));
9980 else if (scm_is_false (scm_negative_p (n
)))
9981 return scm_i_from_double
9982 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9984 return scm_c_make_rectangular
9985 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9991 /* In the following functions we dispatch to the real-arg funcs like log()
9992 when we know the arg is real, instead of just handing everything to
9993 clog() for instance. This is in case clog() doesn't optimize for a
9994 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9995 well use it to go straight to the applicable C func. */
9997 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9999 "Return the natural logarithm of @var{z}.")
10000 #define FUNC_NAME s_scm_log
10002 if (SCM_COMPLEXP (z
))
10004 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
10005 && defined (SCM_COMPLEX_VALUE)
10006 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
10008 double re
= SCM_COMPLEX_REAL (z
);
10009 double im
= SCM_COMPLEX_IMAG (z
);
10010 return scm_c_make_rectangular (log (hypot (re
, im
)),
10014 else if (SCM_REALP (z
))
10015 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
10016 else if (SCM_I_INUMP (z
))
10018 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10019 if (scm_is_eq (z
, SCM_INUM0
))
10020 scm_num_overflow (s_scm_log
);
10022 return log_of_shifted_double (SCM_I_INUM (z
), 0);
10024 else if (SCM_BIGP (z
))
10025 return log_of_exact_integer (z
);
10026 else if (SCM_FRACTIONP (z
))
10027 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10028 SCM_FRACTION_DENOMINATOR (z
));
10030 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
10035 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10037 "Return the base 10 logarithm of @var{z}.")
10038 #define FUNC_NAME s_scm_log10
10040 if (SCM_COMPLEXP (z
))
10042 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10043 clog() and a multiply by M_LOG10E, rather than the fallback
10044 log10+hypot+atan2.) */
10045 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10046 && defined SCM_COMPLEX_VALUE
10047 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10049 double re
= SCM_COMPLEX_REAL (z
);
10050 double im
= SCM_COMPLEX_IMAG (z
);
10051 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10052 M_LOG10E
* atan2 (im
, re
));
10055 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10057 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10058 if (scm_is_eq (z
, SCM_INUM0
))
10059 scm_num_overflow (s_scm_log10
);
10062 double re
= scm_to_double (z
);
10063 double l
= log10 (fabs (re
));
10064 if (copysign (1.0, re
) > 0.0)
10065 return scm_i_from_double (l
);
10067 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10070 else if (SCM_BIGP (z
))
10071 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10072 else if (SCM_FRACTIONP (z
))
10073 return scm_product (flo_log10e
,
10074 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10075 SCM_FRACTION_DENOMINATOR (z
)));
10077 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10082 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10084 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10085 "base of natural logarithms (2.71828@dots{}).")
10086 #define FUNC_NAME s_scm_exp
10088 if (SCM_COMPLEXP (z
))
10090 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10091 && defined (SCM_COMPLEX_VALUE)
10092 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10094 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10095 SCM_COMPLEX_IMAG (z
));
10098 else if (SCM_NUMBERP (z
))
10100 /* When z is a negative bignum the conversion to double overflows,
10101 giving -infinity, but that's ok, the exp is still 0.0. */
10102 return scm_i_from_double (exp (scm_to_double (z
)));
10105 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10110 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10112 "Return two exact non-negative integers @var{s} and @var{r}\n"
10113 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10114 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10115 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10118 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10120 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10124 scm_exact_integer_sqrt (k
, &s
, &r
);
10125 return scm_values (scm_list_2 (s
, r
));
10130 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10132 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10136 if (SCM_I_INUM (k
) < 0)
10137 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10138 "exact non-negative integer");
10139 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10140 mpz_inits (ss
, rr
, NULL
);
10141 mpz_sqrtrem (ss
, rr
, kk
);
10142 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10143 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10144 mpz_clears (kk
, ss
, rr
, NULL
);
10146 else if (SCM_LIKELY (SCM_BIGP (k
)))
10150 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10151 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10152 "exact non-negative integer");
10153 s
= scm_i_mkbig ();
10154 r
= scm_i_mkbig ();
10155 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10156 scm_remember_upto_here_1 (k
);
10157 *sp
= scm_i_normbig (s
);
10158 *rp
= scm_i_normbig (r
);
10161 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10162 "exact non-negative integer");
10165 /* Return true iff K is a perfect square.
10166 K must be an exact integer. */
10168 exact_integer_is_perfect_square (SCM k
)
10172 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10176 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10177 result
= mpz_perfect_square_p (kk
);
10182 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10183 scm_remember_upto_here_1 (k
);
10188 /* Return the floor of the square root of K.
10189 K must be an exact integer. */
10191 exact_integer_floor_square_root (SCM k
)
10193 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10198 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10200 ss
= mpz_get_ui (kk
);
10202 return SCM_I_MAKINUM (ss
);
10208 s
= scm_i_mkbig ();
10209 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10210 scm_remember_upto_here_1 (k
);
10211 return scm_i_normbig (s
);
10216 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10218 "Return the square root of @var{z}. Of the two possible roots\n"
10219 "(positive and negative), the one with positive real part\n"
10220 "is returned, or if that's zero then a positive imaginary part.\n"
10224 "(sqrt 9.0) @result{} 3.0\n"
10225 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10226 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10227 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10229 #define FUNC_NAME s_scm_sqrt
10231 if (SCM_COMPLEXP (z
))
10233 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10234 && defined SCM_COMPLEX_VALUE
10235 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10237 double re
= SCM_COMPLEX_REAL (z
);
10238 double im
= SCM_COMPLEX_IMAG (z
);
10239 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10240 0.5 * atan2 (im
, re
));
10243 else if (SCM_NUMBERP (z
))
10245 if (SCM_I_INUMP (z
))
10247 scm_t_inum x
= SCM_I_INUM (z
);
10249 if (SCM_LIKELY (x
>= 0))
10251 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10252 || x
< (1L << (DBL_MANT_DIG
- 1))))
10254 double root
= sqrt (x
);
10256 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10257 integer, then the result is exact. */
10258 if (root
== floor (root
))
10259 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10261 return scm_i_from_double (root
);
10268 mpz_init_set_ui (xx
, x
);
10269 if (mpz_perfect_square_p (xx
))
10272 root
= mpz_get_ui (xx
);
10274 return SCM_I_MAKINUM (root
);
10281 else if (SCM_BIGP (z
))
10283 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10285 SCM root
= scm_i_mkbig ();
10287 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10288 scm_remember_upto_here_1 (z
);
10289 return scm_i_normbig (root
);
10294 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10302 return scm_c_make_rectangular
10303 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10305 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10308 else if (SCM_FRACTIONP (z
))
10310 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10311 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10313 if (exact_integer_is_perfect_square (n
)
10314 && exact_integer_is_perfect_square (d
))
10315 return scm_i_make_ratio_already_reduced
10316 (exact_integer_floor_square_root (n
),
10317 exact_integer_floor_square_root (d
));
10320 double xx
= scm_i_divide2double (n
, d
);
10321 double abs_xx
= fabs (xx
);
10324 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10326 shift
= (scm_to_long (scm_integer_length (n
))
10327 - scm_to_long (scm_integer_length (d
))) / 2;
10329 d
= left_shift_exact_integer (d
, 2 * shift
);
10331 n
= left_shift_exact_integer (n
, -2 * shift
);
10332 xx
= scm_i_divide2double (n
, d
);
10336 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10338 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10342 /* Fallback method, when the cases above do not apply. */
10344 double xx
= scm_to_double (z
);
10346 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10348 return scm_i_from_double (sqrt (xx
));
10352 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10359 scm_init_numbers ()
10361 if (scm_install_gmp_memory_functions
)
10362 mp_set_memory_functions (custom_gmp_malloc
,
10363 custom_gmp_realloc
,
10366 mpz_init_set_si (z_negative_one
, -1);
10368 /* It may be possible to tune the performance of some algorithms by using
10369 * the following constants to avoid the creation of bignums. Please, before
10370 * using these values, remember the two rules of program optimization:
10371 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10372 scm_c_define ("most-positive-fixnum",
10373 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10374 scm_c_define ("most-negative-fixnum",
10375 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10377 scm_add_feature ("complex");
10378 scm_add_feature ("inexact");
10379 flo0
= scm_i_from_double (0.0);
10380 flo_log10e
= scm_i_from_double (M_LOG10E
);
10382 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10385 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10386 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10387 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10388 scm_i_divide2double_lo2b
,
10389 DBL_MANT_DIG
+ 1); /* 2 b^p */
10390 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10394 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10395 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10396 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10397 dbl_minimum_normal_mantissa
,
10401 #include "libguile/numbers.x"
10406 c-file-style: "gnu"