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_RADIX 36
5255 /* use this array as a way to generate a single digit */
5256 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5258 static mpz_t dbl_minimum_normal_mantissa
;
5261 idbl2str (double dbl
, char *a
, int radix
)
5265 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5266 /* revert to existing behavior */
5271 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5281 else if (dbl
== 0.0)
5283 if (!double_is_non_negative_zero (dbl
))
5285 strcpy (a
+ ch
, "0.0");
5288 else if (isnan (dbl
))
5290 strcpy (a
, "+nan.0");
5294 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5295 Accurately" by Robert G. Burger and R. Kent Dybvig */
5298 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5299 int f_is_even
, f_is_odd
;
5302 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5303 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5304 if (e
< DBL_MIN_EXP
)
5306 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5311 f_is_even
= !mpz_odd_p (f
);
5312 f_is_odd
= !f_is_even
;
5314 /* Initialize r, s, mplus, and mminus according
5315 to Table 1 from the paper. */
5318 mpz_set_ui (mminus
, 1);
5319 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5320 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5322 mpz_set_ui (mplus
, 1);
5323 mpz_mul_2exp (r
, f
, 1);
5324 mpz_mul_2exp (s
, mminus
, 1 - e
);
5328 mpz_set_ui (mplus
, 2);
5329 mpz_mul_2exp (r
, f
, 2);
5330 mpz_mul_2exp (s
, mminus
, 2 - e
);
5335 mpz_set_ui (mminus
, 1);
5336 mpz_mul_2exp (mminus
, mminus
, e
);
5337 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5339 mpz_set (mplus
, mminus
);
5340 mpz_mul_2exp (r
, f
, 1 + e
);
5345 mpz_mul_2exp (mplus
, mminus
, 1);
5346 mpz_mul_2exp (r
, f
, 2 + e
);
5351 /* Find the smallest k such that:
5352 (r + mplus) / s < radix^k (if f is even)
5353 (r + mplus) / s <= radix^k (if f is odd) */
5355 /* IMPROVE-ME: Make an initial guess to speed this up */
5356 mpz_add (hi
, r
, mplus
);
5358 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5360 mpz_mul_ui (s
, s
, radix
);
5365 mpz_mul_ui (hi
, hi
, radix
);
5366 while (mpz_cmp (hi
, s
) < f_is_odd
)
5368 mpz_mul_ui (r
, r
, radix
);
5369 mpz_mul_ui (mplus
, mplus
, radix
);
5370 mpz_mul_ui (mminus
, mminus
, radix
);
5371 mpz_mul_ui (hi
, hi
, radix
);
5377 if (k
>= 8 || k
<= -3)
5379 /* Use scientific notation */
5387 /* Print leading zeroes */
5390 for (i
= 0; i
> k
; i
--)
5396 int end_1_p
, end_2_p
;
5399 mpz_mul_ui (mplus
, mplus
, radix
);
5400 mpz_mul_ui (mminus
, mminus
, radix
);
5401 mpz_mul_ui (r
, r
, radix
);
5402 mpz_fdiv_qr (digit
, r
, r
, s
);
5403 d
= mpz_get_ui (digit
);
5405 mpz_add (hi
, r
, mplus
);
5406 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5407 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5408 if (end_1_p
|| end_2_p
)
5410 mpz_mul_2exp (r
, r
, 1);
5415 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5417 a
[ch
++] = number_chars
[d
];
5424 a
[ch
++] = number_chars
[d
];
5443 ch
+= scm_iint2str (show_exp
, radix
, a
+ ch
);
5446 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5453 icmplx2str (double real
, double imag
, char *str
, int radix
)
5458 i
= idbl2str (real
, str
, radix
);
5459 #ifdef HAVE_COPYSIGN
5460 sgn
= copysign (1.0, imag
);
5464 /* Don't output a '+' for negative numbers or for Inf and
5465 NaN. They will provide their own sign. */
5466 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5468 i
+= idbl2str (imag
, &str
[i
], radix
);
5474 iflo2str (SCM flt
, char *str
, int radix
)
5477 if (SCM_REALP (flt
))
5478 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5480 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5485 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5486 characters in the result.
5488 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5490 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5495 return scm_iuint2str (-num
, rad
, p
) + 1;
5498 return scm_iuint2str (num
, rad
, p
);
5501 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5502 characters in the result.
5504 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5506 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5510 scm_t_uintmax n
= num
;
5512 if (rad
< 2 || rad
> 36)
5513 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5515 for (n
/= rad
; n
> 0; n
/= rad
)
5525 p
[i
] = number_chars
[d
];
5530 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5532 "Return a string holding the external representation of the\n"
5533 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5534 "inexact, a radix of 10 will be used.")
5535 #define FUNC_NAME s_scm_number_to_string
5539 if (SCM_UNBNDP (radix
))
5542 base
= scm_to_signed_integer (radix
, 2, 36);
5544 if (SCM_I_INUMP (n
))
5546 char num_buf
[SCM_INTBUFLEN
];
5547 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5548 return scm_from_locale_stringn (num_buf
, length
);
5550 else if (SCM_BIGP (n
))
5552 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5553 size_t len
= strlen (str
);
5554 void (*freefunc
) (void *, size_t);
5556 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5557 scm_remember_upto_here_1 (n
);
5558 ret
= scm_from_latin1_stringn (str
, len
);
5559 freefunc (str
, len
+ 1);
5562 else if (SCM_FRACTIONP (n
))
5564 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5565 scm_from_locale_string ("/"),
5566 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5568 else if (SCM_INEXACTP (n
))
5570 char num_buf
[FLOBUFLEN
];
5571 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5574 SCM_WRONG_TYPE_ARG (1, n
);
5579 /* These print routines used to be stubbed here so that scm_repl.c
5580 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5583 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5585 char num_buf
[FLOBUFLEN
];
5586 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5591 scm_i_print_double (double val
, SCM port
)
5593 char num_buf
[FLOBUFLEN
];
5594 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5598 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5601 char num_buf
[FLOBUFLEN
];
5602 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5607 scm_i_print_complex (double real
, double imag
, SCM port
)
5609 char num_buf
[FLOBUFLEN
];
5610 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5614 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5617 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5618 scm_display (str
, port
);
5619 scm_remember_upto_here_1 (str
);
5624 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5626 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5627 size_t len
= strlen (str
);
5628 void (*freefunc
) (void *, size_t);
5629 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5630 scm_remember_upto_here_1 (exp
);
5631 scm_lfwrite (str
, len
, port
);
5632 freefunc (str
, len
+ 1);
5635 /*** END nums->strs ***/
5638 /*** STRINGS -> NUMBERS ***/
5640 /* The following functions implement the conversion from strings to numbers.
5641 * The implementation somehow follows the grammar for numbers as it is given
5642 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5643 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5644 * points should be noted about the implementation:
5646 * * Each function keeps a local index variable 'idx' that points at the
5647 * current position within the parsed string. The global index is only
5648 * updated if the function could parse the corresponding syntactic unit
5651 * * Similarly, the functions keep track of indicators of inexactness ('#',
5652 * '.' or exponents) using local variables ('hash_seen', 'x').
5654 * * Sequences of digits are parsed into temporary variables holding fixnums.
5655 * Only if these fixnums would overflow, the result variables are updated
5656 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5657 * the temporary variables holding the fixnums are cleared, and the process
5658 * starts over again. If for example fixnums were able to store five decimal
5659 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5660 * and the result was computed as 12345 * 100000 + 67890. In other words,
5661 * only every five digits two bignum operations were performed.
5663 * Notes on the handling of exactness specifiers:
5665 * When parsing non-real complex numbers, we apply exactness specifiers on
5666 * per-component basis, as is done in PLT Scheme. For complex numbers
5667 * written in rectangular form, exactness specifiers are applied to the
5668 * real and imaginary parts before calling scm_make_rectangular. For
5669 * complex numbers written in polar form, exactness specifiers are applied
5670 * to the magnitude and angle before calling scm_make_polar.
5672 * There are two kinds of exactness specifiers: forced and implicit. A
5673 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5674 * the entire number, and applies to both components of a complex number.
5675 * "#e" causes each component to be made exact, and "#i" causes each
5676 * component to be made inexact. If no forced exactness specifier is
5677 * present, then the exactness of each component is determined
5678 * independently by the presence or absence of a decimal point or hash mark
5679 * within that component. If a decimal point or hash mark is present, the
5680 * component is made inexact, otherwise it is made exact.
5682 * After the exactness specifiers have been applied to each component, they
5683 * are passed to either scm_make_rectangular or scm_make_polar to produce
5684 * the final result. Note that this will result in a real number if the
5685 * imaginary part, magnitude, or angle is an exact 0.
5687 * For example, (string->number "#i5.0+0i") does the equivalent of:
5689 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5692 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5694 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5696 /* Caller is responsible for checking that the return value is in range
5697 for the given radix, which should be <= 36. */
5699 char_decimal_value (scm_t_uint32 c
)
5701 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5702 that's certainly above any valid decimal, so we take advantage of
5703 that to elide some tests. */
5704 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5706 /* If that failed, try extended hexadecimals, then. Only accept ascii
5711 if (c
>= (scm_t_uint32
) 'a')
5712 d
= c
- (scm_t_uint32
)'a' + 10U;
5717 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5718 in base RADIX. Upon success, return the unsigned integer and update
5719 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5721 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5722 unsigned int radix
, enum t_exactness
*p_exactness
)
5724 unsigned int idx
= *p_idx
;
5725 unsigned int hash_seen
= 0;
5726 scm_t_bits shift
= 1;
5728 unsigned int digit_value
;
5731 size_t len
= scm_i_string_length (mem
);
5736 c
= scm_i_string_ref (mem
, idx
);
5737 digit_value
= char_decimal_value (c
);
5738 if (digit_value
>= radix
)
5742 result
= SCM_I_MAKINUM (digit_value
);
5745 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5755 digit_value
= char_decimal_value (c
);
5756 /* This check catches non-decimals in addition to out-of-range
5758 if (digit_value
>= radix
)
5763 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5765 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5767 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5774 shift
= shift
* radix
;
5775 add
= add
* radix
+ digit_value
;
5780 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5782 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5786 *p_exactness
= INEXACT
;
5792 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5793 * covers the parts of the rules that start at a potential point. The value
5794 * of the digits up to the point have been parsed by the caller and are given
5795 * in variable result. The content of *p_exactness indicates, whether a hash
5796 * has already been seen in the digits before the point.
5799 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5802 mem2decimal_from_point (SCM result
, SCM mem
,
5803 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5805 unsigned int idx
= *p_idx
;
5806 enum t_exactness x
= *p_exactness
;
5807 size_t len
= scm_i_string_length (mem
);
5812 if (scm_i_string_ref (mem
, idx
) == '.')
5814 scm_t_bits shift
= 1;
5816 unsigned int digit_value
;
5817 SCM big_shift
= SCM_INUM1
;
5822 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5823 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5828 digit_value
= DIGIT2UINT (c
);
5839 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5841 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5842 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5844 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5852 add
= add
* 10 + digit_value
;
5858 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5859 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5860 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5863 result
= scm_divide (result
, big_shift
);
5865 /* We've seen a decimal point, thus the value is implicitly inexact. */
5877 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5879 switch (scm_i_string_ref (mem
, idx
))
5891 c
= scm_i_string_ref (mem
, idx
);
5899 c
= scm_i_string_ref (mem
, idx
);
5908 c
= scm_i_string_ref (mem
, idx
);
5913 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5917 exponent
= DIGIT2UINT (c
);
5920 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5921 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5924 if (exponent
<= SCM_MAXEXP
)
5925 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5931 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
5933 size_t exp_len
= idx
- start
;
5934 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5935 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5936 scm_out_of_range ("string->number", exp_num
);
5939 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5941 result
= scm_product (result
, e
);
5943 result
= scm_divide (result
, e
);
5945 /* We've seen an exponent, thus the value is implicitly inexact. */
5963 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5966 mem2ureal (SCM mem
, unsigned int *p_idx
,
5967 unsigned int radix
, enum t_exactness forced_x
,
5968 int allow_inf_or_nan
)
5970 unsigned int idx
= *p_idx
;
5972 size_t len
= scm_i_string_length (mem
);
5974 /* Start off believing that the number will be exact. This changes
5975 to INEXACT if we see a decimal point or a hash. */
5976 enum t_exactness implicit_x
= EXACT
;
5981 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
5982 switch (scm_i_string_ref (mem
, idx
))
5985 switch (scm_i_string_ref (mem
, idx
+ 1))
5988 switch (scm_i_string_ref (mem
, idx
+ 2))
5991 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
5992 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6000 switch (scm_i_string_ref (mem
, idx
+ 1))
6003 switch (scm_i_string_ref (mem
, idx
+ 2))
6006 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6008 /* Cobble up the fractional part. We might want to
6009 set the NaN's mantissa from it. */
6011 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6014 #if SCM_ENABLE_DEPRECATED == 1
6015 scm_c_issue_deprecation_warning
6016 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6029 if (scm_i_string_ref (mem
, idx
) == '.')
6033 else if (idx
+ 1 == len
)
6035 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6038 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6039 p_idx
, &implicit_x
);
6045 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6046 if (scm_is_false (uinteger
))
6051 else if (scm_i_string_ref (mem
, idx
) == '/')
6059 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6060 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6063 /* both are int/big here, I assume */
6064 result
= scm_i_make_ratio (uinteger
, divisor
);
6066 else if (radix
== 10)
6068 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6069 if (scm_is_false (result
))
6081 if (SCM_INEXACTP (result
))
6082 return scm_inexact_to_exact (result
);
6086 if (SCM_INEXACTP (result
))
6089 return scm_exact_to_inexact (result
);
6091 if (implicit_x
== INEXACT
)
6093 if (SCM_INEXACTP (result
))
6096 return scm_exact_to_inexact (result
);
6102 /* We should never get here */
6103 scm_syserror ("mem2ureal");
6107 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6110 mem2complex (SCM mem
, unsigned int idx
,
6111 unsigned int radix
, enum t_exactness forced_x
)
6116 size_t len
= scm_i_string_length (mem
);
6121 c
= scm_i_string_ref (mem
, idx
);
6136 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6137 if (scm_is_false (ureal
))
6139 /* input must be either +i or -i */
6144 if (scm_i_string_ref (mem
, idx
) == 'i'
6145 || scm_i_string_ref (mem
, idx
) == 'I')
6151 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6158 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6159 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6164 c
= scm_i_string_ref (mem
, idx
);
6168 /* either +<ureal>i or -<ureal>i */
6175 return scm_make_rectangular (SCM_INUM0
, ureal
);
6178 /* polar input: <real>@<real>. */
6189 c
= scm_i_string_ref (mem
, idx
);
6207 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6208 if (scm_is_false (angle
))
6213 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6214 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6216 result
= scm_make_polar (ureal
, angle
);
6221 /* expecting input matching <real>[+-]<ureal>?i */
6228 int sign
= (c
== '+') ? 1 : -1;
6229 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6231 if (scm_is_false (imag
))
6232 imag
= SCM_I_MAKINUM (sign
);
6233 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6234 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6238 if (scm_i_string_ref (mem
, idx
) != 'i'
6239 && scm_i_string_ref (mem
, idx
) != 'I')
6246 return scm_make_rectangular (ureal
, imag
);
6255 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6257 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6260 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6262 unsigned int idx
= 0;
6263 unsigned int radix
= NO_RADIX
;
6264 enum t_exactness forced_x
= NO_EXACTNESS
;
6265 size_t len
= scm_i_string_length (mem
);
6267 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6268 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6270 switch (scm_i_string_ref (mem
, idx
+ 1))
6273 if (radix
!= NO_RADIX
)
6278 if (radix
!= NO_RADIX
)
6283 if (forced_x
!= NO_EXACTNESS
)
6288 if (forced_x
!= NO_EXACTNESS
)
6293 if (radix
!= NO_RADIX
)
6298 if (radix
!= NO_RADIX
)
6308 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6309 if (radix
== NO_RADIX
)
6310 radix
= default_radix
;
6312 return mem2complex (mem
, idx
, radix
, forced_x
);
6316 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6317 unsigned int default_radix
)
6319 SCM str
= scm_from_locale_stringn (mem
, len
);
6321 return scm_i_string_to_number (str
, default_radix
);
6325 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6326 (SCM string
, SCM radix
),
6327 "Return a number of the maximally precise representation\n"
6328 "expressed by the given @var{string}. @var{radix} must be an\n"
6329 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6330 "is a default radix that may be overridden by an explicit radix\n"
6331 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6332 "supplied, then the default radix is 10. If string is not a\n"
6333 "syntactically valid notation for a number, then\n"
6334 "@code{string->number} returns @code{#f}.")
6335 #define FUNC_NAME s_scm_string_to_number
6339 SCM_VALIDATE_STRING (1, string
);
6341 if (SCM_UNBNDP (radix
))
6344 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6346 answer
= scm_i_string_to_number (string
, base
);
6347 scm_remember_upto_here_1 (string
);
6353 /*** END strs->nums ***/
6356 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6358 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6360 #define FUNC_NAME s_scm_number_p
6362 return scm_from_bool (SCM_NUMBERP (x
));
6366 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6368 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6369 "otherwise. Note that the sets of real, rational and integer\n"
6370 "values form subsets of the set of complex numbers, i. e. the\n"
6371 "predicate will also be fulfilled if @var{x} is a real,\n"
6372 "rational or integer number.")
6373 #define FUNC_NAME s_scm_complex_p
6375 /* all numbers are complex. */
6376 return scm_number_p (x
);
6380 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6382 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6383 "otherwise. Note that the set of integer values forms a subset of\n"
6384 "the set of real numbers, i. e. the predicate will also be\n"
6385 "fulfilled if @var{x} is an integer number.")
6386 #define FUNC_NAME s_scm_real_p
6388 return scm_from_bool
6389 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6393 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6395 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6396 "otherwise. Note that the set of integer values forms a subset of\n"
6397 "the set of rational numbers, i. e. the predicate will also be\n"
6398 "fulfilled if @var{x} is an integer number.")
6399 #define FUNC_NAME s_scm_rational_p
6401 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6403 else if (SCM_REALP (x
))
6404 /* due to their limited precision, finite floating point numbers are
6405 rational as well. (finite means neither infinity nor a NaN) */
6406 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6412 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6414 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6416 #define FUNC_NAME s_scm_integer_p
6418 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6420 else if (SCM_REALP (x
))
6422 double val
= SCM_REAL_VALUE (x
);
6423 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6431 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6432 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6433 (SCM x
, SCM y
, SCM rest
),
6434 "Return @code{#t} if all parameters are numerically equal.")
6435 #define FUNC_NAME s_scm_i_num_eq_p
6437 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6439 while (!scm_is_null (rest
))
6441 if (scm_is_false (scm_num_eq_p (x
, y
)))
6445 rest
= scm_cdr (rest
);
6447 return scm_num_eq_p (x
, y
);
6451 scm_num_eq_p (SCM x
, SCM y
)
6454 if (SCM_I_INUMP (x
))
6456 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6457 if (SCM_I_INUMP (y
))
6459 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6460 return scm_from_bool (xx
== yy
);
6462 else if (SCM_BIGP (y
))
6464 else if (SCM_REALP (y
))
6466 /* On a 32-bit system an inum fits a double, we can cast the inum
6467 to a double and compare.
6469 But on a 64-bit system an inum is bigger than a double and
6470 casting it to a double (call that dxx) will round. dxx is at
6471 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6472 an integer and fits a long. So we cast yy to a long and
6473 compare with plain xx.
6475 An alternative (for any size system actually) would be to check
6476 yy is an integer (with floor) and is in range of an inum
6477 (compare against appropriate powers of 2) then test
6478 xx==(scm_t_signed_bits)yy. It's just a matter of which
6479 casts/comparisons might be fastest or easiest for the cpu. */
6481 double yy
= SCM_REAL_VALUE (y
);
6482 return scm_from_bool ((double) xx
== yy
6483 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6484 || xx
== (scm_t_signed_bits
) yy
));
6486 else if (SCM_COMPLEXP (y
))
6487 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6488 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6489 else if (SCM_FRACTIONP (y
))
6492 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6494 else if (SCM_BIGP (x
))
6496 if (SCM_I_INUMP (y
))
6498 else if (SCM_BIGP (y
))
6500 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6501 scm_remember_upto_here_2 (x
, y
);
6502 return scm_from_bool (0 == cmp
);
6504 else if (SCM_REALP (y
))
6507 if (isnan (SCM_REAL_VALUE (y
)))
6509 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6510 scm_remember_upto_here_1 (x
);
6511 return scm_from_bool (0 == cmp
);
6513 else if (SCM_COMPLEXP (y
))
6516 if (0.0 != SCM_COMPLEX_IMAG (y
))
6518 if (isnan (SCM_COMPLEX_REAL (y
)))
6520 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6521 scm_remember_upto_here_1 (x
);
6522 return scm_from_bool (0 == cmp
);
6524 else if (SCM_FRACTIONP (y
))
6527 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6529 else if (SCM_REALP (x
))
6531 double xx
= SCM_REAL_VALUE (x
);
6532 if (SCM_I_INUMP (y
))
6534 /* see comments with inum/real above */
6535 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6536 return scm_from_bool (xx
== (double) yy
6537 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6538 || (scm_t_signed_bits
) xx
== yy
));
6540 else if (SCM_BIGP (y
))
6543 if (isnan (SCM_REAL_VALUE (x
)))
6545 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6546 scm_remember_upto_here_1 (y
);
6547 return scm_from_bool (0 == cmp
);
6549 else if (SCM_REALP (y
))
6550 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6551 else if (SCM_COMPLEXP (y
))
6552 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6553 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6554 else if (SCM_FRACTIONP (y
))
6556 double xx
= SCM_REAL_VALUE (x
);
6560 return scm_from_bool (xx
< 0.0);
6561 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6565 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6567 else if (SCM_COMPLEXP (x
))
6569 if (SCM_I_INUMP (y
))
6570 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6571 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6572 else if (SCM_BIGP (y
))
6575 if (0.0 != SCM_COMPLEX_IMAG (x
))
6577 if (isnan (SCM_COMPLEX_REAL (x
)))
6579 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6580 scm_remember_upto_here_1 (y
);
6581 return scm_from_bool (0 == cmp
);
6583 else if (SCM_REALP (y
))
6584 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6585 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6586 else if (SCM_COMPLEXP (y
))
6587 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6588 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6589 else if (SCM_FRACTIONP (y
))
6592 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6594 xx
= SCM_COMPLEX_REAL (x
);
6598 return scm_from_bool (xx
< 0.0);
6599 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6603 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6605 else if (SCM_FRACTIONP (x
))
6607 if (SCM_I_INUMP (y
))
6609 else if (SCM_BIGP (y
))
6611 else if (SCM_REALP (y
))
6613 double yy
= SCM_REAL_VALUE (y
);
6617 return scm_from_bool (0.0 < yy
);
6618 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6621 else if (SCM_COMPLEXP (y
))
6624 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6626 yy
= SCM_COMPLEX_REAL (y
);
6630 return scm_from_bool (0.0 < yy
);
6631 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6634 else if (SCM_FRACTIONP (y
))
6635 return scm_i_fraction_equalp (x
, y
);
6637 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6640 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6644 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6645 done are good for inums, but for bignums an answer can almost always be
6646 had by just examining a few high bits of the operands, as done by GMP in
6647 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6648 of the float exponent to take into account. */
6650 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6651 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6652 (SCM x
, SCM y
, SCM rest
),
6653 "Return @code{#t} if the list of parameters is monotonically\n"
6655 #define FUNC_NAME s_scm_i_num_less_p
6657 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6659 while (!scm_is_null (rest
))
6661 if (scm_is_false (scm_less_p (x
, y
)))
6665 rest
= scm_cdr (rest
);
6667 return scm_less_p (x
, y
);
6671 scm_less_p (SCM x
, SCM y
)
6674 if (SCM_I_INUMP (x
))
6676 scm_t_inum xx
= SCM_I_INUM (x
);
6677 if (SCM_I_INUMP (y
))
6679 scm_t_inum yy
= SCM_I_INUM (y
);
6680 return scm_from_bool (xx
< yy
);
6682 else if (SCM_BIGP (y
))
6684 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6685 scm_remember_upto_here_1 (y
);
6686 return scm_from_bool (sgn
> 0);
6688 else if (SCM_REALP (y
))
6689 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6690 else if (SCM_FRACTIONP (y
))
6692 /* "x < a/b" becomes "x*b < a" */
6694 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6695 y
= SCM_FRACTION_NUMERATOR (y
);
6699 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6701 else if (SCM_BIGP (x
))
6703 if (SCM_I_INUMP (y
))
6705 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6706 scm_remember_upto_here_1 (x
);
6707 return scm_from_bool (sgn
< 0);
6709 else if (SCM_BIGP (y
))
6711 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6712 scm_remember_upto_here_2 (x
, y
);
6713 return scm_from_bool (cmp
< 0);
6715 else if (SCM_REALP (y
))
6718 if (isnan (SCM_REAL_VALUE (y
)))
6720 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6721 scm_remember_upto_here_1 (x
);
6722 return scm_from_bool (cmp
< 0);
6724 else if (SCM_FRACTIONP (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_REALP (x
))
6731 if (SCM_I_INUMP (y
))
6732 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6733 else if (SCM_BIGP (y
))
6736 if (isnan (SCM_REAL_VALUE (x
)))
6738 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6739 scm_remember_upto_here_1 (y
);
6740 return scm_from_bool (cmp
> 0);
6742 else if (SCM_REALP (y
))
6743 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6744 else if (SCM_FRACTIONP (y
))
6746 double xx
= SCM_REAL_VALUE (x
);
6750 return scm_from_bool (xx
< 0.0);
6751 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
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_FRACTIONP (x
))
6759 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6761 /* "a/b < y" becomes "a < y*b" */
6762 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6763 x
= SCM_FRACTION_NUMERATOR (x
);
6766 else if (SCM_REALP (y
))
6768 double yy
= SCM_REAL_VALUE (y
);
6772 return scm_from_bool (0.0 < yy
);
6773 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6776 else if (SCM_FRACTIONP (y
))
6778 /* "a/b < c/d" becomes "a*d < c*b" */
6779 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6780 SCM_FRACTION_DENOMINATOR (y
));
6781 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6782 SCM_FRACTION_DENOMINATOR (x
));
6788 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6791 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6795 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6796 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6797 (SCM x
, SCM y
, SCM rest
),
6798 "Return @code{#t} if the list of parameters is monotonically\n"
6800 #define FUNC_NAME s_scm_i_num_gr_p
6802 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6804 while (!scm_is_null (rest
))
6806 if (scm_is_false (scm_gr_p (x
, y
)))
6810 rest
= scm_cdr (rest
);
6812 return scm_gr_p (x
, y
);
6815 #define FUNC_NAME s_scm_i_num_gr_p
6817 scm_gr_p (SCM x
, SCM y
)
6819 if (!SCM_NUMBERP (x
))
6820 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6821 else if (!SCM_NUMBERP (y
))
6822 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6824 return scm_less_p (y
, x
);
6829 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6830 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6831 (SCM x
, SCM y
, SCM rest
),
6832 "Return @code{#t} if the list of parameters is monotonically\n"
6834 #define FUNC_NAME s_scm_i_num_leq_p
6836 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6838 while (!scm_is_null (rest
))
6840 if (scm_is_false (scm_leq_p (x
, y
)))
6844 rest
= scm_cdr (rest
);
6846 return scm_leq_p (x
, y
);
6849 #define FUNC_NAME s_scm_i_num_leq_p
6851 scm_leq_p (SCM x
, SCM y
)
6853 if (!SCM_NUMBERP (x
))
6854 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6855 else if (!SCM_NUMBERP (y
))
6856 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6857 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6860 return scm_not (scm_less_p (y
, x
));
6865 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6866 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6867 (SCM x
, SCM y
, SCM rest
),
6868 "Return @code{#t} if the list of parameters is monotonically\n"
6870 #define FUNC_NAME s_scm_i_num_geq_p
6872 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6874 while (!scm_is_null (rest
))
6876 if (scm_is_false (scm_geq_p (x
, y
)))
6880 rest
= scm_cdr (rest
);
6882 return scm_geq_p (x
, y
);
6885 #define FUNC_NAME s_scm_i_num_geq_p
6887 scm_geq_p (SCM x
, SCM y
)
6889 if (!SCM_NUMBERP (x
))
6890 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6891 else if (!SCM_NUMBERP (y
))
6892 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6893 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6896 return scm_not (scm_less_p (x
, y
));
6901 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6903 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6905 #define FUNC_NAME s_scm_zero_p
6907 if (SCM_I_INUMP (z
))
6908 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6909 else if (SCM_BIGP (z
))
6911 else if (SCM_REALP (z
))
6912 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6913 else if (SCM_COMPLEXP (z
))
6914 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6915 && SCM_COMPLEX_IMAG (z
) == 0.0);
6916 else if (SCM_FRACTIONP (z
))
6919 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6924 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6926 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6928 #define FUNC_NAME s_scm_positive_p
6930 if (SCM_I_INUMP (x
))
6931 return scm_from_bool (SCM_I_INUM (x
) > 0);
6932 else if (SCM_BIGP (x
))
6934 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6935 scm_remember_upto_here_1 (x
);
6936 return scm_from_bool (sgn
> 0);
6938 else if (SCM_REALP (x
))
6939 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6940 else if (SCM_FRACTIONP (x
))
6941 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6943 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6948 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6950 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6952 #define FUNC_NAME s_scm_negative_p
6954 if (SCM_I_INUMP (x
))
6955 return scm_from_bool (SCM_I_INUM (x
) < 0);
6956 else if (SCM_BIGP (x
))
6958 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6959 scm_remember_upto_here_1 (x
);
6960 return scm_from_bool (sgn
< 0);
6962 else if (SCM_REALP (x
))
6963 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6964 else if (SCM_FRACTIONP (x
))
6965 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6967 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6972 /* scm_min and scm_max return an inexact when either argument is inexact, as
6973 required by r5rs. On that basis, for exact/inexact combinations the
6974 exact is converted to inexact to compare and possibly return. This is
6975 unlike scm_less_p above which takes some trouble to preserve all bits in
6976 its test, such trouble is not required for min and max. */
6978 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6979 (SCM x
, SCM y
, SCM rest
),
6980 "Return the maximum of all parameter values.")
6981 #define FUNC_NAME s_scm_i_max
6983 while (!scm_is_null (rest
))
6984 { x
= scm_max (x
, y
);
6986 rest
= scm_cdr (rest
);
6988 return scm_max (x
, y
);
6992 #define s_max s_scm_i_max
6993 #define g_max g_scm_i_max
6996 scm_max (SCM x
, SCM y
)
7001 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7002 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7005 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7008 if (SCM_I_INUMP (x
))
7010 scm_t_inum xx
= SCM_I_INUM (x
);
7011 if (SCM_I_INUMP (y
))
7013 scm_t_inum yy
= SCM_I_INUM (y
);
7014 return (xx
< yy
) ? y
: x
;
7016 else if (SCM_BIGP (y
))
7018 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7019 scm_remember_upto_here_1 (y
);
7020 return (sgn
< 0) ? x
: y
;
7022 else if (SCM_REALP (y
))
7025 double yyd
= SCM_REAL_VALUE (y
);
7028 return scm_from_double (xxd
);
7029 /* If y is a NaN, then "==" is false and we return the NaN */
7030 else if (SCM_LIKELY (!(xxd
== yyd
)))
7032 /* Handle signed zeroes properly */
7038 else if (SCM_FRACTIONP (y
))
7041 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7044 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7046 else if (SCM_BIGP (x
))
7048 if (SCM_I_INUMP (y
))
7050 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7051 scm_remember_upto_here_1 (x
);
7052 return (sgn
< 0) ? y
: x
;
7054 else if (SCM_BIGP (y
))
7056 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7057 scm_remember_upto_here_2 (x
, y
);
7058 return (cmp
> 0) ? x
: y
;
7060 else if (SCM_REALP (y
))
7062 /* if y==NaN then xx>yy is false, so we return the NaN y */
7065 xx
= scm_i_big2dbl (x
);
7066 yy
= SCM_REAL_VALUE (y
);
7067 return (xx
> yy
? scm_from_double (xx
) : y
);
7069 else if (SCM_FRACTIONP (y
))
7074 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7076 else if (SCM_REALP (x
))
7078 if (SCM_I_INUMP (y
))
7080 scm_t_inum yy
= SCM_I_INUM (y
);
7081 double xxd
= SCM_REAL_VALUE (x
);
7085 return scm_from_double (yyd
);
7086 /* If x is a NaN, then "==" is false and we return the NaN */
7087 else if (SCM_LIKELY (!(xxd
== yyd
)))
7089 /* Handle signed zeroes properly */
7095 else if (SCM_BIGP (y
))
7100 else if (SCM_REALP (y
))
7102 double xx
= SCM_REAL_VALUE (x
);
7103 double yy
= SCM_REAL_VALUE (y
);
7105 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7108 else if (SCM_LIKELY (xx
< yy
))
7110 /* If neither (xx > yy) nor (xx < yy), then
7111 either they're equal or one is a NaN */
7112 else if (SCM_UNLIKELY (isnan (xx
)))
7113 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7114 else if (SCM_UNLIKELY (isnan (yy
)))
7115 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7116 /* xx == yy, but handle signed zeroes properly */
7117 else if (double_is_non_negative_zero (yy
))
7122 else if (SCM_FRACTIONP (y
))
7124 double yy
= scm_i_fraction2double (y
);
7125 double xx
= SCM_REAL_VALUE (x
);
7126 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7129 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7131 else if (SCM_FRACTIONP (x
))
7133 if (SCM_I_INUMP (y
))
7137 else if (SCM_BIGP (y
))
7141 else if (SCM_REALP (y
))
7143 double xx
= scm_i_fraction2double (x
);
7144 /* if y==NaN then ">" is false, so we return the NaN y */
7145 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7147 else if (SCM_FRACTIONP (y
))
7152 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7155 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7159 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7160 (SCM x
, SCM y
, SCM rest
),
7161 "Return the minimum of all parameter values.")
7162 #define FUNC_NAME s_scm_i_min
7164 while (!scm_is_null (rest
))
7165 { x
= scm_min (x
, y
);
7167 rest
= scm_cdr (rest
);
7169 return scm_min (x
, y
);
7173 #define s_min s_scm_i_min
7174 #define g_min g_scm_i_min
7177 scm_min (SCM x
, SCM y
)
7182 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7183 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7186 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7189 if (SCM_I_INUMP (x
))
7191 scm_t_inum xx
= SCM_I_INUM (x
);
7192 if (SCM_I_INUMP (y
))
7194 scm_t_inum yy
= SCM_I_INUM (y
);
7195 return (xx
< yy
) ? x
: y
;
7197 else if (SCM_BIGP (y
))
7199 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7200 scm_remember_upto_here_1 (y
);
7201 return (sgn
< 0) ? y
: x
;
7203 else if (SCM_REALP (y
))
7206 /* if y==NaN then "<" is false and we return NaN */
7207 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7209 else if (SCM_FRACTIONP (y
))
7212 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7215 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7217 else if (SCM_BIGP (x
))
7219 if (SCM_I_INUMP (y
))
7221 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7222 scm_remember_upto_here_1 (x
);
7223 return (sgn
< 0) ? x
: y
;
7225 else if (SCM_BIGP (y
))
7227 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7228 scm_remember_upto_here_2 (x
, y
);
7229 return (cmp
> 0) ? y
: x
;
7231 else if (SCM_REALP (y
))
7233 /* if y==NaN then xx<yy is false, so we return the NaN y */
7236 xx
= scm_i_big2dbl (x
);
7237 yy
= SCM_REAL_VALUE (y
);
7238 return (xx
< yy
? scm_from_double (xx
) : y
);
7240 else if (SCM_FRACTIONP (y
))
7245 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7247 else if (SCM_REALP (x
))
7249 if (SCM_I_INUMP (y
))
7251 double z
= SCM_I_INUM (y
);
7252 /* if x==NaN then "<" is false and we return NaN */
7253 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7255 else if (SCM_BIGP (y
))
7260 else if (SCM_REALP (y
))
7262 double xx
= SCM_REAL_VALUE (x
);
7263 double yy
= SCM_REAL_VALUE (y
);
7265 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7268 else if (SCM_LIKELY (xx
> yy
))
7270 /* If neither (xx < yy) nor (xx > yy), then
7271 either they're equal or one is a NaN */
7272 else if (SCM_UNLIKELY (isnan (xx
)))
7273 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7274 else if (SCM_UNLIKELY (isnan (yy
)))
7275 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7276 /* xx == yy, but handle signed zeroes properly */
7277 else if (double_is_non_negative_zero (xx
))
7282 else if (SCM_FRACTIONP (y
))
7284 double yy
= scm_i_fraction2double (y
);
7285 double xx
= SCM_REAL_VALUE (x
);
7286 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7289 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7291 else if (SCM_FRACTIONP (x
))
7293 if (SCM_I_INUMP (y
))
7297 else if (SCM_BIGP (y
))
7301 else if (SCM_REALP (y
))
7303 double xx
= scm_i_fraction2double (x
);
7304 /* if y==NaN then "<" is false, so we return the NaN y */
7305 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7307 else if (SCM_FRACTIONP (y
))
7312 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7315 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7319 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7320 (SCM x
, SCM y
, SCM rest
),
7321 "Return the sum of all parameter values. Return 0 if called without\n"
7323 #define FUNC_NAME s_scm_i_sum
7325 while (!scm_is_null (rest
))
7326 { x
= scm_sum (x
, y
);
7328 rest
= scm_cdr (rest
);
7330 return scm_sum (x
, y
);
7334 #define s_sum s_scm_i_sum
7335 #define g_sum g_scm_i_sum
7338 scm_sum (SCM x
, SCM y
)
7340 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7342 if (SCM_NUMBERP (x
)) return x
;
7343 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7344 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7347 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7349 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7351 scm_t_inum xx
= SCM_I_INUM (x
);
7352 scm_t_inum yy
= SCM_I_INUM (y
);
7353 scm_t_inum z
= xx
+ yy
;
7354 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7356 else if (SCM_BIGP (y
))
7361 else if (SCM_REALP (y
))
7363 scm_t_inum xx
= SCM_I_INUM (x
);
7364 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7366 else if (SCM_COMPLEXP (y
))
7368 scm_t_inum xx
= SCM_I_INUM (x
);
7369 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7370 SCM_COMPLEX_IMAG (y
));
7372 else if (SCM_FRACTIONP (y
))
7373 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7374 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7375 SCM_FRACTION_DENOMINATOR (y
));
7377 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7378 } else if (SCM_BIGP (x
))
7380 if (SCM_I_INUMP (y
))
7385 inum
= SCM_I_INUM (y
);
7388 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7391 SCM result
= scm_i_mkbig ();
7392 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7393 scm_remember_upto_here_1 (x
);
7394 /* we know the result will have to be a bignum */
7397 return scm_i_normbig (result
);
7401 SCM result
= scm_i_mkbig ();
7402 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7403 scm_remember_upto_here_1 (x
);
7404 /* we know the result will have to be a bignum */
7407 return scm_i_normbig (result
);
7410 else if (SCM_BIGP (y
))
7412 SCM result
= scm_i_mkbig ();
7413 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7414 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7415 mpz_add (SCM_I_BIG_MPZ (result
),
7418 scm_remember_upto_here_2 (x
, y
);
7419 /* we know the result will have to be a bignum */
7422 return scm_i_normbig (result
);
7424 else if (SCM_REALP (y
))
7426 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7427 scm_remember_upto_here_1 (x
);
7428 return scm_from_double (result
);
7430 else if (SCM_COMPLEXP (y
))
7432 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7433 + SCM_COMPLEX_REAL (y
));
7434 scm_remember_upto_here_1 (x
);
7435 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7437 else if (SCM_FRACTIONP (y
))
7438 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7439 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7440 SCM_FRACTION_DENOMINATOR (y
));
7442 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7444 else if (SCM_REALP (x
))
7446 if (SCM_I_INUMP (y
))
7447 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7448 else if (SCM_BIGP (y
))
7450 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7451 scm_remember_upto_here_1 (y
);
7452 return scm_from_double (result
);
7454 else if (SCM_REALP (y
))
7455 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7456 else if (SCM_COMPLEXP (y
))
7457 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7458 SCM_COMPLEX_IMAG (y
));
7459 else if (SCM_FRACTIONP (y
))
7460 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7462 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7464 else if (SCM_COMPLEXP (x
))
7466 if (SCM_I_INUMP (y
))
7467 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7468 SCM_COMPLEX_IMAG (x
));
7469 else if (SCM_BIGP (y
))
7471 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7472 + SCM_COMPLEX_REAL (x
));
7473 scm_remember_upto_here_1 (y
);
7474 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7476 else if (SCM_REALP (y
))
7477 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7478 SCM_COMPLEX_IMAG (x
));
7479 else if (SCM_COMPLEXP (y
))
7480 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7481 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7482 else if (SCM_FRACTIONP (y
))
7483 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7484 SCM_COMPLEX_IMAG (x
));
7486 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7488 else if (SCM_FRACTIONP (x
))
7490 if (SCM_I_INUMP (y
))
7491 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7492 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7493 SCM_FRACTION_DENOMINATOR (x
));
7494 else if (SCM_BIGP (y
))
7495 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7496 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7497 SCM_FRACTION_DENOMINATOR (x
));
7498 else if (SCM_REALP (y
))
7499 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7500 else if (SCM_COMPLEXP (y
))
7501 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7502 SCM_COMPLEX_IMAG (y
));
7503 else if (SCM_FRACTIONP (y
))
7504 /* a/b + c/d = (ad + bc) / bd */
7505 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7506 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7507 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7509 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7512 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7516 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7518 "Return @math{@var{x}+1}.")
7519 #define FUNC_NAME s_scm_oneplus
7521 return scm_sum (x
, SCM_INUM1
);
7526 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7527 (SCM x
, SCM y
, SCM rest
),
7528 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7529 "the sum of all but the first argument are subtracted from the first\n"
7531 #define FUNC_NAME s_scm_i_difference
7533 while (!scm_is_null (rest
))
7534 { x
= scm_difference (x
, y
);
7536 rest
= scm_cdr (rest
);
7538 return scm_difference (x
, y
);
7542 #define s_difference s_scm_i_difference
7543 #define g_difference g_scm_i_difference
7546 scm_difference (SCM x
, SCM y
)
7547 #define FUNC_NAME s_difference
7549 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7552 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7554 if (SCM_I_INUMP (x
))
7556 scm_t_inum xx
= -SCM_I_INUM (x
);
7557 if (SCM_FIXABLE (xx
))
7558 return SCM_I_MAKINUM (xx
);
7560 return scm_i_inum2big (xx
);
7562 else if (SCM_BIGP (x
))
7563 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7564 bignum, but negating that gives a fixnum. */
7565 return scm_i_normbig (scm_i_clonebig (x
, 0));
7566 else if (SCM_REALP (x
))
7567 return scm_from_double (-SCM_REAL_VALUE (x
));
7568 else if (SCM_COMPLEXP (x
))
7569 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7570 -SCM_COMPLEX_IMAG (x
));
7571 else if (SCM_FRACTIONP (x
))
7572 return scm_i_make_ratio_already_reduced
7573 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7574 SCM_FRACTION_DENOMINATOR (x
));
7576 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7579 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7581 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7583 scm_t_inum xx
= SCM_I_INUM (x
);
7584 scm_t_inum yy
= SCM_I_INUM (y
);
7585 scm_t_inum z
= xx
- yy
;
7586 if (SCM_FIXABLE (z
))
7587 return SCM_I_MAKINUM (z
);
7589 return scm_i_inum2big (z
);
7591 else if (SCM_BIGP (y
))
7593 /* inum-x - big-y */
7594 scm_t_inum xx
= SCM_I_INUM (x
);
7598 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7599 bignum, but negating that gives a fixnum. */
7600 return scm_i_normbig (scm_i_clonebig (y
, 0));
7604 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7605 SCM result
= scm_i_mkbig ();
7608 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7611 /* x - y == -(y + -x) */
7612 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7613 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7615 scm_remember_upto_here_1 (y
);
7617 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7618 /* we know the result will have to be a bignum */
7621 return scm_i_normbig (result
);
7624 else if (SCM_REALP (y
))
7626 scm_t_inum xx
= SCM_I_INUM (x
);
7629 * We need to handle x == exact 0
7630 * specially because R6RS states that:
7631 * (- 0.0) ==> -0.0 and
7632 * (- 0.0 0.0) ==> 0.0
7633 * and the scheme compiler changes
7634 * (- 0.0) into (- 0 0.0)
7635 * So we need to treat (- 0 0.0) like (- 0.0).
7636 * At the C level, (-x) is different than (0.0 - x).
7637 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7640 return scm_from_double (- SCM_REAL_VALUE (y
));
7642 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7644 else if (SCM_COMPLEXP (y
))
7646 scm_t_inum xx
= SCM_I_INUM (x
);
7648 /* We need to handle x == exact 0 specially.
7649 See the comment above (for SCM_REALP (y)) */
7651 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7652 - SCM_COMPLEX_IMAG (y
));
7654 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7655 - SCM_COMPLEX_IMAG (y
));
7657 else if (SCM_FRACTIONP (y
))
7658 /* a - b/c = (ac - b) / c */
7659 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7660 SCM_FRACTION_NUMERATOR (y
)),
7661 SCM_FRACTION_DENOMINATOR (y
));
7663 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7665 else if (SCM_BIGP (x
))
7667 if (SCM_I_INUMP (y
))
7669 /* big-x - inum-y */
7670 scm_t_inum yy
= SCM_I_INUM (y
);
7671 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7673 scm_remember_upto_here_1 (x
);
7675 return (SCM_FIXABLE (-yy
) ?
7676 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7679 SCM result
= scm_i_mkbig ();
7682 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7684 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7685 scm_remember_upto_here_1 (x
);
7687 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7688 /* we know the result will have to be a bignum */
7691 return scm_i_normbig (result
);
7694 else if (SCM_BIGP (y
))
7696 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7697 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7698 SCM result
= scm_i_mkbig ();
7699 mpz_sub (SCM_I_BIG_MPZ (result
),
7702 scm_remember_upto_here_2 (x
, y
);
7703 /* we know the result will have to be a bignum */
7704 if ((sgn_x
== 1) && (sgn_y
== -1))
7706 if ((sgn_x
== -1) && (sgn_y
== 1))
7708 return scm_i_normbig (result
);
7710 else if (SCM_REALP (y
))
7712 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7713 scm_remember_upto_here_1 (x
);
7714 return scm_from_double (result
);
7716 else if (SCM_COMPLEXP (y
))
7718 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7719 - SCM_COMPLEX_REAL (y
));
7720 scm_remember_upto_here_1 (x
);
7721 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7723 else if (SCM_FRACTIONP (y
))
7724 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7725 SCM_FRACTION_NUMERATOR (y
)),
7726 SCM_FRACTION_DENOMINATOR (y
));
7727 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7729 else if (SCM_REALP (x
))
7731 if (SCM_I_INUMP (y
))
7732 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7733 else if (SCM_BIGP (y
))
7735 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7736 scm_remember_upto_here_1 (x
);
7737 return scm_from_double (result
);
7739 else if (SCM_REALP (y
))
7740 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7741 else if (SCM_COMPLEXP (y
))
7742 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7743 -SCM_COMPLEX_IMAG (y
));
7744 else if (SCM_FRACTIONP (y
))
7745 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7747 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7749 else if (SCM_COMPLEXP (x
))
7751 if (SCM_I_INUMP (y
))
7752 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7753 SCM_COMPLEX_IMAG (x
));
7754 else if (SCM_BIGP (y
))
7756 double real_part
= (SCM_COMPLEX_REAL (x
)
7757 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7758 scm_remember_upto_here_1 (x
);
7759 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7761 else if (SCM_REALP (y
))
7762 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7763 SCM_COMPLEX_IMAG (x
));
7764 else if (SCM_COMPLEXP (y
))
7765 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7766 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7767 else if (SCM_FRACTIONP (y
))
7768 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7769 SCM_COMPLEX_IMAG (x
));
7771 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7773 else if (SCM_FRACTIONP (x
))
7775 if (SCM_I_INUMP (y
))
7776 /* a/b - c = (a - cb) / b */
7777 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7778 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7779 SCM_FRACTION_DENOMINATOR (x
));
7780 else if (SCM_BIGP (y
))
7781 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7782 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7783 SCM_FRACTION_DENOMINATOR (x
));
7784 else if (SCM_REALP (y
))
7785 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7786 else if (SCM_COMPLEXP (y
))
7787 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7788 -SCM_COMPLEX_IMAG (y
));
7789 else if (SCM_FRACTIONP (y
))
7790 /* a/b - c/d = (ad - bc) / bd */
7791 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7792 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7793 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7795 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7798 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7803 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7805 "Return @math{@var{x}-1}.")
7806 #define FUNC_NAME s_scm_oneminus
7808 return scm_difference (x
, SCM_INUM1
);
7813 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7814 (SCM x
, SCM y
, SCM rest
),
7815 "Return the product of all arguments. If called without arguments,\n"
7817 #define FUNC_NAME s_scm_i_product
7819 while (!scm_is_null (rest
))
7820 { x
= scm_product (x
, y
);
7822 rest
= scm_cdr (rest
);
7824 return scm_product (x
, y
);
7828 #define s_product s_scm_i_product
7829 #define g_product g_scm_i_product
7832 scm_product (SCM x
, SCM y
)
7834 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7837 return SCM_I_MAKINUM (1L);
7838 else if (SCM_NUMBERP (x
))
7841 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7844 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7849 xx
= SCM_I_INUM (x
);
7854 /* exact1 is the universal multiplicative identity */
7858 /* exact0 times a fixnum is exact0: optimize this case */
7859 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7861 /* if the other argument is inexact, the result is inexact,
7862 and we must do the multiplication in order to handle
7863 infinities and NaNs properly. */
7864 else if (SCM_REALP (y
))
7865 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7866 else if (SCM_COMPLEXP (y
))
7867 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7868 0.0 * SCM_COMPLEX_IMAG (y
));
7869 /* we've already handled inexact numbers,
7870 so y must be exact, and we return exact0 */
7871 else if (SCM_NUMP (y
))
7874 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7878 * This case is important for more than just optimization.
7879 * It handles the case of negating
7880 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7881 * which is a bignum that must be changed back into a fixnum.
7882 * Failure to do so will cause the following to return #f:
7883 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7885 return scm_difference(y
, SCM_UNDEFINED
);
7889 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7891 scm_t_inum yy
= SCM_I_INUM (y
);
7892 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7893 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7894 if (SCM_FIXABLE (kk
))
7895 return SCM_I_MAKINUM (kk
);
7897 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7898 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7899 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7900 return SCM_I_MAKINUM (xx
* yy
);
7904 SCM result
= scm_i_inum2big (xx
);
7905 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7906 return scm_i_normbig (result
);
7909 else if (SCM_BIGP (y
))
7911 SCM result
= scm_i_mkbig ();
7912 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7913 scm_remember_upto_here_1 (y
);
7916 else if (SCM_REALP (y
))
7917 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7918 else if (SCM_COMPLEXP (y
))
7919 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7920 xx
* SCM_COMPLEX_IMAG (y
));
7921 else if (SCM_FRACTIONP (y
))
7922 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7923 SCM_FRACTION_DENOMINATOR (y
));
7925 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7927 else if (SCM_BIGP (x
))
7929 if (SCM_I_INUMP (y
))
7934 else if (SCM_BIGP (y
))
7936 SCM result
= scm_i_mkbig ();
7937 mpz_mul (SCM_I_BIG_MPZ (result
),
7940 scm_remember_upto_here_2 (x
, y
);
7943 else if (SCM_REALP (y
))
7945 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7946 scm_remember_upto_here_1 (x
);
7947 return scm_from_double (result
);
7949 else if (SCM_COMPLEXP (y
))
7951 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7952 scm_remember_upto_here_1 (x
);
7953 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7954 z
* SCM_COMPLEX_IMAG (y
));
7956 else if (SCM_FRACTIONP (y
))
7957 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7958 SCM_FRACTION_DENOMINATOR (y
));
7960 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7962 else if (SCM_REALP (x
))
7964 if (SCM_I_INUMP (y
))
7969 else if (SCM_BIGP (y
))
7971 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7972 scm_remember_upto_here_1 (y
);
7973 return scm_from_double (result
);
7975 else if (SCM_REALP (y
))
7976 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7977 else if (SCM_COMPLEXP (y
))
7978 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7979 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7980 else if (SCM_FRACTIONP (y
))
7981 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7983 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7985 else if (SCM_COMPLEXP (x
))
7987 if (SCM_I_INUMP (y
))
7992 else if (SCM_BIGP (y
))
7994 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7995 scm_remember_upto_here_1 (y
);
7996 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7997 z
* SCM_COMPLEX_IMAG (x
));
7999 else if (SCM_REALP (y
))
8000 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8001 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8002 else if (SCM_COMPLEXP (y
))
8004 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8005 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8006 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8007 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8009 else if (SCM_FRACTIONP (y
))
8011 double yy
= scm_i_fraction2double (y
);
8012 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8013 yy
* SCM_COMPLEX_IMAG (x
));
8016 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8018 else if (SCM_FRACTIONP (x
))
8020 if (SCM_I_INUMP (y
))
8021 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8022 SCM_FRACTION_DENOMINATOR (x
));
8023 else if (SCM_BIGP (y
))
8024 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8025 SCM_FRACTION_DENOMINATOR (x
));
8026 else if (SCM_REALP (y
))
8027 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8028 else if (SCM_COMPLEXP (y
))
8030 double xx
= scm_i_fraction2double (x
);
8031 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8032 xx
* SCM_COMPLEX_IMAG (y
));
8034 else if (SCM_FRACTIONP (y
))
8035 /* a/b * c/d = ac / bd */
8036 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8037 SCM_FRACTION_NUMERATOR (y
)),
8038 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8039 SCM_FRACTION_DENOMINATOR (y
)));
8041 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8044 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8047 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8048 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8049 #define ALLOW_DIVIDE_BY_ZERO
8050 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8053 /* The code below for complex division is adapted from the GNU
8054 libstdc++, which adapted it from f2c's libF77, and is subject to
8057 /****************************************************************
8058 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8060 Permission to use, copy, modify, and distribute this software
8061 and its documentation for any purpose and without fee is hereby
8062 granted, provided that the above copyright notice appear in all
8063 copies and that both that the copyright notice and this
8064 permission notice and warranty disclaimer appear in supporting
8065 documentation, and that the names of AT&T Bell Laboratories or
8066 Bellcore or any of their entities not be used in advertising or
8067 publicity pertaining to distribution of the software without
8068 specific, written prior permission.
8070 AT&T and Bellcore disclaim all warranties with regard to this
8071 software, including all implied warranties of merchantability
8072 and fitness. In no event shall AT&T or Bellcore be liable for
8073 any special, indirect or consequential damages or any damages
8074 whatsoever resulting from loss of use, data or profits, whether
8075 in an action of contract, negligence or other tortious action,
8076 arising out of or in connection with the use or performance of
8078 ****************************************************************/
8080 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8081 (SCM x
, SCM y
, SCM rest
),
8082 "Divide the first argument by the product of the remaining\n"
8083 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8085 #define FUNC_NAME s_scm_i_divide
8087 while (!scm_is_null (rest
))
8088 { x
= scm_divide (x
, y
);
8090 rest
= scm_cdr (rest
);
8092 return scm_divide (x
, y
);
8096 #define s_divide s_scm_i_divide
8097 #define g_divide g_scm_i_divide
8100 scm_divide (SCM x
, SCM y
)
8101 #define FUNC_NAME s_divide
8105 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8108 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8109 else if (SCM_I_INUMP (x
))
8111 scm_t_inum xx
= SCM_I_INUM (x
);
8112 if (xx
== 1 || xx
== -1)
8114 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8116 scm_num_overflow (s_divide
);
8119 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8121 else if (SCM_BIGP (x
))
8122 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8123 else if (SCM_REALP (x
))
8125 double xx
= SCM_REAL_VALUE (x
);
8126 #ifndef ALLOW_DIVIDE_BY_ZERO
8128 scm_num_overflow (s_divide
);
8131 return scm_from_double (1.0 / xx
);
8133 else if (SCM_COMPLEXP (x
))
8135 double r
= SCM_COMPLEX_REAL (x
);
8136 double i
= SCM_COMPLEX_IMAG (x
);
8137 if (fabs(r
) <= fabs(i
))
8140 double d
= i
* (1.0 + t
* t
);
8141 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8146 double d
= r
* (1.0 + t
* t
);
8147 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8150 else if (SCM_FRACTIONP (x
))
8151 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8152 SCM_FRACTION_NUMERATOR (x
));
8154 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8157 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8159 scm_t_inum xx
= SCM_I_INUM (x
);
8160 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8162 scm_t_inum yy
= SCM_I_INUM (y
);
8165 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8166 scm_num_overflow (s_divide
);
8168 return scm_from_double ((double) xx
/ (double) yy
);
8171 else if (xx
% yy
!= 0)
8172 return scm_i_make_ratio (x
, y
);
8175 scm_t_inum z
= xx
/ yy
;
8176 if (SCM_FIXABLE (z
))
8177 return SCM_I_MAKINUM (z
);
8179 return scm_i_inum2big (z
);
8182 else if (SCM_BIGP (y
))
8183 return scm_i_make_ratio (x
, y
);
8184 else if (SCM_REALP (y
))
8186 double yy
= SCM_REAL_VALUE (y
);
8187 #ifndef ALLOW_DIVIDE_BY_ZERO
8189 scm_num_overflow (s_divide
);
8192 /* FIXME: Precision may be lost here due to:
8193 (1) The cast from 'scm_t_inum' to 'double'
8194 (2) Double rounding */
8195 return scm_from_double ((double) xx
/ yy
);
8197 else if (SCM_COMPLEXP (y
))
8200 complex_div
: /* y _must_ be a complex number */
8202 double r
= SCM_COMPLEX_REAL (y
);
8203 double i
= SCM_COMPLEX_IMAG (y
);
8204 if (fabs(r
) <= fabs(i
))
8207 double d
= i
* (1.0 + t
* t
);
8208 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8213 double d
= r
* (1.0 + t
* t
);
8214 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8218 else if (SCM_FRACTIONP (y
))
8219 /* a / b/c = ac / b */
8220 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8221 SCM_FRACTION_NUMERATOR (y
));
8223 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8225 else if (SCM_BIGP (x
))
8227 if (SCM_I_INUMP (y
))
8229 scm_t_inum yy
= SCM_I_INUM (y
);
8232 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8233 scm_num_overflow (s_divide
);
8235 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8236 scm_remember_upto_here_1 (x
);
8237 return (sgn
== 0) ? scm_nan () : scm_inf ();
8244 /* FIXME: HMM, what are the relative performance issues here?
8245 We need to test. Is it faster on average to test
8246 divisible_p, then perform whichever operation, or is it
8247 faster to perform the integer div opportunistically and
8248 switch to real if there's a remainder? For now we take the
8249 middle ground: test, then if divisible, use the faster div
8252 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8253 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8257 SCM result
= scm_i_mkbig ();
8258 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8259 scm_remember_upto_here_1 (x
);
8261 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8262 return scm_i_normbig (result
);
8265 return scm_i_make_ratio (x
, y
);
8268 else if (SCM_BIGP (y
))
8270 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8274 SCM result
= scm_i_mkbig ();
8275 mpz_divexact (SCM_I_BIG_MPZ (result
),
8278 scm_remember_upto_here_2 (x
, y
);
8279 return scm_i_normbig (result
);
8282 return scm_i_make_ratio (x
, y
);
8284 else if (SCM_REALP (y
))
8286 double yy
= SCM_REAL_VALUE (y
);
8287 #ifndef ALLOW_DIVIDE_BY_ZERO
8289 scm_num_overflow (s_divide
);
8292 /* FIXME: Precision may be lost here due to:
8293 (1) scm_i_big2dbl (2) Double rounding */
8294 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8296 else if (SCM_COMPLEXP (y
))
8298 a
= scm_i_big2dbl (x
);
8301 else if (SCM_FRACTIONP (y
))
8302 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8303 SCM_FRACTION_NUMERATOR (y
));
8305 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8307 else if (SCM_REALP (x
))
8309 double rx
= SCM_REAL_VALUE (x
);
8310 if (SCM_I_INUMP (y
))
8312 scm_t_inum yy
= SCM_I_INUM (y
);
8313 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8315 scm_num_overflow (s_divide
);
8318 /* FIXME: Precision may be lost here due to:
8319 (1) The cast from 'scm_t_inum' to 'double'
8320 (2) Double rounding */
8321 return scm_from_double (rx
/ (double) yy
);
8323 else if (SCM_BIGP (y
))
8325 /* FIXME: Precision may be lost here due to:
8326 (1) The conversion from bignum to double
8327 (2) Double rounding */
8328 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8329 scm_remember_upto_here_1 (y
);
8330 return scm_from_double (rx
/ dby
);
8332 else if (SCM_REALP (y
))
8334 double yy
= SCM_REAL_VALUE (y
);
8335 #ifndef ALLOW_DIVIDE_BY_ZERO
8337 scm_num_overflow (s_divide
);
8340 return scm_from_double (rx
/ yy
);
8342 else if (SCM_COMPLEXP (y
))
8347 else if (SCM_FRACTIONP (y
))
8348 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8350 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8352 else if (SCM_COMPLEXP (x
))
8354 double rx
= SCM_COMPLEX_REAL (x
);
8355 double ix
= SCM_COMPLEX_IMAG (x
);
8356 if (SCM_I_INUMP (y
))
8358 scm_t_inum yy
= SCM_I_INUM (y
);
8359 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8361 scm_num_overflow (s_divide
);
8365 /* FIXME: Precision may be lost here due to:
8366 (1) The conversion from 'scm_t_inum' to double
8367 (2) Double rounding */
8369 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8372 else if (SCM_BIGP (y
))
8374 /* FIXME: Precision may be lost here due to:
8375 (1) The conversion from bignum to double
8376 (2) Double rounding */
8377 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8378 scm_remember_upto_here_1 (y
);
8379 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8381 else if (SCM_REALP (y
))
8383 double yy
= SCM_REAL_VALUE (y
);
8384 #ifndef ALLOW_DIVIDE_BY_ZERO
8386 scm_num_overflow (s_divide
);
8389 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8391 else if (SCM_COMPLEXP (y
))
8393 double ry
= SCM_COMPLEX_REAL (y
);
8394 double iy
= SCM_COMPLEX_IMAG (y
);
8395 if (fabs(ry
) <= fabs(iy
))
8398 double d
= iy
* (1.0 + t
* t
);
8399 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8404 double d
= ry
* (1.0 + t
* t
);
8405 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8408 else if (SCM_FRACTIONP (y
))
8410 /* FIXME: Precision may be lost here due to:
8411 (1) The conversion from fraction to double
8412 (2) Double rounding */
8413 double yy
= scm_i_fraction2double (y
);
8414 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8417 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8419 else if (SCM_FRACTIONP (x
))
8421 if (SCM_I_INUMP (y
))
8423 scm_t_inum yy
= SCM_I_INUM (y
);
8424 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8426 scm_num_overflow (s_divide
);
8429 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8430 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8432 else if (SCM_BIGP (y
))
8434 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8435 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8437 else if (SCM_REALP (y
))
8439 double yy
= SCM_REAL_VALUE (y
);
8440 #ifndef ALLOW_DIVIDE_BY_ZERO
8442 scm_num_overflow (s_divide
);
8445 /* FIXME: Precision may be lost here due to:
8446 (1) The conversion from fraction to double
8447 (2) Double rounding */
8448 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8450 else if (SCM_COMPLEXP (y
))
8452 /* FIXME: Precision may be lost here due to:
8453 (1) The conversion from fraction to double
8454 (2) Double rounding */
8455 a
= scm_i_fraction2double (x
);
8458 else if (SCM_FRACTIONP (y
))
8459 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8460 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8462 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8465 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8471 scm_c_truncate (double x
)
8476 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8477 half-way case (ie. when x is an integer plus 0.5) going upwards.
8478 Then half-way cases are identified and adjusted down if the
8479 round-upwards didn't give the desired even integer.
8481 "plus_half == result" identifies a half-way case. If plus_half, which is
8482 x + 0.5, is an integer then x must be an integer plus 0.5.
8484 An odd "result" value is identified with result/2 != floor(result/2).
8485 This is done with plus_half, since that value is ready for use sooner in
8486 a pipelined cpu, and we're already requiring plus_half == result.
8488 Note however that we need to be careful when x is big and already an
8489 integer. In that case "x+0.5" may round to an adjacent integer, causing
8490 us to return such a value, incorrectly. For instance if the hardware is
8491 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8492 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8493 returned. Or if the hardware is in round-upwards mode, then other bigger
8494 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8495 representable value, 2^128+2^76 (or whatever), again incorrect.
8497 These bad roundings of x+0.5 are avoided by testing at the start whether
8498 x is already an integer. If it is then clearly that's the desired result
8499 already. And if it's not then the exponent must be small enough to allow
8500 an 0.5 to be represented, and hence added without a bad rounding. */
8503 scm_c_round (double x
)
8505 double plus_half
, result
;
8510 plus_half
= x
+ 0.5;
8511 result
= floor (plus_half
);
8512 /* Adjust so that the rounding is towards even. */
8513 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8518 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8520 "Round the number @var{x} towards zero.")
8521 #define FUNC_NAME s_scm_truncate_number
8523 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8525 else if (SCM_REALP (x
))
8526 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8527 else if (SCM_FRACTIONP (x
))
8528 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8529 SCM_FRACTION_DENOMINATOR (x
));
8531 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8532 s_scm_truncate_number
);
8536 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8538 "Round the number @var{x} towards the nearest integer. "
8539 "When it is exactly halfway between two integers, "
8540 "round towards the even one.")
8541 #define FUNC_NAME s_scm_round_number
8543 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8545 else if (SCM_REALP (x
))
8546 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8547 else if (SCM_FRACTIONP (x
))
8548 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8549 SCM_FRACTION_DENOMINATOR (x
));
8551 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8552 s_scm_round_number
);
8556 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8558 "Round the number @var{x} towards minus infinity.")
8559 #define FUNC_NAME s_scm_floor
8561 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8563 else if (SCM_REALP (x
))
8564 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8565 else if (SCM_FRACTIONP (x
))
8566 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8567 SCM_FRACTION_DENOMINATOR (x
));
8569 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8573 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8575 "Round the number @var{x} towards infinity.")
8576 #define FUNC_NAME s_scm_ceiling
8578 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8580 else if (SCM_REALP (x
))
8581 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8582 else if (SCM_FRACTIONP (x
))
8583 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8584 SCM_FRACTION_DENOMINATOR (x
));
8586 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8590 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8592 "Return @var{x} raised to the power of @var{y}.")
8593 #define FUNC_NAME s_scm_expt
8595 if (scm_is_integer (y
))
8597 if (scm_is_true (scm_exact_p (y
)))
8598 return scm_integer_expt (x
, y
);
8601 /* Here we handle the case where the exponent is an inexact
8602 integer. We make the exponent exact in order to use
8603 scm_integer_expt, and thus avoid the spurious imaginary
8604 parts that may result from round-off errors in the general
8605 e^(y log x) method below (for example when squaring a large
8606 negative number). In this case, we must return an inexact
8607 result for correctness. We also make the base inexact so
8608 that scm_integer_expt will use fast inexact arithmetic
8609 internally. Note that making the base inexact is not
8610 sufficient to guarantee an inexact result, because
8611 scm_integer_expt will return an exact 1 when the exponent
8612 is 0, even if the base is inexact. */
8613 return scm_exact_to_inexact
8614 (scm_integer_expt (scm_exact_to_inexact (x
),
8615 scm_inexact_to_exact (y
)));
8618 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8620 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8622 else if (scm_is_complex (x
) && scm_is_complex (y
))
8623 return scm_exp (scm_product (scm_log (x
), y
));
8624 else if (scm_is_complex (x
))
8625 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8627 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8631 /* sin/cos/tan/asin/acos/atan
8632 sinh/cosh/tanh/asinh/acosh/atanh
8633 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8634 Written by Jerry D. Hedden, (C) FSF.
8635 See the file `COPYING' for terms applying to this program. */
8637 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8639 "Compute the sine of @var{z}.")
8640 #define FUNC_NAME s_scm_sin
8642 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8643 return z
; /* sin(exact0) = exact0 */
8644 else if (scm_is_real (z
))
8645 return scm_from_double (sin (scm_to_double (z
)));
8646 else if (SCM_COMPLEXP (z
))
8648 x
= SCM_COMPLEX_REAL (z
);
8649 y
= SCM_COMPLEX_IMAG (z
);
8650 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8651 cos (x
) * sinh (y
));
8654 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8658 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8660 "Compute the cosine of @var{z}.")
8661 #define FUNC_NAME s_scm_cos
8663 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8664 return SCM_INUM1
; /* cos(exact0) = exact1 */
8665 else if (scm_is_real (z
))
8666 return scm_from_double (cos (scm_to_double (z
)));
8667 else if (SCM_COMPLEXP (z
))
8669 x
= SCM_COMPLEX_REAL (z
);
8670 y
= SCM_COMPLEX_IMAG (z
);
8671 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8672 -sin (x
) * sinh (y
));
8675 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8679 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8681 "Compute the tangent of @var{z}.")
8682 #define FUNC_NAME s_scm_tan
8684 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8685 return z
; /* tan(exact0) = exact0 */
8686 else if (scm_is_real (z
))
8687 return scm_from_double (tan (scm_to_double (z
)));
8688 else if (SCM_COMPLEXP (z
))
8690 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8691 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8692 w
= cos (x
) + cosh (y
);
8693 #ifndef ALLOW_DIVIDE_BY_ZERO
8695 scm_num_overflow (s_scm_tan
);
8697 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8700 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8704 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8706 "Compute the hyperbolic sine of @var{z}.")
8707 #define FUNC_NAME s_scm_sinh
8709 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8710 return z
; /* sinh(exact0) = exact0 */
8711 else if (scm_is_real (z
))
8712 return scm_from_double (sinh (scm_to_double (z
)));
8713 else if (SCM_COMPLEXP (z
))
8715 x
= SCM_COMPLEX_REAL (z
);
8716 y
= SCM_COMPLEX_IMAG (z
);
8717 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8718 cosh (x
) * sin (y
));
8721 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8725 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8727 "Compute the hyperbolic cosine of @var{z}.")
8728 #define FUNC_NAME s_scm_cosh
8730 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8731 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8732 else if (scm_is_real (z
))
8733 return scm_from_double (cosh (scm_to_double (z
)));
8734 else if (SCM_COMPLEXP (z
))
8736 x
= SCM_COMPLEX_REAL (z
);
8737 y
= SCM_COMPLEX_IMAG (z
);
8738 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8739 sinh (x
) * sin (y
));
8742 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8746 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8748 "Compute the hyperbolic tangent of @var{z}.")
8749 #define FUNC_NAME s_scm_tanh
8751 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8752 return z
; /* tanh(exact0) = exact0 */
8753 else if (scm_is_real (z
))
8754 return scm_from_double (tanh (scm_to_double (z
)));
8755 else if (SCM_COMPLEXP (z
))
8757 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8758 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8759 w
= cosh (x
) + cos (y
);
8760 #ifndef ALLOW_DIVIDE_BY_ZERO
8762 scm_num_overflow (s_scm_tanh
);
8764 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8767 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8771 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8773 "Compute the arc sine of @var{z}.")
8774 #define FUNC_NAME s_scm_asin
8776 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8777 return z
; /* asin(exact0) = exact0 */
8778 else if (scm_is_real (z
))
8780 double w
= scm_to_double (z
);
8781 if (w
>= -1.0 && w
<= 1.0)
8782 return scm_from_double (asin (w
));
8784 return scm_product (scm_c_make_rectangular (0, -1),
8785 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8787 else if (SCM_COMPLEXP (z
))
8789 x
= SCM_COMPLEX_REAL (z
);
8790 y
= SCM_COMPLEX_IMAG (z
);
8791 return scm_product (scm_c_make_rectangular (0, -1),
8792 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8795 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8799 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8801 "Compute the arc cosine of @var{z}.")
8802 #define FUNC_NAME s_scm_acos
8804 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8805 return SCM_INUM0
; /* acos(exact1) = 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 (acos (w
));
8812 return scm_sum (scm_from_double (acos (0.0)),
8813 scm_product (scm_c_make_rectangular (0, 1),
8814 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8816 else if (SCM_COMPLEXP (z
))
8818 x
= SCM_COMPLEX_REAL (z
);
8819 y
= SCM_COMPLEX_IMAG (z
);
8820 return scm_sum (scm_from_double (acos (0.0)),
8821 scm_product (scm_c_make_rectangular (0, 1),
8822 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8825 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8829 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8831 "With one argument, compute the arc tangent of @var{z}.\n"
8832 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8833 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8834 #define FUNC_NAME s_scm_atan
8838 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8839 return z
; /* atan(exact0) = exact0 */
8840 else if (scm_is_real (z
))
8841 return scm_from_double (atan (scm_to_double (z
)));
8842 else if (SCM_COMPLEXP (z
))
8845 v
= SCM_COMPLEX_REAL (z
);
8846 w
= SCM_COMPLEX_IMAG (z
);
8847 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8848 scm_c_make_rectangular (v
, w
+ 1.0))),
8849 scm_c_make_rectangular (0, 2));
8852 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8854 else if (scm_is_real (z
))
8856 if (scm_is_real (y
))
8857 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8859 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8862 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8866 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8868 "Compute the inverse hyperbolic sine of @var{z}.")
8869 #define FUNC_NAME s_scm_sys_asinh
8871 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8872 return z
; /* asinh(exact0) = exact0 */
8873 else if (scm_is_real (z
))
8874 return scm_from_double (asinh (scm_to_double (z
)));
8875 else if (scm_is_number (z
))
8876 return scm_log (scm_sum (z
,
8877 scm_sqrt (scm_sum (scm_product (z
, z
),
8880 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8884 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8886 "Compute the inverse hyperbolic cosine of @var{z}.")
8887 #define FUNC_NAME s_scm_sys_acosh
8889 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8890 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8891 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8892 return scm_from_double (acosh (scm_to_double (z
)));
8893 else if (scm_is_number (z
))
8894 return scm_log (scm_sum (z
,
8895 scm_sqrt (scm_difference (scm_product (z
, z
),
8898 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8902 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8904 "Compute the inverse hyperbolic tangent of @var{z}.")
8905 #define FUNC_NAME s_scm_sys_atanh
8907 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8908 return z
; /* atanh(exact0) = exact0 */
8909 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8910 return scm_from_double (atanh (scm_to_double (z
)));
8911 else if (scm_is_number (z
))
8912 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8913 scm_difference (SCM_INUM1
, z
))),
8916 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8921 scm_c_make_rectangular (double re
, double im
)
8925 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8927 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8928 SCM_COMPLEX_REAL (z
) = re
;
8929 SCM_COMPLEX_IMAG (z
) = im
;
8933 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8934 (SCM real_part
, SCM imaginary_part
),
8935 "Return a complex number constructed of the given @var{real_part} "
8936 "and @var{imaginary_part} parts.")
8937 #define FUNC_NAME s_scm_make_rectangular
8939 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8940 SCM_ARG1
, FUNC_NAME
, "real");
8941 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8942 SCM_ARG2
, FUNC_NAME
, "real");
8944 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8945 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8948 return scm_c_make_rectangular (scm_to_double (real_part
),
8949 scm_to_double (imaginary_part
));
8954 scm_c_make_polar (double mag
, double ang
)
8958 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8959 use it on Glibc-based systems that have it (it's a GNU extension). See
8960 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8962 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8963 sincos (ang
, &s
, &c
);
8969 /* If s and c are NaNs, this indicates that the angle is a NaN,
8970 infinite, or perhaps simply too large to determine its value
8971 mod 2*pi. However, we know something that the floating-point
8972 implementation doesn't know: We know that s and c are finite.
8973 Therefore, if the magnitude is zero, return a complex zero.
8975 The reason we check for the NaNs instead of using this case
8976 whenever mag == 0.0 is because when the angle is known, we'd
8977 like to return the correct kind of non-real complex zero:
8978 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8979 on which quadrant the angle is in.
8981 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8982 return scm_c_make_rectangular (0.0, 0.0);
8984 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8987 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8989 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8990 #define FUNC_NAME s_scm_make_polar
8992 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8993 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8995 /* If mag is exact0, return exact0 */
8996 if (scm_is_eq (mag
, SCM_INUM0
))
8998 /* Return a real if ang is exact0 */
8999 else if (scm_is_eq (ang
, SCM_INUM0
))
9002 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9007 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9009 "Return the real part of the number @var{z}.")
9010 #define FUNC_NAME s_scm_real_part
9012 if (SCM_COMPLEXP (z
))
9013 return scm_from_double (SCM_COMPLEX_REAL (z
));
9014 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9017 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9022 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9024 "Return the imaginary part of the number @var{z}.")
9025 #define FUNC_NAME s_scm_imag_part
9027 if (SCM_COMPLEXP (z
))
9028 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9029 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9032 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9036 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9038 "Return the numerator of the number @var{z}.")
9039 #define FUNC_NAME s_scm_numerator
9041 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9043 else if (SCM_FRACTIONP (z
))
9044 return SCM_FRACTION_NUMERATOR (z
);
9045 else if (SCM_REALP (z
))
9046 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9048 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9053 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9055 "Return the denominator of the number @var{z}.")
9056 #define FUNC_NAME s_scm_denominator
9058 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9060 else if (SCM_FRACTIONP (z
))
9061 return SCM_FRACTION_DENOMINATOR (z
);
9062 else if (SCM_REALP (z
))
9063 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9065 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9070 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9072 "Return the magnitude of the number @var{z}. This is the same as\n"
9073 "@code{abs} for real arguments, but also allows complex numbers.")
9074 #define FUNC_NAME s_scm_magnitude
9076 if (SCM_I_INUMP (z
))
9078 scm_t_inum zz
= SCM_I_INUM (z
);
9081 else if (SCM_POSFIXABLE (-zz
))
9082 return SCM_I_MAKINUM (-zz
);
9084 return scm_i_inum2big (-zz
);
9086 else if (SCM_BIGP (z
))
9088 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9089 scm_remember_upto_here_1 (z
);
9091 return scm_i_clonebig (z
, 0);
9095 else if (SCM_REALP (z
))
9096 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9097 else if (SCM_COMPLEXP (z
))
9098 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9099 else if (SCM_FRACTIONP (z
))
9101 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9103 return scm_i_make_ratio_already_reduced
9104 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9105 SCM_FRACTION_DENOMINATOR (z
));
9108 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9113 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9115 "Return the angle of the complex number @var{z}.")
9116 #define FUNC_NAME s_scm_angle
9118 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9119 flo0 to save allocating a new flonum with scm_from_double each time.
9120 But if atan2 follows the floating point rounding mode, then the value
9121 is not a constant. Maybe it'd be close enough though. */
9122 if (SCM_I_INUMP (z
))
9124 if (SCM_I_INUM (z
) >= 0)
9127 return scm_from_double (atan2 (0.0, -1.0));
9129 else if (SCM_BIGP (z
))
9131 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9132 scm_remember_upto_here_1 (z
);
9134 return scm_from_double (atan2 (0.0, -1.0));
9138 else if (SCM_REALP (z
))
9140 double x
= SCM_REAL_VALUE (z
);
9141 if (x
> 0.0 || double_is_non_negative_zero (x
))
9144 return scm_from_double (atan2 (0.0, -1.0));
9146 else if (SCM_COMPLEXP (z
))
9147 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9148 else if (SCM_FRACTIONP (z
))
9150 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9152 else return scm_from_double (atan2 (0.0, -1.0));
9155 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9160 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9162 "Convert the number @var{z} to its inexact representation.\n")
9163 #define FUNC_NAME s_scm_exact_to_inexact
9165 if (SCM_I_INUMP (z
))
9166 return scm_from_double ((double) SCM_I_INUM (z
));
9167 else if (SCM_BIGP (z
))
9168 return scm_from_double (scm_i_big2dbl (z
));
9169 else if (SCM_FRACTIONP (z
))
9170 return scm_from_double (scm_i_fraction2double (z
));
9171 else if (SCM_INEXACTP (z
))
9174 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9179 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9181 "Return an exact number that is numerically closest to @var{z}.")
9182 #define FUNC_NAME s_scm_inexact_to_exact
9184 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9191 val
= SCM_REAL_VALUE (z
);
9192 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9193 val
= SCM_COMPLEX_REAL (z
);
9195 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9197 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9198 SCM_OUT_OF_RANGE (1, z
);
9199 else if (val
== 0.0)
9206 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9208 expon
-= DBL_MANT_DIG
;
9211 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9215 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9216 SCM_I_BIG_MPZ (numerator
),
9220 numerator
= scm_i_normbig (numerator
);
9222 return scm_i_make_ratio_already_reduced
9223 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9225 return left_shift_exact_integer (numerator
, expon
);
9233 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9235 "Returns the @emph{simplest} rational number differing\n"
9236 "from @var{x} by no more than @var{eps}.\n"
9238 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9239 "exact result when both its arguments are exact. Thus, you might need\n"
9240 "to use @code{inexact->exact} on the arguments.\n"
9243 "(rationalize (inexact->exact 1.2) 1/100)\n"
9246 #define FUNC_NAME s_scm_rationalize
9248 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9249 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9250 eps
= scm_abs (eps
);
9251 if (scm_is_false (scm_positive_p (eps
)))
9253 /* eps is either zero or a NaN */
9254 if (scm_is_true (scm_nan_p (eps
)))
9256 else if (SCM_INEXACTP (eps
))
9257 return scm_exact_to_inexact (x
);
9261 else if (scm_is_false (scm_finite_p (eps
)))
9263 if (scm_is_true (scm_finite_p (x
)))
9268 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9270 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9271 scm_ceiling (scm_difference (x
, eps
)))))
9273 /* There's an integer within range; we want the one closest to zero */
9274 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9276 /* zero is within range */
9277 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9282 else if (scm_is_true (scm_positive_p (x
)))
9283 return scm_ceiling (scm_difference (x
, eps
));
9285 return scm_floor (scm_sum (x
, eps
));
9289 /* Use continued fractions to find closest ratio. All
9290 arithmetic is done with exact numbers.
9293 SCM ex
= scm_inexact_to_exact (x
);
9294 SCM int_part
= scm_floor (ex
);
9296 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9297 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9301 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9302 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9304 /* We stop after a million iterations just to be absolutely sure
9305 that we don't go into an infinite loop. The process normally
9306 converges after less than a dozen iterations.
9309 while (++i
< 1000000)
9311 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9312 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9313 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9315 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9316 eps
))) /* abs(x-a/b) <= eps */
9318 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9319 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9320 return scm_exact_to_inexact (res
);
9324 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9326 tt
= scm_floor (rx
); /* tt = floor (rx) */
9332 scm_num_overflow (s_scm_rationalize
);
9337 /* conversion functions */
9340 scm_is_integer (SCM val
)
9342 return scm_is_true (scm_integer_p (val
));
9346 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9348 if (SCM_I_INUMP (val
))
9350 scm_t_signed_bits n
= SCM_I_INUM (val
);
9351 return n
>= min
&& n
<= max
;
9353 else if (SCM_BIGP (val
))
9355 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9357 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9359 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9361 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9362 return n
>= min
&& n
<= max
;
9372 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9373 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9376 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9377 SCM_I_BIG_MPZ (val
));
9379 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9391 return n
>= min
&& n
<= max
;
9399 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9401 if (SCM_I_INUMP (val
))
9403 scm_t_signed_bits n
= SCM_I_INUM (val
);
9404 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9406 else if (SCM_BIGP (val
))
9408 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9410 else if (max
<= ULONG_MAX
)
9412 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9414 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9415 return n
>= min
&& n
<= max
;
9425 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9428 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9429 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9432 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9433 SCM_I_BIG_MPZ (val
));
9435 return n
>= min
&& n
<= max
;
9443 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9445 scm_error (scm_out_of_range_key
,
9447 "Value out of range ~S to ~S: ~S",
9448 scm_list_3 (min
, max
, bad_val
),
9449 scm_list_1 (bad_val
));
9452 #define TYPE scm_t_intmax
9453 #define TYPE_MIN min
9454 #define TYPE_MAX max
9455 #define SIZEOF_TYPE 0
9456 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9457 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9458 #include "libguile/conv-integer.i.c"
9460 #define TYPE scm_t_uintmax
9461 #define TYPE_MIN min
9462 #define TYPE_MAX max
9463 #define SIZEOF_TYPE 0
9464 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9465 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9466 #include "libguile/conv-uinteger.i.c"
9468 #define TYPE scm_t_int8
9469 #define TYPE_MIN SCM_T_INT8_MIN
9470 #define TYPE_MAX SCM_T_INT8_MAX
9471 #define SIZEOF_TYPE 1
9472 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9473 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9474 #include "libguile/conv-integer.i.c"
9476 #define TYPE scm_t_uint8
9478 #define TYPE_MAX SCM_T_UINT8_MAX
9479 #define SIZEOF_TYPE 1
9480 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9481 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9482 #include "libguile/conv-uinteger.i.c"
9484 #define TYPE scm_t_int16
9485 #define TYPE_MIN SCM_T_INT16_MIN
9486 #define TYPE_MAX SCM_T_INT16_MAX
9487 #define SIZEOF_TYPE 2
9488 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9489 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9490 #include "libguile/conv-integer.i.c"
9492 #define TYPE scm_t_uint16
9494 #define TYPE_MAX SCM_T_UINT16_MAX
9495 #define SIZEOF_TYPE 2
9496 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9497 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9498 #include "libguile/conv-uinteger.i.c"
9500 #define TYPE scm_t_int32
9501 #define TYPE_MIN SCM_T_INT32_MIN
9502 #define TYPE_MAX SCM_T_INT32_MAX
9503 #define SIZEOF_TYPE 4
9504 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9505 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9506 #include "libguile/conv-integer.i.c"
9508 #define TYPE scm_t_uint32
9510 #define TYPE_MAX SCM_T_UINT32_MAX
9511 #define SIZEOF_TYPE 4
9512 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9513 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9514 #include "libguile/conv-uinteger.i.c"
9516 #define TYPE scm_t_wchar
9517 #define TYPE_MIN (scm_t_int32)-1
9518 #define TYPE_MAX (scm_t_int32)0x10ffff
9519 #define SIZEOF_TYPE 4
9520 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9521 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9522 #include "libguile/conv-integer.i.c"
9524 #define TYPE scm_t_int64
9525 #define TYPE_MIN SCM_T_INT64_MIN
9526 #define TYPE_MAX SCM_T_INT64_MAX
9527 #define SIZEOF_TYPE 8
9528 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9529 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9530 #include "libguile/conv-integer.i.c"
9532 #define TYPE scm_t_uint64
9534 #define TYPE_MAX SCM_T_UINT64_MAX
9535 #define SIZEOF_TYPE 8
9536 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9537 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9538 #include "libguile/conv-uinteger.i.c"
9541 scm_to_mpz (SCM val
, mpz_t rop
)
9543 if (SCM_I_INUMP (val
))
9544 mpz_set_si (rop
, SCM_I_INUM (val
));
9545 else if (SCM_BIGP (val
))
9546 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9548 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9552 scm_from_mpz (mpz_t val
)
9554 return scm_i_mpz2num (val
);
9558 scm_is_real (SCM val
)
9560 return scm_is_true (scm_real_p (val
));
9564 scm_is_rational (SCM val
)
9566 return scm_is_true (scm_rational_p (val
));
9570 scm_to_double (SCM val
)
9572 if (SCM_I_INUMP (val
))
9573 return SCM_I_INUM (val
);
9574 else if (SCM_BIGP (val
))
9575 return scm_i_big2dbl (val
);
9576 else if (SCM_FRACTIONP (val
))
9577 return scm_i_fraction2double (val
);
9578 else if (SCM_REALP (val
))
9579 return SCM_REAL_VALUE (val
);
9581 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9585 scm_from_double (double val
)
9589 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9591 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9592 SCM_REAL_VALUE (z
) = val
;
9597 #if SCM_ENABLE_DEPRECATED == 1
9600 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9602 scm_c_issue_deprecation_warning
9603 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9607 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9611 scm_out_of_range (NULL
, num
);
9614 return scm_to_double (num
);
9618 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9620 scm_c_issue_deprecation_warning
9621 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9625 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9629 scm_out_of_range (NULL
, num
);
9632 return scm_to_double (num
);
9638 scm_is_complex (SCM val
)
9640 return scm_is_true (scm_complex_p (val
));
9644 scm_c_real_part (SCM z
)
9646 if (SCM_COMPLEXP (z
))
9647 return SCM_COMPLEX_REAL (z
);
9650 /* Use the scm_real_part to get proper error checking and
9653 return scm_to_double (scm_real_part (z
));
9658 scm_c_imag_part (SCM z
)
9660 if (SCM_COMPLEXP (z
))
9661 return SCM_COMPLEX_IMAG (z
);
9664 /* Use the scm_imag_part to get proper error checking and
9665 dispatching. The result will almost always be 0.0, but not
9668 return scm_to_double (scm_imag_part (z
));
9673 scm_c_magnitude (SCM z
)
9675 return scm_to_double (scm_magnitude (z
));
9681 return scm_to_double (scm_angle (z
));
9685 scm_is_number (SCM z
)
9687 return scm_is_true (scm_number_p (z
));
9691 /* Returns log(x * 2^shift) */
9693 log_of_shifted_double (double x
, long shift
)
9695 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9697 if (x
> 0.0 || double_is_non_negative_zero (x
))
9698 return scm_from_double (ans
);
9700 return scm_c_make_rectangular (ans
, M_PI
);
9703 /* Returns log(n), for exact integer n */
9705 log_of_exact_integer (SCM n
)
9707 if (SCM_I_INUMP (n
))
9708 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9709 else if (SCM_BIGP (n
))
9712 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9713 return log_of_shifted_double (signif
, expon
);
9716 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9719 /* Returns log(n/d), for exact non-zero integers n and d */
9721 log_of_fraction (SCM n
, SCM d
)
9723 long n_size
= scm_to_long (scm_integer_length (n
));
9724 long d_size
= scm_to_long (scm_integer_length (d
));
9726 if (abs (n_size
- d_size
) > 1)
9727 return (scm_difference (log_of_exact_integer (n
),
9728 log_of_exact_integer (d
)));
9729 else if (scm_is_false (scm_negative_p (n
)))
9730 return scm_from_double
9731 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9733 return scm_c_make_rectangular
9734 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9740 /* In the following functions we dispatch to the real-arg funcs like log()
9741 when we know the arg is real, instead of just handing everything to
9742 clog() for instance. This is in case clog() doesn't optimize for a
9743 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9744 well use it to go straight to the applicable C func. */
9746 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9748 "Return the natural logarithm of @var{z}.")
9749 #define FUNC_NAME s_scm_log
9751 if (SCM_COMPLEXP (z
))
9753 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9754 && defined (SCM_COMPLEX_VALUE)
9755 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9757 double re
= SCM_COMPLEX_REAL (z
);
9758 double im
= SCM_COMPLEX_IMAG (z
);
9759 return scm_c_make_rectangular (log (hypot (re
, im
)),
9763 else if (SCM_REALP (z
))
9764 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9765 else if (SCM_I_INUMP (z
))
9767 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9768 if (scm_is_eq (z
, SCM_INUM0
))
9769 scm_num_overflow (s_scm_log
);
9771 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9773 else if (SCM_BIGP (z
))
9774 return log_of_exact_integer (z
);
9775 else if (SCM_FRACTIONP (z
))
9776 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9777 SCM_FRACTION_DENOMINATOR (z
));
9779 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9784 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9786 "Return the base 10 logarithm of @var{z}.")
9787 #define FUNC_NAME s_scm_log10
9789 if (SCM_COMPLEXP (z
))
9791 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9792 clog() and a multiply by M_LOG10E, rather than the fallback
9793 log10+hypot+atan2.) */
9794 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9795 && defined SCM_COMPLEX_VALUE
9796 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9798 double re
= SCM_COMPLEX_REAL (z
);
9799 double im
= SCM_COMPLEX_IMAG (z
);
9800 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9801 M_LOG10E
* atan2 (im
, re
));
9804 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9806 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9807 if (scm_is_eq (z
, SCM_INUM0
))
9808 scm_num_overflow (s_scm_log10
);
9811 double re
= scm_to_double (z
);
9812 double l
= log10 (fabs (re
));
9813 if (re
> 0.0 || double_is_non_negative_zero (re
))
9814 return scm_from_double (l
);
9816 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9819 else if (SCM_BIGP (z
))
9820 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9821 else if (SCM_FRACTIONP (z
))
9822 return scm_product (flo_log10e
,
9823 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9824 SCM_FRACTION_DENOMINATOR (z
)));
9826 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9831 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9833 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9834 "base of natural logarithms (2.71828@dots{}).")
9835 #define FUNC_NAME s_scm_exp
9837 if (SCM_COMPLEXP (z
))
9839 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9840 && defined (SCM_COMPLEX_VALUE)
9841 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9843 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9844 SCM_COMPLEX_IMAG (z
));
9847 else if (SCM_NUMBERP (z
))
9849 /* When z is a negative bignum the conversion to double overflows,
9850 giving -infinity, but that's ok, the exp is still 0.0. */
9851 return scm_from_double (exp (scm_to_double (z
)));
9854 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9859 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9861 "Return two exact non-negative integers @var{s} and @var{r}\n"
9862 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9863 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9864 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9867 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9869 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9873 scm_exact_integer_sqrt (k
, &s
, &r
);
9874 return scm_values (scm_list_2 (s
, r
));
9879 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9881 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9883 scm_t_inum kk
= SCM_I_INUM (k
);
9887 if (SCM_LIKELY (kk
> 0))
9892 uu
= (ss
+ kk
/ss
) / 2;
9894 *sp
= SCM_I_MAKINUM (ss
);
9895 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9897 else if (SCM_LIKELY (kk
== 0))
9898 *sp
= *rp
= SCM_INUM0
;
9900 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9901 "exact non-negative integer");
9903 else if (SCM_LIKELY (SCM_BIGP (k
)))
9907 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9908 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9909 "exact non-negative integer");
9912 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9913 scm_remember_upto_here_1 (k
);
9914 *sp
= scm_i_normbig (s
);
9915 *rp
= scm_i_normbig (r
);
9918 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9919 "exact non-negative integer");
9923 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9925 "Return the square root of @var{z}. Of the two possible roots\n"
9926 "(positive and negative), the one with positive real part\n"
9927 "is returned, or if that's zero then a positive imaginary part.\n"
9931 "(sqrt 9.0) @result{} 3.0\n"
9932 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9933 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9934 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9936 #define FUNC_NAME s_scm_sqrt
9938 if (SCM_COMPLEXP (z
))
9940 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9941 && defined SCM_COMPLEX_VALUE
9942 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9944 double re
= SCM_COMPLEX_REAL (z
);
9945 double im
= SCM_COMPLEX_IMAG (z
);
9946 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9947 0.5 * atan2 (im
, re
));
9950 else if (SCM_NUMBERP (z
))
9952 double xx
= scm_to_double (z
);
9954 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9956 return scm_from_double (sqrt (xx
));
9959 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9968 if (scm_install_gmp_memory_functions
)
9969 mp_set_memory_functions (custom_gmp_malloc
,
9973 mpz_init_set_si (z_negative_one
, -1);
9975 /* It may be possible to tune the performance of some algorithms by using
9976 * the following constants to avoid the creation of bignums. Please, before
9977 * using these values, remember the two rules of program optimization:
9978 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9979 scm_c_define ("most-positive-fixnum",
9980 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9981 scm_c_define ("most-negative-fixnum",
9982 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9984 scm_add_feature ("complex");
9985 scm_add_feature ("inexact");
9986 flo0
= scm_from_double (0.0);
9987 flo_log10e
= scm_from_double (M_LOG10E
);
9989 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9992 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
9993 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
9994 mpz_mul_2exp (scm_i_divide2double_lo2b
,
9995 scm_i_divide2double_lo2b
,
9996 DBL_MANT_DIG
+ 1); /* 2 b^p */
9997 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10001 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10002 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10003 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10004 dbl_minimum_normal_mantissa
,
10008 #include "libguile/numbers.x"
10013 c-file-style: "gnu"