1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 /* FIXME: We assume that FLT_RADIX is 2 */
85 verify (FLT_RADIX
== 2);
87 typedef scm_t_signed_bits scm_t_inum
;
88 #define scm_from_inum(x) (scm_from_signed_integer (x))
90 /* Tests to see if a C double is neither infinite nor a NaN.
91 TODO: if it's available, use C99's isfinite(x) instead */
92 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
94 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
95 of the infinity, but other platforms return a boolean only. */
96 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
97 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
102 Wonder if this might be faster for some of our code? A switch on
103 the numtag would jump directly to the right case, and the
104 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
106 #define SCM_I_NUMTAG_NOTNUM 0
107 #define SCM_I_NUMTAG_INUM 1
108 #define SCM_I_NUMTAG_BIG scm_tc16_big
109 #define SCM_I_NUMTAG_REAL scm_tc16_real
110 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
111 #define SCM_I_NUMTAG(x) \
112 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
113 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
114 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
115 : SCM_I_NUMTAG_NOTNUM)))
117 /* the macro above will not work as is with fractions */
120 /* Default to 1, because as we used to hard-code `free' as the
121 deallocator, we know that overriding these functions with
122 instrumented `malloc' / `free' is OK. */
123 int scm_install_gmp_memory_functions
= 1;
125 static SCM exactly_one_half
;
126 static SCM flo_log10e
;
128 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
130 /* FLOBUFLEN is the maximum number of characters neccessary for the
131 * printed or scm_string representation of an inexact number.
133 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
136 #if !defined (HAVE_ASINH)
137 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
139 #if !defined (HAVE_ACOSH)
140 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
142 #if !defined (HAVE_ATANH)
143 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
146 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
147 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
148 in March 2006), mpz_cmp_d now handles infinities properly. */
150 #define xmpz_cmp_d(z, d) \
151 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
153 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
157 #if defined (GUILE_I)
158 #if defined HAVE_COMPLEX_DOUBLE
160 /* For an SCM object Z which is a complex number (ie. satisfies
161 SCM_COMPLEXP), return its value as a C level "complex double". */
162 #define SCM_COMPLEX_VALUE(z) \
163 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
165 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
167 /* Convert a C "complex double" to an SCM value. */
169 scm_from_complex_double (complex double z
)
171 return scm_c_make_rectangular (creal (z
), cimag (z
));
174 #endif /* HAVE_COMPLEX_DOUBLE */
179 static mpz_t z_negative_one
;
183 /* Clear the `mpz_t' embedded in bignum PTR. */
185 finalize_bignum (void *ptr
, void *data
)
189 bignum
= PTR2SCM (ptr
);
190 mpz_clear (SCM_I_BIG_MPZ (bignum
));
193 /* The next three functions (custom_libgmp_*) are passed to
194 mp_set_memory_functions (in GMP) so that memory used by the digits
195 themselves is known to the garbage collector. This is needed so
196 that GC will be run at appropriate times. Otherwise, a program which
197 creates many large bignums would malloc a huge amount of memory
198 before the GC runs. */
200 custom_gmp_malloc (size_t alloc_size
)
202 return scm_malloc (alloc_size
);
206 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
208 return scm_realloc (old_ptr
, new_size
);
212 custom_gmp_free (void *ptr
, size_t size
)
218 /* Return a new uninitialized bignum. */
224 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
225 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
229 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
238 /* Return a newly created bignum. */
239 SCM z
= make_bignum ();
240 mpz_init (SCM_I_BIG_MPZ (z
));
245 scm_i_inum2big (scm_t_inum x
)
247 /* Return a newly created bignum initialized to X. */
248 SCM z
= make_bignum ();
249 #if SIZEOF_VOID_P == SIZEOF_LONG
250 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
252 /* Note that in this case, you'll also have to check all mpz_*_ui and
253 mpz_*_si invocations in Guile. */
254 #error creation of mpz not implemented for this inum size
260 scm_i_long2big (long x
)
262 /* Return a newly created bignum initialized to X. */
263 SCM z
= make_bignum ();
264 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
269 scm_i_ulong2big (unsigned long x
)
271 /* Return a newly created bignum initialized to X. */
272 SCM z
= make_bignum ();
273 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
278 scm_i_clonebig (SCM src_big
, int same_sign_p
)
280 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
281 SCM z
= make_bignum ();
282 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
284 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
289 scm_i_bigcmp (SCM x
, SCM y
)
291 /* Return neg if x < y, pos if x > y, and 0 if x == y */
292 /* presume we already know x and y are bignums */
293 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
294 scm_remember_upto_here_2 (x
, y
);
299 scm_i_dbl2big (double d
)
301 /* results are only defined if d is an integer */
302 SCM z
= make_bignum ();
303 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
307 /* Convert a integer in double representation to a SCM number. */
310 scm_i_dbl2num (double u
)
312 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
313 powers of 2, so there's no rounding when making "double" values
314 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
315 get rounded on a 64-bit machine, hence the "+1".
317 The use of floor() to force to an integer value ensures we get a
318 "numerically closest" value without depending on how a
319 double->long cast or how mpz_set_d will round. For reference,
320 double->long probably follows the hardware rounding mode,
321 mpz_set_d truncates towards zero. */
323 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
324 representable as a double? */
326 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
327 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
328 return SCM_I_MAKINUM ((scm_t_inum
) u
);
330 return scm_i_dbl2big (u
);
333 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
335 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
336 bignum b into a normalized significand and exponent such that
337 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
338 The return value is the significand rounded to the closest
339 representable double, and the exponent is placed into *expon_p.
340 If b is zero, then the returned exponent and significand are both
344 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
346 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
349 if (bits
> DBL_MANT_DIG
)
351 shift
= bits
- DBL_MANT_DIG
;
352 b
= round_right_shift_exact_integer (b
, shift
);
356 double signif
= frexp (SCM_I_INUM (b
), &expon
);
357 *expon_p
= expon
+ shift
;
364 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
365 scm_remember_upto_here_1 (b
);
366 *expon_p
= expon
+ shift
;
371 /* scm_i_big2dbl() rounds to the closest representable double,
372 in accordance with R5RS exact->inexact. */
374 scm_i_big2dbl (SCM b
)
377 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
378 return ldexp (signif
, expon
);
382 scm_i_normbig (SCM b
)
384 /* convert a big back to a fixnum if it'll fit */
385 /* presume b is a bignum */
386 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
388 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
389 if (SCM_FIXABLE (val
))
390 b
= SCM_I_MAKINUM (val
);
395 static SCM_C_INLINE_KEYWORD SCM
396 scm_i_mpz2num (mpz_t b
)
398 /* convert a mpz number to a SCM number. */
399 if (mpz_fits_slong_p (b
))
401 scm_t_inum val
= mpz_get_si (b
);
402 if (SCM_FIXABLE (val
))
403 return SCM_I_MAKINUM (val
);
407 SCM z
= make_bignum ();
408 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
413 /* Make the ratio NUMERATOR/DENOMINATOR, where:
414 1. NUMERATOR and DENOMINATOR are exact integers
415 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
417 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
419 /* Flip signs so that the denominator is positive. */
420 if (scm_is_false (scm_positive_p (denominator
)))
422 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
423 scm_num_overflow ("make-ratio");
426 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
427 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
431 /* Check for the integer case */
432 if (scm_is_eq (denominator
, SCM_INUM1
))
435 return scm_double_cell (scm_tc16_fraction
,
436 SCM_UNPACK (numerator
),
437 SCM_UNPACK (denominator
), 0);
440 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
442 /* Make the ratio NUMERATOR/DENOMINATOR */
444 scm_i_make_ratio (SCM numerator
, SCM denominator
)
445 #define FUNC_NAME "make-ratio"
447 /* Make sure the arguments are proper */
448 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
449 SCM_WRONG_TYPE_ARG (1, numerator
);
450 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
451 SCM_WRONG_TYPE_ARG (2, denominator
);
454 SCM the_gcd
= scm_gcd (numerator
, denominator
);
455 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
457 /* Reduce to lowest terms */
458 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
459 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
461 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
466 static mpz_t scm_i_divide2double_lo2b
;
468 /* Return the double that is closest to the exact rational N/D, with
469 ties rounded toward even mantissas. N and D must be exact
472 scm_i_divide2double (SCM n
, SCM d
)
475 mpz_t nn
, dd
, lo
, hi
, x
;
480 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
482 if (scm_is_true (scm_positive_p (n
)))
484 else if (scm_is_true (scm_negative_p (n
)))
489 mpz_init_set_si (dd
, SCM_I_INUM (d
));
492 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
495 mpz_init_set_si (nn
, SCM_I_INUM (n
));
497 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
499 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
503 /* Now we need to find the value of e such that:
506 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
507 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
508 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
511 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
512 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
513 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
515 where: p = DBL_MANT_DIG
516 b = FLT_RADIX (here assumed to be 2)
518 After rounding, the mantissa must be an integer between b^{p-1} and
519 (b^p - 1), except for subnormal numbers. In the inequations [1A]
520 and [1B], the middle expression represents the mantissa *before*
521 rounding, and therefore is bounded by the range of values that will
522 round to a floating-point number with the exponent e. The upper
523 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
524 ties will round up to the next power of b. The lower bound is
525 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
526 this power of b. Here we subtract 1/2b instead of 1/2 because it
527 is in the range of the next smaller exponent, where the
528 representable numbers are closer together by a factor of b.
530 Inequations [2A] and [2B] are derived from [1A] and [1B] by
531 multiplying by 2b, and in [3A] and [3B] we multiply by the
532 denominator of the middle value to obtain integer expressions.
534 In the code below, we refer to the three expressions in [3A] or
535 [3B] as lo, x, and hi. If the number is normalizable, we will
536 achieve the goal: lo <= x < hi */
538 /* Make an initial guess for e */
539 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
540 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
541 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
543 /* Compute the initial values of lo, x, and hi
544 based on the initial guess of e */
545 mpz_inits (lo
, hi
, x
, NULL
);
546 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
547 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
549 mpz_mul_2exp (lo
, lo
, e
);
550 mpz_mul_2exp (hi
, lo
, 1);
552 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
553 (but without making e less then the minimum exponent) */
554 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
556 mpz_mul_2exp (x
, x
, 1);
559 while (mpz_cmp (x
, hi
) >= 0)
561 /* If we ever used lo's value again,
562 we would need to double lo here. */
563 mpz_mul_2exp (hi
, hi
, 1);
567 /* Now compute the rounded mantissa:
568 n / b^e d (if e >= 0)
569 n b^-e / d (if e <= 0) */
575 mpz_mul_2exp (nn
, nn
, -e
);
577 mpz_mul_2exp (dd
, dd
, e
);
579 /* mpz does not directly support rounded right
580 shifts, so we have to do it the hard way.
581 For efficiency, we reuse lo and hi.
582 hi == quotient, lo == remainder */
583 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
585 /* The fractional part of the unrounded mantissa would be
586 remainder/dividend, i.e. lo/dd. So we have a tie if
587 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
588 integer expression 2*lo = dd. Here we do that comparison
589 to decide whether to round up or down. */
590 mpz_mul_2exp (lo
, lo
, 1);
591 cmp
= mpz_cmp (lo
, dd
);
592 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
593 mpz_add_ui (hi
, hi
, 1);
595 result
= ldexp (mpz_get_d (hi
), e
);
599 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
605 scm_i_fraction2double (SCM z
)
607 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
608 SCM_FRACTION_DENOMINATOR (z
));
612 double_is_non_negative_zero (double x
)
614 static double zero
= 0.0;
616 return !memcmp (&x
, &zero
, sizeof(double));
619 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
621 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
623 #define FUNC_NAME s_scm_exact_p
625 if (SCM_INEXACTP (x
))
627 else if (SCM_NUMBERP (x
))
630 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
635 scm_is_exact (SCM val
)
637 return scm_is_true (scm_exact_p (val
));
640 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
642 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
644 #define FUNC_NAME s_scm_inexact_p
646 if (SCM_INEXACTP (x
))
648 else if (SCM_NUMBERP (x
))
651 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
656 scm_is_inexact (SCM val
)
658 return scm_is_true (scm_inexact_p (val
));
661 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
663 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
665 #define FUNC_NAME s_scm_odd_p
669 scm_t_inum val
= SCM_I_INUM (n
);
670 return scm_from_bool ((val
& 1L) != 0);
672 else if (SCM_BIGP (n
))
674 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
675 scm_remember_upto_here_1 (n
);
676 return scm_from_bool (odd_p
);
678 else if (SCM_REALP (n
))
680 double val
= SCM_REAL_VALUE (n
);
681 if (DOUBLE_IS_FINITE (val
))
683 double rem
= fabs (fmod (val
, 2.0));
690 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
695 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
697 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
699 #define FUNC_NAME s_scm_even_p
703 scm_t_inum val
= SCM_I_INUM (n
);
704 return scm_from_bool ((val
& 1L) == 0);
706 else if (SCM_BIGP (n
))
708 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
709 scm_remember_upto_here_1 (n
);
710 return scm_from_bool (even_p
);
712 else if (SCM_REALP (n
))
714 double val
= SCM_REAL_VALUE (n
);
715 if (DOUBLE_IS_FINITE (val
))
717 double rem
= fabs (fmod (val
, 2.0));
724 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
728 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
730 "Return @code{#t} if the real number @var{x} is neither\n"
731 "infinite nor a NaN, @code{#f} otherwise.")
732 #define FUNC_NAME s_scm_finite_p
735 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
736 else if (scm_is_real (x
))
739 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
743 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
745 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
746 "@samp{-inf.0}. Otherwise return @code{#f}.")
747 #define FUNC_NAME s_scm_inf_p
750 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
751 else if (scm_is_real (x
))
754 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
758 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
760 "Return @code{#t} if the real number @var{x} is a NaN,\n"
761 "or @code{#f} otherwise.")
762 #define FUNC_NAME s_scm_nan_p
765 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
766 else if (scm_is_real (x
))
769 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
773 /* Guile's idea of infinity. */
774 static double guile_Inf
;
776 /* Guile's idea of not a number. */
777 static double guile_NaN
;
780 guile_ieee_init (void)
782 /* Some version of gcc on some old version of Linux used to crash when
783 trying to make Inf and NaN. */
786 /* C99 INFINITY, when available.
787 FIXME: The standard allows for INFINITY to be something that overflows
788 at compile time. We ought to have a configure test to check for that
789 before trying to use it. (But in practice we believe this is not a
790 problem on any system guile is likely to target.) */
791 guile_Inf
= INFINITY
;
792 #elif defined HAVE_DINFINITY
794 extern unsigned int DINFINITY
[2];
795 guile_Inf
= (*((double *) (DINFINITY
)));
802 if (guile_Inf
== tmp
)
809 /* C99 NAN, when available */
811 #elif defined HAVE_DQNAN
814 extern unsigned int DQNAN
[2];
815 guile_NaN
= (*((double *)(DQNAN
)));
818 guile_NaN
= guile_Inf
/ guile_Inf
;
822 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
825 #define FUNC_NAME s_scm_inf
827 static int initialized
= 0;
833 return scm_from_double (guile_Inf
);
837 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
840 #define FUNC_NAME s_scm_nan
842 static int initialized
= 0;
848 return scm_from_double (guile_NaN
);
853 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
855 "Return the absolute value of @var{x}.")
856 #define FUNC_NAME s_scm_abs
860 scm_t_inum xx
= SCM_I_INUM (x
);
863 else if (SCM_POSFIXABLE (-xx
))
864 return SCM_I_MAKINUM (-xx
);
866 return scm_i_inum2big (-xx
);
868 else if (SCM_LIKELY (SCM_REALP (x
)))
870 double xx
= SCM_REAL_VALUE (x
);
871 /* If x is a NaN then xx<0 is false so we return x unchanged */
873 return scm_from_double (-xx
);
874 /* Handle signed zeroes properly */
875 else if (SCM_UNLIKELY (xx
== 0.0))
880 else if (SCM_BIGP (x
))
882 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
884 return scm_i_clonebig (x
, 0);
888 else if (SCM_FRACTIONP (x
))
890 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
892 return scm_i_make_ratio_already_reduced
893 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
894 SCM_FRACTION_DENOMINATOR (x
));
897 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
902 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
904 "Return the quotient of the numbers @var{x} and @var{y}.")
905 #define FUNC_NAME s_scm_quotient
907 if (SCM_LIKELY (scm_is_integer (x
)))
909 if (SCM_LIKELY (scm_is_integer (y
)))
910 return scm_truncate_quotient (x
, y
);
912 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
915 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
919 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
921 "Return the remainder of the numbers @var{x} and @var{y}.\n"
923 "(remainder 13 4) @result{} 1\n"
924 "(remainder -13 4) @result{} -1\n"
926 #define FUNC_NAME s_scm_remainder
928 if (SCM_LIKELY (scm_is_integer (x
)))
930 if (SCM_LIKELY (scm_is_integer (y
)))
931 return scm_truncate_remainder (x
, y
);
933 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
936 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
941 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
943 "Return the modulo of the numbers @var{x} and @var{y}.\n"
945 "(modulo 13 4) @result{} 1\n"
946 "(modulo -13 4) @result{} 3\n"
948 #define FUNC_NAME s_scm_modulo
950 if (SCM_LIKELY (scm_is_integer (x
)))
952 if (SCM_LIKELY (scm_is_integer (y
)))
953 return scm_floor_remainder (x
, y
);
955 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
958 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
962 /* Return the exact integer q such that n = q*d, for exact integers n
963 and d, where d is known in advance to divide n evenly (with zero
964 remainder). For large integers, this can be computed more
965 efficiently than when the remainder is unknown. */
967 scm_exact_integer_quotient (SCM n
, SCM d
)
968 #define FUNC_NAME "exact-integer-quotient"
970 if (SCM_LIKELY (SCM_I_INUMP (n
)))
972 scm_t_inum nn
= SCM_I_INUM (n
);
973 if (SCM_LIKELY (SCM_I_INUMP (d
)))
975 scm_t_inum dd
= SCM_I_INUM (d
);
976 if (SCM_UNLIKELY (dd
== 0))
977 scm_num_overflow ("exact-integer-quotient");
980 scm_t_inum qq
= nn
/ dd
;
981 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
982 return SCM_I_MAKINUM (qq
);
984 return scm_i_inum2big (qq
);
987 else if (SCM_LIKELY (SCM_BIGP (d
)))
989 /* n is an inum and d is a bignum. Given that d is known to
990 divide n evenly, there are only two possibilities: n is 0,
991 or else n is fixnum-min and d is abs(fixnum-min). */
995 return SCM_I_MAKINUM (-1);
998 SCM_WRONG_TYPE_ARG (2, d
);
1000 else if (SCM_LIKELY (SCM_BIGP (n
)))
1002 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1004 scm_t_inum dd
= SCM_I_INUM (d
);
1005 if (SCM_UNLIKELY (dd
== 0))
1006 scm_num_overflow ("exact-integer-quotient");
1007 else if (SCM_UNLIKELY (dd
== 1))
1011 SCM q
= scm_i_mkbig ();
1013 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1016 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1017 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1019 scm_remember_upto_here_1 (n
);
1020 return scm_i_normbig (q
);
1023 else if (SCM_LIKELY (SCM_BIGP (d
)))
1025 SCM q
= scm_i_mkbig ();
1026 mpz_divexact (SCM_I_BIG_MPZ (q
),
1029 scm_remember_upto_here_2 (n
, d
);
1030 return scm_i_normbig (q
);
1033 SCM_WRONG_TYPE_ARG (2, d
);
1036 SCM_WRONG_TYPE_ARG (1, n
);
1040 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1041 two-valued functions. It is called from primitive generics that take
1042 two arguments and return two values, when the core procedure is
1043 unable to handle the given argument types. If there are GOOPS
1044 methods for this primitive generic, it dispatches to GOOPS and, if
1045 successful, expects two values to be returned, which are placed in
1046 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1047 wrong-type-arg exception.
1049 FIXME: This obviously belongs somewhere else, but until we decide on
1050 the right API, it is here as a static function, because it is needed
1051 by the *_divide functions below.
1054 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1055 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1057 if (SCM_UNPACK (gf
))
1058 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
1060 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1063 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1065 "Return the integer @var{q} such that\n"
1066 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1067 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1069 "(euclidean-quotient 123 10) @result{} 12\n"
1070 "(euclidean-quotient 123 -10) @result{} -12\n"
1071 "(euclidean-quotient -123 10) @result{} -13\n"
1072 "(euclidean-quotient -123 -10) @result{} 13\n"
1073 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1074 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1076 #define FUNC_NAME s_scm_euclidean_quotient
1078 if (scm_is_false (scm_negative_p (y
)))
1079 return scm_floor_quotient (x
, y
);
1081 return scm_ceiling_quotient (x
, y
);
1085 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1087 "Return the real number @var{r} such that\n"
1088 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1089 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1090 "for some integer @var{q}.\n"
1092 "(euclidean-remainder 123 10) @result{} 3\n"
1093 "(euclidean-remainder 123 -10) @result{} 3\n"
1094 "(euclidean-remainder -123 10) @result{} 7\n"
1095 "(euclidean-remainder -123 -10) @result{} 7\n"
1096 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1097 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1099 #define FUNC_NAME s_scm_euclidean_remainder
1101 if (scm_is_false (scm_negative_p (y
)))
1102 return scm_floor_remainder (x
, y
);
1104 return scm_ceiling_remainder (x
, y
);
1108 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1110 "Return the integer @var{q} and the real number @var{r}\n"
1111 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1112 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1114 "(euclidean/ 123 10) @result{} 12 and 3\n"
1115 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1116 "(euclidean/ -123 10) @result{} -13 and 7\n"
1117 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1118 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1119 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1121 #define FUNC_NAME s_scm_i_euclidean_divide
1123 if (scm_is_false (scm_negative_p (y
)))
1124 return scm_i_floor_divide (x
, y
);
1126 return scm_i_ceiling_divide (x
, y
);
1131 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1133 if (scm_is_false (scm_negative_p (y
)))
1134 return scm_floor_divide (x
, y
, qp
, rp
);
1136 return scm_ceiling_divide (x
, y
, qp
, rp
);
1139 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1140 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1142 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1144 "Return the floor of @math{@var{x} / @var{y}}.\n"
1146 "(floor-quotient 123 10) @result{} 12\n"
1147 "(floor-quotient 123 -10) @result{} -13\n"
1148 "(floor-quotient -123 10) @result{} -13\n"
1149 "(floor-quotient -123 -10) @result{} 12\n"
1150 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1151 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1153 #define FUNC_NAME s_scm_floor_quotient
1155 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1157 scm_t_inum xx
= SCM_I_INUM (x
);
1158 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1160 scm_t_inum yy
= SCM_I_INUM (y
);
1161 scm_t_inum xx1
= xx
;
1163 if (SCM_LIKELY (yy
> 0))
1165 if (SCM_UNLIKELY (xx
< 0))
1168 else if (SCM_UNLIKELY (yy
== 0))
1169 scm_num_overflow (s_scm_floor_quotient
);
1173 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1174 return SCM_I_MAKINUM (qq
);
1176 return scm_i_inum2big (qq
);
1178 else if (SCM_BIGP (y
))
1180 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1181 scm_remember_upto_here_1 (y
);
1183 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1185 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1187 else if (SCM_REALP (y
))
1188 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1189 else if (SCM_FRACTIONP (y
))
1190 return scm_i_exact_rational_floor_quotient (x
, y
);
1192 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1193 s_scm_floor_quotient
);
1195 else if (SCM_BIGP (x
))
1197 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1199 scm_t_inum yy
= SCM_I_INUM (y
);
1200 if (SCM_UNLIKELY (yy
== 0))
1201 scm_num_overflow (s_scm_floor_quotient
);
1202 else if (SCM_UNLIKELY (yy
== 1))
1206 SCM q
= scm_i_mkbig ();
1208 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1211 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1212 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1214 scm_remember_upto_here_1 (x
);
1215 return scm_i_normbig (q
);
1218 else if (SCM_BIGP (y
))
1220 SCM q
= scm_i_mkbig ();
1221 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1224 scm_remember_upto_here_2 (x
, y
);
1225 return scm_i_normbig (q
);
1227 else if (SCM_REALP (y
))
1228 return scm_i_inexact_floor_quotient
1229 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1230 else if (SCM_FRACTIONP (y
))
1231 return scm_i_exact_rational_floor_quotient (x
, y
);
1233 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1234 s_scm_floor_quotient
);
1236 else if (SCM_REALP (x
))
1238 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1239 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1240 return scm_i_inexact_floor_quotient
1241 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1243 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1244 s_scm_floor_quotient
);
1246 else if (SCM_FRACTIONP (x
))
1249 return scm_i_inexact_floor_quotient
1250 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1251 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1252 return scm_i_exact_rational_floor_quotient (x
, y
);
1254 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1255 s_scm_floor_quotient
);
1258 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1259 s_scm_floor_quotient
);
1264 scm_i_inexact_floor_quotient (double x
, double y
)
1266 if (SCM_UNLIKELY (y
== 0))
1267 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1269 return scm_from_double (floor (x
/ y
));
1273 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1275 return scm_floor_quotient
1276 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1277 scm_product (scm_numerator (y
), scm_denominator (x
)));
1280 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1281 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1283 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1285 "Return the real number @var{r} such that\n"
1286 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1287 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1289 "(floor-remainder 123 10) @result{} 3\n"
1290 "(floor-remainder 123 -10) @result{} -7\n"
1291 "(floor-remainder -123 10) @result{} 7\n"
1292 "(floor-remainder -123 -10) @result{} -3\n"
1293 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1294 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1296 #define FUNC_NAME s_scm_floor_remainder
1298 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1300 scm_t_inum xx
= SCM_I_INUM (x
);
1301 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1303 scm_t_inum yy
= SCM_I_INUM (y
);
1304 if (SCM_UNLIKELY (yy
== 0))
1305 scm_num_overflow (s_scm_floor_remainder
);
1308 scm_t_inum rr
= xx
% yy
;
1309 int needs_adjustment
;
1311 if (SCM_LIKELY (yy
> 0))
1312 needs_adjustment
= (rr
< 0);
1314 needs_adjustment
= (rr
> 0);
1316 if (needs_adjustment
)
1318 return SCM_I_MAKINUM (rr
);
1321 else if (SCM_BIGP (y
))
1323 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1324 scm_remember_upto_here_1 (y
);
1329 SCM r
= scm_i_mkbig ();
1330 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1331 scm_remember_upto_here_1 (y
);
1332 return scm_i_normbig (r
);
1341 SCM r
= scm_i_mkbig ();
1342 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1343 scm_remember_upto_here_1 (y
);
1344 return scm_i_normbig (r
);
1347 else if (SCM_REALP (y
))
1348 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1349 else if (SCM_FRACTIONP (y
))
1350 return scm_i_exact_rational_floor_remainder (x
, y
);
1352 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1353 s_scm_floor_remainder
);
1355 else if (SCM_BIGP (x
))
1357 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1359 scm_t_inum yy
= SCM_I_INUM (y
);
1360 if (SCM_UNLIKELY (yy
== 0))
1361 scm_num_overflow (s_scm_floor_remainder
);
1366 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1368 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1369 scm_remember_upto_here_1 (x
);
1370 return SCM_I_MAKINUM (rr
);
1373 else if (SCM_BIGP (y
))
1375 SCM r
= scm_i_mkbig ();
1376 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1379 scm_remember_upto_here_2 (x
, y
);
1380 return scm_i_normbig (r
);
1382 else if (SCM_REALP (y
))
1383 return scm_i_inexact_floor_remainder
1384 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1385 else if (SCM_FRACTIONP (y
))
1386 return scm_i_exact_rational_floor_remainder (x
, y
);
1388 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1389 s_scm_floor_remainder
);
1391 else if (SCM_REALP (x
))
1393 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1394 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1395 return scm_i_inexact_floor_remainder
1396 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1398 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1399 s_scm_floor_remainder
);
1401 else if (SCM_FRACTIONP (x
))
1404 return scm_i_inexact_floor_remainder
1405 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1406 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1407 return scm_i_exact_rational_floor_remainder (x
, y
);
1409 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1410 s_scm_floor_remainder
);
1413 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1414 s_scm_floor_remainder
);
1419 scm_i_inexact_floor_remainder (double x
, double y
)
1421 /* Although it would be more efficient to use fmod here, we can't
1422 because it would in some cases produce results inconsistent with
1423 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1424 close). In particular, when x is very close to a multiple of y,
1425 then r might be either 0.0 or y, but those two cases must
1426 correspond to different choices of q. If r = 0.0 then q must be
1427 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1428 and remainder chooses the other, it would be bad. */
1429 if (SCM_UNLIKELY (y
== 0))
1430 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1432 return scm_from_double (x
- y
* floor (x
/ y
));
1436 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1438 SCM xd
= scm_denominator (x
);
1439 SCM yd
= scm_denominator (y
);
1440 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1441 scm_product (scm_numerator (y
), xd
));
1442 return scm_divide (r1
, scm_product (xd
, yd
));
1446 static void scm_i_inexact_floor_divide (double x
, double y
,
1448 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1451 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1453 "Return the integer @var{q} and the real number @var{r}\n"
1454 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1455 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1457 "(floor/ 123 10) @result{} 12 and 3\n"
1458 "(floor/ 123 -10) @result{} -13 and -7\n"
1459 "(floor/ -123 10) @result{} -13 and 7\n"
1460 "(floor/ -123 -10) @result{} 12 and -3\n"
1461 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1462 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1464 #define FUNC_NAME s_scm_i_floor_divide
1468 scm_floor_divide(x
, y
, &q
, &r
);
1469 return scm_values (scm_list_2 (q
, r
));
1473 #define s_scm_floor_divide s_scm_i_floor_divide
1474 #define g_scm_floor_divide g_scm_i_floor_divide
1477 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1479 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1481 scm_t_inum xx
= SCM_I_INUM (x
);
1482 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1484 scm_t_inum yy
= SCM_I_INUM (y
);
1485 if (SCM_UNLIKELY (yy
== 0))
1486 scm_num_overflow (s_scm_floor_divide
);
1489 scm_t_inum qq
= xx
/ yy
;
1490 scm_t_inum rr
= xx
% yy
;
1491 int needs_adjustment
;
1493 if (SCM_LIKELY (yy
> 0))
1494 needs_adjustment
= (rr
< 0);
1496 needs_adjustment
= (rr
> 0);
1498 if (needs_adjustment
)
1504 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1505 *qp
= SCM_I_MAKINUM (qq
);
1507 *qp
= scm_i_inum2big (qq
);
1508 *rp
= SCM_I_MAKINUM (rr
);
1512 else if (SCM_BIGP (y
))
1514 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1515 scm_remember_upto_here_1 (y
);
1520 SCM r
= scm_i_mkbig ();
1521 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1522 scm_remember_upto_here_1 (y
);
1523 *qp
= SCM_I_MAKINUM (-1);
1524 *rp
= scm_i_normbig (r
);
1539 SCM r
= scm_i_mkbig ();
1540 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1541 scm_remember_upto_here_1 (y
);
1542 *qp
= SCM_I_MAKINUM (-1);
1543 *rp
= scm_i_normbig (r
);
1547 else if (SCM_REALP (y
))
1548 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1549 else if (SCM_FRACTIONP (y
))
1550 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1552 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1553 s_scm_floor_divide
, qp
, rp
);
1555 else if (SCM_BIGP (x
))
1557 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1559 scm_t_inum yy
= SCM_I_INUM (y
);
1560 if (SCM_UNLIKELY (yy
== 0))
1561 scm_num_overflow (s_scm_floor_divide
);
1564 SCM q
= scm_i_mkbig ();
1565 SCM r
= scm_i_mkbig ();
1567 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1568 SCM_I_BIG_MPZ (x
), yy
);
1571 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1572 SCM_I_BIG_MPZ (x
), -yy
);
1573 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1575 scm_remember_upto_here_1 (x
);
1576 *qp
= scm_i_normbig (q
);
1577 *rp
= scm_i_normbig (r
);
1581 else if (SCM_BIGP (y
))
1583 SCM q
= scm_i_mkbig ();
1584 SCM r
= scm_i_mkbig ();
1585 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1586 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1587 scm_remember_upto_here_2 (x
, y
);
1588 *qp
= scm_i_normbig (q
);
1589 *rp
= scm_i_normbig (r
);
1592 else if (SCM_REALP (y
))
1593 return scm_i_inexact_floor_divide
1594 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1595 else if (SCM_FRACTIONP (y
))
1596 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1598 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1599 s_scm_floor_divide
, qp
, rp
);
1601 else if (SCM_REALP (x
))
1603 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1604 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1605 return scm_i_inexact_floor_divide
1606 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1608 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1609 s_scm_floor_divide
, qp
, rp
);
1611 else if (SCM_FRACTIONP (x
))
1614 return scm_i_inexact_floor_divide
1615 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1616 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1617 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1619 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1620 s_scm_floor_divide
, qp
, rp
);
1623 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1624 s_scm_floor_divide
, qp
, rp
);
1628 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1630 if (SCM_UNLIKELY (y
== 0))
1631 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1634 double q
= floor (x
/ y
);
1635 double r
= x
- q
* y
;
1636 *qp
= scm_from_double (q
);
1637 *rp
= scm_from_double (r
);
1642 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1645 SCM xd
= scm_denominator (x
);
1646 SCM yd
= scm_denominator (y
);
1648 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1649 scm_product (scm_numerator (y
), xd
),
1651 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1654 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1655 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1657 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1659 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1661 "(ceiling-quotient 123 10) @result{} 13\n"
1662 "(ceiling-quotient 123 -10) @result{} -12\n"
1663 "(ceiling-quotient -123 10) @result{} -12\n"
1664 "(ceiling-quotient -123 -10) @result{} 13\n"
1665 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1666 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1668 #define FUNC_NAME s_scm_ceiling_quotient
1670 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1672 scm_t_inum xx
= SCM_I_INUM (x
);
1673 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1675 scm_t_inum yy
= SCM_I_INUM (y
);
1676 if (SCM_UNLIKELY (yy
== 0))
1677 scm_num_overflow (s_scm_ceiling_quotient
);
1680 scm_t_inum xx1
= xx
;
1682 if (SCM_LIKELY (yy
> 0))
1684 if (SCM_LIKELY (xx
>= 0))
1690 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1691 return SCM_I_MAKINUM (qq
);
1693 return scm_i_inum2big (qq
);
1696 else if (SCM_BIGP (y
))
1698 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1699 scm_remember_upto_here_1 (y
);
1700 if (SCM_LIKELY (sign
> 0))
1702 if (SCM_LIKELY (xx
> 0))
1704 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1705 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1706 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1708 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1709 scm_remember_upto_here_1 (y
);
1710 return SCM_I_MAKINUM (-1);
1720 else if (SCM_REALP (y
))
1721 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1722 else if (SCM_FRACTIONP (y
))
1723 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1725 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1726 s_scm_ceiling_quotient
);
1728 else if (SCM_BIGP (x
))
1730 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1732 scm_t_inum yy
= SCM_I_INUM (y
);
1733 if (SCM_UNLIKELY (yy
== 0))
1734 scm_num_overflow (s_scm_ceiling_quotient
);
1735 else if (SCM_UNLIKELY (yy
== 1))
1739 SCM q
= scm_i_mkbig ();
1741 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1744 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1745 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1747 scm_remember_upto_here_1 (x
);
1748 return scm_i_normbig (q
);
1751 else if (SCM_BIGP (y
))
1753 SCM q
= scm_i_mkbig ();
1754 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1757 scm_remember_upto_here_2 (x
, y
);
1758 return scm_i_normbig (q
);
1760 else if (SCM_REALP (y
))
1761 return scm_i_inexact_ceiling_quotient
1762 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1763 else if (SCM_FRACTIONP (y
))
1764 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1766 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1767 s_scm_ceiling_quotient
);
1769 else if (SCM_REALP (x
))
1771 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1772 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1773 return scm_i_inexact_ceiling_quotient
1774 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1776 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1777 s_scm_ceiling_quotient
);
1779 else if (SCM_FRACTIONP (x
))
1782 return scm_i_inexact_ceiling_quotient
1783 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1784 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1785 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1787 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1788 s_scm_ceiling_quotient
);
1791 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1792 s_scm_ceiling_quotient
);
1797 scm_i_inexact_ceiling_quotient (double x
, double y
)
1799 if (SCM_UNLIKELY (y
== 0))
1800 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1802 return scm_from_double (ceil (x
/ y
));
1806 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1808 return scm_ceiling_quotient
1809 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1810 scm_product (scm_numerator (y
), scm_denominator (x
)));
1813 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1814 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1816 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1818 "Return the real number @var{r} such that\n"
1819 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1820 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1822 "(ceiling-remainder 123 10) @result{} -7\n"
1823 "(ceiling-remainder 123 -10) @result{} 3\n"
1824 "(ceiling-remainder -123 10) @result{} -3\n"
1825 "(ceiling-remainder -123 -10) @result{} 7\n"
1826 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1827 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1829 #define FUNC_NAME s_scm_ceiling_remainder
1831 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1833 scm_t_inum xx
= SCM_I_INUM (x
);
1834 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1836 scm_t_inum yy
= SCM_I_INUM (y
);
1837 if (SCM_UNLIKELY (yy
== 0))
1838 scm_num_overflow (s_scm_ceiling_remainder
);
1841 scm_t_inum rr
= xx
% yy
;
1842 int needs_adjustment
;
1844 if (SCM_LIKELY (yy
> 0))
1845 needs_adjustment
= (rr
> 0);
1847 needs_adjustment
= (rr
< 0);
1849 if (needs_adjustment
)
1851 return SCM_I_MAKINUM (rr
);
1854 else if (SCM_BIGP (y
))
1856 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1857 scm_remember_upto_here_1 (y
);
1858 if (SCM_LIKELY (sign
> 0))
1860 if (SCM_LIKELY (xx
> 0))
1862 SCM r
= scm_i_mkbig ();
1863 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1864 scm_remember_upto_here_1 (y
);
1865 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1866 return scm_i_normbig (r
);
1868 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1869 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1870 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1872 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1873 scm_remember_upto_here_1 (y
);
1883 SCM r
= scm_i_mkbig ();
1884 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1885 scm_remember_upto_here_1 (y
);
1886 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1887 return scm_i_normbig (r
);
1890 else if (SCM_REALP (y
))
1891 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1892 else if (SCM_FRACTIONP (y
))
1893 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1895 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1896 s_scm_ceiling_remainder
);
1898 else if (SCM_BIGP (x
))
1900 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1902 scm_t_inum yy
= SCM_I_INUM (y
);
1903 if (SCM_UNLIKELY (yy
== 0))
1904 scm_num_overflow (s_scm_ceiling_remainder
);
1909 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1911 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1912 scm_remember_upto_here_1 (x
);
1913 return SCM_I_MAKINUM (rr
);
1916 else if (SCM_BIGP (y
))
1918 SCM r
= scm_i_mkbig ();
1919 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1922 scm_remember_upto_here_2 (x
, y
);
1923 return scm_i_normbig (r
);
1925 else if (SCM_REALP (y
))
1926 return scm_i_inexact_ceiling_remainder
1927 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1928 else if (SCM_FRACTIONP (y
))
1929 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1931 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1932 s_scm_ceiling_remainder
);
1934 else if (SCM_REALP (x
))
1936 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1937 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1938 return scm_i_inexact_ceiling_remainder
1939 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1941 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1942 s_scm_ceiling_remainder
);
1944 else if (SCM_FRACTIONP (x
))
1947 return scm_i_inexact_ceiling_remainder
1948 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1949 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1950 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1952 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1953 s_scm_ceiling_remainder
);
1956 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1957 s_scm_ceiling_remainder
);
1962 scm_i_inexact_ceiling_remainder (double x
, double y
)
1964 /* Although it would be more efficient to use fmod here, we can't
1965 because it would in some cases produce results inconsistent with
1966 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1967 close). In particular, when x is very close to a multiple of y,
1968 then r might be either 0.0 or -y, but those two cases must
1969 correspond to different choices of q. If r = 0.0 then q must be
1970 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1971 and remainder chooses the other, it would be bad. */
1972 if (SCM_UNLIKELY (y
== 0))
1973 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1975 return scm_from_double (x
- y
* ceil (x
/ y
));
1979 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1981 SCM xd
= scm_denominator (x
);
1982 SCM yd
= scm_denominator (y
);
1983 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1984 scm_product (scm_numerator (y
), xd
));
1985 return scm_divide (r1
, scm_product (xd
, yd
));
1988 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1990 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1993 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1995 "Return the integer @var{q} and the real number @var{r}\n"
1996 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1997 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1999 "(ceiling/ 123 10) @result{} 13 and -7\n"
2000 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2001 "(ceiling/ -123 10) @result{} -12 and -3\n"
2002 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2003 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2004 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2006 #define FUNC_NAME s_scm_i_ceiling_divide
2010 scm_ceiling_divide(x
, y
, &q
, &r
);
2011 return scm_values (scm_list_2 (q
, r
));
2015 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2016 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2019 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2021 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2023 scm_t_inum xx
= SCM_I_INUM (x
);
2024 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2026 scm_t_inum yy
= SCM_I_INUM (y
);
2027 if (SCM_UNLIKELY (yy
== 0))
2028 scm_num_overflow (s_scm_ceiling_divide
);
2031 scm_t_inum qq
= xx
/ yy
;
2032 scm_t_inum rr
= xx
% yy
;
2033 int needs_adjustment
;
2035 if (SCM_LIKELY (yy
> 0))
2036 needs_adjustment
= (rr
> 0);
2038 needs_adjustment
= (rr
< 0);
2040 if (needs_adjustment
)
2045 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2046 *qp
= SCM_I_MAKINUM (qq
);
2048 *qp
= scm_i_inum2big (qq
);
2049 *rp
= SCM_I_MAKINUM (rr
);
2053 else if (SCM_BIGP (y
))
2055 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2056 scm_remember_upto_here_1 (y
);
2057 if (SCM_LIKELY (sign
> 0))
2059 if (SCM_LIKELY (xx
> 0))
2061 SCM r
= scm_i_mkbig ();
2062 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2063 scm_remember_upto_here_1 (y
);
2064 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2066 *rp
= scm_i_normbig (r
);
2068 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2069 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2070 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2072 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2073 scm_remember_upto_here_1 (y
);
2074 *qp
= SCM_I_MAKINUM (-1);
2090 SCM r
= scm_i_mkbig ();
2091 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2092 scm_remember_upto_here_1 (y
);
2093 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2095 *rp
= scm_i_normbig (r
);
2099 else if (SCM_REALP (y
))
2100 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2101 else if (SCM_FRACTIONP (y
))
2102 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2104 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2105 s_scm_ceiling_divide
, qp
, rp
);
2107 else if (SCM_BIGP (x
))
2109 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2111 scm_t_inum yy
= SCM_I_INUM (y
);
2112 if (SCM_UNLIKELY (yy
== 0))
2113 scm_num_overflow (s_scm_ceiling_divide
);
2116 SCM q
= scm_i_mkbig ();
2117 SCM r
= scm_i_mkbig ();
2119 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2120 SCM_I_BIG_MPZ (x
), yy
);
2123 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2124 SCM_I_BIG_MPZ (x
), -yy
);
2125 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2127 scm_remember_upto_here_1 (x
);
2128 *qp
= scm_i_normbig (q
);
2129 *rp
= scm_i_normbig (r
);
2133 else if (SCM_BIGP (y
))
2135 SCM q
= scm_i_mkbig ();
2136 SCM r
= scm_i_mkbig ();
2137 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2138 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2139 scm_remember_upto_here_2 (x
, y
);
2140 *qp
= scm_i_normbig (q
);
2141 *rp
= scm_i_normbig (r
);
2144 else if (SCM_REALP (y
))
2145 return scm_i_inexact_ceiling_divide
2146 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2147 else if (SCM_FRACTIONP (y
))
2148 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2150 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2151 s_scm_ceiling_divide
, qp
, rp
);
2153 else if (SCM_REALP (x
))
2155 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2156 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2157 return scm_i_inexact_ceiling_divide
2158 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2160 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2161 s_scm_ceiling_divide
, qp
, rp
);
2163 else if (SCM_FRACTIONP (x
))
2166 return scm_i_inexact_ceiling_divide
2167 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2168 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2169 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2171 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2172 s_scm_ceiling_divide
, qp
, rp
);
2175 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2176 s_scm_ceiling_divide
, qp
, rp
);
2180 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2182 if (SCM_UNLIKELY (y
== 0))
2183 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2186 double q
= ceil (x
/ y
);
2187 double r
= x
- q
* y
;
2188 *qp
= scm_from_double (q
);
2189 *rp
= scm_from_double (r
);
2194 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2197 SCM xd
= scm_denominator (x
);
2198 SCM yd
= scm_denominator (y
);
2200 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2201 scm_product (scm_numerator (y
), xd
),
2203 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2206 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2207 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2209 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2211 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2213 "(truncate-quotient 123 10) @result{} 12\n"
2214 "(truncate-quotient 123 -10) @result{} -12\n"
2215 "(truncate-quotient -123 10) @result{} -12\n"
2216 "(truncate-quotient -123 -10) @result{} 12\n"
2217 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2218 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2220 #define FUNC_NAME s_scm_truncate_quotient
2222 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2224 scm_t_inum xx
= SCM_I_INUM (x
);
2225 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2227 scm_t_inum yy
= SCM_I_INUM (y
);
2228 if (SCM_UNLIKELY (yy
== 0))
2229 scm_num_overflow (s_scm_truncate_quotient
);
2232 scm_t_inum qq
= xx
/ yy
;
2233 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2234 return SCM_I_MAKINUM (qq
);
2236 return scm_i_inum2big (qq
);
2239 else if (SCM_BIGP (y
))
2241 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2242 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2243 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2245 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2246 scm_remember_upto_here_1 (y
);
2247 return SCM_I_MAKINUM (-1);
2252 else if (SCM_REALP (y
))
2253 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2254 else if (SCM_FRACTIONP (y
))
2255 return scm_i_exact_rational_truncate_quotient (x
, y
);
2257 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2258 s_scm_truncate_quotient
);
2260 else if (SCM_BIGP (x
))
2262 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2264 scm_t_inum yy
= SCM_I_INUM (y
);
2265 if (SCM_UNLIKELY (yy
== 0))
2266 scm_num_overflow (s_scm_truncate_quotient
);
2267 else if (SCM_UNLIKELY (yy
== 1))
2271 SCM q
= scm_i_mkbig ();
2273 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2276 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2277 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2279 scm_remember_upto_here_1 (x
);
2280 return scm_i_normbig (q
);
2283 else if (SCM_BIGP (y
))
2285 SCM q
= scm_i_mkbig ();
2286 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2289 scm_remember_upto_here_2 (x
, y
);
2290 return scm_i_normbig (q
);
2292 else if (SCM_REALP (y
))
2293 return scm_i_inexact_truncate_quotient
2294 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2295 else if (SCM_FRACTIONP (y
))
2296 return scm_i_exact_rational_truncate_quotient (x
, y
);
2298 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2299 s_scm_truncate_quotient
);
2301 else if (SCM_REALP (x
))
2303 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2304 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2305 return scm_i_inexact_truncate_quotient
2306 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2308 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2309 s_scm_truncate_quotient
);
2311 else if (SCM_FRACTIONP (x
))
2314 return scm_i_inexact_truncate_quotient
2315 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2316 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2317 return scm_i_exact_rational_truncate_quotient (x
, y
);
2319 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2320 s_scm_truncate_quotient
);
2323 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2324 s_scm_truncate_quotient
);
2329 scm_i_inexact_truncate_quotient (double x
, double y
)
2331 if (SCM_UNLIKELY (y
== 0))
2332 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2334 return scm_from_double (trunc (x
/ y
));
2338 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2340 return scm_truncate_quotient
2341 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2342 scm_product (scm_numerator (y
), scm_denominator (x
)));
2345 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2346 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2348 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2350 "Return the real number @var{r} such that\n"
2351 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2352 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2354 "(truncate-remainder 123 10) @result{} 3\n"
2355 "(truncate-remainder 123 -10) @result{} 3\n"
2356 "(truncate-remainder -123 10) @result{} -3\n"
2357 "(truncate-remainder -123 -10) @result{} -3\n"
2358 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2359 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2361 #define FUNC_NAME s_scm_truncate_remainder
2363 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2365 scm_t_inum xx
= SCM_I_INUM (x
);
2366 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2368 scm_t_inum yy
= SCM_I_INUM (y
);
2369 if (SCM_UNLIKELY (yy
== 0))
2370 scm_num_overflow (s_scm_truncate_remainder
);
2372 return SCM_I_MAKINUM (xx
% yy
);
2374 else if (SCM_BIGP (y
))
2376 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2377 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2378 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2380 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2381 scm_remember_upto_here_1 (y
);
2387 else if (SCM_REALP (y
))
2388 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2389 else if (SCM_FRACTIONP (y
))
2390 return scm_i_exact_rational_truncate_remainder (x
, y
);
2392 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2393 s_scm_truncate_remainder
);
2395 else if (SCM_BIGP (x
))
2397 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2399 scm_t_inum yy
= SCM_I_INUM (y
);
2400 if (SCM_UNLIKELY (yy
== 0))
2401 scm_num_overflow (s_scm_truncate_remainder
);
2404 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2405 (yy
> 0) ? yy
: -yy
)
2406 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2407 scm_remember_upto_here_1 (x
);
2408 return SCM_I_MAKINUM (rr
);
2411 else if (SCM_BIGP (y
))
2413 SCM r
= scm_i_mkbig ();
2414 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2417 scm_remember_upto_here_2 (x
, y
);
2418 return scm_i_normbig (r
);
2420 else if (SCM_REALP (y
))
2421 return scm_i_inexact_truncate_remainder
2422 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2423 else if (SCM_FRACTIONP (y
))
2424 return scm_i_exact_rational_truncate_remainder (x
, y
);
2426 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2427 s_scm_truncate_remainder
);
2429 else if (SCM_REALP (x
))
2431 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2432 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2433 return scm_i_inexact_truncate_remainder
2434 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2436 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2437 s_scm_truncate_remainder
);
2439 else if (SCM_FRACTIONP (x
))
2442 return scm_i_inexact_truncate_remainder
2443 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2444 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2445 return scm_i_exact_rational_truncate_remainder (x
, y
);
2447 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2448 s_scm_truncate_remainder
);
2451 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2452 s_scm_truncate_remainder
);
2457 scm_i_inexact_truncate_remainder (double x
, double y
)
2459 /* Although it would be more efficient to use fmod here, we can't
2460 because it would in some cases produce results inconsistent with
2461 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2462 close). In particular, when x is very close to a multiple of y,
2463 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2464 correspond to different choices of q. If quotient chooses one and
2465 remainder chooses the other, it would be bad. */
2466 if (SCM_UNLIKELY (y
== 0))
2467 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2469 return scm_from_double (x
- y
* trunc (x
/ y
));
2473 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2475 SCM xd
= scm_denominator (x
);
2476 SCM yd
= scm_denominator (y
);
2477 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2478 scm_product (scm_numerator (y
), xd
));
2479 return scm_divide (r1
, scm_product (xd
, yd
));
2483 static void scm_i_inexact_truncate_divide (double x
, double y
,
2485 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2488 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2490 "Return the integer @var{q} and the real number @var{r}\n"
2491 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2492 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2494 "(truncate/ 123 10) @result{} 12 and 3\n"
2495 "(truncate/ 123 -10) @result{} -12 and 3\n"
2496 "(truncate/ -123 10) @result{} -12 and -3\n"
2497 "(truncate/ -123 -10) @result{} 12 and -3\n"
2498 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2499 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2501 #define FUNC_NAME s_scm_i_truncate_divide
2505 scm_truncate_divide(x
, y
, &q
, &r
);
2506 return scm_values (scm_list_2 (q
, r
));
2510 #define s_scm_truncate_divide s_scm_i_truncate_divide
2511 #define g_scm_truncate_divide g_scm_i_truncate_divide
2514 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2516 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2518 scm_t_inum xx
= SCM_I_INUM (x
);
2519 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2521 scm_t_inum yy
= SCM_I_INUM (y
);
2522 if (SCM_UNLIKELY (yy
== 0))
2523 scm_num_overflow (s_scm_truncate_divide
);
2526 scm_t_inum qq
= xx
/ yy
;
2527 scm_t_inum rr
= xx
% yy
;
2528 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2529 *qp
= SCM_I_MAKINUM (qq
);
2531 *qp
= scm_i_inum2big (qq
);
2532 *rp
= SCM_I_MAKINUM (rr
);
2536 else if (SCM_BIGP (y
))
2538 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2539 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2540 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2542 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2543 scm_remember_upto_here_1 (y
);
2544 *qp
= SCM_I_MAKINUM (-1);
2554 else if (SCM_REALP (y
))
2555 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2556 else if (SCM_FRACTIONP (y
))
2557 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2559 return two_valued_wta_dispatch_2
2560 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2561 s_scm_truncate_divide
, qp
, rp
);
2563 else if (SCM_BIGP (x
))
2565 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2567 scm_t_inum yy
= SCM_I_INUM (y
);
2568 if (SCM_UNLIKELY (yy
== 0))
2569 scm_num_overflow (s_scm_truncate_divide
);
2572 SCM q
= scm_i_mkbig ();
2575 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2576 SCM_I_BIG_MPZ (x
), yy
);
2579 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2580 SCM_I_BIG_MPZ (x
), -yy
);
2581 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2583 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2584 scm_remember_upto_here_1 (x
);
2585 *qp
= scm_i_normbig (q
);
2586 *rp
= SCM_I_MAKINUM (rr
);
2590 else if (SCM_BIGP (y
))
2592 SCM q
= scm_i_mkbig ();
2593 SCM r
= scm_i_mkbig ();
2594 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2595 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2596 scm_remember_upto_here_2 (x
, y
);
2597 *qp
= scm_i_normbig (q
);
2598 *rp
= scm_i_normbig (r
);
2600 else if (SCM_REALP (y
))
2601 return scm_i_inexact_truncate_divide
2602 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2603 else if (SCM_FRACTIONP (y
))
2604 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2606 return two_valued_wta_dispatch_2
2607 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2608 s_scm_truncate_divide
, qp
, rp
);
2610 else if (SCM_REALP (x
))
2612 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2613 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2614 return scm_i_inexact_truncate_divide
2615 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2617 return two_valued_wta_dispatch_2
2618 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2619 s_scm_truncate_divide
, qp
, rp
);
2621 else if (SCM_FRACTIONP (x
))
2624 return scm_i_inexact_truncate_divide
2625 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2626 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2627 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2629 return two_valued_wta_dispatch_2
2630 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2631 s_scm_truncate_divide
, qp
, rp
);
2634 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2635 s_scm_truncate_divide
, qp
, rp
);
2639 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2641 if (SCM_UNLIKELY (y
== 0))
2642 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2645 double q
= trunc (x
/ y
);
2646 double r
= x
- q
* y
;
2647 *qp
= scm_from_double (q
);
2648 *rp
= scm_from_double (r
);
2653 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2656 SCM xd
= scm_denominator (x
);
2657 SCM yd
= scm_denominator (y
);
2659 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2660 scm_product (scm_numerator (y
), xd
),
2662 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2665 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2666 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2667 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2669 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2671 "Return the integer @var{q} such that\n"
2672 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2673 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2675 "(centered-quotient 123 10) @result{} 12\n"
2676 "(centered-quotient 123 -10) @result{} -12\n"
2677 "(centered-quotient -123 10) @result{} -12\n"
2678 "(centered-quotient -123 -10) @result{} 12\n"
2679 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2680 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2682 #define FUNC_NAME s_scm_centered_quotient
2684 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2686 scm_t_inum xx
= SCM_I_INUM (x
);
2687 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2689 scm_t_inum yy
= SCM_I_INUM (y
);
2690 if (SCM_UNLIKELY (yy
== 0))
2691 scm_num_overflow (s_scm_centered_quotient
);
2694 scm_t_inum qq
= xx
/ yy
;
2695 scm_t_inum rr
= xx
% yy
;
2696 if (SCM_LIKELY (xx
> 0))
2698 if (SCM_LIKELY (yy
> 0))
2700 if (rr
>= (yy
+ 1) / 2)
2705 if (rr
>= (1 - yy
) / 2)
2711 if (SCM_LIKELY (yy
> 0))
2722 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2723 return SCM_I_MAKINUM (qq
);
2725 return scm_i_inum2big (qq
);
2728 else if (SCM_BIGP (y
))
2730 /* Pass a denormalized bignum version of x (even though it
2731 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2732 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2734 else if (SCM_REALP (y
))
2735 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2736 else if (SCM_FRACTIONP (y
))
2737 return scm_i_exact_rational_centered_quotient (x
, y
);
2739 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2740 s_scm_centered_quotient
);
2742 else if (SCM_BIGP (x
))
2744 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2746 scm_t_inum yy
= SCM_I_INUM (y
);
2747 if (SCM_UNLIKELY (yy
== 0))
2748 scm_num_overflow (s_scm_centered_quotient
);
2749 else if (SCM_UNLIKELY (yy
== 1))
2753 SCM q
= scm_i_mkbig ();
2755 /* Arrange for rr to initially be non-positive,
2756 because that simplifies the test to see
2757 if it is within the needed bounds. */
2760 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2761 SCM_I_BIG_MPZ (x
), yy
);
2762 scm_remember_upto_here_1 (x
);
2764 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2765 SCM_I_BIG_MPZ (q
), 1);
2769 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2770 SCM_I_BIG_MPZ (x
), -yy
);
2771 scm_remember_upto_here_1 (x
);
2772 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2774 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2775 SCM_I_BIG_MPZ (q
), 1);
2777 return scm_i_normbig (q
);
2780 else if (SCM_BIGP (y
))
2781 return scm_i_bigint_centered_quotient (x
, y
);
2782 else if (SCM_REALP (y
))
2783 return scm_i_inexact_centered_quotient
2784 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2785 else if (SCM_FRACTIONP (y
))
2786 return scm_i_exact_rational_centered_quotient (x
, y
);
2788 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2789 s_scm_centered_quotient
);
2791 else if (SCM_REALP (x
))
2793 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2794 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2795 return scm_i_inexact_centered_quotient
2796 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2798 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2799 s_scm_centered_quotient
);
2801 else if (SCM_FRACTIONP (x
))
2804 return scm_i_inexact_centered_quotient
2805 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2806 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2807 return scm_i_exact_rational_centered_quotient (x
, y
);
2809 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2810 s_scm_centered_quotient
);
2813 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2814 s_scm_centered_quotient
);
2819 scm_i_inexact_centered_quotient (double x
, double y
)
2821 if (SCM_LIKELY (y
> 0))
2822 return scm_from_double (floor (x
/y
+ 0.5));
2823 else if (SCM_LIKELY (y
< 0))
2824 return scm_from_double (ceil (x
/y
- 0.5));
2826 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2831 /* Assumes that both x and y are bigints, though
2832 x might be able to fit into a fixnum. */
2834 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2838 /* Note that x might be small enough to fit into a
2839 fixnum, so we must not let it escape into the wild */
2843 /* min_r will eventually become -abs(y)/2 */
2844 min_r
= scm_i_mkbig ();
2845 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2846 SCM_I_BIG_MPZ (y
), 1);
2848 /* Arrange for rr to initially be non-positive,
2849 because that simplifies the test to see
2850 if it is within the needed bounds. */
2851 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2853 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2854 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2855 scm_remember_upto_here_2 (x
, y
);
2856 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2857 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2858 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2859 SCM_I_BIG_MPZ (q
), 1);
2863 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2864 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2865 scm_remember_upto_here_2 (x
, y
);
2866 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2867 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2868 SCM_I_BIG_MPZ (q
), 1);
2870 scm_remember_upto_here_2 (r
, min_r
);
2871 return scm_i_normbig (q
);
2875 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2877 return scm_centered_quotient
2878 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2879 scm_product (scm_numerator (y
), scm_denominator (x
)));
2882 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2883 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2884 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2886 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2888 "Return the real number @var{r} such that\n"
2889 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2890 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2891 "for some integer @var{q}.\n"
2893 "(centered-remainder 123 10) @result{} 3\n"
2894 "(centered-remainder 123 -10) @result{} 3\n"
2895 "(centered-remainder -123 10) @result{} -3\n"
2896 "(centered-remainder -123 -10) @result{} -3\n"
2897 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2898 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2900 #define FUNC_NAME s_scm_centered_remainder
2902 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2904 scm_t_inum xx
= SCM_I_INUM (x
);
2905 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2907 scm_t_inum yy
= SCM_I_INUM (y
);
2908 if (SCM_UNLIKELY (yy
== 0))
2909 scm_num_overflow (s_scm_centered_remainder
);
2912 scm_t_inum rr
= xx
% yy
;
2913 if (SCM_LIKELY (xx
> 0))
2915 if (SCM_LIKELY (yy
> 0))
2917 if (rr
>= (yy
+ 1) / 2)
2922 if (rr
>= (1 - yy
) / 2)
2928 if (SCM_LIKELY (yy
> 0))
2939 return SCM_I_MAKINUM (rr
);
2942 else if (SCM_BIGP (y
))
2944 /* Pass a denormalized bignum version of x (even though it
2945 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2946 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2948 else if (SCM_REALP (y
))
2949 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2950 else if (SCM_FRACTIONP (y
))
2951 return scm_i_exact_rational_centered_remainder (x
, y
);
2953 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2954 s_scm_centered_remainder
);
2956 else if (SCM_BIGP (x
))
2958 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2960 scm_t_inum yy
= SCM_I_INUM (y
);
2961 if (SCM_UNLIKELY (yy
== 0))
2962 scm_num_overflow (s_scm_centered_remainder
);
2966 /* Arrange for rr to initially be non-positive,
2967 because that simplifies the test to see
2968 if it is within the needed bounds. */
2971 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2972 scm_remember_upto_here_1 (x
);
2978 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2979 scm_remember_upto_here_1 (x
);
2983 return SCM_I_MAKINUM (rr
);
2986 else if (SCM_BIGP (y
))
2987 return scm_i_bigint_centered_remainder (x
, y
);
2988 else if (SCM_REALP (y
))
2989 return scm_i_inexact_centered_remainder
2990 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2991 else if (SCM_FRACTIONP (y
))
2992 return scm_i_exact_rational_centered_remainder (x
, y
);
2994 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2995 s_scm_centered_remainder
);
2997 else if (SCM_REALP (x
))
2999 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3000 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3001 return scm_i_inexact_centered_remainder
3002 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3004 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3005 s_scm_centered_remainder
);
3007 else if (SCM_FRACTIONP (x
))
3010 return scm_i_inexact_centered_remainder
3011 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3012 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3013 return scm_i_exact_rational_centered_remainder (x
, y
);
3015 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3016 s_scm_centered_remainder
);
3019 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3020 s_scm_centered_remainder
);
3025 scm_i_inexact_centered_remainder (double x
, double y
)
3029 /* Although it would be more efficient to use fmod here, we can't
3030 because it would in some cases produce results inconsistent with
3031 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3032 close). In particular, when x-y/2 is very close to a multiple of
3033 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3034 two cases must correspond to different choices of q. If quotient
3035 chooses one and remainder chooses the other, it would be bad. */
3036 if (SCM_LIKELY (y
> 0))
3037 q
= floor (x
/y
+ 0.5);
3038 else if (SCM_LIKELY (y
< 0))
3039 q
= ceil (x
/y
- 0.5);
3041 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3044 return scm_from_double (x
- q
* y
);
3047 /* Assumes that both x and y are bigints, though
3048 x might be able to fit into a fixnum. */
3050 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3054 /* Note that x might be small enough to fit into a
3055 fixnum, so we must not let it escape into the wild */
3058 /* min_r will eventually become -abs(y)/2 */
3059 min_r
= scm_i_mkbig ();
3060 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3061 SCM_I_BIG_MPZ (y
), 1);
3063 /* Arrange for rr to initially be non-positive,
3064 because that simplifies the test to see
3065 if it is within the needed bounds. */
3066 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3068 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3069 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3070 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3071 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3072 mpz_add (SCM_I_BIG_MPZ (r
),
3078 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3079 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3080 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3081 mpz_sub (SCM_I_BIG_MPZ (r
),
3085 scm_remember_upto_here_2 (x
, y
);
3086 return scm_i_normbig (r
);
3090 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3092 SCM xd
= scm_denominator (x
);
3093 SCM yd
= scm_denominator (y
);
3094 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3095 scm_product (scm_numerator (y
), xd
));
3096 return scm_divide (r1
, scm_product (xd
, yd
));
3100 static void scm_i_inexact_centered_divide (double x
, double y
,
3102 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3103 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3106 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3108 "Return the integer @var{q} and the real number @var{r}\n"
3109 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3110 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3112 "(centered/ 123 10) @result{} 12 and 3\n"
3113 "(centered/ 123 -10) @result{} -12 and 3\n"
3114 "(centered/ -123 10) @result{} -12 and -3\n"
3115 "(centered/ -123 -10) @result{} 12 and -3\n"
3116 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3117 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3119 #define FUNC_NAME s_scm_i_centered_divide
3123 scm_centered_divide(x
, y
, &q
, &r
);
3124 return scm_values (scm_list_2 (q
, r
));
3128 #define s_scm_centered_divide s_scm_i_centered_divide
3129 #define g_scm_centered_divide g_scm_i_centered_divide
3132 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3134 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3136 scm_t_inum xx
= SCM_I_INUM (x
);
3137 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3139 scm_t_inum yy
= SCM_I_INUM (y
);
3140 if (SCM_UNLIKELY (yy
== 0))
3141 scm_num_overflow (s_scm_centered_divide
);
3144 scm_t_inum qq
= xx
/ yy
;
3145 scm_t_inum rr
= xx
% yy
;
3146 if (SCM_LIKELY (xx
> 0))
3148 if (SCM_LIKELY (yy
> 0))
3150 if (rr
>= (yy
+ 1) / 2)
3155 if (rr
>= (1 - yy
) / 2)
3161 if (SCM_LIKELY (yy
> 0))
3172 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3173 *qp
= SCM_I_MAKINUM (qq
);
3175 *qp
= scm_i_inum2big (qq
);
3176 *rp
= SCM_I_MAKINUM (rr
);
3180 else if (SCM_BIGP (y
))
3182 /* Pass a denormalized bignum version of x (even though it
3183 can fit in a fixnum) to scm_i_bigint_centered_divide */
3184 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3186 else if (SCM_REALP (y
))
3187 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3188 else if (SCM_FRACTIONP (y
))
3189 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3191 return two_valued_wta_dispatch_2
3192 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3193 s_scm_centered_divide
, qp
, rp
);
3195 else if (SCM_BIGP (x
))
3197 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3199 scm_t_inum yy
= SCM_I_INUM (y
);
3200 if (SCM_UNLIKELY (yy
== 0))
3201 scm_num_overflow (s_scm_centered_divide
);
3204 SCM q
= scm_i_mkbig ();
3206 /* Arrange for rr to initially be non-positive,
3207 because that simplifies the test to see
3208 if it is within the needed bounds. */
3211 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3212 SCM_I_BIG_MPZ (x
), yy
);
3213 scm_remember_upto_here_1 (x
);
3216 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3217 SCM_I_BIG_MPZ (q
), 1);
3223 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3224 SCM_I_BIG_MPZ (x
), -yy
);
3225 scm_remember_upto_here_1 (x
);
3226 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3229 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3230 SCM_I_BIG_MPZ (q
), 1);
3234 *qp
= scm_i_normbig (q
);
3235 *rp
= SCM_I_MAKINUM (rr
);
3239 else if (SCM_BIGP (y
))
3240 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3241 else if (SCM_REALP (y
))
3242 return scm_i_inexact_centered_divide
3243 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3244 else if (SCM_FRACTIONP (y
))
3245 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3247 return two_valued_wta_dispatch_2
3248 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3249 s_scm_centered_divide
, qp
, rp
);
3251 else if (SCM_REALP (x
))
3253 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3254 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3255 return scm_i_inexact_centered_divide
3256 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3258 return two_valued_wta_dispatch_2
3259 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3260 s_scm_centered_divide
, qp
, rp
);
3262 else if (SCM_FRACTIONP (x
))
3265 return scm_i_inexact_centered_divide
3266 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3267 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3268 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3270 return two_valued_wta_dispatch_2
3271 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3272 s_scm_centered_divide
, qp
, rp
);
3275 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3276 s_scm_centered_divide
, qp
, rp
);
3280 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3284 if (SCM_LIKELY (y
> 0))
3285 q
= floor (x
/y
+ 0.5);
3286 else if (SCM_LIKELY (y
< 0))
3287 q
= ceil (x
/y
- 0.5);
3289 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3293 *qp
= scm_from_double (q
);
3294 *rp
= scm_from_double (r
);
3297 /* Assumes that both x and y are bigints, though
3298 x might be able to fit into a fixnum. */
3300 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3304 /* Note that x might be small enough to fit into a
3305 fixnum, so we must not let it escape into the wild */
3309 /* min_r will eventually become -abs(y/2) */
3310 min_r
= scm_i_mkbig ();
3311 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3312 SCM_I_BIG_MPZ (y
), 1);
3314 /* Arrange for rr to initially be non-positive,
3315 because that simplifies the test to see
3316 if it is within the needed bounds. */
3317 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3319 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3320 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3321 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3322 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3324 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3325 SCM_I_BIG_MPZ (q
), 1);
3326 mpz_add (SCM_I_BIG_MPZ (r
),
3333 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3334 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3335 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3337 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3338 SCM_I_BIG_MPZ (q
), 1);
3339 mpz_sub (SCM_I_BIG_MPZ (r
),
3344 scm_remember_upto_here_2 (x
, y
);
3345 *qp
= scm_i_normbig (q
);
3346 *rp
= scm_i_normbig (r
);
3350 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3353 SCM xd
= scm_denominator (x
);
3354 SCM yd
= scm_denominator (y
);
3356 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3357 scm_product (scm_numerator (y
), xd
),
3359 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3362 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3363 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3364 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3366 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3368 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3369 "with ties going to the nearest even integer.\n"
3371 "(round-quotient 123 10) @result{} 12\n"
3372 "(round-quotient 123 -10) @result{} -12\n"
3373 "(round-quotient -123 10) @result{} -12\n"
3374 "(round-quotient -123 -10) @result{} 12\n"
3375 "(round-quotient 125 10) @result{} 12\n"
3376 "(round-quotient 127 10) @result{} 13\n"
3377 "(round-quotient 135 10) @result{} 14\n"
3378 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3379 "(round-quotient 16/3 -10/7) @result{} -4\n"
3381 #define FUNC_NAME s_scm_round_quotient
3383 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3385 scm_t_inum xx
= SCM_I_INUM (x
);
3386 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3388 scm_t_inum yy
= SCM_I_INUM (y
);
3389 if (SCM_UNLIKELY (yy
== 0))
3390 scm_num_overflow (s_scm_round_quotient
);
3393 scm_t_inum qq
= xx
/ yy
;
3394 scm_t_inum rr
= xx
% yy
;
3396 scm_t_inum r2
= 2 * rr
;
3398 if (SCM_LIKELY (yy
< 0))
3418 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3419 return SCM_I_MAKINUM (qq
);
3421 return scm_i_inum2big (qq
);
3424 else if (SCM_BIGP (y
))
3426 /* Pass a denormalized bignum version of x (even though it
3427 can fit in a fixnum) to scm_i_bigint_round_quotient */
3428 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3430 else if (SCM_REALP (y
))
3431 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3432 else if (SCM_FRACTIONP (y
))
3433 return scm_i_exact_rational_round_quotient (x
, y
);
3435 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3436 s_scm_round_quotient
);
3438 else if (SCM_BIGP (x
))
3440 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3442 scm_t_inum yy
= SCM_I_INUM (y
);
3443 if (SCM_UNLIKELY (yy
== 0))
3444 scm_num_overflow (s_scm_round_quotient
);
3445 else if (SCM_UNLIKELY (yy
== 1))
3449 SCM q
= scm_i_mkbig ();
3451 int needs_adjustment
;
3455 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3456 SCM_I_BIG_MPZ (x
), yy
);
3457 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3458 needs_adjustment
= (2*rr
>= yy
);
3460 needs_adjustment
= (2*rr
> yy
);
3464 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3465 SCM_I_BIG_MPZ (x
), -yy
);
3466 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3467 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3468 needs_adjustment
= (2*rr
<= yy
);
3470 needs_adjustment
= (2*rr
< yy
);
3472 scm_remember_upto_here_1 (x
);
3473 if (needs_adjustment
)
3474 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3475 return scm_i_normbig (q
);
3478 else if (SCM_BIGP (y
))
3479 return scm_i_bigint_round_quotient (x
, y
);
3480 else if (SCM_REALP (y
))
3481 return scm_i_inexact_round_quotient
3482 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3483 else if (SCM_FRACTIONP (y
))
3484 return scm_i_exact_rational_round_quotient (x
, y
);
3486 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3487 s_scm_round_quotient
);
3489 else if (SCM_REALP (x
))
3491 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3492 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3493 return scm_i_inexact_round_quotient
3494 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3496 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3497 s_scm_round_quotient
);
3499 else if (SCM_FRACTIONP (x
))
3502 return scm_i_inexact_round_quotient
3503 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3504 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3505 return scm_i_exact_rational_round_quotient (x
, y
);
3507 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3508 s_scm_round_quotient
);
3511 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3512 s_scm_round_quotient
);
3517 scm_i_inexact_round_quotient (double x
, double y
)
3519 if (SCM_UNLIKELY (y
== 0))
3520 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3522 return scm_from_double (scm_c_round (x
/ y
));
3525 /* Assumes that both x and y are bigints, though
3526 x might be able to fit into a fixnum. */
3528 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3531 int cmp
, needs_adjustment
;
3533 /* Note that x might be small enough to fit into a
3534 fixnum, so we must not let it escape into the wild */
3537 r2
= scm_i_mkbig ();
3539 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3540 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3541 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3542 scm_remember_upto_here_2 (x
, r
);
3544 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3545 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3546 needs_adjustment
= (cmp
>= 0);
3548 needs_adjustment
= (cmp
> 0);
3549 scm_remember_upto_here_2 (r2
, y
);
3551 if (needs_adjustment
)
3552 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3554 return scm_i_normbig (q
);
3558 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3560 return scm_round_quotient
3561 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3562 scm_product (scm_numerator (y
), scm_denominator (x
)));
3565 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3566 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3567 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3569 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3571 "Return the real number @var{r} such that\n"
3572 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3573 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3574 "nearest integer, with ties going to the nearest\n"
3577 "(round-remainder 123 10) @result{} 3\n"
3578 "(round-remainder 123 -10) @result{} 3\n"
3579 "(round-remainder -123 10) @result{} -3\n"
3580 "(round-remainder -123 -10) @result{} -3\n"
3581 "(round-remainder 125 10) @result{} 5\n"
3582 "(round-remainder 127 10) @result{} -3\n"
3583 "(round-remainder 135 10) @result{} -5\n"
3584 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3585 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3587 #define FUNC_NAME s_scm_round_remainder
3589 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3591 scm_t_inum xx
= SCM_I_INUM (x
);
3592 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3594 scm_t_inum yy
= SCM_I_INUM (y
);
3595 if (SCM_UNLIKELY (yy
== 0))
3596 scm_num_overflow (s_scm_round_remainder
);
3599 scm_t_inum qq
= xx
/ yy
;
3600 scm_t_inum rr
= xx
% yy
;
3602 scm_t_inum r2
= 2 * rr
;
3604 if (SCM_LIKELY (yy
< 0))
3624 return SCM_I_MAKINUM (rr
);
3627 else if (SCM_BIGP (y
))
3629 /* Pass a denormalized bignum version of x (even though it
3630 can fit in a fixnum) to scm_i_bigint_round_remainder */
3631 return scm_i_bigint_round_remainder
3632 (scm_i_long2big (xx
), y
);
3634 else if (SCM_REALP (y
))
3635 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3636 else if (SCM_FRACTIONP (y
))
3637 return scm_i_exact_rational_round_remainder (x
, y
);
3639 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3640 s_scm_round_remainder
);
3642 else if (SCM_BIGP (x
))
3644 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3646 scm_t_inum yy
= SCM_I_INUM (y
);
3647 if (SCM_UNLIKELY (yy
== 0))
3648 scm_num_overflow (s_scm_round_remainder
);
3651 SCM q
= scm_i_mkbig ();
3653 int needs_adjustment
;
3657 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3658 SCM_I_BIG_MPZ (x
), yy
);
3659 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3660 needs_adjustment
= (2*rr
>= yy
);
3662 needs_adjustment
= (2*rr
> yy
);
3666 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3667 SCM_I_BIG_MPZ (x
), -yy
);
3668 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3669 needs_adjustment
= (2*rr
<= yy
);
3671 needs_adjustment
= (2*rr
< yy
);
3673 scm_remember_upto_here_2 (x
, q
);
3674 if (needs_adjustment
)
3676 return SCM_I_MAKINUM (rr
);
3679 else if (SCM_BIGP (y
))
3680 return scm_i_bigint_round_remainder (x
, y
);
3681 else if (SCM_REALP (y
))
3682 return scm_i_inexact_round_remainder
3683 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3684 else if (SCM_FRACTIONP (y
))
3685 return scm_i_exact_rational_round_remainder (x
, y
);
3687 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3688 s_scm_round_remainder
);
3690 else if (SCM_REALP (x
))
3692 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3693 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3694 return scm_i_inexact_round_remainder
3695 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3697 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3698 s_scm_round_remainder
);
3700 else if (SCM_FRACTIONP (x
))
3703 return scm_i_inexact_round_remainder
3704 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3705 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3706 return scm_i_exact_rational_round_remainder (x
, y
);
3708 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3709 s_scm_round_remainder
);
3712 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3713 s_scm_round_remainder
);
3718 scm_i_inexact_round_remainder (double x
, double y
)
3720 /* Although it would be more efficient to use fmod here, we can't
3721 because it would in some cases produce results inconsistent with
3722 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3723 close). In particular, when x-y/2 is very close to a multiple of
3724 y, then r might be either -abs(y/2) or abs(y/2), but those two
3725 cases must correspond to different choices of q. If quotient
3726 chooses one and remainder chooses the other, it would be bad. */
3728 if (SCM_UNLIKELY (y
== 0))
3729 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3732 double q
= scm_c_round (x
/ y
);
3733 return scm_from_double (x
- q
* y
);
3737 /* Assumes that both x and y are bigints, though
3738 x might be able to fit into a fixnum. */
3740 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3743 int cmp
, needs_adjustment
;
3745 /* Note that x might be small enough to fit into a
3746 fixnum, so we must not let it escape into the wild */
3749 r2
= scm_i_mkbig ();
3751 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3752 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3753 scm_remember_upto_here_1 (x
);
3754 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3756 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3757 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3758 needs_adjustment
= (cmp
>= 0);
3760 needs_adjustment
= (cmp
> 0);
3761 scm_remember_upto_here_2 (q
, r2
);
3763 if (needs_adjustment
)
3764 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3766 scm_remember_upto_here_1 (y
);
3767 return scm_i_normbig (r
);
3771 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3773 SCM xd
= scm_denominator (x
);
3774 SCM yd
= scm_denominator (y
);
3775 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3776 scm_product (scm_numerator (y
), xd
));
3777 return scm_divide (r1
, scm_product (xd
, yd
));
3781 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3782 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3783 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3785 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3787 "Return the integer @var{q} and the real number @var{r}\n"
3788 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3789 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3790 "nearest integer, with ties going to the nearest even integer.\n"
3792 "(round/ 123 10) @result{} 12 and 3\n"
3793 "(round/ 123 -10) @result{} -12 and 3\n"
3794 "(round/ -123 10) @result{} -12 and -3\n"
3795 "(round/ -123 -10) @result{} 12 and -3\n"
3796 "(round/ 125 10) @result{} 12 and 5\n"
3797 "(round/ 127 10) @result{} 13 and -3\n"
3798 "(round/ 135 10) @result{} 14 and -5\n"
3799 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3800 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3802 #define FUNC_NAME s_scm_i_round_divide
3806 scm_round_divide(x
, y
, &q
, &r
);
3807 return scm_values (scm_list_2 (q
, r
));
3811 #define s_scm_round_divide s_scm_i_round_divide
3812 #define g_scm_round_divide g_scm_i_round_divide
3815 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3817 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3819 scm_t_inum xx
= SCM_I_INUM (x
);
3820 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3822 scm_t_inum yy
= SCM_I_INUM (y
);
3823 if (SCM_UNLIKELY (yy
== 0))
3824 scm_num_overflow (s_scm_round_divide
);
3827 scm_t_inum qq
= xx
/ yy
;
3828 scm_t_inum rr
= xx
% yy
;
3830 scm_t_inum r2
= 2 * rr
;
3832 if (SCM_LIKELY (yy
< 0))
3852 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3853 *qp
= SCM_I_MAKINUM (qq
);
3855 *qp
= scm_i_inum2big (qq
);
3856 *rp
= SCM_I_MAKINUM (rr
);
3860 else if (SCM_BIGP (y
))
3862 /* Pass a denormalized bignum version of x (even though it
3863 can fit in a fixnum) to scm_i_bigint_round_divide */
3864 return scm_i_bigint_round_divide
3865 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3867 else if (SCM_REALP (y
))
3868 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3869 else if (SCM_FRACTIONP (y
))
3870 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3872 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3873 s_scm_round_divide
, qp
, rp
);
3875 else if (SCM_BIGP (x
))
3877 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3879 scm_t_inum yy
= SCM_I_INUM (y
);
3880 if (SCM_UNLIKELY (yy
== 0))
3881 scm_num_overflow (s_scm_round_divide
);
3884 SCM q
= scm_i_mkbig ();
3886 int needs_adjustment
;
3890 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3891 SCM_I_BIG_MPZ (x
), yy
);
3892 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3893 needs_adjustment
= (2*rr
>= yy
);
3895 needs_adjustment
= (2*rr
> yy
);
3899 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3900 SCM_I_BIG_MPZ (x
), -yy
);
3901 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3902 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3903 needs_adjustment
= (2*rr
<= yy
);
3905 needs_adjustment
= (2*rr
< yy
);
3907 scm_remember_upto_here_1 (x
);
3908 if (needs_adjustment
)
3910 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3913 *qp
= scm_i_normbig (q
);
3914 *rp
= SCM_I_MAKINUM (rr
);
3918 else if (SCM_BIGP (y
))
3919 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3920 else if (SCM_REALP (y
))
3921 return scm_i_inexact_round_divide
3922 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3923 else if (SCM_FRACTIONP (y
))
3924 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3926 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3927 s_scm_round_divide
, qp
, rp
);
3929 else if (SCM_REALP (x
))
3931 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3932 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3933 return scm_i_inexact_round_divide
3934 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3936 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3937 s_scm_round_divide
, qp
, rp
);
3939 else if (SCM_FRACTIONP (x
))
3942 return scm_i_inexact_round_divide
3943 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3944 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3945 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3947 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3948 s_scm_round_divide
, qp
, rp
);
3951 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3952 s_scm_round_divide
, qp
, rp
);
3956 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3958 if (SCM_UNLIKELY (y
== 0))
3959 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3962 double q
= scm_c_round (x
/ y
);
3963 double r
= x
- q
* y
;
3964 *qp
= scm_from_double (q
);
3965 *rp
= scm_from_double (r
);
3969 /* Assumes that both x and y are bigints, though
3970 x might be able to fit into a fixnum. */
3972 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3975 int cmp
, needs_adjustment
;
3977 /* Note that x might be small enough to fit into a
3978 fixnum, so we must not let it escape into the wild */
3981 r2
= scm_i_mkbig ();
3983 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3984 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3985 scm_remember_upto_here_1 (x
);
3986 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3988 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3989 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3990 needs_adjustment
= (cmp
>= 0);
3992 needs_adjustment
= (cmp
> 0);
3994 if (needs_adjustment
)
3996 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3997 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4000 scm_remember_upto_here_2 (r2
, y
);
4001 *qp
= scm_i_normbig (q
);
4002 *rp
= scm_i_normbig (r
);
4006 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4009 SCM xd
= scm_denominator (x
);
4010 SCM yd
= scm_denominator (y
);
4012 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4013 scm_product (scm_numerator (y
), xd
),
4015 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4019 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4020 (SCM x
, SCM y
, SCM rest
),
4021 "Return the greatest common divisor of all parameter values.\n"
4022 "If called without arguments, 0 is returned.")
4023 #define FUNC_NAME s_scm_i_gcd
4025 while (!scm_is_null (rest
))
4026 { x
= scm_gcd (x
, y
);
4028 rest
= scm_cdr (rest
);
4030 return scm_gcd (x
, y
);
4034 #define s_gcd s_scm_i_gcd
4035 #define g_gcd g_scm_i_gcd
4038 scm_gcd (SCM x
, SCM y
)
4040 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4041 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4043 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4045 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4047 scm_t_inum xx
= SCM_I_INUM (x
);
4048 scm_t_inum yy
= SCM_I_INUM (y
);
4049 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4050 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4052 if (SCM_UNLIKELY (xx
== 0))
4054 else if (SCM_UNLIKELY (yy
== 0))
4059 /* Determine a common factor 2^k */
4060 while (((u
| v
) & 1) == 0)
4066 /* Now, any factor 2^n can be eliminated */
4068 while ((u
& 1) == 0)
4071 while ((v
& 1) == 0)
4073 /* Both u and v are now odd. Subtract the smaller one
4074 from the larger one to produce an even number, remove
4075 more factors of two, and repeat. */
4081 while ((u
& 1) == 0)
4087 while ((v
& 1) == 0)
4093 return (SCM_POSFIXABLE (result
)
4094 ? SCM_I_MAKINUM (result
)
4095 : scm_i_inum2big (result
));
4097 else if (SCM_BIGP (y
))
4103 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4105 else if (SCM_BIGP (x
))
4107 if (SCM_I_INUMP (y
))
4112 yy
= SCM_I_INUM (y
);
4117 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4118 scm_remember_upto_here_1 (x
);
4119 return (SCM_POSFIXABLE (result
)
4120 ? SCM_I_MAKINUM (result
)
4121 : scm_from_unsigned_integer (result
));
4123 else if (SCM_BIGP (y
))
4125 SCM result
= scm_i_mkbig ();
4126 mpz_gcd (SCM_I_BIG_MPZ (result
),
4129 scm_remember_upto_here_2 (x
, y
);
4130 return scm_i_normbig (result
);
4133 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4136 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4139 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4140 (SCM x
, SCM y
, SCM rest
),
4141 "Return the least common multiple of the arguments.\n"
4142 "If called without arguments, 1 is returned.")
4143 #define FUNC_NAME s_scm_i_lcm
4145 while (!scm_is_null (rest
))
4146 { x
= scm_lcm (x
, y
);
4148 rest
= scm_cdr (rest
);
4150 return scm_lcm (x
, y
);
4154 #define s_lcm s_scm_i_lcm
4155 #define g_lcm g_scm_i_lcm
4158 scm_lcm (SCM n1
, SCM n2
)
4160 if (SCM_UNBNDP (n2
))
4162 if (SCM_UNBNDP (n1
))
4163 return SCM_I_MAKINUM (1L);
4164 n2
= SCM_I_MAKINUM (1L);
4167 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4168 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4169 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4170 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4172 if (SCM_I_INUMP (n1
))
4174 if (SCM_I_INUMP (n2
))
4176 SCM d
= scm_gcd (n1
, n2
);
4177 if (scm_is_eq (d
, SCM_INUM0
))
4180 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4184 /* inum n1, big n2 */
4187 SCM result
= scm_i_mkbig ();
4188 scm_t_inum nn1
= SCM_I_INUM (n1
);
4189 if (nn1
== 0) return SCM_INUM0
;
4190 if (nn1
< 0) nn1
= - nn1
;
4191 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4192 scm_remember_upto_here_1 (n2
);
4200 if (SCM_I_INUMP (n2
))
4207 SCM result
= scm_i_mkbig ();
4208 mpz_lcm(SCM_I_BIG_MPZ (result
),
4210 SCM_I_BIG_MPZ (n2
));
4211 scm_remember_upto_here_2(n1
, n2
);
4212 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4218 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4223 + + + x (map digit:logand X Y)
4224 + - + x (map digit:logand X (lognot (+ -1 Y)))
4225 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4226 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4231 + + + (map digit:logior X Y)
4232 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4233 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4234 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4239 + + + (map digit:logxor X Y)
4240 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4241 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4242 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4247 + + (any digit:logand X Y)
4248 + - (any digit:logand X (lognot (+ -1 Y)))
4249 - + (any digit:logand (lognot (+ -1 X)) Y)
4254 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4255 (SCM x
, SCM y
, SCM rest
),
4256 "Return the bitwise AND of the integer arguments.\n\n"
4258 "(logand) @result{} -1\n"
4259 "(logand 7) @result{} 7\n"
4260 "(logand #b111 #b011 #b001) @result{} 1\n"
4262 #define FUNC_NAME s_scm_i_logand
4264 while (!scm_is_null (rest
))
4265 { x
= scm_logand (x
, y
);
4267 rest
= scm_cdr (rest
);
4269 return scm_logand (x
, y
);
4273 #define s_scm_logand s_scm_i_logand
4275 SCM
scm_logand (SCM n1
, SCM n2
)
4276 #define FUNC_NAME s_scm_logand
4280 if (SCM_UNBNDP (n2
))
4282 if (SCM_UNBNDP (n1
))
4283 return SCM_I_MAKINUM (-1);
4284 else if (!SCM_NUMBERP (n1
))
4285 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4286 else if (SCM_NUMBERP (n1
))
4289 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4292 if (SCM_I_INUMP (n1
))
4294 nn1
= SCM_I_INUM (n1
);
4295 if (SCM_I_INUMP (n2
))
4297 scm_t_inum nn2
= SCM_I_INUM (n2
);
4298 return SCM_I_MAKINUM (nn1
& nn2
);
4300 else if SCM_BIGP (n2
)
4306 SCM result_z
= scm_i_mkbig ();
4308 mpz_init_set_si (nn1_z
, nn1
);
4309 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4310 scm_remember_upto_here_1 (n2
);
4312 return scm_i_normbig (result_z
);
4316 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4318 else if (SCM_BIGP (n1
))
4320 if (SCM_I_INUMP (n2
))
4323 nn1
= SCM_I_INUM (n1
);
4326 else if (SCM_BIGP (n2
))
4328 SCM result_z
= scm_i_mkbig ();
4329 mpz_and (SCM_I_BIG_MPZ (result_z
),
4331 SCM_I_BIG_MPZ (n2
));
4332 scm_remember_upto_here_2 (n1
, n2
);
4333 return scm_i_normbig (result_z
);
4336 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4339 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4344 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4345 (SCM x
, SCM y
, SCM rest
),
4346 "Return the bitwise OR of the integer arguments.\n\n"
4348 "(logior) @result{} 0\n"
4349 "(logior 7) @result{} 7\n"
4350 "(logior #b000 #b001 #b011) @result{} 3\n"
4352 #define FUNC_NAME s_scm_i_logior
4354 while (!scm_is_null (rest
))
4355 { x
= scm_logior (x
, y
);
4357 rest
= scm_cdr (rest
);
4359 return scm_logior (x
, y
);
4363 #define s_scm_logior s_scm_i_logior
4365 SCM
scm_logior (SCM n1
, SCM n2
)
4366 #define FUNC_NAME s_scm_logior
4370 if (SCM_UNBNDP (n2
))
4372 if (SCM_UNBNDP (n1
))
4374 else if (SCM_NUMBERP (n1
))
4377 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4380 if (SCM_I_INUMP (n1
))
4382 nn1
= SCM_I_INUM (n1
);
4383 if (SCM_I_INUMP (n2
))
4385 long nn2
= SCM_I_INUM (n2
);
4386 return SCM_I_MAKINUM (nn1
| nn2
);
4388 else if (SCM_BIGP (n2
))
4394 SCM result_z
= scm_i_mkbig ();
4396 mpz_init_set_si (nn1_z
, nn1
);
4397 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4398 scm_remember_upto_here_1 (n2
);
4400 return scm_i_normbig (result_z
);
4404 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4406 else if (SCM_BIGP (n1
))
4408 if (SCM_I_INUMP (n2
))
4411 nn1
= SCM_I_INUM (n1
);
4414 else if (SCM_BIGP (n2
))
4416 SCM result_z
= scm_i_mkbig ();
4417 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4419 SCM_I_BIG_MPZ (n2
));
4420 scm_remember_upto_here_2 (n1
, n2
);
4421 return scm_i_normbig (result_z
);
4424 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4427 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4432 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4433 (SCM x
, SCM y
, SCM rest
),
4434 "Return the bitwise XOR of the integer arguments. A bit is\n"
4435 "set in the result if it is set in an odd number of arguments.\n"
4437 "(logxor) @result{} 0\n"
4438 "(logxor 7) @result{} 7\n"
4439 "(logxor #b000 #b001 #b011) @result{} 2\n"
4440 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4442 #define FUNC_NAME s_scm_i_logxor
4444 while (!scm_is_null (rest
))
4445 { x
= scm_logxor (x
, y
);
4447 rest
= scm_cdr (rest
);
4449 return scm_logxor (x
, y
);
4453 #define s_scm_logxor s_scm_i_logxor
4455 SCM
scm_logxor (SCM n1
, SCM n2
)
4456 #define FUNC_NAME s_scm_logxor
4460 if (SCM_UNBNDP (n2
))
4462 if (SCM_UNBNDP (n1
))
4464 else if (SCM_NUMBERP (n1
))
4467 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4470 if (SCM_I_INUMP (n1
))
4472 nn1
= SCM_I_INUM (n1
);
4473 if (SCM_I_INUMP (n2
))
4475 scm_t_inum nn2
= SCM_I_INUM (n2
);
4476 return SCM_I_MAKINUM (nn1
^ nn2
);
4478 else if (SCM_BIGP (n2
))
4482 SCM result_z
= scm_i_mkbig ();
4484 mpz_init_set_si (nn1_z
, nn1
);
4485 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4486 scm_remember_upto_here_1 (n2
);
4488 return scm_i_normbig (result_z
);
4492 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4494 else if (SCM_BIGP (n1
))
4496 if (SCM_I_INUMP (n2
))
4499 nn1
= SCM_I_INUM (n1
);
4502 else if (SCM_BIGP (n2
))
4504 SCM result_z
= scm_i_mkbig ();
4505 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4507 SCM_I_BIG_MPZ (n2
));
4508 scm_remember_upto_here_2 (n1
, n2
);
4509 return scm_i_normbig (result_z
);
4512 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4515 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4520 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4522 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4523 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4524 "without actually calculating the @code{logand}, just testing\n"
4528 "(logtest #b0100 #b1011) @result{} #f\n"
4529 "(logtest #b0100 #b0111) @result{} #t\n"
4531 #define FUNC_NAME s_scm_logtest
4535 if (SCM_I_INUMP (j
))
4537 nj
= SCM_I_INUM (j
);
4538 if (SCM_I_INUMP (k
))
4540 scm_t_inum nk
= SCM_I_INUM (k
);
4541 return scm_from_bool (nj
& nk
);
4543 else if (SCM_BIGP (k
))
4551 mpz_init_set_si (nj_z
, nj
);
4552 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4553 scm_remember_upto_here_1 (k
);
4554 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4560 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4562 else if (SCM_BIGP (j
))
4564 if (SCM_I_INUMP (k
))
4567 nj
= SCM_I_INUM (j
);
4570 else if (SCM_BIGP (k
))
4574 mpz_init (result_z
);
4578 scm_remember_upto_here_2 (j
, k
);
4579 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4580 mpz_clear (result_z
);
4584 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4587 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4592 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4594 "Test whether bit number @var{index} in @var{j} is set.\n"
4595 "@var{index} starts from 0 for the least significant bit.\n"
4598 "(logbit? 0 #b1101) @result{} #t\n"
4599 "(logbit? 1 #b1101) @result{} #f\n"
4600 "(logbit? 2 #b1101) @result{} #t\n"
4601 "(logbit? 3 #b1101) @result{} #t\n"
4602 "(logbit? 4 #b1101) @result{} #f\n"
4604 #define FUNC_NAME s_scm_logbit_p
4606 unsigned long int iindex
;
4607 iindex
= scm_to_ulong (index
);
4609 if (SCM_I_INUMP (j
))
4611 /* bits above what's in an inum follow the sign bit */
4612 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4613 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4615 else if (SCM_BIGP (j
))
4617 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4618 scm_remember_upto_here_1 (j
);
4619 return scm_from_bool (val
);
4622 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4627 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4629 "Return the integer which is the ones-complement of the integer\n"
4633 "(number->string (lognot #b10000000) 2)\n"
4634 " @result{} \"-10000001\"\n"
4635 "(number->string (lognot #b0) 2)\n"
4636 " @result{} \"-1\"\n"
4638 #define FUNC_NAME s_scm_lognot
4640 if (SCM_I_INUMP (n
)) {
4641 /* No overflow here, just need to toggle all the bits making up the inum.
4642 Enhancement: No need to strip the tag and add it back, could just xor
4643 a block of 1 bits, if that worked with the various debug versions of
4645 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4647 } else if (SCM_BIGP (n
)) {
4648 SCM result
= scm_i_mkbig ();
4649 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4650 scm_remember_upto_here_1 (n
);
4654 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4659 /* returns 0 if IN is not an integer. OUT must already be
4662 coerce_to_big (SCM in
, mpz_t out
)
4665 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4666 else if (SCM_I_INUMP (in
))
4667 mpz_set_si (out
, SCM_I_INUM (in
));
4674 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4675 (SCM n
, SCM k
, SCM m
),
4676 "Return @var{n} raised to the integer exponent\n"
4677 "@var{k}, modulo @var{m}.\n"
4680 "(modulo-expt 2 3 5)\n"
4683 #define FUNC_NAME s_scm_modulo_expt
4689 /* There are two classes of error we might encounter --
4690 1) Math errors, which we'll report by calling scm_num_overflow,
4692 2) wrong-type errors, which of course we'll report by calling
4694 We don't report those errors immediately, however; instead we do
4695 some cleanup first. These variables tell us which error (if
4696 any) we should report after cleaning up.
4698 int report_overflow
= 0;
4700 int position_of_wrong_type
= 0;
4701 SCM value_of_wrong_type
= SCM_INUM0
;
4703 SCM result
= SCM_UNDEFINED
;
4709 if (scm_is_eq (m
, SCM_INUM0
))
4711 report_overflow
= 1;
4715 if (!coerce_to_big (n
, n_tmp
))
4717 value_of_wrong_type
= n
;
4718 position_of_wrong_type
= 1;
4722 if (!coerce_to_big (k
, k_tmp
))
4724 value_of_wrong_type
= k
;
4725 position_of_wrong_type
= 2;
4729 if (!coerce_to_big (m
, m_tmp
))
4731 value_of_wrong_type
= m
;
4732 position_of_wrong_type
= 3;
4736 /* if the exponent K is negative, and we simply call mpz_powm, we
4737 will get a divide-by-zero exception when an inverse 1/n mod m
4738 doesn't exist (or is not unique). Since exceptions are hard to
4739 handle, we'll attempt the inversion "by hand" -- that way, we get
4740 a simple failure code, which is easy to handle. */
4742 if (-1 == mpz_sgn (k_tmp
))
4744 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4746 report_overflow
= 1;
4749 mpz_neg (k_tmp
, k_tmp
);
4752 result
= scm_i_mkbig ();
4753 mpz_powm (SCM_I_BIG_MPZ (result
),
4758 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4759 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4766 if (report_overflow
)
4767 scm_num_overflow (FUNC_NAME
);
4769 if (position_of_wrong_type
)
4770 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4771 value_of_wrong_type
);
4773 return scm_i_normbig (result
);
4777 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4779 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4780 "exact integer, @var{n} can be any number.\n"
4782 "Negative @var{k} is supported, and results in\n"
4783 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4784 "@math{@var{n}^0} is 1, as usual, and that\n"
4785 "includes @math{0^0} is 1.\n"
4788 "(integer-expt 2 5) @result{} 32\n"
4789 "(integer-expt -3 3) @result{} -27\n"
4790 "(integer-expt 5 -3) @result{} 1/125\n"
4791 "(integer-expt 0 0) @result{} 1\n"
4793 #define FUNC_NAME s_scm_integer_expt
4796 SCM z_i2
= SCM_BOOL_F
;
4798 SCM acc
= SCM_I_MAKINUM (1L);
4800 /* Specifically refrain from checking the type of the first argument.
4801 This allows us to exponentiate any object that can be multiplied.
4802 If we must raise to a negative power, we must also be able to
4803 take its reciprocal. */
4804 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4805 SCM_WRONG_TYPE_ARG (2, k
);
4807 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4808 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4809 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4810 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4811 /* The next check is necessary only because R6RS specifies different
4812 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4813 we simply skip this case and move on. */
4814 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4816 /* k cannot be 0 at this point, because we
4817 have already checked for that case above */
4818 if (scm_is_true (scm_positive_p (k
)))
4820 else /* return NaN for (0 ^ k) for negative k per R6RS */
4823 else if (SCM_FRACTIONP (n
))
4825 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4826 needless reduction of intermediate products to lowest terms.
4827 If a and b have no common factors, then a^k and b^k have no
4828 common factors. Use 'scm_i_make_ratio_already_reduced' to
4829 construct the final result, so that no gcd computations are
4830 needed to exponentiate a fraction. */
4831 if (scm_is_true (scm_positive_p (k
)))
4832 return scm_i_make_ratio_already_reduced
4833 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4834 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4837 k
= scm_difference (k
, SCM_UNDEFINED
);
4838 return scm_i_make_ratio_already_reduced
4839 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4840 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4844 if (SCM_I_INUMP (k
))
4845 i2
= SCM_I_INUM (k
);
4846 else if (SCM_BIGP (k
))
4848 z_i2
= scm_i_clonebig (k
, 1);
4849 scm_remember_upto_here_1 (k
);
4853 SCM_WRONG_TYPE_ARG (2, k
);
4857 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4859 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4860 n
= scm_divide (n
, SCM_UNDEFINED
);
4864 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4868 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4870 return scm_product (acc
, n
);
4872 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4873 acc
= scm_product (acc
, n
);
4874 n
= scm_product (n
, n
);
4875 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4883 n
= scm_divide (n
, SCM_UNDEFINED
);
4890 return scm_product (acc
, n
);
4892 acc
= scm_product (acc
, n
);
4893 n
= scm_product (n
, n
);
4900 /* Efficiently compute (N * 2^COUNT),
4901 where N is an exact integer, and COUNT > 0. */
4903 left_shift_exact_integer (SCM n
, long count
)
4905 if (SCM_I_INUMP (n
))
4907 scm_t_inum nn
= SCM_I_INUM (n
);
4909 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4910 overflow a non-zero fixnum. For smaller shifts we check the
4911 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4912 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4913 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4917 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4918 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4920 return SCM_I_MAKINUM (nn
<< count
);
4923 SCM result
= scm_i_inum2big (nn
);
4924 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4929 else if (SCM_BIGP (n
))
4931 SCM result
= scm_i_mkbig ();
4932 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
4933 scm_remember_upto_here_1 (n
);
4937 scm_syserror ("left_shift_exact_integer");
4940 /* Efficiently compute floor (N / 2^COUNT),
4941 where N is an exact integer and COUNT > 0. */
4943 floor_right_shift_exact_integer (SCM n
, long count
)
4945 if (SCM_I_INUMP (n
))
4947 scm_t_inum nn
= SCM_I_INUM (n
);
4949 if (count
>= SCM_I_FIXNUM_BIT
)
4950 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
4952 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
4954 else if (SCM_BIGP (n
))
4956 SCM result
= scm_i_mkbig ();
4957 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4959 scm_remember_upto_here_1 (n
);
4960 return scm_i_normbig (result
);
4963 scm_syserror ("floor_right_shift_exact_integer");
4966 /* Efficiently compute round (N / 2^COUNT),
4967 where N is an exact integer and COUNT > 0. */
4969 round_right_shift_exact_integer (SCM n
, long count
)
4971 if (SCM_I_INUMP (n
))
4973 if (count
>= SCM_I_FIXNUM_BIT
)
4977 scm_t_inum nn
= SCM_I_INUM (n
);
4978 scm_t_inum qq
= SCM_SRS (nn
, count
);
4980 if (0 == (nn
& (1L << (count
-1))))
4981 return SCM_I_MAKINUM (qq
); /* round down */
4982 else if (nn
& ((1L << (count
-1)) - 1))
4983 return SCM_I_MAKINUM (qq
+ 1); /* round up */
4985 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
4988 else if (SCM_BIGP (n
))
4990 SCM q
= scm_i_mkbig ();
4992 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
4993 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
4994 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
4995 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
4996 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4997 scm_remember_upto_here_1 (n
);
4998 return scm_i_normbig (q
);
5001 scm_syserror ("round_right_shift_exact_integer");
5004 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5006 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5007 "@var{n} and @var{count} must be exact integers.\n"
5009 "With @var{n} viewed as an infinite-precision twos-complement\n"
5010 "integer, @code{ash} means a left shift introducing zero bits\n"
5011 "when @var{count} is positive, or a right shift dropping bits\n"
5012 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5015 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5016 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5018 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5019 "(ash -23 -2) @result{} -6\n"
5021 #define FUNC_NAME s_scm_ash
5023 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5025 long bits_to_shift
= scm_to_long (count
);
5027 if (bits_to_shift
> 0)
5028 return left_shift_exact_integer (n
, bits_to_shift
);
5029 else if (SCM_LIKELY (bits_to_shift
< 0))
5030 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5035 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5039 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5041 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5042 "@var{n} and @var{count} must be exact integers.\n"
5044 "With @var{n} viewed as an infinite-precision twos-complement\n"
5045 "integer, @code{round-ash} means a left shift introducing zero\n"
5046 "bits when @var{count} is positive, or a right shift rounding\n"
5047 "to the nearest integer (with ties going to the nearest even\n"
5048 "integer) when @var{count} is negative. This is a rounded\n"
5049 "``arithmetic'' shift.\n"
5052 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5053 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5054 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5055 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5056 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5057 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5059 #define FUNC_NAME s_scm_round_ash
5061 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5063 long bits_to_shift
= scm_to_long (count
);
5065 if (bits_to_shift
> 0)
5066 return left_shift_exact_integer (n
, bits_to_shift
);
5067 else if (SCM_LIKELY (bits_to_shift
< 0))
5068 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5073 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5078 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5079 (SCM n
, SCM start
, SCM end
),
5080 "Return the integer composed of the @var{start} (inclusive)\n"
5081 "through @var{end} (exclusive) bits of @var{n}. The\n"
5082 "@var{start}th bit becomes the 0-th bit in the result.\n"
5085 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5086 " @result{} \"1010\"\n"
5087 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5088 " @result{} \"10110\"\n"
5090 #define FUNC_NAME s_scm_bit_extract
5092 unsigned long int istart
, iend
, bits
;
5093 istart
= scm_to_ulong (start
);
5094 iend
= scm_to_ulong (end
);
5095 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5097 /* how many bits to keep */
5098 bits
= iend
- istart
;
5100 if (SCM_I_INUMP (n
))
5102 scm_t_inum in
= SCM_I_INUM (n
);
5104 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5105 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5106 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5108 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5110 /* Since we emulate two's complement encoded numbers, this
5111 * special case requires us to produce a result that has
5112 * more bits than can be stored in a fixnum.
5114 SCM result
= scm_i_inum2big (in
);
5115 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5120 /* mask down to requisite bits */
5121 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5122 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5124 else if (SCM_BIGP (n
))
5129 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5133 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5134 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5135 such bits into a ulong. */
5136 result
= scm_i_mkbig ();
5137 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5138 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5139 result
= scm_i_normbig (result
);
5141 scm_remember_upto_here_1 (n
);
5145 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5150 static const char scm_logtab
[] = {
5151 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5154 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5156 "Return the number of bits in integer @var{n}. If integer is\n"
5157 "positive, the 1-bits in its binary representation are counted.\n"
5158 "If negative, the 0-bits in its two's-complement binary\n"
5159 "representation are counted. If 0, 0 is returned.\n"
5162 "(logcount #b10101010)\n"
5169 #define FUNC_NAME s_scm_logcount
5171 if (SCM_I_INUMP (n
))
5173 unsigned long c
= 0;
5174 scm_t_inum nn
= SCM_I_INUM (n
);
5179 c
+= scm_logtab
[15 & nn
];
5182 return SCM_I_MAKINUM (c
);
5184 else if (SCM_BIGP (n
))
5186 unsigned long count
;
5187 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5188 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5190 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5191 scm_remember_upto_here_1 (n
);
5192 return SCM_I_MAKINUM (count
);
5195 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5200 static const char scm_ilentab
[] = {
5201 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5205 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5207 "Return the number of bits necessary to represent @var{n}.\n"
5210 "(integer-length #b10101010)\n"
5212 "(integer-length 0)\n"
5214 "(integer-length #b1111)\n"
5217 #define FUNC_NAME s_scm_integer_length
5219 if (SCM_I_INUMP (n
))
5221 unsigned long c
= 0;
5223 scm_t_inum nn
= SCM_I_INUM (n
);
5229 l
= scm_ilentab
[15 & nn
];
5232 return SCM_I_MAKINUM (c
- 4 + l
);
5234 else if (SCM_BIGP (n
))
5236 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5237 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5238 1 too big, so check for that and adjust. */
5239 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5240 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5241 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5242 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5244 scm_remember_upto_here_1 (n
);
5245 return SCM_I_MAKINUM (size
);
5248 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5252 /*** NUMBERS -> STRINGS ***/
5253 #define SCM_MAX_DBL_PREC 60
5254 #define SCM_MAX_DBL_RADIX 36
5256 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5257 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5258 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5261 void init_dblprec(int *prec
, int radix
) {
5262 /* determine floating point precision by adding successively
5263 smaller increments to 1.0 until it is considered == 1.0 */
5264 double f
= ((double)1.0)/radix
;
5265 double fsum
= 1.0 + f
;
5270 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5282 void init_fx_radix(double *fx_list
, int radix
)
5284 /* initialize a per-radix list of tolerances. When added
5285 to a number < 1.0, we can determine if we should raund
5286 up and quit converting a number to a string. */
5290 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5291 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5294 /* use this array as a way to generate a single digit */
5295 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5298 idbl2str (double f
, char *a
, int radix
)
5300 int efmt
, dpt
, d
, i
, wp
;
5302 #ifdef DBL_MIN_10_EXP
5305 #endif /* DBL_MIN_10_EXP */
5310 radix
> SCM_MAX_DBL_RADIX
)
5312 /* revert to existing behavior */
5316 wp
= scm_dblprec
[radix
-2];
5317 fx
= fx_per_radix
[radix
-2];
5321 #ifdef HAVE_COPYSIGN
5322 double sgn
= copysign (1.0, f
);
5327 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5333 strcpy (a
, "-inf.0");
5335 strcpy (a
, "+inf.0");
5340 strcpy (a
, "+nan.0");
5350 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5351 make-uniform-vector, from causing infinite loops. */
5352 /* just do the checking...if it passes, we do the conversion for our
5353 radix again below */
5360 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5368 while (f_cpy
> 10.0)
5371 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5392 if (f
+ fx
[wp
] >= radix
)
5399 /* adding 9999 makes this equivalent to abs(x) % 3 */
5400 dpt
= (exp
+ 9999) % 3;
5404 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5426 a
[ch
++] = number_chars
[d
];
5429 if (f
+ fx
[wp
] >= 1.0)
5431 a
[ch
- 1] = number_chars
[d
+1];
5443 if ((dpt
> 4) && (exp
> 6))
5445 d
= (a
[0] == '-' ? 2 : 1);
5446 for (i
= ch
++; i
> d
; i
--)
5459 if (a
[ch
- 1] == '.')
5460 a
[ch
++] = '0'; /* trailing zero */
5469 for (i
= radix
; i
<= exp
; i
*= radix
);
5470 for (i
/= radix
; i
; i
/= radix
)
5472 a
[ch
++] = number_chars
[exp
/ i
];
5481 icmplx2str (double real
, double imag
, char *str
, int radix
)
5486 i
= idbl2str (real
, str
, radix
);
5487 #ifdef HAVE_COPYSIGN
5488 sgn
= copysign (1.0, imag
);
5492 /* Don't output a '+' for negative numbers or for Inf and
5493 NaN. They will provide their own sign. */
5494 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5496 i
+= idbl2str (imag
, &str
[i
], radix
);
5502 iflo2str (SCM flt
, char *str
, int radix
)
5505 if (SCM_REALP (flt
))
5506 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5508 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5513 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5514 characters in the result.
5516 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5518 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5523 return scm_iuint2str (-num
, rad
, p
) + 1;
5526 return scm_iuint2str (num
, rad
, p
);
5529 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5530 characters in the result.
5532 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5534 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5538 scm_t_uintmax n
= num
;
5540 if (rad
< 2 || rad
> 36)
5541 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5543 for (n
/= rad
; n
> 0; n
/= rad
)
5553 p
[i
] = number_chars
[d
];
5558 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5560 "Return a string holding the external representation of the\n"
5561 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5562 "inexact, a radix of 10 will be used.")
5563 #define FUNC_NAME s_scm_number_to_string
5567 if (SCM_UNBNDP (radix
))
5570 base
= scm_to_signed_integer (radix
, 2, 36);
5572 if (SCM_I_INUMP (n
))
5574 char num_buf
[SCM_INTBUFLEN
];
5575 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5576 return scm_from_locale_stringn (num_buf
, length
);
5578 else if (SCM_BIGP (n
))
5580 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5581 size_t len
= strlen (str
);
5582 void (*freefunc
) (void *, size_t);
5584 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5585 scm_remember_upto_here_1 (n
);
5586 ret
= scm_from_latin1_stringn (str
, len
);
5587 freefunc (str
, len
+ 1);
5590 else if (SCM_FRACTIONP (n
))
5592 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5593 scm_from_locale_string ("/"),
5594 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5596 else if (SCM_INEXACTP (n
))
5598 char num_buf
[FLOBUFLEN
];
5599 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5602 SCM_WRONG_TYPE_ARG (1, n
);
5607 /* These print routines used to be stubbed here so that scm_repl.c
5608 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5611 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5613 char num_buf
[FLOBUFLEN
];
5614 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5619 scm_i_print_double (double val
, SCM port
)
5621 char num_buf
[FLOBUFLEN
];
5622 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5626 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5629 char num_buf
[FLOBUFLEN
];
5630 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5635 scm_i_print_complex (double real
, double imag
, SCM port
)
5637 char num_buf
[FLOBUFLEN
];
5638 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5642 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5645 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5646 scm_display (str
, port
);
5647 scm_remember_upto_here_1 (str
);
5652 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5654 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5655 size_t len
= strlen (str
);
5656 void (*freefunc
) (void *, size_t);
5657 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5658 scm_remember_upto_here_1 (exp
);
5659 scm_lfwrite (str
, len
, port
);
5660 freefunc (str
, len
+ 1);
5663 /*** END nums->strs ***/
5666 /*** STRINGS -> NUMBERS ***/
5668 /* The following functions implement the conversion from strings to numbers.
5669 * The implementation somehow follows the grammar for numbers as it is given
5670 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5671 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5672 * points should be noted about the implementation:
5674 * * Each function keeps a local index variable 'idx' that points at the
5675 * current position within the parsed string. The global index is only
5676 * updated if the function could parse the corresponding syntactic unit
5679 * * Similarly, the functions keep track of indicators of inexactness ('#',
5680 * '.' or exponents) using local variables ('hash_seen', 'x').
5682 * * Sequences of digits are parsed into temporary variables holding fixnums.
5683 * Only if these fixnums would overflow, the result variables are updated
5684 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5685 * the temporary variables holding the fixnums are cleared, and the process
5686 * starts over again. If for example fixnums were able to store five decimal
5687 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5688 * and the result was computed as 12345 * 100000 + 67890. In other words,
5689 * only every five digits two bignum operations were performed.
5691 * Notes on the handling of exactness specifiers:
5693 * When parsing non-real complex numbers, we apply exactness specifiers on
5694 * per-component basis, as is done in PLT Scheme. For complex numbers
5695 * written in rectangular form, exactness specifiers are applied to the
5696 * real and imaginary parts before calling scm_make_rectangular. For
5697 * complex numbers written in polar form, exactness specifiers are applied
5698 * to the magnitude and angle before calling scm_make_polar.
5700 * There are two kinds of exactness specifiers: forced and implicit. A
5701 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5702 * the entire number, and applies to both components of a complex number.
5703 * "#e" causes each component to be made exact, and "#i" causes each
5704 * component to be made inexact. If no forced exactness specifier is
5705 * present, then the exactness of each component is determined
5706 * independently by the presence or absence of a decimal point or hash mark
5707 * within that component. If a decimal point or hash mark is present, the
5708 * component is made inexact, otherwise it is made exact.
5710 * After the exactness specifiers have been applied to each component, they
5711 * are passed to either scm_make_rectangular or scm_make_polar to produce
5712 * the final result. Note that this will result in a real number if the
5713 * imaginary part, magnitude, or angle is an exact 0.
5715 * For example, (string->number "#i5.0+0i") does the equivalent of:
5717 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5720 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5722 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5724 /* Caller is responsible for checking that the return value is in range
5725 for the given radix, which should be <= 36. */
5727 char_decimal_value (scm_t_uint32 c
)
5729 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5730 that's certainly above any valid decimal, so we take advantage of
5731 that to elide some tests. */
5732 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5734 /* If that failed, try extended hexadecimals, then. Only accept ascii
5739 if (c
>= (scm_t_uint32
) 'a')
5740 d
= c
- (scm_t_uint32
)'a' + 10U;
5745 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5746 in base RADIX. Upon success, return the unsigned integer and update
5747 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5749 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5750 unsigned int radix
, enum t_exactness
*p_exactness
)
5752 unsigned int idx
= *p_idx
;
5753 unsigned int hash_seen
= 0;
5754 scm_t_bits shift
= 1;
5756 unsigned int digit_value
;
5759 size_t len
= scm_i_string_length (mem
);
5764 c
= scm_i_string_ref (mem
, idx
);
5765 digit_value
= char_decimal_value (c
);
5766 if (digit_value
>= radix
)
5770 result
= SCM_I_MAKINUM (digit_value
);
5773 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5783 digit_value
= char_decimal_value (c
);
5784 /* This check catches non-decimals in addition to out-of-range
5786 if (digit_value
>= radix
)
5791 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5793 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5795 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5802 shift
= shift
* radix
;
5803 add
= add
* radix
+ digit_value
;
5808 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5810 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5814 *p_exactness
= INEXACT
;
5820 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5821 * covers the parts of the rules that start at a potential point. The value
5822 * of the digits up to the point have been parsed by the caller and are given
5823 * in variable result. The content of *p_exactness indicates, whether a hash
5824 * has already been seen in the digits before the point.
5827 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5830 mem2decimal_from_point (SCM result
, SCM mem
,
5831 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5833 unsigned int idx
= *p_idx
;
5834 enum t_exactness x
= *p_exactness
;
5835 size_t len
= scm_i_string_length (mem
);
5840 if (scm_i_string_ref (mem
, idx
) == '.')
5842 scm_t_bits shift
= 1;
5844 unsigned int digit_value
;
5845 SCM big_shift
= SCM_INUM1
;
5850 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5851 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5856 digit_value
= DIGIT2UINT (c
);
5867 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5869 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5870 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5872 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5880 add
= add
* 10 + digit_value
;
5886 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5887 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5888 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5891 result
= scm_divide (result
, big_shift
);
5893 /* We've seen a decimal point, thus the value is implicitly inexact. */
5905 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5907 switch (scm_i_string_ref (mem
, idx
))
5919 c
= scm_i_string_ref (mem
, idx
);
5927 c
= scm_i_string_ref (mem
, idx
);
5936 c
= scm_i_string_ref (mem
, idx
);
5941 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5945 exponent
= DIGIT2UINT (c
);
5948 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5949 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5952 if (exponent
<= SCM_MAXEXP
)
5953 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5959 if (exponent
> SCM_MAXEXP
)
5961 size_t exp_len
= idx
- start
;
5962 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5963 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5964 scm_out_of_range ("string->number", exp_num
);
5967 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5969 result
= scm_product (result
, e
);
5971 result
= scm_divide (result
, e
);
5973 /* We've seen an exponent, thus the value is implicitly inexact. */
5991 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5994 mem2ureal (SCM mem
, unsigned int *p_idx
,
5995 unsigned int radix
, enum t_exactness forced_x
,
5996 int allow_inf_or_nan
)
5998 unsigned int idx
= *p_idx
;
6000 size_t len
= scm_i_string_length (mem
);
6002 /* Start off believing that the number will be exact. This changes
6003 to INEXACT if we see a decimal point or a hash. */
6004 enum t_exactness implicit_x
= EXACT
;
6009 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6010 switch (scm_i_string_ref (mem
, idx
))
6013 switch (scm_i_string_ref (mem
, idx
+ 1))
6016 switch (scm_i_string_ref (mem
, idx
+ 2))
6019 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6020 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6028 switch (scm_i_string_ref (mem
, idx
+ 1))
6031 switch (scm_i_string_ref (mem
, idx
+ 2))
6034 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6036 /* Cobble up the fractional part. We might want to
6037 set the NaN's mantissa from it. */
6039 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6042 #if SCM_ENABLE_DEPRECATED == 1
6043 scm_c_issue_deprecation_warning
6044 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6057 if (scm_i_string_ref (mem
, idx
) == '.')
6061 else if (idx
+ 1 == len
)
6063 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6066 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6067 p_idx
, &implicit_x
);
6073 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6074 if (scm_is_false (uinteger
))
6079 else if (scm_i_string_ref (mem
, idx
) == '/')
6087 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6088 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6091 /* both are int/big here, I assume */
6092 result
= scm_i_make_ratio (uinteger
, divisor
);
6094 else if (radix
== 10)
6096 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6097 if (scm_is_false (result
))
6109 if (SCM_INEXACTP (result
))
6110 return scm_inexact_to_exact (result
);
6114 if (SCM_INEXACTP (result
))
6117 return scm_exact_to_inexact (result
);
6119 if (implicit_x
== INEXACT
)
6121 if (SCM_INEXACTP (result
))
6124 return scm_exact_to_inexact (result
);
6130 /* We should never get here */
6131 scm_syserror ("mem2ureal");
6135 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6138 mem2complex (SCM mem
, unsigned int idx
,
6139 unsigned int radix
, enum t_exactness forced_x
)
6144 size_t len
= scm_i_string_length (mem
);
6149 c
= scm_i_string_ref (mem
, idx
);
6164 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6165 if (scm_is_false (ureal
))
6167 /* input must be either +i or -i */
6172 if (scm_i_string_ref (mem
, idx
) == 'i'
6173 || scm_i_string_ref (mem
, idx
) == 'I')
6179 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6186 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6187 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6192 c
= scm_i_string_ref (mem
, idx
);
6196 /* either +<ureal>i or -<ureal>i */
6203 return scm_make_rectangular (SCM_INUM0
, ureal
);
6206 /* polar input: <real>@<real>. */
6217 c
= scm_i_string_ref (mem
, idx
);
6235 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6236 if (scm_is_false (angle
))
6241 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6242 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6244 result
= scm_make_polar (ureal
, angle
);
6249 /* expecting input matching <real>[+-]<ureal>?i */
6256 int sign
= (c
== '+') ? 1 : -1;
6257 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6259 if (scm_is_false (imag
))
6260 imag
= SCM_I_MAKINUM (sign
);
6261 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6262 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6266 if (scm_i_string_ref (mem
, idx
) != 'i'
6267 && scm_i_string_ref (mem
, idx
) != 'I')
6274 return scm_make_rectangular (ureal
, imag
);
6283 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6285 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6288 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6290 unsigned int idx
= 0;
6291 unsigned int radix
= NO_RADIX
;
6292 enum t_exactness forced_x
= NO_EXACTNESS
;
6293 size_t len
= scm_i_string_length (mem
);
6295 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6296 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6298 switch (scm_i_string_ref (mem
, idx
+ 1))
6301 if (radix
!= NO_RADIX
)
6306 if (radix
!= NO_RADIX
)
6311 if (forced_x
!= NO_EXACTNESS
)
6316 if (forced_x
!= NO_EXACTNESS
)
6321 if (radix
!= NO_RADIX
)
6326 if (radix
!= NO_RADIX
)
6336 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6337 if (radix
== NO_RADIX
)
6338 radix
= default_radix
;
6340 return mem2complex (mem
, idx
, radix
, forced_x
);
6344 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6345 unsigned int default_radix
)
6347 SCM str
= scm_from_locale_stringn (mem
, len
);
6349 return scm_i_string_to_number (str
, default_radix
);
6353 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6354 (SCM string
, SCM radix
),
6355 "Return a number of the maximally precise representation\n"
6356 "expressed by the given @var{string}. @var{radix} must be an\n"
6357 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6358 "is a default radix that may be overridden by an explicit radix\n"
6359 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6360 "supplied, then the default radix is 10. If string is not a\n"
6361 "syntactically valid notation for a number, then\n"
6362 "@code{string->number} returns @code{#f}.")
6363 #define FUNC_NAME s_scm_string_to_number
6367 SCM_VALIDATE_STRING (1, string
);
6369 if (SCM_UNBNDP (radix
))
6372 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6374 answer
= scm_i_string_to_number (string
, base
);
6375 scm_remember_upto_here_1 (string
);
6381 /*** END strs->nums ***/
6384 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6386 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6388 #define FUNC_NAME s_scm_number_p
6390 return scm_from_bool (SCM_NUMBERP (x
));
6394 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6396 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6397 "otherwise. Note that the sets of real, rational and integer\n"
6398 "values form subsets of the set of complex numbers, i. e. the\n"
6399 "predicate will also be fulfilled if @var{x} is a real,\n"
6400 "rational or integer number.")
6401 #define FUNC_NAME s_scm_complex_p
6403 /* all numbers are complex. */
6404 return scm_number_p (x
);
6408 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6410 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6411 "otherwise. Note that the set of integer values forms a subset of\n"
6412 "the set of real numbers, i. e. the predicate will also be\n"
6413 "fulfilled if @var{x} is an integer number.")
6414 #define FUNC_NAME s_scm_real_p
6416 return scm_from_bool
6417 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6421 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6423 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6424 "otherwise. Note that the set of integer values forms a subset of\n"
6425 "the set of rational numbers, i. e. the predicate will also be\n"
6426 "fulfilled if @var{x} is an integer number.")
6427 #define FUNC_NAME s_scm_rational_p
6429 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6431 else if (SCM_REALP (x
))
6432 /* due to their limited precision, finite floating point numbers are
6433 rational as well. (finite means neither infinity nor a NaN) */
6434 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6440 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6442 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6444 #define FUNC_NAME s_scm_integer_p
6446 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6448 else if (SCM_REALP (x
))
6450 double val
= SCM_REAL_VALUE (x
);
6451 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6459 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6460 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6461 (SCM x
, SCM y
, SCM rest
),
6462 "Return @code{#t} if all parameters are numerically equal.")
6463 #define FUNC_NAME s_scm_i_num_eq_p
6465 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6467 while (!scm_is_null (rest
))
6469 if (scm_is_false (scm_num_eq_p (x
, y
)))
6473 rest
= scm_cdr (rest
);
6475 return scm_num_eq_p (x
, y
);
6479 scm_num_eq_p (SCM x
, SCM y
)
6482 if (SCM_I_INUMP (x
))
6484 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6485 if (SCM_I_INUMP (y
))
6487 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6488 return scm_from_bool (xx
== yy
);
6490 else if (SCM_BIGP (y
))
6492 else if (SCM_REALP (y
))
6494 /* On a 32-bit system an inum fits a double, we can cast the inum
6495 to a double and compare.
6497 But on a 64-bit system an inum is bigger than a double and
6498 casting it to a double (call that dxx) will round. dxx is at
6499 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6500 an integer and fits a long. So we cast yy to a long and
6501 compare with plain xx.
6503 An alternative (for any size system actually) would be to check
6504 yy is an integer (with floor) and is in range of an inum
6505 (compare against appropriate powers of 2) then test
6506 xx==(scm_t_signed_bits)yy. It's just a matter of which
6507 casts/comparisons might be fastest or easiest for the cpu. */
6509 double yy
= SCM_REAL_VALUE (y
);
6510 return scm_from_bool ((double) xx
== yy
6511 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6512 || xx
== (scm_t_signed_bits
) yy
));
6514 else if (SCM_COMPLEXP (y
))
6515 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6516 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6517 else if (SCM_FRACTIONP (y
))
6520 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6522 else if (SCM_BIGP (x
))
6524 if (SCM_I_INUMP (y
))
6526 else if (SCM_BIGP (y
))
6528 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6529 scm_remember_upto_here_2 (x
, y
);
6530 return scm_from_bool (0 == cmp
);
6532 else if (SCM_REALP (y
))
6535 if (isnan (SCM_REAL_VALUE (y
)))
6537 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6538 scm_remember_upto_here_1 (x
);
6539 return scm_from_bool (0 == cmp
);
6541 else if (SCM_COMPLEXP (y
))
6544 if (0.0 != SCM_COMPLEX_IMAG (y
))
6546 if (isnan (SCM_COMPLEX_REAL (y
)))
6548 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6549 scm_remember_upto_here_1 (x
);
6550 return scm_from_bool (0 == cmp
);
6552 else if (SCM_FRACTIONP (y
))
6555 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6557 else if (SCM_REALP (x
))
6559 double xx
= SCM_REAL_VALUE (x
);
6560 if (SCM_I_INUMP (y
))
6562 /* see comments with inum/real above */
6563 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6564 return scm_from_bool (xx
== (double) yy
6565 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6566 || (scm_t_signed_bits
) xx
== yy
));
6568 else if (SCM_BIGP (y
))
6571 if (isnan (SCM_REAL_VALUE (x
)))
6573 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6574 scm_remember_upto_here_1 (y
);
6575 return scm_from_bool (0 == cmp
);
6577 else if (SCM_REALP (y
))
6578 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6579 else if (SCM_COMPLEXP (y
))
6580 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6581 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6582 else if (SCM_FRACTIONP (y
))
6584 double xx
= SCM_REAL_VALUE (x
);
6588 return scm_from_bool (xx
< 0.0);
6589 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6593 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6595 else if (SCM_COMPLEXP (x
))
6597 if (SCM_I_INUMP (y
))
6598 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6599 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6600 else if (SCM_BIGP (y
))
6603 if (0.0 != SCM_COMPLEX_IMAG (x
))
6605 if (isnan (SCM_COMPLEX_REAL (x
)))
6607 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6608 scm_remember_upto_here_1 (y
);
6609 return scm_from_bool (0 == cmp
);
6611 else if (SCM_REALP (y
))
6612 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6613 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6614 else if (SCM_COMPLEXP (y
))
6615 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6616 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6617 else if (SCM_FRACTIONP (y
))
6620 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6622 xx
= SCM_COMPLEX_REAL (x
);
6626 return scm_from_bool (xx
< 0.0);
6627 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6631 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6633 else if (SCM_FRACTIONP (x
))
6635 if (SCM_I_INUMP (y
))
6637 else if (SCM_BIGP (y
))
6639 else if (SCM_REALP (y
))
6641 double yy
= SCM_REAL_VALUE (y
);
6645 return scm_from_bool (0.0 < yy
);
6646 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6649 else if (SCM_COMPLEXP (y
))
6652 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6654 yy
= SCM_COMPLEX_REAL (y
);
6658 return scm_from_bool (0.0 < yy
);
6659 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6662 else if (SCM_FRACTIONP (y
))
6663 return scm_i_fraction_equalp (x
, y
);
6665 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6668 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6672 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6673 done are good for inums, but for bignums an answer can almost always be
6674 had by just examining a few high bits of the operands, as done by GMP in
6675 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6676 of the float exponent to take into account. */
6678 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6679 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6680 (SCM x
, SCM y
, SCM rest
),
6681 "Return @code{#t} if the list of parameters is monotonically\n"
6683 #define FUNC_NAME s_scm_i_num_less_p
6685 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6687 while (!scm_is_null (rest
))
6689 if (scm_is_false (scm_less_p (x
, y
)))
6693 rest
= scm_cdr (rest
);
6695 return scm_less_p (x
, y
);
6699 scm_less_p (SCM x
, SCM y
)
6702 if (SCM_I_INUMP (x
))
6704 scm_t_inum xx
= SCM_I_INUM (x
);
6705 if (SCM_I_INUMP (y
))
6707 scm_t_inum yy
= SCM_I_INUM (y
);
6708 return scm_from_bool (xx
< yy
);
6710 else if (SCM_BIGP (y
))
6712 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6713 scm_remember_upto_here_1 (y
);
6714 return scm_from_bool (sgn
> 0);
6716 else if (SCM_REALP (y
))
6717 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6718 else if (SCM_FRACTIONP (y
))
6720 /* "x < a/b" becomes "x*b < a" */
6722 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6723 y
= SCM_FRACTION_NUMERATOR (y
);
6727 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6729 else if (SCM_BIGP (x
))
6731 if (SCM_I_INUMP (y
))
6733 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6734 scm_remember_upto_here_1 (x
);
6735 return scm_from_bool (sgn
< 0);
6737 else if (SCM_BIGP (y
))
6739 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6740 scm_remember_upto_here_2 (x
, y
);
6741 return scm_from_bool (cmp
< 0);
6743 else if (SCM_REALP (y
))
6746 if (isnan (SCM_REAL_VALUE (y
)))
6748 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6749 scm_remember_upto_here_1 (x
);
6750 return scm_from_bool (cmp
< 0);
6752 else if (SCM_FRACTIONP (y
))
6755 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6757 else if (SCM_REALP (x
))
6759 if (SCM_I_INUMP (y
))
6760 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6761 else if (SCM_BIGP (y
))
6764 if (isnan (SCM_REAL_VALUE (x
)))
6766 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6767 scm_remember_upto_here_1 (y
);
6768 return scm_from_bool (cmp
> 0);
6770 else if (SCM_REALP (y
))
6771 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6772 else if (SCM_FRACTIONP (y
))
6774 double xx
= SCM_REAL_VALUE (x
);
6778 return scm_from_bool (xx
< 0.0);
6779 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6783 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6785 else if (SCM_FRACTIONP (x
))
6787 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6789 /* "a/b < y" becomes "a < y*b" */
6790 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6791 x
= SCM_FRACTION_NUMERATOR (x
);
6794 else if (SCM_REALP (y
))
6796 double yy
= SCM_REAL_VALUE (y
);
6800 return scm_from_bool (0.0 < yy
);
6801 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6804 else if (SCM_FRACTIONP (y
))
6806 /* "a/b < c/d" becomes "a*d < c*b" */
6807 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6808 SCM_FRACTION_DENOMINATOR (y
));
6809 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6810 SCM_FRACTION_DENOMINATOR (x
));
6816 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6819 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6823 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6824 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6825 (SCM x
, SCM y
, SCM rest
),
6826 "Return @code{#t} if the list of parameters is monotonically\n"
6828 #define FUNC_NAME s_scm_i_num_gr_p
6830 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6832 while (!scm_is_null (rest
))
6834 if (scm_is_false (scm_gr_p (x
, y
)))
6838 rest
= scm_cdr (rest
);
6840 return scm_gr_p (x
, y
);
6843 #define FUNC_NAME s_scm_i_num_gr_p
6845 scm_gr_p (SCM x
, SCM y
)
6847 if (!SCM_NUMBERP (x
))
6848 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6849 else if (!SCM_NUMBERP (y
))
6850 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6852 return scm_less_p (y
, x
);
6857 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6858 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6859 (SCM x
, SCM y
, SCM rest
),
6860 "Return @code{#t} if the list of parameters is monotonically\n"
6862 #define FUNC_NAME s_scm_i_num_leq_p
6864 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6866 while (!scm_is_null (rest
))
6868 if (scm_is_false (scm_leq_p (x
, y
)))
6872 rest
= scm_cdr (rest
);
6874 return scm_leq_p (x
, y
);
6877 #define FUNC_NAME s_scm_i_num_leq_p
6879 scm_leq_p (SCM x
, SCM y
)
6881 if (!SCM_NUMBERP (x
))
6882 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6883 else if (!SCM_NUMBERP (y
))
6884 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6885 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6888 return scm_not (scm_less_p (y
, x
));
6893 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6894 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6895 (SCM x
, SCM y
, SCM rest
),
6896 "Return @code{#t} if the list of parameters is monotonically\n"
6898 #define FUNC_NAME s_scm_i_num_geq_p
6900 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6902 while (!scm_is_null (rest
))
6904 if (scm_is_false (scm_geq_p (x
, y
)))
6908 rest
= scm_cdr (rest
);
6910 return scm_geq_p (x
, y
);
6913 #define FUNC_NAME s_scm_i_num_geq_p
6915 scm_geq_p (SCM x
, SCM y
)
6917 if (!SCM_NUMBERP (x
))
6918 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6919 else if (!SCM_NUMBERP (y
))
6920 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6921 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6924 return scm_not (scm_less_p (x
, y
));
6929 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6931 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6933 #define FUNC_NAME s_scm_zero_p
6935 if (SCM_I_INUMP (z
))
6936 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6937 else if (SCM_BIGP (z
))
6939 else if (SCM_REALP (z
))
6940 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6941 else if (SCM_COMPLEXP (z
))
6942 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6943 && SCM_COMPLEX_IMAG (z
) == 0.0);
6944 else if (SCM_FRACTIONP (z
))
6947 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6952 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6954 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6956 #define FUNC_NAME s_scm_positive_p
6958 if (SCM_I_INUMP (x
))
6959 return scm_from_bool (SCM_I_INUM (x
) > 0);
6960 else if (SCM_BIGP (x
))
6962 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6963 scm_remember_upto_here_1 (x
);
6964 return scm_from_bool (sgn
> 0);
6966 else if (SCM_REALP (x
))
6967 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6968 else if (SCM_FRACTIONP (x
))
6969 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6971 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6976 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6978 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6980 #define FUNC_NAME s_scm_negative_p
6982 if (SCM_I_INUMP (x
))
6983 return scm_from_bool (SCM_I_INUM (x
) < 0);
6984 else if (SCM_BIGP (x
))
6986 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6987 scm_remember_upto_here_1 (x
);
6988 return scm_from_bool (sgn
< 0);
6990 else if (SCM_REALP (x
))
6991 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6992 else if (SCM_FRACTIONP (x
))
6993 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6995 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7000 /* scm_min and scm_max return an inexact when either argument is inexact, as
7001 required by r5rs. On that basis, for exact/inexact combinations the
7002 exact is converted to inexact to compare and possibly return. This is
7003 unlike scm_less_p above which takes some trouble to preserve all bits in
7004 its test, such trouble is not required for min and max. */
7006 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7007 (SCM x
, SCM y
, SCM rest
),
7008 "Return the maximum of all parameter values.")
7009 #define FUNC_NAME s_scm_i_max
7011 while (!scm_is_null (rest
))
7012 { x
= scm_max (x
, y
);
7014 rest
= scm_cdr (rest
);
7016 return scm_max (x
, y
);
7020 #define s_max s_scm_i_max
7021 #define g_max g_scm_i_max
7024 scm_max (SCM x
, SCM y
)
7029 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7030 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7033 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7036 if (SCM_I_INUMP (x
))
7038 scm_t_inum xx
= SCM_I_INUM (x
);
7039 if (SCM_I_INUMP (y
))
7041 scm_t_inum yy
= SCM_I_INUM (y
);
7042 return (xx
< yy
) ? y
: x
;
7044 else if (SCM_BIGP (y
))
7046 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7047 scm_remember_upto_here_1 (y
);
7048 return (sgn
< 0) ? x
: y
;
7050 else if (SCM_REALP (y
))
7053 double yyd
= SCM_REAL_VALUE (y
);
7056 return scm_from_double (xxd
);
7057 /* If y is a NaN, then "==" is false and we return the NaN */
7058 else if (SCM_LIKELY (!(xxd
== yyd
)))
7060 /* Handle signed zeroes properly */
7066 else if (SCM_FRACTIONP (y
))
7069 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7072 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7074 else if (SCM_BIGP (x
))
7076 if (SCM_I_INUMP (y
))
7078 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7079 scm_remember_upto_here_1 (x
);
7080 return (sgn
< 0) ? y
: x
;
7082 else if (SCM_BIGP (y
))
7084 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7085 scm_remember_upto_here_2 (x
, y
);
7086 return (cmp
> 0) ? x
: y
;
7088 else if (SCM_REALP (y
))
7090 /* if y==NaN then xx>yy is false, so we return the NaN y */
7093 xx
= scm_i_big2dbl (x
);
7094 yy
= SCM_REAL_VALUE (y
);
7095 return (xx
> yy
? scm_from_double (xx
) : y
);
7097 else if (SCM_FRACTIONP (y
))
7102 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7104 else if (SCM_REALP (x
))
7106 if (SCM_I_INUMP (y
))
7108 scm_t_inum yy
= SCM_I_INUM (y
);
7109 double xxd
= SCM_REAL_VALUE (x
);
7113 return scm_from_double (yyd
);
7114 /* If x is a NaN, then "==" is false and we return the NaN */
7115 else if (SCM_LIKELY (!(xxd
== yyd
)))
7117 /* Handle signed zeroes properly */
7123 else if (SCM_BIGP (y
))
7128 else if (SCM_REALP (y
))
7130 double xx
= SCM_REAL_VALUE (x
);
7131 double yy
= SCM_REAL_VALUE (y
);
7133 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7136 else if (SCM_LIKELY (xx
< yy
))
7138 /* If neither (xx > yy) nor (xx < yy), then
7139 either they're equal or one is a NaN */
7140 else if (SCM_UNLIKELY (isnan (xx
)))
7141 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7142 else if (SCM_UNLIKELY (isnan (yy
)))
7143 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7144 /* xx == yy, but handle signed zeroes properly */
7145 else if (double_is_non_negative_zero (yy
))
7150 else if (SCM_FRACTIONP (y
))
7152 double yy
= scm_i_fraction2double (y
);
7153 double xx
= SCM_REAL_VALUE (x
);
7154 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7157 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7159 else if (SCM_FRACTIONP (x
))
7161 if (SCM_I_INUMP (y
))
7165 else if (SCM_BIGP (y
))
7169 else if (SCM_REALP (y
))
7171 double xx
= scm_i_fraction2double (x
);
7172 /* if y==NaN then ">" is false, so we return the NaN y */
7173 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7175 else if (SCM_FRACTIONP (y
))
7180 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7183 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7187 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7188 (SCM x
, SCM y
, SCM rest
),
7189 "Return the minimum of all parameter values.")
7190 #define FUNC_NAME s_scm_i_min
7192 while (!scm_is_null (rest
))
7193 { x
= scm_min (x
, y
);
7195 rest
= scm_cdr (rest
);
7197 return scm_min (x
, y
);
7201 #define s_min s_scm_i_min
7202 #define g_min g_scm_i_min
7205 scm_min (SCM x
, SCM y
)
7210 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7211 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7214 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7217 if (SCM_I_INUMP (x
))
7219 scm_t_inum xx
= SCM_I_INUM (x
);
7220 if (SCM_I_INUMP (y
))
7222 scm_t_inum yy
= SCM_I_INUM (y
);
7223 return (xx
< yy
) ? x
: y
;
7225 else if (SCM_BIGP (y
))
7227 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7228 scm_remember_upto_here_1 (y
);
7229 return (sgn
< 0) ? y
: x
;
7231 else if (SCM_REALP (y
))
7234 /* if y==NaN then "<" is false and we return NaN */
7235 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7237 else if (SCM_FRACTIONP (y
))
7240 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7243 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7245 else if (SCM_BIGP (x
))
7247 if (SCM_I_INUMP (y
))
7249 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7250 scm_remember_upto_here_1 (x
);
7251 return (sgn
< 0) ? x
: y
;
7253 else if (SCM_BIGP (y
))
7255 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7256 scm_remember_upto_here_2 (x
, y
);
7257 return (cmp
> 0) ? y
: x
;
7259 else if (SCM_REALP (y
))
7261 /* if y==NaN then xx<yy is false, so we return the NaN y */
7264 xx
= scm_i_big2dbl (x
);
7265 yy
= SCM_REAL_VALUE (y
);
7266 return (xx
< yy
? scm_from_double (xx
) : y
);
7268 else if (SCM_FRACTIONP (y
))
7273 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7275 else if (SCM_REALP (x
))
7277 if (SCM_I_INUMP (y
))
7279 double z
= SCM_I_INUM (y
);
7280 /* if x==NaN then "<" is false and we return NaN */
7281 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7283 else if (SCM_BIGP (y
))
7288 else if (SCM_REALP (y
))
7290 double xx
= SCM_REAL_VALUE (x
);
7291 double yy
= SCM_REAL_VALUE (y
);
7293 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7296 else if (SCM_LIKELY (xx
> yy
))
7298 /* If neither (xx < yy) nor (xx > yy), then
7299 either they're equal or one is a NaN */
7300 else if (SCM_UNLIKELY (isnan (xx
)))
7301 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7302 else if (SCM_UNLIKELY (isnan (yy
)))
7303 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7304 /* xx == yy, but handle signed zeroes properly */
7305 else if (double_is_non_negative_zero (xx
))
7310 else if (SCM_FRACTIONP (y
))
7312 double yy
= scm_i_fraction2double (y
);
7313 double xx
= SCM_REAL_VALUE (x
);
7314 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7317 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7319 else if (SCM_FRACTIONP (x
))
7321 if (SCM_I_INUMP (y
))
7325 else if (SCM_BIGP (y
))
7329 else if (SCM_REALP (y
))
7331 double xx
= scm_i_fraction2double (x
);
7332 /* if y==NaN then "<" is false, so we return the NaN y */
7333 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7335 else if (SCM_FRACTIONP (y
))
7340 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7343 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7347 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7348 (SCM x
, SCM y
, SCM rest
),
7349 "Return the sum of all parameter values. Return 0 if called without\n"
7351 #define FUNC_NAME s_scm_i_sum
7353 while (!scm_is_null (rest
))
7354 { x
= scm_sum (x
, y
);
7356 rest
= scm_cdr (rest
);
7358 return scm_sum (x
, y
);
7362 #define s_sum s_scm_i_sum
7363 #define g_sum g_scm_i_sum
7366 scm_sum (SCM x
, SCM y
)
7368 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7370 if (SCM_NUMBERP (x
)) return x
;
7371 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7372 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7375 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7377 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7379 scm_t_inum xx
= SCM_I_INUM (x
);
7380 scm_t_inum yy
= SCM_I_INUM (y
);
7381 scm_t_inum z
= xx
+ yy
;
7382 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7384 else if (SCM_BIGP (y
))
7389 else if (SCM_REALP (y
))
7391 scm_t_inum xx
= SCM_I_INUM (x
);
7392 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7394 else if (SCM_COMPLEXP (y
))
7396 scm_t_inum xx
= SCM_I_INUM (x
);
7397 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7398 SCM_COMPLEX_IMAG (y
));
7400 else if (SCM_FRACTIONP (y
))
7401 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7402 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7403 SCM_FRACTION_DENOMINATOR (y
));
7405 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7406 } else if (SCM_BIGP (x
))
7408 if (SCM_I_INUMP (y
))
7413 inum
= SCM_I_INUM (y
);
7416 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7419 SCM result
= scm_i_mkbig ();
7420 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7421 scm_remember_upto_here_1 (x
);
7422 /* we know the result will have to be a bignum */
7425 return scm_i_normbig (result
);
7429 SCM result
= scm_i_mkbig ();
7430 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7431 scm_remember_upto_here_1 (x
);
7432 /* we know the result will have to be a bignum */
7435 return scm_i_normbig (result
);
7438 else if (SCM_BIGP (y
))
7440 SCM result
= scm_i_mkbig ();
7441 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7442 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7443 mpz_add (SCM_I_BIG_MPZ (result
),
7446 scm_remember_upto_here_2 (x
, y
);
7447 /* we know the result will have to be a bignum */
7450 return scm_i_normbig (result
);
7452 else if (SCM_REALP (y
))
7454 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7455 scm_remember_upto_here_1 (x
);
7456 return scm_from_double (result
);
7458 else if (SCM_COMPLEXP (y
))
7460 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7461 + SCM_COMPLEX_REAL (y
));
7462 scm_remember_upto_here_1 (x
);
7463 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7465 else if (SCM_FRACTIONP (y
))
7466 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7467 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7468 SCM_FRACTION_DENOMINATOR (y
));
7470 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7472 else if (SCM_REALP (x
))
7474 if (SCM_I_INUMP (y
))
7475 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7476 else if (SCM_BIGP (y
))
7478 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7479 scm_remember_upto_here_1 (y
);
7480 return scm_from_double (result
);
7482 else if (SCM_REALP (y
))
7483 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7484 else if (SCM_COMPLEXP (y
))
7485 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7486 SCM_COMPLEX_IMAG (y
));
7487 else if (SCM_FRACTIONP (y
))
7488 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7490 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7492 else if (SCM_COMPLEXP (x
))
7494 if (SCM_I_INUMP (y
))
7495 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7496 SCM_COMPLEX_IMAG (x
));
7497 else if (SCM_BIGP (y
))
7499 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7500 + SCM_COMPLEX_REAL (x
));
7501 scm_remember_upto_here_1 (y
);
7502 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7504 else if (SCM_REALP (y
))
7505 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7506 SCM_COMPLEX_IMAG (x
));
7507 else if (SCM_COMPLEXP (y
))
7508 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7509 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7510 else if (SCM_FRACTIONP (y
))
7511 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7512 SCM_COMPLEX_IMAG (x
));
7514 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7516 else if (SCM_FRACTIONP (x
))
7518 if (SCM_I_INUMP (y
))
7519 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7520 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7521 SCM_FRACTION_DENOMINATOR (x
));
7522 else if (SCM_BIGP (y
))
7523 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7524 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7525 SCM_FRACTION_DENOMINATOR (x
));
7526 else if (SCM_REALP (y
))
7527 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7528 else if (SCM_COMPLEXP (y
))
7529 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7530 SCM_COMPLEX_IMAG (y
));
7531 else if (SCM_FRACTIONP (y
))
7532 /* a/b + c/d = (ad + bc) / bd */
7533 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7534 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7535 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7537 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7540 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7544 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7546 "Return @math{@var{x}+1}.")
7547 #define FUNC_NAME s_scm_oneplus
7549 return scm_sum (x
, SCM_INUM1
);
7554 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7555 (SCM x
, SCM y
, SCM rest
),
7556 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7557 "the sum of all but the first argument are subtracted from the first\n"
7559 #define FUNC_NAME s_scm_i_difference
7561 while (!scm_is_null (rest
))
7562 { x
= scm_difference (x
, y
);
7564 rest
= scm_cdr (rest
);
7566 return scm_difference (x
, y
);
7570 #define s_difference s_scm_i_difference
7571 #define g_difference g_scm_i_difference
7574 scm_difference (SCM x
, SCM y
)
7575 #define FUNC_NAME s_difference
7577 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7580 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7582 if (SCM_I_INUMP (x
))
7584 scm_t_inum xx
= -SCM_I_INUM (x
);
7585 if (SCM_FIXABLE (xx
))
7586 return SCM_I_MAKINUM (xx
);
7588 return scm_i_inum2big (xx
);
7590 else if (SCM_BIGP (x
))
7591 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7592 bignum, but negating that gives a fixnum. */
7593 return scm_i_normbig (scm_i_clonebig (x
, 0));
7594 else if (SCM_REALP (x
))
7595 return scm_from_double (-SCM_REAL_VALUE (x
));
7596 else if (SCM_COMPLEXP (x
))
7597 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7598 -SCM_COMPLEX_IMAG (x
));
7599 else if (SCM_FRACTIONP (x
))
7600 return scm_i_make_ratio_already_reduced
7601 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7602 SCM_FRACTION_DENOMINATOR (x
));
7604 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7607 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7609 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7611 scm_t_inum xx
= SCM_I_INUM (x
);
7612 scm_t_inum yy
= SCM_I_INUM (y
);
7613 scm_t_inum z
= xx
- yy
;
7614 if (SCM_FIXABLE (z
))
7615 return SCM_I_MAKINUM (z
);
7617 return scm_i_inum2big (z
);
7619 else if (SCM_BIGP (y
))
7621 /* inum-x - big-y */
7622 scm_t_inum xx
= SCM_I_INUM (x
);
7626 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7627 bignum, but negating that gives a fixnum. */
7628 return scm_i_normbig (scm_i_clonebig (y
, 0));
7632 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7633 SCM result
= scm_i_mkbig ();
7636 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7639 /* x - y == -(y + -x) */
7640 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7641 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7643 scm_remember_upto_here_1 (y
);
7645 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7646 /* we know the result will have to be a bignum */
7649 return scm_i_normbig (result
);
7652 else if (SCM_REALP (y
))
7654 scm_t_inum xx
= SCM_I_INUM (x
);
7657 * We need to handle x == exact 0
7658 * specially because R6RS states that:
7659 * (- 0.0) ==> -0.0 and
7660 * (- 0.0 0.0) ==> 0.0
7661 * and the scheme compiler changes
7662 * (- 0.0) into (- 0 0.0)
7663 * So we need to treat (- 0 0.0) like (- 0.0).
7664 * At the C level, (-x) is different than (0.0 - x).
7665 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7668 return scm_from_double (- SCM_REAL_VALUE (y
));
7670 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7672 else if (SCM_COMPLEXP (y
))
7674 scm_t_inum xx
= SCM_I_INUM (x
);
7676 /* We need to handle x == exact 0 specially.
7677 See the comment above (for SCM_REALP (y)) */
7679 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7680 - SCM_COMPLEX_IMAG (y
));
7682 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7683 - SCM_COMPLEX_IMAG (y
));
7685 else if (SCM_FRACTIONP (y
))
7686 /* a - b/c = (ac - b) / c */
7687 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7688 SCM_FRACTION_NUMERATOR (y
)),
7689 SCM_FRACTION_DENOMINATOR (y
));
7691 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7693 else if (SCM_BIGP (x
))
7695 if (SCM_I_INUMP (y
))
7697 /* big-x - inum-y */
7698 scm_t_inum yy
= SCM_I_INUM (y
);
7699 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7701 scm_remember_upto_here_1 (x
);
7703 return (SCM_FIXABLE (-yy
) ?
7704 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7707 SCM result
= scm_i_mkbig ();
7710 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7712 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7713 scm_remember_upto_here_1 (x
);
7715 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7716 /* we know the result will have to be a bignum */
7719 return scm_i_normbig (result
);
7722 else if (SCM_BIGP (y
))
7724 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7725 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7726 SCM result
= scm_i_mkbig ();
7727 mpz_sub (SCM_I_BIG_MPZ (result
),
7730 scm_remember_upto_here_2 (x
, y
);
7731 /* we know the result will have to be a bignum */
7732 if ((sgn_x
== 1) && (sgn_y
== -1))
7734 if ((sgn_x
== -1) && (sgn_y
== 1))
7736 return scm_i_normbig (result
);
7738 else if (SCM_REALP (y
))
7740 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7741 scm_remember_upto_here_1 (x
);
7742 return scm_from_double (result
);
7744 else if (SCM_COMPLEXP (y
))
7746 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7747 - SCM_COMPLEX_REAL (y
));
7748 scm_remember_upto_here_1 (x
);
7749 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7751 else if (SCM_FRACTIONP (y
))
7752 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7753 SCM_FRACTION_NUMERATOR (y
)),
7754 SCM_FRACTION_DENOMINATOR (y
));
7755 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7757 else if (SCM_REALP (x
))
7759 if (SCM_I_INUMP (y
))
7760 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7761 else if (SCM_BIGP (y
))
7763 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7764 scm_remember_upto_here_1 (x
);
7765 return scm_from_double (result
);
7767 else if (SCM_REALP (y
))
7768 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7769 else if (SCM_COMPLEXP (y
))
7770 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7771 -SCM_COMPLEX_IMAG (y
));
7772 else if (SCM_FRACTIONP (y
))
7773 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7775 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7777 else if (SCM_COMPLEXP (x
))
7779 if (SCM_I_INUMP (y
))
7780 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7781 SCM_COMPLEX_IMAG (x
));
7782 else if (SCM_BIGP (y
))
7784 double real_part
= (SCM_COMPLEX_REAL (x
)
7785 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7786 scm_remember_upto_here_1 (x
);
7787 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7789 else if (SCM_REALP (y
))
7790 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7791 SCM_COMPLEX_IMAG (x
));
7792 else if (SCM_COMPLEXP (y
))
7793 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7794 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7795 else if (SCM_FRACTIONP (y
))
7796 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7797 SCM_COMPLEX_IMAG (x
));
7799 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7801 else if (SCM_FRACTIONP (x
))
7803 if (SCM_I_INUMP (y
))
7804 /* a/b - c = (a - cb) / b */
7805 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7806 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7807 SCM_FRACTION_DENOMINATOR (x
));
7808 else if (SCM_BIGP (y
))
7809 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7810 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7811 SCM_FRACTION_DENOMINATOR (x
));
7812 else if (SCM_REALP (y
))
7813 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7814 else if (SCM_COMPLEXP (y
))
7815 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7816 -SCM_COMPLEX_IMAG (y
));
7817 else if (SCM_FRACTIONP (y
))
7818 /* a/b - c/d = (ad - bc) / bd */
7819 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7820 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7821 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7823 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7826 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7831 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7833 "Return @math{@var{x}-1}.")
7834 #define FUNC_NAME s_scm_oneminus
7836 return scm_difference (x
, SCM_INUM1
);
7841 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7842 (SCM x
, SCM y
, SCM rest
),
7843 "Return the product of all arguments. If called without arguments,\n"
7845 #define FUNC_NAME s_scm_i_product
7847 while (!scm_is_null (rest
))
7848 { x
= scm_product (x
, y
);
7850 rest
= scm_cdr (rest
);
7852 return scm_product (x
, y
);
7856 #define s_product s_scm_i_product
7857 #define g_product g_scm_i_product
7860 scm_product (SCM x
, SCM y
)
7862 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7865 return SCM_I_MAKINUM (1L);
7866 else if (SCM_NUMBERP (x
))
7869 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7872 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7877 xx
= SCM_I_INUM (x
);
7882 /* exact1 is the universal multiplicative identity */
7886 /* exact0 times a fixnum is exact0: optimize this case */
7887 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7889 /* if the other argument is inexact, the result is inexact,
7890 and we must do the multiplication in order to handle
7891 infinities and NaNs properly. */
7892 else if (SCM_REALP (y
))
7893 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7894 else if (SCM_COMPLEXP (y
))
7895 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7896 0.0 * SCM_COMPLEX_IMAG (y
));
7897 /* we've already handled inexact numbers,
7898 so y must be exact, and we return exact0 */
7899 else if (SCM_NUMP (y
))
7902 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7906 * This case is important for more than just optimization.
7907 * It handles the case of negating
7908 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7909 * which is a bignum that must be changed back into a fixnum.
7910 * Failure to do so will cause the following to return #f:
7911 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7913 return scm_difference(y
, SCM_UNDEFINED
);
7917 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7919 scm_t_inum yy
= SCM_I_INUM (y
);
7920 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7921 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7922 if (SCM_FIXABLE (kk
))
7923 return SCM_I_MAKINUM (kk
);
7925 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7926 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7927 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7928 return SCM_I_MAKINUM (xx
* yy
);
7932 SCM result
= scm_i_inum2big (xx
);
7933 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7934 return scm_i_normbig (result
);
7937 else if (SCM_BIGP (y
))
7939 SCM result
= scm_i_mkbig ();
7940 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7941 scm_remember_upto_here_1 (y
);
7944 else if (SCM_REALP (y
))
7945 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7946 else if (SCM_COMPLEXP (y
))
7947 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7948 xx
* SCM_COMPLEX_IMAG (y
));
7949 else if (SCM_FRACTIONP (y
))
7950 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7951 SCM_FRACTION_DENOMINATOR (y
));
7953 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7955 else if (SCM_BIGP (x
))
7957 if (SCM_I_INUMP (y
))
7962 else if (SCM_BIGP (y
))
7964 SCM result
= scm_i_mkbig ();
7965 mpz_mul (SCM_I_BIG_MPZ (result
),
7968 scm_remember_upto_here_2 (x
, y
);
7971 else if (SCM_REALP (y
))
7973 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7974 scm_remember_upto_here_1 (x
);
7975 return scm_from_double (result
);
7977 else if (SCM_COMPLEXP (y
))
7979 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7980 scm_remember_upto_here_1 (x
);
7981 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7982 z
* SCM_COMPLEX_IMAG (y
));
7984 else if (SCM_FRACTIONP (y
))
7985 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7986 SCM_FRACTION_DENOMINATOR (y
));
7988 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7990 else if (SCM_REALP (x
))
7992 if (SCM_I_INUMP (y
))
7997 else if (SCM_BIGP (y
))
7999 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8000 scm_remember_upto_here_1 (y
);
8001 return scm_from_double (result
);
8003 else if (SCM_REALP (y
))
8004 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8005 else if (SCM_COMPLEXP (y
))
8006 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8007 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8008 else if (SCM_FRACTIONP (y
))
8009 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8011 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8013 else if (SCM_COMPLEXP (x
))
8015 if (SCM_I_INUMP (y
))
8020 else if (SCM_BIGP (y
))
8022 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8023 scm_remember_upto_here_1 (y
);
8024 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8025 z
* SCM_COMPLEX_IMAG (x
));
8027 else if (SCM_REALP (y
))
8028 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8029 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8030 else if (SCM_COMPLEXP (y
))
8032 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8033 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8034 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8035 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8037 else if (SCM_FRACTIONP (y
))
8039 double yy
= scm_i_fraction2double (y
);
8040 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8041 yy
* SCM_COMPLEX_IMAG (x
));
8044 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8046 else if (SCM_FRACTIONP (x
))
8048 if (SCM_I_INUMP (y
))
8049 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8050 SCM_FRACTION_DENOMINATOR (x
));
8051 else if (SCM_BIGP (y
))
8052 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8053 SCM_FRACTION_DENOMINATOR (x
));
8054 else if (SCM_REALP (y
))
8055 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8056 else if (SCM_COMPLEXP (y
))
8058 double xx
= scm_i_fraction2double (x
);
8059 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8060 xx
* SCM_COMPLEX_IMAG (y
));
8062 else if (SCM_FRACTIONP (y
))
8063 /* a/b * c/d = ac / bd */
8064 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8065 SCM_FRACTION_NUMERATOR (y
)),
8066 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8067 SCM_FRACTION_DENOMINATOR (y
)));
8069 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8072 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8075 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8076 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8077 #define ALLOW_DIVIDE_BY_ZERO
8078 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8081 /* The code below for complex division is adapted from the GNU
8082 libstdc++, which adapted it from f2c's libF77, and is subject to
8085 /****************************************************************
8086 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8088 Permission to use, copy, modify, and distribute this software
8089 and its documentation for any purpose and without fee is hereby
8090 granted, provided that the above copyright notice appear in all
8091 copies and that both that the copyright notice and this
8092 permission notice and warranty disclaimer appear in supporting
8093 documentation, and that the names of AT&T Bell Laboratories or
8094 Bellcore or any of their entities not be used in advertising or
8095 publicity pertaining to distribution of the software without
8096 specific, written prior permission.
8098 AT&T and Bellcore disclaim all warranties with regard to this
8099 software, including all implied warranties of merchantability
8100 and fitness. In no event shall AT&T or Bellcore be liable for
8101 any special, indirect or consequential damages or any damages
8102 whatsoever resulting from loss of use, data or profits, whether
8103 in an action of contract, negligence or other tortious action,
8104 arising out of or in connection with the use or performance of
8106 ****************************************************************/
8108 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8109 (SCM x
, SCM y
, SCM rest
),
8110 "Divide the first argument by the product of the remaining\n"
8111 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8113 #define FUNC_NAME s_scm_i_divide
8115 while (!scm_is_null (rest
))
8116 { x
= scm_divide (x
, y
);
8118 rest
= scm_cdr (rest
);
8120 return scm_divide (x
, y
);
8124 #define s_divide s_scm_i_divide
8125 #define g_divide g_scm_i_divide
8128 scm_divide (SCM x
, SCM y
)
8129 #define FUNC_NAME s_divide
8133 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8136 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8137 else if (SCM_I_INUMP (x
))
8139 scm_t_inum xx
= SCM_I_INUM (x
);
8140 if (xx
== 1 || xx
== -1)
8142 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8144 scm_num_overflow (s_divide
);
8147 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8149 else if (SCM_BIGP (x
))
8150 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8151 else if (SCM_REALP (x
))
8153 double xx
= SCM_REAL_VALUE (x
);
8154 #ifndef ALLOW_DIVIDE_BY_ZERO
8156 scm_num_overflow (s_divide
);
8159 return scm_from_double (1.0 / xx
);
8161 else if (SCM_COMPLEXP (x
))
8163 double r
= SCM_COMPLEX_REAL (x
);
8164 double i
= SCM_COMPLEX_IMAG (x
);
8165 if (fabs(r
) <= fabs(i
))
8168 double d
= i
* (1.0 + t
* t
);
8169 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8174 double d
= r
* (1.0 + t
* t
);
8175 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8178 else if (SCM_FRACTIONP (x
))
8179 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8180 SCM_FRACTION_NUMERATOR (x
));
8182 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8185 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8187 scm_t_inum xx
= SCM_I_INUM (x
);
8188 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8190 scm_t_inum yy
= SCM_I_INUM (y
);
8193 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8194 scm_num_overflow (s_divide
);
8196 return scm_from_double ((double) xx
/ (double) yy
);
8199 else if (xx
% yy
!= 0)
8200 return scm_i_make_ratio (x
, y
);
8203 scm_t_inum z
= xx
/ yy
;
8204 if (SCM_FIXABLE (z
))
8205 return SCM_I_MAKINUM (z
);
8207 return scm_i_inum2big (z
);
8210 else if (SCM_BIGP (y
))
8211 return scm_i_make_ratio (x
, y
);
8212 else if (SCM_REALP (y
))
8214 double yy
= SCM_REAL_VALUE (y
);
8215 #ifndef ALLOW_DIVIDE_BY_ZERO
8217 scm_num_overflow (s_divide
);
8220 /* FIXME: Precision may be lost here due to:
8221 (1) The cast from 'scm_t_inum' to 'double'
8222 (2) Double rounding */
8223 return scm_from_double ((double) xx
/ yy
);
8225 else if (SCM_COMPLEXP (y
))
8228 complex_div
: /* y _must_ be a complex number */
8230 double r
= SCM_COMPLEX_REAL (y
);
8231 double i
= SCM_COMPLEX_IMAG (y
);
8232 if (fabs(r
) <= fabs(i
))
8235 double d
= i
* (1.0 + t
* t
);
8236 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8241 double d
= r
* (1.0 + t
* t
);
8242 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8246 else if (SCM_FRACTIONP (y
))
8247 /* a / b/c = ac / b */
8248 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8249 SCM_FRACTION_NUMERATOR (y
));
8251 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8253 else if (SCM_BIGP (x
))
8255 if (SCM_I_INUMP (y
))
8257 scm_t_inum yy
= SCM_I_INUM (y
);
8260 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8261 scm_num_overflow (s_divide
);
8263 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8264 scm_remember_upto_here_1 (x
);
8265 return (sgn
== 0) ? scm_nan () : scm_inf ();
8272 /* FIXME: HMM, what are the relative performance issues here?
8273 We need to test. Is it faster on average to test
8274 divisible_p, then perform whichever operation, or is it
8275 faster to perform the integer div opportunistically and
8276 switch to real if there's a remainder? For now we take the
8277 middle ground: test, then if divisible, use the faster div
8280 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8281 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8285 SCM result
= scm_i_mkbig ();
8286 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8287 scm_remember_upto_here_1 (x
);
8289 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8290 return scm_i_normbig (result
);
8293 return scm_i_make_ratio (x
, y
);
8296 else if (SCM_BIGP (y
))
8298 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8302 SCM result
= scm_i_mkbig ();
8303 mpz_divexact (SCM_I_BIG_MPZ (result
),
8306 scm_remember_upto_here_2 (x
, y
);
8307 return scm_i_normbig (result
);
8310 return scm_i_make_ratio (x
, y
);
8312 else if (SCM_REALP (y
))
8314 double yy
= SCM_REAL_VALUE (y
);
8315 #ifndef ALLOW_DIVIDE_BY_ZERO
8317 scm_num_overflow (s_divide
);
8320 /* FIXME: Precision may be lost here due to:
8321 (1) scm_i_big2dbl (2) Double rounding */
8322 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8324 else if (SCM_COMPLEXP (y
))
8326 a
= scm_i_big2dbl (x
);
8329 else if (SCM_FRACTIONP (y
))
8330 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8331 SCM_FRACTION_NUMERATOR (y
));
8333 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8335 else if (SCM_REALP (x
))
8337 double rx
= SCM_REAL_VALUE (x
);
8338 if (SCM_I_INUMP (y
))
8340 scm_t_inum yy
= SCM_I_INUM (y
);
8341 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8343 scm_num_overflow (s_divide
);
8346 /* FIXME: Precision may be lost here due to:
8347 (1) The cast from 'scm_t_inum' to 'double'
8348 (2) Double rounding */
8349 return scm_from_double (rx
/ (double) yy
);
8351 else if (SCM_BIGP (y
))
8353 /* FIXME: Precision may be lost here due to:
8354 (1) The conversion from bignum to double
8355 (2) Double rounding */
8356 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8357 scm_remember_upto_here_1 (y
);
8358 return scm_from_double (rx
/ dby
);
8360 else if (SCM_REALP (y
))
8362 double yy
= SCM_REAL_VALUE (y
);
8363 #ifndef ALLOW_DIVIDE_BY_ZERO
8365 scm_num_overflow (s_divide
);
8368 return scm_from_double (rx
/ yy
);
8370 else if (SCM_COMPLEXP (y
))
8375 else if (SCM_FRACTIONP (y
))
8376 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8378 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8380 else if (SCM_COMPLEXP (x
))
8382 double rx
= SCM_COMPLEX_REAL (x
);
8383 double ix
= SCM_COMPLEX_IMAG (x
);
8384 if (SCM_I_INUMP (y
))
8386 scm_t_inum yy
= SCM_I_INUM (y
);
8387 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8389 scm_num_overflow (s_divide
);
8393 /* FIXME: Precision may be lost here due to:
8394 (1) The conversion from 'scm_t_inum' to double
8395 (2) Double rounding */
8397 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8400 else if (SCM_BIGP (y
))
8402 /* FIXME: Precision may be lost here due to:
8403 (1) The conversion from bignum to double
8404 (2) Double rounding */
8405 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8406 scm_remember_upto_here_1 (y
);
8407 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8409 else if (SCM_REALP (y
))
8411 double yy
= SCM_REAL_VALUE (y
);
8412 #ifndef ALLOW_DIVIDE_BY_ZERO
8414 scm_num_overflow (s_divide
);
8417 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8419 else if (SCM_COMPLEXP (y
))
8421 double ry
= SCM_COMPLEX_REAL (y
);
8422 double iy
= SCM_COMPLEX_IMAG (y
);
8423 if (fabs(ry
) <= fabs(iy
))
8426 double d
= iy
* (1.0 + t
* t
);
8427 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8432 double d
= ry
* (1.0 + t
* t
);
8433 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8436 else if (SCM_FRACTIONP (y
))
8438 /* FIXME: Precision may be lost here due to:
8439 (1) The conversion from fraction to double
8440 (2) Double rounding */
8441 double yy
= scm_i_fraction2double (y
);
8442 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8445 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8447 else if (SCM_FRACTIONP (x
))
8449 if (SCM_I_INUMP (y
))
8451 scm_t_inum yy
= SCM_I_INUM (y
);
8452 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8454 scm_num_overflow (s_divide
);
8457 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8458 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8460 else if (SCM_BIGP (y
))
8462 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8463 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8465 else if (SCM_REALP (y
))
8467 double yy
= SCM_REAL_VALUE (y
);
8468 #ifndef ALLOW_DIVIDE_BY_ZERO
8470 scm_num_overflow (s_divide
);
8473 /* FIXME: Precision may be lost here due to:
8474 (1) The conversion from fraction to double
8475 (2) Double rounding */
8476 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8478 else if (SCM_COMPLEXP (y
))
8480 /* FIXME: Precision may be lost here due to:
8481 (1) The conversion from fraction to double
8482 (2) Double rounding */
8483 a
= scm_i_fraction2double (x
);
8486 else if (SCM_FRACTIONP (y
))
8487 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8488 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8490 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8493 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8499 scm_c_truncate (double x
)
8504 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8505 half-way case (ie. when x is an integer plus 0.5) going upwards.
8506 Then half-way cases are identified and adjusted down if the
8507 round-upwards didn't give the desired even integer.
8509 "plus_half == result" identifies a half-way case. If plus_half, which is
8510 x + 0.5, is an integer then x must be an integer plus 0.5.
8512 An odd "result" value is identified with result/2 != floor(result/2).
8513 This is done with plus_half, since that value is ready for use sooner in
8514 a pipelined cpu, and we're already requiring plus_half == result.
8516 Note however that we need to be careful when x is big and already an
8517 integer. In that case "x+0.5" may round to an adjacent integer, causing
8518 us to return such a value, incorrectly. For instance if the hardware is
8519 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8520 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8521 returned. Or if the hardware is in round-upwards mode, then other bigger
8522 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8523 representable value, 2^128+2^76 (or whatever), again incorrect.
8525 These bad roundings of x+0.5 are avoided by testing at the start whether
8526 x is already an integer. If it is then clearly that's the desired result
8527 already. And if it's not then the exponent must be small enough to allow
8528 an 0.5 to be represented, and hence added without a bad rounding. */
8531 scm_c_round (double x
)
8533 double plus_half
, result
;
8538 plus_half
= x
+ 0.5;
8539 result
= floor (plus_half
);
8540 /* Adjust so that the rounding is towards even. */
8541 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8546 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8548 "Round the number @var{x} towards zero.")
8549 #define FUNC_NAME s_scm_truncate_number
8551 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8553 else if (SCM_REALP (x
))
8554 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8555 else if (SCM_FRACTIONP (x
))
8556 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8557 SCM_FRACTION_DENOMINATOR (x
));
8559 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8560 s_scm_truncate_number
);
8564 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8566 "Round the number @var{x} towards the nearest integer. "
8567 "When it is exactly halfway between two integers, "
8568 "round towards the even one.")
8569 #define FUNC_NAME s_scm_round_number
8571 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8573 else if (SCM_REALP (x
))
8574 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8575 else if (SCM_FRACTIONP (x
))
8576 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8577 SCM_FRACTION_DENOMINATOR (x
));
8579 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8580 s_scm_round_number
);
8584 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8586 "Round the number @var{x} towards minus infinity.")
8587 #define FUNC_NAME s_scm_floor
8589 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8591 else if (SCM_REALP (x
))
8592 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8593 else if (SCM_FRACTIONP (x
))
8594 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8595 SCM_FRACTION_DENOMINATOR (x
));
8597 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8601 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8603 "Round the number @var{x} towards infinity.")
8604 #define FUNC_NAME s_scm_ceiling
8606 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8608 else if (SCM_REALP (x
))
8609 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8610 else if (SCM_FRACTIONP (x
))
8611 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8612 SCM_FRACTION_DENOMINATOR (x
));
8614 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8618 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8620 "Return @var{x} raised to the power of @var{y}.")
8621 #define FUNC_NAME s_scm_expt
8623 if (scm_is_integer (y
))
8625 if (scm_is_true (scm_exact_p (y
)))
8626 return scm_integer_expt (x
, y
);
8629 /* Here we handle the case where the exponent is an inexact
8630 integer. We make the exponent exact in order to use
8631 scm_integer_expt, and thus avoid the spurious imaginary
8632 parts that may result from round-off errors in the general
8633 e^(y log x) method below (for example when squaring a large
8634 negative number). In this case, we must return an inexact
8635 result for correctness. We also make the base inexact so
8636 that scm_integer_expt will use fast inexact arithmetic
8637 internally. Note that making the base inexact is not
8638 sufficient to guarantee an inexact result, because
8639 scm_integer_expt will return an exact 1 when the exponent
8640 is 0, even if the base is inexact. */
8641 return scm_exact_to_inexact
8642 (scm_integer_expt (scm_exact_to_inexact (x
),
8643 scm_inexact_to_exact (y
)));
8646 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8648 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8650 else if (scm_is_complex (x
) && scm_is_complex (y
))
8651 return scm_exp (scm_product (scm_log (x
), y
));
8652 else if (scm_is_complex (x
))
8653 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8655 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8659 /* sin/cos/tan/asin/acos/atan
8660 sinh/cosh/tanh/asinh/acosh/atanh
8661 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8662 Written by Jerry D. Hedden, (C) FSF.
8663 See the file `COPYING' for terms applying to this program. */
8665 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8667 "Compute the sine of @var{z}.")
8668 #define FUNC_NAME s_scm_sin
8670 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8671 return z
; /* sin(exact0) = exact0 */
8672 else if (scm_is_real (z
))
8673 return scm_from_double (sin (scm_to_double (z
)));
8674 else if (SCM_COMPLEXP (z
))
8676 x
= SCM_COMPLEX_REAL (z
);
8677 y
= SCM_COMPLEX_IMAG (z
);
8678 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8679 cos (x
) * sinh (y
));
8682 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8686 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8688 "Compute the cosine of @var{z}.")
8689 #define FUNC_NAME s_scm_cos
8691 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8692 return SCM_INUM1
; /* cos(exact0) = exact1 */
8693 else if (scm_is_real (z
))
8694 return scm_from_double (cos (scm_to_double (z
)));
8695 else if (SCM_COMPLEXP (z
))
8697 x
= SCM_COMPLEX_REAL (z
);
8698 y
= SCM_COMPLEX_IMAG (z
);
8699 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8700 -sin (x
) * sinh (y
));
8703 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8707 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8709 "Compute the tangent of @var{z}.")
8710 #define FUNC_NAME s_scm_tan
8712 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8713 return z
; /* tan(exact0) = exact0 */
8714 else if (scm_is_real (z
))
8715 return scm_from_double (tan (scm_to_double (z
)));
8716 else if (SCM_COMPLEXP (z
))
8718 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8719 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8720 w
= cos (x
) + cosh (y
);
8721 #ifndef ALLOW_DIVIDE_BY_ZERO
8723 scm_num_overflow (s_scm_tan
);
8725 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8728 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8732 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8734 "Compute the hyperbolic sine of @var{z}.")
8735 #define FUNC_NAME s_scm_sinh
8737 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8738 return z
; /* sinh(exact0) = exact0 */
8739 else if (scm_is_real (z
))
8740 return scm_from_double (sinh (scm_to_double (z
)));
8741 else if (SCM_COMPLEXP (z
))
8743 x
= SCM_COMPLEX_REAL (z
);
8744 y
= SCM_COMPLEX_IMAG (z
);
8745 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8746 cosh (x
) * sin (y
));
8749 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8753 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8755 "Compute the hyperbolic cosine of @var{z}.")
8756 #define FUNC_NAME s_scm_cosh
8758 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8759 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8760 else if (scm_is_real (z
))
8761 return scm_from_double (cosh (scm_to_double (z
)));
8762 else if (SCM_COMPLEXP (z
))
8764 x
= SCM_COMPLEX_REAL (z
);
8765 y
= SCM_COMPLEX_IMAG (z
);
8766 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8767 sinh (x
) * sin (y
));
8770 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8774 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8776 "Compute the hyperbolic tangent of @var{z}.")
8777 #define FUNC_NAME s_scm_tanh
8779 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8780 return z
; /* tanh(exact0) = exact0 */
8781 else if (scm_is_real (z
))
8782 return scm_from_double (tanh (scm_to_double (z
)));
8783 else if (SCM_COMPLEXP (z
))
8785 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8786 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8787 w
= cosh (x
) + cos (y
);
8788 #ifndef ALLOW_DIVIDE_BY_ZERO
8790 scm_num_overflow (s_scm_tanh
);
8792 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8795 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8799 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8801 "Compute the arc sine of @var{z}.")
8802 #define FUNC_NAME s_scm_asin
8804 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8805 return z
; /* asin(exact0) = exact0 */
8806 else if (scm_is_real (z
))
8808 double w
= scm_to_double (z
);
8809 if (w
>= -1.0 && w
<= 1.0)
8810 return scm_from_double (asin (w
));
8812 return scm_product (scm_c_make_rectangular (0, -1),
8813 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8815 else if (SCM_COMPLEXP (z
))
8817 x
= SCM_COMPLEX_REAL (z
);
8818 y
= SCM_COMPLEX_IMAG (z
);
8819 return scm_product (scm_c_make_rectangular (0, -1),
8820 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8823 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8827 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8829 "Compute the arc cosine of @var{z}.")
8830 #define FUNC_NAME s_scm_acos
8832 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8833 return SCM_INUM0
; /* acos(exact1) = exact0 */
8834 else if (scm_is_real (z
))
8836 double w
= scm_to_double (z
);
8837 if (w
>= -1.0 && w
<= 1.0)
8838 return scm_from_double (acos (w
));
8840 return scm_sum (scm_from_double (acos (0.0)),
8841 scm_product (scm_c_make_rectangular (0, 1),
8842 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8844 else if (SCM_COMPLEXP (z
))
8846 x
= SCM_COMPLEX_REAL (z
);
8847 y
= SCM_COMPLEX_IMAG (z
);
8848 return scm_sum (scm_from_double (acos (0.0)),
8849 scm_product (scm_c_make_rectangular (0, 1),
8850 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8853 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8857 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8859 "With one argument, compute the arc tangent of @var{z}.\n"
8860 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8861 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8862 #define FUNC_NAME s_scm_atan
8866 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8867 return z
; /* atan(exact0) = exact0 */
8868 else if (scm_is_real (z
))
8869 return scm_from_double (atan (scm_to_double (z
)));
8870 else if (SCM_COMPLEXP (z
))
8873 v
= SCM_COMPLEX_REAL (z
);
8874 w
= SCM_COMPLEX_IMAG (z
);
8875 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8876 scm_c_make_rectangular (v
, w
+ 1.0))),
8877 scm_c_make_rectangular (0, 2));
8880 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8882 else if (scm_is_real (z
))
8884 if (scm_is_real (y
))
8885 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8887 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8890 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8894 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8896 "Compute the inverse hyperbolic sine of @var{z}.")
8897 #define FUNC_NAME s_scm_sys_asinh
8899 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8900 return z
; /* asinh(exact0) = exact0 */
8901 else if (scm_is_real (z
))
8902 return scm_from_double (asinh (scm_to_double (z
)));
8903 else if (scm_is_number (z
))
8904 return scm_log (scm_sum (z
,
8905 scm_sqrt (scm_sum (scm_product (z
, z
),
8908 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8912 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8914 "Compute the inverse hyperbolic cosine of @var{z}.")
8915 #define FUNC_NAME s_scm_sys_acosh
8917 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8918 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8919 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8920 return scm_from_double (acosh (scm_to_double (z
)));
8921 else if (scm_is_number (z
))
8922 return scm_log (scm_sum (z
,
8923 scm_sqrt (scm_difference (scm_product (z
, z
),
8926 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8930 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8932 "Compute the inverse hyperbolic tangent of @var{z}.")
8933 #define FUNC_NAME s_scm_sys_atanh
8935 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8936 return z
; /* atanh(exact0) = exact0 */
8937 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8938 return scm_from_double (atanh (scm_to_double (z
)));
8939 else if (scm_is_number (z
))
8940 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8941 scm_difference (SCM_INUM1
, z
))),
8944 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8949 scm_c_make_rectangular (double re
, double im
)
8953 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8955 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8956 SCM_COMPLEX_REAL (z
) = re
;
8957 SCM_COMPLEX_IMAG (z
) = im
;
8961 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8962 (SCM real_part
, SCM imaginary_part
),
8963 "Return a complex number constructed of the given @var{real_part} "
8964 "and @var{imaginary_part} parts.")
8965 #define FUNC_NAME s_scm_make_rectangular
8967 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8968 SCM_ARG1
, FUNC_NAME
, "real");
8969 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8970 SCM_ARG2
, FUNC_NAME
, "real");
8972 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8973 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8976 return scm_c_make_rectangular (scm_to_double (real_part
),
8977 scm_to_double (imaginary_part
));
8982 scm_c_make_polar (double mag
, double ang
)
8986 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8987 use it on Glibc-based systems that have it (it's a GNU extension). See
8988 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8990 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8991 sincos (ang
, &s
, &c
);
8997 /* If s and c are NaNs, this indicates that the angle is a NaN,
8998 infinite, or perhaps simply too large to determine its value
8999 mod 2*pi. However, we know something that the floating-point
9000 implementation doesn't know: We know that s and c are finite.
9001 Therefore, if the magnitude is zero, return a complex zero.
9003 The reason we check for the NaNs instead of using this case
9004 whenever mag == 0.0 is because when the angle is known, we'd
9005 like to return the correct kind of non-real complex zero:
9006 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9007 on which quadrant the angle is in.
9009 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9010 return scm_c_make_rectangular (0.0, 0.0);
9012 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9015 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9017 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9018 #define FUNC_NAME s_scm_make_polar
9020 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9021 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9023 /* If mag is exact0, return exact0 */
9024 if (scm_is_eq (mag
, SCM_INUM0
))
9026 /* Return a real if ang is exact0 */
9027 else if (scm_is_eq (ang
, SCM_INUM0
))
9030 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9035 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9037 "Return the real part of the number @var{z}.")
9038 #define FUNC_NAME s_scm_real_part
9040 if (SCM_COMPLEXP (z
))
9041 return scm_from_double (SCM_COMPLEX_REAL (z
));
9042 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9045 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9050 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9052 "Return the imaginary part of the number @var{z}.")
9053 #define FUNC_NAME s_scm_imag_part
9055 if (SCM_COMPLEXP (z
))
9056 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9057 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9060 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9064 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9066 "Return the numerator of the number @var{z}.")
9067 #define FUNC_NAME s_scm_numerator
9069 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9071 else if (SCM_FRACTIONP (z
))
9072 return SCM_FRACTION_NUMERATOR (z
);
9073 else if (SCM_REALP (z
))
9074 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9076 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9081 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9083 "Return the denominator of the number @var{z}.")
9084 #define FUNC_NAME s_scm_denominator
9086 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9088 else if (SCM_FRACTIONP (z
))
9089 return SCM_FRACTION_DENOMINATOR (z
);
9090 else if (SCM_REALP (z
))
9091 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9093 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9098 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9100 "Return the magnitude of the number @var{z}. This is the same as\n"
9101 "@code{abs} for real arguments, but also allows complex numbers.")
9102 #define FUNC_NAME s_scm_magnitude
9104 if (SCM_I_INUMP (z
))
9106 scm_t_inum zz
= SCM_I_INUM (z
);
9109 else if (SCM_POSFIXABLE (-zz
))
9110 return SCM_I_MAKINUM (-zz
);
9112 return scm_i_inum2big (-zz
);
9114 else if (SCM_BIGP (z
))
9116 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9117 scm_remember_upto_here_1 (z
);
9119 return scm_i_clonebig (z
, 0);
9123 else if (SCM_REALP (z
))
9124 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9125 else if (SCM_COMPLEXP (z
))
9126 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9127 else if (SCM_FRACTIONP (z
))
9129 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9131 return scm_i_make_ratio_already_reduced
9132 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9133 SCM_FRACTION_DENOMINATOR (z
));
9136 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9141 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9143 "Return the angle of the complex number @var{z}.")
9144 #define FUNC_NAME s_scm_angle
9146 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9147 flo0 to save allocating a new flonum with scm_from_double each time.
9148 But if atan2 follows the floating point rounding mode, then the value
9149 is not a constant. Maybe it'd be close enough though. */
9150 if (SCM_I_INUMP (z
))
9152 if (SCM_I_INUM (z
) >= 0)
9155 return scm_from_double (atan2 (0.0, -1.0));
9157 else if (SCM_BIGP (z
))
9159 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9160 scm_remember_upto_here_1 (z
);
9162 return scm_from_double (atan2 (0.0, -1.0));
9166 else if (SCM_REALP (z
))
9168 double x
= SCM_REAL_VALUE (z
);
9169 if (x
> 0.0 || double_is_non_negative_zero (x
))
9172 return scm_from_double (atan2 (0.0, -1.0));
9174 else if (SCM_COMPLEXP (z
))
9175 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9176 else if (SCM_FRACTIONP (z
))
9178 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9180 else return scm_from_double (atan2 (0.0, -1.0));
9183 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9188 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9190 "Convert the number @var{z} to its inexact representation.\n")
9191 #define FUNC_NAME s_scm_exact_to_inexact
9193 if (SCM_I_INUMP (z
))
9194 return scm_from_double ((double) SCM_I_INUM (z
));
9195 else if (SCM_BIGP (z
))
9196 return scm_from_double (scm_i_big2dbl (z
));
9197 else if (SCM_FRACTIONP (z
))
9198 return scm_from_double (scm_i_fraction2double (z
));
9199 else if (SCM_INEXACTP (z
))
9202 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9207 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9209 "Return an exact number that is numerically closest to @var{z}.")
9210 #define FUNC_NAME s_scm_inexact_to_exact
9212 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9219 val
= SCM_REAL_VALUE (z
);
9220 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9221 val
= SCM_COMPLEX_REAL (z
);
9223 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9225 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9226 SCM_OUT_OF_RANGE (1, z
);
9227 else if (val
== 0.0)
9234 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9236 expon
-= DBL_MANT_DIG
;
9239 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9243 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9244 SCM_I_BIG_MPZ (numerator
),
9248 numerator
= scm_i_normbig (numerator
);
9250 return scm_i_make_ratio_already_reduced
9251 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9253 return left_shift_exact_integer (numerator
, expon
);
9261 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9263 "Returns the @emph{simplest} rational number differing\n"
9264 "from @var{x} by no more than @var{eps}.\n"
9266 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9267 "exact result when both its arguments are exact. Thus, you might need\n"
9268 "to use @code{inexact->exact} on the arguments.\n"
9271 "(rationalize (inexact->exact 1.2) 1/100)\n"
9274 #define FUNC_NAME s_scm_rationalize
9276 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9277 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9278 eps
= scm_abs (eps
);
9279 if (scm_is_false (scm_positive_p (eps
)))
9281 /* eps is either zero or a NaN */
9282 if (scm_is_true (scm_nan_p (eps
)))
9284 else if (SCM_INEXACTP (eps
))
9285 return scm_exact_to_inexact (x
);
9289 else if (scm_is_false (scm_finite_p (eps
)))
9291 if (scm_is_true (scm_finite_p (x
)))
9296 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9298 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9299 scm_ceiling (scm_difference (x
, eps
)))))
9301 /* There's an integer within range; we want the one closest to zero */
9302 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9304 /* zero is within range */
9305 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9310 else if (scm_is_true (scm_positive_p (x
)))
9311 return scm_ceiling (scm_difference (x
, eps
));
9313 return scm_floor (scm_sum (x
, eps
));
9317 /* Use continued fractions to find closest ratio. All
9318 arithmetic is done with exact numbers.
9321 SCM ex
= scm_inexact_to_exact (x
);
9322 SCM int_part
= scm_floor (ex
);
9324 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9325 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9329 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9330 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9332 /* We stop after a million iterations just to be absolutely sure
9333 that we don't go into an infinite loop. The process normally
9334 converges after less than a dozen iterations.
9337 while (++i
< 1000000)
9339 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9340 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9341 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9343 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9344 eps
))) /* abs(x-a/b) <= eps */
9346 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9347 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9348 return scm_exact_to_inexact (res
);
9352 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9354 tt
= scm_floor (rx
); /* tt = floor (rx) */
9360 scm_num_overflow (s_scm_rationalize
);
9365 /* conversion functions */
9368 scm_is_integer (SCM val
)
9370 return scm_is_true (scm_integer_p (val
));
9374 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9376 if (SCM_I_INUMP (val
))
9378 scm_t_signed_bits n
= SCM_I_INUM (val
);
9379 return n
>= min
&& n
<= max
;
9381 else if (SCM_BIGP (val
))
9383 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9385 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9387 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9389 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9390 return n
>= min
&& n
<= max
;
9400 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9401 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9404 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9405 SCM_I_BIG_MPZ (val
));
9407 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9419 return n
>= min
&& n
<= max
;
9427 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9429 if (SCM_I_INUMP (val
))
9431 scm_t_signed_bits n
= SCM_I_INUM (val
);
9432 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9434 else if (SCM_BIGP (val
))
9436 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9438 else if (max
<= ULONG_MAX
)
9440 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9442 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9443 return n
>= min
&& n
<= max
;
9453 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9456 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9457 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9460 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9461 SCM_I_BIG_MPZ (val
));
9463 return n
>= min
&& n
<= max
;
9471 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9473 scm_error (scm_out_of_range_key
,
9475 "Value out of range ~S to ~S: ~S",
9476 scm_list_3 (min
, max
, bad_val
),
9477 scm_list_1 (bad_val
));
9480 #define TYPE scm_t_intmax
9481 #define TYPE_MIN min
9482 #define TYPE_MAX max
9483 #define SIZEOF_TYPE 0
9484 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9485 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9486 #include "libguile/conv-integer.i.c"
9488 #define TYPE scm_t_uintmax
9489 #define TYPE_MIN min
9490 #define TYPE_MAX max
9491 #define SIZEOF_TYPE 0
9492 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9493 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9494 #include "libguile/conv-uinteger.i.c"
9496 #define TYPE scm_t_int8
9497 #define TYPE_MIN SCM_T_INT8_MIN
9498 #define TYPE_MAX SCM_T_INT8_MAX
9499 #define SIZEOF_TYPE 1
9500 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9501 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9502 #include "libguile/conv-integer.i.c"
9504 #define TYPE scm_t_uint8
9506 #define TYPE_MAX SCM_T_UINT8_MAX
9507 #define SIZEOF_TYPE 1
9508 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9509 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9510 #include "libguile/conv-uinteger.i.c"
9512 #define TYPE scm_t_int16
9513 #define TYPE_MIN SCM_T_INT16_MIN
9514 #define TYPE_MAX SCM_T_INT16_MAX
9515 #define SIZEOF_TYPE 2
9516 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9517 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9518 #include "libguile/conv-integer.i.c"
9520 #define TYPE scm_t_uint16
9522 #define TYPE_MAX SCM_T_UINT16_MAX
9523 #define SIZEOF_TYPE 2
9524 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9525 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9526 #include "libguile/conv-uinteger.i.c"
9528 #define TYPE scm_t_int32
9529 #define TYPE_MIN SCM_T_INT32_MIN
9530 #define TYPE_MAX SCM_T_INT32_MAX
9531 #define SIZEOF_TYPE 4
9532 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9533 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9534 #include "libguile/conv-integer.i.c"
9536 #define TYPE scm_t_uint32
9538 #define TYPE_MAX SCM_T_UINT32_MAX
9539 #define SIZEOF_TYPE 4
9540 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9541 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9542 #include "libguile/conv-uinteger.i.c"
9544 #define TYPE scm_t_wchar
9545 #define TYPE_MIN (scm_t_int32)-1
9546 #define TYPE_MAX (scm_t_int32)0x10ffff
9547 #define SIZEOF_TYPE 4
9548 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9549 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9550 #include "libguile/conv-integer.i.c"
9552 #define TYPE scm_t_int64
9553 #define TYPE_MIN SCM_T_INT64_MIN
9554 #define TYPE_MAX SCM_T_INT64_MAX
9555 #define SIZEOF_TYPE 8
9556 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9557 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9558 #include "libguile/conv-integer.i.c"
9560 #define TYPE scm_t_uint64
9562 #define TYPE_MAX SCM_T_UINT64_MAX
9563 #define SIZEOF_TYPE 8
9564 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9565 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9566 #include "libguile/conv-uinteger.i.c"
9569 scm_to_mpz (SCM val
, mpz_t rop
)
9571 if (SCM_I_INUMP (val
))
9572 mpz_set_si (rop
, SCM_I_INUM (val
));
9573 else if (SCM_BIGP (val
))
9574 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9576 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9580 scm_from_mpz (mpz_t val
)
9582 return scm_i_mpz2num (val
);
9586 scm_is_real (SCM val
)
9588 return scm_is_true (scm_real_p (val
));
9592 scm_is_rational (SCM val
)
9594 return scm_is_true (scm_rational_p (val
));
9598 scm_to_double (SCM val
)
9600 if (SCM_I_INUMP (val
))
9601 return SCM_I_INUM (val
);
9602 else if (SCM_BIGP (val
))
9603 return scm_i_big2dbl (val
);
9604 else if (SCM_FRACTIONP (val
))
9605 return scm_i_fraction2double (val
);
9606 else if (SCM_REALP (val
))
9607 return SCM_REAL_VALUE (val
);
9609 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9613 scm_from_double (double val
)
9617 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9619 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9620 SCM_REAL_VALUE (z
) = val
;
9625 #if SCM_ENABLE_DEPRECATED == 1
9628 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9630 scm_c_issue_deprecation_warning
9631 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9635 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9639 scm_out_of_range (NULL
, num
);
9642 return scm_to_double (num
);
9646 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9648 scm_c_issue_deprecation_warning
9649 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9653 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9657 scm_out_of_range (NULL
, num
);
9660 return scm_to_double (num
);
9666 scm_is_complex (SCM val
)
9668 return scm_is_true (scm_complex_p (val
));
9672 scm_c_real_part (SCM z
)
9674 if (SCM_COMPLEXP (z
))
9675 return SCM_COMPLEX_REAL (z
);
9678 /* Use the scm_real_part to get proper error checking and
9681 return scm_to_double (scm_real_part (z
));
9686 scm_c_imag_part (SCM z
)
9688 if (SCM_COMPLEXP (z
))
9689 return SCM_COMPLEX_IMAG (z
);
9692 /* Use the scm_imag_part to get proper error checking and
9693 dispatching. The result will almost always be 0.0, but not
9696 return scm_to_double (scm_imag_part (z
));
9701 scm_c_magnitude (SCM z
)
9703 return scm_to_double (scm_magnitude (z
));
9709 return scm_to_double (scm_angle (z
));
9713 scm_is_number (SCM z
)
9715 return scm_is_true (scm_number_p (z
));
9719 /* Returns log(x * 2^shift) */
9721 log_of_shifted_double (double x
, long shift
)
9723 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9725 if (x
> 0.0 || double_is_non_negative_zero (x
))
9726 return scm_from_double (ans
);
9728 return scm_c_make_rectangular (ans
, M_PI
);
9731 /* Returns log(n), for exact integer n */
9733 log_of_exact_integer (SCM n
)
9735 if (SCM_I_INUMP (n
))
9736 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9737 else if (SCM_BIGP (n
))
9740 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9741 return log_of_shifted_double (signif
, expon
);
9744 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9747 /* Returns log(n/d), for exact non-zero integers n and d */
9749 log_of_fraction (SCM n
, SCM d
)
9751 long n_size
= scm_to_long (scm_integer_length (n
));
9752 long d_size
= scm_to_long (scm_integer_length (d
));
9754 if (abs (n_size
- d_size
) > 1)
9755 return (scm_difference (log_of_exact_integer (n
),
9756 log_of_exact_integer (d
)));
9757 else if (scm_is_false (scm_negative_p (n
)))
9758 return scm_from_double
9759 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9761 return scm_c_make_rectangular
9762 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9768 /* In the following functions we dispatch to the real-arg funcs like log()
9769 when we know the arg is real, instead of just handing everything to
9770 clog() for instance. This is in case clog() doesn't optimize for a
9771 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9772 well use it to go straight to the applicable C func. */
9774 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9776 "Return the natural logarithm of @var{z}.")
9777 #define FUNC_NAME s_scm_log
9779 if (SCM_COMPLEXP (z
))
9781 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9782 && defined (SCM_COMPLEX_VALUE)
9783 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9785 double re
= SCM_COMPLEX_REAL (z
);
9786 double im
= SCM_COMPLEX_IMAG (z
);
9787 return scm_c_make_rectangular (log (hypot (re
, im
)),
9791 else if (SCM_REALP (z
))
9792 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9793 else if (SCM_I_INUMP (z
))
9795 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9796 if (scm_is_eq (z
, SCM_INUM0
))
9797 scm_num_overflow (s_scm_log
);
9799 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9801 else if (SCM_BIGP (z
))
9802 return log_of_exact_integer (z
);
9803 else if (SCM_FRACTIONP (z
))
9804 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9805 SCM_FRACTION_DENOMINATOR (z
));
9807 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9812 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9814 "Return the base 10 logarithm of @var{z}.")
9815 #define FUNC_NAME s_scm_log10
9817 if (SCM_COMPLEXP (z
))
9819 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9820 clog() and a multiply by M_LOG10E, rather than the fallback
9821 log10+hypot+atan2.) */
9822 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9823 && defined SCM_COMPLEX_VALUE
9824 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9826 double re
= SCM_COMPLEX_REAL (z
);
9827 double im
= SCM_COMPLEX_IMAG (z
);
9828 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9829 M_LOG10E
* atan2 (im
, re
));
9832 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9834 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9835 if (scm_is_eq (z
, SCM_INUM0
))
9836 scm_num_overflow (s_scm_log10
);
9839 double re
= scm_to_double (z
);
9840 double l
= log10 (fabs (re
));
9841 if (re
> 0.0 || double_is_non_negative_zero (re
))
9842 return scm_from_double (l
);
9844 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9847 else if (SCM_BIGP (z
))
9848 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9849 else if (SCM_FRACTIONP (z
))
9850 return scm_product (flo_log10e
,
9851 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9852 SCM_FRACTION_DENOMINATOR (z
)));
9854 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9859 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9861 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9862 "base of natural logarithms (2.71828@dots{}).")
9863 #define FUNC_NAME s_scm_exp
9865 if (SCM_COMPLEXP (z
))
9867 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9868 && defined (SCM_COMPLEX_VALUE)
9869 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9871 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9872 SCM_COMPLEX_IMAG (z
));
9875 else if (SCM_NUMBERP (z
))
9877 /* When z is a negative bignum the conversion to double overflows,
9878 giving -infinity, but that's ok, the exp is still 0.0. */
9879 return scm_from_double (exp (scm_to_double (z
)));
9882 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9887 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9889 "Return two exact non-negative integers @var{s} and @var{r}\n"
9890 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9891 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9892 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9895 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9897 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9901 scm_exact_integer_sqrt (k
, &s
, &r
);
9902 return scm_values (scm_list_2 (s
, r
));
9907 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9909 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9911 scm_t_inum kk
= SCM_I_INUM (k
);
9915 if (SCM_LIKELY (kk
> 0))
9920 uu
= (ss
+ kk
/ss
) / 2;
9922 *sp
= SCM_I_MAKINUM (ss
);
9923 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9925 else if (SCM_LIKELY (kk
== 0))
9926 *sp
= *rp
= SCM_INUM0
;
9928 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9929 "exact non-negative integer");
9931 else if (SCM_LIKELY (SCM_BIGP (k
)))
9935 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9936 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9937 "exact non-negative integer");
9940 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9941 scm_remember_upto_here_1 (k
);
9942 *sp
= scm_i_normbig (s
);
9943 *rp
= scm_i_normbig (r
);
9946 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9947 "exact non-negative integer");
9951 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9953 "Return the square root of @var{z}. Of the two possible roots\n"
9954 "(positive and negative), the one with positive real part\n"
9955 "is returned, or if that's zero then a positive imaginary part.\n"
9959 "(sqrt 9.0) @result{} 3.0\n"
9960 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9961 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9962 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9964 #define FUNC_NAME s_scm_sqrt
9966 if (SCM_COMPLEXP (z
))
9968 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9969 && defined SCM_COMPLEX_VALUE
9970 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9972 double re
= SCM_COMPLEX_REAL (z
);
9973 double im
= SCM_COMPLEX_IMAG (z
);
9974 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9975 0.5 * atan2 (im
, re
));
9978 else if (SCM_NUMBERP (z
))
9980 double xx
= scm_to_double (z
);
9982 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9984 return scm_from_double (sqrt (xx
));
9987 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9998 if (scm_install_gmp_memory_functions
)
9999 mp_set_memory_functions (custom_gmp_malloc
,
10000 custom_gmp_realloc
,
10003 mpz_init_set_si (z_negative_one
, -1);
10005 /* It may be possible to tune the performance of some algorithms by using
10006 * the following constants to avoid the creation of bignums. Please, before
10007 * using these values, remember the two rules of program optimization:
10008 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10009 scm_c_define ("most-positive-fixnum",
10010 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10011 scm_c_define ("most-negative-fixnum",
10012 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10014 scm_add_feature ("complex");
10015 scm_add_feature ("inexact");
10016 flo0
= scm_from_double (0.0);
10017 flo_log10e
= scm_from_double (M_LOG10E
);
10019 /* determine floating point precision */
10020 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
10022 init_dblprec(&scm_dblprec
[i
-2],i
);
10023 init_fx_radix(fx_per_radix
[i
-2],i
);
10026 /* hard code precision for base 10 if the preprocessor tells us to... */
10027 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
10030 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10033 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10034 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10035 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10036 scm_i_divide2double_lo2b
,
10037 DBL_MANT_DIG
+ 1); /* 2 b^p */
10038 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10041 #include "libguile/numbers.x"
10046 c-file-style: "gnu"