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
= SCM_PACK_POINTER (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
;
478 if (SCM_LIKELY (SCM_I_INUMP (d
)))
480 if (SCM_LIKELY (SCM_I_INUMP (n
)
481 && (SCM_I_FIXNUM_BIT
-1 <= DBL_MANT_DIG
482 || (SCM_I_INUM (n
) < (1L << DBL_MANT_DIG
)
483 && SCM_I_INUM (d
) < (1L << DBL_MANT_DIG
)))))
484 /* If both N and D can be losslessly converted to doubles, then
485 we can rely on IEEE floating point to do proper rounding much
486 faster than we can. */
487 return ((double) SCM_I_INUM (n
)) / ((double) SCM_I_INUM (d
));
489 if (SCM_UNLIKELY (scm_is_eq (d
, SCM_INUM0
)))
491 if (scm_is_true (scm_positive_p (n
)))
493 else if (scm_is_true (scm_negative_p (n
)))
499 mpz_init_set_si (dd
, SCM_I_INUM (d
));
502 mpz_init_set (dd
, SCM_I_BIG_MPZ (d
));
505 mpz_init_set_si (nn
, SCM_I_INUM (n
));
507 mpz_init_set (nn
, SCM_I_BIG_MPZ (n
));
509 neg
= (mpz_sgn (nn
) < 0) ^ (mpz_sgn (dd
) < 0);
513 /* Now we need to find the value of e such that:
516 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
517 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
518 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
521 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
522 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
523 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
525 where: p = DBL_MANT_DIG
526 b = FLT_RADIX (here assumed to be 2)
528 After rounding, the mantissa must be an integer between b^{p-1} and
529 (b^p - 1), except for subnormal numbers. In the inequations [1A]
530 and [1B], the middle expression represents the mantissa *before*
531 rounding, and therefore is bounded by the range of values that will
532 round to a floating-point number with the exponent e. The upper
533 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
534 ties will round up to the next power of b. The lower bound is
535 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
536 this power of b. Here we subtract 1/2b instead of 1/2 because it
537 is in the range of the next smaller exponent, where the
538 representable numbers are closer together by a factor of b.
540 Inequations [2A] and [2B] are derived from [1A] and [1B] by
541 multiplying by 2b, and in [3A] and [3B] we multiply by the
542 denominator of the middle value to obtain integer expressions.
544 In the code below, we refer to the three expressions in [3A] or
545 [3B] as lo, x, and hi. If the number is normalizable, we will
546 achieve the goal: lo <= x < hi */
548 /* Make an initial guess for e */
549 e
= mpz_sizeinbase (nn
, 2) - mpz_sizeinbase (dd
, 2) - (DBL_MANT_DIG
-1);
550 if (e
< DBL_MIN_EXP
- DBL_MANT_DIG
)
551 e
= DBL_MIN_EXP
- DBL_MANT_DIG
;
553 /* Compute the initial values of lo, x, and hi
554 based on the initial guess of e */
555 mpz_inits (lo
, hi
, x
, NULL
);
556 mpz_mul_2exp (x
, nn
, 2 + ((e
< 0) ? -e
: 0));
557 mpz_mul (lo
, dd
, scm_i_divide2double_lo2b
);
559 mpz_mul_2exp (lo
, lo
, e
);
560 mpz_mul_2exp (hi
, lo
, 1);
562 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
563 (but without making e less then the minimum exponent) */
564 while (mpz_cmp (x
, lo
) < 0 && e
> DBL_MIN_EXP
- DBL_MANT_DIG
)
566 mpz_mul_2exp (x
, x
, 1);
569 while (mpz_cmp (x
, hi
) >= 0)
571 /* If we ever used lo's value again,
572 we would need to double lo here. */
573 mpz_mul_2exp (hi
, hi
, 1);
577 /* Now compute the rounded mantissa:
578 n / b^e d (if e >= 0)
579 n b^-e / d (if e <= 0) */
585 mpz_mul_2exp (nn
, nn
, -e
);
587 mpz_mul_2exp (dd
, dd
, e
);
589 /* mpz does not directly support rounded right
590 shifts, so we have to do it the hard way.
591 For efficiency, we reuse lo and hi.
592 hi == quotient, lo == remainder */
593 mpz_fdiv_qr (hi
, lo
, nn
, dd
);
595 /* The fractional part of the unrounded mantissa would be
596 remainder/dividend, i.e. lo/dd. So we have a tie if
597 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
598 integer expression 2*lo = dd. Here we do that comparison
599 to decide whether to round up or down. */
600 mpz_mul_2exp (lo
, lo
, 1);
601 cmp
= mpz_cmp (lo
, dd
);
602 if (cmp
> 0 || (cmp
== 0 && mpz_odd_p (hi
)))
603 mpz_add_ui (hi
, hi
, 1);
605 result
= ldexp (mpz_get_d (hi
), e
);
609 mpz_clears (nn
, dd
, lo
, hi
, x
, NULL
);
615 scm_i_fraction2double (SCM z
)
617 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z
),
618 SCM_FRACTION_DENOMINATOR (z
));
622 double_is_non_negative_zero (double x
)
624 static double zero
= 0.0;
626 return !memcmp (&x
, &zero
, sizeof(double));
629 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
631 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
633 #define FUNC_NAME s_scm_exact_p
635 if (SCM_INEXACTP (x
))
637 else if (SCM_NUMBERP (x
))
640 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
645 scm_is_exact (SCM val
)
647 return scm_is_true (scm_exact_p (val
));
650 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
652 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
654 #define FUNC_NAME s_scm_inexact_p
656 if (SCM_INEXACTP (x
))
658 else if (SCM_NUMBERP (x
))
661 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
666 scm_is_inexact (SCM val
)
668 return scm_is_true (scm_inexact_p (val
));
671 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
673 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
675 #define FUNC_NAME s_scm_odd_p
679 scm_t_inum val
= SCM_I_INUM (n
);
680 return scm_from_bool ((val
& 1L) != 0);
682 else if (SCM_BIGP (n
))
684 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
685 scm_remember_upto_here_1 (n
);
686 return scm_from_bool (odd_p
);
688 else if (SCM_REALP (n
))
690 double val
= SCM_REAL_VALUE (n
);
691 if (DOUBLE_IS_FINITE (val
))
693 double rem
= fabs (fmod (val
, 2.0));
700 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
705 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
707 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
709 #define FUNC_NAME s_scm_even_p
713 scm_t_inum val
= SCM_I_INUM (n
);
714 return scm_from_bool ((val
& 1L) == 0);
716 else if (SCM_BIGP (n
))
718 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
719 scm_remember_upto_here_1 (n
);
720 return scm_from_bool (even_p
);
722 else if (SCM_REALP (n
))
724 double val
= SCM_REAL_VALUE (n
);
725 if (DOUBLE_IS_FINITE (val
))
727 double rem
= fabs (fmod (val
, 2.0));
734 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
738 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
740 "Return @code{#t} if the real number @var{x} is neither\n"
741 "infinite nor a NaN, @code{#f} otherwise.")
742 #define FUNC_NAME s_scm_finite_p
745 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
746 else if (scm_is_real (x
))
749 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
753 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
755 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
756 "@samp{-inf.0}. Otherwise return @code{#f}.")
757 #define FUNC_NAME s_scm_inf_p
760 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
761 else if (scm_is_real (x
))
764 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
768 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
770 "Return @code{#t} if the real number @var{x} is a NaN,\n"
771 "or @code{#f} otherwise.")
772 #define FUNC_NAME s_scm_nan_p
775 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
776 else if (scm_is_real (x
))
779 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
783 /* Guile's idea of infinity. */
784 static double guile_Inf
;
786 /* Guile's idea of not a number. */
787 static double guile_NaN
;
790 guile_ieee_init (void)
792 /* Some version of gcc on some old version of Linux used to crash when
793 trying to make Inf and NaN. */
796 /* C99 INFINITY, when available.
797 FIXME: The standard allows for INFINITY to be something that overflows
798 at compile time. We ought to have a configure test to check for that
799 before trying to use it. (But in practice we believe this is not a
800 problem on any system guile is likely to target.) */
801 guile_Inf
= INFINITY
;
802 #elif defined HAVE_DINFINITY
804 extern unsigned int DINFINITY
[2];
805 guile_Inf
= (*((double *) (DINFINITY
)));
812 if (guile_Inf
== tmp
)
819 /* C99 NAN, when available */
821 #elif defined HAVE_DQNAN
824 extern unsigned int DQNAN
[2];
825 guile_NaN
= (*((double *)(DQNAN
)));
828 guile_NaN
= guile_Inf
/ guile_Inf
;
832 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
835 #define FUNC_NAME s_scm_inf
837 static int initialized
= 0;
843 return scm_from_double (guile_Inf
);
847 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
850 #define FUNC_NAME s_scm_nan
852 static int initialized
= 0;
858 return scm_from_double (guile_NaN
);
863 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
865 "Return the absolute value of @var{x}.")
866 #define FUNC_NAME s_scm_abs
870 scm_t_inum xx
= SCM_I_INUM (x
);
873 else if (SCM_POSFIXABLE (-xx
))
874 return SCM_I_MAKINUM (-xx
);
876 return scm_i_inum2big (-xx
);
878 else if (SCM_LIKELY (SCM_REALP (x
)))
880 double xx
= SCM_REAL_VALUE (x
);
881 /* If x is a NaN then xx<0 is false so we return x unchanged */
883 return scm_from_double (-xx
);
884 /* Handle signed zeroes properly */
885 else if (SCM_UNLIKELY (xx
== 0.0))
890 else if (SCM_BIGP (x
))
892 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
894 return scm_i_clonebig (x
, 0);
898 else if (SCM_FRACTIONP (x
))
900 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
902 return scm_i_make_ratio_already_reduced
903 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
904 SCM_FRACTION_DENOMINATOR (x
));
907 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
912 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
914 "Return the quotient of the numbers @var{x} and @var{y}.")
915 #define FUNC_NAME s_scm_quotient
917 if (SCM_LIKELY (scm_is_integer (x
)))
919 if (SCM_LIKELY (scm_is_integer (y
)))
920 return scm_truncate_quotient (x
, y
);
922 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
925 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
929 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
931 "Return the remainder of the numbers @var{x} and @var{y}.\n"
933 "(remainder 13 4) @result{} 1\n"
934 "(remainder -13 4) @result{} -1\n"
936 #define FUNC_NAME s_scm_remainder
938 if (SCM_LIKELY (scm_is_integer (x
)))
940 if (SCM_LIKELY (scm_is_integer (y
)))
941 return scm_truncate_remainder (x
, y
);
943 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
946 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
951 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
953 "Return the modulo of the numbers @var{x} and @var{y}.\n"
955 "(modulo 13 4) @result{} 1\n"
956 "(modulo -13 4) @result{} 3\n"
958 #define FUNC_NAME s_scm_modulo
960 if (SCM_LIKELY (scm_is_integer (x
)))
962 if (SCM_LIKELY (scm_is_integer (y
)))
963 return scm_floor_remainder (x
, y
);
965 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
968 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
972 /* Return the exact integer q such that n = q*d, for exact integers n
973 and d, where d is known in advance to divide n evenly (with zero
974 remainder). For large integers, this can be computed more
975 efficiently than when the remainder is unknown. */
977 scm_exact_integer_quotient (SCM n
, SCM d
)
978 #define FUNC_NAME "exact-integer-quotient"
980 if (SCM_LIKELY (SCM_I_INUMP (n
)))
982 scm_t_inum nn
= SCM_I_INUM (n
);
983 if (SCM_LIKELY (SCM_I_INUMP (d
)))
985 scm_t_inum dd
= SCM_I_INUM (d
);
986 if (SCM_UNLIKELY (dd
== 0))
987 scm_num_overflow ("exact-integer-quotient");
990 scm_t_inum qq
= nn
/ dd
;
991 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
992 return SCM_I_MAKINUM (qq
);
994 return scm_i_inum2big (qq
);
997 else if (SCM_LIKELY (SCM_BIGP (d
)))
999 /* n is an inum and d is a bignum. Given that d is known to
1000 divide n evenly, there are only two possibilities: n is 0,
1001 or else n is fixnum-min and d is abs(fixnum-min). */
1005 return SCM_I_MAKINUM (-1);
1008 SCM_WRONG_TYPE_ARG (2, d
);
1010 else if (SCM_LIKELY (SCM_BIGP (n
)))
1012 if (SCM_LIKELY (SCM_I_INUMP (d
)))
1014 scm_t_inum dd
= SCM_I_INUM (d
);
1015 if (SCM_UNLIKELY (dd
== 0))
1016 scm_num_overflow ("exact-integer-quotient");
1017 else if (SCM_UNLIKELY (dd
== 1))
1021 SCM q
= scm_i_mkbig ();
1023 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
1026 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
1027 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1029 scm_remember_upto_here_1 (n
);
1030 return scm_i_normbig (q
);
1033 else if (SCM_LIKELY (SCM_BIGP (d
)))
1035 SCM q
= scm_i_mkbig ();
1036 mpz_divexact (SCM_I_BIG_MPZ (q
),
1039 scm_remember_upto_here_2 (n
, d
);
1040 return scm_i_normbig (q
);
1043 SCM_WRONG_TYPE_ARG (2, d
);
1046 SCM_WRONG_TYPE_ARG (1, n
);
1050 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1051 two-valued functions. It is called from primitive generics that take
1052 two arguments and return two values, when the core procedure is
1053 unable to handle the given argument types. If there are GOOPS
1054 methods for this primitive generic, it dispatches to GOOPS and, if
1055 successful, expects two values to be returned, which are placed in
1056 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1057 wrong-type-arg exception.
1059 FIXME: This obviously belongs somewhere else, but until we decide on
1060 the right API, it is here as a static function, because it is needed
1061 by the *_divide functions below.
1064 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
1065 const char *subr
, SCM
*rp1
, SCM
*rp2
)
1067 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
1069 scm_i_extract_values_2 (vals
, rp1
, rp2
);
1072 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1074 "Return the integer @var{q} such that\n"
1075 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1076 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1078 "(euclidean-quotient 123 10) @result{} 12\n"
1079 "(euclidean-quotient 123 -10) @result{} -12\n"
1080 "(euclidean-quotient -123 10) @result{} -13\n"
1081 "(euclidean-quotient -123 -10) @result{} 13\n"
1082 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1083 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1085 #define FUNC_NAME s_scm_euclidean_quotient
1087 if (scm_is_false (scm_negative_p (y
)))
1088 return scm_floor_quotient (x
, y
);
1090 return scm_ceiling_quotient (x
, y
);
1094 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1096 "Return the real number @var{r} such that\n"
1097 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1098 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1099 "for some integer @var{q}.\n"
1101 "(euclidean-remainder 123 10) @result{} 3\n"
1102 "(euclidean-remainder 123 -10) @result{} 3\n"
1103 "(euclidean-remainder -123 10) @result{} 7\n"
1104 "(euclidean-remainder -123 -10) @result{} 7\n"
1105 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1106 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1108 #define FUNC_NAME s_scm_euclidean_remainder
1110 if (scm_is_false (scm_negative_p (y
)))
1111 return scm_floor_remainder (x
, y
);
1113 return scm_ceiling_remainder (x
, y
);
1117 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1119 "Return the integer @var{q} and the real number @var{r}\n"
1120 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1121 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1123 "(euclidean/ 123 10) @result{} 12 and 3\n"
1124 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1125 "(euclidean/ -123 10) @result{} -13 and 7\n"
1126 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1127 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1128 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1130 #define FUNC_NAME s_scm_i_euclidean_divide
1132 if (scm_is_false (scm_negative_p (y
)))
1133 return scm_i_floor_divide (x
, y
);
1135 return scm_i_ceiling_divide (x
, y
);
1140 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1142 if (scm_is_false (scm_negative_p (y
)))
1143 return scm_floor_divide (x
, y
, qp
, rp
);
1145 return scm_ceiling_divide (x
, y
, qp
, rp
);
1148 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1149 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1151 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1153 "Return the floor of @math{@var{x} / @var{y}}.\n"
1155 "(floor-quotient 123 10) @result{} 12\n"
1156 "(floor-quotient 123 -10) @result{} -13\n"
1157 "(floor-quotient -123 10) @result{} -13\n"
1158 "(floor-quotient -123 -10) @result{} 12\n"
1159 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1160 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1162 #define FUNC_NAME s_scm_floor_quotient
1164 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1166 scm_t_inum xx
= SCM_I_INUM (x
);
1167 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1169 scm_t_inum yy
= SCM_I_INUM (y
);
1170 scm_t_inum xx1
= xx
;
1172 if (SCM_LIKELY (yy
> 0))
1174 if (SCM_UNLIKELY (xx
< 0))
1177 else if (SCM_UNLIKELY (yy
== 0))
1178 scm_num_overflow (s_scm_floor_quotient
);
1182 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1183 return SCM_I_MAKINUM (qq
);
1185 return scm_i_inum2big (qq
);
1187 else if (SCM_BIGP (y
))
1189 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1190 scm_remember_upto_here_1 (y
);
1192 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1194 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1196 else if (SCM_REALP (y
))
1197 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1198 else if (SCM_FRACTIONP (y
))
1199 return scm_i_exact_rational_floor_quotient (x
, y
);
1201 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1202 s_scm_floor_quotient
);
1204 else if (SCM_BIGP (x
))
1206 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1208 scm_t_inum yy
= SCM_I_INUM (y
);
1209 if (SCM_UNLIKELY (yy
== 0))
1210 scm_num_overflow (s_scm_floor_quotient
);
1211 else if (SCM_UNLIKELY (yy
== 1))
1215 SCM q
= scm_i_mkbig ();
1217 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1220 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1221 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1223 scm_remember_upto_here_1 (x
);
1224 return scm_i_normbig (q
);
1227 else if (SCM_BIGP (y
))
1229 SCM q
= scm_i_mkbig ();
1230 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1233 scm_remember_upto_here_2 (x
, y
);
1234 return scm_i_normbig (q
);
1236 else if (SCM_REALP (y
))
1237 return scm_i_inexact_floor_quotient
1238 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1239 else if (SCM_FRACTIONP (y
))
1240 return scm_i_exact_rational_floor_quotient (x
, y
);
1242 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1243 s_scm_floor_quotient
);
1245 else if (SCM_REALP (x
))
1247 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1248 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1249 return scm_i_inexact_floor_quotient
1250 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1252 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1253 s_scm_floor_quotient
);
1255 else if (SCM_FRACTIONP (x
))
1258 return scm_i_inexact_floor_quotient
1259 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1260 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1261 return scm_i_exact_rational_floor_quotient (x
, y
);
1263 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1264 s_scm_floor_quotient
);
1267 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1268 s_scm_floor_quotient
);
1273 scm_i_inexact_floor_quotient (double x
, double y
)
1275 if (SCM_UNLIKELY (y
== 0))
1276 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1278 return scm_from_double (floor (x
/ y
));
1282 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1284 return scm_floor_quotient
1285 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1286 scm_product (scm_numerator (y
), scm_denominator (x
)));
1289 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1290 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1292 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1294 "Return the real number @var{r} such that\n"
1295 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1296 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1298 "(floor-remainder 123 10) @result{} 3\n"
1299 "(floor-remainder 123 -10) @result{} -7\n"
1300 "(floor-remainder -123 10) @result{} 7\n"
1301 "(floor-remainder -123 -10) @result{} -3\n"
1302 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1303 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1305 #define FUNC_NAME s_scm_floor_remainder
1307 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1309 scm_t_inum xx
= SCM_I_INUM (x
);
1310 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1312 scm_t_inum yy
= SCM_I_INUM (y
);
1313 if (SCM_UNLIKELY (yy
== 0))
1314 scm_num_overflow (s_scm_floor_remainder
);
1317 scm_t_inum rr
= xx
% yy
;
1318 int needs_adjustment
;
1320 if (SCM_LIKELY (yy
> 0))
1321 needs_adjustment
= (rr
< 0);
1323 needs_adjustment
= (rr
> 0);
1325 if (needs_adjustment
)
1327 return SCM_I_MAKINUM (rr
);
1330 else if (SCM_BIGP (y
))
1332 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1333 scm_remember_upto_here_1 (y
);
1338 SCM r
= scm_i_mkbig ();
1339 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1340 scm_remember_upto_here_1 (y
);
1341 return scm_i_normbig (r
);
1350 SCM r
= scm_i_mkbig ();
1351 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1352 scm_remember_upto_here_1 (y
);
1353 return scm_i_normbig (r
);
1356 else if (SCM_REALP (y
))
1357 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1358 else if (SCM_FRACTIONP (y
))
1359 return scm_i_exact_rational_floor_remainder (x
, y
);
1361 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1362 s_scm_floor_remainder
);
1364 else if (SCM_BIGP (x
))
1366 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1368 scm_t_inum yy
= SCM_I_INUM (y
);
1369 if (SCM_UNLIKELY (yy
== 0))
1370 scm_num_overflow (s_scm_floor_remainder
);
1375 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1377 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1378 scm_remember_upto_here_1 (x
);
1379 return SCM_I_MAKINUM (rr
);
1382 else if (SCM_BIGP (y
))
1384 SCM r
= scm_i_mkbig ();
1385 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1388 scm_remember_upto_here_2 (x
, y
);
1389 return scm_i_normbig (r
);
1391 else if (SCM_REALP (y
))
1392 return scm_i_inexact_floor_remainder
1393 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1394 else if (SCM_FRACTIONP (y
))
1395 return scm_i_exact_rational_floor_remainder (x
, y
);
1397 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1398 s_scm_floor_remainder
);
1400 else if (SCM_REALP (x
))
1402 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1403 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1404 return scm_i_inexact_floor_remainder
1405 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1407 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1408 s_scm_floor_remainder
);
1410 else if (SCM_FRACTIONP (x
))
1413 return scm_i_inexact_floor_remainder
1414 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1415 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1416 return scm_i_exact_rational_floor_remainder (x
, y
);
1418 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1419 s_scm_floor_remainder
);
1422 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1423 s_scm_floor_remainder
);
1428 scm_i_inexact_floor_remainder (double x
, double y
)
1430 /* Although it would be more efficient to use fmod here, we can't
1431 because it would in some cases produce results inconsistent with
1432 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1433 close). In particular, when x is very close to a multiple of y,
1434 then r might be either 0.0 or y, but those two cases must
1435 correspond to different choices of q. If r = 0.0 then q must be
1436 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1437 and remainder chooses the other, it would be bad. */
1438 if (SCM_UNLIKELY (y
== 0))
1439 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1441 return scm_from_double (x
- y
* floor (x
/ y
));
1445 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1447 SCM xd
= scm_denominator (x
);
1448 SCM yd
= scm_denominator (y
);
1449 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1450 scm_product (scm_numerator (y
), xd
));
1451 return scm_divide (r1
, scm_product (xd
, yd
));
1455 static void scm_i_inexact_floor_divide (double x
, double y
,
1457 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1460 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1462 "Return the integer @var{q} and the real number @var{r}\n"
1463 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1464 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1466 "(floor/ 123 10) @result{} 12 and 3\n"
1467 "(floor/ 123 -10) @result{} -13 and -7\n"
1468 "(floor/ -123 10) @result{} -13 and 7\n"
1469 "(floor/ -123 -10) @result{} 12 and -3\n"
1470 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1471 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1473 #define FUNC_NAME s_scm_i_floor_divide
1477 scm_floor_divide(x
, y
, &q
, &r
);
1478 return scm_values (scm_list_2 (q
, r
));
1482 #define s_scm_floor_divide s_scm_i_floor_divide
1483 #define g_scm_floor_divide g_scm_i_floor_divide
1486 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1488 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1490 scm_t_inum xx
= SCM_I_INUM (x
);
1491 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1493 scm_t_inum yy
= SCM_I_INUM (y
);
1494 if (SCM_UNLIKELY (yy
== 0))
1495 scm_num_overflow (s_scm_floor_divide
);
1498 scm_t_inum qq
= xx
/ yy
;
1499 scm_t_inum rr
= xx
% yy
;
1500 int needs_adjustment
;
1502 if (SCM_LIKELY (yy
> 0))
1503 needs_adjustment
= (rr
< 0);
1505 needs_adjustment
= (rr
> 0);
1507 if (needs_adjustment
)
1513 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1514 *qp
= SCM_I_MAKINUM (qq
);
1516 *qp
= scm_i_inum2big (qq
);
1517 *rp
= SCM_I_MAKINUM (rr
);
1521 else if (SCM_BIGP (y
))
1523 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1524 scm_remember_upto_here_1 (y
);
1529 SCM r
= scm_i_mkbig ();
1530 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1531 scm_remember_upto_here_1 (y
);
1532 *qp
= SCM_I_MAKINUM (-1);
1533 *rp
= scm_i_normbig (r
);
1548 SCM r
= scm_i_mkbig ();
1549 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1550 scm_remember_upto_here_1 (y
);
1551 *qp
= SCM_I_MAKINUM (-1);
1552 *rp
= scm_i_normbig (r
);
1556 else if (SCM_REALP (y
))
1557 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1558 else if (SCM_FRACTIONP (y
))
1559 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1561 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1562 s_scm_floor_divide
, qp
, rp
);
1564 else if (SCM_BIGP (x
))
1566 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1568 scm_t_inum yy
= SCM_I_INUM (y
);
1569 if (SCM_UNLIKELY (yy
== 0))
1570 scm_num_overflow (s_scm_floor_divide
);
1573 SCM q
= scm_i_mkbig ();
1574 SCM r
= scm_i_mkbig ();
1576 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1577 SCM_I_BIG_MPZ (x
), yy
);
1580 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1581 SCM_I_BIG_MPZ (x
), -yy
);
1582 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1584 scm_remember_upto_here_1 (x
);
1585 *qp
= scm_i_normbig (q
);
1586 *rp
= scm_i_normbig (r
);
1590 else if (SCM_BIGP (y
))
1592 SCM q
= scm_i_mkbig ();
1593 SCM r
= scm_i_mkbig ();
1594 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1595 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1596 scm_remember_upto_here_2 (x
, y
);
1597 *qp
= scm_i_normbig (q
);
1598 *rp
= scm_i_normbig (r
);
1601 else if (SCM_REALP (y
))
1602 return scm_i_inexact_floor_divide
1603 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1604 else if (SCM_FRACTIONP (y
))
1605 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1607 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1608 s_scm_floor_divide
, qp
, rp
);
1610 else if (SCM_REALP (x
))
1612 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1613 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1614 return scm_i_inexact_floor_divide
1615 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1617 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1618 s_scm_floor_divide
, qp
, rp
);
1620 else if (SCM_FRACTIONP (x
))
1623 return scm_i_inexact_floor_divide
1624 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1625 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1626 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1628 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1629 s_scm_floor_divide
, qp
, rp
);
1632 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1633 s_scm_floor_divide
, qp
, rp
);
1637 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1639 if (SCM_UNLIKELY (y
== 0))
1640 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1643 double q
= floor (x
/ y
);
1644 double r
= x
- q
* y
;
1645 *qp
= scm_from_double (q
);
1646 *rp
= scm_from_double (r
);
1651 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1654 SCM xd
= scm_denominator (x
);
1655 SCM yd
= scm_denominator (y
);
1657 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1658 scm_product (scm_numerator (y
), xd
),
1660 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1663 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1664 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1666 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1668 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1670 "(ceiling-quotient 123 10) @result{} 13\n"
1671 "(ceiling-quotient 123 -10) @result{} -12\n"
1672 "(ceiling-quotient -123 10) @result{} -12\n"
1673 "(ceiling-quotient -123 -10) @result{} 13\n"
1674 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1675 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1677 #define FUNC_NAME s_scm_ceiling_quotient
1679 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1681 scm_t_inum xx
= SCM_I_INUM (x
);
1682 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1684 scm_t_inum yy
= SCM_I_INUM (y
);
1685 if (SCM_UNLIKELY (yy
== 0))
1686 scm_num_overflow (s_scm_ceiling_quotient
);
1689 scm_t_inum xx1
= xx
;
1691 if (SCM_LIKELY (yy
> 0))
1693 if (SCM_LIKELY (xx
>= 0))
1699 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1700 return SCM_I_MAKINUM (qq
);
1702 return scm_i_inum2big (qq
);
1705 else if (SCM_BIGP (y
))
1707 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1708 scm_remember_upto_here_1 (y
);
1709 if (SCM_LIKELY (sign
> 0))
1711 if (SCM_LIKELY (xx
> 0))
1713 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1714 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1715 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1717 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1718 scm_remember_upto_here_1 (y
);
1719 return SCM_I_MAKINUM (-1);
1729 else if (SCM_REALP (y
))
1730 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1731 else if (SCM_FRACTIONP (y
))
1732 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1734 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1735 s_scm_ceiling_quotient
);
1737 else if (SCM_BIGP (x
))
1739 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1741 scm_t_inum yy
= SCM_I_INUM (y
);
1742 if (SCM_UNLIKELY (yy
== 0))
1743 scm_num_overflow (s_scm_ceiling_quotient
);
1744 else if (SCM_UNLIKELY (yy
== 1))
1748 SCM q
= scm_i_mkbig ();
1750 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1753 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1754 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1756 scm_remember_upto_here_1 (x
);
1757 return scm_i_normbig (q
);
1760 else if (SCM_BIGP (y
))
1762 SCM q
= scm_i_mkbig ();
1763 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1766 scm_remember_upto_here_2 (x
, y
);
1767 return scm_i_normbig (q
);
1769 else if (SCM_REALP (y
))
1770 return scm_i_inexact_ceiling_quotient
1771 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1772 else if (SCM_FRACTIONP (y
))
1773 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1775 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1776 s_scm_ceiling_quotient
);
1778 else if (SCM_REALP (x
))
1780 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1781 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1782 return scm_i_inexact_ceiling_quotient
1783 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1785 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1786 s_scm_ceiling_quotient
);
1788 else if (SCM_FRACTIONP (x
))
1791 return scm_i_inexact_ceiling_quotient
1792 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1793 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1794 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1796 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1797 s_scm_ceiling_quotient
);
1800 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1801 s_scm_ceiling_quotient
);
1806 scm_i_inexact_ceiling_quotient (double x
, double y
)
1808 if (SCM_UNLIKELY (y
== 0))
1809 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1811 return scm_from_double (ceil (x
/ y
));
1815 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1817 return scm_ceiling_quotient
1818 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1819 scm_product (scm_numerator (y
), scm_denominator (x
)));
1822 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1823 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1825 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1827 "Return the real number @var{r} such that\n"
1828 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1829 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1831 "(ceiling-remainder 123 10) @result{} -7\n"
1832 "(ceiling-remainder 123 -10) @result{} 3\n"
1833 "(ceiling-remainder -123 10) @result{} -3\n"
1834 "(ceiling-remainder -123 -10) @result{} 7\n"
1835 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1836 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1838 #define FUNC_NAME s_scm_ceiling_remainder
1840 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1842 scm_t_inum xx
= SCM_I_INUM (x
);
1843 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1845 scm_t_inum yy
= SCM_I_INUM (y
);
1846 if (SCM_UNLIKELY (yy
== 0))
1847 scm_num_overflow (s_scm_ceiling_remainder
);
1850 scm_t_inum rr
= xx
% yy
;
1851 int needs_adjustment
;
1853 if (SCM_LIKELY (yy
> 0))
1854 needs_adjustment
= (rr
> 0);
1856 needs_adjustment
= (rr
< 0);
1858 if (needs_adjustment
)
1860 return SCM_I_MAKINUM (rr
);
1863 else if (SCM_BIGP (y
))
1865 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1866 scm_remember_upto_here_1 (y
);
1867 if (SCM_LIKELY (sign
> 0))
1869 if (SCM_LIKELY (xx
> 0))
1871 SCM r
= scm_i_mkbig ();
1872 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1873 scm_remember_upto_here_1 (y
);
1874 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1875 return scm_i_normbig (r
);
1877 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1878 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1879 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1881 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1882 scm_remember_upto_here_1 (y
);
1892 SCM r
= scm_i_mkbig ();
1893 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1894 scm_remember_upto_here_1 (y
);
1895 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1896 return scm_i_normbig (r
);
1899 else if (SCM_REALP (y
))
1900 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1901 else if (SCM_FRACTIONP (y
))
1902 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1904 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1905 s_scm_ceiling_remainder
);
1907 else if (SCM_BIGP (x
))
1909 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1911 scm_t_inum yy
= SCM_I_INUM (y
);
1912 if (SCM_UNLIKELY (yy
== 0))
1913 scm_num_overflow (s_scm_ceiling_remainder
);
1918 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1920 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1921 scm_remember_upto_here_1 (x
);
1922 return SCM_I_MAKINUM (rr
);
1925 else if (SCM_BIGP (y
))
1927 SCM r
= scm_i_mkbig ();
1928 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1931 scm_remember_upto_here_2 (x
, y
);
1932 return scm_i_normbig (r
);
1934 else if (SCM_REALP (y
))
1935 return scm_i_inexact_ceiling_remainder
1936 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1937 else if (SCM_FRACTIONP (y
))
1938 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1940 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1941 s_scm_ceiling_remainder
);
1943 else if (SCM_REALP (x
))
1945 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1946 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1947 return scm_i_inexact_ceiling_remainder
1948 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1950 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1951 s_scm_ceiling_remainder
);
1953 else if (SCM_FRACTIONP (x
))
1956 return scm_i_inexact_ceiling_remainder
1957 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1958 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1959 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1961 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1962 s_scm_ceiling_remainder
);
1965 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1966 s_scm_ceiling_remainder
);
1971 scm_i_inexact_ceiling_remainder (double x
, double y
)
1973 /* Although it would be more efficient to use fmod here, we can't
1974 because it would in some cases produce results inconsistent with
1975 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1976 close). In particular, when x is very close to a multiple of y,
1977 then r might be either 0.0 or -y, but those two cases must
1978 correspond to different choices of q. If r = 0.0 then q must be
1979 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1980 and remainder chooses the other, it would be bad. */
1981 if (SCM_UNLIKELY (y
== 0))
1982 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1984 return scm_from_double (x
- y
* ceil (x
/ y
));
1988 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1990 SCM xd
= scm_denominator (x
);
1991 SCM yd
= scm_denominator (y
);
1992 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1993 scm_product (scm_numerator (y
), xd
));
1994 return scm_divide (r1
, scm_product (xd
, yd
));
1997 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1999 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2002 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2004 "Return the integer @var{q} and the real number @var{r}\n"
2005 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2006 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2008 "(ceiling/ 123 10) @result{} 13 and -7\n"
2009 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2010 "(ceiling/ -123 10) @result{} -12 and -3\n"
2011 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2012 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2013 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2015 #define FUNC_NAME s_scm_i_ceiling_divide
2019 scm_ceiling_divide(x
, y
, &q
, &r
);
2020 return scm_values (scm_list_2 (q
, r
));
2024 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2025 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2028 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2030 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2032 scm_t_inum xx
= SCM_I_INUM (x
);
2033 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2035 scm_t_inum yy
= SCM_I_INUM (y
);
2036 if (SCM_UNLIKELY (yy
== 0))
2037 scm_num_overflow (s_scm_ceiling_divide
);
2040 scm_t_inum qq
= xx
/ yy
;
2041 scm_t_inum rr
= xx
% yy
;
2042 int needs_adjustment
;
2044 if (SCM_LIKELY (yy
> 0))
2045 needs_adjustment
= (rr
> 0);
2047 needs_adjustment
= (rr
< 0);
2049 if (needs_adjustment
)
2054 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2055 *qp
= SCM_I_MAKINUM (qq
);
2057 *qp
= scm_i_inum2big (qq
);
2058 *rp
= SCM_I_MAKINUM (rr
);
2062 else if (SCM_BIGP (y
))
2064 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2065 scm_remember_upto_here_1 (y
);
2066 if (SCM_LIKELY (sign
> 0))
2068 if (SCM_LIKELY (xx
> 0))
2070 SCM r
= scm_i_mkbig ();
2071 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2072 scm_remember_upto_here_1 (y
);
2073 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2075 *rp
= scm_i_normbig (r
);
2077 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2078 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2079 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2081 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2082 scm_remember_upto_here_1 (y
);
2083 *qp
= SCM_I_MAKINUM (-1);
2099 SCM r
= scm_i_mkbig ();
2100 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2101 scm_remember_upto_here_1 (y
);
2102 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2104 *rp
= scm_i_normbig (r
);
2108 else if (SCM_REALP (y
))
2109 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2110 else if (SCM_FRACTIONP (y
))
2111 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2113 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2114 s_scm_ceiling_divide
, qp
, rp
);
2116 else if (SCM_BIGP (x
))
2118 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2120 scm_t_inum yy
= SCM_I_INUM (y
);
2121 if (SCM_UNLIKELY (yy
== 0))
2122 scm_num_overflow (s_scm_ceiling_divide
);
2125 SCM q
= scm_i_mkbig ();
2126 SCM r
= scm_i_mkbig ();
2128 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2129 SCM_I_BIG_MPZ (x
), yy
);
2132 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2133 SCM_I_BIG_MPZ (x
), -yy
);
2134 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2136 scm_remember_upto_here_1 (x
);
2137 *qp
= scm_i_normbig (q
);
2138 *rp
= scm_i_normbig (r
);
2142 else if (SCM_BIGP (y
))
2144 SCM q
= scm_i_mkbig ();
2145 SCM r
= scm_i_mkbig ();
2146 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2147 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2148 scm_remember_upto_here_2 (x
, y
);
2149 *qp
= scm_i_normbig (q
);
2150 *rp
= scm_i_normbig (r
);
2153 else if (SCM_REALP (y
))
2154 return scm_i_inexact_ceiling_divide
2155 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2156 else if (SCM_FRACTIONP (y
))
2157 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2159 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2160 s_scm_ceiling_divide
, qp
, rp
);
2162 else if (SCM_REALP (x
))
2164 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2165 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2166 return scm_i_inexact_ceiling_divide
2167 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2169 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2170 s_scm_ceiling_divide
, qp
, rp
);
2172 else if (SCM_FRACTIONP (x
))
2175 return scm_i_inexact_ceiling_divide
2176 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2177 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2178 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2180 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2181 s_scm_ceiling_divide
, qp
, rp
);
2184 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2185 s_scm_ceiling_divide
, qp
, rp
);
2189 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2191 if (SCM_UNLIKELY (y
== 0))
2192 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2195 double q
= ceil (x
/ y
);
2196 double r
= x
- q
* y
;
2197 *qp
= scm_from_double (q
);
2198 *rp
= scm_from_double (r
);
2203 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2206 SCM xd
= scm_denominator (x
);
2207 SCM yd
= scm_denominator (y
);
2209 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2210 scm_product (scm_numerator (y
), xd
),
2212 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2215 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2216 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2218 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2220 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2222 "(truncate-quotient 123 10) @result{} 12\n"
2223 "(truncate-quotient 123 -10) @result{} -12\n"
2224 "(truncate-quotient -123 10) @result{} -12\n"
2225 "(truncate-quotient -123 -10) @result{} 12\n"
2226 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2227 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2229 #define FUNC_NAME s_scm_truncate_quotient
2231 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2233 scm_t_inum xx
= SCM_I_INUM (x
);
2234 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2236 scm_t_inum yy
= SCM_I_INUM (y
);
2237 if (SCM_UNLIKELY (yy
== 0))
2238 scm_num_overflow (s_scm_truncate_quotient
);
2241 scm_t_inum qq
= xx
/ yy
;
2242 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2243 return SCM_I_MAKINUM (qq
);
2245 return scm_i_inum2big (qq
);
2248 else if (SCM_BIGP (y
))
2250 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2251 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2252 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2254 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2255 scm_remember_upto_here_1 (y
);
2256 return SCM_I_MAKINUM (-1);
2261 else if (SCM_REALP (y
))
2262 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2263 else if (SCM_FRACTIONP (y
))
2264 return scm_i_exact_rational_truncate_quotient (x
, y
);
2266 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2267 s_scm_truncate_quotient
);
2269 else if (SCM_BIGP (x
))
2271 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2273 scm_t_inum yy
= SCM_I_INUM (y
);
2274 if (SCM_UNLIKELY (yy
== 0))
2275 scm_num_overflow (s_scm_truncate_quotient
);
2276 else if (SCM_UNLIKELY (yy
== 1))
2280 SCM q
= scm_i_mkbig ();
2282 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2285 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2286 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2288 scm_remember_upto_here_1 (x
);
2289 return scm_i_normbig (q
);
2292 else if (SCM_BIGP (y
))
2294 SCM q
= scm_i_mkbig ();
2295 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2298 scm_remember_upto_here_2 (x
, y
);
2299 return scm_i_normbig (q
);
2301 else if (SCM_REALP (y
))
2302 return scm_i_inexact_truncate_quotient
2303 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2304 else if (SCM_FRACTIONP (y
))
2305 return scm_i_exact_rational_truncate_quotient (x
, y
);
2307 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2308 s_scm_truncate_quotient
);
2310 else if (SCM_REALP (x
))
2312 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2313 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2314 return scm_i_inexact_truncate_quotient
2315 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2317 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2318 s_scm_truncate_quotient
);
2320 else if (SCM_FRACTIONP (x
))
2323 return scm_i_inexact_truncate_quotient
2324 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2325 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2326 return scm_i_exact_rational_truncate_quotient (x
, y
);
2328 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2329 s_scm_truncate_quotient
);
2332 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2333 s_scm_truncate_quotient
);
2338 scm_i_inexact_truncate_quotient (double x
, double y
)
2340 if (SCM_UNLIKELY (y
== 0))
2341 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2343 return scm_from_double (trunc (x
/ y
));
2347 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2349 return scm_truncate_quotient
2350 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2351 scm_product (scm_numerator (y
), scm_denominator (x
)));
2354 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2355 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2357 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2359 "Return the real number @var{r} such that\n"
2360 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2361 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2363 "(truncate-remainder 123 10) @result{} 3\n"
2364 "(truncate-remainder 123 -10) @result{} 3\n"
2365 "(truncate-remainder -123 10) @result{} -3\n"
2366 "(truncate-remainder -123 -10) @result{} -3\n"
2367 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2368 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2370 #define FUNC_NAME s_scm_truncate_remainder
2372 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2374 scm_t_inum xx
= SCM_I_INUM (x
);
2375 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2377 scm_t_inum yy
= SCM_I_INUM (y
);
2378 if (SCM_UNLIKELY (yy
== 0))
2379 scm_num_overflow (s_scm_truncate_remainder
);
2381 return SCM_I_MAKINUM (xx
% yy
);
2383 else if (SCM_BIGP (y
))
2385 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2386 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2387 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2389 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2390 scm_remember_upto_here_1 (y
);
2396 else if (SCM_REALP (y
))
2397 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2398 else if (SCM_FRACTIONP (y
))
2399 return scm_i_exact_rational_truncate_remainder (x
, y
);
2401 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2402 s_scm_truncate_remainder
);
2404 else if (SCM_BIGP (x
))
2406 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2408 scm_t_inum yy
= SCM_I_INUM (y
);
2409 if (SCM_UNLIKELY (yy
== 0))
2410 scm_num_overflow (s_scm_truncate_remainder
);
2413 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2414 (yy
> 0) ? yy
: -yy
)
2415 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2416 scm_remember_upto_here_1 (x
);
2417 return SCM_I_MAKINUM (rr
);
2420 else if (SCM_BIGP (y
))
2422 SCM r
= scm_i_mkbig ();
2423 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2426 scm_remember_upto_here_2 (x
, y
);
2427 return scm_i_normbig (r
);
2429 else if (SCM_REALP (y
))
2430 return scm_i_inexact_truncate_remainder
2431 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2432 else if (SCM_FRACTIONP (y
))
2433 return scm_i_exact_rational_truncate_remainder (x
, y
);
2435 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2436 s_scm_truncate_remainder
);
2438 else if (SCM_REALP (x
))
2440 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2441 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2442 return scm_i_inexact_truncate_remainder
2443 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2445 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2446 s_scm_truncate_remainder
);
2448 else if (SCM_FRACTIONP (x
))
2451 return scm_i_inexact_truncate_remainder
2452 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2453 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2454 return scm_i_exact_rational_truncate_remainder (x
, y
);
2456 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2457 s_scm_truncate_remainder
);
2460 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2461 s_scm_truncate_remainder
);
2466 scm_i_inexact_truncate_remainder (double x
, double y
)
2468 /* Although it would be more efficient to use fmod here, we can't
2469 because it would in some cases produce results inconsistent with
2470 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2471 close). In particular, when x is very close to a multiple of y,
2472 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2473 correspond to different choices of q. If quotient chooses one and
2474 remainder chooses the other, it would be bad. */
2475 if (SCM_UNLIKELY (y
== 0))
2476 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2478 return scm_from_double (x
- y
* trunc (x
/ y
));
2482 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2484 SCM xd
= scm_denominator (x
);
2485 SCM yd
= scm_denominator (y
);
2486 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2487 scm_product (scm_numerator (y
), xd
));
2488 return scm_divide (r1
, scm_product (xd
, yd
));
2492 static void scm_i_inexact_truncate_divide (double x
, double y
,
2494 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2497 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2499 "Return the integer @var{q} and the real number @var{r}\n"
2500 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2501 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2503 "(truncate/ 123 10) @result{} 12 and 3\n"
2504 "(truncate/ 123 -10) @result{} -12 and 3\n"
2505 "(truncate/ -123 10) @result{} -12 and -3\n"
2506 "(truncate/ -123 -10) @result{} 12 and -3\n"
2507 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2508 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2510 #define FUNC_NAME s_scm_i_truncate_divide
2514 scm_truncate_divide(x
, y
, &q
, &r
);
2515 return scm_values (scm_list_2 (q
, r
));
2519 #define s_scm_truncate_divide s_scm_i_truncate_divide
2520 #define g_scm_truncate_divide g_scm_i_truncate_divide
2523 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2525 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2527 scm_t_inum xx
= SCM_I_INUM (x
);
2528 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2530 scm_t_inum yy
= SCM_I_INUM (y
);
2531 if (SCM_UNLIKELY (yy
== 0))
2532 scm_num_overflow (s_scm_truncate_divide
);
2535 scm_t_inum qq
= xx
/ yy
;
2536 scm_t_inum rr
= xx
% yy
;
2537 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2538 *qp
= SCM_I_MAKINUM (qq
);
2540 *qp
= scm_i_inum2big (qq
);
2541 *rp
= SCM_I_MAKINUM (rr
);
2545 else if (SCM_BIGP (y
))
2547 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2548 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2549 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2551 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2552 scm_remember_upto_here_1 (y
);
2553 *qp
= SCM_I_MAKINUM (-1);
2563 else if (SCM_REALP (y
))
2564 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2565 else if (SCM_FRACTIONP (y
))
2566 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2568 return two_valued_wta_dispatch_2
2569 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2570 s_scm_truncate_divide
, qp
, rp
);
2572 else if (SCM_BIGP (x
))
2574 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2576 scm_t_inum yy
= SCM_I_INUM (y
);
2577 if (SCM_UNLIKELY (yy
== 0))
2578 scm_num_overflow (s_scm_truncate_divide
);
2581 SCM q
= scm_i_mkbig ();
2584 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2585 SCM_I_BIG_MPZ (x
), yy
);
2588 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2589 SCM_I_BIG_MPZ (x
), -yy
);
2590 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2592 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2593 scm_remember_upto_here_1 (x
);
2594 *qp
= scm_i_normbig (q
);
2595 *rp
= SCM_I_MAKINUM (rr
);
2599 else if (SCM_BIGP (y
))
2601 SCM q
= scm_i_mkbig ();
2602 SCM r
= scm_i_mkbig ();
2603 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2604 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2605 scm_remember_upto_here_2 (x
, y
);
2606 *qp
= scm_i_normbig (q
);
2607 *rp
= scm_i_normbig (r
);
2609 else if (SCM_REALP (y
))
2610 return scm_i_inexact_truncate_divide
2611 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2612 else if (SCM_FRACTIONP (y
))
2613 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2615 return two_valued_wta_dispatch_2
2616 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2617 s_scm_truncate_divide
, qp
, rp
);
2619 else if (SCM_REALP (x
))
2621 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2622 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2623 return scm_i_inexact_truncate_divide
2624 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2626 return two_valued_wta_dispatch_2
2627 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2628 s_scm_truncate_divide
, qp
, rp
);
2630 else if (SCM_FRACTIONP (x
))
2633 return scm_i_inexact_truncate_divide
2634 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2635 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2636 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2638 return two_valued_wta_dispatch_2
2639 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2640 s_scm_truncate_divide
, qp
, rp
);
2643 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2644 s_scm_truncate_divide
, qp
, rp
);
2648 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2650 if (SCM_UNLIKELY (y
== 0))
2651 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2654 double q
= trunc (x
/ y
);
2655 double r
= x
- q
* y
;
2656 *qp
= scm_from_double (q
);
2657 *rp
= scm_from_double (r
);
2662 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2665 SCM xd
= scm_denominator (x
);
2666 SCM yd
= scm_denominator (y
);
2668 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2669 scm_product (scm_numerator (y
), xd
),
2671 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2674 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2675 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2676 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2678 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2680 "Return the integer @var{q} such that\n"
2681 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2682 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2684 "(centered-quotient 123 10) @result{} 12\n"
2685 "(centered-quotient 123 -10) @result{} -12\n"
2686 "(centered-quotient -123 10) @result{} -12\n"
2687 "(centered-quotient -123 -10) @result{} 12\n"
2688 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2689 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2691 #define FUNC_NAME s_scm_centered_quotient
2693 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2695 scm_t_inum xx
= SCM_I_INUM (x
);
2696 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2698 scm_t_inum yy
= SCM_I_INUM (y
);
2699 if (SCM_UNLIKELY (yy
== 0))
2700 scm_num_overflow (s_scm_centered_quotient
);
2703 scm_t_inum qq
= xx
/ yy
;
2704 scm_t_inum rr
= xx
% yy
;
2705 if (SCM_LIKELY (xx
> 0))
2707 if (SCM_LIKELY (yy
> 0))
2709 if (rr
>= (yy
+ 1) / 2)
2714 if (rr
>= (1 - yy
) / 2)
2720 if (SCM_LIKELY (yy
> 0))
2731 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2732 return SCM_I_MAKINUM (qq
);
2734 return scm_i_inum2big (qq
);
2737 else if (SCM_BIGP (y
))
2739 /* Pass a denormalized bignum version of x (even though it
2740 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2741 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2743 else if (SCM_REALP (y
))
2744 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2745 else if (SCM_FRACTIONP (y
))
2746 return scm_i_exact_rational_centered_quotient (x
, y
);
2748 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2749 s_scm_centered_quotient
);
2751 else if (SCM_BIGP (x
))
2753 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2755 scm_t_inum yy
= SCM_I_INUM (y
);
2756 if (SCM_UNLIKELY (yy
== 0))
2757 scm_num_overflow (s_scm_centered_quotient
);
2758 else if (SCM_UNLIKELY (yy
== 1))
2762 SCM q
= scm_i_mkbig ();
2764 /* Arrange for rr to initially be non-positive,
2765 because that simplifies the test to see
2766 if it is within the needed bounds. */
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
);
2773 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2774 SCM_I_BIG_MPZ (q
), 1);
2778 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2779 SCM_I_BIG_MPZ (x
), -yy
);
2780 scm_remember_upto_here_1 (x
);
2781 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2783 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2784 SCM_I_BIG_MPZ (q
), 1);
2786 return scm_i_normbig (q
);
2789 else if (SCM_BIGP (y
))
2790 return scm_i_bigint_centered_quotient (x
, y
);
2791 else if (SCM_REALP (y
))
2792 return scm_i_inexact_centered_quotient
2793 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2794 else if (SCM_FRACTIONP (y
))
2795 return scm_i_exact_rational_centered_quotient (x
, y
);
2797 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2798 s_scm_centered_quotient
);
2800 else if (SCM_REALP (x
))
2802 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2803 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2804 return scm_i_inexact_centered_quotient
2805 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2807 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2808 s_scm_centered_quotient
);
2810 else if (SCM_FRACTIONP (x
))
2813 return scm_i_inexact_centered_quotient
2814 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2815 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2816 return scm_i_exact_rational_centered_quotient (x
, y
);
2818 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2819 s_scm_centered_quotient
);
2822 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2823 s_scm_centered_quotient
);
2828 scm_i_inexact_centered_quotient (double x
, double y
)
2830 if (SCM_LIKELY (y
> 0))
2831 return scm_from_double (floor (x
/y
+ 0.5));
2832 else if (SCM_LIKELY (y
< 0))
2833 return scm_from_double (ceil (x
/y
- 0.5));
2835 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2840 /* Assumes that both x and y are bigints, though
2841 x might be able to fit into a fixnum. */
2843 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2847 /* Note that x might be small enough to fit into a
2848 fixnum, so we must not let it escape into the wild */
2852 /* min_r will eventually become -abs(y)/2 */
2853 min_r
= scm_i_mkbig ();
2854 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2855 SCM_I_BIG_MPZ (y
), 1);
2857 /* Arrange for rr to initially be non-positive,
2858 because that simplifies the test to see
2859 if it is within the needed bounds. */
2860 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2862 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2863 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2864 scm_remember_upto_here_2 (x
, y
);
2865 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2866 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2867 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2868 SCM_I_BIG_MPZ (q
), 1);
2872 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2873 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2874 scm_remember_upto_here_2 (x
, y
);
2875 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2876 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2877 SCM_I_BIG_MPZ (q
), 1);
2879 scm_remember_upto_here_2 (r
, min_r
);
2880 return scm_i_normbig (q
);
2884 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2886 return scm_centered_quotient
2887 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2888 scm_product (scm_numerator (y
), scm_denominator (x
)));
2891 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2892 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2893 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2895 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2897 "Return the real number @var{r} such that\n"
2898 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2899 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2900 "for some integer @var{q}.\n"
2902 "(centered-remainder 123 10) @result{} 3\n"
2903 "(centered-remainder 123 -10) @result{} 3\n"
2904 "(centered-remainder -123 10) @result{} -3\n"
2905 "(centered-remainder -123 -10) @result{} -3\n"
2906 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2907 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2909 #define FUNC_NAME s_scm_centered_remainder
2911 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2913 scm_t_inum xx
= SCM_I_INUM (x
);
2914 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2916 scm_t_inum yy
= SCM_I_INUM (y
);
2917 if (SCM_UNLIKELY (yy
== 0))
2918 scm_num_overflow (s_scm_centered_remainder
);
2921 scm_t_inum rr
= xx
% yy
;
2922 if (SCM_LIKELY (xx
> 0))
2924 if (SCM_LIKELY (yy
> 0))
2926 if (rr
>= (yy
+ 1) / 2)
2931 if (rr
>= (1 - yy
) / 2)
2937 if (SCM_LIKELY (yy
> 0))
2948 return SCM_I_MAKINUM (rr
);
2951 else if (SCM_BIGP (y
))
2953 /* Pass a denormalized bignum version of x (even though it
2954 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2955 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2957 else if (SCM_REALP (y
))
2958 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2959 else if (SCM_FRACTIONP (y
))
2960 return scm_i_exact_rational_centered_remainder (x
, y
);
2962 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2963 s_scm_centered_remainder
);
2965 else if (SCM_BIGP (x
))
2967 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2969 scm_t_inum yy
= SCM_I_INUM (y
);
2970 if (SCM_UNLIKELY (yy
== 0))
2971 scm_num_overflow (s_scm_centered_remainder
);
2975 /* Arrange for rr to initially be non-positive,
2976 because that simplifies the test to see
2977 if it is within the needed bounds. */
2980 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2981 scm_remember_upto_here_1 (x
);
2987 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2988 scm_remember_upto_here_1 (x
);
2992 return SCM_I_MAKINUM (rr
);
2995 else if (SCM_BIGP (y
))
2996 return scm_i_bigint_centered_remainder (x
, y
);
2997 else if (SCM_REALP (y
))
2998 return scm_i_inexact_centered_remainder
2999 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3000 else if (SCM_FRACTIONP (y
))
3001 return scm_i_exact_rational_centered_remainder (x
, y
);
3003 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3004 s_scm_centered_remainder
);
3006 else if (SCM_REALP (x
))
3008 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3009 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3010 return scm_i_inexact_centered_remainder
3011 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3013 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3014 s_scm_centered_remainder
);
3016 else if (SCM_FRACTIONP (x
))
3019 return scm_i_inexact_centered_remainder
3020 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3021 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3022 return scm_i_exact_rational_centered_remainder (x
, y
);
3024 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3025 s_scm_centered_remainder
);
3028 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3029 s_scm_centered_remainder
);
3034 scm_i_inexact_centered_remainder (double x
, double y
)
3038 /* Although it would be more efficient to use fmod here, we can't
3039 because it would in some cases produce results inconsistent with
3040 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3041 close). In particular, when x-y/2 is very close to a multiple of
3042 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3043 two cases must correspond to different choices of q. If quotient
3044 chooses one and remainder chooses the other, it would be bad. */
3045 if (SCM_LIKELY (y
> 0))
3046 q
= floor (x
/y
+ 0.5);
3047 else if (SCM_LIKELY (y
< 0))
3048 q
= ceil (x
/y
- 0.5);
3050 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3053 return scm_from_double (x
- q
* y
);
3056 /* Assumes that both x and y are bigints, though
3057 x might be able to fit into a fixnum. */
3059 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3063 /* Note that x might be small enough to fit into a
3064 fixnum, so we must not let it escape into the wild */
3067 /* min_r will eventually become -abs(y)/2 */
3068 min_r
= scm_i_mkbig ();
3069 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3070 SCM_I_BIG_MPZ (y
), 1);
3072 /* Arrange for rr to initially be non-positive,
3073 because that simplifies the test to see
3074 if it is within the needed bounds. */
3075 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3077 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3078 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3079 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3080 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3081 mpz_add (SCM_I_BIG_MPZ (r
),
3087 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3088 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3089 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3090 mpz_sub (SCM_I_BIG_MPZ (r
),
3094 scm_remember_upto_here_2 (x
, y
);
3095 return scm_i_normbig (r
);
3099 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3101 SCM xd
= scm_denominator (x
);
3102 SCM yd
= scm_denominator (y
);
3103 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3104 scm_product (scm_numerator (y
), xd
));
3105 return scm_divide (r1
, scm_product (xd
, yd
));
3109 static void scm_i_inexact_centered_divide (double x
, double y
,
3111 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3112 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3115 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3117 "Return the integer @var{q} and the real number @var{r}\n"
3118 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3119 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3121 "(centered/ 123 10) @result{} 12 and 3\n"
3122 "(centered/ 123 -10) @result{} -12 and 3\n"
3123 "(centered/ -123 10) @result{} -12 and -3\n"
3124 "(centered/ -123 -10) @result{} 12 and -3\n"
3125 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3126 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3128 #define FUNC_NAME s_scm_i_centered_divide
3132 scm_centered_divide(x
, y
, &q
, &r
);
3133 return scm_values (scm_list_2 (q
, r
));
3137 #define s_scm_centered_divide s_scm_i_centered_divide
3138 #define g_scm_centered_divide g_scm_i_centered_divide
3141 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3143 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3145 scm_t_inum xx
= SCM_I_INUM (x
);
3146 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3148 scm_t_inum yy
= SCM_I_INUM (y
);
3149 if (SCM_UNLIKELY (yy
== 0))
3150 scm_num_overflow (s_scm_centered_divide
);
3153 scm_t_inum qq
= xx
/ yy
;
3154 scm_t_inum rr
= xx
% yy
;
3155 if (SCM_LIKELY (xx
> 0))
3157 if (SCM_LIKELY (yy
> 0))
3159 if (rr
>= (yy
+ 1) / 2)
3164 if (rr
>= (1 - yy
) / 2)
3170 if (SCM_LIKELY (yy
> 0))
3181 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3182 *qp
= SCM_I_MAKINUM (qq
);
3184 *qp
= scm_i_inum2big (qq
);
3185 *rp
= SCM_I_MAKINUM (rr
);
3189 else if (SCM_BIGP (y
))
3191 /* Pass a denormalized bignum version of x (even though it
3192 can fit in a fixnum) to scm_i_bigint_centered_divide */
3193 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3195 else if (SCM_REALP (y
))
3196 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3197 else if (SCM_FRACTIONP (y
))
3198 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3200 return two_valued_wta_dispatch_2
3201 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3202 s_scm_centered_divide
, qp
, rp
);
3204 else if (SCM_BIGP (x
))
3206 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3208 scm_t_inum yy
= SCM_I_INUM (y
);
3209 if (SCM_UNLIKELY (yy
== 0))
3210 scm_num_overflow (s_scm_centered_divide
);
3213 SCM q
= scm_i_mkbig ();
3215 /* Arrange for rr to initially be non-positive,
3216 because that simplifies the test to see
3217 if it is within the needed bounds. */
3220 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3221 SCM_I_BIG_MPZ (x
), yy
);
3222 scm_remember_upto_here_1 (x
);
3225 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3226 SCM_I_BIG_MPZ (q
), 1);
3232 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3233 SCM_I_BIG_MPZ (x
), -yy
);
3234 scm_remember_upto_here_1 (x
);
3235 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3238 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3239 SCM_I_BIG_MPZ (q
), 1);
3243 *qp
= scm_i_normbig (q
);
3244 *rp
= SCM_I_MAKINUM (rr
);
3248 else if (SCM_BIGP (y
))
3249 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3250 else if (SCM_REALP (y
))
3251 return scm_i_inexact_centered_divide
3252 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3253 else if (SCM_FRACTIONP (y
))
3254 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3256 return two_valued_wta_dispatch_2
3257 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3258 s_scm_centered_divide
, qp
, rp
);
3260 else if (SCM_REALP (x
))
3262 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3263 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3264 return scm_i_inexact_centered_divide
3265 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3267 return two_valued_wta_dispatch_2
3268 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3269 s_scm_centered_divide
, qp
, rp
);
3271 else if (SCM_FRACTIONP (x
))
3274 return scm_i_inexact_centered_divide
3275 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3276 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3277 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3279 return two_valued_wta_dispatch_2
3280 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3281 s_scm_centered_divide
, qp
, rp
);
3284 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3285 s_scm_centered_divide
, qp
, rp
);
3289 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3293 if (SCM_LIKELY (y
> 0))
3294 q
= floor (x
/y
+ 0.5);
3295 else if (SCM_LIKELY (y
< 0))
3296 q
= ceil (x
/y
- 0.5);
3298 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3302 *qp
= scm_from_double (q
);
3303 *rp
= scm_from_double (r
);
3306 /* Assumes that both x and y are bigints, though
3307 x might be able to fit into a fixnum. */
3309 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3313 /* Note that x might be small enough to fit into a
3314 fixnum, so we must not let it escape into the wild */
3318 /* min_r will eventually become -abs(y/2) */
3319 min_r
= scm_i_mkbig ();
3320 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3321 SCM_I_BIG_MPZ (y
), 1);
3323 /* Arrange for rr to initially be non-positive,
3324 because that simplifies the test to see
3325 if it is within the needed bounds. */
3326 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3328 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3329 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3330 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3331 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3333 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3334 SCM_I_BIG_MPZ (q
), 1);
3335 mpz_add (SCM_I_BIG_MPZ (r
),
3342 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3343 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3344 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3346 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3347 SCM_I_BIG_MPZ (q
), 1);
3348 mpz_sub (SCM_I_BIG_MPZ (r
),
3353 scm_remember_upto_here_2 (x
, y
);
3354 *qp
= scm_i_normbig (q
);
3355 *rp
= scm_i_normbig (r
);
3359 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3362 SCM xd
= scm_denominator (x
);
3363 SCM yd
= scm_denominator (y
);
3365 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3366 scm_product (scm_numerator (y
), xd
),
3368 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3371 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3372 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3373 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3375 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3377 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3378 "with ties going to the nearest even integer.\n"
3380 "(round-quotient 123 10) @result{} 12\n"
3381 "(round-quotient 123 -10) @result{} -12\n"
3382 "(round-quotient -123 10) @result{} -12\n"
3383 "(round-quotient -123 -10) @result{} 12\n"
3384 "(round-quotient 125 10) @result{} 12\n"
3385 "(round-quotient 127 10) @result{} 13\n"
3386 "(round-quotient 135 10) @result{} 14\n"
3387 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3388 "(round-quotient 16/3 -10/7) @result{} -4\n"
3390 #define FUNC_NAME s_scm_round_quotient
3392 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3394 scm_t_inum xx
= SCM_I_INUM (x
);
3395 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3397 scm_t_inum yy
= SCM_I_INUM (y
);
3398 if (SCM_UNLIKELY (yy
== 0))
3399 scm_num_overflow (s_scm_round_quotient
);
3402 scm_t_inum qq
= xx
/ yy
;
3403 scm_t_inum rr
= xx
% yy
;
3405 scm_t_inum r2
= 2 * rr
;
3407 if (SCM_LIKELY (yy
< 0))
3427 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3428 return SCM_I_MAKINUM (qq
);
3430 return scm_i_inum2big (qq
);
3433 else if (SCM_BIGP (y
))
3435 /* Pass a denormalized bignum version of x (even though it
3436 can fit in a fixnum) to scm_i_bigint_round_quotient */
3437 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3439 else if (SCM_REALP (y
))
3440 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3441 else if (SCM_FRACTIONP (y
))
3442 return scm_i_exact_rational_round_quotient (x
, y
);
3444 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3445 s_scm_round_quotient
);
3447 else if (SCM_BIGP (x
))
3449 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3451 scm_t_inum yy
= SCM_I_INUM (y
);
3452 if (SCM_UNLIKELY (yy
== 0))
3453 scm_num_overflow (s_scm_round_quotient
);
3454 else if (SCM_UNLIKELY (yy
== 1))
3458 SCM q
= scm_i_mkbig ();
3460 int needs_adjustment
;
3464 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3465 SCM_I_BIG_MPZ (x
), yy
);
3466 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3467 needs_adjustment
= (2*rr
>= yy
);
3469 needs_adjustment
= (2*rr
> yy
);
3473 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3474 SCM_I_BIG_MPZ (x
), -yy
);
3475 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3476 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3477 needs_adjustment
= (2*rr
<= yy
);
3479 needs_adjustment
= (2*rr
< yy
);
3481 scm_remember_upto_here_1 (x
);
3482 if (needs_adjustment
)
3483 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3484 return scm_i_normbig (q
);
3487 else if (SCM_BIGP (y
))
3488 return scm_i_bigint_round_quotient (x
, y
);
3489 else if (SCM_REALP (y
))
3490 return scm_i_inexact_round_quotient
3491 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3492 else if (SCM_FRACTIONP (y
))
3493 return scm_i_exact_rational_round_quotient (x
, y
);
3495 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3496 s_scm_round_quotient
);
3498 else if (SCM_REALP (x
))
3500 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3501 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3502 return scm_i_inexact_round_quotient
3503 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3505 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3506 s_scm_round_quotient
);
3508 else if (SCM_FRACTIONP (x
))
3511 return scm_i_inexact_round_quotient
3512 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3513 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3514 return scm_i_exact_rational_round_quotient (x
, y
);
3516 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3517 s_scm_round_quotient
);
3520 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3521 s_scm_round_quotient
);
3526 scm_i_inexact_round_quotient (double x
, double y
)
3528 if (SCM_UNLIKELY (y
== 0))
3529 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3531 return scm_from_double (scm_c_round (x
/ y
));
3534 /* Assumes that both x and y are bigints, though
3535 x might be able to fit into a fixnum. */
3537 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3540 int cmp
, needs_adjustment
;
3542 /* Note that x might be small enough to fit into a
3543 fixnum, so we must not let it escape into the wild */
3546 r2
= scm_i_mkbig ();
3548 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3549 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3550 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3551 scm_remember_upto_here_2 (x
, r
);
3553 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3554 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3555 needs_adjustment
= (cmp
>= 0);
3557 needs_adjustment
= (cmp
> 0);
3558 scm_remember_upto_here_2 (r2
, y
);
3560 if (needs_adjustment
)
3561 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3563 return scm_i_normbig (q
);
3567 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3569 return scm_round_quotient
3570 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3571 scm_product (scm_numerator (y
), scm_denominator (x
)));
3574 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3575 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3576 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3578 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3580 "Return the real number @var{r} such that\n"
3581 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3582 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3583 "nearest integer, with ties going to the nearest\n"
3586 "(round-remainder 123 10) @result{} 3\n"
3587 "(round-remainder 123 -10) @result{} 3\n"
3588 "(round-remainder -123 10) @result{} -3\n"
3589 "(round-remainder -123 -10) @result{} -3\n"
3590 "(round-remainder 125 10) @result{} 5\n"
3591 "(round-remainder 127 10) @result{} -3\n"
3592 "(round-remainder 135 10) @result{} -5\n"
3593 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3594 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3596 #define FUNC_NAME s_scm_round_remainder
3598 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3600 scm_t_inum xx
= SCM_I_INUM (x
);
3601 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3603 scm_t_inum yy
= SCM_I_INUM (y
);
3604 if (SCM_UNLIKELY (yy
== 0))
3605 scm_num_overflow (s_scm_round_remainder
);
3608 scm_t_inum qq
= xx
/ yy
;
3609 scm_t_inum rr
= xx
% yy
;
3611 scm_t_inum r2
= 2 * rr
;
3613 if (SCM_LIKELY (yy
< 0))
3633 return SCM_I_MAKINUM (rr
);
3636 else if (SCM_BIGP (y
))
3638 /* Pass a denormalized bignum version of x (even though it
3639 can fit in a fixnum) to scm_i_bigint_round_remainder */
3640 return scm_i_bigint_round_remainder
3641 (scm_i_long2big (xx
), y
);
3643 else if (SCM_REALP (y
))
3644 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3645 else if (SCM_FRACTIONP (y
))
3646 return scm_i_exact_rational_round_remainder (x
, y
);
3648 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3649 s_scm_round_remainder
);
3651 else if (SCM_BIGP (x
))
3653 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3655 scm_t_inum yy
= SCM_I_INUM (y
);
3656 if (SCM_UNLIKELY (yy
== 0))
3657 scm_num_overflow (s_scm_round_remainder
);
3660 SCM q
= scm_i_mkbig ();
3662 int needs_adjustment
;
3666 rr
= mpz_fdiv_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
);
3675 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3676 SCM_I_BIG_MPZ (x
), -yy
);
3677 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3678 needs_adjustment
= (2*rr
<= yy
);
3680 needs_adjustment
= (2*rr
< yy
);
3682 scm_remember_upto_here_2 (x
, q
);
3683 if (needs_adjustment
)
3685 return SCM_I_MAKINUM (rr
);
3688 else if (SCM_BIGP (y
))
3689 return scm_i_bigint_round_remainder (x
, y
);
3690 else if (SCM_REALP (y
))
3691 return scm_i_inexact_round_remainder
3692 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3693 else if (SCM_FRACTIONP (y
))
3694 return scm_i_exact_rational_round_remainder (x
, y
);
3696 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3697 s_scm_round_remainder
);
3699 else if (SCM_REALP (x
))
3701 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3702 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3703 return scm_i_inexact_round_remainder
3704 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3706 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3707 s_scm_round_remainder
);
3709 else if (SCM_FRACTIONP (x
))
3712 return scm_i_inexact_round_remainder
3713 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3714 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3715 return scm_i_exact_rational_round_remainder (x
, y
);
3717 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3718 s_scm_round_remainder
);
3721 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3722 s_scm_round_remainder
);
3727 scm_i_inexact_round_remainder (double x
, double y
)
3729 /* Although it would be more efficient to use fmod here, we can't
3730 because it would in some cases produce results inconsistent with
3731 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3732 close). In particular, when x-y/2 is very close to a multiple of
3733 y, then r might be either -abs(y/2) or abs(y/2), but those two
3734 cases must correspond to different choices of q. If quotient
3735 chooses one and remainder chooses the other, it would be bad. */
3737 if (SCM_UNLIKELY (y
== 0))
3738 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3741 double q
= scm_c_round (x
/ y
);
3742 return scm_from_double (x
- q
* y
);
3746 /* Assumes that both x and y are bigints, though
3747 x might be able to fit into a fixnum. */
3749 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3752 int cmp
, needs_adjustment
;
3754 /* Note that x might be small enough to fit into a
3755 fixnum, so we must not let it escape into the wild */
3758 r2
= scm_i_mkbig ();
3760 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3761 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3762 scm_remember_upto_here_1 (x
);
3763 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3765 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3766 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3767 needs_adjustment
= (cmp
>= 0);
3769 needs_adjustment
= (cmp
> 0);
3770 scm_remember_upto_here_2 (q
, r2
);
3772 if (needs_adjustment
)
3773 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3775 scm_remember_upto_here_1 (y
);
3776 return scm_i_normbig (r
);
3780 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3782 SCM xd
= scm_denominator (x
);
3783 SCM yd
= scm_denominator (y
);
3784 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3785 scm_product (scm_numerator (y
), xd
));
3786 return scm_divide (r1
, scm_product (xd
, yd
));
3790 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3791 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3792 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3794 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3796 "Return the integer @var{q} and the real number @var{r}\n"
3797 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3798 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3799 "nearest integer, with ties going to the nearest even integer.\n"
3801 "(round/ 123 10) @result{} 12 and 3\n"
3802 "(round/ 123 -10) @result{} -12 and 3\n"
3803 "(round/ -123 10) @result{} -12 and -3\n"
3804 "(round/ -123 -10) @result{} 12 and -3\n"
3805 "(round/ 125 10) @result{} 12 and 5\n"
3806 "(round/ 127 10) @result{} 13 and -3\n"
3807 "(round/ 135 10) @result{} 14 and -5\n"
3808 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3809 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3811 #define FUNC_NAME s_scm_i_round_divide
3815 scm_round_divide(x
, y
, &q
, &r
);
3816 return scm_values (scm_list_2 (q
, r
));
3820 #define s_scm_round_divide s_scm_i_round_divide
3821 #define g_scm_round_divide g_scm_i_round_divide
3824 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3826 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3828 scm_t_inum xx
= SCM_I_INUM (x
);
3829 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3831 scm_t_inum yy
= SCM_I_INUM (y
);
3832 if (SCM_UNLIKELY (yy
== 0))
3833 scm_num_overflow (s_scm_round_divide
);
3836 scm_t_inum qq
= xx
/ yy
;
3837 scm_t_inum rr
= xx
% yy
;
3839 scm_t_inum r2
= 2 * rr
;
3841 if (SCM_LIKELY (yy
< 0))
3861 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3862 *qp
= SCM_I_MAKINUM (qq
);
3864 *qp
= scm_i_inum2big (qq
);
3865 *rp
= SCM_I_MAKINUM (rr
);
3869 else if (SCM_BIGP (y
))
3871 /* Pass a denormalized bignum version of x (even though it
3872 can fit in a fixnum) to scm_i_bigint_round_divide */
3873 return scm_i_bigint_round_divide
3874 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3876 else if (SCM_REALP (y
))
3877 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3878 else if (SCM_FRACTIONP (y
))
3879 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3881 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3882 s_scm_round_divide
, qp
, rp
);
3884 else if (SCM_BIGP (x
))
3886 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3888 scm_t_inum yy
= SCM_I_INUM (y
);
3889 if (SCM_UNLIKELY (yy
== 0))
3890 scm_num_overflow (s_scm_round_divide
);
3893 SCM q
= scm_i_mkbig ();
3895 int needs_adjustment
;
3899 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3900 SCM_I_BIG_MPZ (x
), yy
);
3901 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3902 needs_adjustment
= (2*rr
>= yy
);
3904 needs_adjustment
= (2*rr
> yy
);
3908 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3909 SCM_I_BIG_MPZ (x
), -yy
);
3910 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3911 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3912 needs_adjustment
= (2*rr
<= yy
);
3914 needs_adjustment
= (2*rr
< yy
);
3916 scm_remember_upto_here_1 (x
);
3917 if (needs_adjustment
)
3919 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3922 *qp
= scm_i_normbig (q
);
3923 *rp
= SCM_I_MAKINUM (rr
);
3927 else if (SCM_BIGP (y
))
3928 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3929 else if (SCM_REALP (y
))
3930 return scm_i_inexact_round_divide
3931 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3932 else if (SCM_FRACTIONP (y
))
3933 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3935 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3936 s_scm_round_divide
, qp
, rp
);
3938 else if (SCM_REALP (x
))
3940 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3941 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3942 return scm_i_inexact_round_divide
3943 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3945 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3946 s_scm_round_divide
, qp
, rp
);
3948 else if (SCM_FRACTIONP (x
))
3951 return scm_i_inexact_round_divide
3952 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3953 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3954 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3956 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3957 s_scm_round_divide
, qp
, rp
);
3960 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3961 s_scm_round_divide
, qp
, rp
);
3965 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3967 if (SCM_UNLIKELY (y
== 0))
3968 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3971 double q
= scm_c_round (x
/ y
);
3972 double r
= x
- q
* y
;
3973 *qp
= scm_from_double (q
);
3974 *rp
= scm_from_double (r
);
3978 /* Assumes that both x and y are bigints, though
3979 x might be able to fit into a fixnum. */
3981 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3984 int cmp
, needs_adjustment
;
3986 /* Note that x might be small enough to fit into a
3987 fixnum, so we must not let it escape into the wild */
3990 r2
= scm_i_mkbig ();
3992 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3993 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3994 scm_remember_upto_here_1 (x
);
3995 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3997 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3998 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3999 needs_adjustment
= (cmp
>= 0);
4001 needs_adjustment
= (cmp
> 0);
4003 if (needs_adjustment
)
4005 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4006 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4009 scm_remember_upto_here_2 (r2
, y
);
4010 *qp
= scm_i_normbig (q
);
4011 *rp
= scm_i_normbig (r
);
4015 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4018 SCM xd
= scm_denominator (x
);
4019 SCM yd
= scm_denominator (y
);
4021 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4022 scm_product (scm_numerator (y
), xd
),
4024 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4028 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4029 (SCM x
, SCM y
, SCM rest
),
4030 "Return the greatest common divisor of all parameter values.\n"
4031 "If called without arguments, 0 is returned.")
4032 #define FUNC_NAME s_scm_i_gcd
4034 while (!scm_is_null (rest
))
4035 { x
= scm_gcd (x
, y
);
4037 rest
= scm_cdr (rest
);
4039 return scm_gcd (x
, y
);
4043 #define s_gcd s_scm_i_gcd
4044 #define g_gcd g_scm_i_gcd
4047 scm_gcd (SCM x
, SCM y
)
4049 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4050 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4052 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4054 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4056 scm_t_inum xx
= SCM_I_INUM (x
);
4057 scm_t_inum yy
= SCM_I_INUM (y
);
4058 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4059 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4061 if (SCM_UNLIKELY (xx
== 0))
4063 else if (SCM_UNLIKELY (yy
== 0))
4068 /* Determine a common factor 2^k */
4069 while (((u
| v
) & 1) == 0)
4075 /* Now, any factor 2^n can be eliminated */
4077 while ((u
& 1) == 0)
4080 while ((v
& 1) == 0)
4082 /* Both u and v are now odd. Subtract the smaller one
4083 from the larger one to produce an even number, remove
4084 more factors of two, and repeat. */
4090 while ((u
& 1) == 0)
4096 while ((v
& 1) == 0)
4102 return (SCM_POSFIXABLE (result
)
4103 ? SCM_I_MAKINUM (result
)
4104 : scm_i_inum2big (result
));
4106 else if (SCM_BIGP (y
))
4112 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4114 else if (SCM_BIGP (x
))
4116 if (SCM_I_INUMP (y
))
4121 yy
= SCM_I_INUM (y
);
4126 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4127 scm_remember_upto_here_1 (x
);
4128 return (SCM_POSFIXABLE (result
)
4129 ? SCM_I_MAKINUM (result
)
4130 : scm_from_unsigned_integer (result
));
4132 else if (SCM_BIGP (y
))
4134 SCM result
= scm_i_mkbig ();
4135 mpz_gcd (SCM_I_BIG_MPZ (result
),
4138 scm_remember_upto_here_2 (x
, y
);
4139 return scm_i_normbig (result
);
4142 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4145 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4148 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4149 (SCM x
, SCM y
, SCM rest
),
4150 "Return the least common multiple of the arguments.\n"
4151 "If called without arguments, 1 is returned.")
4152 #define FUNC_NAME s_scm_i_lcm
4154 while (!scm_is_null (rest
))
4155 { x
= scm_lcm (x
, y
);
4157 rest
= scm_cdr (rest
);
4159 return scm_lcm (x
, y
);
4163 #define s_lcm s_scm_i_lcm
4164 #define g_lcm g_scm_i_lcm
4167 scm_lcm (SCM n1
, SCM n2
)
4169 if (SCM_UNBNDP (n2
))
4171 if (SCM_UNBNDP (n1
))
4172 return SCM_I_MAKINUM (1L);
4173 n2
= SCM_I_MAKINUM (1L);
4176 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
4177 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4179 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
4180 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4182 if (SCM_I_INUMP (n1
))
4184 if (SCM_I_INUMP (n2
))
4186 SCM d
= scm_gcd (n1
, n2
);
4187 if (scm_is_eq (d
, SCM_INUM0
))
4190 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4194 /* inum n1, big n2 */
4197 SCM result
= scm_i_mkbig ();
4198 scm_t_inum nn1
= SCM_I_INUM (n1
);
4199 if (nn1
== 0) return SCM_INUM0
;
4200 if (nn1
< 0) nn1
= - nn1
;
4201 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4202 scm_remember_upto_here_1 (n2
);
4210 if (SCM_I_INUMP (n2
))
4217 SCM result
= scm_i_mkbig ();
4218 mpz_lcm(SCM_I_BIG_MPZ (result
),
4220 SCM_I_BIG_MPZ (n2
));
4221 scm_remember_upto_here_2(n1
, n2
);
4222 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4228 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4233 + + + x (map digit:logand X Y)
4234 + - + x (map digit:logand X (lognot (+ -1 Y)))
4235 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4236 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4241 + + + (map digit:logior X Y)
4242 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4243 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4244 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4249 + + + (map digit:logxor X Y)
4250 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4251 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4252 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4257 + + (any digit:logand X Y)
4258 + - (any digit:logand X (lognot (+ -1 Y)))
4259 - + (any digit:logand (lognot (+ -1 X)) Y)
4264 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4265 (SCM x
, SCM y
, SCM rest
),
4266 "Return the bitwise AND of the integer arguments.\n\n"
4268 "(logand) @result{} -1\n"
4269 "(logand 7) @result{} 7\n"
4270 "(logand #b111 #b011 #b001) @result{} 1\n"
4272 #define FUNC_NAME s_scm_i_logand
4274 while (!scm_is_null (rest
))
4275 { x
= scm_logand (x
, y
);
4277 rest
= scm_cdr (rest
);
4279 return scm_logand (x
, y
);
4283 #define s_scm_logand s_scm_i_logand
4285 SCM
scm_logand (SCM n1
, SCM n2
)
4286 #define FUNC_NAME s_scm_logand
4290 if (SCM_UNBNDP (n2
))
4292 if (SCM_UNBNDP (n1
))
4293 return SCM_I_MAKINUM (-1);
4294 else if (!SCM_NUMBERP (n1
))
4295 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4296 else if (SCM_NUMBERP (n1
))
4299 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4302 if (SCM_I_INUMP (n1
))
4304 nn1
= SCM_I_INUM (n1
);
4305 if (SCM_I_INUMP (n2
))
4307 scm_t_inum nn2
= SCM_I_INUM (n2
);
4308 return SCM_I_MAKINUM (nn1
& nn2
);
4310 else if SCM_BIGP (n2
)
4316 SCM result_z
= scm_i_mkbig ();
4318 mpz_init_set_si (nn1_z
, nn1
);
4319 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4320 scm_remember_upto_here_1 (n2
);
4322 return scm_i_normbig (result_z
);
4326 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4328 else if (SCM_BIGP (n1
))
4330 if (SCM_I_INUMP (n2
))
4333 nn1
= SCM_I_INUM (n1
);
4336 else if (SCM_BIGP (n2
))
4338 SCM result_z
= scm_i_mkbig ();
4339 mpz_and (SCM_I_BIG_MPZ (result_z
),
4341 SCM_I_BIG_MPZ (n2
));
4342 scm_remember_upto_here_2 (n1
, n2
);
4343 return scm_i_normbig (result_z
);
4346 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4349 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4354 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4355 (SCM x
, SCM y
, SCM rest
),
4356 "Return the bitwise OR of the integer arguments.\n\n"
4358 "(logior) @result{} 0\n"
4359 "(logior 7) @result{} 7\n"
4360 "(logior #b000 #b001 #b011) @result{} 3\n"
4362 #define FUNC_NAME s_scm_i_logior
4364 while (!scm_is_null (rest
))
4365 { x
= scm_logior (x
, y
);
4367 rest
= scm_cdr (rest
);
4369 return scm_logior (x
, y
);
4373 #define s_scm_logior s_scm_i_logior
4375 SCM
scm_logior (SCM n1
, SCM n2
)
4376 #define FUNC_NAME s_scm_logior
4380 if (SCM_UNBNDP (n2
))
4382 if (SCM_UNBNDP (n1
))
4384 else if (SCM_NUMBERP (n1
))
4387 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4390 if (SCM_I_INUMP (n1
))
4392 nn1
= SCM_I_INUM (n1
);
4393 if (SCM_I_INUMP (n2
))
4395 long nn2
= SCM_I_INUM (n2
);
4396 return SCM_I_MAKINUM (nn1
| nn2
);
4398 else if (SCM_BIGP (n2
))
4404 SCM result_z
= scm_i_mkbig ();
4406 mpz_init_set_si (nn1_z
, nn1
);
4407 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4408 scm_remember_upto_here_1 (n2
);
4410 return scm_i_normbig (result_z
);
4414 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4416 else if (SCM_BIGP (n1
))
4418 if (SCM_I_INUMP (n2
))
4421 nn1
= SCM_I_INUM (n1
);
4424 else if (SCM_BIGP (n2
))
4426 SCM result_z
= scm_i_mkbig ();
4427 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4429 SCM_I_BIG_MPZ (n2
));
4430 scm_remember_upto_here_2 (n1
, n2
);
4431 return scm_i_normbig (result_z
);
4434 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4437 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4442 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4443 (SCM x
, SCM y
, SCM rest
),
4444 "Return the bitwise XOR of the integer arguments. A bit is\n"
4445 "set in the result if it is set in an odd number of arguments.\n"
4447 "(logxor) @result{} 0\n"
4448 "(logxor 7) @result{} 7\n"
4449 "(logxor #b000 #b001 #b011) @result{} 2\n"
4450 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4452 #define FUNC_NAME s_scm_i_logxor
4454 while (!scm_is_null (rest
))
4455 { x
= scm_logxor (x
, y
);
4457 rest
= scm_cdr (rest
);
4459 return scm_logxor (x
, y
);
4463 #define s_scm_logxor s_scm_i_logxor
4465 SCM
scm_logxor (SCM n1
, SCM n2
)
4466 #define FUNC_NAME s_scm_logxor
4470 if (SCM_UNBNDP (n2
))
4472 if (SCM_UNBNDP (n1
))
4474 else if (SCM_NUMBERP (n1
))
4477 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4480 if (SCM_I_INUMP (n1
))
4482 nn1
= SCM_I_INUM (n1
);
4483 if (SCM_I_INUMP (n2
))
4485 scm_t_inum nn2
= SCM_I_INUM (n2
);
4486 return SCM_I_MAKINUM (nn1
^ nn2
);
4488 else if (SCM_BIGP (n2
))
4492 SCM result_z
= scm_i_mkbig ();
4494 mpz_init_set_si (nn1_z
, nn1
);
4495 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4496 scm_remember_upto_here_1 (n2
);
4498 return scm_i_normbig (result_z
);
4502 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4504 else if (SCM_BIGP (n1
))
4506 if (SCM_I_INUMP (n2
))
4509 nn1
= SCM_I_INUM (n1
);
4512 else if (SCM_BIGP (n2
))
4514 SCM result_z
= scm_i_mkbig ();
4515 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4517 SCM_I_BIG_MPZ (n2
));
4518 scm_remember_upto_here_2 (n1
, n2
);
4519 return scm_i_normbig (result_z
);
4522 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4525 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4530 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4532 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4533 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4534 "without actually calculating the @code{logand}, just testing\n"
4538 "(logtest #b0100 #b1011) @result{} #f\n"
4539 "(logtest #b0100 #b0111) @result{} #t\n"
4541 #define FUNC_NAME s_scm_logtest
4545 if (SCM_I_INUMP (j
))
4547 nj
= SCM_I_INUM (j
);
4548 if (SCM_I_INUMP (k
))
4550 scm_t_inum nk
= SCM_I_INUM (k
);
4551 return scm_from_bool (nj
& nk
);
4553 else if (SCM_BIGP (k
))
4561 mpz_init_set_si (nj_z
, nj
);
4562 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4563 scm_remember_upto_here_1 (k
);
4564 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4570 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4572 else if (SCM_BIGP (j
))
4574 if (SCM_I_INUMP (k
))
4577 nj
= SCM_I_INUM (j
);
4580 else if (SCM_BIGP (k
))
4584 mpz_init (result_z
);
4588 scm_remember_upto_here_2 (j
, k
);
4589 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4590 mpz_clear (result_z
);
4594 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4597 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4602 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4604 "Test whether bit number @var{index} in @var{j} is set.\n"
4605 "@var{index} starts from 0 for the least significant bit.\n"
4608 "(logbit? 0 #b1101) @result{} #t\n"
4609 "(logbit? 1 #b1101) @result{} #f\n"
4610 "(logbit? 2 #b1101) @result{} #t\n"
4611 "(logbit? 3 #b1101) @result{} #t\n"
4612 "(logbit? 4 #b1101) @result{} #f\n"
4614 #define FUNC_NAME s_scm_logbit_p
4616 unsigned long int iindex
;
4617 iindex
= scm_to_ulong (index
);
4619 if (SCM_I_INUMP (j
))
4621 /* bits above what's in an inum follow the sign bit */
4622 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4623 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4625 else if (SCM_BIGP (j
))
4627 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4628 scm_remember_upto_here_1 (j
);
4629 return scm_from_bool (val
);
4632 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4637 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4639 "Return the integer which is the ones-complement of the integer\n"
4643 "(number->string (lognot #b10000000) 2)\n"
4644 " @result{} \"-10000001\"\n"
4645 "(number->string (lognot #b0) 2)\n"
4646 " @result{} \"-1\"\n"
4648 #define FUNC_NAME s_scm_lognot
4650 if (SCM_I_INUMP (n
)) {
4651 /* No overflow here, just need to toggle all the bits making up the inum.
4652 Enhancement: No need to strip the tag and add it back, could just xor
4653 a block of 1 bits, if that worked with the various debug versions of
4655 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4657 } else if (SCM_BIGP (n
)) {
4658 SCM result
= scm_i_mkbig ();
4659 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4660 scm_remember_upto_here_1 (n
);
4664 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4669 /* returns 0 if IN is not an integer. OUT must already be
4672 coerce_to_big (SCM in
, mpz_t out
)
4675 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4676 else if (SCM_I_INUMP (in
))
4677 mpz_set_si (out
, SCM_I_INUM (in
));
4684 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4685 (SCM n
, SCM k
, SCM m
),
4686 "Return @var{n} raised to the integer exponent\n"
4687 "@var{k}, modulo @var{m}.\n"
4690 "(modulo-expt 2 3 5)\n"
4693 #define FUNC_NAME s_scm_modulo_expt
4699 /* There are two classes of error we might encounter --
4700 1) Math errors, which we'll report by calling scm_num_overflow,
4702 2) wrong-type errors, which of course we'll report by calling
4704 We don't report those errors immediately, however; instead we do
4705 some cleanup first. These variables tell us which error (if
4706 any) we should report after cleaning up.
4708 int report_overflow
= 0;
4710 int position_of_wrong_type
= 0;
4711 SCM value_of_wrong_type
= SCM_INUM0
;
4713 SCM result
= SCM_UNDEFINED
;
4719 if (scm_is_eq (m
, SCM_INUM0
))
4721 report_overflow
= 1;
4725 if (!coerce_to_big (n
, n_tmp
))
4727 value_of_wrong_type
= n
;
4728 position_of_wrong_type
= 1;
4732 if (!coerce_to_big (k
, k_tmp
))
4734 value_of_wrong_type
= k
;
4735 position_of_wrong_type
= 2;
4739 if (!coerce_to_big (m
, m_tmp
))
4741 value_of_wrong_type
= m
;
4742 position_of_wrong_type
= 3;
4746 /* if the exponent K is negative, and we simply call mpz_powm, we
4747 will get a divide-by-zero exception when an inverse 1/n mod m
4748 doesn't exist (or is not unique). Since exceptions are hard to
4749 handle, we'll attempt the inversion "by hand" -- that way, we get
4750 a simple failure code, which is easy to handle. */
4752 if (-1 == mpz_sgn (k_tmp
))
4754 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4756 report_overflow
= 1;
4759 mpz_neg (k_tmp
, k_tmp
);
4762 result
= scm_i_mkbig ();
4763 mpz_powm (SCM_I_BIG_MPZ (result
),
4768 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4769 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4776 if (report_overflow
)
4777 scm_num_overflow (FUNC_NAME
);
4779 if (position_of_wrong_type
)
4780 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4781 value_of_wrong_type
);
4783 return scm_i_normbig (result
);
4787 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4789 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4790 "exact integer, @var{n} can be any number.\n"
4792 "Negative @var{k} is supported, and results in\n"
4793 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4794 "@math{@var{n}^0} is 1, as usual, and that\n"
4795 "includes @math{0^0} is 1.\n"
4798 "(integer-expt 2 5) @result{} 32\n"
4799 "(integer-expt -3 3) @result{} -27\n"
4800 "(integer-expt 5 -3) @result{} 1/125\n"
4801 "(integer-expt 0 0) @result{} 1\n"
4803 #define FUNC_NAME s_scm_integer_expt
4806 SCM z_i2
= SCM_BOOL_F
;
4808 SCM acc
= SCM_I_MAKINUM (1L);
4810 /* Specifically refrain from checking the type of the first argument.
4811 This allows us to exponentiate any object that can be multiplied.
4812 If we must raise to a negative power, we must also be able to
4813 take its reciprocal. */
4814 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4815 SCM_WRONG_TYPE_ARG (2, k
);
4817 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4818 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4819 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4820 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4821 /* The next check is necessary only because R6RS specifies different
4822 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4823 we simply skip this case and move on. */
4824 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4826 /* k cannot be 0 at this point, because we
4827 have already checked for that case above */
4828 if (scm_is_true (scm_positive_p (k
)))
4830 else /* return NaN for (0 ^ k) for negative k per R6RS */
4833 else if (SCM_FRACTIONP (n
))
4835 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4836 needless reduction of intermediate products to lowest terms.
4837 If a and b have no common factors, then a^k and b^k have no
4838 common factors. Use 'scm_i_make_ratio_already_reduced' to
4839 construct the final result, so that no gcd computations are
4840 needed to exponentiate a fraction. */
4841 if (scm_is_true (scm_positive_p (k
)))
4842 return scm_i_make_ratio_already_reduced
4843 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4844 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4847 k
= scm_difference (k
, SCM_UNDEFINED
);
4848 return scm_i_make_ratio_already_reduced
4849 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4850 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4854 if (SCM_I_INUMP (k
))
4855 i2
= SCM_I_INUM (k
);
4856 else if (SCM_BIGP (k
))
4858 z_i2
= scm_i_clonebig (k
, 1);
4859 scm_remember_upto_here_1 (k
);
4863 SCM_WRONG_TYPE_ARG (2, k
);
4867 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4869 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4870 n
= scm_divide (n
, SCM_UNDEFINED
);
4874 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4878 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4880 return scm_product (acc
, n
);
4882 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4883 acc
= scm_product (acc
, n
);
4884 n
= scm_product (n
, n
);
4885 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4893 n
= scm_divide (n
, SCM_UNDEFINED
);
4900 return scm_product (acc
, n
);
4902 acc
= scm_product (acc
, n
);
4903 n
= scm_product (n
, n
);
4910 /* Efficiently compute (N * 2^COUNT),
4911 where N is an exact integer, and COUNT > 0. */
4913 left_shift_exact_integer (SCM n
, long count
)
4915 if (SCM_I_INUMP (n
))
4917 scm_t_inum nn
= SCM_I_INUM (n
);
4919 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4920 overflow a non-zero fixnum. For smaller shifts we check the
4921 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4922 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4923 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4927 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4928 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4930 return SCM_I_MAKINUM (nn
<< count
);
4933 SCM result
= scm_i_inum2big (nn
);
4934 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4939 else if (SCM_BIGP (n
))
4941 SCM result
= scm_i_mkbig ();
4942 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
4943 scm_remember_upto_here_1 (n
);
4947 scm_syserror ("left_shift_exact_integer");
4950 /* Efficiently compute floor (N / 2^COUNT),
4951 where N is an exact integer and COUNT > 0. */
4953 floor_right_shift_exact_integer (SCM n
, long count
)
4955 if (SCM_I_INUMP (n
))
4957 scm_t_inum nn
= SCM_I_INUM (n
);
4959 if (count
>= SCM_I_FIXNUM_BIT
)
4960 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
4962 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
4964 else if (SCM_BIGP (n
))
4966 SCM result
= scm_i_mkbig ();
4967 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4969 scm_remember_upto_here_1 (n
);
4970 return scm_i_normbig (result
);
4973 scm_syserror ("floor_right_shift_exact_integer");
4976 /* Efficiently compute round (N / 2^COUNT),
4977 where N is an exact integer and COUNT > 0. */
4979 round_right_shift_exact_integer (SCM n
, long count
)
4981 if (SCM_I_INUMP (n
))
4983 if (count
>= SCM_I_FIXNUM_BIT
)
4987 scm_t_inum nn
= SCM_I_INUM (n
);
4988 scm_t_inum qq
= SCM_SRS (nn
, count
);
4990 if (0 == (nn
& (1L << (count
-1))))
4991 return SCM_I_MAKINUM (qq
); /* round down */
4992 else if (nn
& ((1L << (count
-1)) - 1))
4993 return SCM_I_MAKINUM (qq
+ 1); /* round up */
4995 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
4998 else if (SCM_BIGP (n
))
5000 SCM q
= scm_i_mkbig ();
5002 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
5003 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
5004 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
5005 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
5006 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
5007 scm_remember_upto_here_1 (n
);
5008 return scm_i_normbig (q
);
5011 scm_syserror ("round_right_shift_exact_integer");
5014 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
5016 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5017 "@var{n} and @var{count} must be exact integers.\n"
5019 "With @var{n} viewed as an infinite-precision twos-complement\n"
5020 "integer, @code{ash} means a left shift introducing zero bits\n"
5021 "when @var{count} is positive, or a right shift dropping bits\n"
5022 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5025 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5026 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5028 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5029 "(ash -23 -2) @result{} -6\n"
5031 #define FUNC_NAME s_scm_ash
5033 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5035 long bits_to_shift
= scm_to_long (count
);
5037 if (bits_to_shift
> 0)
5038 return left_shift_exact_integer (n
, bits_to_shift
);
5039 else if (SCM_LIKELY (bits_to_shift
< 0))
5040 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
5045 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5049 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
5051 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5052 "@var{n} and @var{count} must be exact integers.\n"
5054 "With @var{n} viewed as an infinite-precision twos-complement\n"
5055 "integer, @code{round-ash} means a left shift introducing zero\n"
5056 "bits when @var{count} is positive, or a right shift rounding\n"
5057 "to the nearest integer (with ties going to the nearest even\n"
5058 "integer) when @var{count} is negative. This is a rounded\n"
5059 "``arithmetic'' shift.\n"
5062 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5063 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5064 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5065 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5066 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5067 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5069 #define FUNC_NAME s_scm_round_ash
5071 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
5073 long bits_to_shift
= scm_to_long (count
);
5075 if (bits_to_shift
> 0)
5076 return left_shift_exact_integer (n
, bits_to_shift
);
5077 else if (SCM_LIKELY (bits_to_shift
< 0))
5078 return round_right_shift_exact_integer (n
, -bits_to_shift
);
5083 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5088 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
5089 (SCM n
, SCM start
, SCM end
),
5090 "Return the integer composed of the @var{start} (inclusive)\n"
5091 "through @var{end} (exclusive) bits of @var{n}. The\n"
5092 "@var{start}th bit becomes the 0-th bit in the result.\n"
5095 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5096 " @result{} \"1010\"\n"
5097 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5098 " @result{} \"10110\"\n"
5100 #define FUNC_NAME s_scm_bit_extract
5102 unsigned long int istart
, iend
, bits
;
5103 istart
= scm_to_ulong (start
);
5104 iend
= scm_to_ulong (end
);
5105 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
5107 /* how many bits to keep */
5108 bits
= iend
- istart
;
5110 if (SCM_I_INUMP (n
))
5112 scm_t_inum in
= SCM_I_INUM (n
);
5114 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5115 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5116 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
5118 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
5120 /* Since we emulate two's complement encoded numbers, this
5121 * special case requires us to produce a result that has
5122 * more bits than can be stored in a fixnum.
5124 SCM result
= scm_i_inum2big (in
);
5125 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
5130 /* mask down to requisite bits */
5131 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
5132 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
5134 else if (SCM_BIGP (n
))
5139 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
5143 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5144 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5145 such bits into a ulong. */
5146 result
= scm_i_mkbig ();
5147 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5148 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5149 result
= scm_i_normbig (result
);
5151 scm_remember_upto_here_1 (n
);
5155 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5160 static const char scm_logtab
[] = {
5161 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5164 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5166 "Return the number of bits in integer @var{n}. If integer is\n"
5167 "positive, the 1-bits in its binary representation are counted.\n"
5168 "If negative, the 0-bits in its two's-complement binary\n"
5169 "representation are counted. If 0, 0 is returned.\n"
5172 "(logcount #b10101010)\n"
5179 #define FUNC_NAME s_scm_logcount
5181 if (SCM_I_INUMP (n
))
5183 unsigned long c
= 0;
5184 scm_t_inum nn
= SCM_I_INUM (n
);
5189 c
+= scm_logtab
[15 & nn
];
5192 return SCM_I_MAKINUM (c
);
5194 else if (SCM_BIGP (n
))
5196 unsigned long count
;
5197 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5198 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5200 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5201 scm_remember_upto_here_1 (n
);
5202 return SCM_I_MAKINUM (count
);
5205 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5210 static const char scm_ilentab
[] = {
5211 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5215 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5217 "Return the number of bits necessary to represent @var{n}.\n"
5220 "(integer-length #b10101010)\n"
5222 "(integer-length 0)\n"
5224 "(integer-length #b1111)\n"
5227 #define FUNC_NAME s_scm_integer_length
5229 if (SCM_I_INUMP (n
))
5231 unsigned long c
= 0;
5233 scm_t_inum nn
= SCM_I_INUM (n
);
5239 l
= scm_ilentab
[15 & nn
];
5242 return SCM_I_MAKINUM (c
- 4 + l
);
5244 else if (SCM_BIGP (n
))
5246 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5247 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5248 1 too big, so check for that and adjust. */
5249 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5250 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5251 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5252 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5254 scm_remember_upto_here_1 (n
);
5255 return SCM_I_MAKINUM (size
);
5258 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5262 /*** NUMBERS -> STRINGS ***/
5263 #define SCM_MAX_DBL_RADIX 36
5265 /* use this array as a way to generate a single digit */
5266 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5268 static mpz_t dbl_minimum_normal_mantissa
;
5271 idbl2str (double dbl
, char *a
, int radix
)
5275 if (radix
< 2 || radix
> SCM_MAX_DBL_RADIX
)
5276 /* revert to existing behavior */
5281 strcpy (a
, (dbl
> 0.0) ? "+inf.0" : "-inf.0");
5291 else if (dbl
== 0.0)
5293 if (!double_is_non_negative_zero (dbl
))
5295 strcpy (a
+ ch
, "0.0");
5298 else if (isnan (dbl
))
5300 strcpy (a
, "+nan.0");
5304 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5305 Accurately" by Robert G. Burger and R. Kent Dybvig */
5308 mpz_t f
, r
, s
, mplus
, mminus
, hi
, digit
;
5309 int f_is_even
, f_is_odd
;
5313 mpz_inits (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5314 mpz_set_d (f
, ldexp (frexp (dbl
, &e
), DBL_MANT_DIG
));
5315 if (e
< DBL_MIN_EXP
)
5317 mpz_tdiv_q_2exp (f
, f
, DBL_MIN_EXP
- e
);
5322 f_is_even
= !mpz_odd_p (f
);
5323 f_is_odd
= !f_is_even
;
5325 /* Initialize r, s, mplus, and mminus according
5326 to Table 1 from the paper. */
5329 mpz_set_ui (mminus
, 1);
5330 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0
5331 || e
== DBL_MIN_EXP
- DBL_MANT_DIG
)
5333 mpz_set_ui (mplus
, 1);
5334 mpz_mul_2exp (r
, f
, 1);
5335 mpz_mul_2exp (s
, mminus
, 1 - e
);
5339 mpz_set_ui (mplus
, 2);
5340 mpz_mul_2exp (r
, f
, 2);
5341 mpz_mul_2exp (s
, mminus
, 2 - e
);
5346 mpz_set_ui (mminus
, 1);
5347 mpz_mul_2exp (mminus
, mminus
, e
);
5348 if (mpz_cmp (f
, dbl_minimum_normal_mantissa
) != 0)
5350 mpz_set (mplus
, mminus
);
5351 mpz_mul_2exp (r
, f
, 1 + e
);
5356 mpz_mul_2exp (mplus
, mminus
, 1);
5357 mpz_mul_2exp (r
, f
, 2 + e
);
5362 /* Find the smallest k such that:
5363 (r + mplus) / s < radix^k (if f is even)
5364 (r + mplus) / s <= radix^k (if f is odd) */
5366 /* IMPROVE-ME: Make an initial guess to speed this up */
5367 mpz_add (hi
, r
, mplus
);
5369 while (mpz_cmp (hi
, s
) >= f_is_odd
)
5371 mpz_mul_ui (s
, s
, radix
);
5376 mpz_mul_ui (hi
, hi
, radix
);
5377 while (mpz_cmp (hi
, s
) < f_is_odd
)
5379 mpz_mul_ui (r
, r
, radix
);
5380 mpz_mul_ui (mplus
, mplus
, radix
);
5381 mpz_mul_ui (mminus
, mminus
, radix
);
5382 mpz_mul_ui (hi
, hi
, radix
);
5393 /* Use scientific notation */
5401 /* Print leading zeroes */
5404 for (i
= 0; i
> k
; i
--)
5411 int end_1_p
, end_2_p
;
5414 mpz_mul_ui (mplus
, mplus
, radix
);
5415 mpz_mul_ui (mminus
, mminus
, radix
);
5416 mpz_mul_ui (r
, r
, radix
);
5417 mpz_fdiv_qr (digit
, r
, r
, s
);
5418 d
= mpz_get_ui (digit
);
5420 mpz_add (hi
, r
, mplus
);
5421 end_1_p
= (mpz_cmp (r
, mminus
) < f_is_even
);
5422 end_2_p
= (mpz_cmp (s
, hi
) < f_is_even
);
5423 if (end_1_p
|| end_2_p
)
5425 mpz_mul_2exp (r
, r
, 1);
5430 else if (mpz_cmp (r
, s
) >= !(d
& 1))
5432 a
[ch
++] = number_chars
[d
];
5439 a
[ch
++] = number_chars
[d
];
5447 if (expon
>= 7 && k
>= 4 && expon
>= k
)
5449 /* Here we would have to print more than three zeroes
5450 followed by a decimal point and another zero. It
5451 makes more sense to use scientific notation. */
5453 /* Adjust k to what it would have been if we had chosen
5454 scientific notation from the beginning. */
5457 /* k will now be <= 0, with magnitude equal to the number of
5458 digits that we printed which should now be put after the
5461 /* Insert a decimal point */
5462 memmove (a
+ ch
+ k
+ 1, a
+ ch
+ k
, -k
);
5482 ch
+= scm_iint2str (expon
, radix
, a
+ ch
);
5485 mpz_clears (f
, r
, s
, mplus
, mminus
, hi
, digit
, NULL
);
5492 icmplx2str (double real
, double imag
, char *str
, int radix
)
5497 i
= idbl2str (real
, str
, radix
);
5498 #ifdef HAVE_COPYSIGN
5499 sgn
= copysign (1.0, imag
);
5503 /* Don't output a '+' for negative numbers or for Inf and
5504 NaN. They will provide their own sign. */
5505 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5507 i
+= idbl2str (imag
, &str
[i
], radix
);
5513 iflo2str (SCM flt
, char *str
, int radix
)
5516 if (SCM_REALP (flt
))
5517 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5519 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5524 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5525 characters in the result.
5527 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5529 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5534 return scm_iuint2str (-num
, rad
, p
) + 1;
5537 return scm_iuint2str (num
, rad
, p
);
5540 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5541 characters in the result.
5543 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5545 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5549 scm_t_uintmax n
= num
;
5551 if (rad
< 2 || rad
> 36)
5552 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5554 for (n
/= rad
; n
> 0; n
/= rad
)
5564 p
[i
] = number_chars
[d
];
5569 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5571 "Return a string holding the external representation of the\n"
5572 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5573 "inexact, a radix of 10 will be used.")
5574 #define FUNC_NAME s_scm_number_to_string
5578 if (SCM_UNBNDP (radix
))
5581 base
= scm_to_signed_integer (radix
, 2, 36);
5583 if (SCM_I_INUMP (n
))
5585 char num_buf
[SCM_INTBUFLEN
];
5586 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5587 return scm_from_locale_stringn (num_buf
, length
);
5589 else if (SCM_BIGP (n
))
5591 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5592 size_t len
= strlen (str
);
5593 void (*freefunc
) (void *, size_t);
5595 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5596 scm_remember_upto_here_1 (n
);
5597 ret
= scm_from_latin1_stringn (str
, len
);
5598 freefunc (str
, len
+ 1);
5601 else if (SCM_FRACTIONP (n
))
5603 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5604 scm_from_locale_string ("/"),
5605 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5607 else if (SCM_INEXACTP (n
))
5609 char num_buf
[FLOBUFLEN
];
5610 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5613 SCM_WRONG_TYPE_ARG (1, n
);
5618 /* These print routines used to be stubbed here so that scm_repl.c
5619 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5622 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5624 char num_buf
[FLOBUFLEN
];
5625 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5630 scm_i_print_double (double val
, SCM port
)
5632 char num_buf
[FLOBUFLEN
];
5633 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5637 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5640 char num_buf
[FLOBUFLEN
];
5641 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5646 scm_i_print_complex (double real
, double imag
, SCM port
)
5648 char num_buf
[FLOBUFLEN
];
5649 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5653 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5656 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5657 scm_display (str
, port
);
5658 scm_remember_upto_here_1 (str
);
5663 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5665 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5666 size_t len
= strlen (str
);
5667 void (*freefunc
) (void *, size_t);
5668 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5669 scm_remember_upto_here_1 (exp
);
5670 scm_lfwrite_unlocked (str
, len
, port
);
5671 freefunc (str
, len
+ 1);
5674 /*** END nums->strs ***/
5677 /*** STRINGS -> NUMBERS ***/
5679 /* The following functions implement the conversion from strings to numbers.
5680 * The implementation somehow follows the grammar for numbers as it is given
5681 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5682 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5683 * points should be noted about the implementation:
5685 * * Each function keeps a local index variable 'idx' that points at the
5686 * current position within the parsed string. The global index is only
5687 * updated if the function could parse the corresponding syntactic unit
5690 * * Similarly, the functions keep track of indicators of inexactness ('#',
5691 * '.' or exponents) using local variables ('hash_seen', 'x').
5693 * * Sequences of digits are parsed into temporary variables holding fixnums.
5694 * Only if these fixnums would overflow, the result variables are updated
5695 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5696 * the temporary variables holding the fixnums are cleared, and the process
5697 * starts over again. If for example fixnums were able to store five decimal
5698 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5699 * and the result was computed as 12345 * 100000 + 67890. In other words,
5700 * only every five digits two bignum operations were performed.
5702 * Notes on the handling of exactness specifiers:
5704 * When parsing non-real complex numbers, we apply exactness specifiers on
5705 * per-component basis, as is done in PLT Scheme. For complex numbers
5706 * written in rectangular form, exactness specifiers are applied to the
5707 * real and imaginary parts before calling scm_make_rectangular. For
5708 * complex numbers written in polar form, exactness specifiers are applied
5709 * to the magnitude and angle before calling scm_make_polar.
5711 * There are two kinds of exactness specifiers: forced and implicit. A
5712 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5713 * the entire number, and applies to both components of a complex number.
5714 * "#e" causes each component to be made exact, and "#i" causes each
5715 * component to be made inexact. If no forced exactness specifier is
5716 * present, then the exactness of each component is determined
5717 * independently by the presence or absence of a decimal point or hash mark
5718 * within that component. If a decimal point or hash mark is present, the
5719 * component is made inexact, otherwise it is made exact.
5721 * After the exactness specifiers have been applied to each component, they
5722 * are passed to either scm_make_rectangular or scm_make_polar to produce
5723 * the final result. Note that this will result in a real number if the
5724 * imaginary part, magnitude, or angle is an exact 0.
5726 * For example, (string->number "#i5.0+0i") does the equivalent of:
5728 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5731 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5733 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5735 /* Caller is responsible for checking that the return value is in range
5736 for the given radix, which should be <= 36. */
5738 char_decimal_value (scm_t_uint32 c
)
5740 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5741 that's certainly above any valid decimal, so we take advantage of
5742 that to elide some tests. */
5743 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5745 /* If that failed, try extended hexadecimals, then. Only accept ascii
5750 if (c
>= (scm_t_uint32
) 'a')
5751 d
= c
- (scm_t_uint32
)'a' + 10U;
5756 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5757 in base RADIX. Upon success, return the unsigned integer and update
5758 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5760 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5761 unsigned int radix
, enum t_exactness
*p_exactness
)
5763 unsigned int idx
= *p_idx
;
5764 unsigned int hash_seen
= 0;
5765 scm_t_bits shift
= 1;
5767 unsigned int digit_value
;
5770 size_t len
= scm_i_string_length (mem
);
5775 c
= scm_i_string_ref (mem
, idx
);
5776 digit_value
= char_decimal_value (c
);
5777 if (digit_value
>= radix
)
5781 result
= SCM_I_MAKINUM (digit_value
);
5784 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5794 digit_value
= char_decimal_value (c
);
5795 /* This check catches non-decimals in addition to out-of-range
5797 if (digit_value
>= radix
)
5802 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5804 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5806 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5813 shift
= shift
* radix
;
5814 add
= add
* radix
+ digit_value
;
5819 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5821 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5825 *p_exactness
= INEXACT
;
5831 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5832 * covers the parts of the rules that start at a potential point. The value
5833 * of the digits up to the point have been parsed by the caller and are given
5834 * in variable result. The content of *p_exactness indicates, whether a hash
5835 * has already been seen in the digits before the point.
5838 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5841 mem2decimal_from_point (SCM result
, SCM mem
,
5842 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5844 unsigned int idx
= *p_idx
;
5845 enum t_exactness x
= *p_exactness
;
5846 size_t len
= scm_i_string_length (mem
);
5851 if (scm_i_string_ref (mem
, idx
) == '.')
5853 scm_t_bits shift
= 1;
5855 unsigned int digit_value
;
5856 SCM big_shift
= SCM_INUM1
;
5861 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5862 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5867 digit_value
= DIGIT2UINT (c
);
5878 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5880 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5881 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5883 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5891 add
= add
* 10 + digit_value
;
5897 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5898 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5899 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5902 result
= scm_divide (result
, big_shift
);
5904 /* We've seen a decimal point, thus the value is implicitly inexact. */
5916 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5918 switch (scm_i_string_ref (mem
, idx
))
5930 c
= scm_i_string_ref (mem
, idx
);
5938 c
= scm_i_string_ref (mem
, idx
);
5947 c
= scm_i_string_ref (mem
, idx
);
5952 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5956 exponent
= DIGIT2UINT (c
);
5959 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5960 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5963 if (exponent
<= SCM_MAXEXP
)
5964 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5970 if (exponent
> ((sign
== 1) ? SCM_MAXEXP
: SCM_MAXEXP
+ DBL_DIG
+ 1))
5972 size_t exp_len
= idx
- start
;
5973 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5974 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5975 scm_out_of_range ("string->number", exp_num
);
5978 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5980 result
= scm_product (result
, e
);
5982 result
= scm_divide (result
, e
);
5984 /* We've seen an exponent, thus the value is implicitly inexact. */
6002 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6005 mem2ureal (SCM mem
, unsigned int *p_idx
,
6006 unsigned int radix
, enum t_exactness forced_x
,
6007 int allow_inf_or_nan
)
6009 unsigned int idx
= *p_idx
;
6011 size_t len
= scm_i_string_length (mem
);
6013 /* Start off believing that the number will be exact. This changes
6014 to INEXACT if we see a decimal point or a hash. */
6015 enum t_exactness implicit_x
= EXACT
;
6020 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
6021 switch (scm_i_string_ref (mem
, idx
))
6024 switch (scm_i_string_ref (mem
, idx
+ 1))
6027 switch (scm_i_string_ref (mem
, idx
+ 2))
6030 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
6031 && scm_i_string_ref (mem
, idx
+ 4) == '0')
6039 switch (scm_i_string_ref (mem
, idx
+ 1))
6042 switch (scm_i_string_ref (mem
, idx
+ 2))
6045 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
6047 /* Cobble up the fractional part. We might want to
6048 set the NaN's mantissa from it. */
6050 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
6053 #if SCM_ENABLE_DEPRECATED == 1
6054 scm_c_issue_deprecation_warning
6055 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6068 if (scm_i_string_ref (mem
, idx
) == '.')
6072 else if (idx
+ 1 == len
)
6074 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
6077 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
6078 p_idx
, &implicit_x
);
6084 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6085 if (scm_is_false (uinteger
))
6090 else if (scm_i_string_ref (mem
, idx
) == '/')
6098 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
6099 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
6102 /* both are int/big here, I assume */
6103 result
= scm_i_make_ratio (uinteger
, divisor
);
6105 else if (radix
== 10)
6107 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
6108 if (scm_is_false (result
))
6120 if (SCM_INEXACTP (result
))
6121 return scm_inexact_to_exact (result
);
6125 if (SCM_INEXACTP (result
))
6128 return scm_exact_to_inexact (result
);
6130 if (implicit_x
== INEXACT
)
6132 if (SCM_INEXACTP (result
))
6135 return scm_exact_to_inexact (result
);
6141 /* We should never get here */
6142 scm_syserror ("mem2ureal");
6146 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6149 mem2complex (SCM mem
, unsigned int idx
,
6150 unsigned int radix
, enum t_exactness forced_x
)
6155 size_t len
= scm_i_string_length (mem
);
6160 c
= scm_i_string_ref (mem
, idx
);
6175 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6176 if (scm_is_false (ureal
))
6178 /* input must be either +i or -i */
6183 if (scm_i_string_ref (mem
, idx
) == 'i'
6184 || scm_i_string_ref (mem
, idx
) == 'I')
6190 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6197 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6198 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6203 c
= scm_i_string_ref (mem
, idx
);
6207 /* either +<ureal>i or -<ureal>i */
6214 return scm_make_rectangular (SCM_INUM0
, ureal
);
6217 /* polar input: <real>@<real>. */
6228 c
= scm_i_string_ref (mem
, idx
);
6246 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6247 if (scm_is_false (angle
))
6252 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6253 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6255 result
= scm_make_polar (ureal
, angle
);
6260 /* expecting input matching <real>[+-]<ureal>?i */
6267 int sign
= (c
== '+') ? 1 : -1;
6268 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6270 if (scm_is_false (imag
))
6271 imag
= SCM_I_MAKINUM (sign
);
6272 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6273 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6277 if (scm_i_string_ref (mem
, idx
) != 'i'
6278 && scm_i_string_ref (mem
, idx
) != 'I')
6285 return scm_make_rectangular (ureal
, imag
);
6294 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6296 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6299 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6301 unsigned int idx
= 0;
6302 unsigned int radix
= NO_RADIX
;
6303 enum t_exactness forced_x
= NO_EXACTNESS
;
6304 size_t len
= scm_i_string_length (mem
);
6306 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6307 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6309 switch (scm_i_string_ref (mem
, idx
+ 1))
6312 if (radix
!= NO_RADIX
)
6317 if (radix
!= NO_RADIX
)
6322 if (forced_x
!= NO_EXACTNESS
)
6327 if (forced_x
!= NO_EXACTNESS
)
6332 if (radix
!= NO_RADIX
)
6337 if (radix
!= NO_RADIX
)
6347 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6348 if (radix
== NO_RADIX
)
6349 radix
= default_radix
;
6351 return mem2complex (mem
, idx
, radix
, forced_x
);
6355 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6356 unsigned int default_radix
)
6358 SCM str
= scm_from_locale_stringn (mem
, len
);
6360 return scm_i_string_to_number (str
, default_radix
);
6364 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6365 (SCM string
, SCM radix
),
6366 "Return a number of the maximally precise representation\n"
6367 "expressed by the given @var{string}. @var{radix} must be an\n"
6368 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6369 "is a default radix that may be overridden by an explicit radix\n"
6370 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6371 "supplied, then the default radix is 10. If string is not a\n"
6372 "syntactically valid notation for a number, then\n"
6373 "@code{string->number} returns @code{#f}.")
6374 #define FUNC_NAME s_scm_string_to_number
6378 SCM_VALIDATE_STRING (1, string
);
6380 if (SCM_UNBNDP (radix
))
6383 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6385 answer
= scm_i_string_to_number (string
, base
);
6386 scm_remember_upto_here_1 (string
);
6392 /*** END strs->nums ***/
6395 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6397 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6399 #define FUNC_NAME s_scm_number_p
6401 return scm_from_bool (SCM_NUMBERP (x
));
6405 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6407 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6408 "otherwise. Note that the sets of real, rational and integer\n"
6409 "values form subsets of the set of complex numbers, i. e. the\n"
6410 "predicate will also be fulfilled if @var{x} is a real,\n"
6411 "rational or integer number.")
6412 #define FUNC_NAME s_scm_complex_p
6414 /* all numbers are complex. */
6415 return scm_number_p (x
);
6419 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6421 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6422 "otherwise. Note that the set of integer values forms a subset of\n"
6423 "the set of real numbers, i. e. the predicate will also be\n"
6424 "fulfilled if @var{x} is an integer number.")
6425 #define FUNC_NAME s_scm_real_p
6427 return scm_from_bool
6428 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6432 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6434 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6435 "otherwise. Note that the set of integer values forms a subset of\n"
6436 "the set of rational numbers, i. e. the predicate will also be\n"
6437 "fulfilled if @var{x} is an integer number.")
6438 #define FUNC_NAME s_scm_rational_p
6440 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6442 else if (SCM_REALP (x
))
6443 /* due to their limited precision, finite floating point numbers are
6444 rational as well. (finite means neither infinity nor a NaN) */
6445 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6451 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6453 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6455 #define FUNC_NAME s_scm_integer_p
6457 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6459 else if (SCM_REALP (x
))
6461 double val
= SCM_REAL_VALUE (x
);
6462 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6470 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6471 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6472 (SCM x
, SCM y
, SCM rest
),
6473 "Return @code{#t} if all parameters are numerically equal.")
6474 #define FUNC_NAME s_scm_i_num_eq_p
6476 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6478 while (!scm_is_null (rest
))
6480 if (scm_is_false (scm_num_eq_p (x
, y
)))
6484 rest
= scm_cdr (rest
);
6486 return scm_num_eq_p (x
, y
);
6490 scm_num_eq_p (SCM x
, SCM y
)
6493 if (SCM_I_INUMP (x
))
6495 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6496 if (SCM_I_INUMP (y
))
6498 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6499 return scm_from_bool (xx
== yy
);
6501 else if (SCM_BIGP (y
))
6503 else if (SCM_REALP (y
))
6505 /* On a 32-bit system an inum fits a double, we can cast the inum
6506 to a double and compare.
6508 But on a 64-bit system an inum is bigger than a double and
6509 casting it to a double (call that dxx) will round. dxx is at
6510 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6511 an integer and fits a long. So we cast yy to a long and
6512 compare with plain xx.
6514 An alternative (for any size system actually) would be to check
6515 yy is an integer (with floor) and is in range of an inum
6516 (compare against appropriate powers of 2) then test
6517 xx==(scm_t_signed_bits)yy. It's just a matter of which
6518 casts/comparisons might be fastest or easiest for the cpu. */
6520 double yy
= SCM_REAL_VALUE (y
);
6521 return scm_from_bool ((double) xx
== yy
6522 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6523 || xx
== (scm_t_signed_bits
) yy
));
6525 else if (SCM_COMPLEXP (y
))
6526 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6527 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6528 else if (SCM_FRACTIONP (y
))
6531 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6534 else if (SCM_BIGP (x
))
6536 if (SCM_I_INUMP (y
))
6538 else if (SCM_BIGP (y
))
6540 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6541 scm_remember_upto_here_2 (x
, y
);
6542 return scm_from_bool (0 == cmp
);
6544 else if (SCM_REALP (y
))
6547 if (isnan (SCM_REAL_VALUE (y
)))
6549 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6550 scm_remember_upto_here_1 (x
);
6551 return scm_from_bool (0 == cmp
);
6553 else if (SCM_COMPLEXP (y
))
6556 if (0.0 != SCM_COMPLEX_IMAG (y
))
6558 if (isnan (SCM_COMPLEX_REAL (y
)))
6560 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6561 scm_remember_upto_here_1 (x
);
6562 return scm_from_bool (0 == cmp
);
6564 else if (SCM_FRACTIONP (y
))
6567 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6570 else if (SCM_REALP (x
))
6572 double xx
= SCM_REAL_VALUE (x
);
6573 if (SCM_I_INUMP (y
))
6575 /* see comments with inum/real above */
6576 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6577 return scm_from_bool (xx
== (double) yy
6578 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6579 || (scm_t_signed_bits
) xx
== yy
));
6581 else if (SCM_BIGP (y
))
6584 if (isnan (SCM_REAL_VALUE (x
)))
6586 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6587 scm_remember_upto_here_1 (y
);
6588 return scm_from_bool (0 == cmp
);
6590 else if (SCM_REALP (y
))
6591 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6592 else if (SCM_COMPLEXP (y
))
6593 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6594 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6595 else if (SCM_FRACTIONP (y
))
6597 double xx
= SCM_REAL_VALUE (x
);
6601 return scm_from_bool (xx
< 0.0);
6602 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6606 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6609 else if (SCM_COMPLEXP (x
))
6611 if (SCM_I_INUMP (y
))
6612 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6613 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6614 else if (SCM_BIGP (y
))
6617 if (0.0 != SCM_COMPLEX_IMAG (x
))
6619 if (isnan (SCM_COMPLEX_REAL (x
)))
6621 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6622 scm_remember_upto_here_1 (y
);
6623 return scm_from_bool (0 == cmp
);
6625 else if (SCM_REALP (y
))
6626 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6627 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6628 else if (SCM_COMPLEXP (y
))
6629 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6630 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6631 else if (SCM_FRACTIONP (y
))
6634 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6636 xx
= SCM_COMPLEX_REAL (x
);
6640 return scm_from_bool (xx
< 0.0);
6641 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6645 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6648 else if (SCM_FRACTIONP (x
))
6650 if (SCM_I_INUMP (y
))
6652 else if (SCM_BIGP (y
))
6654 else if (SCM_REALP (y
))
6656 double yy
= SCM_REAL_VALUE (y
);
6660 return scm_from_bool (0.0 < yy
);
6661 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6664 else if (SCM_COMPLEXP (y
))
6667 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6669 yy
= SCM_COMPLEX_REAL (y
);
6673 return scm_from_bool (0.0 < yy
);
6674 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6677 else if (SCM_FRACTIONP (y
))
6678 return scm_i_fraction_equalp (x
, y
);
6680 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6684 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6689 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6690 done are good for inums, but for bignums an answer can almost always be
6691 had by just examining a few high bits of the operands, as done by GMP in
6692 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6693 of the float exponent to take into account. */
6695 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6696 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6697 (SCM x
, SCM y
, SCM rest
),
6698 "Return @code{#t} if the list of parameters is monotonically\n"
6700 #define FUNC_NAME s_scm_i_num_less_p
6702 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6704 while (!scm_is_null (rest
))
6706 if (scm_is_false (scm_less_p (x
, y
)))
6710 rest
= scm_cdr (rest
);
6712 return scm_less_p (x
, y
);
6716 scm_less_p (SCM x
, SCM y
)
6719 if (SCM_I_INUMP (x
))
6721 scm_t_inum xx
= SCM_I_INUM (x
);
6722 if (SCM_I_INUMP (y
))
6724 scm_t_inum yy
= SCM_I_INUM (y
);
6725 return scm_from_bool (xx
< yy
);
6727 else if (SCM_BIGP (y
))
6729 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6730 scm_remember_upto_here_1 (y
);
6731 return scm_from_bool (sgn
> 0);
6733 else if (SCM_REALP (y
))
6734 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6735 else if (SCM_FRACTIONP (y
))
6737 /* "x < a/b" becomes "x*b < a" */
6739 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6740 y
= SCM_FRACTION_NUMERATOR (y
);
6744 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6745 s_scm_i_num_less_p
);
6747 else if (SCM_BIGP (x
))
6749 if (SCM_I_INUMP (y
))
6751 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6752 scm_remember_upto_here_1 (x
);
6753 return scm_from_bool (sgn
< 0);
6755 else if (SCM_BIGP (y
))
6757 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6758 scm_remember_upto_here_2 (x
, y
);
6759 return scm_from_bool (cmp
< 0);
6761 else if (SCM_REALP (y
))
6764 if (isnan (SCM_REAL_VALUE (y
)))
6766 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6767 scm_remember_upto_here_1 (x
);
6768 return scm_from_bool (cmp
< 0);
6770 else if (SCM_FRACTIONP (y
))
6773 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6774 s_scm_i_num_less_p
);
6776 else if (SCM_REALP (x
))
6778 if (SCM_I_INUMP (y
))
6779 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6780 else if (SCM_BIGP (y
))
6783 if (isnan (SCM_REAL_VALUE (x
)))
6785 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6786 scm_remember_upto_here_1 (y
);
6787 return scm_from_bool (cmp
> 0);
6789 else if (SCM_REALP (y
))
6790 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6791 else if (SCM_FRACTIONP (y
))
6793 double xx
= SCM_REAL_VALUE (x
);
6797 return scm_from_bool (xx
< 0.0);
6798 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6802 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6803 s_scm_i_num_less_p
);
6805 else if (SCM_FRACTIONP (x
))
6807 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6809 /* "a/b < y" becomes "a < y*b" */
6810 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6811 x
= SCM_FRACTION_NUMERATOR (x
);
6814 else if (SCM_REALP (y
))
6816 double yy
= SCM_REAL_VALUE (y
);
6820 return scm_from_bool (0.0 < yy
);
6821 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6824 else if (SCM_FRACTIONP (y
))
6826 /* "a/b < c/d" becomes "a*d < c*b" */
6827 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6828 SCM_FRACTION_DENOMINATOR (y
));
6829 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6830 SCM_FRACTION_DENOMINATOR (x
));
6836 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6837 s_scm_i_num_less_p
);
6840 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6841 s_scm_i_num_less_p
);
6845 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6846 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6847 (SCM x
, SCM y
, SCM rest
),
6848 "Return @code{#t} if the list of parameters is monotonically\n"
6850 #define FUNC_NAME s_scm_i_num_gr_p
6852 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6854 while (!scm_is_null (rest
))
6856 if (scm_is_false (scm_gr_p (x
, y
)))
6860 rest
= scm_cdr (rest
);
6862 return scm_gr_p (x
, y
);
6865 #define FUNC_NAME s_scm_i_num_gr_p
6867 scm_gr_p (SCM x
, SCM y
)
6869 if (!SCM_NUMBERP (x
))
6870 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6871 else if (!SCM_NUMBERP (y
))
6872 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6874 return scm_less_p (y
, x
);
6879 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6880 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6881 (SCM x
, SCM y
, SCM rest
),
6882 "Return @code{#t} if the list of parameters is monotonically\n"
6884 #define FUNC_NAME s_scm_i_num_leq_p
6886 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6888 while (!scm_is_null (rest
))
6890 if (scm_is_false (scm_leq_p (x
, y
)))
6894 rest
= scm_cdr (rest
);
6896 return scm_leq_p (x
, y
);
6899 #define FUNC_NAME s_scm_i_num_leq_p
6901 scm_leq_p (SCM x
, SCM y
)
6903 if (!SCM_NUMBERP (x
))
6904 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6905 else if (!SCM_NUMBERP (y
))
6906 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6907 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6910 return scm_not (scm_less_p (y
, x
));
6915 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6916 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6917 (SCM x
, SCM y
, SCM rest
),
6918 "Return @code{#t} if the list of parameters is monotonically\n"
6920 #define FUNC_NAME s_scm_i_num_geq_p
6922 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6924 while (!scm_is_null (rest
))
6926 if (scm_is_false (scm_geq_p (x
, y
)))
6930 rest
= scm_cdr (rest
);
6932 return scm_geq_p (x
, y
);
6935 #define FUNC_NAME s_scm_i_num_geq_p
6937 scm_geq_p (SCM x
, SCM y
)
6939 if (!SCM_NUMBERP (x
))
6940 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6941 else if (!SCM_NUMBERP (y
))
6942 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6943 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6946 return scm_not (scm_less_p (x
, y
));
6951 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6953 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6955 #define FUNC_NAME s_scm_zero_p
6957 if (SCM_I_INUMP (z
))
6958 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6959 else if (SCM_BIGP (z
))
6961 else if (SCM_REALP (z
))
6962 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6963 else if (SCM_COMPLEXP (z
))
6964 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6965 && SCM_COMPLEX_IMAG (z
) == 0.0);
6966 else if (SCM_FRACTIONP (z
))
6969 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6974 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6976 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6978 #define FUNC_NAME s_scm_positive_p
6980 if (SCM_I_INUMP (x
))
6981 return scm_from_bool (SCM_I_INUM (x
) > 0);
6982 else if (SCM_BIGP (x
))
6984 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6985 scm_remember_upto_here_1 (x
);
6986 return scm_from_bool (sgn
> 0);
6988 else if (SCM_REALP (x
))
6989 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6990 else if (SCM_FRACTIONP (x
))
6991 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6993 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6998 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
7000 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7002 #define FUNC_NAME s_scm_negative_p
7004 if (SCM_I_INUMP (x
))
7005 return scm_from_bool (SCM_I_INUM (x
) < 0);
7006 else if (SCM_BIGP (x
))
7008 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7009 scm_remember_upto_here_1 (x
);
7010 return scm_from_bool (sgn
< 0);
7012 else if (SCM_REALP (x
))
7013 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7014 else if (SCM_FRACTIONP (x
))
7015 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7017 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7022 /* scm_min and scm_max return an inexact when either argument is inexact, as
7023 required by r5rs. On that basis, for exact/inexact combinations the
7024 exact is converted to inexact to compare and possibly return. This is
7025 unlike scm_less_p above which takes some trouble to preserve all bits in
7026 its test, such trouble is not required for min and max. */
7028 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7029 (SCM x
, SCM y
, SCM rest
),
7030 "Return the maximum of all parameter values.")
7031 #define FUNC_NAME s_scm_i_max
7033 while (!scm_is_null (rest
))
7034 { x
= scm_max (x
, y
);
7036 rest
= scm_cdr (rest
);
7038 return scm_max (x
, y
);
7042 #define s_max s_scm_i_max
7043 #define g_max g_scm_i_max
7046 scm_max (SCM x
, SCM y
)
7051 return scm_wta_dispatch_0 (g_max
, s_max
);
7052 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7055 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
7058 if (SCM_I_INUMP (x
))
7060 scm_t_inum xx
= SCM_I_INUM (x
);
7061 if (SCM_I_INUMP (y
))
7063 scm_t_inum yy
= SCM_I_INUM (y
);
7064 return (xx
< yy
) ? y
: x
;
7066 else if (SCM_BIGP (y
))
7068 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7069 scm_remember_upto_here_1 (y
);
7070 return (sgn
< 0) ? x
: y
;
7072 else if (SCM_REALP (y
))
7075 double yyd
= SCM_REAL_VALUE (y
);
7078 return scm_from_double (xxd
);
7079 /* If y is a NaN, then "==" is false and we return the NaN */
7080 else if (SCM_LIKELY (!(xxd
== yyd
)))
7082 /* Handle signed zeroes properly */
7088 else if (SCM_FRACTIONP (y
))
7091 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7094 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7096 else if (SCM_BIGP (x
))
7098 if (SCM_I_INUMP (y
))
7100 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7101 scm_remember_upto_here_1 (x
);
7102 return (sgn
< 0) ? y
: x
;
7104 else if (SCM_BIGP (y
))
7106 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7107 scm_remember_upto_here_2 (x
, y
);
7108 return (cmp
> 0) ? x
: y
;
7110 else if (SCM_REALP (y
))
7112 /* if y==NaN then xx>yy is false, so we return the NaN y */
7115 xx
= scm_i_big2dbl (x
);
7116 yy
= SCM_REAL_VALUE (y
);
7117 return (xx
> yy
? scm_from_double (xx
) : y
);
7119 else if (SCM_FRACTIONP (y
))
7124 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7126 else if (SCM_REALP (x
))
7128 if (SCM_I_INUMP (y
))
7130 scm_t_inum yy
= SCM_I_INUM (y
);
7131 double xxd
= SCM_REAL_VALUE (x
);
7135 return scm_from_double (yyd
);
7136 /* If x is a NaN, then "==" is false and we return the NaN */
7137 else if (SCM_LIKELY (!(xxd
== yyd
)))
7139 /* Handle signed zeroes properly */
7145 else if (SCM_BIGP (y
))
7150 else if (SCM_REALP (y
))
7152 double xx
= SCM_REAL_VALUE (x
);
7153 double yy
= SCM_REAL_VALUE (y
);
7155 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7158 else if (SCM_LIKELY (xx
< yy
))
7160 /* If neither (xx > yy) nor (xx < yy), then
7161 either they're equal or one is a NaN */
7162 else if (SCM_UNLIKELY (isnan (xx
)))
7163 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7164 else if (SCM_UNLIKELY (isnan (yy
)))
7165 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7166 /* xx == yy, but handle signed zeroes properly */
7167 else if (double_is_non_negative_zero (yy
))
7172 else if (SCM_FRACTIONP (y
))
7174 double yy
= scm_i_fraction2double (y
);
7175 double xx
= SCM_REAL_VALUE (x
);
7176 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7179 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7181 else if (SCM_FRACTIONP (x
))
7183 if (SCM_I_INUMP (y
))
7187 else if (SCM_BIGP (y
))
7191 else if (SCM_REALP (y
))
7193 double xx
= scm_i_fraction2double (x
);
7194 /* if y==NaN then ">" is false, so we return the NaN y */
7195 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7197 else if (SCM_FRACTIONP (y
))
7202 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7205 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7209 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7210 (SCM x
, SCM y
, SCM rest
),
7211 "Return the minimum of all parameter values.")
7212 #define FUNC_NAME s_scm_i_min
7214 while (!scm_is_null (rest
))
7215 { x
= scm_min (x
, y
);
7217 rest
= scm_cdr (rest
);
7219 return scm_min (x
, y
);
7223 #define s_min s_scm_i_min
7224 #define g_min g_scm_i_min
7227 scm_min (SCM x
, SCM y
)
7232 return scm_wta_dispatch_0 (g_min
, s_min
);
7233 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7236 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
7239 if (SCM_I_INUMP (x
))
7241 scm_t_inum xx
= SCM_I_INUM (x
);
7242 if (SCM_I_INUMP (y
))
7244 scm_t_inum yy
= SCM_I_INUM (y
);
7245 return (xx
< yy
) ? x
: y
;
7247 else if (SCM_BIGP (y
))
7249 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7250 scm_remember_upto_here_1 (y
);
7251 return (sgn
< 0) ? y
: x
;
7253 else if (SCM_REALP (y
))
7256 /* if y==NaN then "<" is false and we return NaN */
7257 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7259 else if (SCM_FRACTIONP (y
))
7262 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7265 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7267 else if (SCM_BIGP (x
))
7269 if (SCM_I_INUMP (y
))
7271 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7272 scm_remember_upto_here_1 (x
);
7273 return (sgn
< 0) ? x
: y
;
7275 else if (SCM_BIGP (y
))
7277 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7278 scm_remember_upto_here_2 (x
, y
);
7279 return (cmp
> 0) ? y
: x
;
7281 else if (SCM_REALP (y
))
7283 /* if y==NaN then xx<yy is false, so we return the NaN y */
7286 xx
= scm_i_big2dbl (x
);
7287 yy
= SCM_REAL_VALUE (y
);
7288 return (xx
< yy
? scm_from_double (xx
) : y
);
7290 else if (SCM_FRACTIONP (y
))
7295 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7297 else if (SCM_REALP (x
))
7299 if (SCM_I_INUMP (y
))
7301 double z
= SCM_I_INUM (y
);
7302 /* if x==NaN then "<" is false and we return NaN */
7303 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7305 else if (SCM_BIGP (y
))
7310 else if (SCM_REALP (y
))
7312 double xx
= SCM_REAL_VALUE (x
);
7313 double yy
= SCM_REAL_VALUE (y
);
7315 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7318 else if (SCM_LIKELY (xx
> yy
))
7320 /* If neither (xx < yy) nor (xx > yy), then
7321 either they're equal or one is a NaN */
7322 else if (SCM_UNLIKELY (isnan (xx
)))
7323 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7324 else if (SCM_UNLIKELY (isnan (yy
)))
7325 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7326 /* xx == yy, but handle signed zeroes properly */
7327 else if (double_is_non_negative_zero (xx
))
7332 else if (SCM_FRACTIONP (y
))
7334 double yy
= scm_i_fraction2double (y
);
7335 double xx
= SCM_REAL_VALUE (x
);
7336 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7339 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7341 else if (SCM_FRACTIONP (x
))
7343 if (SCM_I_INUMP (y
))
7347 else if (SCM_BIGP (y
))
7351 else if (SCM_REALP (y
))
7353 double xx
= scm_i_fraction2double (x
);
7354 /* if y==NaN then "<" is false, so we return the NaN y */
7355 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7357 else if (SCM_FRACTIONP (y
))
7362 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7365 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7369 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7370 (SCM x
, SCM y
, SCM rest
),
7371 "Return the sum of all parameter values. Return 0 if called without\n"
7373 #define FUNC_NAME s_scm_i_sum
7375 while (!scm_is_null (rest
))
7376 { x
= scm_sum (x
, y
);
7378 rest
= scm_cdr (rest
);
7380 return scm_sum (x
, y
);
7384 #define s_sum s_scm_i_sum
7385 #define g_sum g_scm_i_sum
7388 scm_sum (SCM x
, SCM y
)
7390 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7392 if (SCM_NUMBERP (x
)) return x
;
7393 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7394 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7397 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7399 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7401 scm_t_inum xx
= SCM_I_INUM (x
);
7402 scm_t_inum yy
= SCM_I_INUM (y
);
7403 scm_t_inum z
= xx
+ yy
;
7404 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7406 else if (SCM_BIGP (y
))
7411 else if (SCM_REALP (y
))
7413 scm_t_inum xx
= SCM_I_INUM (x
);
7414 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7416 else if (SCM_COMPLEXP (y
))
7418 scm_t_inum xx
= SCM_I_INUM (x
);
7419 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7420 SCM_COMPLEX_IMAG (y
));
7422 else if (SCM_FRACTIONP (y
))
7423 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7424 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7425 SCM_FRACTION_DENOMINATOR (y
));
7427 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7428 } else if (SCM_BIGP (x
))
7430 if (SCM_I_INUMP (y
))
7435 inum
= SCM_I_INUM (y
);
7438 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7441 SCM result
= scm_i_mkbig ();
7442 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7443 scm_remember_upto_here_1 (x
);
7444 /* we know the result will have to be a bignum */
7447 return scm_i_normbig (result
);
7451 SCM result
= scm_i_mkbig ();
7452 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7453 scm_remember_upto_here_1 (x
);
7454 /* we know the result will have to be a bignum */
7457 return scm_i_normbig (result
);
7460 else if (SCM_BIGP (y
))
7462 SCM result
= scm_i_mkbig ();
7463 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7464 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7465 mpz_add (SCM_I_BIG_MPZ (result
),
7468 scm_remember_upto_here_2 (x
, y
);
7469 /* we know the result will have to be a bignum */
7472 return scm_i_normbig (result
);
7474 else if (SCM_REALP (y
))
7476 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7477 scm_remember_upto_here_1 (x
);
7478 return scm_from_double (result
);
7480 else if (SCM_COMPLEXP (y
))
7482 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7483 + SCM_COMPLEX_REAL (y
));
7484 scm_remember_upto_here_1 (x
);
7485 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7487 else if (SCM_FRACTIONP (y
))
7488 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7489 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7490 SCM_FRACTION_DENOMINATOR (y
));
7492 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7494 else if (SCM_REALP (x
))
7496 if (SCM_I_INUMP (y
))
7497 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7498 else if (SCM_BIGP (y
))
7500 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7501 scm_remember_upto_here_1 (y
);
7502 return scm_from_double (result
);
7504 else if (SCM_REALP (y
))
7505 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7506 else if (SCM_COMPLEXP (y
))
7507 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7508 SCM_COMPLEX_IMAG (y
));
7509 else if (SCM_FRACTIONP (y
))
7510 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7512 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7514 else if (SCM_COMPLEXP (x
))
7516 if (SCM_I_INUMP (y
))
7517 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7518 SCM_COMPLEX_IMAG (x
));
7519 else if (SCM_BIGP (y
))
7521 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7522 + SCM_COMPLEX_REAL (x
));
7523 scm_remember_upto_here_1 (y
);
7524 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7526 else if (SCM_REALP (y
))
7527 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7528 SCM_COMPLEX_IMAG (x
));
7529 else if (SCM_COMPLEXP (y
))
7530 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7531 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7532 else if (SCM_FRACTIONP (y
))
7533 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7534 SCM_COMPLEX_IMAG (x
));
7536 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7538 else if (SCM_FRACTIONP (x
))
7540 if (SCM_I_INUMP (y
))
7541 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7542 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7543 SCM_FRACTION_DENOMINATOR (x
));
7544 else if (SCM_BIGP (y
))
7545 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7546 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7547 SCM_FRACTION_DENOMINATOR (x
));
7548 else if (SCM_REALP (y
))
7549 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7550 else if (SCM_COMPLEXP (y
))
7551 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7552 SCM_COMPLEX_IMAG (y
));
7553 else if (SCM_FRACTIONP (y
))
7554 /* a/b + c/d = (ad + bc) / bd */
7555 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7556 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7557 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7559 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7562 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7566 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7568 "Return @math{@var{x}+1}.")
7569 #define FUNC_NAME s_scm_oneplus
7571 return scm_sum (x
, SCM_INUM1
);
7576 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7577 (SCM x
, SCM y
, SCM rest
),
7578 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7579 "the sum of all but the first argument are subtracted from the first\n"
7581 #define FUNC_NAME s_scm_i_difference
7583 while (!scm_is_null (rest
))
7584 { x
= scm_difference (x
, y
);
7586 rest
= scm_cdr (rest
);
7588 return scm_difference (x
, y
);
7592 #define s_difference s_scm_i_difference
7593 #define g_difference g_scm_i_difference
7596 scm_difference (SCM x
, SCM y
)
7597 #define FUNC_NAME s_difference
7599 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7602 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7604 if (SCM_I_INUMP (x
))
7606 scm_t_inum xx
= -SCM_I_INUM (x
);
7607 if (SCM_FIXABLE (xx
))
7608 return SCM_I_MAKINUM (xx
);
7610 return scm_i_inum2big (xx
);
7612 else if (SCM_BIGP (x
))
7613 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7614 bignum, but negating that gives a fixnum. */
7615 return scm_i_normbig (scm_i_clonebig (x
, 0));
7616 else if (SCM_REALP (x
))
7617 return scm_from_double (-SCM_REAL_VALUE (x
));
7618 else if (SCM_COMPLEXP (x
))
7619 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7620 -SCM_COMPLEX_IMAG (x
));
7621 else if (SCM_FRACTIONP (x
))
7622 return scm_i_make_ratio_already_reduced
7623 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7624 SCM_FRACTION_DENOMINATOR (x
));
7626 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7629 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7631 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7633 scm_t_inum xx
= SCM_I_INUM (x
);
7634 scm_t_inum yy
= SCM_I_INUM (y
);
7635 scm_t_inum z
= xx
- yy
;
7636 if (SCM_FIXABLE (z
))
7637 return SCM_I_MAKINUM (z
);
7639 return scm_i_inum2big (z
);
7641 else if (SCM_BIGP (y
))
7643 /* inum-x - big-y */
7644 scm_t_inum xx
= SCM_I_INUM (x
);
7648 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7649 bignum, but negating that gives a fixnum. */
7650 return scm_i_normbig (scm_i_clonebig (y
, 0));
7654 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7655 SCM result
= scm_i_mkbig ();
7658 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7661 /* x - y == -(y + -x) */
7662 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7663 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7665 scm_remember_upto_here_1 (y
);
7667 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7668 /* we know the result will have to be a bignum */
7671 return scm_i_normbig (result
);
7674 else if (SCM_REALP (y
))
7676 scm_t_inum xx
= SCM_I_INUM (x
);
7679 * We need to handle x == exact 0
7680 * specially because R6RS states that:
7681 * (- 0.0) ==> -0.0 and
7682 * (- 0.0 0.0) ==> 0.0
7683 * and the scheme compiler changes
7684 * (- 0.0) into (- 0 0.0)
7685 * So we need to treat (- 0 0.0) like (- 0.0).
7686 * At the C level, (-x) is different than (0.0 - x).
7687 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7690 return scm_from_double (- SCM_REAL_VALUE (y
));
7692 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7694 else if (SCM_COMPLEXP (y
))
7696 scm_t_inum xx
= SCM_I_INUM (x
);
7698 /* We need to handle x == exact 0 specially.
7699 See the comment above (for SCM_REALP (y)) */
7701 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7702 - SCM_COMPLEX_IMAG (y
));
7704 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7705 - SCM_COMPLEX_IMAG (y
));
7707 else if (SCM_FRACTIONP (y
))
7708 /* a - b/c = (ac - b) / c */
7709 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7710 SCM_FRACTION_NUMERATOR (y
)),
7711 SCM_FRACTION_DENOMINATOR (y
));
7713 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7715 else if (SCM_BIGP (x
))
7717 if (SCM_I_INUMP (y
))
7719 /* big-x - inum-y */
7720 scm_t_inum yy
= SCM_I_INUM (y
);
7721 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7723 scm_remember_upto_here_1 (x
);
7725 return (SCM_FIXABLE (-yy
) ?
7726 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7729 SCM result
= scm_i_mkbig ();
7732 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7734 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7735 scm_remember_upto_here_1 (x
);
7737 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7738 /* we know the result will have to be a bignum */
7741 return scm_i_normbig (result
);
7744 else if (SCM_BIGP (y
))
7746 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7747 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7748 SCM result
= scm_i_mkbig ();
7749 mpz_sub (SCM_I_BIG_MPZ (result
),
7752 scm_remember_upto_here_2 (x
, y
);
7753 /* we know the result will have to be a bignum */
7754 if ((sgn_x
== 1) && (sgn_y
== -1))
7756 if ((sgn_x
== -1) && (sgn_y
== 1))
7758 return scm_i_normbig (result
);
7760 else if (SCM_REALP (y
))
7762 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7763 scm_remember_upto_here_1 (x
);
7764 return scm_from_double (result
);
7766 else if (SCM_COMPLEXP (y
))
7768 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7769 - SCM_COMPLEX_REAL (y
));
7770 scm_remember_upto_here_1 (x
);
7771 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7773 else if (SCM_FRACTIONP (y
))
7774 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7775 SCM_FRACTION_NUMERATOR (y
)),
7776 SCM_FRACTION_DENOMINATOR (y
));
7778 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7780 else if (SCM_REALP (x
))
7782 if (SCM_I_INUMP (y
))
7783 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7784 else if (SCM_BIGP (y
))
7786 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7787 scm_remember_upto_here_1 (x
);
7788 return scm_from_double (result
);
7790 else if (SCM_REALP (y
))
7791 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7792 else if (SCM_COMPLEXP (y
))
7793 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7794 -SCM_COMPLEX_IMAG (y
));
7795 else if (SCM_FRACTIONP (y
))
7796 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7798 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7800 else if (SCM_COMPLEXP (x
))
7802 if (SCM_I_INUMP (y
))
7803 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7804 SCM_COMPLEX_IMAG (x
));
7805 else if (SCM_BIGP (y
))
7807 double real_part
= (SCM_COMPLEX_REAL (x
)
7808 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7809 scm_remember_upto_here_1 (x
);
7810 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7812 else if (SCM_REALP (y
))
7813 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7814 SCM_COMPLEX_IMAG (x
));
7815 else if (SCM_COMPLEXP (y
))
7816 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7817 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7818 else if (SCM_FRACTIONP (y
))
7819 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7820 SCM_COMPLEX_IMAG (x
));
7822 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7824 else if (SCM_FRACTIONP (x
))
7826 if (SCM_I_INUMP (y
))
7827 /* a/b - c = (a - cb) / b */
7828 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7829 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7830 SCM_FRACTION_DENOMINATOR (x
));
7831 else if (SCM_BIGP (y
))
7832 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7833 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7834 SCM_FRACTION_DENOMINATOR (x
));
7835 else if (SCM_REALP (y
))
7836 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7837 else if (SCM_COMPLEXP (y
))
7838 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7839 -SCM_COMPLEX_IMAG (y
));
7840 else if (SCM_FRACTIONP (y
))
7841 /* a/b - c/d = (ad - bc) / bd */
7842 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7843 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7844 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7846 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7849 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7854 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7856 "Return @math{@var{x}-1}.")
7857 #define FUNC_NAME s_scm_oneminus
7859 return scm_difference (x
, SCM_INUM1
);
7864 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7865 (SCM x
, SCM y
, SCM rest
),
7866 "Return the product of all arguments. If called without arguments,\n"
7868 #define FUNC_NAME s_scm_i_product
7870 while (!scm_is_null (rest
))
7871 { x
= scm_product (x
, y
);
7873 rest
= scm_cdr (rest
);
7875 return scm_product (x
, y
);
7879 #define s_product s_scm_i_product
7880 #define g_product g_scm_i_product
7883 scm_product (SCM x
, SCM y
)
7885 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7888 return SCM_I_MAKINUM (1L);
7889 else if (SCM_NUMBERP (x
))
7892 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7895 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7900 xx
= SCM_I_INUM (x
);
7905 /* exact1 is the universal multiplicative identity */
7909 /* exact0 times a fixnum is exact0: optimize this case */
7910 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7912 /* if the other argument is inexact, the result is inexact,
7913 and we must do the multiplication in order to handle
7914 infinities and NaNs properly. */
7915 else if (SCM_REALP (y
))
7916 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7917 else if (SCM_COMPLEXP (y
))
7918 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7919 0.0 * SCM_COMPLEX_IMAG (y
));
7920 /* we've already handled inexact numbers,
7921 so y must be exact, and we return exact0 */
7922 else if (SCM_NUMP (y
))
7925 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7929 * This case is important for more than just optimization.
7930 * It handles the case of negating
7931 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7932 * which is a bignum that must be changed back into a fixnum.
7933 * Failure to do so will cause the following to return #f:
7934 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7936 return scm_difference(y
, SCM_UNDEFINED
);
7940 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7942 scm_t_inum yy
= SCM_I_INUM (y
);
7943 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7944 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7945 if (SCM_FIXABLE (kk
))
7946 return SCM_I_MAKINUM (kk
);
7948 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7949 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7950 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7951 return SCM_I_MAKINUM (xx
* yy
);
7955 SCM result
= scm_i_inum2big (xx
);
7956 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7957 return scm_i_normbig (result
);
7960 else if (SCM_BIGP (y
))
7962 SCM result
= scm_i_mkbig ();
7963 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7964 scm_remember_upto_here_1 (y
);
7967 else if (SCM_REALP (y
))
7968 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7969 else if (SCM_COMPLEXP (y
))
7970 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7971 xx
* SCM_COMPLEX_IMAG (y
));
7972 else if (SCM_FRACTIONP (y
))
7973 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7974 SCM_FRACTION_DENOMINATOR (y
));
7976 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7978 else if (SCM_BIGP (x
))
7980 if (SCM_I_INUMP (y
))
7985 else if (SCM_BIGP (y
))
7987 SCM result
= scm_i_mkbig ();
7988 mpz_mul (SCM_I_BIG_MPZ (result
),
7991 scm_remember_upto_here_2 (x
, y
);
7994 else if (SCM_REALP (y
))
7996 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7997 scm_remember_upto_here_1 (x
);
7998 return scm_from_double (result
);
8000 else if (SCM_COMPLEXP (y
))
8002 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
8003 scm_remember_upto_here_1 (x
);
8004 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
8005 z
* SCM_COMPLEX_IMAG (y
));
8007 else if (SCM_FRACTIONP (y
))
8008 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
8009 SCM_FRACTION_DENOMINATOR (y
));
8011 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8013 else if (SCM_REALP (x
))
8015 if (SCM_I_INUMP (y
))
8020 else if (SCM_BIGP (y
))
8022 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8023 scm_remember_upto_here_1 (y
);
8024 return scm_from_double (result
);
8026 else if (SCM_REALP (y
))
8027 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8028 else if (SCM_COMPLEXP (y
))
8029 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8030 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8031 else if (SCM_FRACTIONP (y
))
8032 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8034 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8036 else if (SCM_COMPLEXP (x
))
8038 if (SCM_I_INUMP (y
))
8043 else if (SCM_BIGP (y
))
8045 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8046 scm_remember_upto_here_1 (y
);
8047 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8048 z
* SCM_COMPLEX_IMAG (x
));
8050 else if (SCM_REALP (y
))
8051 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8052 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8053 else if (SCM_COMPLEXP (y
))
8055 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8056 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8057 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8058 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8060 else if (SCM_FRACTIONP (y
))
8062 double yy
= scm_i_fraction2double (y
);
8063 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8064 yy
* SCM_COMPLEX_IMAG (x
));
8067 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8069 else if (SCM_FRACTIONP (x
))
8071 if (SCM_I_INUMP (y
))
8072 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8073 SCM_FRACTION_DENOMINATOR (x
));
8074 else if (SCM_BIGP (y
))
8075 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8076 SCM_FRACTION_DENOMINATOR (x
));
8077 else if (SCM_REALP (y
))
8078 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8079 else if (SCM_COMPLEXP (y
))
8081 double xx
= scm_i_fraction2double (x
);
8082 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8083 xx
* SCM_COMPLEX_IMAG (y
));
8085 else if (SCM_FRACTIONP (y
))
8086 /* a/b * c/d = ac / bd */
8087 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8088 SCM_FRACTION_NUMERATOR (y
)),
8089 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8090 SCM_FRACTION_DENOMINATOR (y
)));
8092 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8095 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8098 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8099 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8100 #define ALLOW_DIVIDE_BY_ZERO
8101 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8104 /* The code below for complex division is adapted from the GNU
8105 libstdc++, which adapted it from f2c's libF77, and is subject to
8108 /****************************************************************
8109 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8111 Permission to use, copy, modify, and distribute this software
8112 and its documentation for any purpose and without fee is hereby
8113 granted, provided that the above copyright notice appear in all
8114 copies and that both that the copyright notice and this
8115 permission notice and warranty disclaimer appear in supporting
8116 documentation, and that the names of AT&T Bell Laboratories or
8117 Bellcore or any of their entities not be used in advertising or
8118 publicity pertaining to distribution of the software without
8119 specific, written prior permission.
8121 AT&T and Bellcore disclaim all warranties with regard to this
8122 software, including all implied warranties of merchantability
8123 and fitness. In no event shall AT&T or Bellcore be liable for
8124 any special, indirect or consequential damages or any damages
8125 whatsoever resulting from loss of use, data or profits, whether
8126 in an action of contract, negligence or other tortious action,
8127 arising out of or in connection with the use or performance of
8129 ****************************************************************/
8131 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8132 (SCM x
, SCM y
, SCM rest
),
8133 "Divide the first argument by the product of the remaining\n"
8134 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8136 #define FUNC_NAME s_scm_i_divide
8138 while (!scm_is_null (rest
))
8139 { x
= scm_divide (x
, y
);
8141 rest
= scm_cdr (rest
);
8143 return scm_divide (x
, y
);
8147 #define s_divide s_scm_i_divide
8148 #define g_divide g_scm_i_divide
8151 scm_divide (SCM x
, SCM y
)
8152 #define FUNC_NAME s_divide
8156 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8159 return scm_wta_dispatch_0 (g_divide
, s_divide
);
8160 else if (SCM_I_INUMP (x
))
8162 scm_t_inum xx
= SCM_I_INUM (x
);
8163 if (xx
== 1 || xx
== -1)
8165 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8167 scm_num_overflow (s_divide
);
8170 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8172 else if (SCM_BIGP (x
))
8173 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8174 else if (SCM_REALP (x
))
8176 double xx
= SCM_REAL_VALUE (x
);
8177 #ifndef ALLOW_DIVIDE_BY_ZERO
8179 scm_num_overflow (s_divide
);
8182 return scm_from_double (1.0 / xx
);
8184 else if (SCM_COMPLEXP (x
))
8186 double r
= SCM_COMPLEX_REAL (x
);
8187 double i
= SCM_COMPLEX_IMAG (x
);
8188 if (fabs(r
) <= fabs(i
))
8191 double d
= i
* (1.0 + t
* t
);
8192 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8197 double d
= r
* (1.0 + t
* t
);
8198 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8201 else if (SCM_FRACTIONP (x
))
8202 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8203 SCM_FRACTION_NUMERATOR (x
));
8205 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8208 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8210 scm_t_inum xx
= SCM_I_INUM (x
);
8211 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8213 scm_t_inum yy
= SCM_I_INUM (y
);
8216 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8217 scm_num_overflow (s_divide
);
8219 return scm_from_double ((double) xx
/ (double) yy
);
8222 else if (xx
% yy
!= 0)
8223 return scm_i_make_ratio (x
, y
);
8226 scm_t_inum z
= xx
/ yy
;
8227 if (SCM_FIXABLE (z
))
8228 return SCM_I_MAKINUM (z
);
8230 return scm_i_inum2big (z
);
8233 else if (SCM_BIGP (y
))
8234 return scm_i_make_ratio (x
, y
);
8235 else if (SCM_REALP (y
))
8237 double yy
= SCM_REAL_VALUE (y
);
8238 #ifndef ALLOW_DIVIDE_BY_ZERO
8240 scm_num_overflow (s_divide
);
8243 /* FIXME: Precision may be lost here due to:
8244 (1) The cast from 'scm_t_inum' to 'double'
8245 (2) Double rounding */
8246 return scm_from_double ((double) xx
/ yy
);
8248 else if (SCM_COMPLEXP (y
))
8251 complex_div
: /* y _must_ be a complex number */
8253 double r
= SCM_COMPLEX_REAL (y
);
8254 double i
= SCM_COMPLEX_IMAG (y
);
8255 if (fabs(r
) <= fabs(i
))
8258 double d
= i
* (1.0 + t
* t
);
8259 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8264 double d
= r
* (1.0 + t
* t
);
8265 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8269 else if (SCM_FRACTIONP (y
))
8270 /* a / b/c = ac / b */
8271 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8272 SCM_FRACTION_NUMERATOR (y
));
8274 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8276 else if (SCM_BIGP (x
))
8278 if (SCM_I_INUMP (y
))
8280 scm_t_inum yy
= SCM_I_INUM (y
);
8283 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8284 scm_num_overflow (s_divide
);
8286 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8287 scm_remember_upto_here_1 (x
);
8288 return (sgn
== 0) ? scm_nan () : scm_inf ();
8295 /* FIXME: HMM, what are the relative performance issues here?
8296 We need to test. Is it faster on average to test
8297 divisible_p, then perform whichever operation, or is it
8298 faster to perform the integer div opportunistically and
8299 switch to real if there's a remainder? For now we take the
8300 middle ground: test, then if divisible, use the faster div
8303 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8304 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8308 SCM result
= scm_i_mkbig ();
8309 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8310 scm_remember_upto_here_1 (x
);
8312 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8313 return scm_i_normbig (result
);
8316 return scm_i_make_ratio (x
, y
);
8319 else if (SCM_BIGP (y
))
8321 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8325 SCM result
= scm_i_mkbig ();
8326 mpz_divexact (SCM_I_BIG_MPZ (result
),
8329 scm_remember_upto_here_2 (x
, y
);
8330 return scm_i_normbig (result
);
8333 return scm_i_make_ratio (x
, y
);
8335 else if (SCM_REALP (y
))
8337 double yy
= SCM_REAL_VALUE (y
);
8338 #ifndef ALLOW_DIVIDE_BY_ZERO
8340 scm_num_overflow (s_divide
);
8343 /* FIXME: Precision may be lost here due to:
8344 (1) scm_i_big2dbl (2) Double rounding */
8345 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8347 else if (SCM_COMPLEXP (y
))
8349 a
= scm_i_big2dbl (x
);
8352 else if (SCM_FRACTIONP (y
))
8353 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8354 SCM_FRACTION_NUMERATOR (y
));
8356 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8358 else if (SCM_REALP (x
))
8360 double rx
= SCM_REAL_VALUE (x
);
8361 if (SCM_I_INUMP (y
))
8363 scm_t_inum yy
= SCM_I_INUM (y
);
8364 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8366 scm_num_overflow (s_divide
);
8369 /* FIXME: Precision may be lost here due to:
8370 (1) The cast from 'scm_t_inum' to 'double'
8371 (2) Double rounding */
8372 return scm_from_double (rx
/ (double) yy
);
8374 else if (SCM_BIGP (y
))
8376 /* FIXME: Precision may be lost here due to:
8377 (1) The conversion from bignum to double
8378 (2) Double rounding */
8379 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8380 scm_remember_upto_here_1 (y
);
8381 return scm_from_double (rx
/ dby
);
8383 else if (SCM_REALP (y
))
8385 double yy
= SCM_REAL_VALUE (y
);
8386 #ifndef ALLOW_DIVIDE_BY_ZERO
8388 scm_num_overflow (s_divide
);
8391 return scm_from_double (rx
/ yy
);
8393 else if (SCM_COMPLEXP (y
))
8398 else if (SCM_FRACTIONP (y
))
8399 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8401 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8403 else if (SCM_COMPLEXP (x
))
8405 double rx
= SCM_COMPLEX_REAL (x
);
8406 double ix
= SCM_COMPLEX_IMAG (x
);
8407 if (SCM_I_INUMP (y
))
8409 scm_t_inum yy
= SCM_I_INUM (y
);
8410 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8412 scm_num_overflow (s_divide
);
8416 /* FIXME: Precision may be lost here due to:
8417 (1) The conversion from 'scm_t_inum' to double
8418 (2) Double rounding */
8420 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8423 else if (SCM_BIGP (y
))
8425 /* FIXME: Precision may be lost here due to:
8426 (1) The conversion from bignum to double
8427 (2) Double rounding */
8428 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8429 scm_remember_upto_here_1 (y
);
8430 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8432 else if (SCM_REALP (y
))
8434 double yy
= SCM_REAL_VALUE (y
);
8435 #ifndef ALLOW_DIVIDE_BY_ZERO
8437 scm_num_overflow (s_divide
);
8440 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8442 else if (SCM_COMPLEXP (y
))
8444 double ry
= SCM_COMPLEX_REAL (y
);
8445 double iy
= SCM_COMPLEX_IMAG (y
);
8446 if (fabs(ry
) <= fabs(iy
))
8449 double d
= iy
* (1.0 + t
* t
);
8450 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8455 double d
= ry
* (1.0 + t
* t
);
8456 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8459 else if (SCM_FRACTIONP (y
))
8461 /* FIXME: Precision may be lost here due to:
8462 (1) The conversion from fraction to double
8463 (2) Double rounding */
8464 double yy
= scm_i_fraction2double (y
);
8465 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8468 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8470 else if (SCM_FRACTIONP (x
))
8472 if (SCM_I_INUMP (y
))
8474 scm_t_inum yy
= SCM_I_INUM (y
);
8475 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8477 scm_num_overflow (s_divide
);
8480 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8481 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8483 else if (SCM_BIGP (y
))
8485 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8486 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8488 else if (SCM_REALP (y
))
8490 double yy
= SCM_REAL_VALUE (y
);
8491 #ifndef ALLOW_DIVIDE_BY_ZERO
8493 scm_num_overflow (s_divide
);
8496 /* FIXME: Precision may be lost here due to:
8497 (1) The conversion from fraction to double
8498 (2) Double rounding */
8499 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8501 else if (SCM_COMPLEXP (y
))
8503 /* FIXME: Precision may be lost here due to:
8504 (1) The conversion from fraction to double
8505 (2) Double rounding */
8506 a
= scm_i_fraction2double (x
);
8509 else if (SCM_FRACTIONP (y
))
8510 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8511 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8513 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8516 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8522 scm_c_truncate (double x
)
8527 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8528 half-way case (ie. when x is an integer plus 0.5) going upwards.
8529 Then half-way cases are identified and adjusted down if the
8530 round-upwards didn't give the desired even integer.
8532 "plus_half == result" identifies a half-way case. If plus_half, which is
8533 x + 0.5, is an integer then x must be an integer plus 0.5.
8535 An odd "result" value is identified with result/2 != floor(result/2).
8536 This is done with plus_half, since that value is ready for use sooner in
8537 a pipelined cpu, and we're already requiring plus_half == result.
8539 Note however that we need to be careful when x is big and already an
8540 integer. In that case "x+0.5" may round to an adjacent integer, causing
8541 us to return such a value, incorrectly. For instance if the hardware is
8542 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8543 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8544 returned. Or if the hardware is in round-upwards mode, then other bigger
8545 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8546 representable value, 2^128+2^76 (or whatever), again incorrect.
8548 These bad roundings of x+0.5 are avoided by testing at the start whether
8549 x is already an integer. If it is then clearly that's the desired result
8550 already. And if it's not then the exponent must be small enough to allow
8551 an 0.5 to be represented, and hence added without a bad rounding. */
8554 scm_c_round (double x
)
8556 double plus_half
, result
;
8561 plus_half
= x
+ 0.5;
8562 result
= floor (plus_half
);
8563 /* Adjust so that the rounding is towards even. */
8564 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8569 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8571 "Round the number @var{x} towards zero.")
8572 #define FUNC_NAME s_scm_truncate_number
8574 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8576 else if (SCM_REALP (x
))
8577 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8578 else if (SCM_FRACTIONP (x
))
8579 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8580 SCM_FRACTION_DENOMINATOR (x
));
8582 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8583 s_scm_truncate_number
);
8587 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8589 "Round the number @var{x} towards the nearest integer. "
8590 "When it is exactly halfway between two integers, "
8591 "round towards the even one.")
8592 #define FUNC_NAME s_scm_round_number
8594 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8596 else if (SCM_REALP (x
))
8597 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8598 else if (SCM_FRACTIONP (x
))
8599 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8600 SCM_FRACTION_DENOMINATOR (x
));
8602 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8603 s_scm_round_number
);
8607 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8609 "Round the number @var{x} towards minus infinity.")
8610 #define FUNC_NAME s_scm_floor
8612 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8614 else if (SCM_REALP (x
))
8615 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8616 else if (SCM_FRACTIONP (x
))
8617 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8618 SCM_FRACTION_DENOMINATOR (x
));
8620 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8624 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8626 "Round the number @var{x} towards infinity.")
8627 #define FUNC_NAME s_scm_ceiling
8629 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8631 else if (SCM_REALP (x
))
8632 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8633 else if (SCM_FRACTIONP (x
))
8634 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8635 SCM_FRACTION_DENOMINATOR (x
));
8637 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8641 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8643 "Return @var{x} raised to the power of @var{y}.")
8644 #define FUNC_NAME s_scm_expt
8646 if (scm_is_integer (y
))
8648 if (scm_is_true (scm_exact_p (y
)))
8649 return scm_integer_expt (x
, y
);
8652 /* Here we handle the case where the exponent is an inexact
8653 integer. We make the exponent exact in order to use
8654 scm_integer_expt, and thus avoid the spurious imaginary
8655 parts that may result from round-off errors in the general
8656 e^(y log x) method below (for example when squaring a large
8657 negative number). In this case, we must return an inexact
8658 result for correctness. We also make the base inexact so
8659 that scm_integer_expt will use fast inexact arithmetic
8660 internally. Note that making the base inexact is not
8661 sufficient to guarantee an inexact result, because
8662 scm_integer_expt will return an exact 1 when the exponent
8663 is 0, even if the base is inexact. */
8664 return scm_exact_to_inexact
8665 (scm_integer_expt (scm_exact_to_inexact (x
),
8666 scm_inexact_to_exact (y
)));
8669 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8671 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8673 else if (scm_is_complex (x
) && scm_is_complex (y
))
8674 return scm_exp (scm_product (scm_log (x
), y
));
8675 else if (scm_is_complex (x
))
8676 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8678 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8682 /* sin/cos/tan/asin/acos/atan
8683 sinh/cosh/tanh/asinh/acosh/atanh
8684 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8685 Written by Jerry D. Hedden, (C) FSF.
8686 See the file `COPYING' for terms applying to this program. */
8688 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8690 "Compute the sine of @var{z}.")
8691 #define FUNC_NAME s_scm_sin
8693 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8694 return z
; /* sin(exact0) = exact0 */
8695 else if (scm_is_real (z
))
8696 return scm_from_double (sin (scm_to_double (z
)));
8697 else if (SCM_COMPLEXP (z
))
8699 x
= SCM_COMPLEX_REAL (z
);
8700 y
= SCM_COMPLEX_IMAG (z
);
8701 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8702 cos (x
) * sinh (y
));
8705 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8709 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8711 "Compute the cosine of @var{z}.")
8712 #define FUNC_NAME s_scm_cos
8714 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8715 return SCM_INUM1
; /* cos(exact0) = exact1 */
8716 else if (scm_is_real (z
))
8717 return scm_from_double (cos (scm_to_double (z
)));
8718 else if (SCM_COMPLEXP (z
))
8720 x
= SCM_COMPLEX_REAL (z
);
8721 y
= SCM_COMPLEX_IMAG (z
);
8722 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8723 -sin (x
) * sinh (y
));
8726 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8730 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8732 "Compute the tangent of @var{z}.")
8733 #define FUNC_NAME s_scm_tan
8735 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8736 return z
; /* tan(exact0) = exact0 */
8737 else if (scm_is_real (z
))
8738 return scm_from_double (tan (scm_to_double (z
)));
8739 else if (SCM_COMPLEXP (z
))
8741 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8742 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8743 w
= cos (x
) + cosh (y
);
8744 #ifndef ALLOW_DIVIDE_BY_ZERO
8746 scm_num_overflow (s_scm_tan
);
8748 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8751 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8755 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8757 "Compute the hyperbolic sine of @var{z}.")
8758 #define FUNC_NAME s_scm_sinh
8760 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8761 return z
; /* sinh(exact0) = exact0 */
8762 else if (scm_is_real (z
))
8763 return scm_from_double (sinh (scm_to_double (z
)));
8764 else if (SCM_COMPLEXP (z
))
8766 x
= SCM_COMPLEX_REAL (z
);
8767 y
= SCM_COMPLEX_IMAG (z
);
8768 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8769 cosh (x
) * sin (y
));
8772 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8776 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8778 "Compute the hyperbolic cosine of @var{z}.")
8779 #define FUNC_NAME s_scm_cosh
8781 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8782 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8783 else if (scm_is_real (z
))
8784 return scm_from_double (cosh (scm_to_double (z
)));
8785 else if (SCM_COMPLEXP (z
))
8787 x
= SCM_COMPLEX_REAL (z
);
8788 y
= SCM_COMPLEX_IMAG (z
);
8789 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8790 sinh (x
) * sin (y
));
8793 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8797 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8799 "Compute the hyperbolic tangent of @var{z}.")
8800 #define FUNC_NAME s_scm_tanh
8802 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8803 return z
; /* tanh(exact0) = exact0 */
8804 else if (scm_is_real (z
))
8805 return scm_from_double (tanh (scm_to_double (z
)));
8806 else if (SCM_COMPLEXP (z
))
8808 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8809 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8810 w
= cosh (x
) + cos (y
);
8811 #ifndef ALLOW_DIVIDE_BY_ZERO
8813 scm_num_overflow (s_scm_tanh
);
8815 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8818 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8822 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8824 "Compute the arc sine of @var{z}.")
8825 #define FUNC_NAME s_scm_asin
8827 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8828 return z
; /* asin(exact0) = exact0 */
8829 else if (scm_is_real (z
))
8831 double w
= scm_to_double (z
);
8832 if (w
>= -1.0 && w
<= 1.0)
8833 return scm_from_double (asin (w
));
8835 return scm_product (scm_c_make_rectangular (0, -1),
8836 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8838 else if (SCM_COMPLEXP (z
))
8840 x
= SCM_COMPLEX_REAL (z
);
8841 y
= SCM_COMPLEX_IMAG (z
);
8842 return scm_product (scm_c_make_rectangular (0, -1),
8843 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8846 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8850 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8852 "Compute the arc cosine of @var{z}.")
8853 #define FUNC_NAME s_scm_acos
8855 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8856 return SCM_INUM0
; /* acos(exact1) = exact0 */
8857 else if (scm_is_real (z
))
8859 double w
= scm_to_double (z
);
8860 if (w
>= -1.0 && w
<= 1.0)
8861 return scm_from_double (acos (w
));
8863 return scm_sum (scm_from_double (acos (0.0)),
8864 scm_product (scm_c_make_rectangular (0, 1),
8865 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8867 else if (SCM_COMPLEXP (z
))
8869 x
= SCM_COMPLEX_REAL (z
);
8870 y
= SCM_COMPLEX_IMAG (z
);
8871 return scm_sum (scm_from_double (acos (0.0)),
8872 scm_product (scm_c_make_rectangular (0, 1),
8873 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8876 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8880 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8882 "With one argument, compute the arc tangent of @var{z}.\n"
8883 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8884 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8885 #define FUNC_NAME s_scm_atan
8889 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8890 return z
; /* atan(exact0) = exact0 */
8891 else if (scm_is_real (z
))
8892 return scm_from_double (atan (scm_to_double (z
)));
8893 else if (SCM_COMPLEXP (z
))
8896 v
= SCM_COMPLEX_REAL (z
);
8897 w
= SCM_COMPLEX_IMAG (z
);
8898 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8899 scm_c_make_rectangular (v
, w
+ 1.0))),
8900 scm_c_make_rectangular (0, 2));
8903 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8905 else if (scm_is_real (z
))
8907 if (scm_is_real (y
))
8908 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8910 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8913 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8917 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8919 "Compute the inverse hyperbolic sine of @var{z}.")
8920 #define FUNC_NAME s_scm_sys_asinh
8922 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8923 return z
; /* asinh(exact0) = exact0 */
8924 else if (scm_is_real (z
))
8925 return scm_from_double (asinh (scm_to_double (z
)));
8926 else if (scm_is_number (z
))
8927 return scm_log (scm_sum (z
,
8928 scm_sqrt (scm_sum (scm_product (z
, z
),
8931 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8935 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8937 "Compute the inverse hyperbolic cosine of @var{z}.")
8938 #define FUNC_NAME s_scm_sys_acosh
8940 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8941 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8942 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8943 return scm_from_double (acosh (scm_to_double (z
)));
8944 else if (scm_is_number (z
))
8945 return scm_log (scm_sum (z
,
8946 scm_sqrt (scm_difference (scm_product (z
, z
),
8949 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8953 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8955 "Compute the inverse hyperbolic tangent of @var{z}.")
8956 #define FUNC_NAME s_scm_sys_atanh
8958 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8959 return z
; /* atanh(exact0) = exact0 */
8960 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8961 return scm_from_double (atanh (scm_to_double (z
)));
8962 else if (scm_is_number (z
))
8963 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8964 scm_difference (SCM_INUM1
, z
))),
8967 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8972 scm_c_make_rectangular (double re
, double im
)
8976 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8978 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8979 SCM_COMPLEX_REAL (z
) = re
;
8980 SCM_COMPLEX_IMAG (z
) = im
;
8984 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8985 (SCM real_part
, SCM imaginary_part
),
8986 "Return a complex number constructed of the given @var{real_part} "
8987 "and @var{imaginary_part} parts.")
8988 #define FUNC_NAME s_scm_make_rectangular
8990 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8991 SCM_ARG1
, FUNC_NAME
, "real");
8992 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8993 SCM_ARG2
, FUNC_NAME
, "real");
8995 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8996 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8999 return scm_c_make_rectangular (scm_to_double (real_part
),
9000 scm_to_double (imaginary_part
));
9005 scm_c_make_polar (double mag
, double ang
)
9009 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9010 use it on Glibc-based systems that have it (it's a GNU extension). See
9011 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9013 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9014 sincos (ang
, &s
, &c
);
9020 /* If s and c are NaNs, this indicates that the angle is a NaN,
9021 infinite, or perhaps simply too large to determine its value
9022 mod 2*pi. However, we know something that the floating-point
9023 implementation doesn't know: We know that s and c are finite.
9024 Therefore, if the magnitude is zero, return a complex zero.
9026 The reason we check for the NaNs instead of using this case
9027 whenever mag == 0.0 is because when the angle is known, we'd
9028 like to return the correct kind of non-real complex zero:
9029 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9030 on which quadrant the angle is in.
9032 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9033 return scm_c_make_rectangular (0.0, 0.0);
9035 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9038 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9040 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9041 #define FUNC_NAME s_scm_make_polar
9043 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9044 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9046 /* If mag is exact0, return exact0 */
9047 if (scm_is_eq (mag
, SCM_INUM0
))
9049 /* Return a real if ang is exact0 */
9050 else if (scm_is_eq (ang
, SCM_INUM0
))
9053 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9058 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9060 "Return the real part of the number @var{z}.")
9061 #define FUNC_NAME s_scm_real_part
9063 if (SCM_COMPLEXP (z
))
9064 return scm_from_double (SCM_COMPLEX_REAL (z
));
9065 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9068 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9073 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9075 "Return the imaginary part of the number @var{z}.")
9076 #define FUNC_NAME s_scm_imag_part
9078 if (SCM_COMPLEXP (z
))
9079 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9080 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9083 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9087 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9089 "Return the numerator of the number @var{z}.")
9090 #define FUNC_NAME s_scm_numerator
9092 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9094 else if (SCM_FRACTIONP (z
))
9095 return SCM_FRACTION_NUMERATOR (z
);
9096 else if (SCM_REALP (z
))
9097 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9099 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9104 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9106 "Return the denominator of the number @var{z}.")
9107 #define FUNC_NAME s_scm_denominator
9109 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9111 else if (SCM_FRACTIONP (z
))
9112 return SCM_FRACTION_DENOMINATOR (z
);
9113 else if (SCM_REALP (z
))
9114 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9116 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
9122 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9124 "Return the magnitude of the number @var{z}. This is the same as\n"
9125 "@code{abs} for real arguments, but also allows complex numbers.")
9126 #define FUNC_NAME s_scm_magnitude
9128 if (SCM_I_INUMP (z
))
9130 scm_t_inum zz
= SCM_I_INUM (z
);
9133 else if (SCM_POSFIXABLE (-zz
))
9134 return SCM_I_MAKINUM (-zz
);
9136 return scm_i_inum2big (-zz
);
9138 else if (SCM_BIGP (z
))
9140 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9141 scm_remember_upto_here_1 (z
);
9143 return scm_i_clonebig (z
, 0);
9147 else if (SCM_REALP (z
))
9148 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9149 else if (SCM_COMPLEXP (z
))
9150 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9151 else if (SCM_FRACTIONP (z
))
9153 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9155 return scm_i_make_ratio_already_reduced
9156 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9157 SCM_FRACTION_DENOMINATOR (z
));
9160 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
9166 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9168 "Return the angle of the complex number @var{z}.")
9169 #define FUNC_NAME s_scm_angle
9171 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9172 flo0 to save allocating a new flonum with scm_from_double each time.
9173 But if atan2 follows the floating point rounding mode, then the value
9174 is not a constant. Maybe it'd be close enough though. */
9175 if (SCM_I_INUMP (z
))
9177 if (SCM_I_INUM (z
) >= 0)
9180 return scm_from_double (atan2 (0.0, -1.0));
9182 else if (SCM_BIGP (z
))
9184 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9185 scm_remember_upto_here_1 (z
);
9187 return scm_from_double (atan2 (0.0, -1.0));
9191 else if (SCM_REALP (z
))
9193 double x
= SCM_REAL_VALUE (z
);
9194 if (x
> 0.0 || double_is_non_negative_zero (x
))
9197 return scm_from_double (atan2 (0.0, -1.0));
9199 else if (SCM_COMPLEXP (z
))
9200 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9201 else if (SCM_FRACTIONP (z
))
9203 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9205 else return scm_from_double (atan2 (0.0, -1.0));
9208 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9213 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9215 "Convert the number @var{z} to its inexact representation.\n")
9216 #define FUNC_NAME s_scm_exact_to_inexact
9218 if (SCM_I_INUMP (z
))
9219 return scm_from_double ((double) SCM_I_INUM (z
));
9220 else if (SCM_BIGP (z
))
9221 return scm_from_double (scm_i_big2dbl (z
));
9222 else if (SCM_FRACTIONP (z
))
9223 return scm_from_double (scm_i_fraction2double (z
));
9224 else if (SCM_INEXACTP (z
))
9227 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
9228 s_scm_exact_to_inexact
);
9233 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9235 "Return an exact number that is numerically closest to @var{z}.")
9236 #define FUNC_NAME s_scm_inexact_to_exact
9238 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9245 val
= SCM_REAL_VALUE (z
);
9246 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9247 val
= SCM_COMPLEX_REAL (z
);
9249 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
9250 s_scm_inexact_to_exact
);
9252 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9253 SCM_OUT_OF_RANGE (1, z
);
9254 else if (val
== 0.0)
9261 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9263 expon
-= DBL_MANT_DIG
;
9266 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9270 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9271 SCM_I_BIG_MPZ (numerator
),
9275 numerator
= scm_i_normbig (numerator
);
9277 return scm_i_make_ratio_already_reduced
9278 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9280 return left_shift_exact_integer (numerator
, expon
);
9288 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9290 "Returns the @emph{simplest} rational number differing\n"
9291 "from @var{x} by no more than @var{eps}.\n"
9293 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9294 "exact result when both its arguments are exact. Thus, you might need\n"
9295 "to use @code{inexact->exact} on the arguments.\n"
9298 "(rationalize (inexact->exact 1.2) 1/100)\n"
9301 #define FUNC_NAME s_scm_rationalize
9303 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9304 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9305 eps
= scm_abs (eps
);
9306 if (scm_is_false (scm_positive_p (eps
)))
9308 /* eps is either zero or a NaN */
9309 if (scm_is_true (scm_nan_p (eps
)))
9311 else if (SCM_INEXACTP (eps
))
9312 return scm_exact_to_inexact (x
);
9316 else if (scm_is_false (scm_finite_p (eps
)))
9318 if (scm_is_true (scm_finite_p (x
)))
9323 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9325 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9326 scm_ceiling (scm_difference (x
, eps
)))))
9328 /* There's an integer within range; we want the one closest to zero */
9329 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9331 /* zero is within range */
9332 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9337 else if (scm_is_true (scm_positive_p (x
)))
9338 return scm_ceiling (scm_difference (x
, eps
));
9340 return scm_floor (scm_sum (x
, eps
));
9344 /* Use continued fractions to find closest ratio. All
9345 arithmetic is done with exact numbers.
9348 SCM ex
= scm_inexact_to_exact (x
);
9349 SCM int_part
= scm_floor (ex
);
9351 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9352 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9356 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9357 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9359 /* We stop after a million iterations just to be absolutely sure
9360 that we don't go into an infinite loop. The process normally
9361 converges after less than a dozen iterations.
9364 while (++i
< 1000000)
9366 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9367 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9368 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9370 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9371 eps
))) /* abs(x-a/b) <= eps */
9373 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9374 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9375 return scm_exact_to_inexact (res
);
9379 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9381 tt
= scm_floor (rx
); /* tt = floor (rx) */
9387 scm_num_overflow (s_scm_rationalize
);
9392 /* conversion functions */
9395 scm_is_integer (SCM val
)
9397 return scm_is_true (scm_integer_p (val
));
9401 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9403 if (SCM_I_INUMP (val
))
9405 scm_t_signed_bits n
= SCM_I_INUM (val
);
9406 return n
>= min
&& n
<= max
;
9408 else if (SCM_BIGP (val
))
9410 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9412 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9414 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9416 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9417 return n
>= min
&& n
<= max
;
9427 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9428 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9431 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9432 SCM_I_BIG_MPZ (val
));
9434 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9446 return n
>= min
&& n
<= max
;
9454 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9456 if (SCM_I_INUMP (val
))
9458 scm_t_signed_bits n
= SCM_I_INUM (val
);
9459 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9461 else if (SCM_BIGP (val
))
9463 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9465 else if (max
<= ULONG_MAX
)
9467 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9469 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9470 return n
>= min
&& n
<= max
;
9480 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9483 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9484 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9487 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9488 SCM_I_BIG_MPZ (val
));
9490 return n
>= min
&& n
<= max
;
9498 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9500 scm_error (scm_out_of_range_key
,
9502 "Value out of range ~S to ~S: ~S",
9503 scm_list_3 (min
, max
, bad_val
),
9504 scm_list_1 (bad_val
));
9507 #define TYPE scm_t_intmax
9508 #define TYPE_MIN min
9509 #define TYPE_MAX max
9510 #define SIZEOF_TYPE 0
9511 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9512 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9513 #include "libguile/conv-integer.i.c"
9515 #define TYPE scm_t_uintmax
9516 #define TYPE_MIN min
9517 #define TYPE_MAX max
9518 #define SIZEOF_TYPE 0
9519 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9520 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9521 #include "libguile/conv-uinteger.i.c"
9523 #define TYPE scm_t_int8
9524 #define TYPE_MIN SCM_T_INT8_MIN
9525 #define TYPE_MAX SCM_T_INT8_MAX
9526 #define SIZEOF_TYPE 1
9527 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9528 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9529 #include "libguile/conv-integer.i.c"
9531 #define TYPE scm_t_uint8
9533 #define TYPE_MAX SCM_T_UINT8_MAX
9534 #define SIZEOF_TYPE 1
9535 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9536 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9537 #include "libguile/conv-uinteger.i.c"
9539 #define TYPE scm_t_int16
9540 #define TYPE_MIN SCM_T_INT16_MIN
9541 #define TYPE_MAX SCM_T_INT16_MAX
9542 #define SIZEOF_TYPE 2
9543 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9544 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9545 #include "libguile/conv-integer.i.c"
9547 #define TYPE scm_t_uint16
9549 #define TYPE_MAX SCM_T_UINT16_MAX
9550 #define SIZEOF_TYPE 2
9551 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9552 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9553 #include "libguile/conv-uinteger.i.c"
9555 #define TYPE scm_t_int32
9556 #define TYPE_MIN SCM_T_INT32_MIN
9557 #define TYPE_MAX SCM_T_INT32_MAX
9558 #define SIZEOF_TYPE 4
9559 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9560 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9561 #include "libguile/conv-integer.i.c"
9563 #define TYPE scm_t_uint32
9565 #define TYPE_MAX SCM_T_UINT32_MAX
9566 #define SIZEOF_TYPE 4
9567 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9568 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9569 #include "libguile/conv-uinteger.i.c"
9571 #define TYPE scm_t_wchar
9572 #define TYPE_MIN (scm_t_int32)-1
9573 #define TYPE_MAX (scm_t_int32)0x10ffff
9574 #define SIZEOF_TYPE 4
9575 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9576 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9577 #include "libguile/conv-integer.i.c"
9579 #define TYPE scm_t_int64
9580 #define TYPE_MIN SCM_T_INT64_MIN
9581 #define TYPE_MAX SCM_T_INT64_MAX
9582 #define SIZEOF_TYPE 8
9583 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9584 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9585 #include "libguile/conv-integer.i.c"
9587 #define TYPE scm_t_uint64
9589 #define TYPE_MAX SCM_T_UINT64_MAX
9590 #define SIZEOF_TYPE 8
9591 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9592 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9593 #include "libguile/conv-uinteger.i.c"
9596 scm_to_mpz (SCM val
, mpz_t rop
)
9598 if (SCM_I_INUMP (val
))
9599 mpz_set_si (rop
, SCM_I_INUM (val
));
9600 else if (SCM_BIGP (val
))
9601 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9603 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9607 scm_from_mpz (mpz_t val
)
9609 return scm_i_mpz2num (val
);
9613 scm_is_real (SCM val
)
9615 return scm_is_true (scm_real_p (val
));
9619 scm_is_rational (SCM val
)
9621 return scm_is_true (scm_rational_p (val
));
9625 scm_to_double (SCM val
)
9627 if (SCM_I_INUMP (val
))
9628 return SCM_I_INUM (val
);
9629 else if (SCM_BIGP (val
))
9630 return scm_i_big2dbl (val
);
9631 else if (SCM_FRACTIONP (val
))
9632 return scm_i_fraction2double (val
);
9633 else if (SCM_REALP (val
))
9634 return SCM_REAL_VALUE (val
);
9636 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9640 scm_from_double (double val
)
9644 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9646 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9647 SCM_REAL_VALUE (z
) = val
;
9653 scm_is_complex (SCM val
)
9655 return scm_is_true (scm_complex_p (val
));
9659 scm_c_real_part (SCM z
)
9661 if (SCM_COMPLEXP (z
))
9662 return SCM_COMPLEX_REAL (z
);
9665 /* Use the scm_real_part to get proper error checking and
9668 return scm_to_double (scm_real_part (z
));
9673 scm_c_imag_part (SCM z
)
9675 if (SCM_COMPLEXP (z
))
9676 return SCM_COMPLEX_IMAG (z
);
9679 /* Use the scm_imag_part to get proper error checking and
9680 dispatching. The result will almost always be 0.0, but not
9683 return scm_to_double (scm_imag_part (z
));
9688 scm_c_magnitude (SCM z
)
9690 return scm_to_double (scm_magnitude (z
));
9696 return scm_to_double (scm_angle (z
));
9700 scm_is_number (SCM z
)
9702 return scm_is_true (scm_number_p (z
));
9706 /* Returns log(x * 2^shift) */
9708 log_of_shifted_double (double x
, long shift
)
9710 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9712 if (x
> 0.0 || double_is_non_negative_zero (x
))
9713 return scm_from_double (ans
);
9715 return scm_c_make_rectangular (ans
, M_PI
);
9718 /* Returns log(n), for exact integer n */
9720 log_of_exact_integer (SCM n
)
9722 if (SCM_I_INUMP (n
))
9723 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9724 else if (SCM_BIGP (n
))
9727 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9728 return log_of_shifted_double (signif
, expon
);
9731 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9734 /* Returns log(n/d), for exact non-zero integers n and d */
9736 log_of_fraction (SCM n
, SCM d
)
9738 long n_size
= scm_to_long (scm_integer_length (n
));
9739 long d_size
= scm_to_long (scm_integer_length (d
));
9741 if (abs (n_size
- d_size
) > 1)
9742 return (scm_difference (log_of_exact_integer (n
),
9743 log_of_exact_integer (d
)));
9744 else if (scm_is_false (scm_negative_p (n
)))
9745 return scm_from_double
9746 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9748 return scm_c_make_rectangular
9749 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9755 /* In the following functions we dispatch to the real-arg funcs like log()
9756 when we know the arg is real, instead of just handing everything to
9757 clog() for instance. This is in case clog() doesn't optimize for a
9758 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9759 well use it to go straight to the applicable C func. */
9761 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9763 "Return the natural logarithm of @var{z}.")
9764 #define FUNC_NAME s_scm_log
9766 if (SCM_COMPLEXP (z
))
9768 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9769 && defined (SCM_COMPLEX_VALUE)
9770 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9772 double re
= SCM_COMPLEX_REAL (z
);
9773 double im
= SCM_COMPLEX_IMAG (z
);
9774 return scm_c_make_rectangular (log (hypot (re
, im
)),
9778 else if (SCM_REALP (z
))
9779 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9780 else if (SCM_I_INUMP (z
))
9782 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9783 if (scm_is_eq (z
, SCM_INUM0
))
9784 scm_num_overflow (s_scm_log
);
9786 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9788 else if (SCM_BIGP (z
))
9789 return log_of_exact_integer (z
);
9790 else if (SCM_FRACTIONP (z
))
9791 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9792 SCM_FRACTION_DENOMINATOR (z
));
9794 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9799 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9801 "Return the base 10 logarithm of @var{z}.")
9802 #define FUNC_NAME s_scm_log10
9804 if (SCM_COMPLEXP (z
))
9806 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9807 clog() and a multiply by M_LOG10E, rather than the fallback
9808 log10+hypot+atan2.) */
9809 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9810 && defined SCM_COMPLEX_VALUE
9811 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9813 double re
= SCM_COMPLEX_REAL (z
);
9814 double im
= SCM_COMPLEX_IMAG (z
);
9815 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9816 M_LOG10E
* atan2 (im
, re
));
9819 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9821 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9822 if (scm_is_eq (z
, SCM_INUM0
))
9823 scm_num_overflow (s_scm_log10
);
9826 double re
= scm_to_double (z
);
9827 double l
= log10 (fabs (re
));
9828 if (re
> 0.0 || double_is_non_negative_zero (re
))
9829 return scm_from_double (l
);
9831 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9834 else if (SCM_BIGP (z
))
9835 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9836 else if (SCM_FRACTIONP (z
))
9837 return scm_product (flo_log10e
,
9838 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9839 SCM_FRACTION_DENOMINATOR (z
)));
9841 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9846 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9848 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9849 "base of natural logarithms (2.71828@dots{}).")
9850 #define FUNC_NAME s_scm_exp
9852 if (SCM_COMPLEXP (z
))
9854 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9855 && defined (SCM_COMPLEX_VALUE)
9856 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9858 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9859 SCM_COMPLEX_IMAG (z
));
9862 else if (SCM_NUMBERP (z
))
9864 /* When z is a negative bignum the conversion to double overflows,
9865 giving -infinity, but that's ok, the exp is still 0.0. */
9866 return scm_from_double (exp (scm_to_double (z
)));
9869 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9874 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9876 "Return two exact non-negative integers @var{s} and @var{r}\n"
9877 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9878 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9879 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9882 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9884 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9888 scm_exact_integer_sqrt (k
, &s
, &r
);
9889 return scm_values (scm_list_2 (s
, r
));
9894 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9896 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9900 if (SCM_I_INUM (k
) < 0)
9901 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9902 "exact non-negative integer");
9903 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
9904 mpz_inits (ss
, rr
, NULL
);
9905 mpz_sqrtrem (ss
, rr
, kk
);
9906 *sp
= SCM_I_MAKINUM (mpz_get_ui (ss
));
9907 *rp
= SCM_I_MAKINUM (mpz_get_ui (rr
));
9908 mpz_clears (kk
, ss
, rr
, NULL
);
9910 else if (SCM_LIKELY (SCM_BIGP (k
)))
9914 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9915 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9916 "exact non-negative integer");
9919 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9920 scm_remember_upto_here_1 (k
);
9921 *sp
= scm_i_normbig (s
);
9922 *rp
= scm_i_normbig (r
);
9925 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9926 "exact non-negative integer");
9929 /* Return true iff K is a perfect square.
9930 K must be an exact integer. */
9932 exact_integer_is_perfect_square (SCM k
)
9936 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9940 mpz_init_set_si (kk
, SCM_I_INUM (k
));
9941 result
= mpz_perfect_square_p (kk
);
9946 result
= mpz_perfect_square_p (SCM_I_BIG_MPZ (k
));
9947 scm_remember_upto_here_1 (k
);
9952 /* Return the floor of the square root of K.
9953 K must be an exact integer. */
9955 exact_integer_floor_square_root (SCM k
)
9957 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9962 mpz_init_set_ui (kk
, SCM_I_INUM (k
));
9964 ss
= mpz_get_ui (kk
);
9966 return SCM_I_MAKINUM (ss
);
9973 mpz_sqrt (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (k
));
9974 scm_remember_upto_here_1 (k
);
9975 return scm_i_normbig (s
);
9980 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9982 "Return the square root of @var{z}. Of the two possible roots\n"
9983 "(positive and negative), the one with positive real part\n"
9984 "is returned, or if that's zero then a positive imaginary part.\n"
9988 "(sqrt 9.0) @result{} 3.0\n"
9989 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9990 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9991 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9993 #define FUNC_NAME s_scm_sqrt
9995 if (SCM_COMPLEXP (z
))
9997 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9998 && defined SCM_COMPLEX_VALUE
9999 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
10001 double re
= SCM_COMPLEX_REAL (z
);
10002 double im
= SCM_COMPLEX_IMAG (z
);
10003 return scm_c_make_polar (sqrt (hypot (re
, im
)),
10004 0.5 * atan2 (im
, re
));
10007 else if (SCM_NUMBERP (z
))
10009 if (SCM_I_INUMP (z
))
10011 scm_t_inum x
= SCM_I_INUM (z
);
10013 if (SCM_LIKELY (x
>= 0))
10015 if (SCM_LIKELY (SCM_I_FIXNUM_BIT
< DBL_MANT_DIG
10016 || x
< (1L << (DBL_MANT_DIG
- 1))))
10018 double root
= sqrt (x
);
10020 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10021 integer, then the result is exact. */
10022 if (root
== floor (root
))
10023 return SCM_I_MAKINUM ((scm_t_inum
) root
);
10025 return scm_from_double (root
);
10032 mpz_init_set_ui (xx
, x
);
10033 if (mpz_perfect_square_p (xx
))
10036 root
= mpz_get_ui (xx
);
10038 return SCM_I_MAKINUM (root
);
10045 else if (SCM_BIGP (z
))
10047 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z
)))
10049 SCM root
= scm_i_mkbig ();
10051 mpz_sqrt (SCM_I_BIG_MPZ (root
), SCM_I_BIG_MPZ (z
));
10052 scm_remember_upto_here_1 (z
);
10053 return scm_i_normbig (root
);
10058 double signif
= scm_i_big2dbl_2exp (z
, &expon
);
10066 return scm_c_make_rectangular
10067 (0.0, ldexp (sqrt (-signif
), expon
/ 2));
10069 return scm_from_double (ldexp (sqrt (signif
), expon
/ 2));
10072 else if (SCM_FRACTIONP (z
))
10074 SCM n
= SCM_FRACTION_NUMERATOR (z
);
10075 SCM d
= SCM_FRACTION_DENOMINATOR (z
);
10077 if (exact_integer_is_perfect_square (n
)
10078 && exact_integer_is_perfect_square (d
))
10079 return scm_i_make_ratio_already_reduced
10080 (exact_integer_floor_square_root (n
),
10081 exact_integer_floor_square_root (d
));
10084 double xx
= scm_i_divide2double (n
, d
);
10085 double abs_xx
= fabs (xx
);
10088 if (SCM_UNLIKELY (abs_xx
> DBL_MAX
|| abs_xx
< DBL_MIN
))
10090 shift
= (scm_to_long (scm_integer_length (n
))
10091 - scm_to_long (scm_integer_length (d
))) / 2;
10093 d
= left_shift_exact_integer (d
, 2 * shift
);
10095 n
= left_shift_exact_integer (n
, -2 * shift
);
10096 xx
= scm_i_divide2double (n
, d
);
10100 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx
), shift
));
10102 return scm_from_double (ldexp (sqrt (xx
), shift
));
10106 /* Fallback method, when the cases above do not apply. */
10108 double xx
= scm_to_double (z
);
10110 return scm_c_make_rectangular (0.0, sqrt (-xx
));
10112 return scm_from_double (sqrt (xx
));
10116 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10123 scm_init_numbers ()
10125 if (scm_install_gmp_memory_functions
)
10126 mp_set_memory_functions (custom_gmp_malloc
,
10127 custom_gmp_realloc
,
10130 mpz_init_set_si (z_negative_one
, -1);
10132 /* It may be possible to tune the performance of some algorithms by using
10133 * the following constants to avoid the creation of bignums. Please, before
10134 * using these values, remember the two rules of program optimization:
10135 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10136 scm_c_define ("most-positive-fixnum",
10137 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10138 scm_c_define ("most-negative-fixnum",
10139 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10141 scm_add_feature ("complex");
10142 scm_add_feature ("inexact");
10143 flo0
= scm_from_double (0.0);
10144 flo_log10e
= scm_from_double (M_LOG10E
);
10146 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10149 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10150 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10151 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10152 scm_i_divide2double_lo2b
,
10153 DBL_MANT_DIG
+ 1); /* 2 b^p */
10154 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10158 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10159 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10160 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10161 dbl_minimum_normal_mantissa
,
10165 #include "libguile/numbers.x"
10170 c-file-style: "gnu"