1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
3 * 2013 Free Software Foundation, Inc.
5 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
6 * and Bellcore. See scm_divide.
9 * This library is free software; you can redistribute it and/or
10 * modify it under the terms of the GNU Lesser General Public License
11 * as published by the Free Software Foundation; either version 3 of
12 * the License, or (at your option) any later version.
14 * This library is distributed in the hope that it will be useful, but
15 * WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * Lesser General Public License for more details.
19 * You should have received a copy of the GNU Lesser General Public
20 * License along with this library; if not, write to the Free Software
21 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 /* General assumptions:
27 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
28 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
29 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
30 * XXX What about infinities? They are equal to their own floor! -mhw
31 * All objects satisfying SCM_FRACTIONP are never an integer.
36 - see if special casing bignums and reals in integer-exponent when
37 possible (to use mpz_pow and mpf_pow_ui) is faster.
39 - look in to better short-circuiting of common cases in
40 integer-expt and elsewhere.
42 - see if direct mpz operations can help in ash and elsewhere.
64 #include "libguile/_scm.h"
65 #include "libguile/feature.h"
66 #include "libguile/ports.h"
67 #include "libguile/root.h"
68 #include "libguile/smob.h"
69 #include "libguile/strings.h"
70 #include "libguile/bdw-gc.h"
72 #include "libguile/validate.h"
73 #include "libguile/numbers.h"
74 #include "libguile/deprecation.h"
76 #include "libguile/eq.h"
78 /* values per glibc, if not already defined */
80 #define M_LOG10E 0.43429448190325182765
83 #define M_LN2 0.69314718055994530942
86 #define M_PI 3.14159265358979323846
89 /* FIXME: We assume that FLT_RADIX is 2 */
90 verify (FLT_RADIX
== 2);
92 typedef scm_t_signed_bits scm_t_inum
;
93 #define scm_from_inum(x) (scm_from_signed_integer (x))
95 /* Test an inum to see if it can be converted to a double without loss
96 of precision. Note that this will sometimes return 0 even when 1
97 could have been returned, e.g. for large powers of 2. It is designed
98 to be a fast check to optimize common cases. */
99 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
100 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
101 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
103 #if ! HAVE_DECL_MPZ_INITS
105 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
107 #define VARARG_MPZ_ITERATOR(func) \
109 func ## s (mpz_t x, ...) \
117 x = va_arg (ap, mpz_ptr); \
122 VARARG_MPZ_ITERATOR (mpz_init
)
123 VARARG_MPZ_ITERATOR (mpz_clear
)
130 Wonder if this might be faster for some of our code? A switch on
131 the numtag would jump directly to the right case, and the
132 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
134 #define SCM_I_NUMTAG_NOTNUM 0
135 #define SCM_I_NUMTAG_INUM 1
136 #define SCM_I_NUMTAG_BIG scm_tc16_big
137 #define SCM_I_NUMTAG_REAL scm_tc16_real
138 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
139 #define SCM_I_NUMTAG(x) \
140 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
141 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
142 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
143 : SCM_I_NUMTAG_NOTNUM)))
145 /* the macro above will not work as is with fractions */
148 /* Default to 1, because as we used to hard-code `free' as the
149 deallocator, we know that overriding these functions with
150 instrumented `malloc' / `free' is OK. */
151 int scm_install_gmp_memory_functions
= 1;
153 static SCM exactly_one_half
;
154 static SCM flo_log10e
;
156 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
158 /* FLOBUFLEN is the maximum number of characters neccessary for the
159 * printed or scm_string representation of an inexact number.
161 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
164 #if !defined (HAVE_ASINH)
165 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
167 #if !defined (HAVE_ACOSH)
168 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
170 #if !defined (HAVE_ATANH)
171 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
174 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
175 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
176 in March 2006), mpz_cmp_d now handles infinities properly. */
178 #define xmpz_cmp_d(z, d) \
179 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
181 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
185 #if defined (GUILE_I)
186 #if defined HAVE_COMPLEX_DOUBLE
188 /* For an SCM object Z which is a complex number (ie. satisfies
189 SCM_COMPLEXP), return its value as a C level "complex double". */
190 #define SCM_COMPLEX_VALUE(z) \
191 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
193 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
195 /* Convert a C "complex double" to an SCM value. */
197 scm_from_complex_double (complex double z
)
199 return scm_c_make_rectangular (creal (z
), cimag (z
));
202 #endif /* HAVE_COMPLEX_DOUBLE */
207 static mpz_t z_negative_one
;
211 /* Clear the `mpz_t' embedded in bignum PTR. */
213 finalize_bignum (void *ptr
, void *data
)
217 bignum
= PTR2SCM (ptr
);
218 mpz_clear (SCM_I_BIG_MPZ (bignum
));
221 /* The next three functions (custom_libgmp_*) are passed to
222 mp_set_memory_functions (in GMP) so that memory used by the digits
223 themselves is known to the garbage collector. This is needed so
224 that GC will be run at appropriate times. Otherwise, a program which
225 creates many large bignums would malloc a huge amount of memory
226 before the GC runs. */
228 custom_gmp_malloc (size_t alloc_size
)
230 return scm_malloc (alloc_size
);
234 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
236 return scm_realloc (old_ptr
, new_size
);
240 custom_gmp_free (void *ptr
, size_t size
)
246 /* Return a new uninitialized bignum. */
252 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
253 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
257 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
266 /* Return a newly created bignum. */
267 SCM z
= make_bignum ();
268 mpz_init (SCM_I_BIG_MPZ (z
));
273 scm_i_inum2big (scm_t_inum x
)
275 /* Return a newly created bignum initialized to X. */
276 SCM z
= make_bignum ();
277 #if SIZEOF_VOID_P == SIZEOF_LONG
278 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
280 /* Note that in this case, you'll also have to check all mpz_*_ui and
281 mpz_*_si invocations in Guile. */
282 #error creation of mpz not implemented for this inum size
288 scm_i_long2big (long x
)
290 /* Return a newly created bignum initialized to X. */
291 SCM z
= make_bignum ();
292 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
297 scm_i_ulong2big (unsigned long x
)
299 /* Return a newly created bignum initialized to X. */
300 SCM z
= make_bignum ();
301 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
306 scm_i_clonebig (SCM src_big
, int same_sign_p
)
308 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
309 SCM z
= make_bignum ();
310 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
312 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
317 scm_i_bigcmp (SCM x
, SCM y
)
319 /* Return neg if x < y, pos if x > y, and 0 if x == y */
320 /* presume we already know x and y are bignums */
321 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
322 scm_remember_upto_here_2 (x
, y
);
327 scm_i_dbl2big (double d
)
329 /* results are only defined if d is an integer */
330 SCM z
= make_bignum ();
331 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
335 /* Convert a integer in double representation to a SCM number. */
338 scm_i_dbl2num (double u
)
340 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
341 powers of 2, so there's no rounding when making "double" values
342 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
343 get rounded on a 64-bit machine, hence the "+1".
345 The use of floor() to force to an integer value ensures we get a
346 "numerically closest" value without depending on how a
347 double->long cast or how mpz_set_d will round. For reference,
348 double->long probably follows the hardware rounding mode,
349 mpz_set_d truncates towards zero. */
351 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
352 representable as a double? */
354 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
355 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
356 return SCM_I_MAKINUM ((scm_t_inum
) u
);
358 return scm_i_dbl2big (u
);
361 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
363 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
364 bignum b into a normalized significand and exponent such that
365 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
366 The return value is the significand rounded to the closest
367 representable double, and the exponent is placed into *expon_p.
368 If b is zero, then the returned exponent and significand are both
372 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
374 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
377 if (bits
> DBL_MANT_DIG
)
379 shift
= bits
- DBL_MANT_DIG
;
380 b
= round_right_shift_exact_integer (b
, shift
);
384 double signif
= frexp (SCM_I_INUM (b
), &expon
);
385 *expon_p
= expon
+ shift
;
392 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
393 scm_remember_upto_here_1 (b
);
394 *expon_p
= expon
+ shift
;
399 /* scm_i_big2dbl() rounds to the closest representable double,
400 in accordance with R5RS exact->inexact. */
402 scm_i_big2dbl (SCM b
)
405 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
406 return ldexp (signif
, expon
);
410 scm_i_normbig (SCM b
)
412 /* convert a big back to a fixnum if it'll fit */
413 /* presume b is a bignum */
414 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
416 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
417 if (SCM_FIXABLE (val
))
418 b
= SCM_I_MAKINUM (val
);
423 static SCM_C_INLINE_KEYWORD SCM
424 scm_i_mpz2num (mpz_t b
)
426 /* convert a mpz number to a SCM number. */
427 if (mpz_fits_slong_p (b
))
429 scm_t_inum val
= mpz_get_si (b
);
430 if (SCM_FIXABLE (val
))
431 return SCM_I_MAKINUM (val
);
435 SCM z
= make_bignum ();
436 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
441 /* Make the ratio NUMERATOR/DENOMINATOR, where:
442 1. NUMERATOR and DENOMINATOR are exact integers
443 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
445 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
447 /* Flip signs so that the denominator is positive. */
448 if (scm_is_false (scm_positive_p (denominator
)))
450 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
451 scm_num_overflow ("make-ratio");
454 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
455 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
459 /* Check for the integer case */
460 if (scm_is_eq (denominator
, SCM_INUM1
))
463 return scm_double_cell (scm_tc16_fraction
,
464 SCM_UNPACK (numerator
),
465 SCM_UNPACK (denominator
), 0);
468 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
470 /* Make the ratio NUMERATOR/DENOMINATOR */
472 scm_i_make_ratio (SCM numerator
, SCM denominator
)
473 #define FUNC_NAME "make-ratio"
475 /* Make sure the arguments are proper */
476 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
477 SCM_WRONG_TYPE_ARG (1, numerator
);
478 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
479 SCM_WRONG_TYPE_ARG (2, denominator
);
482 SCM the_gcd
= scm_gcd (numerator
, denominator
);
483 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
485 /* Reduce to lowest terms */
486 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
487 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
489 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
494 static mpz_t scm_i_divide2double_lo2b
;
496 /* Return the double that is closest to the exact rational N/D, with
497 ties rounded toward even mantissas. N and D must be exact
500 scm_i_divide2double (SCM n
, SCM d
)
503 mpz_t nn
, dd
, lo
, hi
, x
;
506 if (SCM_LIKELY (SCM_I_INUMP (d
)))
510 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n
))
511 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d
))))
512 /* If both N and D can be losslessly converted to doubles, then
513 we can rely on IEEE floating point to do proper rounding much
514 faster than we can. */
515 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
517 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
519 if (scm_is_true (scm_positive_p (n
)))
521 else if (scm_is_true (scm_negative_p (n
)))
527 mpz_init_set_si (dd
, SCM_I_INUM (d
));
530 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
533 mpz_init_set_si (nn
, SCM_I_INUM (n
));
535 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
537 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
541 /* Now we need to find the value of e such that:
544 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
545 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
546 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
549 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
550 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
551 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
553 where: p = DBL_MANT_DIG
554 b = FLT_RADIX (here assumed to be 2)
556 After rounding, the mantissa must be an integer between b^{p-1} and
557 (b^p - 1), except for subnormal numbers. In the inequations [1A]
558 and [1B], the middle expression represents the mantissa *before*
559 rounding, and therefore is bounded by the range of values that will
560 round to a floating-point number with the exponent e. The upper
561 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
562 ties will round up to the next power of b. The lower bound is
563 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
564 this power of b. Here we subtract 1/2b instead of 1/2 because it
565 is in the range of the next smaller exponent, where the
566 representable numbers are closer together by a factor of b.
568 Inequations [2A] and [2B] are derived from [1A] and [1B] by
569 multiplying by 2b, and in [3A] and [3B] we multiply by the
570 denominator of the middle value to obtain integer expressions.
572 In the code below, we refer to the three expressions in [3A] or
573 [3B] as lo, x, and hi. If the number is normalizable, we will
574 achieve the goal: lo <= x < hi */
576 /* Make an initial guess for e */
577 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
578 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
579 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
581 /* Compute the initial values of lo, x, and hi
582 based on the initial guess of e */
583 mpz_inits (lo
, hi
, x
, NULL
);
584 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
585 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
587 mpz_mul_2exp (lo
, lo
, e
);
588 mpz_mul_2exp (hi
, lo
, 1);
590 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
591 (but without making e less then the minimum exponent) */
592 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
594 mpz_mul_2exp (x
, x
, 1);
597 while (mpz_cmp (x
, hi
) >= 0)
599 /* If we ever used lo's value again,
600 we would need to double lo here. */
601 mpz_mul_2exp (hi
, hi
, 1);
605 /* Now compute the rounded mantissa:
606 n / b^e d (if e >= 0)
607 n b^-e / d (if e <= 0) */
613 mpz_mul_2exp (nn
, nn
, -e
);
615 mpz_mul_2exp (dd
, dd
, e
);
617 /* mpz does not directly support rounded right
618 shifts, so we have to do it the hard way.
619 For efficiency, we reuse lo and hi.
620 hi == quotient, lo == remainder */
621 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
623 /* The fractional part of the unrounded mantissa would be
624 remainder/dividend, i.e. lo/dd. So we have a tie if
625 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
626 integer expression 2*lo = dd. Here we do that comparison
627 to decide whether to round up or down. */
628 mpz_mul_2exp (lo
, lo
, 1);
629 cmp
= mpz_cmp (lo
, dd
);
630 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
631 mpz_add_ui (hi
, hi
, 1);
633 result
= ldexp (mpz_get_d (hi
), e
);
637 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
643 scm_i_fraction2double (SCM z
)
645 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
646 SCM_FRACTION_DENOMINATOR (z
));
650 scm_i_from_double (double val
)
654 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
656 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
657 SCM_REAL_VALUE (z
) = val
;
662 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
664 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
666 #define FUNC_NAME s_scm_exact_p
668 if (SCM_INEXACTP (x
))
670 else if (SCM_NUMBERP (x
))
673 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
678 scm_is_exact (SCM val
)
680 return scm_is_true (scm_exact_p (val
));
683 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
685 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
687 #define FUNC_NAME s_scm_inexact_p
689 if (SCM_INEXACTP (x
))
691 else if (SCM_NUMBERP (x
))
694 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
699 scm_is_inexact (SCM val
)
701 return scm_is_true (scm_inexact_p (val
));
704 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
706 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
708 #define FUNC_NAME s_scm_odd_p
712 scm_t_inum val
= SCM_I_INUM (n
);
713 return scm_from_bool ((val
& 1L) != 0);
715 else if (SCM_BIGP (n
))
717 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
718 scm_remember_upto_here_1 (n
);
719 return scm_from_bool (odd_p
);
721 else if (SCM_REALP (n
))
723 double val
= SCM_REAL_VALUE (n
);
726 double rem
= fabs (fmod (val
, 2.0));
733 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
738 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
740 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
742 #define FUNC_NAME s_scm_even_p
746 scm_t_inum val
= SCM_I_INUM (n
);
747 return scm_from_bool ((val
& 1L) == 0);
749 else if (SCM_BIGP (n
))
751 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
752 scm_remember_upto_here_1 (n
);
753 return scm_from_bool (even_p
);
755 else if (SCM_REALP (n
))
757 double val
= SCM_REAL_VALUE (n
);
760 double rem
= fabs (fmod (val
, 2.0));
767 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
771 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
773 "Return @code{#t} if the real number @var{x} is neither\n"
774 "infinite nor a NaN, @code{#f} otherwise.")
775 #define FUNC_NAME s_scm_finite_p
778 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
779 else if (scm_is_real (x
))
782 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
786 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
788 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
789 "@samp{-inf.0}. Otherwise return @code{#f}.")
790 #define FUNC_NAME s_scm_inf_p
793 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
794 else if (scm_is_real (x
))
797 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
801 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
803 "Return @code{#t} if the real number @var{x} is a NaN,\n"
804 "or @code{#f} otherwise.")
805 #define FUNC_NAME s_scm_nan_p
808 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
809 else if (scm_is_real (x
))
812 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
816 /* Guile's idea of infinity. */
817 static double guile_Inf
;
819 /* Guile's idea of not a number. */
820 static double guile_NaN
;
823 guile_ieee_init (void)
825 /* Some version of gcc on some old version of Linux used to crash when
826 trying to make Inf and NaN. */
829 /* C99 INFINITY, when available.
830 FIXME: The standard allows for INFINITY to be something that overflows
831 at compile time. We ought to have a configure test to check for that
832 before trying to use it. (But in practice we believe this is not a
833 problem on any system guile is likely to target.) */
834 guile_Inf
= INFINITY
;
835 #elif defined HAVE_DINFINITY
837 extern unsigned int DINFINITY
[2];
838 guile_Inf
= (*((double *) (DINFINITY
)));
845 if (guile_Inf
== tmp
)
852 /* C99 NAN, when available */
854 #elif defined HAVE_DQNAN
857 extern unsigned int DQNAN
[2];
858 guile_NaN
= (*((double *)(DQNAN
)));
861 guile_NaN
= guile_Inf
/ guile_Inf
;
865 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
868 #define FUNC_NAME s_scm_inf
870 static int initialized
= 0;
876 return scm_i_from_double (guile_Inf
);
880 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
883 #define FUNC_NAME s_scm_nan
885 static int initialized
= 0;
891 return scm_i_from_double (guile_NaN
);
896 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
898 "Return the absolute value of @var{x}.")
899 #define FUNC_NAME s_scm_abs
903 scm_t_inum xx
= SCM_I_INUM (x
);
906 else if (SCM_POSFIXABLE (-xx
))
907 return SCM_I_MAKINUM (-xx
);
909 return scm_i_inum2big (-xx
);
911 else if (SCM_LIKELY (SCM_REALP (x
)))
913 double xx
= SCM_REAL_VALUE (x
);
914 /* If x is a NaN then xx<0 is false so we return x unchanged */
916 return scm_i_from_double (-xx
);
917 /* Handle signed zeroes properly */
918 else if (SCM_UNLIKELY (xx
== 0.0))
923 else if (SCM_BIGP (x
))
925 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
927 return scm_i_clonebig (x
, 0);
931 else if (SCM_FRACTIONP (x
))
933 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
935 return scm_i_make_ratio_already_reduced
936 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
937 SCM_FRACTION_DENOMINATOR (x
));
940 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
945 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
947 "Return the quotient of the numbers @var{x} and @var{y}.")
948 #define FUNC_NAME s_scm_quotient
950 if (SCM_LIKELY (scm_is_integer (x
)))
952 if (SCM_LIKELY (scm_is_integer (y
)))
953 return scm_truncate_quotient (x
, y
);
955 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
958 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
962 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
964 "Return the remainder of the numbers @var{x} and @var{y}.\n"
966 "(remainder 13 4) @result{} 1\n"
967 "(remainder -13 4) @result{} -1\n"
969 #define FUNC_NAME s_scm_remainder
971 if (SCM_LIKELY (scm_is_integer (x
)))
973 if (SCM_LIKELY (scm_is_integer (y
)))
974 return scm_truncate_remainder (x
, y
);
976 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
979 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
984 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
986 "Return the modulo of the numbers @var{x} and @var{y}.\n"
988 "(modulo 13 4) @result{} 1\n"
989 "(modulo -13 4) @result{} 3\n"
991 #define FUNC_NAME s_scm_modulo
993 if (SCM_LIKELY (scm_is_integer (x
)))
995 if (SCM_LIKELY (scm_is_integer (y
)))
996 return scm_floor_remainder (x
, y
);
998 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
1001 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
1005 /* Return the exact integer q such that n = q*d, for exact integers n
1006 and d, where d is known in advance to divide n evenly (with zero
1007 remainder). For large integers, this can be computed more
1008 efficiently than when the remainder is unknown. */
1010 scm_exact_integer_quotient (SCM n
, SCM d
)
1011 #define FUNC_NAME "exact-integer-quotient"
1013 if (SCM_LIKELY (SCM_I_INUMP (n
)))
1015 scm_t_inum nn
= SCM_I_INUM (n
);
1016 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1018 scm_t_inum dd
= SCM_I_INUM (d
);
1019 if (SCM_UNLIKELY (dd
== 0))
1020 scm_num_overflow ("exact-integer-quotient");
1023 scm_t_inum qq
= nn
/ dd
;
1024 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1025 return SCM_I_MAKINUM (qq
);
1027 return scm_i_inum2big (qq
);
1030 else if (SCM_LIKELY (SCM_BIGP (d
)))
1032 /* n is an inum and d is a bignum. Given that d is known to
1033 divide n evenly, there are only two possibilities: n is 0,
1034 or else n is fixnum-min and d is abs(fixnum-min). */
1038 return SCM_I_MAKINUM (-1);
1041 SCM_WRONG_TYPE_ARG (2, d
);
1043 else if (SCM_LIKELY (SCM_BIGP (n
)))
1045 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1047 scm_t_inum dd
= SCM_I_INUM (d
);
1048 if (SCM_UNLIKELY (dd
== 0))
1049 scm_num_overflow ("exact-integer-quotient");
1050 else if (SCM_UNLIKELY (dd
== 1))
1054 SCM q
= scm_i_mkbig ();
1056 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1059 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1060 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1062 scm_remember_upto_here_1 (n
);
1063 return scm_i_normbig (q
);
1066 else if (SCM_LIKELY (SCM_BIGP (d
)))
1068 SCM q
= scm_i_mkbig ();
1069 mpz_divexact (SCM_I_BIG_MPZ (q
),
1072 scm_remember_upto_here_2 (n
, d
);
1073 return scm_i_normbig (q
);
1076 SCM_WRONG_TYPE_ARG (2, d
);
1079 SCM_WRONG_TYPE_ARG (1, n
);
1083 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1084 two-valued functions. It is called from primitive generics that take
1085 two arguments and return two values, when the core procedure is
1086 unable to handle the given argument types. If there are GOOPS
1087 methods for this primitive generic, it dispatches to GOOPS and, if
1088 successful, expects two values to be returned, which are placed in
1089 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1090 wrong-type-arg exception.
1092 FIXME: This obviously belongs somewhere else, but until we decide on
1093 the right API, it is here as a static function, because it is needed
1094 by the *_divide functions below.
1097 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1098 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1100 if (SCM_UNPACK (gf
))
1101 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
1103 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1106 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1108 "Return the integer @var{q} such that\n"
1109 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1110 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1112 "(euclidean-quotient 123 10) @result{} 12\n"
1113 "(euclidean-quotient 123 -10) @result{} -12\n"
1114 "(euclidean-quotient -123 10) @result{} -13\n"
1115 "(euclidean-quotient -123 -10) @result{} 13\n"
1116 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1117 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1119 #define FUNC_NAME s_scm_euclidean_quotient
1121 if (scm_is_false (scm_negative_p (y
)))
1122 return scm_floor_quotient (x
, y
);
1124 return scm_ceiling_quotient (x
, y
);
1128 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1130 "Return the real number @var{r} such that\n"
1131 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1132 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1133 "for some integer @var{q}.\n"
1135 "(euclidean-remainder 123 10) @result{} 3\n"
1136 "(euclidean-remainder 123 -10) @result{} 3\n"
1137 "(euclidean-remainder -123 10) @result{} 7\n"
1138 "(euclidean-remainder -123 -10) @result{} 7\n"
1139 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1140 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1142 #define FUNC_NAME s_scm_euclidean_remainder
1144 if (scm_is_false (scm_negative_p (y
)))
1145 return scm_floor_remainder (x
, y
);
1147 return scm_ceiling_remainder (x
, y
);
1151 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1153 "Return the integer @var{q} and the real number @var{r}\n"
1154 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1155 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1157 "(euclidean/ 123 10) @result{} 12 and 3\n"
1158 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1159 "(euclidean/ -123 10) @result{} -13 and 7\n"
1160 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1161 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1162 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1164 #define FUNC_NAME s_scm_i_euclidean_divide
1166 if (scm_is_false (scm_negative_p (y
)))
1167 return scm_i_floor_divide (x
, y
);
1169 return scm_i_ceiling_divide (x
, y
);
1174 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1176 if (scm_is_false (scm_negative_p (y
)))
1177 return scm_floor_divide (x
, y
, qp
, rp
);
1179 return scm_ceiling_divide (x
, y
, qp
, rp
);
1182 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1183 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1185 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1187 "Return the floor of @math{@var{x} / @var{y}}.\n"
1189 "(floor-quotient 123 10) @result{} 12\n"
1190 "(floor-quotient 123 -10) @result{} -13\n"
1191 "(floor-quotient -123 10) @result{} -13\n"
1192 "(floor-quotient -123 -10) @result{} 12\n"
1193 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1194 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1196 #define FUNC_NAME s_scm_floor_quotient
1198 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1200 scm_t_inum xx
= SCM_I_INUM (x
);
1201 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1203 scm_t_inum yy
= SCM_I_INUM (y
);
1204 scm_t_inum xx1
= xx
;
1206 if (SCM_LIKELY (yy
> 0))
1208 if (SCM_UNLIKELY (xx
< 0))
1211 else if (SCM_UNLIKELY (yy
== 0))
1212 scm_num_overflow (s_scm_floor_quotient
);
1216 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1217 return SCM_I_MAKINUM (qq
);
1219 return scm_i_inum2big (qq
);
1221 else if (SCM_BIGP (y
))
1223 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1224 scm_remember_upto_here_1 (y
);
1226 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1228 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1230 else if (SCM_REALP (y
))
1231 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1232 else if (SCM_FRACTIONP (y
))
1233 return scm_i_exact_rational_floor_quotient (x
, y
);
1235 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1236 s_scm_floor_quotient
);
1238 else if (SCM_BIGP (x
))
1240 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1242 scm_t_inum yy
= SCM_I_INUM (y
);
1243 if (SCM_UNLIKELY (yy
== 0))
1244 scm_num_overflow (s_scm_floor_quotient
);
1245 else if (SCM_UNLIKELY (yy
== 1))
1249 SCM q
= scm_i_mkbig ();
1251 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1254 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1255 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1257 scm_remember_upto_here_1 (x
);
1258 return scm_i_normbig (q
);
1261 else if (SCM_BIGP (y
))
1263 SCM q
= scm_i_mkbig ();
1264 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1267 scm_remember_upto_here_2 (x
, y
);
1268 return scm_i_normbig (q
);
1270 else if (SCM_REALP (y
))
1271 return scm_i_inexact_floor_quotient
1272 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1273 else if (SCM_FRACTIONP (y
))
1274 return scm_i_exact_rational_floor_quotient (x
, y
);
1276 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1277 s_scm_floor_quotient
);
1279 else if (SCM_REALP (x
))
1281 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1282 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1283 return scm_i_inexact_floor_quotient
1284 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1286 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1287 s_scm_floor_quotient
);
1289 else if (SCM_FRACTIONP (x
))
1292 return scm_i_inexact_floor_quotient
1293 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1294 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1295 return scm_i_exact_rational_floor_quotient (x
, y
);
1297 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1298 s_scm_floor_quotient
);
1301 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1302 s_scm_floor_quotient
);
1307 scm_i_inexact_floor_quotient (double x
, double y
)
1309 if (SCM_UNLIKELY (y
== 0))
1310 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1312 return scm_i_from_double (floor (x
/ y
));
1316 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1318 return scm_floor_quotient
1319 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1320 scm_product (scm_numerator (y
), scm_denominator (x
)));
1323 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1324 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1326 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1328 "Return the real number @var{r} such that\n"
1329 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1330 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1332 "(floor-remainder 123 10) @result{} 3\n"
1333 "(floor-remainder 123 -10) @result{} -7\n"
1334 "(floor-remainder -123 10) @result{} 7\n"
1335 "(floor-remainder -123 -10) @result{} -3\n"
1336 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1337 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1339 #define FUNC_NAME s_scm_floor_remainder
1341 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1343 scm_t_inum xx
= SCM_I_INUM (x
);
1344 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1346 scm_t_inum yy
= SCM_I_INUM (y
);
1347 if (SCM_UNLIKELY (yy
== 0))
1348 scm_num_overflow (s_scm_floor_remainder
);
1351 scm_t_inum rr
= xx
% yy
;
1352 int needs_adjustment
;
1354 if (SCM_LIKELY (yy
> 0))
1355 needs_adjustment
= (rr
< 0);
1357 needs_adjustment
= (rr
> 0);
1359 if (needs_adjustment
)
1361 return SCM_I_MAKINUM (rr
);
1364 else if (SCM_BIGP (y
))
1366 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1367 scm_remember_upto_here_1 (y
);
1372 SCM r
= scm_i_mkbig ();
1373 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1374 scm_remember_upto_here_1 (y
);
1375 return scm_i_normbig (r
);
1384 SCM r
= scm_i_mkbig ();
1385 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1386 scm_remember_upto_here_1 (y
);
1387 return scm_i_normbig (r
);
1390 else if (SCM_REALP (y
))
1391 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1392 else if (SCM_FRACTIONP (y
))
1393 return scm_i_exact_rational_floor_remainder (x
, y
);
1395 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1396 s_scm_floor_remainder
);
1398 else if (SCM_BIGP (x
))
1400 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1402 scm_t_inum yy
= SCM_I_INUM (y
);
1403 if (SCM_UNLIKELY (yy
== 0))
1404 scm_num_overflow (s_scm_floor_remainder
);
1409 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1411 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1412 scm_remember_upto_here_1 (x
);
1413 return SCM_I_MAKINUM (rr
);
1416 else if (SCM_BIGP (y
))
1418 SCM r
= scm_i_mkbig ();
1419 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1422 scm_remember_upto_here_2 (x
, y
);
1423 return scm_i_normbig (r
);
1425 else if (SCM_REALP (y
))
1426 return scm_i_inexact_floor_remainder
1427 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1428 else if (SCM_FRACTIONP (y
))
1429 return scm_i_exact_rational_floor_remainder (x
, y
);
1431 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1432 s_scm_floor_remainder
);
1434 else if (SCM_REALP (x
))
1436 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1437 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1438 return scm_i_inexact_floor_remainder
1439 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1441 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1442 s_scm_floor_remainder
);
1444 else if (SCM_FRACTIONP (x
))
1447 return scm_i_inexact_floor_remainder
1448 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1449 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1450 return scm_i_exact_rational_floor_remainder (x
, y
);
1452 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1453 s_scm_floor_remainder
);
1456 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1457 s_scm_floor_remainder
);
1462 scm_i_inexact_floor_remainder (double x
, double y
)
1464 /* Although it would be more efficient to use fmod here, we can't
1465 because it would in some cases produce results inconsistent with
1466 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1467 close). In particular, when x is very close to a multiple of y,
1468 then r might be either 0.0 or y, but those two cases must
1469 correspond to different choices of q. If r = 0.0 then q must be
1470 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1471 and remainder chooses the other, it would be bad. */
1472 if (SCM_UNLIKELY (y
== 0))
1473 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1475 return scm_i_from_double (x
- y
* floor (x
/ y
));
1479 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1481 SCM xd
= scm_denominator (x
);
1482 SCM yd
= scm_denominator (y
);
1483 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1484 scm_product (scm_numerator (y
), xd
));
1485 return scm_divide (r1
, scm_product (xd
, yd
));
1489 static void scm_i_inexact_floor_divide (double x
, double y
,
1491 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1494 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1496 "Return the integer @var{q} and the real number @var{r}\n"
1497 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1498 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1500 "(floor/ 123 10) @result{} 12 and 3\n"
1501 "(floor/ 123 -10) @result{} -13 and -7\n"
1502 "(floor/ -123 10) @result{} -13 and 7\n"
1503 "(floor/ -123 -10) @result{} 12 and -3\n"
1504 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1505 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1507 #define FUNC_NAME s_scm_i_floor_divide
1511 scm_floor_divide(x
, y
, &q
, &r
);
1512 return scm_values (scm_list_2 (q
, r
));
1516 #define s_scm_floor_divide s_scm_i_floor_divide
1517 #define g_scm_floor_divide g_scm_i_floor_divide
1520 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1522 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1524 scm_t_inum xx
= SCM_I_INUM (x
);
1525 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1527 scm_t_inum yy
= SCM_I_INUM (y
);
1528 if (SCM_UNLIKELY (yy
== 0))
1529 scm_num_overflow (s_scm_floor_divide
);
1532 scm_t_inum qq
= xx
/ yy
;
1533 scm_t_inum rr
= xx
% yy
;
1534 int needs_adjustment
;
1536 if (SCM_LIKELY (yy
> 0))
1537 needs_adjustment
= (rr
< 0);
1539 needs_adjustment
= (rr
> 0);
1541 if (needs_adjustment
)
1547 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1548 *qp
= SCM_I_MAKINUM (qq
);
1550 *qp
= scm_i_inum2big (qq
);
1551 *rp
= SCM_I_MAKINUM (rr
);
1555 else if (SCM_BIGP (y
))
1557 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1558 scm_remember_upto_here_1 (y
);
1563 SCM r
= scm_i_mkbig ();
1564 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1565 scm_remember_upto_here_1 (y
);
1566 *qp
= SCM_I_MAKINUM (-1);
1567 *rp
= scm_i_normbig (r
);
1582 SCM r
= scm_i_mkbig ();
1583 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1584 scm_remember_upto_here_1 (y
);
1585 *qp
= SCM_I_MAKINUM (-1);
1586 *rp
= scm_i_normbig (r
);
1590 else if (SCM_REALP (y
))
1591 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1592 else if (SCM_FRACTIONP (y
))
1593 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1595 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1596 s_scm_floor_divide
, qp
, rp
);
1598 else if (SCM_BIGP (x
))
1600 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1602 scm_t_inum yy
= SCM_I_INUM (y
);
1603 if (SCM_UNLIKELY (yy
== 0))
1604 scm_num_overflow (s_scm_floor_divide
);
1607 SCM q
= scm_i_mkbig ();
1608 SCM r
= scm_i_mkbig ();
1610 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1611 SCM_I_BIG_MPZ (x
), yy
);
1614 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1615 SCM_I_BIG_MPZ (x
), -yy
);
1616 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1618 scm_remember_upto_here_1 (x
);
1619 *qp
= scm_i_normbig (q
);
1620 *rp
= scm_i_normbig (r
);
1624 else if (SCM_BIGP (y
))
1626 SCM q
= scm_i_mkbig ();
1627 SCM r
= scm_i_mkbig ();
1628 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1629 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1630 scm_remember_upto_here_2 (x
, y
);
1631 *qp
= scm_i_normbig (q
);
1632 *rp
= scm_i_normbig (r
);
1635 else if (SCM_REALP (y
))
1636 return scm_i_inexact_floor_divide
1637 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1638 else if (SCM_FRACTIONP (y
))
1639 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1641 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1642 s_scm_floor_divide
, qp
, rp
);
1644 else if (SCM_REALP (x
))
1646 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1647 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1648 return scm_i_inexact_floor_divide
1649 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1651 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1652 s_scm_floor_divide
, qp
, rp
);
1654 else if (SCM_FRACTIONP (x
))
1657 return scm_i_inexact_floor_divide
1658 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1659 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1660 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1662 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1663 s_scm_floor_divide
, qp
, rp
);
1666 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1667 s_scm_floor_divide
, qp
, rp
);
1671 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1673 if (SCM_UNLIKELY (y
== 0))
1674 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1677 double q
= floor (x
/ y
);
1678 double r
= x
- q
* y
;
1679 *qp
= scm_i_from_double (q
);
1680 *rp
= scm_i_from_double (r
);
1685 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1688 SCM xd
= scm_denominator (x
);
1689 SCM yd
= scm_denominator (y
);
1691 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1692 scm_product (scm_numerator (y
), xd
),
1694 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1697 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1698 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1700 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1702 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1704 "(ceiling-quotient 123 10) @result{} 13\n"
1705 "(ceiling-quotient 123 -10) @result{} -12\n"
1706 "(ceiling-quotient -123 10) @result{} -12\n"
1707 "(ceiling-quotient -123 -10) @result{} 13\n"
1708 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1709 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1711 #define FUNC_NAME s_scm_ceiling_quotient
1713 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1715 scm_t_inum xx
= SCM_I_INUM (x
);
1716 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1718 scm_t_inum yy
= SCM_I_INUM (y
);
1719 if (SCM_UNLIKELY (yy
== 0))
1720 scm_num_overflow (s_scm_ceiling_quotient
);
1723 scm_t_inum xx1
= xx
;
1725 if (SCM_LIKELY (yy
> 0))
1727 if (SCM_LIKELY (xx
>= 0))
1733 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1734 return SCM_I_MAKINUM (qq
);
1736 return scm_i_inum2big (qq
);
1739 else if (SCM_BIGP (y
))
1741 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1742 scm_remember_upto_here_1 (y
);
1743 if (SCM_LIKELY (sign
> 0))
1745 if (SCM_LIKELY (xx
> 0))
1747 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1748 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1749 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1751 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1752 scm_remember_upto_here_1 (y
);
1753 return SCM_I_MAKINUM (-1);
1763 else if (SCM_REALP (y
))
1764 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1765 else if (SCM_FRACTIONP (y
))
1766 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1768 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1769 s_scm_ceiling_quotient
);
1771 else if (SCM_BIGP (x
))
1773 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1775 scm_t_inum yy
= SCM_I_INUM (y
);
1776 if (SCM_UNLIKELY (yy
== 0))
1777 scm_num_overflow (s_scm_ceiling_quotient
);
1778 else if (SCM_UNLIKELY (yy
== 1))
1782 SCM q
= scm_i_mkbig ();
1784 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1787 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1788 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1790 scm_remember_upto_here_1 (x
);
1791 return scm_i_normbig (q
);
1794 else if (SCM_BIGP (y
))
1796 SCM q
= scm_i_mkbig ();
1797 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1800 scm_remember_upto_here_2 (x
, y
);
1801 return scm_i_normbig (q
);
1803 else if (SCM_REALP (y
))
1804 return scm_i_inexact_ceiling_quotient
1805 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1806 else if (SCM_FRACTIONP (y
))
1807 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1809 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1810 s_scm_ceiling_quotient
);
1812 else if (SCM_REALP (x
))
1814 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1815 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1816 return scm_i_inexact_ceiling_quotient
1817 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1819 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1820 s_scm_ceiling_quotient
);
1822 else if (SCM_FRACTIONP (x
))
1825 return scm_i_inexact_ceiling_quotient
1826 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1827 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1828 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1830 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1831 s_scm_ceiling_quotient
);
1834 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1835 s_scm_ceiling_quotient
);
1840 scm_i_inexact_ceiling_quotient (double x
, double y
)
1842 if (SCM_UNLIKELY (y
== 0))
1843 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1845 return scm_i_from_double (ceil (x
/ y
));
1849 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1851 return scm_ceiling_quotient
1852 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1853 scm_product (scm_numerator (y
), scm_denominator (x
)));
1856 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1857 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1859 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1861 "Return the real number @var{r} such that\n"
1862 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1863 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1865 "(ceiling-remainder 123 10) @result{} -7\n"
1866 "(ceiling-remainder 123 -10) @result{} 3\n"
1867 "(ceiling-remainder -123 10) @result{} -3\n"
1868 "(ceiling-remainder -123 -10) @result{} 7\n"
1869 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1870 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1872 #define FUNC_NAME s_scm_ceiling_remainder
1874 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1876 scm_t_inum xx
= SCM_I_INUM (x
);
1877 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1879 scm_t_inum yy
= SCM_I_INUM (y
);
1880 if (SCM_UNLIKELY (yy
== 0))
1881 scm_num_overflow (s_scm_ceiling_remainder
);
1884 scm_t_inum rr
= xx
% yy
;
1885 int needs_adjustment
;
1887 if (SCM_LIKELY (yy
> 0))
1888 needs_adjustment
= (rr
> 0);
1890 needs_adjustment
= (rr
< 0);
1892 if (needs_adjustment
)
1894 return SCM_I_MAKINUM (rr
);
1897 else if (SCM_BIGP (y
))
1899 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1900 scm_remember_upto_here_1 (y
);
1901 if (SCM_LIKELY (sign
> 0))
1903 if (SCM_LIKELY (xx
> 0))
1905 SCM r
= scm_i_mkbig ();
1906 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1907 scm_remember_upto_here_1 (y
);
1908 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1909 return scm_i_normbig (r
);
1911 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1912 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1913 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1915 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1916 scm_remember_upto_here_1 (y
);
1926 SCM r
= scm_i_mkbig ();
1927 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1928 scm_remember_upto_here_1 (y
);
1929 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1930 return scm_i_normbig (r
);
1933 else if (SCM_REALP (y
))
1934 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1935 else if (SCM_FRACTIONP (y
))
1936 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1938 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1939 s_scm_ceiling_remainder
);
1941 else if (SCM_BIGP (x
))
1943 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1945 scm_t_inum yy
= SCM_I_INUM (y
);
1946 if (SCM_UNLIKELY (yy
== 0))
1947 scm_num_overflow (s_scm_ceiling_remainder
);
1952 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1954 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1955 scm_remember_upto_here_1 (x
);
1956 return SCM_I_MAKINUM (rr
);
1959 else if (SCM_BIGP (y
))
1961 SCM r
= scm_i_mkbig ();
1962 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1965 scm_remember_upto_here_2 (x
, y
);
1966 return scm_i_normbig (r
);
1968 else if (SCM_REALP (y
))
1969 return scm_i_inexact_ceiling_remainder
1970 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1971 else if (SCM_FRACTIONP (y
))
1972 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1974 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1975 s_scm_ceiling_remainder
);
1977 else if (SCM_REALP (x
))
1979 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1980 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1981 return scm_i_inexact_ceiling_remainder
1982 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1984 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1985 s_scm_ceiling_remainder
);
1987 else if (SCM_FRACTIONP (x
))
1990 return scm_i_inexact_ceiling_remainder
1991 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1992 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1993 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1995 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1996 s_scm_ceiling_remainder
);
1999 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
2000 s_scm_ceiling_remainder
);
2005 scm_i_inexact_ceiling_remainder (double x
, double y
)
2007 /* Although it would be more efficient to use fmod here, we can't
2008 because it would in some cases produce results inconsistent with
2009 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2010 close). In particular, when x is very close to a multiple of y,
2011 then r might be either 0.0 or -y, but those two cases must
2012 correspond to different choices of q. If r = 0.0 then q must be
2013 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2014 and remainder chooses the other, it would be bad. */
2015 if (SCM_UNLIKELY (y
== 0))
2016 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
2018 return scm_i_from_double (x
- y
* ceil (x
/ y
));
2022 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
2024 SCM xd
= scm_denominator (x
);
2025 SCM yd
= scm_denominator (y
);
2026 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
2027 scm_product (scm_numerator (y
), xd
));
2028 return scm_divide (r1
, scm_product (xd
, yd
));
2031 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2033 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2036 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2038 "Return the integer @var{q} and the real number @var{r}\n"
2039 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2040 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2042 "(ceiling/ 123 10) @result{} 13 and -7\n"
2043 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2044 "(ceiling/ -123 10) @result{} -12 and -3\n"
2045 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2046 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2047 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2049 #define FUNC_NAME s_scm_i_ceiling_divide
2053 scm_ceiling_divide(x
, y
, &q
, &r
);
2054 return scm_values (scm_list_2 (q
, r
));
2058 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2059 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2062 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2064 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2066 scm_t_inum xx
= SCM_I_INUM (x
);
2067 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2069 scm_t_inum yy
= SCM_I_INUM (y
);
2070 if (SCM_UNLIKELY (yy
== 0))
2071 scm_num_overflow (s_scm_ceiling_divide
);
2074 scm_t_inum qq
= xx
/ yy
;
2075 scm_t_inum rr
= xx
% yy
;
2076 int needs_adjustment
;
2078 if (SCM_LIKELY (yy
> 0))
2079 needs_adjustment
= (rr
> 0);
2081 needs_adjustment
= (rr
< 0);
2083 if (needs_adjustment
)
2088 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2089 *qp
= SCM_I_MAKINUM (qq
);
2091 *qp
= scm_i_inum2big (qq
);
2092 *rp
= SCM_I_MAKINUM (rr
);
2096 else if (SCM_BIGP (y
))
2098 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2099 scm_remember_upto_here_1 (y
);
2100 if (SCM_LIKELY (sign
> 0))
2102 if (SCM_LIKELY (xx
> 0))
2104 SCM r
= scm_i_mkbig ();
2105 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2106 scm_remember_upto_here_1 (y
);
2107 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2109 *rp
= scm_i_normbig (r
);
2111 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2112 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2113 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2115 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2116 scm_remember_upto_here_1 (y
);
2117 *qp
= SCM_I_MAKINUM (-1);
2133 SCM r
= scm_i_mkbig ();
2134 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2135 scm_remember_upto_here_1 (y
);
2136 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2138 *rp
= scm_i_normbig (r
);
2142 else if (SCM_REALP (y
))
2143 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2144 else if (SCM_FRACTIONP (y
))
2145 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2147 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2148 s_scm_ceiling_divide
, qp
, rp
);
2150 else if (SCM_BIGP (x
))
2152 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2154 scm_t_inum yy
= SCM_I_INUM (y
);
2155 if (SCM_UNLIKELY (yy
== 0))
2156 scm_num_overflow (s_scm_ceiling_divide
);
2159 SCM q
= scm_i_mkbig ();
2160 SCM r
= scm_i_mkbig ();
2162 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2163 SCM_I_BIG_MPZ (x
), yy
);
2166 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2167 SCM_I_BIG_MPZ (x
), -yy
);
2168 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2170 scm_remember_upto_here_1 (x
);
2171 *qp
= scm_i_normbig (q
);
2172 *rp
= scm_i_normbig (r
);
2176 else if (SCM_BIGP (y
))
2178 SCM q
= scm_i_mkbig ();
2179 SCM r
= scm_i_mkbig ();
2180 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2181 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2182 scm_remember_upto_here_2 (x
, y
);
2183 *qp
= scm_i_normbig (q
);
2184 *rp
= scm_i_normbig (r
);
2187 else if (SCM_REALP (y
))
2188 return scm_i_inexact_ceiling_divide
2189 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2190 else if (SCM_FRACTIONP (y
))
2191 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2193 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2194 s_scm_ceiling_divide
, qp
, rp
);
2196 else if (SCM_REALP (x
))
2198 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2199 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2200 return scm_i_inexact_ceiling_divide
2201 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2203 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2204 s_scm_ceiling_divide
, qp
, rp
);
2206 else if (SCM_FRACTIONP (x
))
2209 return scm_i_inexact_ceiling_divide
2210 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2211 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2212 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2214 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2215 s_scm_ceiling_divide
, qp
, rp
);
2218 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2219 s_scm_ceiling_divide
, qp
, rp
);
2223 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2225 if (SCM_UNLIKELY (y
== 0))
2226 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2229 double q
= ceil (x
/ y
);
2230 double r
= x
- q
* y
;
2231 *qp
= scm_i_from_double (q
);
2232 *rp
= scm_i_from_double (r
);
2237 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2240 SCM xd
= scm_denominator (x
);
2241 SCM yd
= scm_denominator (y
);
2243 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2244 scm_product (scm_numerator (y
), xd
),
2246 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2249 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2250 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2252 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2254 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2256 "(truncate-quotient 123 10) @result{} 12\n"
2257 "(truncate-quotient 123 -10) @result{} -12\n"
2258 "(truncate-quotient -123 10) @result{} -12\n"
2259 "(truncate-quotient -123 -10) @result{} 12\n"
2260 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2261 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2263 #define FUNC_NAME s_scm_truncate_quotient
2265 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2267 scm_t_inum xx
= SCM_I_INUM (x
);
2268 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2270 scm_t_inum yy
= SCM_I_INUM (y
);
2271 if (SCM_UNLIKELY (yy
== 0))
2272 scm_num_overflow (s_scm_truncate_quotient
);
2275 scm_t_inum qq
= xx
/ yy
;
2276 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2277 return SCM_I_MAKINUM (qq
);
2279 return scm_i_inum2big (qq
);
2282 else if (SCM_BIGP (y
))
2284 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2285 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2286 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2288 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2289 scm_remember_upto_here_1 (y
);
2290 return SCM_I_MAKINUM (-1);
2295 else if (SCM_REALP (y
))
2296 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2297 else if (SCM_FRACTIONP (y
))
2298 return scm_i_exact_rational_truncate_quotient (x
, y
);
2300 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2301 s_scm_truncate_quotient
);
2303 else if (SCM_BIGP (x
))
2305 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2307 scm_t_inum yy
= SCM_I_INUM (y
);
2308 if (SCM_UNLIKELY (yy
== 0))
2309 scm_num_overflow (s_scm_truncate_quotient
);
2310 else if (SCM_UNLIKELY (yy
== 1))
2314 SCM q
= scm_i_mkbig ();
2316 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2319 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2320 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2322 scm_remember_upto_here_1 (x
);
2323 return scm_i_normbig (q
);
2326 else if (SCM_BIGP (y
))
2328 SCM q
= scm_i_mkbig ();
2329 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2332 scm_remember_upto_here_2 (x
, y
);
2333 return scm_i_normbig (q
);
2335 else if (SCM_REALP (y
))
2336 return scm_i_inexact_truncate_quotient
2337 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2338 else if (SCM_FRACTIONP (y
))
2339 return scm_i_exact_rational_truncate_quotient (x
, y
);
2341 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2342 s_scm_truncate_quotient
);
2344 else if (SCM_REALP (x
))
2346 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2347 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2348 return scm_i_inexact_truncate_quotient
2349 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2351 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2352 s_scm_truncate_quotient
);
2354 else if (SCM_FRACTIONP (x
))
2357 return scm_i_inexact_truncate_quotient
2358 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2359 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2360 return scm_i_exact_rational_truncate_quotient (x
, y
);
2362 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2363 s_scm_truncate_quotient
);
2366 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2367 s_scm_truncate_quotient
);
2372 scm_i_inexact_truncate_quotient (double x
, double y
)
2374 if (SCM_UNLIKELY (y
== 0))
2375 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2377 return scm_i_from_double (trunc (x
/ y
));
2381 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2383 return scm_truncate_quotient
2384 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2385 scm_product (scm_numerator (y
), scm_denominator (x
)));
2388 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2389 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2391 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2393 "Return the real number @var{r} such that\n"
2394 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2395 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2397 "(truncate-remainder 123 10) @result{} 3\n"
2398 "(truncate-remainder 123 -10) @result{} 3\n"
2399 "(truncate-remainder -123 10) @result{} -3\n"
2400 "(truncate-remainder -123 -10) @result{} -3\n"
2401 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2402 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2404 #define FUNC_NAME s_scm_truncate_remainder
2406 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2408 scm_t_inum xx
= SCM_I_INUM (x
);
2409 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2411 scm_t_inum yy
= SCM_I_INUM (y
);
2412 if (SCM_UNLIKELY (yy
== 0))
2413 scm_num_overflow (s_scm_truncate_remainder
);
2415 return SCM_I_MAKINUM (xx
% yy
);
2417 else if (SCM_BIGP (y
))
2419 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2420 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2421 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2423 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2424 scm_remember_upto_here_1 (y
);
2430 else if (SCM_REALP (y
))
2431 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2432 else if (SCM_FRACTIONP (y
))
2433 return scm_i_exact_rational_truncate_remainder (x
, y
);
2435 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2436 s_scm_truncate_remainder
);
2438 else if (SCM_BIGP (x
))
2440 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2442 scm_t_inum yy
= SCM_I_INUM (y
);
2443 if (SCM_UNLIKELY (yy
== 0))
2444 scm_num_overflow (s_scm_truncate_remainder
);
2447 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2448 (yy
> 0) ? yy
: -yy
)
2449 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2450 scm_remember_upto_here_1 (x
);
2451 return SCM_I_MAKINUM (rr
);
2454 else if (SCM_BIGP (y
))
2456 SCM r
= scm_i_mkbig ();
2457 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2460 scm_remember_upto_here_2 (x
, y
);
2461 return scm_i_normbig (r
);
2463 else if (SCM_REALP (y
))
2464 return scm_i_inexact_truncate_remainder
2465 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2466 else if (SCM_FRACTIONP (y
))
2467 return scm_i_exact_rational_truncate_remainder (x
, y
);
2469 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2470 s_scm_truncate_remainder
);
2472 else if (SCM_REALP (x
))
2474 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2475 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2476 return scm_i_inexact_truncate_remainder
2477 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2479 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2480 s_scm_truncate_remainder
);
2482 else if (SCM_FRACTIONP (x
))
2485 return scm_i_inexact_truncate_remainder
2486 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2487 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2488 return scm_i_exact_rational_truncate_remainder (x
, y
);
2490 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2491 s_scm_truncate_remainder
);
2494 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2495 s_scm_truncate_remainder
);
2500 scm_i_inexact_truncate_remainder (double x
, double y
)
2502 /* Although it would be more efficient to use fmod here, we can't
2503 because it would in some cases produce results inconsistent with
2504 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2505 close). In particular, when x is very close to a multiple of y,
2506 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2507 correspond to different choices of q. If quotient chooses one and
2508 remainder chooses the other, it would be bad. */
2509 if (SCM_UNLIKELY (y
== 0))
2510 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2512 return scm_i_from_double (x
- y
* trunc (x
/ y
));
2516 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2518 SCM xd
= scm_denominator (x
);
2519 SCM yd
= scm_denominator (y
);
2520 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2521 scm_product (scm_numerator (y
), xd
));
2522 return scm_divide (r1
, scm_product (xd
, yd
));
2526 static void scm_i_inexact_truncate_divide (double x
, double y
,
2528 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2531 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2533 "Return the integer @var{q} and the real number @var{r}\n"
2534 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2535 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2537 "(truncate/ 123 10) @result{} 12 and 3\n"
2538 "(truncate/ 123 -10) @result{} -12 and 3\n"
2539 "(truncate/ -123 10) @result{} -12 and -3\n"
2540 "(truncate/ -123 -10) @result{} 12 and -3\n"
2541 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2542 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2544 #define FUNC_NAME s_scm_i_truncate_divide
2548 scm_truncate_divide(x
, y
, &q
, &r
);
2549 return scm_values (scm_list_2 (q
, r
));
2553 #define s_scm_truncate_divide s_scm_i_truncate_divide
2554 #define g_scm_truncate_divide g_scm_i_truncate_divide
2557 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2559 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2561 scm_t_inum xx
= SCM_I_INUM (x
);
2562 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2564 scm_t_inum yy
= SCM_I_INUM (y
);
2565 if (SCM_UNLIKELY (yy
== 0))
2566 scm_num_overflow (s_scm_truncate_divide
);
2569 scm_t_inum qq
= xx
/ yy
;
2570 scm_t_inum rr
= xx
% yy
;
2571 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2572 *qp
= SCM_I_MAKINUM (qq
);
2574 *qp
= scm_i_inum2big (qq
);
2575 *rp
= SCM_I_MAKINUM (rr
);
2579 else if (SCM_BIGP (y
))
2581 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2582 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2583 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2585 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2586 scm_remember_upto_here_1 (y
);
2587 *qp
= SCM_I_MAKINUM (-1);
2597 else if (SCM_REALP (y
))
2598 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2599 else if (SCM_FRACTIONP (y
))
2600 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2602 return two_valued_wta_dispatch_2
2603 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2604 s_scm_truncate_divide
, qp
, rp
);
2606 else if (SCM_BIGP (x
))
2608 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2610 scm_t_inum yy
= SCM_I_INUM (y
);
2611 if (SCM_UNLIKELY (yy
== 0))
2612 scm_num_overflow (s_scm_truncate_divide
);
2615 SCM q
= scm_i_mkbig ();
2618 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2619 SCM_I_BIG_MPZ (x
), yy
);
2622 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2623 SCM_I_BIG_MPZ (x
), -yy
);
2624 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2626 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2627 scm_remember_upto_here_1 (x
);
2628 *qp
= scm_i_normbig (q
);
2629 *rp
= SCM_I_MAKINUM (rr
);
2633 else if (SCM_BIGP (y
))
2635 SCM q
= scm_i_mkbig ();
2636 SCM r
= scm_i_mkbig ();
2637 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2638 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2639 scm_remember_upto_here_2 (x
, y
);
2640 *qp
= scm_i_normbig (q
);
2641 *rp
= scm_i_normbig (r
);
2643 else if (SCM_REALP (y
))
2644 return scm_i_inexact_truncate_divide
2645 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2646 else if (SCM_FRACTIONP (y
))
2647 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2649 return two_valued_wta_dispatch_2
2650 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2651 s_scm_truncate_divide
, qp
, rp
);
2653 else if (SCM_REALP (x
))
2655 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2656 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2657 return scm_i_inexact_truncate_divide
2658 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2660 return two_valued_wta_dispatch_2
2661 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2662 s_scm_truncate_divide
, qp
, rp
);
2664 else if (SCM_FRACTIONP (x
))
2667 return scm_i_inexact_truncate_divide
2668 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2669 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2670 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2672 return two_valued_wta_dispatch_2
2673 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2674 s_scm_truncate_divide
, qp
, rp
);
2677 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2678 s_scm_truncate_divide
, qp
, rp
);
2682 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2684 if (SCM_UNLIKELY (y
== 0))
2685 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2688 double q
= trunc (x
/ y
);
2689 double r
= x
- q
* y
;
2690 *qp
= scm_i_from_double (q
);
2691 *rp
= scm_i_from_double (r
);
2696 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2699 SCM xd
= scm_denominator (x
);
2700 SCM yd
= scm_denominator (y
);
2702 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2703 scm_product (scm_numerator (y
), xd
),
2705 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2708 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2709 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2710 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2712 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2714 "Return the integer @var{q} such that\n"
2715 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2716 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2718 "(centered-quotient 123 10) @result{} 12\n"
2719 "(centered-quotient 123 -10) @result{} -12\n"
2720 "(centered-quotient -123 10) @result{} -12\n"
2721 "(centered-quotient -123 -10) @result{} 12\n"
2722 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2723 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2725 #define FUNC_NAME s_scm_centered_quotient
2727 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2729 scm_t_inum xx
= SCM_I_INUM (x
);
2730 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2732 scm_t_inum yy
= SCM_I_INUM (y
);
2733 if (SCM_UNLIKELY (yy
== 0))
2734 scm_num_overflow (s_scm_centered_quotient
);
2737 scm_t_inum qq
= xx
/ yy
;
2738 scm_t_inum rr
= xx
% yy
;
2739 if (SCM_LIKELY (xx
> 0))
2741 if (SCM_LIKELY (yy
> 0))
2743 if (rr
>= (yy
+ 1) / 2)
2748 if (rr
>= (1 - yy
) / 2)
2754 if (SCM_LIKELY (yy
> 0))
2765 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2766 return SCM_I_MAKINUM (qq
);
2768 return scm_i_inum2big (qq
);
2771 else if (SCM_BIGP (y
))
2773 /* Pass a denormalized bignum version of x (even though it
2774 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2775 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2777 else if (SCM_REALP (y
))
2778 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2779 else if (SCM_FRACTIONP (y
))
2780 return scm_i_exact_rational_centered_quotient (x
, y
);
2782 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2783 s_scm_centered_quotient
);
2785 else if (SCM_BIGP (x
))
2787 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2789 scm_t_inum yy
= SCM_I_INUM (y
);
2790 if (SCM_UNLIKELY (yy
== 0))
2791 scm_num_overflow (s_scm_centered_quotient
);
2792 else if (SCM_UNLIKELY (yy
== 1))
2796 SCM q
= scm_i_mkbig ();
2798 /* Arrange for rr to initially be non-positive,
2799 because that simplifies the test to see
2800 if it is within the needed bounds. */
2803 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2804 SCM_I_BIG_MPZ (x
), yy
);
2805 scm_remember_upto_here_1 (x
);
2807 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2808 SCM_I_BIG_MPZ (q
), 1);
2812 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2813 SCM_I_BIG_MPZ (x
), -yy
);
2814 scm_remember_upto_here_1 (x
);
2815 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2817 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2818 SCM_I_BIG_MPZ (q
), 1);
2820 return scm_i_normbig (q
);
2823 else if (SCM_BIGP (y
))
2824 return scm_i_bigint_centered_quotient (x
, y
);
2825 else if (SCM_REALP (y
))
2826 return scm_i_inexact_centered_quotient
2827 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2828 else if (SCM_FRACTIONP (y
))
2829 return scm_i_exact_rational_centered_quotient (x
, y
);
2831 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2832 s_scm_centered_quotient
);
2834 else if (SCM_REALP (x
))
2836 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2837 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2838 return scm_i_inexact_centered_quotient
2839 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2841 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2842 s_scm_centered_quotient
);
2844 else if (SCM_FRACTIONP (x
))
2847 return scm_i_inexact_centered_quotient
2848 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2849 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2850 return scm_i_exact_rational_centered_quotient (x
, y
);
2852 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2853 s_scm_centered_quotient
);
2856 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2857 s_scm_centered_quotient
);
2862 scm_i_inexact_centered_quotient (double x
, double y
)
2864 if (SCM_LIKELY (y
> 0))
2865 return scm_i_from_double (floor (x
/y
+ 0.5));
2866 else if (SCM_LIKELY (y
< 0))
2867 return scm_i_from_double (ceil (x
/y
- 0.5));
2869 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2874 /* Assumes that both x and y are bigints, though
2875 x might be able to fit into a fixnum. */
2877 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2881 /* Note that x might be small enough to fit into a
2882 fixnum, so we must not let it escape into the wild */
2886 /* min_r will eventually become -abs(y)/2 */
2887 min_r
= scm_i_mkbig ();
2888 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2889 SCM_I_BIG_MPZ (y
), 1);
2891 /* Arrange for rr to initially be non-positive,
2892 because that simplifies the test to see
2893 if it is within the needed bounds. */
2894 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2896 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2897 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2898 scm_remember_upto_here_2 (x
, y
);
2899 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2900 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2901 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2902 SCM_I_BIG_MPZ (q
), 1);
2906 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2907 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2908 scm_remember_upto_here_2 (x
, y
);
2909 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2910 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2911 SCM_I_BIG_MPZ (q
), 1);
2913 scm_remember_upto_here_2 (r
, min_r
);
2914 return scm_i_normbig (q
);
2918 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2920 return scm_centered_quotient
2921 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2922 scm_product (scm_numerator (y
), scm_denominator (x
)));
2925 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2926 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2927 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2929 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2931 "Return the real number @var{r} such that\n"
2932 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2933 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2934 "for some integer @var{q}.\n"
2936 "(centered-remainder 123 10) @result{} 3\n"
2937 "(centered-remainder 123 -10) @result{} 3\n"
2938 "(centered-remainder -123 10) @result{} -3\n"
2939 "(centered-remainder -123 -10) @result{} -3\n"
2940 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2941 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2943 #define FUNC_NAME s_scm_centered_remainder
2945 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2947 scm_t_inum xx
= SCM_I_INUM (x
);
2948 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2950 scm_t_inum yy
= SCM_I_INUM (y
);
2951 if (SCM_UNLIKELY (yy
== 0))
2952 scm_num_overflow (s_scm_centered_remainder
);
2955 scm_t_inum rr
= xx
% yy
;
2956 if (SCM_LIKELY (xx
> 0))
2958 if (SCM_LIKELY (yy
> 0))
2960 if (rr
>= (yy
+ 1) / 2)
2965 if (rr
>= (1 - yy
) / 2)
2971 if (SCM_LIKELY (yy
> 0))
2982 return SCM_I_MAKINUM (rr
);
2985 else if (SCM_BIGP (y
))
2987 /* Pass a denormalized bignum version of x (even though it
2988 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2989 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2991 else if (SCM_REALP (y
))
2992 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2993 else if (SCM_FRACTIONP (y
))
2994 return scm_i_exact_rational_centered_remainder (x
, y
);
2996 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2997 s_scm_centered_remainder
);
2999 else if (SCM_BIGP (x
))
3001 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3003 scm_t_inum yy
= SCM_I_INUM (y
);
3004 if (SCM_UNLIKELY (yy
== 0))
3005 scm_num_overflow (s_scm_centered_remainder
);
3009 /* Arrange for rr to initially be non-positive,
3010 because that simplifies the test to see
3011 if it is within the needed bounds. */
3014 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
3015 scm_remember_upto_here_1 (x
);
3021 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
3022 scm_remember_upto_here_1 (x
);
3026 return SCM_I_MAKINUM (rr
);
3029 else if (SCM_BIGP (y
))
3030 return scm_i_bigint_centered_remainder (x
, y
);
3031 else if (SCM_REALP (y
))
3032 return scm_i_inexact_centered_remainder
3033 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3034 else if (SCM_FRACTIONP (y
))
3035 return scm_i_exact_rational_centered_remainder (x
, y
);
3037 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3038 s_scm_centered_remainder
);
3040 else if (SCM_REALP (x
))
3042 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3043 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3044 return scm_i_inexact_centered_remainder
3045 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3047 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3048 s_scm_centered_remainder
);
3050 else if (SCM_FRACTIONP (x
))
3053 return scm_i_inexact_centered_remainder
3054 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3055 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3056 return scm_i_exact_rational_centered_remainder (x
, y
);
3058 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3059 s_scm_centered_remainder
);
3062 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3063 s_scm_centered_remainder
);
3068 scm_i_inexact_centered_remainder (double x
, double y
)
3072 /* Although it would be more efficient to use fmod here, we can't
3073 because it would in some cases produce results inconsistent with
3074 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3075 close). In particular, when x-y/2 is very close to a multiple of
3076 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3077 two cases must correspond to different choices of q. If quotient
3078 chooses one and remainder chooses the other, it would be bad. */
3079 if (SCM_LIKELY (y
> 0))
3080 q
= floor (x
/y
+ 0.5);
3081 else if (SCM_LIKELY (y
< 0))
3082 q
= ceil (x
/y
- 0.5);
3084 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3087 return scm_i_from_double (x
- q
* y
);
3090 /* Assumes that both x and y are bigints, though
3091 x might be able to fit into a fixnum. */
3093 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3097 /* Note that x might be small enough to fit into a
3098 fixnum, so we must not let it escape into the wild */
3101 /* min_r will eventually become -abs(y)/2 */
3102 min_r
= scm_i_mkbig ();
3103 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3104 SCM_I_BIG_MPZ (y
), 1);
3106 /* Arrange for rr to initially be non-positive,
3107 because that simplifies the test to see
3108 if it is within the needed bounds. */
3109 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3111 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3112 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3113 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3114 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3115 mpz_add (SCM_I_BIG_MPZ (r
),
3121 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3122 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3123 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3124 mpz_sub (SCM_I_BIG_MPZ (r
),
3128 scm_remember_upto_here_2 (x
, y
);
3129 return scm_i_normbig (r
);
3133 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3135 SCM xd
= scm_denominator (x
);
3136 SCM yd
= scm_denominator (y
);
3137 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3138 scm_product (scm_numerator (y
), xd
));
3139 return scm_divide (r1
, scm_product (xd
, yd
));
3143 static void scm_i_inexact_centered_divide (double x
, double y
,
3145 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3146 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3149 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3151 "Return the integer @var{q} and the real number @var{r}\n"
3152 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3153 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3155 "(centered/ 123 10) @result{} 12 and 3\n"
3156 "(centered/ 123 -10) @result{} -12 and 3\n"
3157 "(centered/ -123 10) @result{} -12 and -3\n"
3158 "(centered/ -123 -10) @result{} 12 and -3\n"
3159 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3160 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3162 #define FUNC_NAME s_scm_i_centered_divide
3166 scm_centered_divide(x
, y
, &q
, &r
);
3167 return scm_values (scm_list_2 (q
, r
));
3171 #define s_scm_centered_divide s_scm_i_centered_divide
3172 #define g_scm_centered_divide g_scm_i_centered_divide
3175 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3177 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3179 scm_t_inum xx
= SCM_I_INUM (x
);
3180 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3182 scm_t_inum yy
= SCM_I_INUM (y
);
3183 if (SCM_UNLIKELY (yy
== 0))
3184 scm_num_overflow (s_scm_centered_divide
);
3187 scm_t_inum qq
= xx
/ yy
;
3188 scm_t_inum rr
= xx
% yy
;
3189 if (SCM_LIKELY (xx
> 0))
3191 if (SCM_LIKELY (yy
> 0))
3193 if (rr
>= (yy
+ 1) / 2)
3198 if (rr
>= (1 - yy
) / 2)
3204 if (SCM_LIKELY (yy
> 0))
3215 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3216 *qp
= SCM_I_MAKINUM (qq
);
3218 *qp
= scm_i_inum2big (qq
);
3219 *rp
= SCM_I_MAKINUM (rr
);
3223 else if (SCM_BIGP (y
))
3225 /* Pass a denormalized bignum version of x (even though it
3226 can fit in a fixnum) to scm_i_bigint_centered_divide */
3227 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3229 else if (SCM_REALP (y
))
3230 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3231 else if (SCM_FRACTIONP (y
))
3232 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3234 return two_valued_wta_dispatch_2
3235 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3236 s_scm_centered_divide
, qp
, rp
);
3238 else if (SCM_BIGP (x
))
3240 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3242 scm_t_inum yy
= SCM_I_INUM (y
);
3243 if (SCM_UNLIKELY (yy
== 0))
3244 scm_num_overflow (s_scm_centered_divide
);
3247 SCM q
= scm_i_mkbig ();
3249 /* Arrange for rr to initially be non-positive,
3250 because that simplifies the test to see
3251 if it is within the needed bounds. */
3254 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3255 SCM_I_BIG_MPZ (x
), yy
);
3256 scm_remember_upto_here_1 (x
);
3259 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3260 SCM_I_BIG_MPZ (q
), 1);
3266 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3267 SCM_I_BIG_MPZ (x
), -yy
);
3268 scm_remember_upto_here_1 (x
);
3269 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3272 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3273 SCM_I_BIG_MPZ (q
), 1);
3277 *qp
= scm_i_normbig (q
);
3278 *rp
= SCM_I_MAKINUM (rr
);
3282 else if (SCM_BIGP (y
))
3283 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3284 else if (SCM_REALP (y
))
3285 return scm_i_inexact_centered_divide
3286 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3287 else if (SCM_FRACTIONP (y
))
3288 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3290 return two_valued_wta_dispatch_2
3291 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3292 s_scm_centered_divide
, qp
, rp
);
3294 else if (SCM_REALP (x
))
3296 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3297 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3298 return scm_i_inexact_centered_divide
3299 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3301 return two_valued_wta_dispatch_2
3302 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3303 s_scm_centered_divide
, qp
, rp
);
3305 else if (SCM_FRACTIONP (x
))
3308 return scm_i_inexact_centered_divide
3309 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3310 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3311 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3313 return two_valued_wta_dispatch_2
3314 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3315 s_scm_centered_divide
, qp
, rp
);
3318 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3319 s_scm_centered_divide
, qp
, rp
);
3323 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3327 if (SCM_LIKELY (y
> 0))
3328 q
= floor (x
/y
+ 0.5);
3329 else if (SCM_LIKELY (y
< 0))
3330 q
= ceil (x
/y
- 0.5);
3332 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3336 *qp
= scm_i_from_double (q
);
3337 *rp
= scm_i_from_double (r
);
3340 /* Assumes that both x and y are bigints, though
3341 x might be able to fit into a fixnum. */
3343 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3347 /* Note that x might be small enough to fit into a
3348 fixnum, so we must not let it escape into the wild */
3352 /* min_r will eventually become -abs(y/2) */
3353 min_r
= scm_i_mkbig ();
3354 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3355 SCM_I_BIG_MPZ (y
), 1);
3357 /* Arrange for rr to initially be non-positive,
3358 because that simplifies the test to see
3359 if it is within the needed bounds. */
3360 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3362 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3363 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3364 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3365 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3367 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3368 SCM_I_BIG_MPZ (q
), 1);
3369 mpz_add (SCM_I_BIG_MPZ (r
),
3376 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3377 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3378 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3380 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3381 SCM_I_BIG_MPZ (q
), 1);
3382 mpz_sub (SCM_I_BIG_MPZ (r
),
3387 scm_remember_upto_here_2 (x
, y
);
3388 *qp
= scm_i_normbig (q
);
3389 *rp
= scm_i_normbig (r
);
3393 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3396 SCM xd
= scm_denominator (x
);
3397 SCM yd
= scm_denominator (y
);
3399 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3400 scm_product (scm_numerator (y
), xd
),
3402 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3405 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3406 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3407 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3409 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3411 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3412 "with ties going to the nearest even integer.\n"
3414 "(round-quotient 123 10) @result{} 12\n"
3415 "(round-quotient 123 -10) @result{} -12\n"
3416 "(round-quotient -123 10) @result{} -12\n"
3417 "(round-quotient -123 -10) @result{} 12\n"
3418 "(round-quotient 125 10) @result{} 12\n"
3419 "(round-quotient 127 10) @result{} 13\n"
3420 "(round-quotient 135 10) @result{} 14\n"
3421 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3422 "(round-quotient 16/3 -10/7) @result{} -4\n"
3424 #define FUNC_NAME s_scm_round_quotient
3426 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3428 scm_t_inum xx
= SCM_I_INUM (x
);
3429 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3431 scm_t_inum yy
= SCM_I_INUM (y
);
3432 if (SCM_UNLIKELY (yy
== 0))
3433 scm_num_overflow (s_scm_round_quotient
);
3436 scm_t_inum qq
= xx
/ yy
;
3437 scm_t_inum rr
= xx
% yy
;
3439 scm_t_inum r2
= 2 * rr
;
3441 if (SCM_LIKELY (yy
< 0))
3461 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3462 return SCM_I_MAKINUM (qq
);
3464 return scm_i_inum2big (qq
);
3467 else if (SCM_BIGP (y
))
3469 /* Pass a denormalized bignum version of x (even though it
3470 can fit in a fixnum) to scm_i_bigint_round_quotient */
3471 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3473 else if (SCM_REALP (y
))
3474 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3475 else if (SCM_FRACTIONP (y
))
3476 return scm_i_exact_rational_round_quotient (x
, y
);
3478 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3479 s_scm_round_quotient
);
3481 else if (SCM_BIGP (x
))
3483 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3485 scm_t_inum yy
= SCM_I_INUM (y
);
3486 if (SCM_UNLIKELY (yy
== 0))
3487 scm_num_overflow (s_scm_round_quotient
);
3488 else if (SCM_UNLIKELY (yy
== 1))
3492 SCM q
= scm_i_mkbig ();
3494 int needs_adjustment
;
3498 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3499 SCM_I_BIG_MPZ (x
), yy
);
3500 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3501 needs_adjustment
= (2*rr
>= yy
);
3503 needs_adjustment
= (2*rr
> yy
);
3507 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3508 SCM_I_BIG_MPZ (x
), -yy
);
3509 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3510 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3511 needs_adjustment
= (2*rr
<= yy
);
3513 needs_adjustment
= (2*rr
< yy
);
3515 scm_remember_upto_here_1 (x
);
3516 if (needs_adjustment
)
3517 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3518 return scm_i_normbig (q
);
3521 else if (SCM_BIGP (y
))
3522 return scm_i_bigint_round_quotient (x
, y
);
3523 else if (SCM_REALP (y
))
3524 return scm_i_inexact_round_quotient
3525 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3526 else if (SCM_FRACTIONP (y
))
3527 return scm_i_exact_rational_round_quotient (x
, y
);
3529 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3530 s_scm_round_quotient
);
3532 else if (SCM_REALP (x
))
3534 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3535 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3536 return scm_i_inexact_round_quotient
3537 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3539 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3540 s_scm_round_quotient
);
3542 else if (SCM_FRACTIONP (x
))
3545 return scm_i_inexact_round_quotient
3546 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3547 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3548 return scm_i_exact_rational_round_quotient (x
, y
);
3550 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3551 s_scm_round_quotient
);
3554 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3555 s_scm_round_quotient
);
3560 scm_i_inexact_round_quotient (double x
, double y
)
3562 if (SCM_UNLIKELY (y
== 0))
3563 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3565 return scm_i_from_double (scm_c_round (x
/ y
));
3568 /* Assumes that both x and y are bigints, though
3569 x might be able to fit into a fixnum. */
3571 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3574 int cmp
, needs_adjustment
;
3576 /* Note that x might be small enough to fit into a
3577 fixnum, so we must not let it escape into the wild */
3580 r2
= scm_i_mkbig ();
3582 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3583 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3584 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3585 scm_remember_upto_here_2 (x
, r
);
3587 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3588 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3589 needs_adjustment
= (cmp
>= 0);
3591 needs_adjustment
= (cmp
> 0);
3592 scm_remember_upto_here_2 (r2
, y
);
3594 if (needs_adjustment
)
3595 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3597 return scm_i_normbig (q
);
3601 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3603 return scm_round_quotient
3604 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3605 scm_product (scm_numerator (y
), scm_denominator (x
)));
3608 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3609 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3610 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3612 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3614 "Return the real number @var{r} such that\n"
3615 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3616 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3617 "nearest integer, with ties going to the nearest\n"
3620 "(round-remainder 123 10) @result{} 3\n"
3621 "(round-remainder 123 -10) @result{} 3\n"
3622 "(round-remainder -123 10) @result{} -3\n"
3623 "(round-remainder -123 -10) @result{} -3\n"
3624 "(round-remainder 125 10) @result{} 5\n"
3625 "(round-remainder 127 10) @result{} -3\n"
3626 "(round-remainder 135 10) @result{} -5\n"
3627 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3628 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3630 #define FUNC_NAME s_scm_round_remainder
3632 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3634 scm_t_inum xx
= SCM_I_INUM (x
);
3635 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3637 scm_t_inum yy
= SCM_I_INUM (y
);
3638 if (SCM_UNLIKELY (yy
== 0))
3639 scm_num_overflow (s_scm_round_remainder
);
3642 scm_t_inum qq
= xx
/ yy
;
3643 scm_t_inum rr
= xx
% yy
;
3645 scm_t_inum r2
= 2 * rr
;
3647 if (SCM_LIKELY (yy
< 0))
3667 return SCM_I_MAKINUM (rr
);
3670 else if (SCM_BIGP (y
))
3672 /* Pass a denormalized bignum version of x (even though it
3673 can fit in a fixnum) to scm_i_bigint_round_remainder */
3674 return scm_i_bigint_round_remainder
3675 (scm_i_long2big (xx
), y
);
3677 else if (SCM_REALP (y
))
3678 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3679 else if (SCM_FRACTIONP (y
))
3680 return scm_i_exact_rational_round_remainder (x
, y
);
3682 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3683 s_scm_round_remainder
);
3685 else if (SCM_BIGP (x
))
3687 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3689 scm_t_inum yy
= SCM_I_INUM (y
);
3690 if (SCM_UNLIKELY (yy
== 0))
3691 scm_num_overflow (s_scm_round_remainder
);
3694 SCM q
= scm_i_mkbig ();
3696 int needs_adjustment
;
3700 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3701 SCM_I_BIG_MPZ (x
), yy
);
3702 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3703 needs_adjustment
= (2*rr
>= yy
);
3705 needs_adjustment
= (2*rr
> yy
);
3709 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3710 SCM_I_BIG_MPZ (x
), -yy
);
3711 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3712 needs_adjustment
= (2*rr
<= yy
);
3714 needs_adjustment
= (2*rr
< yy
);
3716 scm_remember_upto_here_2 (x
, q
);
3717 if (needs_adjustment
)
3719 return SCM_I_MAKINUM (rr
);
3722 else if (SCM_BIGP (y
))
3723 return scm_i_bigint_round_remainder (x
, y
);
3724 else if (SCM_REALP (y
))
3725 return scm_i_inexact_round_remainder
3726 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3727 else if (SCM_FRACTIONP (y
))
3728 return scm_i_exact_rational_round_remainder (x
, y
);
3730 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3731 s_scm_round_remainder
);
3733 else if (SCM_REALP (x
))
3735 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3736 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3737 return scm_i_inexact_round_remainder
3738 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3740 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3741 s_scm_round_remainder
);
3743 else if (SCM_FRACTIONP (x
))
3746 return scm_i_inexact_round_remainder
3747 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3748 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3749 return scm_i_exact_rational_round_remainder (x
, y
);
3751 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3752 s_scm_round_remainder
);
3755 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3756 s_scm_round_remainder
);
3761 scm_i_inexact_round_remainder (double x
, double y
)
3763 /* Although it would be more efficient to use fmod here, we can't
3764 because it would in some cases produce results inconsistent with
3765 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3766 close). In particular, when x-y/2 is very close to a multiple of
3767 y, then r might be either -abs(y/2) or abs(y/2), but those two
3768 cases must correspond to different choices of q. If quotient
3769 chooses one and remainder chooses the other, it would be bad. */
3771 if (SCM_UNLIKELY (y
== 0))
3772 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3775 double q
= scm_c_round (x
/ y
);
3776 return scm_i_from_double (x
- q
* y
);
3780 /* Assumes that both x and y are bigints, though
3781 x might be able to fit into a fixnum. */
3783 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3786 int cmp
, needs_adjustment
;
3788 /* Note that x might be small enough to fit into a
3789 fixnum, so we must not let it escape into the wild */
3792 r2
= scm_i_mkbig ();
3794 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3795 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3796 scm_remember_upto_here_1 (x
);
3797 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3799 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3800 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3801 needs_adjustment
= (cmp
>= 0);
3803 needs_adjustment
= (cmp
> 0);
3804 scm_remember_upto_here_2 (q
, r2
);
3806 if (needs_adjustment
)
3807 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3809 scm_remember_upto_here_1 (y
);
3810 return scm_i_normbig (r
);
3814 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3816 SCM xd
= scm_denominator (x
);
3817 SCM yd
= scm_denominator (y
);
3818 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3819 scm_product (scm_numerator (y
), xd
));
3820 return scm_divide (r1
, scm_product (xd
, yd
));
3824 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3825 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3826 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3828 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3830 "Return the integer @var{q} and the real number @var{r}\n"
3831 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3832 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3833 "nearest integer, with ties going to the nearest even integer.\n"
3835 "(round/ 123 10) @result{} 12 and 3\n"
3836 "(round/ 123 -10) @result{} -12 and 3\n"
3837 "(round/ -123 10) @result{} -12 and -3\n"
3838 "(round/ -123 -10) @result{} 12 and -3\n"
3839 "(round/ 125 10) @result{} 12 and 5\n"
3840 "(round/ 127 10) @result{} 13 and -3\n"
3841 "(round/ 135 10) @result{} 14 and -5\n"
3842 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3843 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3845 #define FUNC_NAME s_scm_i_round_divide
3849 scm_round_divide(x
, y
, &q
, &r
);
3850 return scm_values (scm_list_2 (q
, r
));
3854 #define s_scm_round_divide s_scm_i_round_divide
3855 #define g_scm_round_divide g_scm_i_round_divide
3858 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3860 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3862 scm_t_inum xx
= SCM_I_INUM (x
);
3863 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3865 scm_t_inum yy
= SCM_I_INUM (y
);
3866 if (SCM_UNLIKELY (yy
== 0))
3867 scm_num_overflow (s_scm_round_divide
);
3870 scm_t_inum qq
= xx
/ yy
;
3871 scm_t_inum rr
= xx
% yy
;
3873 scm_t_inum r2
= 2 * rr
;
3875 if (SCM_LIKELY (yy
< 0))
3895 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3896 *qp
= SCM_I_MAKINUM (qq
);
3898 *qp
= scm_i_inum2big (qq
);
3899 *rp
= SCM_I_MAKINUM (rr
);
3903 else if (SCM_BIGP (y
))
3905 /* Pass a denormalized bignum version of x (even though it
3906 can fit in a fixnum) to scm_i_bigint_round_divide */
3907 return scm_i_bigint_round_divide
3908 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3910 else if (SCM_REALP (y
))
3911 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3912 else if (SCM_FRACTIONP (y
))
3913 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3915 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3916 s_scm_round_divide
, qp
, rp
);
3918 else if (SCM_BIGP (x
))
3920 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3922 scm_t_inum yy
= SCM_I_INUM (y
);
3923 if (SCM_UNLIKELY (yy
== 0))
3924 scm_num_overflow (s_scm_round_divide
);
3927 SCM q
= scm_i_mkbig ();
3929 int needs_adjustment
;
3933 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3934 SCM_I_BIG_MPZ (x
), yy
);
3935 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3936 needs_adjustment
= (2*rr
>= yy
);
3938 needs_adjustment
= (2*rr
> yy
);
3942 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3943 SCM_I_BIG_MPZ (x
), -yy
);
3944 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3945 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3946 needs_adjustment
= (2*rr
<= yy
);
3948 needs_adjustment
= (2*rr
< yy
);
3950 scm_remember_upto_here_1 (x
);
3951 if (needs_adjustment
)
3953 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3956 *qp
= scm_i_normbig (q
);
3957 *rp
= SCM_I_MAKINUM (rr
);
3961 else if (SCM_BIGP (y
))
3962 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3963 else if (SCM_REALP (y
))
3964 return scm_i_inexact_round_divide
3965 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3966 else if (SCM_FRACTIONP (y
))
3967 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3969 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3970 s_scm_round_divide
, qp
, rp
);
3972 else if (SCM_REALP (x
))
3974 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3975 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3976 return scm_i_inexact_round_divide
3977 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3979 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3980 s_scm_round_divide
, qp
, rp
);
3982 else if (SCM_FRACTIONP (x
))
3985 return scm_i_inexact_round_divide
3986 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3987 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3988 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3990 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3991 s_scm_round_divide
, qp
, rp
);
3994 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3995 s_scm_round_divide
, qp
, rp
);
3999 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
4001 if (SCM_UNLIKELY (y
== 0))
4002 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
4005 double q
= scm_c_round (x
/ y
);
4006 double r
= x
- q
* y
;
4007 *qp
= scm_i_from_double (q
);
4008 *rp
= scm_i_from_double (r
);
4012 /* Assumes that both x and y are bigints, though
4013 x might be able to fit into a fixnum. */
4015 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4018 int cmp
, needs_adjustment
;
4020 /* Note that x might be small enough to fit into a
4021 fixnum, so we must not let it escape into the wild */
4024 r2
= scm_i_mkbig ();
4026 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
4027 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
4028 scm_remember_upto_here_1 (x
);
4029 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
4031 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
4032 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4033 needs_adjustment
= (cmp
>= 0);
4035 needs_adjustment
= (cmp
> 0);
4037 if (needs_adjustment
)
4039 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4040 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4043 scm_remember_upto_here_2 (r2
, y
);
4044 *qp
= scm_i_normbig (q
);
4045 *rp
= scm_i_normbig (r
);
4049 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4052 SCM xd
= scm_denominator (x
);
4053 SCM yd
= scm_denominator (y
);
4055 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4056 scm_product (scm_numerator (y
), xd
),
4058 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4062 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4063 (SCM x
, SCM y
, SCM rest
),
4064 "Return the greatest common divisor of all parameter values.\n"
4065 "If called without arguments, 0 is returned.")
4066 #define FUNC_NAME s_scm_i_gcd
4068 while (!scm_is_null (rest
))
4069 { x
= scm_gcd (x
, y
);
4071 rest
= scm_cdr (rest
);
4073 return scm_gcd (x
, y
);
4077 #define s_gcd s_scm_i_gcd
4078 #define g_gcd g_scm_i_gcd
4081 scm_gcd (SCM x
, SCM y
)
4083 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4084 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4086 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4088 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4090 scm_t_inum xx
= SCM_I_INUM (x
);
4091 scm_t_inum yy
= SCM_I_INUM (y
);
4092 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4093 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4095 if (SCM_UNLIKELY (xx
== 0))
4097 else if (SCM_UNLIKELY (yy
== 0))
4102 /* Determine a common factor 2^k */
4103 while (((u
| v
) & 1) == 0)
4109 /* Now, any factor 2^n can be eliminated */
4111 while ((u
& 1) == 0)
4114 while ((v
& 1) == 0)
4116 /* Both u and v are now odd. Subtract the smaller one
4117 from the larger one to produce an even number, remove
4118 more factors of two, and repeat. */
4124 while ((u
& 1) == 0)
4130 while ((v
& 1) == 0)
4136 return (SCM_POSFIXABLE (result
)
4137 ? SCM_I_MAKINUM (result
)
4138 : scm_i_inum2big (result
));
4140 else if (SCM_BIGP (y
))
4145 else if (SCM_REALP (y
) && scm_is_integer (y
))
4146 goto handle_inexacts
;
4148 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4150 else if (SCM_BIGP (x
))
4152 if (SCM_I_INUMP (y
))
4157 yy
= SCM_I_INUM (y
);
4162 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4163 scm_remember_upto_here_1 (x
);
4164 return (SCM_POSFIXABLE (result
)
4165 ? SCM_I_MAKINUM (result
)
4166 : scm_from_unsigned_integer (result
));
4168 else if (SCM_BIGP (y
))
4170 SCM result
= scm_i_mkbig ();
4171 mpz_gcd (SCM_I_BIG_MPZ (result
),
4174 scm_remember_upto_here_2 (x
, y
);
4175 return scm_i_normbig (result
);
4177 else if (SCM_REALP (y
) && scm_is_integer (y
))
4178 goto handle_inexacts
;
4180 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4182 else if (SCM_REALP (x
) && scm_is_integer (x
))
4184 if (SCM_I_INUMP (y
) || SCM_BIGP (y
)
4185 || (SCM_REALP (y
) && scm_is_integer (y
)))
4188 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x
),
4189 scm_inexact_to_exact (y
)));
4192 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4195 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4198 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4199 (SCM x
, SCM y
, SCM rest
),
4200 "Return the least common multiple of the arguments.\n"
4201 "If called without arguments, 1 is returned.")
4202 #define FUNC_NAME s_scm_i_lcm
4204 while (!scm_is_null (rest
))
4205 { x
= scm_lcm (x
, y
);
4207 rest
= scm_cdr (rest
);
4209 return scm_lcm (x
, y
);
4213 #define s_lcm s_scm_i_lcm
4214 #define g_lcm g_scm_i_lcm
4217 scm_lcm (SCM n1
, SCM n2
)
4219 if (SCM_UNLIKELY (SCM_UNBNDP (n2
)))
4220 return SCM_UNBNDP (n1
) ? SCM_INUM1
: scm_abs (n1
);
4222 if (SCM_LIKELY (SCM_I_INUMP (n1
)))
4224 if (SCM_LIKELY (SCM_I_INUMP (n2
)))
4226 SCM d
= scm_gcd (n1
, n2
);
4227 if (scm_is_eq (d
, SCM_INUM0
))
4230 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4232 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4234 /* inum n1, big n2 */
4237 SCM result
= scm_i_mkbig ();
4238 scm_t_inum nn1
= SCM_I_INUM (n1
);
4239 if (nn1
== 0) return SCM_INUM0
;
4240 if (nn1
< 0) nn1
= - nn1
;
4241 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4242 scm_remember_upto_here_1 (n2
);
4246 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4247 goto handle_inexacts
;
4249 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4251 else if (SCM_LIKELY (SCM_BIGP (n1
)))
4254 if (SCM_I_INUMP (n2
))
4259 else if (SCM_LIKELY (SCM_BIGP (n2
)))
4261 SCM result
= scm_i_mkbig ();
4262 mpz_lcm(SCM_I_BIG_MPZ (result
),
4264 SCM_I_BIG_MPZ (n2
));
4265 scm_remember_upto_here_2(n1
, n2
);
4266 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4269 else if (SCM_REALP (n2
) && scm_is_integer (n2
))
4270 goto handle_inexacts
;
4272 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4274 else if (SCM_REALP (n1
) && scm_is_integer (n1
))
4276 if (SCM_I_INUMP (n2
) || SCM_BIGP (n2
)
4277 || (SCM_REALP (n2
) && scm_is_integer (n2
)))
4280 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1
),
4281 scm_inexact_to_exact (n2
)));
4284 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4287 SCM_WTA_DISPATCH_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4290 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4295 + + + x (map digit:logand X Y)
4296 + - + x (map digit:logand X (lognot (+ -1 Y)))
4297 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4298 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4303 + + + (map digit:logior X Y)
4304 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4305 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4306 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4311 + + + (map digit:logxor X Y)
4312 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4313 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4314 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4319 + + (any digit:logand X Y)
4320 + - (any digit:logand X (lognot (+ -1 Y)))
4321 - + (any digit:logand (lognot (+ -1 X)) Y)
4326 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4327 (SCM x
, SCM y
, SCM rest
),
4328 "Return the bitwise AND of the integer arguments.\n\n"
4330 "(logand) @result{} -1\n"
4331 "(logand 7) @result{} 7\n"
4332 "(logand #b111 #b011 #b001) @result{} 1\n"
4334 #define FUNC_NAME s_scm_i_logand
4336 while (!scm_is_null (rest
))
4337 { x
= scm_logand (x
, y
);
4339 rest
= scm_cdr (rest
);
4341 return scm_logand (x
, y
);
4345 #define s_scm_logand s_scm_i_logand
4347 SCM
scm_logand (SCM n1
, SCM n2
)
4348 #define FUNC_NAME s_scm_logand
4352 if (SCM_UNBNDP (n2
))
4354 if (SCM_UNBNDP (n1
))
4355 return SCM_I_MAKINUM (-1);
4356 else if (!SCM_NUMBERP (n1
))
4357 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4358 else if (SCM_NUMBERP (n1
))
4361 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4364 if (SCM_I_INUMP (n1
))
4366 nn1
= SCM_I_INUM (n1
);
4367 if (SCM_I_INUMP (n2
))
4369 scm_t_inum nn2
= SCM_I_INUM (n2
);
4370 return SCM_I_MAKINUM (nn1
& nn2
);
4372 else if SCM_BIGP (n2
)
4378 SCM result_z
= scm_i_mkbig ();
4380 mpz_init_set_si (nn1_z
, nn1
);
4381 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4382 scm_remember_upto_here_1 (n2
);
4384 return scm_i_normbig (result_z
);
4388 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4390 else if (SCM_BIGP (n1
))
4392 if (SCM_I_INUMP (n2
))
4395 nn1
= SCM_I_INUM (n1
);
4398 else if (SCM_BIGP (n2
))
4400 SCM result_z
= scm_i_mkbig ();
4401 mpz_and (SCM_I_BIG_MPZ (result_z
),
4403 SCM_I_BIG_MPZ (n2
));
4404 scm_remember_upto_here_2 (n1
, n2
);
4405 return scm_i_normbig (result_z
);
4408 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4411 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4416 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4417 (SCM x
, SCM y
, SCM rest
),
4418 "Return the bitwise OR of the integer arguments.\n\n"
4420 "(logior) @result{} 0\n"
4421 "(logior 7) @result{} 7\n"
4422 "(logior #b000 #b001 #b011) @result{} 3\n"
4424 #define FUNC_NAME s_scm_i_logior
4426 while (!scm_is_null (rest
))
4427 { x
= scm_logior (x
, y
);
4429 rest
= scm_cdr (rest
);
4431 return scm_logior (x
, y
);
4435 #define s_scm_logior s_scm_i_logior
4437 SCM
scm_logior (SCM n1
, SCM n2
)
4438 #define FUNC_NAME s_scm_logior
4442 if (SCM_UNBNDP (n2
))
4444 if (SCM_UNBNDP (n1
))
4446 else if (SCM_NUMBERP (n1
))
4449 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4452 if (SCM_I_INUMP (n1
))
4454 nn1
= SCM_I_INUM (n1
);
4455 if (SCM_I_INUMP (n2
))
4457 long nn2
= SCM_I_INUM (n2
);
4458 return SCM_I_MAKINUM (nn1
| nn2
);
4460 else if (SCM_BIGP (n2
))
4466 SCM result_z
= scm_i_mkbig ();
4468 mpz_init_set_si (nn1_z
, nn1
);
4469 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4470 scm_remember_upto_here_1 (n2
);
4472 return scm_i_normbig (result_z
);
4476 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4478 else if (SCM_BIGP (n1
))
4480 if (SCM_I_INUMP (n2
))
4483 nn1
= SCM_I_INUM (n1
);
4486 else if (SCM_BIGP (n2
))
4488 SCM result_z
= scm_i_mkbig ();
4489 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4491 SCM_I_BIG_MPZ (n2
));
4492 scm_remember_upto_here_2 (n1
, n2
);
4493 return scm_i_normbig (result_z
);
4496 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4499 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4504 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4505 (SCM x
, SCM y
, SCM rest
),
4506 "Return the bitwise XOR of the integer arguments. A bit is\n"
4507 "set in the result if it is set in an odd number of arguments.\n"
4509 "(logxor) @result{} 0\n"
4510 "(logxor 7) @result{} 7\n"
4511 "(logxor #b000 #b001 #b011) @result{} 2\n"
4512 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4514 #define FUNC_NAME s_scm_i_logxor
4516 while (!scm_is_null (rest
))
4517 { x
= scm_logxor (x
, y
);
4519 rest
= scm_cdr (rest
);
4521 return scm_logxor (x
, y
);
4525 #define s_scm_logxor s_scm_i_logxor
4527 SCM
scm_logxor (SCM n1
, SCM n2
)
4528 #define FUNC_NAME s_scm_logxor
4532 if (SCM_UNBNDP (n2
))
4534 if (SCM_UNBNDP (n1
))
4536 else if (SCM_NUMBERP (n1
))
4539 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4542 if (SCM_I_INUMP (n1
))
4544 nn1
= SCM_I_INUM (n1
);
4545 if (SCM_I_INUMP (n2
))
4547 scm_t_inum nn2
= SCM_I_INUM (n2
);
4548 return SCM_I_MAKINUM (nn1
^ nn2
);
4550 else if (SCM_BIGP (n2
))
4554 SCM result_z
= scm_i_mkbig ();
4556 mpz_init_set_si (nn1_z
, nn1
);
4557 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4558 scm_remember_upto_here_1 (n2
);
4560 return scm_i_normbig (result_z
);
4564 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4566 else if (SCM_BIGP (n1
))
4568 if (SCM_I_INUMP (n2
))
4571 nn1
= SCM_I_INUM (n1
);
4574 else if (SCM_BIGP (n2
))
4576 SCM result_z
= scm_i_mkbig ();
4577 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4579 SCM_I_BIG_MPZ (n2
));
4580 scm_remember_upto_here_2 (n1
, n2
);
4581 return scm_i_normbig (result_z
);
4584 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4587 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4592 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4594 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4595 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4596 "without actually calculating the @code{logand}, just testing\n"
4600 "(logtest #b0100 #b1011) @result{} #f\n"
4601 "(logtest #b0100 #b0111) @result{} #t\n"
4603 #define FUNC_NAME s_scm_logtest
4607 if (SCM_I_INUMP (j
))
4609 nj
= SCM_I_INUM (j
);
4610 if (SCM_I_INUMP (k
))
4612 scm_t_inum nk
= SCM_I_INUM (k
);
4613 return scm_from_bool (nj
& nk
);
4615 else if (SCM_BIGP (k
))
4623 mpz_init_set_si (nj_z
, nj
);
4624 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4625 scm_remember_upto_here_1 (k
);
4626 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4632 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4634 else if (SCM_BIGP (j
))
4636 if (SCM_I_INUMP (k
))
4639 nj
= SCM_I_INUM (j
);
4642 else if (SCM_BIGP (k
))
4646 mpz_init (result_z
);
4650 scm_remember_upto_here_2 (j
, k
);
4651 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4652 mpz_clear (result_z
);
4656 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4659 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4664 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4666 "Test whether bit number @var{index} in @var{j} is set.\n"
4667 "@var{index} starts from 0 for the least significant bit.\n"
4670 "(logbit? 0 #b1101) @result{} #t\n"
4671 "(logbit? 1 #b1101) @result{} #f\n"
4672 "(logbit? 2 #b1101) @result{} #t\n"
4673 "(logbit? 3 #b1101) @result{} #t\n"
4674 "(logbit? 4 #b1101) @result{} #f\n"
4676 #define FUNC_NAME s_scm_logbit_p
4678 unsigned long int iindex
;
4679 iindex
= scm_to_ulong (index
);
4681 if (SCM_I_INUMP (j
))
4683 /* bits above what's in an inum follow the sign bit */
4684 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4685 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4687 else if (SCM_BIGP (j
))
4689 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4690 scm_remember_upto_here_1 (j
);
4691 return scm_from_bool (val
);
4694 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4699 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4701 "Return the integer which is the ones-complement of the integer\n"
4705 "(number->string (lognot #b10000000) 2)\n"
4706 " @result{} \"-10000001\"\n"
4707 "(number->string (lognot #b0) 2)\n"
4708 " @result{} \"-1\"\n"
4710 #define FUNC_NAME s_scm_lognot
4712 if (SCM_I_INUMP (n
)) {
4713 /* No overflow here, just need to toggle all the bits making up the inum.
4714 Enhancement: No need to strip the tag and add it back, could just xor
4715 a block of 1 bits, if that worked with the various debug versions of
4717 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4719 } else if (SCM_BIGP (n
)) {
4720 SCM result
= scm_i_mkbig ();
4721 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4722 scm_remember_upto_here_1 (n
);
4726 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4731 /* returns 0 if IN is not an integer. OUT must already be
4734 coerce_to_big (SCM in
, mpz_t out
)
4737 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4738 else if (SCM_I_INUMP (in
))
4739 mpz_set_si (out
, SCM_I_INUM (in
));
4746 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4747 (SCM n
, SCM k
, SCM m
),
4748 "Return @var{n} raised to the integer exponent\n"
4749 "@var{k}, modulo @var{m}.\n"
4752 "(modulo-expt 2 3 5)\n"
4755 #define FUNC_NAME s_scm_modulo_expt
4761 /* There are two classes of error we might encounter --
4762 1) Math errors, which we'll report by calling scm_num_overflow,
4764 2) wrong-type errors, which of course we'll report by calling
4766 We don't report those errors immediately, however; instead we do
4767 some cleanup first. These variables tell us which error (if
4768 any) we should report after cleaning up.
4770 int report_overflow
= 0;
4772 int position_of_wrong_type
= 0;
4773 SCM value_of_wrong_type
= SCM_INUM0
;
4775 SCM result
= SCM_UNDEFINED
;
4781 if (scm_is_eq (m
, SCM_INUM0
))
4783 report_overflow
= 1;
4787 if (!coerce_to_big (n
, n_tmp
))
4789 value_of_wrong_type
= n
;
4790 position_of_wrong_type
= 1;
4794 if (!coerce_to_big (k
, k_tmp
))
4796 value_of_wrong_type
= k
;
4797 position_of_wrong_type
= 2;
4801 if (!coerce_to_big (m
, m_tmp
))
4803 value_of_wrong_type
= m
;
4804 position_of_wrong_type
= 3;
4808 /* if the exponent K is negative, and we simply call mpz_powm, we
4809 will get a divide-by-zero exception when an inverse 1/n mod m
4810 doesn't exist (or is not unique). Since exceptions are hard to
4811 handle, we'll attempt the inversion "by hand" -- that way, we get
4812 a simple failure code, which is easy to handle. */
4814 if (-1 == mpz_sgn (k_tmp
))
4816 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4818 report_overflow
= 1;
4821 mpz_neg (k_tmp
, k_tmp
);
4824 result
= scm_i_mkbig ();
4825 mpz_powm (SCM_I_BIG_MPZ (result
),
4830 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4831 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4838 if (report_overflow
)
4839 scm_num_overflow (FUNC_NAME
);
4841 if (position_of_wrong_type
)
4842 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4843 value_of_wrong_type
);
4845 return scm_i_normbig (result
);
4849 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4851 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4852 "exact integer, @var{n} can be any number.\n"
4854 "Negative @var{k} is supported, and results in\n"
4855 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4856 "@math{@var{n}^0} is 1, as usual, and that\n"
4857 "includes @math{0^0} is 1.\n"
4860 "(integer-expt 2 5) @result{} 32\n"
4861 "(integer-expt -3 3) @result{} -27\n"
4862 "(integer-expt 5 -3) @result{} 1/125\n"
4863 "(integer-expt 0 0) @result{} 1\n"
4865 #define FUNC_NAME s_scm_integer_expt
4868 SCM z_i2
= SCM_BOOL_F
;
4870 SCM acc
= SCM_I_MAKINUM (1L);
4872 /* Specifically refrain from checking the type of the first argument.
4873 This allows us to exponentiate any object that can be multiplied.
4874 If we must raise to a negative power, we must also be able to
4875 take its reciprocal. */
4876 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4877 SCM_WRONG_TYPE_ARG (2, k
);
4879 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4880 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4881 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4882 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4883 /* The next check is necessary only because R6RS specifies different
4884 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4885 we simply skip this case and move on. */
4886 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4888 /* k cannot be 0 at this point, because we
4889 have already checked for that case above */
4890 if (scm_is_true (scm_positive_p (k
)))
4892 else /* return NaN for (0 ^ k) for negative k per R6RS */
4895 else if (SCM_FRACTIONP (n
))
4897 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4898 needless reduction of intermediate products to lowest terms.
4899 If a and b have no common factors, then a^k and b^k have no
4900 common factors. Use 'scm_i_make_ratio_already_reduced' to
4901 construct the final result, so that no gcd computations are
4902 needed to exponentiate a fraction. */
4903 if (scm_is_true (scm_positive_p (k
)))
4904 return scm_i_make_ratio_already_reduced
4905 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4906 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4909 k
= scm_difference (k
, SCM_UNDEFINED
);
4910 return scm_i_make_ratio_already_reduced
4911 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4912 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4916 if (SCM_I_INUMP (k
))
4917 i2
= SCM_I_INUM (k
);
4918 else if (SCM_BIGP (k
))
4920 z_i2
= scm_i_clonebig (k
, 1);
4921 scm_remember_upto_here_1 (k
);
4925 SCM_WRONG_TYPE_ARG (2, k
);
4929 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4931 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4932 n
= scm_divide (n
, SCM_UNDEFINED
);
4936 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4940 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4942 return scm_product (acc
, n
);
4944 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4945 acc
= scm_product (acc
, n
);
4946 n
= scm_product (n
, n
);
4947 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4955 n
= scm_divide (n
, SCM_UNDEFINED
);
4962 return scm_product (acc
, n
);
4964 acc
= scm_product (acc
, n
);
4965 n
= scm_product (n
, n
);
4972 /* Efficiently compute (N * 2^COUNT),
4973 where N is an exact integer, and COUNT > 0. */
4975 left_shift_exact_integer (SCM n
, long count
)
4977 if (SCM_I_INUMP (n
))
4979 scm_t_inum nn
= SCM_I_INUM (n
);
4981 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
4982 overflow a non-zero fixnum. For smaller shifts we check the
4983 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4984 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4985 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
4987 [*] There's one exception:
4988 (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
4992 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4993 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4995 return SCM_I_MAKINUM (nn
<< count
);
4998 SCM result
= scm_i_inum2big (nn
);
4999 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5001 return scm_i_normbig (result
);
5004 else if (SCM_BIGP (n
))
5006 SCM result
= scm_i_mkbig ();
5007 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
5008 scm_remember_upto_here_1 (n
);
5015 /* Efficiently compute floor (N / 2^COUNT),
5016 where N is an exact integer and COUNT > 0. */
5018 floor_right_shift_exact_integer (SCM n
, long count
)
5020 if (SCM_I_INUMP (n
))
5022 scm_t_inum nn
= SCM_I_INUM (n
);
5024 if (count
>= SCM_I_FIXNUM_BIT
)
5025 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
5027 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
5029 else if (SCM_BIGP (n
))
5031 SCM result
= scm_i_mkbig ();
5032 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
5034 scm_remember_upto_here_1 (n
);
5035 return scm_i_normbig (result
);
5041 /* Efficiently compute round (N / 2^COUNT),
5042 where N is an exact integer and COUNT > 0. */
5044 round_right_shift_exact_integer (SCM n
, long count
)
5046 if (SCM_I_INUMP (n
))
5048 if (count
>= SCM_I_FIXNUM_BIT
)
5052 scm_t_inum nn
= SCM_I_INUM (n
);
5053 scm_t_inum qq
= SCM_SRS (nn
, count
);
5055 if (0 == (nn
& (1L << (count
-1))))
5056 return SCM_I_MAKINUM (qq
); /* round down */
5057 else if (nn
& ((1L << (count
-1)) - 1))
5058 return SCM_I_MAKINUM (qq
+ 1); /* round up */
5060 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
5063 else if (SCM_BIGP (n
))
5065 SCM q
= scm_i_mkbig ();
5067 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5068 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5069 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5070 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5071 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5072 scm_remember_upto_here_1 (n
);
5073 return scm_i_normbig (q
);
5079 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5081 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5082 "@var{n} and @var{count} must be exact integers.\n"
5084 "With @var{n} viewed as an infinite-precision twos-complement\n"
5085 "integer, @code{ash} means a left shift introducing zero bits\n"
5086 "when @var{count} is positive, or a right shift dropping bits\n"
5087 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5090 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5091 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5093 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5094 "(ash -23 -2) @result{} -6\n"
5096 #define FUNC_NAME s_scm_ash
5098 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5100 long bits_to_shift
= scm_to_long (count
);
5102 if (bits_to_shift
> 0)
5103 return left_shift_exact_integer (n
, bits_to_shift
);
5104 else if (SCM_LIKELY (bits_to_shift
< 0))
5105 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5110 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5114 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5116 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5117 "@var{n} and @var{count} must be exact integers.\n"
5119 "With @var{n} viewed as an infinite-precision twos-complement\n"
5120 "integer, @code{round-ash} means a left shift introducing zero\n"
5121 "bits when @var{count} is positive, or a right shift rounding\n"
5122 "to the nearest integer (with ties going to the nearest even\n"
5123 "integer) when @var{count} is negative. This is a rounded\n"
5124 "``arithmetic'' shift.\n"
5127 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5128 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5129 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5130 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5131 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5132 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5134 #define FUNC_NAME s_scm_round_ash
5136 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5138 long bits_to_shift
= scm_to_long (count
);
5140 if (bits_to_shift
> 0)
5141 return left_shift_exact_integer (n
, bits_to_shift
);
5142 else if (SCM_LIKELY (bits_to_shift
< 0))
5143 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5148 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5153 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5154 (SCM n
, SCM start
, SCM end
),
5155 "Return the integer composed of the @var{start} (inclusive)\n"
5156 "through @var{end} (exclusive) bits of @var{n}. The\n"
5157 "@var{start}th bit becomes the 0-th bit in the result.\n"
5160 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5161 " @result{} \"1010\"\n"
5162 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5163 " @result{} \"10110\"\n"
5165 #define FUNC_NAME s_scm_bit_extract
5167 unsigned long int istart
, iend
, bits
;
5168 istart
= scm_to_ulong (start
);
5169 iend
= scm_to_ulong (end
);
5170 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5172 /* how many bits to keep */
5173 bits
= iend
- istart
;
5175 if (SCM_I_INUMP (n
))
5177 scm_t_inum in
= SCM_I_INUM (n
);
5179 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5180 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5181 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5183 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5185 /* Since we emulate two's complement encoded numbers, this
5186 * special case requires us to produce a result that has
5187 * more bits than can be stored in a fixnum.
5189 SCM result
= scm_i_inum2big (in
);
5190 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5195 /* mask down to requisite bits */
5196 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5197 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5199 else if (SCM_BIGP (n
))
5204 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5208 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5209 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5210 such bits into a ulong. */
5211 result
= scm_i_mkbig ();
5212 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5213 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5214 result
= scm_i_normbig (result
);
5216 scm_remember_upto_here_1 (n
);
5220 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5225 static const char scm_logtab
[] = {
5226 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5229 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5231 "Return the number of bits in integer @var{n}. If integer is\n"
5232 "positive, the 1-bits in its binary representation are counted.\n"
5233 "If negative, the 0-bits in its two's-complement binary\n"
5234 "representation are counted. If 0, 0 is returned.\n"
5237 "(logcount #b10101010)\n"
5244 #define FUNC_NAME s_scm_logcount
5246 if (SCM_I_INUMP (n
))
5248 unsigned long c
= 0;
5249 scm_t_inum nn
= SCM_I_INUM (n
);
5254 c
+= scm_logtab
[15 & nn
];
5257 return SCM_I_MAKINUM (c
);
5259 else if (SCM_BIGP (n
))
5261 unsigned long count
;
5262 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5263 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5265 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5266 scm_remember_upto_here_1 (n
);
5267 return SCM_I_MAKINUM (count
);
5270 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5275 static const char scm_ilentab
[] = {
5276 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5280 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5282 "Return the number of bits necessary to represent @var{n}.\n"
5285 "(integer-length #b10101010)\n"
5287 "(integer-length 0)\n"
5289 "(integer-length #b1111)\n"
5292 #define FUNC_NAME s_scm_integer_length
5294 if (SCM_I_INUMP (n
))
5296 unsigned long c
= 0;
5298 scm_t_inum nn
= SCM_I_INUM (n
);
5304 l
= scm_ilentab
[15 & nn
];
5307 return SCM_I_MAKINUM (c
- 4 + l
);
5309 else if (SCM_BIGP (n
))
5311 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5312 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5313 1 too big, so check for that and adjust. */
5314 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5315 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5316 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5317 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5319 scm_remember_upto_here_1 (n
);
5320 return SCM_I_MAKINUM (size
);
5323 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5327 /*** NUMBERS -> STRINGS ***/
5328 #define SCM_MAX_DBL_RADIX 36
5330 /* use this array as a way to generate a single digit */
5331 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5333 static mpz_t dbl_minimum_normal_mantissa
;
5336 idbl2str (double dbl
, char *a
, int radix
)
5340 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5341 /* revert to existing behavior */
5346 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5356 else if (dbl
== 0.0)
5358 if (copysign (1.0, dbl
) < 0.0)
5360 strcpy (a
+ ch
, "0.0");
5363 else if (isnan (dbl
))
5365 strcpy (a
, "+nan.0");
5369 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5370 Accurately" by Robert G. Burger and R. Kent Dybvig */
5373 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5374 int f_is_even
, f_is_odd
;
5378 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5379 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5380 if (e
< DBL_MIN_EXP
)
5382 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5387 f_is_even
= !mpz_odd_p (f
);
5388 f_is_odd
= !f_is_even
;
5390 /* Initialize r, s, mplus, and mminus according
5391 to Table 1 from the paper. */
5394 mpz_set_ui (mminus
, 1);
5395 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5396 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5398 mpz_set_ui (mplus
, 1);
5399 mpz_mul_2exp (r
, f
, 1);
5400 mpz_mul_2exp (s
, mminus
, 1 - e
);
5404 mpz_set_ui (mplus
, 2);
5405 mpz_mul_2exp (r
, f
, 2);
5406 mpz_mul_2exp (s
, mminus
, 2 - e
);
5411 mpz_set_ui (mminus
, 1);
5412 mpz_mul_2exp (mminus
, mminus
, e
);
5413 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5415 mpz_set (mplus
, mminus
);
5416 mpz_mul_2exp (r
, f
, 1 + e
);
5421 mpz_mul_2exp (mplus
, mminus
, 1);
5422 mpz_mul_2exp (r
, f
, 2 + e
);
5427 /* Find the smallest k such that:
5428 (r + mplus) / s < radix^k (if f is even)
5429 (r + mplus) / s <= radix^k (if f is odd) */
5431 /* IMPROVE-ME: Make an initial guess to speed this up */
5432 mpz_add (hi
, r
, mplus
);
5434 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5436 mpz_mul_ui (s
, s
, radix
);
5441 mpz_mul_ui (hi
, hi
, radix
);
5442 while (mpz_cmp (hi
, s
) < f_is_odd
)
5444 mpz_mul_ui (r
, r
, radix
);
5445 mpz_mul_ui (mplus
, mplus
, radix
);
5446 mpz_mul_ui (mminus
, mminus
, radix
);
5447 mpz_mul_ui (hi
, hi
, radix
);
5458 /* Use scientific notation */
5466 /* Print leading zeroes */
5469 for (i
= 0; i
> k
; i
--)
5476 int end_1_p
, end_2_p
;
5479 mpz_mul_ui (mplus
, mplus
, radix
);
5480 mpz_mul_ui (mminus
, mminus
, radix
);
5481 mpz_mul_ui (r
, r
, radix
);
5482 mpz_fdiv_qr (digit
, r
, r
, s
);
5483 d
= mpz_get_ui (digit
);
5485 mpz_add (hi
, r
, mplus
);
5486 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5487 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5488 if (end_1_p
|| end_2_p
)
5490 mpz_mul_2exp (r
, r
, 1);
5495 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5497 a
[ch
++] = number_chars
[d
];
5504 a
[ch
++] = number_chars
[d
];
5512 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5514 /* Here we would have to print more than three zeroes
5515 followed by a decimal point and another zero. It
5516 makes more sense to use scientific notation. */
5518 /* Adjust k to what it would have been if we had chosen
5519 scientific notation from the beginning. */
5522 /* k will now be <= 0, with magnitude equal to the number of
5523 digits that we printed which should now be put after the
5526 /* Insert a decimal point */
5527 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5547 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5550 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5557 icmplx2str (double real
, double imag
, char *str
, int radix
)
5562 i
= idbl2str (real
, str
, radix
);
5563 #ifdef HAVE_COPYSIGN
5564 sgn
= copysign (1.0, imag
);
5568 /* Don't output a '+' for negative numbers or for Inf and
5569 NaN. They will provide their own sign. */
5570 if (sgn
>= 0 && isfinite (imag
))
5572 i
+= idbl2str (imag
, &str
[i
], radix
);
5578 iflo2str (SCM flt
, char *str
, int radix
)
5581 if (SCM_REALP (flt
))
5582 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5584 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5589 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5590 characters in the result.
5592 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5594 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5599 return scm_iuint2str (-num
, rad
, p
) + 1;
5602 return scm_iuint2str (num
, rad
, p
);
5605 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5606 characters in the result.
5608 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5610 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5614 scm_t_uintmax n
= num
;
5616 if (rad
< 2 || rad
> 36)
5617 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5619 for (n
/= rad
; n
> 0; n
/= rad
)
5629 p
[i
] = number_chars
[d
];
5634 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5636 "Return a string holding the external representation of the\n"
5637 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5638 "inexact, a radix of 10 will be used.")
5639 #define FUNC_NAME s_scm_number_to_string
5643 if (SCM_UNBNDP (radix
))
5646 base
= scm_to_signed_integer (radix
, 2, 36);
5648 if (SCM_I_INUMP (n
))
5650 char num_buf
[SCM_INTBUFLEN
];
5651 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5652 return scm_from_locale_stringn (num_buf
, length
);
5654 else if (SCM_BIGP (n
))
5656 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5657 size_t len
= strlen (str
);
5658 void (*freefunc
) (void *, size_t);
5660 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5661 scm_remember_upto_here_1 (n
);
5662 ret
= scm_from_latin1_stringn (str
, len
);
5663 freefunc (str
, len
+ 1);
5666 else if (SCM_FRACTIONP (n
))
5668 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5669 scm_from_locale_string ("/"),
5670 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5672 else if (SCM_INEXACTP (n
))
5674 char num_buf
[FLOBUFLEN
];
5675 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5678 SCM_WRONG_TYPE_ARG (1, n
);
5683 /* These print routines used to be stubbed here so that scm_repl.c
5684 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5687 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5689 char num_buf
[FLOBUFLEN
];
5690 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5695 scm_i_print_double (double val
, SCM port
)
5697 char num_buf
[FLOBUFLEN
];
5698 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5702 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5705 char num_buf
[FLOBUFLEN
];
5706 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5711 scm_i_print_complex (double real
, double imag
, SCM port
)
5713 char num_buf
[FLOBUFLEN
];
5714 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5718 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5721 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5722 scm_display (str
, port
);
5723 scm_remember_upto_here_1 (str
);
5728 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5730 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5731 size_t len
= strlen (str
);
5732 void (*freefunc
) (void *, size_t);
5733 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5734 scm_remember_upto_here_1 (exp
);
5735 scm_lfwrite (str
, len
, port
);
5736 freefunc (str
, len
+ 1);
5739 /*** END nums->strs ***/
5742 /*** STRINGS -> NUMBERS ***/
5744 /* The following functions implement the conversion from strings to numbers.
5745 * The implementation somehow follows the grammar for numbers as it is given
5746 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5747 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5748 * points should be noted about the implementation:
5750 * * Each function keeps a local index variable 'idx' that points at the
5751 * current position within the parsed string. The global index is only
5752 * updated if the function could parse the corresponding syntactic unit
5755 * * Similarly, the functions keep track of indicators of inexactness ('#',
5756 * '.' or exponents) using local variables ('hash_seen', 'x').
5758 * * Sequences of digits are parsed into temporary variables holding fixnums.
5759 * Only if these fixnums would overflow, the result variables are updated
5760 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5761 * the temporary variables holding the fixnums are cleared, and the process
5762 * starts over again. If for example fixnums were able to store five decimal
5763 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5764 * and the result was computed as 12345 * 100000 + 67890. In other words,
5765 * only every five digits two bignum operations were performed.
5767 * Notes on the handling of exactness specifiers:
5769 * When parsing non-real complex numbers, we apply exactness specifiers on
5770 * per-component basis, as is done in PLT Scheme. For complex numbers
5771 * written in rectangular form, exactness specifiers are applied to the
5772 * real and imaginary parts before calling scm_make_rectangular. For
5773 * complex numbers written in polar form, exactness specifiers are applied
5774 * to the magnitude and angle before calling scm_make_polar.
5776 * There are two kinds of exactness specifiers: forced and implicit. A
5777 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5778 * the entire number, and applies to both components of a complex number.
5779 * "#e" causes each component to be made exact, and "#i" causes each
5780 * component to be made inexact. If no forced exactness specifier is
5781 * present, then the exactness of each component is determined
5782 * independently by the presence or absence of a decimal point or hash mark
5783 * within that component. If a decimal point or hash mark is present, the
5784 * component is made inexact, otherwise it is made exact.
5786 * After the exactness specifiers have been applied to each component, they
5787 * are passed to either scm_make_rectangular or scm_make_polar to produce
5788 * the final result. Note that this will result in a real number if the
5789 * imaginary part, magnitude, or angle is an exact 0.
5791 * For example, (string->number "#i5.0+0i") does the equivalent of:
5793 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5796 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5798 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5800 /* Caller is responsible for checking that the return value is in range
5801 for the given radix, which should be <= 36. */
5803 char_decimal_value (scm_t_uint32 c
)
5805 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5806 that's certainly above any valid decimal, so we take advantage of
5807 that to elide some tests. */
5808 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5810 /* If that failed, try extended hexadecimals, then. Only accept ascii
5815 if (c
>= (scm_t_uint32
) 'a')
5816 d
= c
- (scm_t_uint32
)'a' + 10U;
5821 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5822 in base RADIX. Upon success, return the unsigned integer and update
5823 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5825 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5826 unsigned int radix
, enum t_exactness
*p_exactness
)
5828 unsigned int idx
= *p_idx
;
5829 unsigned int hash_seen
= 0;
5830 scm_t_bits shift
= 1;
5832 unsigned int digit_value
;
5835 size_t len
= scm_i_string_length (mem
);
5840 c
= scm_i_string_ref (mem
, idx
);
5841 digit_value
= char_decimal_value (c
);
5842 if (digit_value
>= radix
)
5846 result
= SCM_I_MAKINUM (digit_value
);
5849 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5859 digit_value
= char_decimal_value (c
);
5860 /* This check catches non-decimals in addition to out-of-range
5862 if (digit_value
>= radix
)
5867 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5869 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5871 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5878 shift
= shift
* radix
;
5879 add
= add
* radix
+ digit_value
;
5884 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5886 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5890 *p_exactness
= INEXACT
;
5896 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5897 * covers the parts of the rules that start at a potential point. The value
5898 * of the digits up to the point have been parsed by the caller and are given
5899 * in variable result. The content of *p_exactness indicates, whether a hash
5900 * has already been seen in the digits before the point.
5903 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5906 mem2decimal_from_point (SCM result
, SCM mem
,
5907 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5909 unsigned int idx
= *p_idx
;
5910 enum t_exactness x
= *p_exactness
;
5911 size_t len
= scm_i_string_length (mem
);
5916 if (scm_i_string_ref (mem
, idx
) == '.')
5918 scm_t_bits shift
= 1;
5920 unsigned int digit_value
;
5921 SCM big_shift
= SCM_INUM1
;
5926 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5927 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5932 digit_value
= DIGIT2UINT (c
);
5943 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5945 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5946 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5948 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5956 add
= add
* 10 + digit_value
;
5962 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5963 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5964 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5967 result
= scm_divide (result
, big_shift
);
5969 /* We've seen a decimal point, thus the value is implicitly inexact. */
5981 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5983 switch (scm_i_string_ref (mem
, idx
))
5995 c
= scm_i_string_ref (mem
, idx
);
6003 c
= scm_i_string_ref (mem
, idx
);
6012 c
= scm_i_string_ref (mem
, idx
);
6017 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6021 exponent
= DIGIT2UINT (c
);
6024 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
6025 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
6028 if (exponent
<= SCM_MAXEXP
)
6029 exponent
= exponent
* 10 + DIGIT2UINT (c
);
6035 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
6037 size_t exp_len
= idx
- start
;
6038 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
6039 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
6040 scm_out_of_range ("string->number", exp_num
);
6043 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
6045 result
= scm_product (result
, e
);
6047 result
= scm_divide (result
, e
);
6049 /* We've seen an exponent, thus the value is implicitly inexact. */
6067 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6070 mem2ureal (SCM mem
, unsigned int *p_idx
,
6071 unsigned int radix
, enum t_exactness forced_x
,
6072 int allow_inf_or_nan
)
6074 unsigned int idx
= *p_idx
;
6076 size_t len
= scm_i_string_length (mem
);
6078 /* Start off believing that the number will be exact. This changes
6079 to INEXACT if we see a decimal point or a hash. */
6080 enum t_exactness implicit_x
= EXACT
;
6085 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6086 switch (scm_i_string_ref (mem
, idx
))
6089 switch (scm_i_string_ref (mem
, idx
+ 1))
6092 switch (scm_i_string_ref (mem
, idx
+ 2))
6095 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6096 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6104 switch (scm_i_string_ref (mem
, idx
+ 1))
6107 switch (scm_i_string_ref (mem
, idx
+ 2))
6110 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6112 /* Cobble up the fractional part. We might want to
6113 set the NaN's mantissa from it. */
6115 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6118 #if SCM_ENABLE_DEPRECATED == 1
6119 scm_c_issue_deprecation_warning
6120 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6133 if (scm_i_string_ref (mem
, idx
) == '.')
6137 else if (idx
+ 1 == len
)
6139 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6142 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6143 p_idx
, &implicit_x
);
6149 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6150 if (scm_is_false (uinteger
))
6155 else if (scm_i_string_ref (mem
, idx
) == '/')
6163 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6164 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6167 /* both are int/big here, I assume */
6168 result
= scm_i_make_ratio (uinteger
, divisor
);
6170 else if (radix
== 10)
6172 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6173 if (scm_is_false (result
))
6185 if (SCM_INEXACTP (result
))
6186 return scm_inexact_to_exact (result
);
6190 if (SCM_INEXACTP (result
))
6193 return scm_exact_to_inexact (result
);
6195 if (implicit_x
== INEXACT
)
6197 if (SCM_INEXACTP (result
))
6200 return scm_exact_to_inexact (result
);
6206 /* We should never get here */
6211 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6214 mem2complex (SCM mem
, unsigned int idx
,
6215 unsigned int radix
, enum t_exactness forced_x
)
6220 size_t len
= scm_i_string_length (mem
);
6225 c
= scm_i_string_ref (mem
, idx
);
6240 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6241 if (scm_is_false (ureal
))
6243 /* input must be either +i or -i */
6248 if (scm_i_string_ref (mem
, idx
) == 'i'
6249 || scm_i_string_ref (mem
, idx
) == 'I')
6255 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6262 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6263 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6268 c
= scm_i_string_ref (mem
, idx
);
6272 /* either +<ureal>i or -<ureal>i */
6279 return scm_make_rectangular (SCM_INUM0
, ureal
);
6282 /* polar input: <real>@<real>. */
6293 c
= scm_i_string_ref (mem
, idx
);
6311 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6312 if (scm_is_false (angle
))
6317 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6318 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6320 result
= scm_make_polar (ureal
, angle
);
6325 /* expecting input matching <real>[+-]<ureal>?i */
6332 int sign
= (c
== '+') ? 1 : -1;
6333 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6335 if (scm_is_false (imag
))
6336 imag
= SCM_I_MAKINUM (sign
);
6337 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6338 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6342 if (scm_i_string_ref (mem
, idx
) != 'i'
6343 && scm_i_string_ref (mem
, idx
) != 'I')
6350 return scm_make_rectangular (ureal
, imag
);
6359 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6361 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6364 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6366 unsigned int idx
= 0;
6367 unsigned int radix
= NO_RADIX
;
6368 enum t_exactness forced_x
= NO_EXACTNESS
;
6369 size_t len
= scm_i_string_length (mem
);
6371 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6372 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6374 switch (scm_i_string_ref (mem
, idx
+ 1))
6377 if (radix
!= NO_RADIX
)
6382 if (radix
!= NO_RADIX
)
6387 if (forced_x
!= NO_EXACTNESS
)
6392 if (forced_x
!= NO_EXACTNESS
)
6397 if (radix
!= NO_RADIX
)
6402 if (radix
!= NO_RADIX
)
6412 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6413 if (radix
== NO_RADIX
)
6414 radix
= default_radix
;
6416 return mem2complex (mem
, idx
, radix
, forced_x
);
6420 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6421 unsigned int default_radix
)
6423 SCM str
= scm_from_locale_stringn (mem
, len
);
6425 return scm_i_string_to_number (str
, default_radix
);
6429 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6430 (SCM string
, SCM radix
),
6431 "Return a number of the maximally precise representation\n"
6432 "expressed by the given @var{string}. @var{radix} must be an\n"
6433 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6434 "is a default radix that may be overridden by an explicit radix\n"
6435 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6436 "supplied, then the default radix is 10. If string is not a\n"
6437 "syntactically valid notation for a number, then\n"
6438 "@code{string->number} returns @code{#f}.")
6439 #define FUNC_NAME s_scm_string_to_number
6443 SCM_VALIDATE_STRING (1, string
);
6445 if (SCM_UNBNDP (radix
))
6448 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6450 answer
= scm_i_string_to_number (string
, base
);
6451 scm_remember_upto_here_1 (string
);
6457 /*** END strs->nums ***/
6460 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6462 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6464 #define FUNC_NAME s_scm_number_p
6466 return scm_from_bool (SCM_NUMBERP (x
));
6470 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6472 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6473 "otherwise. Note that the sets of real, rational and integer\n"
6474 "values form subsets of the set of complex numbers, i. e. the\n"
6475 "predicate will also be fulfilled if @var{x} is a real,\n"
6476 "rational or integer number.")
6477 #define FUNC_NAME s_scm_complex_p
6479 /* all numbers are complex. */
6480 return scm_number_p (x
);
6484 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6486 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6487 "otherwise. Note that the set of integer values forms a subset of\n"
6488 "the set of real numbers, i. e. the predicate will also be\n"
6489 "fulfilled if @var{x} is an integer number.")
6490 #define FUNC_NAME s_scm_real_p
6492 return scm_from_bool
6493 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6497 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6499 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6500 "otherwise. Note that the set of integer values forms a subset of\n"
6501 "the set of rational numbers, i. e. the predicate will also be\n"
6502 "fulfilled if @var{x} is an integer number.")
6503 #define FUNC_NAME s_scm_rational_p
6505 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6507 else if (SCM_REALP (x
))
6508 /* due to their limited precision, finite floating point numbers are
6509 rational as well. (finite means neither infinity nor a NaN) */
6510 return scm_from_bool (isfinite (SCM_REAL_VALUE (x
)));
6516 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6518 "Return @code{#t} if @var{x} is an integer number,\n"
6519 "else return @code{#f}.")
6520 #define FUNC_NAME s_scm_integer_p
6522 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6524 else if (SCM_REALP (x
))
6526 double val
= SCM_REAL_VALUE (x
);
6527 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6534 SCM_DEFINE (scm_exact_integer_p
, "exact-integer?", 1, 0, 0,
6536 "Return @code{#t} if @var{x} is an exact integer number,\n"
6537 "else return @code{#f}.")
6538 #define FUNC_NAME s_scm_exact_integer_p
6540 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6548 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6549 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6550 (SCM x
, SCM y
, SCM rest
),
6551 "Return @code{#t} if all parameters are numerically equal.")
6552 #define FUNC_NAME s_scm_i_num_eq_p
6554 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6556 while (!scm_is_null (rest
))
6558 if (scm_is_false (scm_num_eq_p (x
, y
)))
6562 rest
= scm_cdr (rest
);
6564 return scm_num_eq_p (x
, y
);
6568 scm_num_eq_p (SCM x
, SCM y
)
6571 if (SCM_I_INUMP (x
))
6573 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6574 if (SCM_I_INUMP (y
))
6576 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6577 return scm_from_bool (xx
== yy
);
6579 else if (SCM_BIGP (y
))
6581 else if (SCM_REALP (y
))
6583 /* On a 32-bit system an inum fits a double, we can cast the inum
6584 to a double and compare.
6586 But on a 64-bit system an inum is bigger than a double and
6587 casting it to a double (call that dxx) will round.
6588 Although dxx will not in general be equal to xx, dxx will
6589 always be an integer and within a factor of 2 of xx, so if
6590 dxx==yy, we know that yy is an integer and fits in
6591 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6592 compare with plain xx.
6594 An alternative (for any size system actually) would be to check
6595 yy is an integer (with floor) and is in range of an inum
6596 (compare against appropriate powers of 2) then test
6597 xx==(scm_t_signed_bits)yy. It's just a matter of which
6598 casts/comparisons might be fastest or easiest for the cpu. */
6600 double yy
= SCM_REAL_VALUE (y
);
6601 return scm_from_bool ((double) xx
== yy
6602 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6603 || xx
== (scm_t_signed_bits
) yy
));
6605 else if (SCM_COMPLEXP (y
))
6607 /* see comments with inum/real above */
6608 double ry
= SCM_COMPLEX_REAL (y
);
6609 return scm_from_bool ((double) xx
== ry
6610 && 0.0 == SCM_COMPLEX_IMAG (y
)
6611 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6612 || xx
== (scm_t_signed_bits
) ry
));
6614 else if (SCM_FRACTIONP (y
))
6617 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6619 else if (SCM_BIGP (x
))
6621 if (SCM_I_INUMP (y
))
6623 else if (SCM_BIGP (y
))
6625 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6626 scm_remember_upto_here_2 (x
, y
);
6627 return scm_from_bool (0 == cmp
);
6629 else if (SCM_REALP (y
))
6632 if (isnan (SCM_REAL_VALUE (y
)))
6634 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6635 scm_remember_upto_here_1 (x
);
6636 return scm_from_bool (0 == cmp
);
6638 else if (SCM_COMPLEXP (y
))
6641 if (0.0 != SCM_COMPLEX_IMAG (y
))
6643 if (isnan (SCM_COMPLEX_REAL (y
)))
6645 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6646 scm_remember_upto_here_1 (x
);
6647 return scm_from_bool (0 == cmp
);
6649 else if (SCM_FRACTIONP (y
))
6652 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6654 else if (SCM_REALP (x
))
6656 double xx
= SCM_REAL_VALUE (x
);
6657 if (SCM_I_INUMP (y
))
6659 /* see comments with inum/real above */
6660 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6661 return scm_from_bool (xx
== (double) yy
6662 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6663 || (scm_t_signed_bits
) xx
== yy
));
6665 else if (SCM_BIGP (y
))
6670 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
6671 scm_remember_upto_here_1 (y
);
6672 return scm_from_bool (0 == cmp
);
6674 else if (SCM_REALP (y
))
6675 return scm_from_bool (xx
== SCM_REAL_VALUE (y
));
6676 else if (SCM_COMPLEXP (y
))
6677 return scm_from_bool ((xx
== SCM_COMPLEX_REAL (y
))
6678 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6679 else if (SCM_FRACTIONP (y
))
6681 if (isnan (xx
) || isinf (xx
))
6683 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6687 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6689 else if (SCM_COMPLEXP (x
))
6691 if (SCM_I_INUMP (y
))
6693 /* see comments with inum/real above */
6694 double rx
= SCM_COMPLEX_REAL (x
);
6695 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6696 return scm_from_bool (rx
== (double) yy
6697 && 0.0 == SCM_COMPLEX_IMAG (x
)
6698 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6699 || (scm_t_signed_bits
) rx
== yy
));
6701 else if (SCM_BIGP (y
))
6704 if (0.0 != SCM_COMPLEX_IMAG (x
))
6706 if (isnan (SCM_COMPLEX_REAL (x
)))
6708 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6709 scm_remember_upto_here_1 (y
);
6710 return scm_from_bool (0 == cmp
);
6712 else if (SCM_REALP (y
))
6713 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6714 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6715 else if (SCM_COMPLEXP (y
))
6716 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6717 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6718 else if (SCM_FRACTIONP (y
))
6721 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6723 xx
= SCM_COMPLEX_REAL (x
);
6724 if (isnan (xx
) || isinf (xx
))
6726 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6730 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6732 else if (SCM_FRACTIONP (x
))
6734 if (SCM_I_INUMP (y
))
6736 else if (SCM_BIGP (y
))
6738 else if (SCM_REALP (y
))
6740 double yy
= SCM_REAL_VALUE (y
);
6741 if (isnan (yy
) || isinf (yy
))
6743 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6746 else if (SCM_COMPLEXP (y
))
6749 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6751 yy
= SCM_COMPLEX_REAL (y
);
6752 if (isnan (yy
) || isinf(yy
))
6754 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6757 else if (SCM_FRACTIONP (y
))
6758 return scm_i_fraction_equalp (x
, y
);
6760 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6763 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6767 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6768 done are good for inums, but for bignums an answer can almost always be
6769 had by just examining a few high bits of the operands, as done by GMP in
6770 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6771 of the float exponent to take into account. */
6773 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6774 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6775 (SCM x
, SCM y
, SCM rest
),
6776 "Return @code{#t} if the list of parameters is monotonically\n"
6778 #define FUNC_NAME s_scm_i_num_less_p
6780 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6782 while (!scm_is_null (rest
))
6784 if (scm_is_false (scm_less_p (x
, y
)))
6788 rest
= scm_cdr (rest
);
6790 return scm_less_p (x
, y
);
6794 scm_less_p (SCM x
, SCM y
)
6797 if (SCM_I_INUMP (x
))
6799 scm_t_inum xx
= SCM_I_INUM (x
);
6800 if (SCM_I_INUMP (y
))
6802 scm_t_inum yy
= SCM_I_INUM (y
);
6803 return scm_from_bool (xx
< yy
);
6805 else if (SCM_BIGP (y
))
6807 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6808 scm_remember_upto_here_1 (y
);
6809 return scm_from_bool (sgn
> 0);
6811 else if (SCM_REALP (y
))
6813 /* We can safely take the ceiling of y without changing the
6814 result of x<y, given that x is an integer. */
6815 double yy
= ceil (SCM_REAL_VALUE (y
));
6817 /* In the following comparisons, it's important that the right
6818 hand side always be a power of 2, so that it can be
6819 losslessly converted to a double even on 64-bit
6821 if (yy
>= (double) (SCM_MOST_POSITIVE_FIXNUM
+1))
6823 else if (!(yy
> (double) SCM_MOST_NEGATIVE_FIXNUM
))
6824 /* The condition above is carefully written to include the
6825 case where yy==NaN. */
6828 /* yy is a finite integer that fits in an inum. */
6829 return scm_from_bool (xx
< (scm_t_inum
) yy
);
6831 else if (SCM_FRACTIONP (y
))
6833 /* "x < a/b" becomes "x*b < a" */
6835 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6836 y
= SCM_FRACTION_NUMERATOR (y
);
6840 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6842 else if (SCM_BIGP (x
))
6844 if (SCM_I_INUMP (y
))
6846 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6847 scm_remember_upto_here_1 (x
);
6848 return scm_from_bool (sgn
< 0);
6850 else if (SCM_BIGP (y
))
6852 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6853 scm_remember_upto_here_2 (x
, y
);
6854 return scm_from_bool (cmp
< 0);
6856 else if (SCM_REALP (y
))
6859 if (isnan (SCM_REAL_VALUE (y
)))
6861 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6862 scm_remember_upto_here_1 (x
);
6863 return scm_from_bool (cmp
< 0);
6865 else if (SCM_FRACTIONP (y
))
6868 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6870 else if (SCM_REALP (x
))
6872 if (SCM_I_INUMP (y
))
6874 /* We can safely take the floor of x without changing the
6875 result of x<y, given that y is an integer. */
6876 double xx
= floor (SCM_REAL_VALUE (x
));
6878 /* In the following comparisons, it's important that the right
6879 hand side always be a power of 2, so that it can be
6880 losslessly converted to a double even on 64-bit
6882 if (xx
< (double) SCM_MOST_NEGATIVE_FIXNUM
)
6884 else if (!(xx
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)))
6885 /* The condition above is carefully written to include the
6886 case where xx==NaN. */
6889 /* xx is a finite integer that fits in an inum. */
6890 return scm_from_bool ((scm_t_inum
) xx
< SCM_I_INUM (y
));
6892 else if (SCM_BIGP (y
))
6895 if (isnan (SCM_REAL_VALUE (x
)))
6897 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6898 scm_remember_upto_here_1 (y
);
6899 return scm_from_bool (cmp
> 0);
6901 else if (SCM_REALP (y
))
6902 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6903 else if (SCM_FRACTIONP (y
))
6905 double xx
= SCM_REAL_VALUE (x
);
6909 return scm_from_bool (xx
< 0.0);
6910 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6914 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6916 else if (SCM_FRACTIONP (x
))
6918 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6920 /* "a/b < y" becomes "a < y*b" */
6921 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6922 x
= SCM_FRACTION_NUMERATOR (x
);
6925 else if (SCM_REALP (y
))
6927 double yy
= SCM_REAL_VALUE (y
);
6931 return scm_from_bool (0.0 < yy
);
6932 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6935 else if (SCM_FRACTIONP (y
))
6937 /* "a/b < c/d" becomes "a*d < c*b" */
6938 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6939 SCM_FRACTION_DENOMINATOR (y
));
6940 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6941 SCM_FRACTION_DENOMINATOR (x
));
6947 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6950 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6954 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6955 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6956 (SCM x
, SCM y
, SCM rest
),
6957 "Return @code{#t} if the list of parameters is monotonically\n"
6959 #define FUNC_NAME s_scm_i_num_gr_p
6961 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6963 while (!scm_is_null (rest
))
6965 if (scm_is_false (scm_gr_p (x
, y
)))
6969 rest
= scm_cdr (rest
);
6971 return scm_gr_p (x
, y
);
6974 #define FUNC_NAME s_scm_i_num_gr_p
6976 scm_gr_p (SCM x
, SCM y
)
6978 if (!SCM_NUMBERP (x
))
6979 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6980 else if (!SCM_NUMBERP (y
))
6981 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6983 return scm_less_p (y
, x
);
6988 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6989 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6990 (SCM x
, SCM y
, SCM rest
),
6991 "Return @code{#t} if the list of parameters is monotonically\n"
6993 #define FUNC_NAME s_scm_i_num_leq_p
6995 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6997 while (!scm_is_null (rest
))
6999 if (scm_is_false (scm_leq_p (x
, y
)))
7003 rest
= scm_cdr (rest
);
7005 return scm_leq_p (x
, y
);
7008 #define FUNC_NAME s_scm_i_num_leq_p
7010 scm_leq_p (SCM x
, SCM y
)
7012 if (!SCM_NUMBERP (x
))
7013 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7014 else if (!SCM_NUMBERP (y
))
7015 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7016 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7019 return scm_not (scm_less_p (y
, x
));
7024 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
7025 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
7026 (SCM x
, SCM y
, SCM rest
),
7027 "Return @code{#t} if the list of parameters is monotonically\n"
7029 #define FUNC_NAME s_scm_i_num_geq_p
7031 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
7033 while (!scm_is_null (rest
))
7035 if (scm_is_false (scm_geq_p (x
, y
)))
7039 rest
= scm_cdr (rest
);
7041 return scm_geq_p (x
, y
);
7044 #define FUNC_NAME s_scm_i_num_geq_p
7046 scm_geq_p (SCM x
, SCM y
)
7048 if (!SCM_NUMBERP (x
))
7049 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
7050 else if (!SCM_NUMBERP (y
))
7051 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
7052 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
7055 return scm_not (scm_less_p (x
, y
));
7060 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
7062 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7064 #define FUNC_NAME s_scm_zero_p
7066 if (SCM_I_INUMP (z
))
7067 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
7068 else if (SCM_BIGP (z
))
7070 else if (SCM_REALP (z
))
7071 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
7072 else if (SCM_COMPLEXP (z
))
7073 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
7074 && SCM_COMPLEX_IMAG (z
) == 0.0);
7075 else if (SCM_FRACTIONP (z
))
7078 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
7083 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
7085 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7087 #define FUNC_NAME s_scm_positive_p
7089 if (SCM_I_INUMP (x
))
7090 return scm_from_bool (SCM_I_INUM (x
) > 0);
7091 else if (SCM_BIGP (x
))
7093 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7094 scm_remember_upto_here_1 (x
);
7095 return scm_from_bool (sgn
> 0);
7097 else if (SCM_REALP (x
))
7098 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
7099 else if (SCM_FRACTIONP (x
))
7100 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
7102 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
7107 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7109 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7111 #define FUNC_NAME s_scm_negative_p
7113 if (SCM_I_INUMP (x
))
7114 return scm_from_bool (SCM_I_INUM (x
) < 0);
7115 else if (SCM_BIGP (x
))
7117 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7118 scm_remember_upto_here_1 (x
);
7119 return scm_from_bool (sgn
< 0);
7121 else if (SCM_REALP (x
))
7122 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7123 else if (SCM_FRACTIONP (x
))
7124 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7126 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7131 /* scm_min and scm_max return an inexact when either argument is inexact, as
7132 required by r5rs. On that basis, for exact/inexact combinations the
7133 exact is converted to inexact to compare and possibly return. This is
7134 unlike scm_less_p above which takes some trouble to preserve all bits in
7135 its test, such trouble is not required for min and max. */
7137 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7138 (SCM x
, SCM y
, SCM rest
),
7139 "Return the maximum of all parameter values.")
7140 #define FUNC_NAME s_scm_i_max
7142 while (!scm_is_null (rest
))
7143 { x
= scm_max (x
, y
);
7145 rest
= scm_cdr (rest
);
7147 return scm_max (x
, y
);
7151 #define s_max s_scm_i_max
7152 #define g_max g_scm_i_max
7155 scm_max (SCM x
, SCM y
)
7160 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7161 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7164 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7167 if (SCM_I_INUMP (x
))
7169 scm_t_inum xx
= SCM_I_INUM (x
);
7170 if (SCM_I_INUMP (y
))
7172 scm_t_inum yy
= SCM_I_INUM (y
);
7173 return (xx
< yy
) ? y
: x
;
7175 else if (SCM_BIGP (y
))
7177 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7178 scm_remember_upto_here_1 (y
);
7179 return (sgn
< 0) ? x
: y
;
7181 else if (SCM_REALP (y
))
7184 double yyd
= SCM_REAL_VALUE (y
);
7187 return scm_i_from_double (xxd
);
7188 /* If y is a NaN, then "==" is false and we return the NaN */
7189 else if (SCM_LIKELY (!(xxd
== yyd
)))
7191 /* Handle signed zeroes properly */
7197 else if (SCM_FRACTIONP (y
))
7200 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7203 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7205 else if (SCM_BIGP (x
))
7207 if (SCM_I_INUMP (y
))
7209 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7210 scm_remember_upto_here_1 (x
);
7211 return (sgn
< 0) ? y
: x
;
7213 else if (SCM_BIGP (y
))
7215 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7216 scm_remember_upto_here_2 (x
, y
);
7217 return (cmp
> 0) ? x
: y
;
7219 else if (SCM_REALP (y
))
7221 /* if y==NaN then xx>yy is false, so we return the NaN y */
7224 xx
= scm_i_big2dbl (x
);
7225 yy
= SCM_REAL_VALUE (y
);
7226 return (xx
> yy
? scm_i_from_double (xx
) : y
);
7228 else if (SCM_FRACTIONP (y
))
7233 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7235 else if (SCM_REALP (x
))
7237 if (SCM_I_INUMP (y
))
7239 scm_t_inum yy
= SCM_I_INUM (y
);
7240 double xxd
= SCM_REAL_VALUE (x
);
7244 return scm_i_from_double (yyd
);
7245 /* If x is a NaN, then "==" is false and we return the NaN */
7246 else if (SCM_LIKELY (!(xxd
== yyd
)))
7248 /* Handle signed zeroes properly */
7254 else if (SCM_BIGP (y
))
7259 else if (SCM_REALP (y
))
7261 double xx
= SCM_REAL_VALUE (x
);
7262 double yy
= SCM_REAL_VALUE (y
);
7264 /* For purposes of max: nan > +inf.0 > everything else,
7265 per the R6RS errata */
7268 else if (SCM_LIKELY (xx
< yy
))
7270 /* If neither (xx > yy) nor (xx < yy), then
7271 either they're equal or one is a NaN */
7272 else if (SCM_UNLIKELY (xx
!= yy
))
7273 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7274 /* xx == yy, but handle signed zeroes properly */
7275 else if (copysign (1.0, yy
) < 0.0)
7280 else if (SCM_FRACTIONP (y
))
7282 double yy
= scm_i_fraction2double (y
);
7283 double xx
= SCM_REAL_VALUE (x
);
7284 return (xx
< yy
) ? scm_i_from_double (yy
) : x
;
7287 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7289 else if (SCM_FRACTIONP (x
))
7291 if (SCM_I_INUMP (y
))
7295 else if (SCM_BIGP (y
))
7299 else if (SCM_REALP (y
))
7301 double xx
= scm_i_fraction2double (x
);
7302 /* if y==NaN then ">" is false, so we return the NaN y */
7303 return (xx
> SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7305 else if (SCM_FRACTIONP (y
))
7310 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7313 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7317 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7318 (SCM x
, SCM y
, SCM rest
),
7319 "Return the minimum of all parameter values.")
7320 #define FUNC_NAME s_scm_i_min
7322 while (!scm_is_null (rest
))
7323 { x
= scm_min (x
, y
);
7325 rest
= scm_cdr (rest
);
7327 return scm_min (x
, y
);
7331 #define s_min s_scm_i_min
7332 #define g_min g_scm_i_min
7335 scm_min (SCM x
, SCM y
)
7340 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7341 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7344 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7347 if (SCM_I_INUMP (x
))
7349 scm_t_inum xx
= SCM_I_INUM (x
);
7350 if (SCM_I_INUMP (y
))
7352 scm_t_inum yy
= SCM_I_INUM (y
);
7353 return (xx
< yy
) ? x
: y
;
7355 else if (SCM_BIGP (y
))
7357 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7358 scm_remember_upto_here_1 (y
);
7359 return (sgn
< 0) ? y
: x
;
7361 else if (SCM_REALP (y
))
7364 /* if y==NaN then "<" is false and we return NaN */
7365 return (z
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (z
) : y
;
7367 else if (SCM_FRACTIONP (y
))
7370 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7373 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7375 else if (SCM_BIGP (x
))
7377 if (SCM_I_INUMP (y
))
7379 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7380 scm_remember_upto_here_1 (x
);
7381 return (sgn
< 0) ? x
: y
;
7383 else if (SCM_BIGP (y
))
7385 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7386 scm_remember_upto_here_2 (x
, y
);
7387 return (cmp
> 0) ? y
: x
;
7389 else if (SCM_REALP (y
))
7391 /* if y==NaN then xx<yy is false, so we return the NaN y */
7394 xx
= scm_i_big2dbl (x
);
7395 yy
= SCM_REAL_VALUE (y
);
7396 return (xx
< yy
? scm_i_from_double (xx
) : y
);
7398 else if (SCM_FRACTIONP (y
))
7403 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7405 else if (SCM_REALP (x
))
7407 if (SCM_I_INUMP (y
))
7409 double z
= SCM_I_INUM (y
);
7410 /* if x==NaN then "<" is false and we return NaN */
7411 return (z
< SCM_REAL_VALUE (x
)) ? scm_i_from_double (z
) : x
;
7413 else if (SCM_BIGP (y
))
7418 else if (SCM_REALP (y
))
7420 double xx
= SCM_REAL_VALUE (x
);
7421 double yy
= SCM_REAL_VALUE (y
);
7423 /* For purposes of min: nan < -inf.0 < everything else,
7424 per the R6RS errata */
7427 else if (SCM_LIKELY (xx
> yy
))
7429 /* If neither (xx < yy) nor (xx > yy), then
7430 either they're equal or one is a NaN */
7431 else if (SCM_UNLIKELY (xx
!= yy
))
7432 return (xx
!= xx
) ? x
: y
; /* Return the NaN */
7433 /* xx == yy, but handle signed zeroes properly */
7434 else if (copysign (1.0, xx
) < 0.0)
7439 else if (SCM_FRACTIONP (y
))
7441 double yy
= scm_i_fraction2double (y
);
7442 double xx
= SCM_REAL_VALUE (x
);
7443 return (yy
< xx
) ? scm_i_from_double (yy
) : x
;
7446 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7448 else if (SCM_FRACTIONP (x
))
7450 if (SCM_I_INUMP (y
))
7454 else if (SCM_BIGP (y
))
7458 else if (SCM_REALP (y
))
7460 double xx
= scm_i_fraction2double (x
);
7461 /* if y==NaN then "<" is false, so we return the NaN y */
7462 return (xx
< SCM_REAL_VALUE (y
)) ? scm_i_from_double (xx
) : y
;
7464 else if (SCM_FRACTIONP (y
))
7469 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7472 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7476 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7477 (SCM x
, SCM y
, SCM rest
),
7478 "Return the sum of all parameter values. Return 0 if called without\n"
7480 #define FUNC_NAME s_scm_i_sum
7482 while (!scm_is_null (rest
))
7483 { x
= scm_sum (x
, y
);
7485 rest
= scm_cdr (rest
);
7487 return scm_sum (x
, y
);
7491 #define s_sum s_scm_i_sum
7492 #define g_sum g_scm_i_sum
7495 scm_sum (SCM x
, SCM y
)
7497 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7499 if (SCM_NUMBERP (x
)) return x
;
7500 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7501 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7504 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7506 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7508 scm_t_inum xx
= SCM_I_INUM (x
);
7509 scm_t_inum yy
= SCM_I_INUM (y
);
7510 scm_t_inum z
= xx
+ yy
;
7511 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7513 else if (SCM_BIGP (y
))
7518 else if (SCM_REALP (y
))
7520 scm_t_inum xx
= SCM_I_INUM (x
);
7521 return scm_i_from_double (xx
+ SCM_REAL_VALUE (y
));
7523 else if (SCM_COMPLEXP (y
))
7525 scm_t_inum xx
= SCM_I_INUM (x
);
7526 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7527 SCM_COMPLEX_IMAG (y
));
7529 else if (SCM_FRACTIONP (y
))
7530 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7531 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7532 SCM_FRACTION_DENOMINATOR (y
));
7534 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7535 } else if (SCM_BIGP (x
))
7537 if (SCM_I_INUMP (y
))
7542 inum
= SCM_I_INUM (y
);
7545 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7548 SCM result
= scm_i_mkbig ();
7549 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7550 scm_remember_upto_here_1 (x
);
7551 /* we know the result will have to be a bignum */
7554 return scm_i_normbig (result
);
7558 SCM result
= scm_i_mkbig ();
7559 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7560 scm_remember_upto_here_1 (x
);
7561 /* we know the result will have to be a bignum */
7564 return scm_i_normbig (result
);
7567 else if (SCM_BIGP (y
))
7569 SCM result
= scm_i_mkbig ();
7570 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7571 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7572 mpz_add (SCM_I_BIG_MPZ (result
),
7575 scm_remember_upto_here_2 (x
, y
);
7576 /* we know the result will have to be a bignum */
7579 return scm_i_normbig (result
);
7581 else if (SCM_REALP (y
))
7583 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7584 scm_remember_upto_here_1 (x
);
7585 return scm_i_from_double (result
);
7587 else if (SCM_COMPLEXP (y
))
7589 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7590 + SCM_COMPLEX_REAL (y
));
7591 scm_remember_upto_here_1 (x
);
7592 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7594 else if (SCM_FRACTIONP (y
))
7595 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7596 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7597 SCM_FRACTION_DENOMINATOR (y
));
7599 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7601 else if (SCM_REALP (x
))
7603 if (SCM_I_INUMP (y
))
7604 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7605 else if (SCM_BIGP (y
))
7607 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7608 scm_remember_upto_here_1 (y
);
7609 return scm_i_from_double (result
);
7611 else if (SCM_REALP (y
))
7612 return scm_i_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7613 else if (SCM_COMPLEXP (y
))
7614 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7615 SCM_COMPLEX_IMAG (y
));
7616 else if (SCM_FRACTIONP (y
))
7617 return scm_i_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7619 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7621 else if (SCM_COMPLEXP (x
))
7623 if (SCM_I_INUMP (y
))
7624 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7625 SCM_COMPLEX_IMAG (x
));
7626 else if (SCM_BIGP (y
))
7628 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7629 + SCM_COMPLEX_REAL (x
));
7630 scm_remember_upto_here_1 (y
);
7631 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7633 else if (SCM_REALP (y
))
7634 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7635 SCM_COMPLEX_IMAG (x
));
7636 else if (SCM_COMPLEXP (y
))
7637 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7638 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7639 else if (SCM_FRACTIONP (y
))
7640 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7641 SCM_COMPLEX_IMAG (x
));
7643 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7645 else if (SCM_FRACTIONP (x
))
7647 if (SCM_I_INUMP (y
))
7648 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7649 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7650 SCM_FRACTION_DENOMINATOR (x
));
7651 else if (SCM_BIGP (y
))
7652 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7653 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7654 SCM_FRACTION_DENOMINATOR (x
));
7655 else if (SCM_REALP (y
))
7656 return scm_i_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7657 else if (SCM_COMPLEXP (y
))
7658 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7659 SCM_COMPLEX_IMAG (y
));
7660 else if (SCM_FRACTIONP (y
))
7661 /* a/b + c/d = (ad + bc) / bd */
7662 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7663 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7664 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7666 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7669 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7673 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7675 "Return @math{@var{x}+1}.")
7676 #define FUNC_NAME s_scm_oneplus
7678 return scm_sum (x
, SCM_INUM1
);
7683 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7684 (SCM x
, SCM y
, SCM rest
),
7685 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7686 "the sum of all but the first argument are subtracted from the first\n"
7688 #define FUNC_NAME s_scm_i_difference
7690 while (!scm_is_null (rest
))
7691 { x
= scm_difference (x
, y
);
7693 rest
= scm_cdr (rest
);
7695 return scm_difference (x
, y
);
7699 #define s_difference s_scm_i_difference
7700 #define g_difference g_scm_i_difference
7703 scm_difference (SCM x
, SCM y
)
7704 #define FUNC_NAME s_difference
7706 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7709 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7711 if (SCM_I_INUMP (x
))
7713 scm_t_inum xx
= -SCM_I_INUM (x
);
7714 if (SCM_FIXABLE (xx
))
7715 return SCM_I_MAKINUM (xx
);
7717 return scm_i_inum2big (xx
);
7719 else if (SCM_BIGP (x
))
7720 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7721 bignum, but negating that gives a fixnum. */
7722 return scm_i_normbig (scm_i_clonebig (x
, 0));
7723 else if (SCM_REALP (x
))
7724 return scm_i_from_double (-SCM_REAL_VALUE (x
));
7725 else if (SCM_COMPLEXP (x
))
7726 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7727 -SCM_COMPLEX_IMAG (x
));
7728 else if (SCM_FRACTIONP (x
))
7729 return scm_i_make_ratio_already_reduced
7730 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7731 SCM_FRACTION_DENOMINATOR (x
));
7733 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7736 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7738 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7740 scm_t_inum xx
= SCM_I_INUM (x
);
7741 scm_t_inum yy
= SCM_I_INUM (y
);
7742 scm_t_inum z
= xx
- yy
;
7743 if (SCM_FIXABLE (z
))
7744 return SCM_I_MAKINUM (z
);
7746 return scm_i_inum2big (z
);
7748 else if (SCM_BIGP (y
))
7750 /* inum-x - big-y */
7751 scm_t_inum xx
= SCM_I_INUM (x
);
7755 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7756 bignum, but negating that gives a fixnum. */
7757 return scm_i_normbig (scm_i_clonebig (y
, 0));
7761 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7762 SCM result
= scm_i_mkbig ();
7765 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7768 /* x - y == -(y + -x) */
7769 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7770 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7772 scm_remember_upto_here_1 (y
);
7774 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7775 /* we know the result will have to be a bignum */
7778 return scm_i_normbig (result
);
7781 else if (SCM_REALP (y
))
7783 scm_t_inum xx
= SCM_I_INUM (x
);
7786 * We need to handle x == exact 0
7787 * specially because R6RS states that:
7788 * (- 0.0) ==> -0.0 and
7789 * (- 0.0 0.0) ==> 0.0
7790 * and the scheme compiler changes
7791 * (- 0.0) into (- 0 0.0)
7792 * So we need to treat (- 0 0.0) like (- 0.0).
7793 * At the C level, (-x) is different than (0.0 - x).
7794 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7797 return scm_i_from_double (- SCM_REAL_VALUE (y
));
7799 return scm_i_from_double (xx
- SCM_REAL_VALUE (y
));
7801 else if (SCM_COMPLEXP (y
))
7803 scm_t_inum xx
= SCM_I_INUM (x
);
7805 /* We need to handle x == exact 0 specially.
7806 See the comment above (for SCM_REALP (y)) */
7808 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7809 - SCM_COMPLEX_IMAG (y
));
7811 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7812 - SCM_COMPLEX_IMAG (y
));
7814 else if (SCM_FRACTIONP (y
))
7815 /* a - b/c = (ac - b) / c */
7816 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7817 SCM_FRACTION_NUMERATOR (y
)),
7818 SCM_FRACTION_DENOMINATOR (y
));
7820 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7822 else if (SCM_BIGP (x
))
7824 if (SCM_I_INUMP (y
))
7826 /* big-x - inum-y */
7827 scm_t_inum yy
= SCM_I_INUM (y
);
7828 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7830 scm_remember_upto_here_1 (x
);
7832 return (SCM_FIXABLE (-yy
) ?
7833 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7836 SCM result
= scm_i_mkbig ();
7839 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7841 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7842 scm_remember_upto_here_1 (x
);
7844 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7845 /* we know the result will have to be a bignum */
7848 return scm_i_normbig (result
);
7851 else if (SCM_BIGP (y
))
7853 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7854 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7855 SCM result
= scm_i_mkbig ();
7856 mpz_sub (SCM_I_BIG_MPZ (result
),
7859 scm_remember_upto_here_2 (x
, y
);
7860 /* we know the result will have to be a bignum */
7861 if ((sgn_x
== 1) && (sgn_y
== -1))
7863 if ((sgn_x
== -1) && (sgn_y
== 1))
7865 return scm_i_normbig (result
);
7867 else if (SCM_REALP (y
))
7869 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7870 scm_remember_upto_here_1 (x
);
7871 return scm_i_from_double (result
);
7873 else if (SCM_COMPLEXP (y
))
7875 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7876 - SCM_COMPLEX_REAL (y
));
7877 scm_remember_upto_here_1 (x
);
7878 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7880 else if (SCM_FRACTIONP (y
))
7881 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7882 SCM_FRACTION_NUMERATOR (y
)),
7883 SCM_FRACTION_DENOMINATOR (y
));
7884 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7886 else if (SCM_REALP (x
))
7888 if (SCM_I_INUMP (y
))
7889 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7890 else if (SCM_BIGP (y
))
7892 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7893 scm_remember_upto_here_1 (x
);
7894 return scm_i_from_double (result
);
7896 else if (SCM_REALP (y
))
7897 return scm_i_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7898 else if (SCM_COMPLEXP (y
))
7899 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7900 -SCM_COMPLEX_IMAG (y
));
7901 else if (SCM_FRACTIONP (y
))
7902 return scm_i_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7904 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7906 else if (SCM_COMPLEXP (x
))
7908 if (SCM_I_INUMP (y
))
7909 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7910 SCM_COMPLEX_IMAG (x
));
7911 else if (SCM_BIGP (y
))
7913 double real_part
= (SCM_COMPLEX_REAL (x
)
7914 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7915 scm_remember_upto_here_1 (x
);
7916 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7918 else if (SCM_REALP (y
))
7919 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7920 SCM_COMPLEX_IMAG (x
));
7921 else if (SCM_COMPLEXP (y
))
7922 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7923 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7924 else if (SCM_FRACTIONP (y
))
7925 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7926 SCM_COMPLEX_IMAG (x
));
7928 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7930 else if (SCM_FRACTIONP (x
))
7932 if (SCM_I_INUMP (y
))
7933 /* a/b - c = (a - cb) / b */
7934 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7935 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7936 SCM_FRACTION_DENOMINATOR (x
));
7937 else if (SCM_BIGP (y
))
7938 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7939 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7940 SCM_FRACTION_DENOMINATOR (x
));
7941 else if (SCM_REALP (y
))
7942 return scm_i_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7943 else if (SCM_COMPLEXP (y
))
7944 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7945 -SCM_COMPLEX_IMAG (y
));
7946 else if (SCM_FRACTIONP (y
))
7947 /* a/b - c/d = (ad - bc) / bd */
7948 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7949 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7950 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7952 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7955 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7960 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7962 "Return @math{@var{x}-1}.")
7963 #define FUNC_NAME s_scm_oneminus
7965 return scm_difference (x
, SCM_INUM1
);
7970 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7971 (SCM x
, SCM y
, SCM rest
),
7972 "Return the product of all arguments. If called without arguments,\n"
7974 #define FUNC_NAME s_scm_i_product
7976 while (!scm_is_null (rest
))
7977 { x
= scm_product (x
, y
);
7979 rest
= scm_cdr (rest
);
7981 return scm_product (x
, y
);
7985 #define s_product s_scm_i_product
7986 #define g_product g_scm_i_product
7989 scm_product (SCM x
, SCM y
)
7991 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7994 return SCM_I_MAKINUM (1L);
7995 else if (SCM_NUMBERP (x
))
7998 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
8001 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8006 xx
= SCM_I_INUM (x
);
8011 /* exact1 is the universal multiplicative identity */
8015 /* exact0 times a fixnum is exact0: optimize this case */
8016 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8018 /* if the other argument is inexact, the result is inexact,
8019 and we must do the multiplication in order to handle
8020 infinities and NaNs properly. */
8021 else if (SCM_REALP (y
))
8022 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y
));
8023 else if (SCM_COMPLEXP (y
))
8024 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
8025 0.0 * SCM_COMPLEX_IMAG (y
));
8026 /* we've already handled inexact numbers,
8027 so y must be exact, and we return exact0 */
8028 else if (SCM_NUMP (y
))
8031 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8035 * This case is important for more than just optimization.
8036 * It handles the case of negating
8037 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
8038 * which is a bignum that must be changed back into a fixnum.
8039 * Failure to do so will cause the following to return #f:
8040 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
8042 return scm_difference(y
, SCM_UNDEFINED
);
8046 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8048 scm_t_inum yy
= SCM_I_INUM (y
);
8049 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8050 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
8051 if (SCM_FIXABLE (kk
))
8052 return SCM_I_MAKINUM (kk
);
8054 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
8055 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
8056 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
8057 return SCM_I_MAKINUM (xx
* yy
);
8061 SCM result
= scm_i_inum2big (xx
);
8062 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
8063 return scm_i_normbig (result
);
8066 else if (SCM_BIGP (y
))
8068 SCM result
= scm_i_mkbig ();
8069 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
8070 scm_remember_upto_here_1 (y
);
8073 else if (SCM_REALP (y
))
8074 return scm_i_from_double (xx
* SCM_REAL_VALUE (y
));
8075 else if (SCM_COMPLEXP (y
))
8076 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8077 xx
* SCM_COMPLEX_IMAG (y
));
8078 else if (SCM_FRACTIONP (y
))
8079 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8080 SCM_FRACTION_DENOMINATOR (y
));
8082 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8084 else if (SCM_BIGP (x
))
8086 if (SCM_I_INUMP (y
))
8091 else if (SCM_BIGP (y
))
8093 SCM result
= scm_i_mkbig ();
8094 mpz_mul (SCM_I_BIG_MPZ (result
),
8097 scm_remember_upto_here_2 (x
, y
);
8100 else if (SCM_REALP (y
))
8102 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
8103 scm_remember_upto_here_1 (x
);
8104 return scm_i_from_double (result
);
8106 else if (SCM_COMPLEXP (y
))
8108 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8109 scm_remember_upto_here_1 (x
);
8110 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8111 z
* SCM_COMPLEX_IMAG (y
));
8113 else if (SCM_FRACTIONP (y
))
8114 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8115 SCM_FRACTION_DENOMINATOR (y
));
8117 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8119 else if (SCM_REALP (x
))
8121 if (SCM_I_INUMP (y
))
8126 else if (SCM_BIGP (y
))
8128 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8129 scm_remember_upto_here_1 (y
);
8130 return scm_i_from_double (result
);
8132 else if (SCM_REALP (y
))
8133 return scm_i_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8134 else if (SCM_COMPLEXP (y
))
8135 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8136 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8137 else if (SCM_FRACTIONP (y
))
8138 return scm_i_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8140 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8142 else if (SCM_COMPLEXP (x
))
8144 if (SCM_I_INUMP (y
))
8149 else if (SCM_BIGP (y
))
8151 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8152 scm_remember_upto_here_1 (y
);
8153 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8154 z
* SCM_COMPLEX_IMAG (x
));
8156 else if (SCM_REALP (y
))
8157 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8158 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8159 else if (SCM_COMPLEXP (y
))
8161 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8162 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8163 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8164 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8166 else if (SCM_FRACTIONP (y
))
8168 double yy
= scm_i_fraction2double (y
);
8169 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8170 yy
* SCM_COMPLEX_IMAG (x
));
8173 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8175 else if (SCM_FRACTIONP (x
))
8177 if (SCM_I_INUMP (y
))
8178 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8179 SCM_FRACTION_DENOMINATOR (x
));
8180 else if (SCM_BIGP (y
))
8181 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8182 SCM_FRACTION_DENOMINATOR (x
));
8183 else if (SCM_REALP (y
))
8184 return scm_i_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8185 else if (SCM_COMPLEXP (y
))
8187 double xx
= scm_i_fraction2double (x
);
8188 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8189 xx
* SCM_COMPLEX_IMAG (y
));
8191 else if (SCM_FRACTIONP (y
))
8192 /* a/b * c/d = ac / bd */
8193 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8194 SCM_FRACTION_NUMERATOR (y
)),
8195 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8196 SCM_FRACTION_DENOMINATOR (y
)));
8198 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8201 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8204 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8205 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8206 #define ALLOW_DIVIDE_BY_ZERO
8207 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8210 /* The code below for complex division is adapted from the GNU
8211 libstdc++, which adapted it from f2c's libF77, and is subject to
8214 /****************************************************************
8215 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8217 Permission to use, copy, modify, and distribute this software
8218 and its documentation for any purpose and without fee is hereby
8219 granted, provided that the above copyright notice appear in all
8220 copies and that both that the copyright notice and this
8221 permission notice and warranty disclaimer appear in supporting
8222 documentation, and that the names of AT&T Bell Laboratories or
8223 Bellcore or any of their entities not be used in advertising or
8224 publicity pertaining to distribution of the software without
8225 specific, written prior permission.
8227 AT&T and Bellcore disclaim all warranties with regard to this
8228 software, including all implied warranties of merchantability
8229 and fitness. In no event shall AT&T or Bellcore be liable for
8230 any special, indirect or consequential damages or any damages
8231 whatsoever resulting from loss of use, data or profits, whether
8232 in an action of contract, negligence or other tortious action,
8233 arising out of or in connection with the use or performance of
8235 ****************************************************************/
8237 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8238 (SCM x
, SCM y
, SCM rest
),
8239 "Divide the first argument by the product of the remaining\n"
8240 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8242 #define FUNC_NAME s_scm_i_divide
8244 while (!scm_is_null (rest
))
8245 { x
= scm_divide (x
, y
);
8247 rest
= scm_cdr (rest
);
8249 return scm_divide (x
, y
);
8253 #define s_divide s_scm_i_divide
8254 #define g_divide g_scm_i_divide
8257 scm_divide (SCM x
, SCM y
)
8258 #define FUNC_NAME s_divide
8262 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8265 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8266 else if (SCM_I_INUMP (x
))
8268 scm_t_inum xx
= SCM_I_INUM (x
);
8269 if (xx
== 1 || xx
== -1)
8271 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8273 scm_num_overflow (s_divide
);
8276 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8278 else if (SCM_BIGP (x
))
8279 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8280 else if (SCM_REALP (x
))
8282 double xx
= SCM_REAL_VALUE (x
);
8283 #ifndef ALLOW_DIVIDE_BY_ZERO
8285 scm_num_overflow (s_divide
);
8288 return scm_i_from_double (1.0 / xx
);
8290 else if (SCM_COMPLEXP (x
))
8292 double r
= SCM_COMPLEX_REAL (x
);
8293 double i
= SCM_COMPLEX_IMAG (x
);
8294 if (fabs(r
) <= fabs(i
))
8297 double d
= i
* (1.0 + t
* t
);
8298 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8303 double d
= r
* (1.0 + t
* t
);
8304 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8307 else if (SCM_FRACTIONP (x
))
8308 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8309 SCM_FRACTION_NUMERATOR (x
));
8311 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8314 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8316 scm_t_inum xx
= SCM_I_INUM (x
);
8317 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8319 scm_t_inum yy
= SCM_I_INUM (y
);
8322 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8323 scm_num_overflow (s_divide
);
8325 return scm_i_from_double ((double) xx
/ (double) yy
);
8328 else if (xx
% yy
!= 0)
8329 return scm_i_make_ratio (x
, y
);
8332 scm_t_inum z
= xx
/ yy
;
8333 if (SCM_FIXABLE (z
))
8334 return SCM_I_MAKINUM (z
);
8336 return scm_i_inum2big (z
);
8339 else if (SCM_BIGP (y
))
8340 return scm_i_make_ratio (x
, y
);
8341 else if (SCM_REALP (y
))
8343 double yy
= SCM_REAL_VALUE (y
);
8344 #ifndef ALLOW_DIVIDE_BY_ZERO
8346 scm_num_overflow (s_divide
);
8349 /* FIXME: Precision may be lost here due to:
8350 (1) The cast from 'scm_t_inum' to 'double'
8351 (2) Double rounding */
8352 return scm_i_from_double ((double) xx
/ yy
);
8354 else if (SCM_COMPLEXP (y
))
8357 complex_div
: /* y _must_ be a complex number */
8359 double r
= SCM_COMPLEX_REAL (y
);
8360 double i
= SCM_COMPLEX_IMAG (y
);
8361 if (fabs(r
) <= fabs(i
))
8364 double d
= i
* (1.0 + t
* t
);
8365 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8370 double d
= r
* (1.0 + t
* t
);
8371 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8375 else if (SCM_FRACTIONP (y
))
8376 /* a / b/c = ac / b */
8377 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8378 SCM_FRACTION_NUMERATOR (y
));
8380 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8382 else if (SCM_BIGP (x
))
8384 if (SCM_I_INUMP (y
))
8386 scm_t_inum yy
= SCM_I_INUM (y
);
8389 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8390 scm_num_overflow (s_divide
);
8392 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8393 scm_remember_upto_here_1 (x
);
8394 return (sgn
== 0) ? scm_nan () : scm_inf ();
8401 /* FIXME: HMM, what are the relative performance issues here?
8402 We need to test. Is it faster on average to test
8403 divisible_p, then perform whichever operation, or is it
8404 faster to perform the integer div opportunistically and
8405 switch to real if there's a remainder? For now we take the
8406 middle ground: test, then if divisible, use the faster div
8409 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8410 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8414 SCM result
= scm_i_mkbig ();
8415 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8416 scm_remember_upto_here_1 (x
);
8418 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8419 return scm_i_normbig (result
);
8422 return scm_i_make_ratio (x
, y
);
8425 else if (SCM_BIGP (y
))
8427 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8431 SCM result
= scm_i_mkbig ();
8432 mpz_divexact (SCM_I_BIG_MPZ (result
),
8435 scm_remember_upto_here_2 (x
, y
);
8436 return scm_i_normbig (result
);
8439 return scm_i_make_ratio (x
, y
);
8441 else if (SCM_REALP (y
))
8443 double yy
= SCM_REAL_VALUE (y
);
8444 #ifndef ALLOW_DIVIDE_BY_ZERO
8446 scm_num_overflow (s_divide
);
8449 /* FIXME: Precision may be lost here due to:
8450 (1) scm_i_big2dbl (2) Double rounding */
8451 return scm_i_from_double (scm_i_big2dbl (x
) / yy
);
8453 else if (SCM_COMPLEXP (y
))
8455 a
= scm_i_big2dbl (x
);
8458 else if (SCM_FRACTIONP (y
))
8459 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8460 SCM_FRACTION_NUMERATOR (y
));
8462 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8464 else if (SCM_REALP (x
))
8466 double rx
= SCM_REAL_VALUE (x
);
8467 if (SCM_I_INUMP (y
))
8469 scm_t_inum yy
= SCM_I_INUM (y
);
8470 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8472 scm_num_overflow (s_divide
);
8475 /* FIXME: Precision may be lost here due to:
8476 (1) The cast from 'scm_t_inum' to 'double'
8477 (2) Double rounding */
8478 return scm_i_from_double (rx
/ (double) yy
);
8480 else if (SCM_BIGP (y
))
8482 /* FIXME: Precision may be lost here due to:
8483 (1) The conversion from bignum to double
8484 (2) Double rounding */
8485 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8486 scm_remember_upto_here_1 (y
);
8487 return scm_i_from_double (rx
/ dby
);
8489 else if (SCM_REALP (y
))
8491 double yy
= SCM_REAL_VALUE (y
);
8492 #ifndef ALLOW_DIVIDE_BY_ZERO
8494 scm_num_overflow (s_divide
);
8497 return scm_i_from_double (rx
/ yy
);
8499 else if (SCM_COMPLEXP (y
))
8504 else if (SCM_FRACTIONP (y
))
8505 return scm_i_from_double (rx
/ scm_i_fraction2double (y
));
8507 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8509 else if (SCM_COMPLEXP (x
))
8511 double rx
= SCM_COMPLEX_REAL (x
);
8512 double ix
= SCM_COMPLEX_IMAG (x
);
8513 if (SCM_I_INUMP (y
))
8515 scm_t_inum yy
= SCM_I_INUM (y
);
8516 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8518 scm_num_overflow (s_divide
);
8522 /* FIXME: Precision may be lost here due to:
8523 (1) The conversion from 'scm_t_inum' to double
8524 (2) Double rounding */
8526 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8529 else if (SCM_BIGP (y
))
8531 /* FIXME: Precision may be lost here due to:
8532 (1) The conversion from bignum to double
8533 (2) Double rounding */
8534 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8535 scm_remember_upto_here_1 (y
);
8536 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8538 else if (SCM_REALP (y
))
8540 double yy
= SCM_REAL_VALUE (y
);
8541 #ifndef ALLOW_DIVIDE_BY_ZERO
8543 scm_num_overflow (s_divide
);
8546 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8548 else if (SCM_COMPLEXP (y
))
8550 double ry
= SCM_COMPLEX_REAL (y
);
8551 double iy
= SCM_COMPLEX_IMAG (y
);
8552 if (fabs(ry
) <= fabs(iy
))
8555 double d
= iy
* (1.0 + t
* t
);
8556 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8561 double d
= ry
* (1.0 + t
* t
);
8562 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8565 else if (SCM_FRACTIONP (y
))
8567 /* FIXME: Precision may be lost here due to:
8568 (1) The conversion from fraction to double
8569 (2) Double rounding */
8570 double yy
= scm_i_fraction2double (y
);
8571 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8574 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8576 else if (SCM_FRACTIONP (x
))
8578 if (SCM_I_INUMP (y
))
8580 scm_t_inum yy
= SCM_I_INUM (y
);
8581 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8583 scm_num_overflow (s_divide
);
8586 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8587 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8589 else if (SCM_BIGP (y
))
8591 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8592 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8594 else if (SCM_REALP (y
))
8596 double yy
= SCM_REAL_VALUE (y
);
8597 #ifndef ALLOW_DIVIDE_BY_ZERO
8599 scm_num_overflow (s_divide
);
8602 /* FIXME: Precision may be lost here due to:
8603 (1) The conversion from fraction to double
8604 (2) Double rounding */
8605 return scm_i_from_double (scm_i_fraction2double (x
) / yy
);
8607 else if (SCM_COMPLEXP (y
))
8609 /* FIXME: Precision may be lost here due to:
8610 (1) The conversion from fraction to double
8611 (2) Double rounding */
8612 a
= scm_i_fraction2double (x
);
8615 else if (SCM_FRACTIONP (y
))
8616 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8617 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8619 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8622 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8628 scm_c_truncate (double x
)
8633 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8634 half-way case (ie. when x is an integer plus 0.5) going upwards.
8635 Then half-way cases are identified and adjusted down if the
8636 round-upwards didn't give the desired even integer.
8638 "plus_half == result" identifies a half-way case. If plus_half, which is
8639 x + 0.5, is an integer then x must be an integer plus 0.5.
8641 An odd "result" value is identified with result/2 != floor(result/2).
8642 This is done with plus_half, since that value is ready for use sooner in
8643 a pipelined cpu, and we're already requiring plus_half == result.
8645 Note however that we need to be careful when x is big and already an
8646 integer. In that case "x+0.5" may round to an adjacent integer, causing
8647 us to return such a value, incorrectly. For instance if the hardware is
8648 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8649 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8650 returned. Or if the hardware is in round-upwards mode, then other bigger
8651 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8652 representable value, 2^128+2^76 (or whatever), again incorrect.
8654 These bad roundings of x+0.5 are avoided by testing at the start whether
8655 x is already an integer. If it is then clearly that's the desired result
8656 already. And if it's not then the exponent must be small enough to allow
8657 an 0.5 to be represented, and hence added without a bad rounding. */
8660 scm_c_round (double x
)
8662 double plus_half
, result
;
8667 plus_half
= x
+ 0.5;
8668 result
= floor (plus_half
);
8669 /* Adjust so that the rounding is towards even. */
8670 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8675 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8677 "Round the number @var{x} towards zero.")
8678 #define FUNC_NAME s_scm_truncate_number
8680 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8682 else if (SCM_REALP (x
))
8683 return scm_i_from_double (trunc (SCM_REAL_VALUE (x
)));
8684 else if (SCM_FRACTIONP (x
))
8685 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8686 SCM_FRACTION_DENOMINATOR (x
));
8688 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8689 s_scm_truncate_number
);
8693 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8695 "Round the number @var{x} towards the nearest integer. "
8696 "When it is exactly halfway between two integers, "
8697 "round towards the even one.")
8698 #define FUNC_NAME s_scm_round_number
8700 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8702 else if (SCM_REALP (x
))
8703 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8704 else if (SCM_FRACTIONP (x
))
8705 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8706 SCM_FRACTION_DENOMINATOR (x
));
8708 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8709 s_scm_round_number
);
8713 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8715 "Round the number @var{x} towards minus infinity.")
8716 #define FUNC_NAME s_scm_floor
8718 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8720 else if (SCM_REALP (x
))
8721 return scm_i_from_double (floor (SCM_REAL_VALUE (x
)));
8722 else if (SCM_FRACTIONP (x
))
8723 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8724 SCM_FRACTION_DENOMINATOR (x
));
8726 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8730 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8732 "Round the number @var{x} towards infinity.")
8733 #define FUNC_NAME s_scm_ceiling
8735 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8737 else if (SCM_REALP (x
))
8738 return scm_i_from_double (ceil (SCM_REAL_VALUE (x
)));
8739 else if (SCM_FRACTIONP (x
))
8740 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8741 SCM_FRACTION_DENOMINATOR (x
));
8743 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8747 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8749 "Return @var{x} raised to the power of @var{y}.")
8750 #define FUNC_NAME s_scm_expt
8752 if (scm_is_integer (y
))
8754 if (scm_is_true (scm_exact_p (y
)))
8755 return scm_integer_expt (x
, y
);
8758 /* Here we handle the case where the exponent is an inexact
8759 integer. We make the exponent exact in order to use
8760 scm_integer_expt, and thus avoid the spurious imaginary
8761 parts that may result from round-off errors in the general
8762 e^(y log x) method below (for example when squaring a large
8763 negative number). In this case, we must return an inexact
8764 result for correctness. We also make the base inexact so
8765 that scm_integer_expt will use fast inexact arithmetic
8766 internally. Note that making the base inexact is not
8767 sufficient to guarantee an inexact result, because
8768 scm_integer_expt will return an exact 1 when the exponent
8769 is 0, even if the base is inexact. */
8770 return scm_exact_to_inexact
8771 (scm_integer_expt (scm_exact_to_inexact (x
),
8772 scm_inexact_to_exact (y
)));
8775 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8777 return scm_i_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8779 else if (scm_is_complex (x
) && scm_is_complex (y
))
8780 return scm_exp (scm_product (scm_log (x
), y
));
8781 else if (scm_is_complex (x
))
8782 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8784 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8788 /* sin/cos/tan/asin/acos/atan
8789 sinh/cosh/tanh/asinh/acosh/atanh
8790 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8791 Written by Jerry D. Hedden, (C) FSF.
8792 See the file `COPYING' for terms applying to this program. */
8794 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8796 "Compute the sine of @var{z}.")
8797 #define FUNC_NAME s_scm_sin
8799 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8800 return z
; /* sin(exact0) = exact0 */
8801 else if (scm_is_real (z
))
8802 return scm_i_from_double (sin (scm_to_double (z
)));
8803 else if (SCM_COMPLEXP (z
))
8805 x
= SCM_COMPLEX_REAL (z
);
8806 y
= SCM_COMPLEX_IMAG (z
);
8807 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8808 cos (x
) * sinh (y
));
8811 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8815 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8817 "Compute the cosine of @var{z}.")
8818 #define FUNC_NAME s_scm_cos
8820 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8821 return SCM_INUM1
; /* cos(exact0) = exact1 */
8822 else if (scm_is_real (z
))
8823 return scm_i_from_double (cos (scm_to_double (z
)));
8824 else if (SCM_COMPLEXP (z
))
8826 x
= SCM_COMPLEX_REAL (z
);
8827 y
= SCM_COMPLEX_IMAG (z
);
8828 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8829 -sin (x
) * sinh (y
));
8832 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8836 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8838 "Compute the tangent of @var{z}.")
8839 #define FUNC_NAME s_scm_tan
8841 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8842 return z
; /* tan(exact0) = exact0 */
8843 else if (scm_is_real (z
))
8844 return scm_i_from_double (tan (scm_to_double (z
)));
8845 else if (SCM_COMPLEXP (z
))
8847 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8848 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8849 w
= cos (x
) + cosh (y
);
8850 #ifndef ALLOW_DIVIDE_BY_ZERO
8852 scm_num_overflow (s_scm_tan
);
8854 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8857 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8861 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8863 "Compute the hyperbolic sine of @var{z}.")
8864 #define FUNC_NAME s_scm_sinh
8866 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8867 return z
; /* sinh(exact0) = exact0 */
8868 else if (scm_is_real (z
))
8869 return scm_i_from_double (sinh (scm_to_double (z
)));
8870 else if (SCM_COMPLEXP (z
))
8872 x
= SCM_COMPLEX_REAL (z
);
8873 y
= SCM_COMPLEX_IMAG (z
);
8874 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8875 cosh (x
) * sin (y
));
8878 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8882 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8884 "Compute the hyperbolic cosine of @var{z}.")
8885 #define FUNC_NAME s_scm_cosh
8887 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8888 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8889 else if (scm_is_real (z
))
8890 return scm_i_from_double (cosh (scm_to_double (z
)));
8891 else if (SCM_COMPLEXP (z
))
8893 x
= SCM_COMPLEX_REAL (z
);
8894 y
= SCM_COMPLEX_IMAG (z
);
8895 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8896 sinh (x
) * sin (y
));
8899 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8903 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8905 "Compute the hyperbolic tangent of @var{z}.")
8906 #define FUNC_NAME s_scm_tanh
8908 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8909 return z
; /* tanh(exact0) = exact0 */
8910 else if (scm_is_real (z
))
8911 return scm_i_from_double (tanh (scm_to_double (z
)));
8912 else if (SCM_COMPLEXP (z
))
8914 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8915 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8916 w
= cosh (x
) + cos (y
);
8917 #ifndef ALLOW_DIVIDE_BY_ZERO
8919 scm_num_overflow (s_scm_tanh
);
8921 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8924 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8928 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8930 "Compute the arc sine of @var{z}.")
8931 #define FUNC_NAME s_scm_asin
8933 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8934 return z
; /* asin(exact0) = exact0 */
8935 else if (scm_is_real (z
))
8937 double w
= scm_to_double (z
);
8938 if (w
>= -1.0 && w
<= 1.0)
8939 return scm_i_from_double (asin (w
));
8941 return scm_product (scm_c_make_rectangular (0, -1),
8942 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8944 else if (SCM_COMPLEXP (z
))
8946 x
= SCM_COMPLEX_REAL (z
);
8947 y
= SCM_COMPLEX_IMAG (z
);
8948 return scm_product (scm_c_make_rectangular (0, -1),
8949 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8952 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8956 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8958 "Compute the arc cosine of @var{z}.")
8959 #define FUNC_NAME s_scm_acos
8961 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8962 return SCM_INUM0
; /* acos(exact1) = exact0 */
8963 else if (scm_is_real (z
))
8965 double w
= scm_to_double (z
);
8966 if (w
>= -1.0 && w
<= 1.0)
8967 return scm_i_from_double (acos (w
));
8969 return scm_sum (scm_i_from_double (acos (0.0)),
8970 scm_product (scm_c_make_rectangular (0, 1),
8971 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8973 else if (SCM_COMPLEXP (z
))
8975 x
= SCM_COMPLEX_REAL (z
);
8976 y
= SCM_COMPLEX_IMAG (z
);
8977 return scm_sum (scm_i_from_double (acos (0.0)),
8978 scm_product (scm_c_make_rectangular (0, 1),
8979 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8982 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8986 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8988 "With one argument, compute the arc tangent of @var{z}.\n"
8989 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8990 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8991 #define FUNC_NAME s_scm_atan
8995 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8996 return z
; /* atan(exact0) = exact0 */
8997 else if (scm_is_real (z
))
8998 return scm_i_from_double (atan (scm_to_double (z
)));
8999 else if (SCM_COMPLEXP (z
))
9002 v
= SCM_COMPLEX_REAL (z
);
9003 w
= SCM_COMPLEX_IMAG (z
);
9004 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
9005 scm_c_make_rectangular (v
, w
+ 1.0))),
9006 scm_c_make_rectangular (0, 2));
9009 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
9011 else if (scm_is_real (z
))
9013 if (scm_is_real (y
))
9014 return scm_i_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
9016 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
9019 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
9023 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
9025 "Compute the inverse hyperbolic sine of @var{z}.")
9026 #define FUNC_NAME s_scm_sys_asinh
9028 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9029 return z
; /* asinh(exact0) = exact0 */
9030 else if (scm_is_real (z
))
9031 return scm_i_from_double (asinh (scm_to_double (z
)));
9032 else if (scm_is_number (z
))
9033 return scm_log (scm_sum (z
,
9034 scm_sqrt (scm_sum (scm_product (z
, z
),
9037 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
9041 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
9043 "Compute the inverse hyperbolic cosine of @var{z}.")
9044 #define FUNC_NAME s_scm_sys_acosh
9046 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
9047 return SCM_INUM0
; /* acosh(exact1) = exact0 */
9048 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
9049 return scm_i_from_double (acosh (scm_to_double (z
)));
9050 else if (scm_is_number (z
))
9051 return scm_log (scm_sum (z
,
9052 scm_sqrt (scm_difference (scm_product (z
, z
),
9055 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
9059 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
9061 "Compute the inverse hyperbolic tangent of @var{z}.")
9062 #define FUNC_NAME s_scm_sys_atanh
9064 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
9065 return z
; /* atanh(exact0) = exact0 */
9066 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
9067 return scm_i_from_double (atanh (scm_to_double (z
)));
9068 else if (scm_is_number (z
))
9069 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
9070 scm_difference (SCM_INUM1
, z
))),
9073 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
9078 scm_c_make_rectangular (double re
, double im
)
9082 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
9084 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
9085 SCM_COMPLEX_REAL (z
) = re
;
9086 SCM_COMPLEX_IMAG (z
) = im
;
9090 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
9091 (SCM real_part
, SCM imaginary_part
),
9092 "Return a complex number constructed of the given @var{real_part} "
9093 "and @var{imaginary_part} parts.")
9094 #define FUNC_NAME s_scm_make_rectangular
9096 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
9097 SCM_ARG1
, FUNC_NAME
, "real");
9098 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
9099 SCM_ARG2
, FUNC_NAME
, "real");
9101 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9102 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
9105 return scm_c_make_rectangular (scm_to_double (real_part
),
9106 scm_to_double (imaginary_part
));
9111 scm_c_make_polar (double mag
, double ang
)
9115 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9116 use it on Glibc-based systems that have it (it's a GNU extension). See
9117 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9119 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9120 sincos (ang
, &s
, &c
);
9126 /* If s and c are NaNs, this indicates that the angle is a NaN,
9127 infinite, or perhaps simply too large to determine its value
9128 mod 2*pi. However, we know something that the floating-point
9129 implementation doesn't know: We know that s and c are finite.
9130 Therefore, if the magnitude is zero, return a complex zero.
9132 The reason we check for the NaNs instead of using this case
9133 whenever mag == 0.0 is because when the angle is known, we'd
9134 like to return the correct kind of non-real complex zero:
9135 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9136 on which quadrant the angle is in.
9138 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9139 return scm_c_make_rectangular (0.0, 0.0);
9141 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9144 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9146 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9147 #define FUNC_NAME s_scm_make_polar
9149 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9150 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9152 /* If mag is exact0, return exact0 */
9153 if (scm_is_eq (mag
, SCM_INUM0
))
9155 /* Return a real if ang is exact0 */
9156 else if (scm_is_eq (ang
, SCM_INUM0
))
9159 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9164 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9166 "Return the real part of the number @var{z}.")
9167 #define FUNC_NAME s_scm_real_part
9169 if (SCM_COMPLEXP (z
))
9170 return scm_i_from_double (SCM_COMPLEX_REAL (z
));
9171 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9174 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9179 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9181 "Return the imaginary part of the number @var{z}.")
9182 #define FUNC_NAME s_scm_imag_part
9184 if (SCM_COMPLEXP (z
))
9185 return scm_i_from_double (SCM_COMPLEX_IMAG (z
));
9186 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9189 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9193 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9195 "Return the numerator of the number @var{z}.")
9196 #define FUNC_NAME s_scm_numerator
9198 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9200 else if (SCM_FRACTIONP (z
))
9201 return SCM_FRACTION_NUMERATOR (z
);
9202 else if (SCM_REALP (z
))
9204 double zz
= SCM_REAL_VALUE (z
);
9205 if (zz
== floor (zz
))
9206 /* Handle -0.0 and infinities in accordance with R6RS
9207 flnumerator, and optimize handling of integers. */
9210 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9213 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9218 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9220 "Return the denominator of the number @var{z}.")
9221 #define FUNC_NAME s_scm_denominator
9223 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9225 else if (SCM_FRACTIONP (z
))
9226 return SCM_FRACTION_DENOMINATOR (z
);
9227 else if (SCM_REALP (z
))
9229 double zz
= SCM_REAL_VALUE (z
);
9230 if (zz
== floor (zz
))
9231 /* Handle infinities in accordance with R6RS fldenominator, and
9232 optimize handling of integers. */
9233 return scm_i_from_double (1.0);
9235 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9238 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9243 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9245 "Return the magnitude of the number @var{z}. This is the same as\n"
9246 "@code{abs} for real arguments, but also allows complex numbers.")
9247 #define FUNC_NAME s_scm_magnitude
9249 if (SCM_I_INUMP (z
))
9251 scm_t_inum zz
= SCM_I_INUM (z
);
9254 else if (SCM_POSFIXABLE (-zz
))
9255 return SCM_I_MAKINUM (-zz
);
9257 return scm_i_inum2big (-zz
);
9259 else if (SCM_BIGP (z
))
9261 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9262 scm_remember_upto_here_1 (z
);
9264 return scm_i_clonebig (z
, 0);
9268 else if (SCM_REALP (z
))
9269 return scm_i_from_double (fabs (SCM_REAL_VALUE (z
)));
9270 else if (SCM_COMPLEXP (z
))
9271 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9272 else if (SCM_FRACTIONP (z
))
9274 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9276 return scm_i_make_ratio_already_reduced
9277 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9278 SCM_FRACTION_DENOMINATOR (z
));
9281 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9286 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9288 "Return the angle of the complex number @var{z}.")
9289 #define FUNC_NAME s_scm_angle
9291 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9292 flo0 to save allocating a new flonum with scm_i_from_double each time.
9293 But if atan2 follows the floating point rounding mode, then the value
9294 is not a constant. Maybe it'd be close enough though. */
9295 if (SCM_I_INUMP (z
))
9297 if (SCM_I_INUM (z
) >= 0)
9300 return scm_i_from_double (atan2 (0.0, -1.0));
9302 else if (SCM_BIGP (z
))
9304 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9305 scm_remember_upto_here_1 (z
);
9307 return scm_i_from_double (atan2 (0.0, -1.0));
9311 else if (SCM_REALP (z
))
9313 double x
= SCM_REAL_VALUE (z
);
9314 if (copysign (1.0, x
) > 0.0)
9317 return scm_i_from_double (atan2 (0.0, -1.0));
9319 else if (SCM_COMPLEXP (z
))
9320 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9321 else if (SCM_FRACTIONP (z
))
9323 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9325 else return scm_i_from_double (atan2 (0.0, -1.0));
9328 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9333 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9335 "Convert the number @var{z} to its inexact representation.\n")
9336 #define FUNC_NAME s_scm_exact_to_inexact
9338 if (SCM_I_INUMP (z
))
9339 return scm_i_from_double ((double) SCM_I_INUM (z
));
9340 else if (SCM_BIGP (z
))
9341 return scm_i_from_double (scm_i_big2dbl (z
));
9342 else if (SCM_FRACTIONP (z
))
9343 return scm_i_from_double (scm_i_fraction2double (z
));
9344 else if (SCM_INEXACTP (z
))
9347 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9352 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9354 "Return an exact number that is numerically closest to @var{z}.")
9355 #define FUNC_NAME s_scm_inexact_to_exact
9357 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9364 val
= SCM_REAL_VALUE (z
);
9365 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9366 val
= SCM_COMPLEX_REAL (z
);
9368 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9370 if (!SCM_LIKELY (isfinite (val
)))
9371 SCM_OUT_OF_RANGE (1, z
);
9372 else if (val
== 0.0)
9379 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9381 expon
-= DBL_MANT_DIG
;
9384 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9388 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9389 SCM_I_BIG_MPZ (numerator
),
9393 numerator
= scm_i_normbig (numerator
);
9395 return scm_i_make_ratio_already_reduced
9396 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9398 return left_shift_exact_integer (numerator
, expon
);
9406 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9408 "Returns the @emph{simplest} rational number differing\n"
9409 "from @var{x} by no more than @var{eps}.\n"
9411 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9412 "exact result when both its arguments are exact. Thus, you might need\n"
9413 "to use @code{inexact->exact} on the arguments.\n"
9416 "(rationalize (inexact->exact 1.2) 1/100)\n"
9419 #define FUNC_NAME s_scm_rationalize
9421 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9422 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9424 if (SCM_UNLIKELY (!scm_is_exact (eps
) || !scm_is_exact (x
)))
9426 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps
))))
9428 if (scm_is_false (scm_nan_p (eps
)) && scm_is_true (scm_finite_p (x
)))
9433 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x
))))
9436 return scm_exact_to_inexact
9437 (scm_rationalize (scm_inexact_to_exact (x
),
9438 scm_inexact_to_exact (eps
)));
9442 /* X and EPS are exact rationals.
9444 The code that follows is equivalent to the following Scheme code:
9446 (define (exact-rationalize x eps)
9447 (let ((n1 (if (negative? x) -1 1))
9450 (let ((lo (- x eps))
9454 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9455 (nhi (numerator hi)) (dhi (denominator hi))
9456 (n1 n1) (d1 0) (n2 0) (d2 1))
9457 (let-values (((qlo rlo) (floor/ nlo dlo))
9458 ((qhi rhi) (floor/ nhi dhi)))
9459 (let ((n0 (+ n2 (* n1 qlo)))
9460 (d0 (+ d2 (* d1 qlo))))
9461 (cond ((zero? rlo) (/ n0 d0))
9462 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9463 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9469 eps
= scm_abs (eps
);
9470 if (scm_is_true (scm_negative_p (x
)))
9473 x
= scm_difference (x
, SCM_UNDEFINED
);
9476 /* X and EPS are non-negative exact rationals. */
9478 lo
= scm_difference (x
, eps
);
9479 hi
= scm_sum (x
, eps
);
9481 if (scm_is_false (scm_positive_p (lo
)))
9482 /* If zero is included in the interval, return it.
9483 It is the simplest rational of all. */
9488 mpz_t n0
, d0
, n1
, d1
, n2
, d2
;
9489 mpz_t nlo
, dlo
, nhi
, dhi
;
9490 mpz_t qlo
, rlo
, qhi
, rhi
;
9492 /* LO and HI are positive exact rationals. */
9494 /* Our approach here follows the method described by Alan
9495 Bawden in a message entitled "(rationalize x y)" on the
9496 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9498 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9500 In brief, we compute the continued fractions of the two
9501 endpoints of the interval (LO and HI). The continued
9502 fraction of the result consists of the common prefix of the
9503 continued fractions of LO and HI, plus one final term. The
9504 final term of the result is the smallest integer contained
9505 in the interval between the remainders of LO and HI after
9506 the common prefix has been removed.
9508 The following code lazily computes the continued fraction
9509 representations of LO and HI, and simultaneously converts
9510 the continued fraction of the result into a rational
9511 number. We use MPZ functions directly to avoid type
9512 dispatch and GC allocation during the loop. */
9514 mpz_inits (n0
, d0
, n1
, d1
, n2
, d2
,
9519 /* The variables N1, D1, N2 and D2 are used to compute the
9520 resulting rational from its continued fraction. At each
9521 step, N2/D2 and N1/D1 are the last two convergents. They
9522 are normally initialized to 0/1 and 1/0, respectively.
9523 However, if we negated X then we must negate the result as
9524 well, and we do that by initializing N1/D1 to -1/0. */
9525 mpz_set_si (n1
, n1_init
);
9530 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9531 compute the continued fraction representations of LO and HI
9532 using Euclid's algorithm. Initially, NLO/DLO == LO and
9534 scm_to_mpz (scm_numerator (lo
), nlo
);
9535 scm_to_mpz (scm_denominator (lo
), dlo
);
9536 scm_to_mpz (scm_numerator (hi
), nhi
);
9537 scm_to_mpz (scm_denominator (hi
), dhi
);
9539 /* As long as we're using exact arithmetic, the following loop
9540 is guaranteed to terminate. */
9543 /* Compute the next terms (QLO and QHI) of the continued
9544 fractions of LO and HI. */
9545 mpz_fdiv_qr (qlo
, rlo
, nlo
, dlo
); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9546 mpz_fdiv_qr (qhi
, rhi
, nhi
, dhi
); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9548 /* The next term of the result will be either QLO or
9549 QLO+1. Here we compute the next convergent of the
9550 result based on the assumption that QLO is the next
9551 term. If that turns out to be wrong, we'll adjust
9552 these later by adding N1 to N0 and D1 to D0. */
9553 mpz_set (n0
, n2
); mpz_addmul (n0
, n1
, qlo
); /* N0 <-- N2 + (QLO * N1) */
9554 mpz_set (d0
, d2
); mpz_addmul (d0
, d1
, qlo
); /* D0 <-- D2 + (QLO * D1) */
9556 /* We stop iterating when an integer is contained in the
9557 interval between the remainders NLO/DLO and NHI/DHI.
9558 There are two cases to consider: either NLO/DLO == QLO
9559 is an integer (indicated by RLO == 0), or QLO < QHI. */
9560 if (mpz_sgn (rlo
) == 0 || mpz_cmp (qlo
, qhi
) != 0)
9563 /* Efficiently shuffle variables around for the next
9564 iteration. First we shift the recent convergents. */
9565 mpz_swap (n2
, n1
); mpz_swap (n1
, n0
); /* N2 <-- N1 <-- N0 */
9566 mpz_swap (d2
, d1
); mpz_swap (d1
, d0
); /* D2 <-- D1 <-- D0 */
9568 /* The following shuffling is a bit confusing, so some
9569 explanation is in order. Conceptually, we're doing a
9570 couple of things here. After substracting the floor of
9571 NLO/DLO, the remainder is RLO/DLO. The rest of the
9572 continued fraction will represent the remainder's
9573 reciprocal DLO/RLO. Similarly for the HI endpoint.
9574 So in the next iteration, the new endpoints will be
9575 DLO/RLO and DHI/RHI. However, when we take the
9576 reciprocals of these endpoints, their order is
9577 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9578 and NHI/DHI <-- DLO/RLO. */
9579 mpz_swap (nlo
, dhi
); mpz_swap (dhi
, rlo
); /* NLO <-- DHI <-- RLO */
9580 mpz_swap (nhi
, dlo
); mpz_swap (dlo
, rhi
); /* NHI <-- DLO <-- RHI */
9583 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9584 The last term of the result will be the smallest integer in
9585 that interval, which is ceiling(NLO/DLO). We have already
9586 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9587 equal to the ceiling. */
9588 if (mpz_sgn (rlo
) != 0)
9590 /* If RLO is non-zero, then NLO/DLO is not an integer and
9591 the next term will be QLO+1. QLO was used in the
9592 computation of N0 and D0 above. Here we adjust N0 and
9593 D0 to be based on QLO+1 instead of QLO. */
9594 mpz_add (n0
, n0
, n1
); /* N0 <-- N0 + N1 */
9595 mpz_add (d0
, d0
, d1
); /* D0 <-- D0 + D1 */
9598 /* The simplest rational in the interval is N0/D0 */
9599 result
= scm_i_make_ratio_already_reduced (scm_from_mpz (n0
),
9601 mpz_clears (n0
, d0
, n1
, d1
, n2
, d2
,
9611 /* conversion functions */
9614 scm_is_integer (SCM val
)
9616 return scm_is_true (scm_integer_p (val
));
9620 scm_is_exact_integer (SCM val
)
9622 return scm_is_true (scm_exact_integer_p (val
));
9626 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9628 if (SCM_I_INUMP (val
))
9630 scm_t_signed_bits n
= SCM_I_INUM (val
);
9631 return n
>= min
&& n
<= max
;
9633 else if (SCM_BIGP (val
))
9635 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9637 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9639 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9641 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9642 return n
>= min
&& n
<= max
;
9652 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9653 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9656 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9657 SCM_I_BIG_MPZ (val
));
9659 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9671 return n
>= min
&& n
<= max
;
9679 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9681 if (SCM_I_INUMP (val
))
9683 scm_t_signed_bits n
= SCM_I_INUM (val
);
9684 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9686 else if (SCM_BIGP (val
))
9688 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9690 else if (max
<= ULONG_MAX
)
9692 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9694 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9695 return n
>= min
&& n
<= max
;
9705 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9708 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9709 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9712 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9713 SCM_I_BIG_MPZ (val
));
9715 return n
>= min
&& n
<= max
;
9723 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9725 scm_error (scm_out_of_range_key
,
9727 "Value out of range ~S to ~S: ~S",
9728 scm_list_3 (min
, max
, bad_val
),
9729 scm_list_1 (bad_val
));
9732 #define TYPE scm_t_intmax
9733 #define TYPE_MIN min
9734 #define TYPE_MAX max
9735 #define SIZEOF_TYPE 0
9736 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9737 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9738 #include "libguile/conv-integer.i.c"
9740 #define TYPE scm_t_uintmax
9741 #define TYPE_MIN min
9742 #define TYPE_MAX max
9743 #define SIZEOF_TYPE 0
9744 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9745 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9746 #include "libguile/conv-uinteger.i.c"
9748 #define TYPE scm_t_int8
9749 #define TYPE_MIN SCM_T_INT8_MIN
9750 #define TYPE_MAX SCM_T_INT8_MAX
9751 #define SIZEOF_TYPE 1
9752 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9753 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9754 #include "libguile/conv-integer.i.c"
9756 #define TYPE scm_t_uint8
9758 #define TYPE_MAX SCM_T_UINT8_MAX
9759 #define SIZEOF_TYPE 1
9760 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9761 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9762 #include "libguile/conv-uinteger.i.c"
9764 #define TYPE scm_t_int16
9765 #define TYPE_MIN SCM_T_INT16_MIN
9766 #define TYPE_MAX SCM_T_INT16_MAX
9767 #define SIZEOF_TYPE 2
9768 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9769 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9770 #include "libguile/conv-integer.i.c"
9772 #define TYPE scm_t_uint16
9774 #define TYPE_MAX SCM_T_UINT16_MAX
9775 #define SIZEOF_TYPE 2
9776 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9777 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9778 #include "libguile/conv-uinteger.i.c"
9780 #define TYPE scm_t_int32
9781 #define TYPE_MIN SCM_T_INT32_MIN
9782 #define TYPE_MAX SCM_T_INT32_MAX
9783 #define SIZEOF_TYPE 4
9784 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9785 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9786 #include "libguile/conv-integer.i.c"
9788 #define TYPE scm_t_uint32
9790 #define TYPE_MAX SCM_T_UINT32_MAX
9791 #define SIZEOF_TYPE 4
9792 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9793 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9794 #include "libguile/conv-uinteger.i.c"
9796 #define TYPE scm_t_wchar
9797 #define TYPE_MIN (scm_t_int32)-1
9798 #define TYPE_MAX (scm_t_int32)0x10ffff
9799 #define SIZEOF_TYPE 4
9800 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9801 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9802 #include "libguile/conv-integer.i.c"
9804 #define TYPE scm_t_int64
9805 #define TYPE_MIN SCM_T_INT64_MIN
9806 #define TYPE_MAX SCM_T_INT64_MAX
9807 #define SIZEOF_TYPE 8
9808 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9809 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9810 #include "libguile/conv-integer.i.c"
9812 #define TYPE scm_t_uint64
9814 #define TYPE_MAX SCM_T_UINT64_MAX
9815 #define SIZEOF_TYPE 8
9816 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9817 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9818 #include "libguile/conv-uinteger.i.c"
9821 scm_to_mpz (SCM val
, mpz_t rop
)
9823 if (SCM_I_INUMP (val
))
9824 mpz_set_si (rop
, SCM_I_INUM (val
));
9825 else if (SCM_BIGP (val
))
9826 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9828 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9832 scm_from_mpz (mpz_t val
)
9834 return scm_i_mpz2num (val
);
9838 scm_is_real (SCM val
)
9840 return scm_is_true (scm_real_p (val
));
9844 scm_is_rational (SCM val
)
9846 return scm_is_true (scm_rational_p (val
));
9850 scm_to_double (SCM val
)
9852 if (SCM_I_INUMP (val
))
9853 return SCM_I_INUM (val
);
9854 else if (SCM_BIGP (val
))
9855 return scm_i_big2dbl (val
);
9856 else if (SCM_FRACTIONP (val
))
9857 return scm_i_fraction2double (val
);
9858 else if (SCM_REALP (val
))
9859 return SCM_REAL_VALUE (val
);
9861 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9865 scm_from_double (double val
)
9867 return scm_i_from_double (val
);
9870 #if SCM_ENABLE_DEPRECATED == 1
9873 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9875 scm_c_issue_deprecation_warning
9876 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9880 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9884 scm_out_of_range (NULL
, num
);
9887 return scm_to_double (num
);
9891 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9893 scm_c_issue_deprecation_warning
9894 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9898 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9902 scm_out_of_range (NULL
, num
);
9905 return scm_to_double (num
);
9911 scm_is_complex (SCM val
)
9913 return scm_is_true (scm_complex_p (val
));
9917 scm_c_real_part (SCM z
)
9919 if (SCM_COMPLEXP (z
))
9920 return SCM_COMPLEX_REAL (z
);
9923 /* Use the scm_real_part to get proper error checking and
9926 return scm_to_double (scm_real_part (z
));
9931 scm_c_imag_part (SCM z
)
9933 if (SCM_COMPLEXP (z
))
9934 return SCM_COMPLEX_IMAG (z
);
9937 /* Use the scm_imag_part to get proper error checking and
9938 dispatching. The result will almost always be 0.0, but not
9941 return scm_to_double (scm_imag_part (z
));
9946 scm_c_magnitude (SCM z
)
9948 return scm_to_double (scm_magnitude (z
));
9954 return scm_to_double (scm_angle (z
));
9958 scm_is_number (SCM z
)
9960 return scm_is_true (scm_number_p (z
));
9964 /* Returns log(x * 2^shift) */
9966 log_of_shifted_double (double x
, long shift
)
9968 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9970 if (copysign (1.0, x
) > 0.0)
9971 return scm_i_from_double (ans
);
9973 return scm_c_make_rectangular (ans
, M_PI
);
9976 /* Returns log(n), for exact integer n */
9978 log_of_exact_integer (SCM n
)
9980 if (SCM_I_INUMP (n
))
9981 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9982 else if (SCM_BIGP (n
))
9985 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9986 return log_of_shifted_double (signif
, expon
);
9989 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9992 /* Returns log(n/d), for exact non-zero integers n and d */
9994 log_of_fraction (SCM n
, SCM d
)
9996 long n_size
= scm_to_long (scm_integer_length (n
));
9997 long d_size
= scm_to_long (scm_integer_length (d
));
9999 if (abs (n_size
- d_size
) > 1)
10000 return (scm_difference (log_of_exact_integer (n
),
10001 log_of_exact_integer (d
)));
10002 else if (scm_is_false (scm_negative_p (n
)))
10003 return scm_i_from_double
10004 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
10006 return scm_c_make_rectangular
10007 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
10013 /* In the following functions we dispatch to the real-arg funcs like log()
10014 when we know the arg is real, instead of just handing everything to
10015 clog() for instance. This is in case clog() doesn't optimize for a
10016 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
10017 well use it to go straight to the applicable C func. */
10019 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
10021 "Return the natural logarithm of @var{z}.")
10022 #define FUNC_NAME s_scm_log
10024 if (SCM_COMPLEXP (z
))
10026 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
10027 && defined (SCM_COMPLEX_VALUE)
10028 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
10030 double re
= SCM_COMPLEX_REAL (z
);
10031 double im
= SCM_COMPLEX_IMAG (z
);
10032 return scm_c_make_rectangular (log (hypot (re
, im
)),
10036 else if (SCM_REALP (z
))
10037 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
10038 else if (SCM_I_INUMP (z
))
10040 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10041 if (scm_is_eq (z
, SCM_INUM0
))
10042 scm_num_overflow (s_scm_log
);
10044 return log_of_shifted_double (SCM_I_INUM (z
), 0);
10046 else if (SCM_BIGP (z
))
10047 return log_of_exact_integer (z
);
10048 else if (SCM_FRACTIONP (z
))
10049 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10050 SCM_FRACTION_DENOMINATOR (z
));
10052 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
10057 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
10059 "Return the base 10 logarithm of @var{z}.")
10060 #define FUNC_NAME s_scm_log10
10062 if (SCM_COMPLEXP (z
))
10064 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10065 clog() and a multiply by M_LOG10E, rather than the fallback
10066 log10+hypot+atan2.) */
10067 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10068 && defined SCM_COMPLEX_VALUE
10069 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
10071 double re
= SCM_COMPLEX_REAL (z
);
10072 double im
= SCM_COMPLEX_IMAG (z
);
10073 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
10074 M_LOG10E
* atan2 (im
, re
));
10077 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
10079 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10080 if (scm_is_eq (z
, SCM_INUM0
))
10081 scm_num_overflow (s_scm_log10
);
10084 double re
= scm_to_double (z
);
10085 double l
= log10 (fabs (re
));
10086 if (copysign (1.0, re
) > 0.0)
10087 return scm_i_from_double (l
);
10089 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
10092 else if (SCM_BIGP (z
))
10093 return scm_product (flo_log10e
, log_of_exact_integer (z
));
10094 else if (SCM_FRACTIONP (z
))
10095 return scm_product (flo_log10e
,
10096 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
10097 SCM_FRACTION_DENOMINATOR (z
)));
10099 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
10104 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
10106 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10107 "base of natural logarithms (2.71828@dots{}).")
10108 #define FUNC_NAME s_scm_exp
10110 if (SCM_COMPLEXP (z
))
10112 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10113 && defined (SCM_COMPLEX_VALUE)
10114 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
10116 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
10117 SCM_COMPLEX_IMAG (z
));
10120 else if (SCM_NUMBERP (z
))
10122 /* When z is a negative bignum the conversion to double overflows,
10123 giving -infinity, but that's ok, the exp is still 0.0. */
10124 return scm_i_from_double (exp (scm_to_double (z
)));
10127 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
10132 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
10134 "Return two exact non-negative integers @var{s} and @var{r}\n"
10135 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10136 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10137 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10140 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10142 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10146 scm_exact_integer_sqrt (k
, &s
, &r
);
10147 return scm_values (scm_list_2 (s
, r
));
10152 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
10154 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10158 if (SCM_I_INUM (k
) < 0)
10159 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10160 "exact non-negative integer");
10161 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10162 mpz_inits (ss
, rr
, NULL
);
10163 mpz_sqrtrem (ss
, rr
, kk
);
10164 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
10165 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
10166 mpz_clears (kk
, ss
, rr
, NULL
);
10168 else if (SCM_LIKELY (SCM_BIGP (k
)))
10172 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
10173 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10174 "exact non-negative integer");
10175 s
= scm_i_mkbig ();
10176 r
= scm_i_mkbig ();
10177 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
10178 scm_remember_upto_here_1 (k
);
10179 *sp
= scm_i_normbig (s
);
10180 *rp
= scm_i_normbig (r
);
10183 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
10184 "exact non-negative integer");
10187 /* Return true iff K is a perfect square.
10188 K must be an exact integer. */
10190 exact_integer_is_perfect_square (SCM k
)
10194 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10198 mpz_init_set_si (kk
, SCM_I_INUM (k
));
10199 result
= mpz_perfect_square_p (kk
);
10204 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
10205 scm_remember_upto_here_1 (k
);
10210 /* Return the floor of the square root of K.
10211 K must be an exact integer. */
10213 exact_integer_floor_square_root (SCM k
)
10215 if (SCM_LIKELY (SCM_I_INUMP (k
)))
10220 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
10222 ss
= mpz_get_ui (kk
);
10224 return SCM_I_MAKINUM (ss
);
10230 s
= scm_i_mkbig ();
10231 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
10232 scm_remember_upto_here_1 (k
);
10233 return scm_i_normbig (s
);
10238 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
10240 "Return the square root of @var{z}. Of the two possible roots\n"
10241 "(positive and negative), the one with positive real part\n"
10242 "is returned, or if that's zero then a positive imaginary part.\n"
10246 "(sqrt 9.0) @result{} 3.0\n"
10247 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10248 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10249 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10251 #define FUNC_NAME s_scm_sqrt
10253 if (SCM_COMPLEXP (z
))
10255 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10256 && defined SCM_COMPLEX_VALUE
10257 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10259 double re
= SCM_COMPLEX_REAL (z
);
10260 double im
= SCM_COMPLEX_IMAG (z
);
10261 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10262 0.5 * atan2 (im
, re
));
10265 else if (SCM_NUMBERP (z
))
10267 if (SCM_I_INUMP (z
))
10269 scm_t_inum x
= SCM_I_INUM (z
);
10271 if (SCM_LIKELY (x
>= 0))
10273 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10274 || x
< (1L << (DBL_MANT_DIG
- 1))))
10276 double root
= sqrt (x
);
10278 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10279 integer, then the result is exact. */
10280 if (root
== floor (root
))
10281 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10283 return scm_i_from_double (root
);
10290 mpz_init_set_ui (xx
, x
);
10291 if (mpz_perfect_square_p (xx
))
10294 root
= mpz_get_ui (xx
);
10296 return SCM_I_MAKINUM (root
);
10303 else if (SCM_BIGP (z
))
10305 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10307 SCM root
= scm_i_mkbig ();
10309 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10310 scm_remember_upto_here_1 (z
);
10311 return scm_i_normbig (root
);
10316 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10324 return scm_c_make_rectangular
10325 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10327 return scm_i_from_double (ldexp (sqrt (signif
), expon
/ 2));
10330 else if (SCM_FRACTIONP (z
))
10332 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10333 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10335 if (exact_integer_is_perfect_square (n
)
10336 && exact_integer_is_perfect_square (d
))
10337 return scm_i_make_ratio_already_reduced
10338 (exact_integer_floor_square_root (n
),
10339 exact_integer_floor_square_root (d
));
10342 double xx
= scm_i_divide2double (n
, d
);
10343 double abs_xx
= fabs (xx
);
10346 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10348 shift
= (scm_to_long (scm_integer_length (n
))
10349 - scm_to_long (scm_integer_length (d
))) / 2;
10351 d
= left_shift_exact_integer (d
, 2 * shift
);
10353 n
= left_shift_exact_integer (n
, -2 * shift
);
10354 xx
= scm_i_divide2double (n
, d
);
10358 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10360 return scm_i_from_double (ldexp (sqrt (xx
), shift
));
10364 /* Fallback method, when the cases above do not apply. */
10366 double xx
= scm_to_double (z
);
10368 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10370 return scm_i_from_double (sqrt (xx
));
10374 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10381 scm_init_numbers ()
10383 if (scm_install_gmp_memory_functions
)
10384 mp_set_memory_functions (custom_gmp_malloc
,
10385 custom_gmp_realloc
,
10388 mpz_init_set_si (z_negative_one
, -1);
10390 /* It may be possible to tune the performance of some algorithms by using
10391 * the following constants to avoid the creation of bignums. Please, before
10392 * using these values, remember the two rules of program optimization:
10393 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10394 scm_c_define ("most-positive-fixnum",
10395 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10396 scm_c_define ("most-negative-fixnum",
10397 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10399 scm_add_feature ("complex");
10400 scm_add_feature ("inexact");
10401 flo0
= scm_i_from_double (0.0);
10402 flo_log10e
= scm_i_from_double (M_LOG10E
);
10404 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10407 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10408 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10409 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10410 scm_i_divide2double_lo2b
,
10411 DBL_MANT_DIG
+ 1); /* 2 b^p */
10412 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10416 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10417 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10418 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10419 dbl_minimum_normal_mantissa
,
10423 #include "libguile/numbers.x"
10428 c-file-style: "gnu"