1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 /* FIXME: We assume that FLT_RADIX is 2 */
85 verify (FLT_RADIX
== 2);
87 typedef scm_t_signed_bits scm_t_inum
;
88 #define scm_from_inum(x) (scm_from_signed_integer (x))
90 /* Tests to see if a C double is neither infinite nor a NaN.
91 TODO: if it's available, use C99's isfinite(x) instead */
92 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
94 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
95 of the infinity, but other platforms return a boolean only. */
96 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
97 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
102 Wonder if this might be faster for some of our code? A switch on
103 the numtag would jump directly to the right case, and the
104 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
106 #define SCM_I_NUMTAG_NOTNUM 0
107 #define SCM_I_NUMTAG_INUM 1
108 #define SCM_I_NUMTAG_BIG scm_tc16_big
109 #define SCM_I_NUMTAG_REAL scm_tc16_real
110 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
111 #define SCM_I_NUMTAG(x) \
112 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
113 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
114 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
115 : SCM_I_NUMTAG_NOTNUM)))
117 /* the macro above will not work as is with fractions */
120 /* Default to 1, because as we used to hard-code `free' as the
121 deallocator, we know that overriding these functions with
122 instrumented `malloc' / `free' is OK. */
123 int scm_install_gmp_memory_functions
= 1;
125 static SCM exactly_one_half
;
126 static SCM flo_log10e
;
128 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
130 /* FLOBUFLEN is the maximum number of characters neccessary for the
131 * printed or scm_string representation of an inexact number.
133 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
136 #if !defined (HAVE_ASINH)
137 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
139 #if !defined (HAVE_ACOSH)
140 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
142 #if !defined (HAVE_ATANH)
143 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
146 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
147 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
148 in March 2006), mpz_cmp_d now handles infinities properly. */
150 #define xmpz_cmp_d(z, d) \
151 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
153 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
157 #if defined (GUILE_I)
158 #if defined HAVE_COMPLEX_DOUBLE
160 /* For an SCM object Z which is a complex number (ie. satisfies
161 SCM_COMPLEXP), return its value as a C level "complex double". */
162 #define SCM_COMPLEX_VALUE(z) \
163 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
165 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
167 /* Convert a C "complex double" to an SCM value. */
169 scm_from_complex_double (complex double z
)
171 return scm_c_make_rectangular (creal (z
), cimag (z
));
174 #endif /* HAVE_COMPLEX_DOUBLE */
179 static mpz_t z_negative_one
;
183 /* Clear the `mpz_t' embedded in bignum PTR. */
185 finalize_bignum (void *ptr
, void *data
)
189 bignum
= PTR2SCM (ptr
);
190 mpz_clear (SCM_I_BIG_MPZ (bignum
));
193 /* The next three functions (custom_libgmp_*) are passed to
194 mp_set_memory_functions (in GMP) so that memory used by the digits
195 themselves is known to the garbage collector. This is needed so
196 that GC will be run at appropriate times. Otherwise, a program which
197 creates many large bignums would malloc a huge amount of memory
198 before the GC runs. */
200 custom_gmp_malloc (size_t alloc_size
)
202 return scm_malloc (alloc_size
);
206 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
208 return scm_realloc (old_ptr
, new_size
);
212 custom_gmp_free (void *ptr
, size_t size
)
218 /* Return a new uninitialized bignum. */
224 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
225 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
229 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
238 /* Return a newly created bignum. */
239 SCM z
= make_bignum ();
240 mpz_init (SCM_I_BIG_MPZ (z
));
245 scm_i_inum2big (scm_t_inum x
)
247 /* Return a newly created bignum initialized to X. */
248 SCM z
= make_bignum ();
249 #if SIZEOF_VOID_P == SIZEOF_LONG
250 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
252 /* Note that in this case, you'll also have to check all mpz_*_ui and
253 mpz_*_si invocations in Guile. */
254 #error creation of mpz not implemented for this inum size
260 scm_i_long2big (long x
)
262 /* Return a newly created bignum initialized to X. */
263 SCM z
= make_bignum ();
264 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
269 scm_i_ulong2big (unsigned long x
)
271 /* Return a newly created bignum initialized to X. */
272 SCM z
= make_bignum ();
273 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
278 scm_i_clonebig (SCM src_big
, int same_sign_p
)
280 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
281 SCM z
= make_bignum ();
282 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
284 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
289 scm_i_bigcmp (SCM x
, SCM y
)
291 /* Return neg if x < y, pos if x > y, and 0 if x == y */
292 /* presume we already know x and y are bignums */
293 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
294 scm_remember_upto_here_2 (x
, y
);
299 scm_i_dbl2big (double d
)
301 /* results are only defined if d is an integer */
302 SCM z
= make_bignum ();
303 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
307 /* Convert a integer in double representation to a SCM number. */
310 scm_i_dbl2num (double u
)
312 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
313 powers of 2, so there's no rounding when making "double" values
314 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
315 get rounded on a 64-bit machine, hence the "+1".
317 The use of floor() to force to an integer value ensures we get a
318 "numerically closest" value without depending on how a
319 double->long cast or how mpz_set_d will round. For reference,
320 double->long probably follows the hardware rounding mode,
321 mpz_set_d truncates towards zero. */
323 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
324 representable as a double? */
326 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
327 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
328 return SCM_I_MAKINUM ((scm_t_inum
) u
);
330 return scm_i_dbl2big (u
);
333 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
335 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
336 bignum b into a normalized significand and exponent such that
337 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
338 The return value is the significand rounded to the closest
339 representable double, and the exponent is placed into *expon_p.
340 If b is zero, then the returned exponent and significand are both
344 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
346 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
349 if (bits
> DBL_MANT_DIG
)
351 shift
= bits
- DBL_MANT_DIG
;
352 b
= round_right_shift_exact_integer (b
, shift
);
356 double signif
= frexp (SCM_I_INUM (b
), &expon
);
357 *expon_p
= expon
+ shift
;
364 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
365 scm_remember_upto_here_1 (b
);
366 *expon_p
= expon
+ shift
;
371 /* scm_i_big2dbl() rounds to the closest representable double,
372 in accordance with R5RS exact->inexact. */
374 scm_i_big2dbl (SCM b
)
377 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
378 return ldexp (signif
, expon
);
382 scm_i_normbig (SCM b
)
384 /* convert a big back to a fixnum if it'll fit */
385 /* presume b is a bignum */
386 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
388 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
389 if (SCM_FIXABLE (val
))
390 b
= SCM_I_MAKINUM (val
);
395 static SCM_C_INLINE_KEYWORD SCM
396 scm_i_mpz2num (mpz_t b
)
398 /* convert a mpz number to a SCM number. */
399 if (mpz_fits_slong_p (b
))
401 scm_t_inum val
= mpz_get_si (b
);
402 if (SCM_FIXABLE (val
))
403 return SCM_I_MAKINUM (val
);
407 SCM z
= make_bignum ();
408 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
413 /* Make the ratio NUMERATOR/DENOMINATOR, where:
414 1. NUMERATOR and DENOMINATOR are exact integers
415 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
417 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
419 /* Flip signs so that the denominator is positive. */
420 if (scm_is_false (scm_positive_p (denominator
)))
422 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
423 scm_num_overflow ("make-ratio");
426 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
427 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
431 /* Check for the integer case */
432 if (scm_is_eq (denominator
, SCM_INUM1
))
435 return scm_double_cell (scm_tc16_fraction
,
436 SCM_UNPACK (numerator
),
437 SCM_UNPACK (denominator
), 0);
440 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
442 /* Make the ratio NUMERATOR/DENOMINATOR */
444 scm_i_make_ratio (SCM numerator
, SCM denominator
)
445 #define FUNC_NAME "make-ratio"
447 /* Make sure the arguments are proper */
448 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
449 SCM_WRONG_TYPE_ARG (1, numerator
);
450 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
451 SCM_WRONG_TYPE_ARG (2, denominator
);
454 SCM the_gcd
= scm_gcd (numerator
, denominator
);
455 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
457 /* Reduce to lowest terms */
458 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
459 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
461 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
466 static mpz_t scm_i_divide2double_lo2b
;
468 /* Return the double that is closest to the exact rational N/D, with
469 ties rounded toward even mantissas. N and D must be exact
472 scm_i_divide2double (SCM n
, SCM d
)
475 mpz_t nn
, dd
, lo
, hi
, x
;
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 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 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 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 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 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 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 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 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 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
925 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 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
946 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 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
968 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 if (SCM_UNPACK (gf
))
1068 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
1070 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1073 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
1075 "Return the integer @var{q} such that\n"
1076 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1077 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1079 "(euclidean-quotient 123 10) @result{} 12\n"
1080 "(euclidean-quotient 123 -10) @result{} -12\n"
1081 "(euclidean-quotient -123 10) @result{} -13\n"
1082 "(euclidean-quotient -123 -10) @result{} 13\n"
1083 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1084 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1086 #define FUNC_NAME s_scm_euclidean_quotient
1088 if (scm_is_false (scm_negative_p (y
)))
1089 return scm_floor_quotient (x
, y
);
1091 return scm_ceiling_quotient (x
, y
);
1095 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
1097 "Return the real number @var{r} such that\n"
1098 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1099 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1100 "for some integer @var{q}.\n"
1102 "(euclidean-remainder 123 10) @result{} 3\n"
1103 "(euclidean-remainder 123 -10) @result{} 3\n"
1104 "(euclidean-remainder -123 10) @result{} 7\n"
1105 "(euclidean-remainder -123 -10) @result{} 7\n"
1106 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1107 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1109 #define FUNC_NAME s_scm_euclidean_remainder
1111 if (scm_is_false (scm_negative_p (y
)))
1112 return scm_floor_remainder (x
, y
);
1114 return scm_ceiling_remainder (x
, y
);
1118 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1120 "Return the integer @var{q} and the real number @var{r}\n"
1121 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1122 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1124 "(euclidean/ 123 10) @result{} 12 and 3\n"
1125 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1126 "(euclidean/ -123 10) @result{} -13 and 7\n"
1127 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1128 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1129 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1131 #define FUNC_NAME s_scm_i_euclidean_divide
1133 if (scm_is_false (scm_negative_p (y
)))
1134 return scm_i_floor_divide (x
, y
);
1136 return scm_i_ceiling_divide (x
, y
);
1141 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1143 if (scm_is_false (scm_negative_p (y
)))
1144 return scm_floor_divide (x
, y
, qp
, rp
);
1146 return scm_ceiling_divide (x
, y
, qp
, rp
);
1149 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1150 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1152 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1154 "Return the floor of @math{@var{x} / @var{y}}.\n"
1156 "(floor-quotient 123 10) @result{} 12\n"
1157 "(floor-quotient 123 -10) @result{} -13\n"
1158 "(floor-quotient -123 10) @result{} -13\n"
1159 "(floor-quotient -123 -10) @result{} 12\n"
1160 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1161 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1163 #define FUNC_NAME s_scm_floor_quotient
1165 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1167 scm_t_inum xx
= SCM_I_INUM (x
);
1168 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1170 scm_t_inum yy
= SCM_I_INUM (y
);
1171 scm_t_inum xx1
= xx
;
1173 if (SCM_LIKELY (yy
> 0))
1175 if (SCM_UNLIKELY (xx
< 0))
1178 else if (SCM_UNLIKELY (yy
== 0))
1179 scm_num_overflow (s_scm_floor_quotient
);
1183 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1184 return SCM_I_MAKINUM (qq
);
1186 return scm_i_inum2big (qq
);
1188 else if (SCM_BIGP (y
))
1190 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1191 scm_remember_upto_here_1 (y
);
1193 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1195 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1197 else if (SCM_REALP (y
))
1198 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1199 else if (SCM_FRACTIONP (y
))
1200 return scm_i_exact_rational_floor_quotient (x
, y
);
1202 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1203 s_scm_floor_quotient
);
1205 else if (SCM_BIGP (x
))
1207 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1209 scm_t_inum yy
= SCM_I_INUM (y
);
1210 if (SCM_UNLIKELY (yy
== 0))
1211 scm_num_overflow (s_scm_floor_quotient
);
1212 else if (SCM_UNLIKELY (yy
== 1))
1216 SCM q
= scm_i_mkbig ();
1218 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1221 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1222 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1224 scm_remember_upto_here_1 (x
);
1225 return scm_i_normbig (q
);
1228 else if (SCM_BIGP (y
))
1230 SCM q
= scm_i_mkbig ();
1231 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1234 scm_remember_upto_here_2 (x
, y
);
1235 return scm_i_normbig (q
);
1237 else if (SCM_REALP (y
))
1238 return scm_i_inexact_floor_quotient
1239 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1240 else if (SCM_FRACTIONP (y
))
1241 return scm_i_exact_rational_floor_quotient (x
, y
);
1243 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1244 s_scm_floor_quotient
);
1246 else if (SCM_REALP (x
))
1248 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1249 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1250 return scm_i_inexact_floor_quotient
1251 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1253 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1254 s_scm_floor_quotient
);
1256 else if (SCM_FRACTIONP (x
))
1259 return scm_i_inexact_floor_quotient
1260 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1261 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1262 return scm_i_exact_rational_floor_quotient (x
, y
);
1264 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1265 s_scm_floor_quotient
);
1268 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1269 s_scm_floor_quotient
);
1274 scm_i_inexact_floor_quotient (double x
, double y
)
1276 if (SCM_UNLIKELY (y
== 0))
1277 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1279 return scm_from_double (floor (x
/ y
));
1283 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1285 return scm_floor_quotient
1286 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1287 scm_product (scm_numerator (y
), scm_denominator (x
)));
1290 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1291 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1293 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1295 "Return the real number @var{r} such that\n"
1296 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1297 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1299 "(floor-remainder 123 10) @result{} 3\n"
1300 "(floor-remainder 123 -10) @result{} -7\n"
1301 "(floor-remainder -123 10) @result{} 7\n"
1302 "(floor-remainder -123 -10) @result{} -3\n"
1303 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1304 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1306 #define FUNC_NAME s_scm_floor_remainder
1308 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1310 scm_t_inum xx
= SCM_I_INUM (x
);
1311 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1313 scm_t_inum yy
= SCM_I_INUM (y
);
1314 if (SCM_UNLIKELY (yy
== 0))
1315 scm_num_overflow (s_scm_floor_remainder
);
1318 scm_t_inum rr
= xx
% yy
;
1319 int needs_adjustment
;
1321 if (SCM_LIKELY (yy
> 0))
1322 needs_adjustment
= (rr
< 0);
1324 needs_adjustment
= (rr
> 0);
1326 if (needs_adjustment
)
1328 return SCM_I_MAKINUM (rr
);
1331 else if (SCM_BIGP (y
))
1333 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1334 scm_remember_upto_here_1 (y
);
1339 SCM r
= scm_i_mkbig ();
1340 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1341 scm_remember_upto_here_1 (y
);
1342 return scm_i_normbig (r
);
1351 SCM r
= scm_i_mkbig ();
1352 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1353 scm_remember_upto_here_1 (y
);
1354 return scm_i_normbig (r
);
1357 else if (SCM_REALP (y
))
1358 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1359 else if (SCM_FRACTIONP (y
))
1360 return scm_i_exact_rational_floor_remainder (x
, y
);
1362 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1363 s_scm_floor_remainder
);
1365 else if (SCM_BIGP (x
))
1367 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1369 scm_t_inum yy
= SCM_I_INUM (y
);
1370 if (SCM_UNLIKELY (yy
== 0))
1371 scm_num_overflow (s_scm_floor_remainder
);
1376 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1378 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1379 scm_remember_upto_here_1 (x
);
1380 return SCM_I_MAKINUM (rr
);
1383 else if (SCM_BIGP (y
))
1385 SCM r
= scm_i_mkbig ();
1386 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1389 scm_remember_upto_here_2 (x
, y
);
1390 return scm_i_normbig (r
);
1392 else if (SCM_REALP (y
))
1393 return scm_i_inexact_floor_remainder
1394 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1395 else if (SCM_FRACTIONP (y
))
1396 return scm_i_exact_rational_floor_remainder (x
, y
);
1398 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1399 s_scm_floor_remainder
);
1401 else if (SCM_REALP (x
))
1403 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1404 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1405 return scm_i_inexact_floor_remainder
1406 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1408 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1409 s_scm_floor_remainder
);
1411 else if (SCM_FRACTIONP (x
))
1414 return scm_i_inexact_floor_remainder
1415 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1416 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1417 return scm_i_exact_rational_floor_remainder (x
, y
);
1419 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1420 s_scm_floor_remainder
);
1423 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1424 s_scm_floor_remainder
);
1429 scm_i_inexact_floor_remainder (double x
, double y
)
1431 /* Although it would be more efficient to use fmod here, we can't
1432 because it would in some cases produce results inconsistent with
1433 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1434 close). In particular, when x is very close to a multiple of y,
1435 then r might be either 0.0 or y, but those two cases must
1436 correspond to different choices of q. If r = 0.0 then q must be
1437 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1438 and remainder chooses the other, it would be bad. */
1439 if (SCM_UNLIKELY (y
== 0))
1440 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1442 return scm_from_double (x
- y
* floor (x
/ y
));
1446 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1448 SCM xd
= scm_denominator (x
);
1449 SCM yd
= scm_denominator (y
);
1450 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1451 scm_product (scm_numerator (y
), xd
));
1452 return scm_divide (r1
, scm_product (xd
, yd
));
1456 static void scm_i_inexact_floor_divide (double x
, double y
,
1458 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1461 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1463 "Return the integer @var{q} and the real number @var{r}\n"
1464 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1465 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1467 "(floor/ 123 10) @result{} 12 and 3\n"
1468 "(floor/ 123 -10) @result{} -13 and -7\n"
1469 "(floor/ -123 10) @result{} -13 and 7\n"
1470 "(floor/ -123 -10) @result{} 12 and -3\n"
1471 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1472 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1474 #define FUNC_NAME s_scm_i_floor_divide
1478 scm_floor_divide(x
, y
, &q
, &r
);
1479 return scm_values (scm_list_2 (q
, r
));
1483 #define s_scm_floor_divide s_scm_i_floor_divide
1484 #define g_scm_floor_divide g_scm_i_floor_divide
1487 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1489 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1491 scm_t_inum xx
= SCM_I_INUM (x
);
1492 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1494 scm_t_inum yy
= SCM_I_INUM (y
);
1495 if (SCM_UNLIKELY (yy
== 0))
1496 scm_num_overflow (s_scm_floor_divide
);
1499 scm_t_inum qq
= xx
/ yy
;
1500 scm_t_inum rr
= xx
% yy
;
1501 int needs_adjustment
;
1503 if (SCM_LIKELY (yy
> 0))
1504 needs_adjustment
= (rr
< 0);
1506 needs_adjustment
= (rr
> 0);
1508 if (needs_adjustment
)
1514 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1515 *qp
= SCM_I_MAKINUM (qq
);
1517 *qp
= scm_i_inum2big (qq
);
1518 *rp
= SCM_I_MAKINUM (rr
);
1522 else if (SCM_BIGP (y
))
1524 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1525 scm_remember_upto_here_1 (y
);
1530 SCM r
= scm_i_mkbig ();
1531 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1532 scm_remember_upto_here_1 (y
);
1533 *qp
= SCM_I_MAKINUM (-1);
1534 *rp
= scm_i_normbig (r
);
1549 SCM r
= scm_i_mkbig ();
1550 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1551 scm_remember_upto_here_1 (y
);
1552 *qp
= SCM_I_MAKINUM (-1);
1553 *rp
= scm_i_normbig (r
);
1557 else if (SCM_REALP (y
))
1558 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1559 else if (SCM_FRACTIONP (y
))
1560 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1562 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1563 s_scm_floor_divide
, qp
, rp
);
1565 else if (SCM_BIGP (x
))
1567 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1569 scm_t_inum yy
= SCM_I_INUM (y
);
1570 if (SCM_UNLIKELY (yy
== 0))
1571 scm_num_overflow (s_scm_floor_divide
);
1574 SCM q
= scm_i_mkbig ();
1575 SCM r
= scm_i_mkbig ();
1577 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1578 SCM_I_BIG_MPZ (x
), yy
);
1581 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1582 SCM_I_BIG_MPZ (x
), -yy
);
1583 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1585 scm_remember_upto_here_1 (x
);
1586 *qp
= scm_i_normbig (q
);
1587 *rp
= scm_i_normbig (r
);
1591 else if (SCM_BIGP (y
))
1593 SCM q
= scm_i_mkbig ();
1594 SCM r
= scm_i_mkbig ();
1595 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1596 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1597 scm_remember_upto_here_2 (x
, y
);
1598 *qp
= scm_i_normbig (q
);
1599 *rp
= scm_i_normbig (r
);
1602 else if (SCM_REALP (y
))
1603 return scm_i_inexact_floor_divide
1604 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1605 else if (SCM_FRACTIONP (y
))
1606 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1608 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1609 s_scm_floor_divide
, qp
, rp
);
1611 else if (SCM_REALP (x
))
1613 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1614 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1615 return scm_i_inexact_floor_divide
1616 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1618 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1619 s_scm_floor_divide
, qp
, rp
);
1621 else if (SCM_FRACTIONP (x
))
1624 return scm_i_inexact_floor_divide
1625 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1626 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1627 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1629 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1630 s_scm_floor_divide
, qp
, rp
);
1633 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1634 s_scm_floor_divide
, qp
, rp
);
1638 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1640 if (SCM_UNLIKELY (y
== 0))
1641 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1644 double q
= floor (x
/ y
);
1645 double r
= x
- q
* y
;
1646 *qp
= scm_from_double (q
);
1647 *rp
= scm_from_double (r
);
1652 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1655 SCM xd
= scm_denominator (x
);
1656 SCM yd
= scm_denominator (y
);
1658 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1659 scm_product (scm_numerator (y
), xd
),
1661 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1664 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1665 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1667 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1669 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1671 "(ceiling-quotient 123 10) @result{} 13\n"
1672 "(ceiling-quotient 123 -10) @result{} -12\n"
1673 "(ceiling-quotient -123 10) @result{} -12\n"
1674 "(ceiling-quotient -123 -10) @result{} 13\n"
1675 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1676 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1678 #define FUNC_NAME s_scm_ceiling_quotient
1680 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1682 scm_t_inum xx
= SCM_I_INUM (x
);
1683 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1685 scm_t_inum yy
= SCM_I_INUM (y
);
1686 if (SCM_UNLIKELY (yy
== 0))
1687 scm_num_overflow (s_scm_ceiling_quotient
);
1690 scm_t_inum xx1
= xx
;
1692 if (SCM_LIKELY (yy
> 0))
1694 if (SCM_LIKELY (xx
>= 0))
1700 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1701 return SCM_I_MAKINUM (qq
);
1703 return scm_i_inum2big (qq
);
1706 else if (SCM_BIGP (y
))
1708 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1709 scm_remember_upto_here_1 (y
);
1710 if (SCM_LIKELY (sign
> 0))
1712 if (SCM_LIKELY (xx
> 0))
1714 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1715 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1716 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1718 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1719 scm_remember_upto_here_1 (y
);
1720 return SCM_I_MAKINUM (-1);
1730 else if (SCM_REALP (y
))
1731 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1732 else if (SCM_FRACTIONP (y
))
1733 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1735 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1736 s_scm_ceiling_quotient
);
1738 else if (SCM_BIGP (x
))
1740 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1742 scm_t_inum yy
= SCM_I_INUM (y
);
1743 if (SCM_UNLIKELY (yy
== 0))
1744 scm_num_overflow (s_scm_ceiling_quotient
);
1745 else if (SCM_UNLIKELY (yy
== 1))
1749 SCM q
= scm_i_mkbig ();
1751 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1754 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1755 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1757 scm_remember_upto_here_1 (x
);
1758 return scm_i_normbig (q
);
1761 else if (SCM_BIGP (y
))
1763 SCM q
= scm_i_mkbig ();
1764 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1767 scm_remember_upto_here_2 (x
, y
);
1768 return scm_i_normbig (q
);
1770 else if (SCM_REALP (y
))
1771 return scm_i_inexact_ceiling_quotient
1772 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1773 else if (SCM_FRACTIONP (y
))
1774 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1776 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1777 s_scm_ceiling_quotient
);
1779 else if (SCM_REALP (x
))
1781 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1782 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1783 return scm_i_inexact_ceiling_quotient
1784 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1786 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1787 s_scm_ceiling_quotient
);
1789 else if (SCM_FRACTIONP (x
))
1792 return scm_i_inexact_ceiling_quotient
1793 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1794 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1795 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1797 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1798 s_scm_ceiling_quotient
);
1801 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1802 s_scm_ceiling_quotient
);
1807 scm_i_inexact_ceiling_quotient (double x
, double y
)
1809 if (SCM_UNLIKELY (y
== 0))
1810 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1812 return scm_from_double (ceil (x
/ y
));
1816 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1818 return scm_ceiling_quotient
1819 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1820 scm_product (scm_numerator (y
), scm_denominator (x
)));
1823 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1824 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1826 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1828 "Return the real number @var{r} such that\n"
1829 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1830 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1832 "(ceiling-remainder 123 10) @result{} -7\n"
1833 "(ceiling-remainder 123 -10) @result{} 3\n"
1834 "(ceiling-remainder -123 10) @result{} -3\n"
1835 "(ceiling-remainder -123 -10) @result{} 7\n"
1836 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1837 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1839 #define FUNC_NAME s_scm_ceiling_remainder
1841 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1843 scm_t_inum xx
= SCM_I_INUM (x
);
1844 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1846 scm_t_inum yy
= SCM_I_INUM (y
);
1847 if (SCM_UNLIKELY (yy
== 0))
1848 scm_num_overflow (s_scm_ceiling_remainder
);
1851 scm_t_inum rr
= xx
% yy
;
1852 int needs_adjustment
;
1854 if (SCM_LIKELY (yy
> 0))
1855 needs_adjustment
= (rr
> 0);
1857 needs_adjustment
= (rr
< 0);
1859 if (needs_adjustment
)
1861 return SCM_I_MAKINUM (rr
);
1864 else if (SCM_BIGP (y
))
1866 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1867 scm_remember_upto_here_1 (y
);
1868 if (SCM_LIKELY (sign
> 0))
1870 if (SCM_LIKELY (xx
> 0))
1872 SCM r
= scm_i_mkbig ();
1873 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1874 scm_remember_upto_here_1 (y
);
1875 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1876 return scm_i_normbig (r
);
1878 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1879 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1880 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1882 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1883 scm_remember_upto_here_1 (y
);
1893 SCM r
= scm_i_mkbig ();
1894 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1895 scm_remember_upto_here_1 (y
);
1896 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1897 return scm_i_normbig (r
);
1900 else if (SCM_REALP (y
))
1901 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1902 else if (SCM_FRACTIONP (y
))
1903 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1905 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1906 s_scm_ceiling_remainder
);
1908 else if (SCM_BIGP (x
))
1910 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1912 scm_t_inum yy
= SCM_I_INUM (y
);
1913 if (SCM_UNLIKELY (yy
== 0))
1914 scm_num_overflow (s_scm_ceiling_remainder
);
1919 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1921 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1922 scm_remember_upto_here_1 (x
);
1923 return SCM_I_MAKINUM (rr
);
1926 else if (SCM_BIGP (y
))
1928 SCM r
= scm_i_mkbig ();
1929 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1932 scm_remember_upto_here_2 (x
, y
);
1933 return scm_i_normbig (r
);
1935 else if (SCM_REALP (y
))
1936 return scm_i_inexact_ceiling_remainder
1937 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1938 else if (SCM_FRACTIONP (y
))
1939 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1941 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1942 s_scm_ceiling_remainder
);
1944 else if (SCM_REALP (x
))
1946 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1947 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1948 return scm_i_inexact_ceiling_remainder
1949 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1951 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1952 s_scm_ceiling_remainder
);
1954 else if (SCM_FRACTIONP (x
))
1957 return scm_i_inexact_ceiling_remainder
1958 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1959 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1960 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1962 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1963 s_scm_ceiling_remainder
);
1966 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1967 s_scm_ceiling_remainder
);
1972 scm_i_inexact_ceiling_remainder (double x
, double y
)
1974 /* Although it would be more efficient to use fmod here, we can't
1975 because it would in some cases produce results inconsistent with
1976 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1977 close). In particular, when x is very close to a multiple of y,
1978 then r might be either 0.0 or -y, but those two cases must
1979 correspond to different choices of q. If r = 0.0 then q must be
1980 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1981 and remainder chooses the other, it would be bad. */
1982 if (SCM_UNLIKELY (y
== 0))
1983 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1985 return scm_from_double (x
- y
* ceil (x
/ y
));
1989 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1991 SCM xd
= scm_denominator (x
);
1992 SCM yd
= scm_denominator (y
);
1993 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1994 scm_product (scm_numerator (y
), xd
));
1995 return scm_divide (r1
, scm_product (xd
, yd
));
1998 static void scm_i_inexact_ceiling_divide (double x
, double y
,
2000 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
2003 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
2005 "Return the integer @var{q} and the real number @var{r}\n"
2006 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2007 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2009 "(ceiling/ 123 10) @result{} 13 and -7\n"
2010 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2011 "(ceiling/ -123 10) @result{} -12 and -3\n"
2012 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2013 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2014 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2016 #define FUNC_NAME s_scm_i_ceiling_divide
2020 scm_ceiling_divide(x
, y
, &q
, &r
);
2021 return scm_values (scm_list_2 (q
, r
));
2025 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2026 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2029 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2031 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2033 scm_t_inum xx
= SCM_I_INUM (x
);
2034 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2036 scm_t_inum yy
= SCM_I_INUM (y
);
2037 if (SCM_UNLIKELY (yy
== 0))
2038 scm_num_overflow (s_scm_ceiling_divide
);
2041 scm_t_inum qq
= xx
/ yy
;
2042 scm_t_inum rr
= xx
% yy
;
2043 int needs_adjustment
;
2045 if (SCM_LIKELY (yy
> 0))
2046 needs_adjustment
= (rr
> 0);
2048 needs_adjustment
= (rr
< 0);
2050 if (needs_adjustment
)
2055 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2056 *qp
= SCM_I_MAKINUM (qq
);
2058 *qp
= scm_i_inum2big (qq
);
2059 *rp
= SCM_I_MAKINUM (rr
);
2063 else if (SCM_BIGP (y
))
2065 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2066 scm_remember_upto_here_1 (y
);
2067 if (SCM_LIKELY (sign
> 0))
2069 if (SCM_LIKELY (xx
> 0))
2071 SCM r
= scm_i_mkbig ();
2072 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
2073 scm_remember_upto_here_1 (y
);
2074 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2076 *rp
= scm_i_normbig (r
);
2078 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2079 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2080 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2082 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2083 scm_remember_upto_here_1 (y
);
2084 *qp
= SCM_I_MAKINUM (-1);
2100 SCM r
= scm_i_mkbig ();
2101 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
2102 scm_remember_upto_here_1 (y
);
2103 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
2105 *rp
= scm_i_normbig (r
);
2109 else if (SCM_REALP (y
))
2110 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2111 else if (SCM_FRACTIONP (y
))
2112 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2114 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2115 s_scm_ceiling_divide
, qp
, rp
);
2117 else if (SCM_BIGP (x
))
2119 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2121 scm_t_inum yy
= SCM_I_INUM (y
);
2122 if (SCM_UNLIKELY (yy
== 0))
2123 scm_num_overflow (s_scm_ceiling_divide
);
2126 SCM q
= scm_i_mkbig ();
2127 SCM r
= scm_i_mkbig ();
2129 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2130 SCM_I_BIG_MPZ (x
), yy
);
2133 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2134 SCM_I_BIG_MPZ (x
), -yy
);
2135 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2137 scm_remember_upto_here_1 (x
);
2138 *qp
= scm_i_normbig (q
);
2139 *rp
= scm_i_normbig (r
);
2143 else if (SCM_BIGP (y
))
2145 SCM q
= scm_i_mkbig ();
2146 SCM r
= scm_i_mkbig ();
2147 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2148 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2149 scm_remember_upto_here_2 (x
, y
);
2150 *qp
= scm_i_normbig (q
);
2151 *rp
= scm_i_normbig (r
);
2154 else if (SCM_REALP (y
))
2155 return scm_i_inexact_ceiling_divide
2156 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2157 else if (SCM_FRACTIONP (y
))
2158 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2160 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2161 s_scm_ceiling_divide
, qp
, rp
);
2163 else if (SCM_REALP (x
))
2165 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2166 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2167 return scm_i_inexact_ceiling_divide
2168 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2170 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2171 s_scm_ceiling_divide
, qp
, rp
);
2173 else if (SCM_FRACTIONP (x
))
2176 return scm_i_inexact_ceiling_divide
2177 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2178 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2179 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2181 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2182 s_scm_ceiling_divide
, qp
, rp
);
2185 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2186 s_scm_ceiling_divide
, qp
, rp
);
2190 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2192 if (SCM_UNLIKELY (y
== 0))
2193 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2196 double q
= ceil (x
/ y
);
2197 double r
= x
- q
* y
;
2198 *qp
= scm_from_double (q
);
2199 *rp
= scm_from_double (r
);
2204 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2207 SCM xd
= scm_denominator (x
);
2208 SCM yd
= scm_denominator (y
);
2210 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2211 scm_product (scm_numerator (y
), xd
),
2213 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2216 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2217 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2219 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2221 "Return @math{@var{x} / @var{y}} rounded toward zero.\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 -10) @result{} 12\n"
2227 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2228 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2230 #define FUNC_NAME s_scm_truncate_quotient
2232 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2234 scm_t_inum xx
= SCM_I_INUM (x
);
2235 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2237 scm_t_inum yy
= SCM_I_INUM (y
);
2238 if (SCM_UNLIKELY (yy
== 0))
2239 scm_num_overflow (s_scm_truncate_quotient
);
2242 scm_t_inum qq
= xx
/ yy
;
2243 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2244 return SCM_I_MAKINUM (qq
);
2246 return scm_i_inum2big (qq
);
2249 else if (SCM_BIGP (y
))
2251 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2252 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2253 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2255 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2256 scm_remember_upto_here_1 (y
);
2257 return SCM_I_MAKINUM (-1);
2262 else if (SCM_REALP (y
))
2263 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2264 else if (SCM_FRACTIONP (y
))
2265 return scm_i_exact_rational_truncate_quotient (x
, y
);
2267 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2268 s_scm_truncate_quotient
);
2270 else if (SCM_BIGP (x
))
2272 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2274 scm_t_inum yy
= SCM_I_INUM (y
);
2275 if (SCM_UNLIKELY (yy
== 0))
2276 scm_num_overflow (s_scm_truncate_quotient
);
2277 else if (SCM_UNLIKELY (yy
== 1))
2281 SCM q
= scm_i_mkbig ();
2283 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2286 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2287 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2289 scm_remember_upto_here_1 (x
);
2290 return scm_i_normbig (q
);
2293 else if (SCM_BIGP (y
))
2295 SCM q
= scm_i_mkbig ();
2296 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2299 scm_remember_upto_here_2 (x
, y
);
2300 return scm_i_normbig (q
);
2302 else if (SCM_REALP (y
))
2303 return scm_i_inexact_truncate_quotient
2304 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2305 else if (SCM_FRACTIONP (y
))
2306 return scm_i_exact_rational_truncate_quotient (x
, y
);
2308 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2309 s_scm_truncate_quotient
);
2311 else if (SCM_REALP (x
))
2313 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2314 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2315 return scm_i_inexact_truncate_quotient
2316 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2318 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2319 s_scm_truncate_quotient
);
2321 else if (SCM_FRACTIONP (x
))
2324 return scm_i_inexact_truncate_quotient
2325 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2326 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2327 return scm_i_exact_rational_truncate_quotient (x
, y
);
2329 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2330 s_scm_truncate_quotient
);
2333 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2334 s_scm_truncate_quotient
);
2339 scm_i_inexact_truncate_quotient (double x
, double y
)
2341 if (SCM_UNLIKELY (y
== 0))
2342 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2344 return scm_from_double (trunc (x
/ y
));
2348 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2350 return scm_truncate_quotient
2351 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2352 scm_product (scm_numerator (y
), scm_denominator (x
)));
2355 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2356 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2358 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2360 "Return the real number @var{r} such that\n"
2361 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2362 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\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 -10) @result{} -3\n"
2368 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2369 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2371 #define FUNC_NAME s_scm_truncate_remainder
2373 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2375 scm_t_inum xx
= SCM_I_INUM (x
);
2376 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2378 scm_t_inum yy
= SCM_I_INUM (y
);
2379 if (SCM_UNLIKELY (yy
== 0))
2380 scm_num_overflow (s_scm_truncate_remainder
);
2382 return SCM_I_MAKINUM (xx
% yy
);
2384 else if (SCM_BIGP (y
))
2386 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2387 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2388 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2390 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2391 scm_remember_upto_here_1 (y
);
2397 else if (SCM_REALP (y
))
2398 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2399 else if (SCM_FRACTIONP (y
))
2400 return scm_i_exact_rational_truncate_remainder (x
, y
);
2402 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2403 s_scm_truncate_remainder
);
2405 else if (SCM_BIGP (x
))
2407 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2409 scm_t_inum yy
= SCM_I_INUM (y
);
2410 if (SCM_UNLIKELY (yy
== 0))
2411 scm_num_overflow (s_scm_truncate_remainder
);
2414 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2415 (yy
> 0) ? yy
: -yy
)
2416 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2417 scm_remember_upto_here_1 (x
);
2418 return SCM_I_MAKINUM (rr
);
2421 else if (SCM_BIGP (y
))
2423 SCM r
= scm_i_mkbig ();
2424 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2427 scm_remember_upto_here_2 (x
, y
);
2428 return scm_i_normbig (r
);
2430 else if (SCM_REALP (y
))
2431 return scm_i_inexact_truncate_remainder
2432 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2433 else if (SCM_FRACTIONP (y
))
2434 return scm_i_exact_rational_truncate_remainder (x
, y
);
2436 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2437 s_scm_truncate_remainder
);
2439 else if (SCM_REALP (x
))
2441 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2442 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2443 return scm_i_inexact_truncate_remainder
2444 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2446 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2447 s_scm_truncate_remainder
);
2449 else if (SCM_FRACTIONP (x
))
2452 return scm_i_inexact_truncate_remainder
2453 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2454 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2455 return scm_i_exact_rational_truncate_remainder (x
, y
);
2457 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2458 s_scm_truncate_remainder
);
2461 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2462 s_scm_truncate_remainder
);
2467 scm_i_inexact_truncate_remainder (double x
, double y
)
2469 /* Although it would be more efficient to use fmod here, we can't
2470 because it would in some cases produce results inconsistent with
2471 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2472 close). In particular, when x is very close to a multiple of y,
2473 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2474 correspond to different choices of q. If quotient chooses one and
2475 remainder chooses the other, it would be bad. */
2476 if (SCM_UNLIKELY (y
== 0))
2477 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2479 return scm_from_double (x
- y
* trunc (x
/ y
));
2483 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2485 SCM xd
= scm_denominator (x
);
2486 SCM yd
= scm_denominator (y
);
2487 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2488 scm_product (scm_numerator (y
), xd
));
2489 return scm_divide (r1
, scm_product (xd
, yd
));
2493 static void scm_i_inexact_truncate_divide (double x
, double y
,
2495 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2498 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2500 "Return the integer @var{q} and the real number @var{r}\n"
2501 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2502 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\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 -10) @result{} 12 and -3\n"
2508 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2509 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2511 #define FUNC_NAME s_scm_i_truncate_divide
2515 scm_truncate_divide(x
, y
, &q
, &r
);
2516 return scm_values (scm_list_2 (q
, r
));
2520 #define s_scm_truncate_divide s_scm_i_truncate_divide
2521 #define g_scm_truncate_divide g_scm_i_truncate_divide
2524 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2526 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2528 scm_t_inum xx
= SCM_I_INUM (x
);
2529 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2531 scm_t_inum yy
= SCM_I_INUM (y
);
2532 if (SCM_UNLIKELY (yy
== 0))
2533 scm_num_overflow (s_scm_truncate_divide
);
2536 scm_t_inum qq
= xx
/ yy
;
2537 scm_t_inum rr
= xx
% yy
;
2538 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2539 *qp
= SCM_I_MAKINUM (qq
);
2541 *qp
= scm_i_inum2big (qq
);
2542 *rp
= SCM_I_MAKINUM (rr
);
2546 else if (SCM_BIGP (y
))
2548 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2549 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2550 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2552 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2553 scm_remember_upto_here_1 (y
);
2554 *qp
= SCM_I_MAKINUM (-1);
2564 else if (SCM_REALP (y
))
2565 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2566 else if (SCM_FRACTIONP (y
))
2567 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2569 return two_valued_wta_dispatch_2
2570 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2571 s_scm_truncate_divide
, qp
, rp
);
2573 else if (SCM_BIGP (x
))
2575 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2577 scm_t_inum yy
= SCM_I_INUM (y
);
2578 if (SCM_UNLIKELY (yy
== 0))
2579 scm_num_overflow (s_scm_truncate_divide
);
2582 SCM q
= scm_i_mkbig ();
2585 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2586 SCM_I_BIG_MPZ (x
), yy
);
2589 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2590 SCM_I_BIG_MPZ (x
), -yy
);
2591 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2593 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2594 scm_remember_upto_here_1 (x
);
2595 *qp
= scm_i_normbig (q
);
2596 *rp
= SCM_I_MAKINUM (rr
);
2600 else if (SCM_BIGP (y
))
2602 SCM q
= scm_i_mkbig ();
2603 SCM r
= scm_i_mkbig ();
2604 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2605 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2606 scm_remember_upto_here_2 (x
, y
);
2607 *qp
= scm_i_normbig (q
);
2608 *rp
= scm_i_normbig (r
);
2610 else if (SCM_REALP (y
))
2611 return scm_i_inexact_truncate_divide
2612 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2613 else if (SCM_FRACTIONP (y
))
2614 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2616 return two_valued_wta_dispatch_2
2617 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2618 s_scm_truncate_divide
, qp
, rp
);
2620 else if (SCM_REALP (x
))
2622 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2623 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2624 return scm_i_inexact_truncate_divide
2625 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2627 return two_valued_wta_dispatch_2
2628 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2629 s_scm_truncate_divide
, qp
, rp
);
2631 else if (SCM_FRACTIONP (x
))
2634 return scm_i_inexact_truncate_divide
2635 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2636 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2637 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2639 return two_valued_wta_dispatch_2
2640 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2641 s_scm_truncate_divide
, qp
, rp
);
2644 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2645 s_scm_truncate_divide
, qp
, rp
);
2649 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2651 if (SCM_UNLIKELY (y
== 0))
2652 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2655 double q
= trunc (x
/ y
);
2656 double r
= x
- q
* y
;
2657 *qp
= scm_from_double (q
);
2658 *rp
= scm_from_double (r
);
2663 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2666 SCM xd
= scm_denominator (x
);
2667 SCM yd
= scm_denominator (y
);
2669 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2670 scm_product (scm_numerator (y
), xd
),
2672 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2675 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2676 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2677 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2679 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2681 "Return the integer @var{q} such that\n"
2682 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2683 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\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 -10) @result{} 12\n"
2689 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2690 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2692 #define FUNC_NAME s_scm_centered_quotient
2694 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2696 scm_t_inum xx
= SCM_I_INUM (x
);
2697 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2699 scm_t_inum yy
= SCM_I_INUM (y
);
2700 if (SCM_UNLIKELY (yy
== 0))
2701 scm_num_overflow (s_scm_centered_quotient
);
2704 scm_t_inum qq
= xx
/ yy
;
2705 scm_t_inum rr
= xx
% yy
;
2706 if (SCM_LIKELY (xx
> 0))
2708 if (SCM_LIKELY (yy
> 0))
2710 if (rr
>= (yy
+ 1) / 2)
2715 if (rr
>= (1 - yy
) / 2)
2721 if (SCM_LIKELY (yy
> 0))
2732 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2733 return SCM_I_MAKINUM (qq
);
2735 return scm_i_inum2big (qq
);
2738 else if (SCM_BIGP (y
))
2740 /* Pass a denormalized bignum version of x (even though it
2741 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2742 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2744 else if (SCM_REALP (y
))
2745 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2746 else if (SCM_FRACTIONP (y
))
2747 return scm_i_exact_rational_centered_quotient (x
, y
);
2749 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2750 s_scm_centered_quotient
);
2752 else if (SCM_BIGP (x
))
2754 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2756 scm_t_inum yy
= SCM_I_INUM (y
);
2757 if (SCM_UNLIKELY (yy
== 0))
2758 scm_num_overflow (s_scm_centered_quotient
);
2759 else if (SCM_UNLIKELY (yy
== 1))
2763 SCM q
= scm_i_mkbig ();
2765 /* Arrange for rr to initially be non-positive,
2766 because that simplifies the test to see
2767 if it is within the needed bounds. */
2770 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2771 SCM_I_BIG_MPZ (x
), yy
);
2772 scm_remember_upto_here_1 (x
);
2774 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2775 SCM_I_BIG_MPZ (q
), 1);
2779 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2780 SCM_I_BIG_MPZ (x
), -yy
);
2781 scm_remember_upto_here_1 (x
);
2782 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2784 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2785 SCM_I_BIG_MPZ (q
), 1);
2787 return scm_i_normbig (q
);
2790 else if (SCM_BIGP (y
))
2791 return scm_i_bigint_centered_quotient (x
, y
);
2792 else if (SCM_REALP (y
))
2793 return scm_i_inexact_centered_quotient
2794 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2795 else if (SCM_FRACTIONP (y
))
2796 return scm_i_exact_rational_centered_quotient (x
, y
);
2798 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2799 s_scm_centered_quotient
);
2801 else if (SCM_REALP (x
))
2803 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2804 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2805 return scm_i_inexact_centered_quotient
2806 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2808 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2809 s_scm_centered_quotient
);
2811 else if (SCM_FRACTIONP (x
))
2814 return scm_i_inexact_centered_quotient
2815 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2816 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2817 return scm_i_exact_rational_centered_quotient (x
, y
);
2819 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2820 s_scm_centered_quotient
);
2823 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2824 s_scm_centered_quotient
);
2829 scm_i_inexact_centered_quotient (double x
, double y
)
2831 if (SCM_LIKELY (y
> 0))
2832 return scm_from_double (floor (x
/y
+ 0.5));
2833 else if (SCM_LIKELY (y
< 0))
2834 return scm_from_double (ceil (x
/y
- 0.5));
2836 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2841 /* Assumes that both x and y are bigints, though
2842 x might be able to fit into a fixnum. */
2844 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2848 /* Note that x might be small enough to fit into a
2849 fixnum, so we must not let it escape into the wild */
2853 /* min_r will eventually become -abs(y)/2 */
2854 min_r
= scm_i_mkbig ();
2855 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2856 SCM_I_BIG_MPZ (y
), 1);
2858 /* Arrange for rr to initially be non-positive,
2859 because that simplifies the test to see
2860 if it is within the needed bounds. */
2861 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2863 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2864 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2865 scm_remember_upto_here_2 (x
, y
);
2866 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2867 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2868 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2869 SCM_I_BIG_MPZ (q
), 1);
2873 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2874 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2875 scm_remember_upto_here_2 (x
, y
);
2876 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2877 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2878 SCM_I_BIG_MPZ (q
), 1);
2880 scm_remember_upto_here_2 (r
, min_r
);
2881 return scm_i_normbig (q
);
2885 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2887 return scm_centered_quotient
2888 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2889 scm_product (scm_numerator (y
), scm_denominator (x
)));
2892 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2893 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2894 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2896 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2898 "Return the real number @var{r} such that\n"
2899 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2900 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2901 "for some integer @var{q}.\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 -10) @result{} -3\n"
2907 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2908 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2910 #define FUNC_NAME s_scm_centered_remainder
2912 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2914 scm_t_inum xx
= SCM_I_INUM (x
);
2915 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2917 scm_t_inum yy
= SCM_I_INUM (y
);
2918 if (SCM_UNLIKELY (yy
== 0))
2919 scm_num_overflow (s_scm_centered_remainder
);
2922 scm_t_inum rr
= xx
% yy
;
2923 if (SCM_LIKELY (xx
> 0))
2925 if (SCM_LIKELY (yy
> 0))
2927 if (rr
>= (yy
+ 1) / 2)
2932 if (rr
>= (1 - yy
) / 2)
2938 if (SCM_LIKELY (yy
> 0))
2949 return SCM_I_MAKINUM (rr
);
2952 else if (SCM_BIGP (y
))
2954 /* Pass a denormalized bignum version of x (even though it
2955 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2956 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2958 else if (SCM_REALP (y
))
2959 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2960 else if (SCM_FRACTIONP (y
))
2961 return scm_i_exact_rational_centered_remainder (x
, y
);
2963 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2964 s_scm_centered_remainder
);
2966 else if (SCM_BIGP (x
))
2968 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2970 scm_t_inum yy
= SCM_I_INUM (y
);
2971 if (SCM_UNLIKELY (yy
== 0))
2972 scm_num_overflow (s_scm_centered_remainder
);
2976 /* Arrange for rr to initially be non-positive,
2977 because that simplifies the test to see
2978 if it is within the needed bounds. */
2981 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2982 scm_remember_upto_here_1 (x
);
2988 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2989 scm_remember_upto_here_1 (x
);
2993 return SCM_I_MAKINUM (rr
);
2996 else if (SCM_BIGP (y
))
2997 return scm_i_bigint_centered_remainder (x
, y
);
2998 else if (SCM_REALP (y
))
2999 return scm_i_inexact_centered_remainder
3000 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3001 else if (SCM_FRACTIONP (y
))
3002 return scm_i_exact_rational_centered_remainder (x
, y
);
3004 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3005 s_scm_centered_remainder
);
3007 else if (SCM_REALP (x
))
3009 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3010 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3011 return scm_i_inexact_centered_remainder
3012 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3014 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3015 s_scm_centered_remainder
);
3017 else if (SCM_FRACTIONP (x
))
3020 return scm_i_inexact_centered_remainder
3021 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3022 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3023 return scm_i_exact_rational_centered_remainder (x
, y
);
3025 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
3026 s_scm_centered_remainder
);
3029 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
3030 s_scm_centered_remainder
);
3035 scm_i_inexact_centered_remainder (double x
, double y
)
3039 /* Although it would be more efficient to use fmod here, we can't
3040 because it would in some cases produce results inconsistent with
3041 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3042 close). In particular, when x-y/2 is very close to a multiple of
3043 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3044 two cases must correspond to different choices of q. If quotient
3045 chooses one and remainder chooses the other, it would be bad. */
3046 if (SCM_LIKELY (y
> 0))
3047 q
= floor (x
/y
+ 0.5);
3048 else if (SCM_LIKELY (y
< 0))
3049 q
= ceil (x
/y
- 0.5);
3051 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
3054 return scm_from_double (x
- q
* y
);
3057 /* Assumes that both x and y are bigints, though
3058 x might be able to fit into a fixnum. */
3060 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
3064 /* Note that x might be small enough to fit into a
3065 fixnum, so we must not let it escape into the wild */
3068 /* min_r will eventually become -abs(y)/2 */
3069 min_r
= scm_i_mkbig ();
3070 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3071 SCM_I_BIG_MPZ (y
), 1);
3073 /* Arrange for rr to initially be non-positive,
3074 because that simplifies the test to see
3075 if it is within the needed bounds. */
3076 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3078 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
3079 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3080 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3081 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3082 mpz_add (SCM_I_BIG_MPZ (r
),
3088 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
3089 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3090 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3091 mpz_sub (SCM_I_BIG_MPZ (r
),
3095 scm_remember_upto_here_2 (x
, y
);
3096 return scm_i_normbig (r
);
3100 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
3102 SCM xd
= scm_denominator (x
);
3103 SCM yd
= scm_denominator (y
);
3104 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
3105 scm_product (scm_numerator (y
), xd
));
3106 return scm_divide (r1
, scm_product (xd
, yd
));
3110 static void scm_i_inexact_centered_divide (double x
, double y
,
3112 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3113 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3116 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3118 "Return the integer @var{q} and the real number @var{r}\n"
3119 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3120 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\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 -10) @result{} 12 and -3\n"
3126 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3127 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3129 #define FUNC_NAME s_scm_i_centered_divide
3133 scm_centered_divide(x
, y
, &q
, &r
);
3134 return scm_values (scm_list_2 (q
, r
));
3138 #define s_scm_centered_divide s_scm_i_centered_divide
3139 #define g_scm_centered_divide g_scm_i_centered_divide
3142 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3144 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3146 scm_t_inum xx
= SCM_I_INUM (x
);
3147 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3149 scm_t_inum yy
= SCM_I_INUM (y
);
3150 if (SCM_UNLIKELY (yy
== 0))
3151 scm_num_overflow (s_scm_centered_divide
);
3154 scm_t_inum qq
= xx
/ yy
;
3155 scm_t_inum rr
= xx
% yy
;
3156 if (SCM_LIKELY (xx
> 0))
3158 if (SCM_LIKELY (yy
> 0))
3160 if (rr
>= (yy
+ 1) / 2)
3165 if (rr
>= (1 - yy
) / 2)
3171 if (SCM_LIKELY (yy
> 0))
3182 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3183 *qp
= SCM_I_MAKINUM (qq
);
3185 *qp
= scm_i_inum2big (qq
);
3186 *rp
= SCM_I_MAKINUM (rr
);
3190 else if (SCM_BIGP (y
))
3192 /* Pass a denormalized bignum version of x (even though it
3193 can fit in a fixnum) to scm_i_bigint_centered_divide */
3194 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3196 else if (SCM_REALP (y
))
3197 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3198 else if (SCM_FRACTIONP (y
))
3199 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3201 return two_valued_wta_dispatch_2
3202 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3203 s_scm_centered_divide
, qp
, rp
);
3205 else if (SCM_BIGP (x
))
3207 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3209 scm_t_inum yy
= SCM_I_INUM (y
);
3210 if (SCM_UNLIKELY (yy
== 0))
3211 scm_num_overflow (s_scm_centered_divide
);
3214 SCM q
= scm_i_mkbig ();
3216 /* Arrange for rr to initially be non-positive,
3217 because that simplifies the test to see
3218 if it is within the needed bounds. */
3221 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3222 SCM_I_BIG_MPZ (x
), yy
);
3223 scm_remember_upto_here_1 (x
);
3226 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3227 SCM_I_BIG_MPZ (q
), 1);
3233 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3234 SCM_I_BIG_MPZ (x
), -yy
);
3235 scm_remember_upto_here_1 (x
);
3236 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3239 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3240 SCM_I_BIG_MPZ (q
), 1);
3244 *qp
= scm_i_normbig (q
);
3245 *rp
= SCM_I_MAKINUM (rr
);
3249 else if (SCM_BIGP (y
))
3250 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3251 else if (SCM_REALP (y
))
3252 return scm_i_inexact_centered_divide
3253 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3254 else if (SCM_FRACTIONP (y
))
3255 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3257 return two_valued_wta_dispatch_2
3258 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3259 s_scm_centered_divide
, qp
, rp
);
3261 else if (SCM_REALP (x
))
3263 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3264 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3265 return scm_i_inexact_centered_divide
3266 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3268 return two_valued_wta_dispatch_2
3269 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3270 s_scm_centered_divide
, qp
, rp
);
3272 else if (SCM_FRACTIONP (x
))
3275 return scm_i_inexact_centered_divide
3276 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3277 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3278 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3280 return two_valued_wta_dispatch_2
3281 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3282 s_scm_centered_divide
, qp
, rp
);
3285 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3286 s_scm_centered_divide
, qp
, rp
);
3290 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3294 if (SCM_LIKELY (y
> 0))
3295 q
= floor (x
/y
+ 0.5);
3296 else if (SCM_LIKELY (y
< 0))
3297 q
= ceil (x
/y
- 0.5);
3299 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3303 *qp
= scm_from_double (q
);
3304 *rp
= scm_from_double (r
);
3307 /* Assumes that both x and y are bigints, though
3308 x might be able to fit into a fixnum. */
3310 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3314 /* Note that x might be small enough to fit into a
3315 fixnum, so we must not let it escape into the wild */
3319 /* min_r will eventually become -abs(y/2) */
3320 min_r
= scm_i_mkbig ();
3321 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3322 SCM_I_BIG_MPZ (y
), 1);
3324 /* Arrange for rr to initially be non-positive,
3325 because that simplifies the test to see
3326 if it is within the needed bounds. */
3327 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3329 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3330 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3331 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3332 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3334 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3335 SCM_I_BIG_MPZ (q
), 1);
3336 mpz_add (SCM_I_BIG_MPZ (r
),
3343 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3344 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3345 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3347 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3348 SCM_I_BIG_MPZ (q
), 1);
3349 mpz_sub (SCM_I_BIG_MPZ (r
),
3354 scm_remember_upto_here_2 (x
, y
);
3355 *qp
= scm_i_normbig (q
);
3356 *rp
= scm_i_normbig (r
);
3360 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3363 SCM xd
= scm_denominator (x
);
3364 SCM yd
= scm_denominator (y
);
3366 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3367 scm_product (scm_numerator (y
), xd
),
3369 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3372 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3373 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3374 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3376 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3378 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3379 "with ties going to the nearest even integer.\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 -123 -10) @result{} 12\n"
3385 "(round-quotient 125 10) @result{} 12\n"
3386 "(round-quotient 127 10) @result{} 13\n"
3387 "(round-quotient 135 10) @result{} 14\n"
3388 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3389 "(round-quotient 16/3 -10/7) @result{} -4\n"
3391 #define FUNC_NAME s_scm_round_quotient
3393 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3395 scm_t_inum xx
= SCM_I_INUM (x
);
3396 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3398 scm_t_inum yy
= SCM_I_INUM (y
);
3399 if (SCM_UNLIKELY (yy
== 0))
3400 scm_num_overflow (s_scm_round_quotient
);
3403 scm_t_inum qq
= xx
/ yy
;
3404 scm_t_inum rr
= xx
% yy
;
3406 scm_t_inum r2
= 2 * rr
;
3408 if (SCM_LIKELY (yy
< 0))
3428 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3429 return SCM_I_MAKINUM (qq
);
3431 return scm_i_inum2big (qq
);
3434 else if (SCM_BIGP (y
))
3436 /* Pass a denormalized bignum version of x (even though it
3437 can fit in a fixnum) to scm_i_bigint_round_quotient */
3438 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3440 else if (SCM_REALP (y
))
3441 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3442 else if (SCM_FRACTIONP (y
))
3443 return scm_i_exact_rational_round_quotient (x
, y
);
3445 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3446 s_scm_round_quotient
);
3448 else if (SCM_BIGP (x
))
3450 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3452 scm_t_inum yy
= SCM_I_INUM (y
);
3453 if (SCM_UNLIKELY (yy
== 0))
3454 scm_num_overflow (s_scm_round_quotient
);
3455 else if (SCM_UNLIKELY (yy
== 1))
3459 SCM q
= scm_i_mkbig ();
3461 int needs_adjustment
;
3465 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3466 SCM_I_BIG_MPZ (x
), yy
);
3467 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3468 needs_adjustment
= (2*rr
>= yy
);
3470 needs_adjustment
= (2*rr
> yy
);
3474 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3475 SCM_I_BIG_MPZ (x
), -yy
);
3476 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3477 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3478 needs_adjustment
= (2*rr
<= yy
);
3480 needs_adjustment
= (2*rr
< yy
);
3482 scm_remember_upto_here_1 (x
);
3483 if (needs_adjustment
)
3484 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3485 return scm_i_normbig (q
);
3488 else if (SCM_BIGP (y
))
3489 return scm_i_bigint_round_quotient (x
, y
);
3490 else if (SCM_REALP (y
))
3491 return scm_i_inexact_round_quotient
3492 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3493 else if (SCM_FRACTIONP (y
))
3494 return scm_i_exact_rational_round_quotient (x
, y
);
3496 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3497 s_scm_round_quotient
);
3499 else if (SCM_REALP (x
))
3501 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3502 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3503 return scm_i_inexact_round_quotient
3504 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3506 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3507 s_scm_round_quotient
);
3509 else if (SCM_FRACTIONP (x
))
3512 return scm_i_inexact_round_quotient
3513 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3514 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3515 return scm_i_exact_rational_round_quotient (x
, y
);
3517 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3518 s_scm_round_quotient
);
3521 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3522 s_scm_round_quotient
);
3527 scm_i_inexact_round_quotient (double x
, double y
)
3529 if (SCM_UNLIKELY (y
== 0))
3530 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3532 return scm_from_double (scm_c_round (x
/ y
));
3535 /* Assumes that both x and y are bigints, though
3536 x might be able to fit into a fixnum. */
3538 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3541 int cmp
, needs_adjustment
;
3543 /* Note that x might be small enough to fit into a
3544 fixnum, so we must not let it escape into the wild */
3547 r2
= scm_i_mkbig ();
3549 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3550 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3551 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3552 scm_remember_upto_here_2 (x
, r
);
3554 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3555 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3556 needs_adjustment
= (cmp
>= 0);
3558 needs_adjustment
= (cmp
> 0);
3559 scm_remember_upto_here_2 (r2
, y
);
3561 if (needs_adjustment
)
3562 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3564 return scm_i_normbig (q
);
3568 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3570 return scm_round_quotient
3571 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3572 scm_product (scm_numerator (y
), scm_denominator (x
)));
3575 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3576 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3577 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3579 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3581 "Return the real number @var{r} such that\n"
3582 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3583 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3584 "nearest integer, with ties going to the nearest\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 -123 -10) @result{} -3\n"
3591 "(round-remainder 125 10) @result{} 5\n"
3592 "(round-remainder 127 10) @result{} -3\n"
3593 "(round-remainder 135 10) @result{} -5\n"
3594 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3595 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3597 #define FUNC_NAME s_scm_round_remainder
3599 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3601 scm_t_inum xx
= SCM_I_INUM (x
);
3602 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3604 scm_t_inum yy
= SCM_I_INUM (y
);
3605 if (SCM_UNLIKELY (yy
== 0))
3606 scm_num_overflow (s_scm_round_remainder
);
3609 scm_t_inum qq
= xx
/ yy
;
3610 scm_t_inum rr
= xx
% yy
;
3612 scm_t_inum r2
= 2 * rr
;
3614 if (SCM_LIKELY (yy
< 0))
3634 return SCM_I_MAKINUM (rr
);
3637 else if (SCM_BIGP (y
))
3639 /* Pass a denormalized bignum version of x (even though it
3640 can fit in a fixnum) to scm_i_bigint_round_remainder */
3641 return scm_i_bigint_round_remainder
3642 (scm_i_long2big (xx
), y
);
3644 else if (SCM_REALP (y
))
3645 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3646 else if (SCM_FRACTIONP (y
))
3647 return scm_i_exact_rational_round_remainder (x
, y
);
3649 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3650 s_scm_round_remainder
);
3652 else if (SCM_BIGP (x
))
3654 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3656 scm_t_inum yy
= SCM_I_INUM (y
);
3657 if (SCM_UNLIKELY (yy
== 0))
3658 scm_num_overflow (s_scm_round_remainder
);
3661 SCM q
= scm_i_mkbig ();
3663 int needs_adjustment
;
3667 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3668 SCM_I_BIG_MPZ (x
), yy
);
3669 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3670 needs_adjustment
= (2*rr
>= yy
);
3672 needs_adjustment
= (2*rr
> yy
);
3676 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3677 SCM_I_BIG_MPZ (x
), -yy
);
3678 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3679 needs_adjustment
= (2*rr
<= yy
);
3681 needs_adjustment
= (2*rr
< yy
);
3683 scm_remember_upto_here_2 (x
, q
);
3684 if (needs_adjustment
)
3686 return SCM_I_MAKINUM (rr
);
3689 else if (SCM_BIGP (y
))
3690 return scm_i_bigint_round_remainder (x
, y
);
3691 else if (SCM_REALP (y
))
3692 return scm_i_inexact_round_remainder
3693 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3694 else if (SCM_FRACTIONP (y
))
3695 return scm_i_exact_rational_round_remainder (x
, y
);
3697 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3698 s_scm_round_remainder
);
3700 else if (SCM_REALP (x
))
3702 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3703 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3704 return scm_i_inexact_round_remainder
3705 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3707 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3708 s_scm_round_remainder
);
3710 else if (SCM_FRACTIONP (x
))
3713 return scm_i_inexact_round_remainder
3714 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3715 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3716 return scm_i_exact_rational_round_remainder (x
, y
);
3718 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3719 s_scm_round_remainder
);
3722 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3723 s_scm_round_remainder
);
3728 scm_i_inexact_round_remainder (double x
, double y
)
3730 /* Although it would be more efficient to use fmod here, we can't
3731 because it would in some cases produce results inconsistent with
3732 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3733 close). In particular, when x-y/2 is very close to a multiple of
3734 y, then r might be either -abs(y/2) or abs(y/2), but those two
3735 cases must correspond to different choices of q. If quotient
3736 chooses one and remainder chooses the other, it would be bad. */
3738 if (SCM_UNLIKELY (y
== 0))
3739 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3742 double q
= scm_c_round (x
/ y
);
3743 return scm_from_double (x
- q
* y
);
3747 /* Assumes that both x and y are bigints, though
3748 x might be able to fit into a fixnum. */
3750 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3753 int cmp
, needs_adjustment
;
3755 /* Note that x might be small enough to fit into a
3756 fixnum, so we must not let it escape into the wild */
3759 r2
= scm_i_mkbig ();
3761 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3762 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3763 scm_remember_upto_here_1 (x
);
3764 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3766 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3767 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3768 needs_adjustment
= (cmp
>= 0);
3770 needs_adjustment
= (cmp
> 0);
3771 scm_remember_upto_here_2 (q
, r2
);
3773 if (needs_adjustment
)
3774 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3776 scm_remember_upto_here_1 (y
);
3777 return scm_i_normbig (r
);
3781 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3783 SCM xd
= scm_denominator (x
);
3784 SCM yd
= scm_denominator (y
);
3785 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3786 scm_product (scm_numerator (y
), xd
));
3787 return scm_divide (r1
, scm_product (xd
, yd
));
3791 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3792 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3793 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3795 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3797 "Return the integer @var{q} and the real number @var{r}\n"
3798 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3799 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3800 "nearest integer, with ties going to the nearest even integer.\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/ -123 -10) @result{} 12 and -3\n"
3806 "(round/ 125 10) @result{} 12 and 5\n"
3807 "(round/ 127 10) @result{} 13 and -3\n"
3808 "(round/ 135 10) @result{} 14 and -5\n"
3809 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3810 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3812 #define FUNC_NAME s_scm_i_round_divide
3816 scm_round_divide(x
, y
, &q
, &r
);
3817 return scm_values (scm_list_2 (q
, r
));
3821 #define s_scm_round_divide s_scm_i_round_divide
3822 #define g_scm_round_divide g_scm_i_round_divide
3825 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3827 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3829 scm_t_inum xx
= SCM_I_INUM (x
);
3830 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3832 scm_t_inum yy
= SCM_I_INUM (y
);
3833 if (SCM_UNLIKELY (yy
== 0))
3834 scm_num_overflow (s_scm_round_divide
);
3837 scm_t_inum qq
= xx
/ yy
;
3838 scm_t_inum rr
= xx
% yy
;
3840 scm_t_inum r2
= 2 * rr
;
3842 if (SCM_LIKELY (yy
< 0))
3862 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3863 *qp
= SCM_I_MAKINUM (qq
);
3865 *qp
= scm_i_inum2big (qq
);
3866 *rp
= SCM_I_MAKINUM (rr
);
3870 else if (SCM_BIGP (y
))
3872 /* Pass a denormalized bignum version of x (even though it
3873 can fit in a fixnum) to scm_i_bigint_round_divide */
3874 return scm_i_bigint_round_divide
3875 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3877 else if (SCM_REALP (y
))
3878 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3879 else if (SCM_FRACTIONP (y
))
3880 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3882 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3883 s_scm_round_divide
, qp
, rp
);
3885 else if (SCM_BIGP (x
))
3887 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3889 scm_t_inum yy
= SCM_I_INUM (y
);
3890 if (SCM_UNLIKELY (yy
== 0))
3891 scm_num_overflow (s_scm_round_divide
);
3894 SCM q
= scm_i_mkbig ();
3896 int needs_adjustment
;
3900 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3901 SCM_I_BIG_MPZ (x
), yy
);
3902 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3903 needs_adjustment
= (2*rr
>= yy
);
3905 needs_adjustment
= (2*rr
> yy
);
3909 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3910 SCM_I_BIG_MPZ (x
), -yy
);
3911 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3912 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3913 needs_adjustment
= (2*rr
<= yy
);
3915 needs_adjustment
= (2*rr
< yy
);
3917 scm_remember_upto_here_1 (x
);
3918 if (needs_adjustment
)
3920 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3923 *qp
= scm_i_normbig (q
);
3924 *rp
= SCM_I_MAKINUM (rr
);
3928 else if (SCM_BIGP (y
))
3929 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3930 else if (SCM_REALP (y
))
3931 return scm_i_inexact_round_divide
3932 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3933 else if (SCM_FRACTIONP (y
))
3934 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3936 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3937 s_scm_round_divide
, qp
, rp
);
3939 else if (SCM_REALP (x
))
3941 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3942 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3943 return scm_i_inexact_round_divide
3944 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3946 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3947 s_scm_round_divide
, qp
, rp
);
3949 else if (SCM_FRACTIONP (x
))
3952 return scm_i_inexact_round_divide
3953 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3954 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3955 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3957 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3958 s_scm_round_divide
, qp
, rp
);
3961 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3962 s_scm_round_divide
, qp
, rp
);
3966 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3968 if (SCM_UNLIKELY (y
== 0))
3969 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3972 double q
= scm_c_round (x
/ y
);
3973 double r
= x
- q
* y
;
3974 *qp
= scm_from_double (q
);
3975 *rp
= scm_from_double (r
);
3979 /* Assumes that both x and y are bigints, though
3980 x might be able to fit into a fixnum. */
3982 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3985 int cmp
, needs_adjustment
;
3987 /* Note that x might be small enough to fit into a
3988 fixnum, so we must not let it escape into the wild */
3991 r2
= scm_i_mkbig ();
3993 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3994 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3995 scm_remember_upto_here_1 (x
);
3996 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3998 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3999 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
4000 needs_adjustment
= (cmp
>= 0);
4002 needs_adjustment
= (cmp
> 0);
4004 if (needs_adjustment
)
4006 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4007 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
4010 scm_remember_upto_here_2 (r2
, y
);
4011 *qp
= scm_i_normbig (q
);
4012 *rp
= scm_i_normbig (r
);
4016 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
4019 SCM xd
= scm_denominator (x
);
4020 SCM yd
= scm_denominator (y
);
4022 scm_round_divide (scm_product (scm_numerator (x
), yd
),
4023 scm_product (scm_numerator (y
), xd
),
4025 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
4029 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
4030 (SCM x
, SCM y
, SCM rest
),
4031 "Return the greatest common divisor of all parameter values.\n"
4032 "If called without arguments, 0 is returned.")
4033 #define FUNC_NAME s_scm_i_gcd
4035 while (!scm_is_null (rest
))
4036 { x
= scm_gcd (x
, y
);
4038 rest
= scm_cdr (rest
);
4040 return scm_gcd (x
, y
);
4044 #define s_gcd s_scm_i_gcd
4045 #define g_gcd g_scm_i_gcd
4048 scm_gcd (SCM x
, SCM y
)
4050 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
4051 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
4053 if (SCM_LIKELY (SCM_I_INUMP (x
)))
4055 if (SCM_LIKELY (SCM_I_INUMP (y
)))
4057 scm_t_inum xx
= SCM_I_INUM (x
);
4058 scm_t_inum yy
= SCM_I_INUM (y
);
4059 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
4060 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
4062 if (SCM_UNLIKELY (xx
== 0))
4064 else if (SCM_UNLIKELY (yy
== 0))
4069 /* Determine a common factor 2^k */
4070 while (((u
| v
) & 1) == 0)
4076 /* Now, any factor 2^n can be eliminated */
4078 while ((u
& 1) == 0)
4081 while ((v
& 1) == 0)
4083 /* Both u and v are now odd. Subtract the smaller one
4084 from the larger one to produce an even number, remove
4085 more factors of two, and repeat. */
4091 while ((u
& 1) == 0)
4097 while ((v
& 1) == 0)
4103 return (SCM_POSFIXABLE (result
)
4104 ? SCM_I_MAKINUM (result
)
4105 : scm_i_inum2big (result
));
4107 else if (SCM_BIGP (y
))
4113 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4115 else if (SCM_BIGP (x
))
4117 if (SCM_I_INUMP (y
))
4122 yy
= SCM_I_INUM (y
);
4127 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4128 scm_remember_upto_here_1 (x
);
4129 return (SCM_POSFIXABLE (result
)
4130 ? SCM_I_MAKINUM (result
)
4131 : scm_from_unsigned_integer (result
));
4133 else if (SCM_BIGP (y
))
4135 SCM result
= scm_i_mkbig ();
4136 mpz_gcd (SCM_I_BIG_MPZ (result
),
4139 scm_remember_upto_here_2 (x
, y
);
4140 return scm_i_normbig (result
);
4143 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4146 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4149 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4150 (SCM x
, SCM y
, SCM rest
),
4151 "Return the least common multiple of the arguments.\n"
4152 "If called without arguments, 1 is returned.")
4153 #define FUNC_NAME s_scm_i_lcm
4155 while (!scm_is_null (rest
))
4156 { x
= scm_lcm (x
, y
);
4158 rest
= scm_cdr (rest
);
4160 return scm_lcm (x
, y
);
4164 #define s_lcm s_scm_i_lcm
4165 #define g_lcm g_scm_i_lcm
4168 scm_lcm (SCM n1
, SCM n2
)
4170 if (SCM_UNBNDP (n2
))
4172 if (SCM_UNBNDP (n1
))
4173 return SCM_I_MAKINUM (1L);
4174 n2
= SCM_I_MAKINUM (1L);
4177 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4178 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4179 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4180 g_lcm
, n1
, n2
, SCM_ARGn
, 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 (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 (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 (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 (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 (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 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6533 else if (SCM_BIGP (x
))
6535 if (SCM_I_INUMP (y
))
6537 else if (SCM_BIGP (y
))
6539 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6540 scm_remember_upto_here_2 (x
, y
);
6541 return scm_from_bool (0 == cmp
);
6543 else if (SCM_REALP (y
))
6546 if (isnan (SCM_REAL_VALUE (y
)))
6548 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6549 scm_remember_upto_here_1 (x
);
6550 return scm_from_bool (0 == cmp
);
6552 else if (SCM_COMPLEXP (y
))
6555 if (0.0 != SCM_COMPLEX_IMAG (y
))
6557 if (isnan (SCM_COMPLEX_REAL (y
)))
6559 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6560 scm_remember_upto_here_1 (x
);
6561 return scm_from_bool (0 == cmp
);
6563 else if (SCM_FRACTIONP (y
))
6566 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6568 else if (SCM_REALP (x
))
6570 double xx
= SCM_REAL_VALUE (x
);
6571 if (SCM_I_INUMP (y
))
6573 /* see comments with inum/real above */
6574 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6575 return scm_from_bool (xx
== (double) yy
6576 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6577 || (scm_t_signed_bits
) xx
== yy
));
6579 else if (SCM_BIGP (y
))
6582 if (isnan (SCM_REAL_VALUE (x
)))
6584 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6585 scm_remember_upto_here_1 (y
);
6586 return scm_from_bool (0 == cmp
);
6588 else if (SCM_REALP (y
))
6589 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6590 else if (SCM_COMPLEXP (y
))
6591 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6592 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6593 else if (SCM_FRACTIONP (y
))
6595 double xx
= SCM_REAL_VALUE (x
);
6599 return scm_from_bool (xx
< 0.0);
6600 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6604 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6606 else if (SCM_COMPLEXP (x
))
6608 if (SCM_I_INUMP (y
))
6609 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6610 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6611 else if (SCM_BIGP (y
))
6614 if (0.0 != SCM_COMPLEX_IMAG (x
))
6616 if (isnan (SCM_COMPLEX_REAL (x
)))
6618 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6619 scm_remember_upto_here_1 (y
);
6620 return scm_from_bool (0 == cmp
);
6622 else if (SCM_REALP (y
))
6623 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6624 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6625 else if (SCM_COMPLEXP (y
))
6626 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6627 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6628 else if (SCM_FRACTIONP (y
))
6631 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6633 xx
= SCM_COMPLEX_REAL (x
);
6637 return scm_from_bool (xx
< 0.0);
6638 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6642 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6644 else if (SCM_FRACTIONP (x
))
6646 if (SCM_I_INUMP (y
))
6648 else if (SCM_BIGP (y
))
6650 else if (SCM_REALP (y
))
6652 double yy
= SCM_REAL_VALUE (y
);
6656 return scm_from_bool (0.0 < yy
);
6657 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6660 else if (SCM_COMPLEXP (y
))
6663 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6665 yy
= SCM_COMPLEX_REAL (y
);
6669 return scm_from_bool (0.0 < yy
);
6670 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6673 else if (SCM_FRACTIONP (y
))
6674 return scm_i_fraction_equalp (x
, y
);
6676 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6679 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6683 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6684 done are good for inums, but for bignums an answer can almost always be
6685 had by just examining a few high bits of the operands, as done by GMP in
6686 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6687 of the float exponent to take into account. */
6689 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6690 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6691 (SCM x
, SCM y
, SCM rest
),
6692 "Return @code{#t} if the list of parameters is monotonically\n"
6694 #define FUNC_NAME s_scm_i_num_less_p
6696 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6698 while (!scm_is_null (rest
))
6700 if (scm_is_false (scm_less_p (x
, y
)))
6704 rest
= scm_cdr (rest
);
6706 return scm_less_p (x
, y
);
6710 scm_less_p (SCM x
, SCM y
)
6713 if (SCM_I_INUMP (x
))
6715 scm_t_inum xx
= SCM_I_INUM (x
);
6716 if (SCM_I_INUMP (y
))
6718 scm_t_inum yy
= SCM_I_INUM (y
);
6719 return scm_from_bool (xx
< yy
);
6721 else if (SCM_BIGP (y
))
6723 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6724 scm_remember_upto_here_1 (y
);
6725 return scm_from_bool (sgn
> 0);
6727 else if (SCM_REALP (y
))
6728 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6729 else if (SCM_FRACTIONP (y
))
6731 /* "x < a/b" becomes "x*b < a" */
6733 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6734 y
= SCM_FRACTION_NUMERATOR (y
);
6738 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6740 else if (SCM_BIGP (x
))
6742 if (SCM_I_INUMP (y
))
6744 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6745 scm_remember_upto_here_1 (x
);
6746 return scm_from_bool (sgn
< 0);
6748 else if (SCM_BIGP (y
))
6750 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6751 scm_remember_upto_here_2 (x
, y
);
6752 return scm_from_bool (cmp
< 0);
6754 else if (SCM_REALP (y
))
6757 if (isnan (SCM_REAL_VALUE (y
)))
6759 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6760 scm_remember_upto_here_1 (x
);
6761 return scm_from_bool (cmp
< 0);
6763 else if (SCM_FRACTIONP (y
))
6766 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6768 else if (SCM_REALP (x
))
6770 if (SCM_I_INUMP (y
))
6771 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6772 else if (SCM_BIGP (y
))
6775 if (isnan (SCM_REAL_VALUE (x
)))
6777 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6778 scm_remember_upto_here_1 (y
);
6779 return scm_from_bool (cmp
> 0);
6781 else if (SCM_REALP (y
))
6782 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6783 else if (SCM_FRACTIONP (y
))
6785 double xx
= SCM_REAL_VALUE (x
);
6789 return scm_from_bool (xx
< 0.0);
6790 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6794 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6796 else if (SCM_FRACTIONP (x
))
6798 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6800 /* "a/b < y" becomes "a < y*b" */
6801 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6802 x
= SCM_FRACTION_NUMERATOR (x
);
6805 else if (SCM_REALP (y
))
6807 double yy
= SCM_REAL_VALUE (y
);
6811 return scm_from_bool (0.0 < yy
);
6812 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6815 else if (SCM_FRACTIONP (y
))
6817 /* "a/b < c/d" becomes "a*d < c*b" */
6818 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6819 SCM_FRACTION_DENOMINATOR (y
));
6820 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6821 SCM_FRACTION_DENOMINATOR (x
));
6827 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6830 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6834 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6835 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6836 (SCM x
, SCM y
, SCM rest
),
6837 "Return @code{#t} if the list of parameters is monotonically\n"
6839 #define FUNC_NAME s_scm_i_num_gr_p
6841 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6843 while (!scm_is_null (rest
))
6845 if (scm_is_false (scm_gr_p (x
, y
)))
6849 rest
= scm_cdr (rest
);
6851 return scm_gr_p (x
, y
);
6854 #define FUNC_NAME s_scm_i_num_gr_p
6856 scm_gr_p (SCM x
, SCM y
)
6858 if (!SCM_NUMBERP (x
))
6859 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6860 else if (!SCM_NUMBERP (y
))
6861 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6863 return scm_less_p (y
, x
);
6868 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6869 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6870 (SCM x
, SCM y
, SCM rest
),
6871 "Return @code{#t} if the list of parameters is monotonically\n"
6873 #define FUNC_NAME s_scm_i_num_leq_p
6875 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6877 while (!scm_is_null (rest
))
6879 if (scm_is_false (scm_leq_p (x
, y
)))
6883 rest
= scm_cdr (rest
);
6885 return scm_leq_p (x
, y
);
6888 #define FUNC_NAME s_scm_i_num_leq_p
6890 scm_leq_p (SCM x
, SCM y
)
6892 if (!SCM_NUMBERP (x
))
6893 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6894 else if (!SCM_NUMBERP (y
))
6895 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6896 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6899 return scm_not (scm_less_p (y
, x
));
6904 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6905 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6906 (SCM x
, SCM y
, SCM rest
),
6907 "Return @code{#t} if the list of parameters is monotonically\n"
6909 #define FUNC_NAME s_scm_i_num_geq_p
6911 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6913 while (!scm_is_null (rest
))
6915 if (scm_is_false (scm_geq_p (x
, y
)))
6919 rest
= scm_cdr (rest
);
6921 return scm_geq_p (x
, y
);
6924 #define FUNC_NAME s_scm_i_num_geq_p
6926 scm_geq_p (SCM x
, SCM y
)
6928 if (!SCM_NUMBERP (x
))
6929 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6930 else if (!SCM_NUMBERP (y
))
6931 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6932 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6935 return scm_not (scm_less_p (x
, y
));
6940 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6942 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6944 #define FUNC_NAME s_scm_zero_p
6946 if (SCM_I_INUMP (z
))
6947 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6948 else if (SCM_BIGP (z
))
6950 else if (SCM_REALP (z
))
6951 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6952 else if (SCM_COMPLEXP (z
))
6953 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6954 && SCM_COMPLEX_IMAG (z
) == 0.0);
6955 else if (SCM_FRACTIONP (z
))
6958 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6963 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6965 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6967 #define FUNC_NAME s_scm_positive_p
6969 if (SCM_I_INUMP (x
))
6970 return scm_from_bool (SCM_I_INUM (x
) > 0);
6971 else if (SCM_BIGP (x
))
6973 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6974 scm_remember_upto_here_1 (x
);
6975 return scm_from_bool (sgn
> 0);
6977 else if (SCM_REALP (x
))
6978 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6979 else if (SCM_FRACTIONP (x
))
6980 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6982 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6987 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6989 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6991 #define FUNC_NAME s_scm_negative_p
6993 if (SCM_I_INUMP (x
))
6994 return scm_from_bool (SCM_I_INUM (x
) < 0);
6995 else if (SCM_BIGP (x
))
6997 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6998 scm_remember_upto_here_1 (x
);
6999 return scm_from_bool (sgn
< 0);
7001 else if (SCM_REALP (x
))
7002 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
7003 else if (SCM_FRACTIONP (x
))
7004 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
7006 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
7011 /* scm_min and scm_max return an inexact when either argument is inexact, as
7012 required by r5rs. On that basis, for exact/inexact combinations the
7013 exact is converted to inexact to compare and possibly return. This is
7014 unlike scm_less_p above which takes some trouble to preserve all bits in
7015 its test, such trouble is not required for min and max. */
7017 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
7018 (SCM x
, SCM y
, SCM rest
),
7019 "Return the maximum of all parameter values.")
7020 #define FUNC_NAME s_scm_i_max
7022 while (!scm_is_null (rest
))
7023 { x
= scm_max (x
, y
);
7025 rest
= scm_cdr (rest
);
7027 return scm_max (x
, y
);
7031 #define s_max s_scm_i_max
7032 #define g_max g_scm_i_max
7035 scm_max (SCM x
, SCM y
)
7040 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
7041 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7044 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
7047 if (SCM_I_INUMP (x
))
7049 scm_t_inum xx
= SCM_I_INUM (x
);
7050 if (SCM_I_INUMP (y
))
7052 scm_t_inum yy
= SCM_I_INUM (y
);
7053 return (xx
< yy
) ? y
: x
;
7055 else if (SCM_BIGP (y
))
7057 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7058 scm_remember_upto_here_1 (y
);
7059 return (sgn
< 0) ? x
: y
;
7061 else if (SCM_REALP (y
))
7064 double yyd
= SCM_REAL_VALUE (y
);
7067 return scm_from_double (xxd
);
7068 /* If y is a NaN, then "==" is false and we return the NaN */
7069 else if (SCM_LIKELY (!(xxd
== yyd
)))
7071 /* Handle signed zeroes properly */
7077 else if (SCM_FRACTIONP (y
))
7080 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
7083 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7085 else if (SCM_BIGP (x
))
7087 if (SCM_I_INUMP (y
))
7089 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7090 scm_remember_upto_here_1 (x
);
7091 return (sgn
< 0) ? y
: x
;
7093 else if (SCM_BIGP (y
))
7095 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7096 scm_remember_upto_here_2 (x
, y
);
7097 return (cmp
> 0) ? x
: y
;
7099 else if (SCM_REALP (y
))
7101 /* if y==NaN then xx>yy is false, so we return the NaN y */
7104 xx
= scm_i_big2dbl (x
);
7105 yy
= SCM_REAL_VALUE (y
);
7106 return (xx
> yy
? scm_from_double (xx
) : y
);
7108 else if (SCM_FRACTIONP (y
))
7113 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7115 else if (SCM_REALP (x
))
7117 if (SCM_I_INUMP (y
))
7119 scm_t_inum yy
= SCM_I_INUM (y
);
7120 double xxd
= SCM_REAL_VALUE (x
);
7124 return scm_from_double (yyd
);
7125 /* If x is a NaN, then "==" is false and we return the NaN */
7126 else if (SCM_LIKELY (!(xxd
== yyd
)))
7128 /* Handle signed zeroes properly */
7134 else if (SCM_BIGP (y
))
7139 else if (SCM_REALP (y
))
7141 double xx
= SCM_REAL_VALUE (x
);
7142 double yy
= SCM_REAL_VALUE (y
);
7144 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7147 else if (SCM_LIKELY (xx
< yy
))
7149 /* If neither (xx > yy) nor (xx < yy), then
7150 either they're equal or one is a NaN */
7151 else if (SCM_UNLIKELY (isnan (xx
)))
7152 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7153 else if (SCM_UNLIKELY (isnan (yy
)))
7154 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7155 /* xx == yy, but handle signed zeroes properly */
7156 else if (double_is_non_negative_zero (yy
))
7161 else if (SCM_FRACTIONP (y
))
7163 double yy
= scm_i_fraction2double (y
);
7164 double xx
= SCM_REAL_VALUE (x
);
7165 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7168 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7170 else if (SCM_FRACTIONP (x
))
7172 if (SCM_I_INUMP (y
))
7176 else if (SCM_BIGP (y
))
7180 else if (SCM_REALP (y
))
7182 double xx
= scm_i_fraction2double (x
);
7183 /* if y==NaN then ">" is false, so we return the NaN y */
7184 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7186 else if (SCM_FRACTIONP (y
))
7191 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7194 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7198 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7199 (SCM x
, SCM y
, SCM rest
),
7200 "Return the minimum of all parameter values.")
7201 #define FUNC_NAME s_scm_i_min
7203 while (!scm_is_null (rest
))
7204 { x
= scm_min (x
, y
);
7206 rest
= scm_cdr (rest
);
7208 return scm_min (x
, y
);
7212 #define s_min s_scm_i_min
7213 #define g_min g_scm_i_min
7216 scm_min (SCM x
, SCM y
)
7221 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7222 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7225 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7228 if (SCM_I_INUMP (x
))
7230 scm_t_inum xx
= SCM_I_INUM (x
);
7231 if (SCM_I_INUMP (y
))
7233 scm_t_inum yy
= SCM_I_INUM (y
);
7234 return (xx
< yy
) ? x
: y
;
7236 else if (SCM_BIGP (y
))
7238 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7239 scm_remember_upto_here_1 (y
);
7240 return (sgn
< 0) ? y
: x
;
7242 else if (SCM_REALP (y
))
7245 /* if y==NaN then "<" is false and we return NaN */
7246 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7248 else if (SCM_FRACTIONP (y
))
7251 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7254 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7256 else if (SCM_BIGP (x
))
7258 if (SCM_I_INUMP (y
))
7260 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7261 scm_remember_upto_here_1 (x
);
7262 return (sgn
< 0) ? x
: y
;
7264 else if (SCM_BIGP (y
))
7266 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7267 scm_remember_upto_here_2 (x
, y
);
7268 return (cmp
> 0) ? y
: x
;
7270 else if (SCM_REALP (y
))
7272 /* if y==NaN then xx<yy is false, so we return the NaN y */
7275 xx
= scm_i_big2dbl (x
);
7276 yy
= SCM_REAL_VALUE (y
);
7277 return (xx
< yy
? scm_from_double (xx
) : y
);
7279 else if (SCM_FRACTIONP (y
))
7284 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7286 else if (SCM_REALP (x
))
7288 if (SCM_I_INUMP (y
))
7290 double z
= SCM_I_INUM (y
);
7291 /* if x==NaN then "<" is false and we return NaN */
7292 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7294 else if (SCM_BIGP (y
))
7299 else if (SCM_REALP (y
))
7301 double xx
= SCM_REAL_VALUE (x
);
7302 double yy
= SCM_REAL_VALUE (y
);
7304 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7307 else if (SCM_LIKELY (xx
> yy
))
7309 /* If neither (xx < yy) nor (xx > yy), then
7310 either they're equal or one is a NaN */
7311 else if (SCM_UNLIKELY (isnan (xx
)))
7312 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7313 else if (SCM_UNLIKELY (isnan (yy
)))
7314 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7315 /* xx == yy, but handle signed zeroes properly */
7316 else if (double_is_non_negative_zero (xx
))
7321 else if (SCM_FRACTIONP (y
))
7323 double yy
= scm_i_fraction2double (y
);
7324 double xx
= SCM_REAL_VALUE (x
);
7325 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7328 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7330 else if (SCM_FRACTIONP (x
))
7332 if (SCM_I_INUMP (y
))
7336 else if (SCM_BIGP (y
))
7340 else if (SCM_REALP (y
))
7342 double xx
= scm_i_fraction2double (x
);
7343 /* if y==NaN then "<" is false, so we return the NaN y */
7344 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7346 else if (SCM_FRACTIONP (y
))
7351 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7354 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7358 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7359 (SCM x
, SCM y
, SCM rest
),
7360 "Return the sum of all parameter values. Return 0 if called without\n"
7362 #define FUNC_NAME s_scm_i_sum
7364 while (!scm_is_null (rest
))
7365 { x
= scm_sum (x
, y
);
7367 rest
= scm_cdr (rest
);
7369 return scm_sum (x
, y
);
7373 #define s_sum s_scm_i_sum
7374 #define g_sum g_scm_i_sum
7377 scm_sum (SCM x
, SCM y
)
7379 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7381 if (SCM_NUMBERP (x
)) return x
;
7382 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7383 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7386 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7388 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7390 scm_t_inum xx
= SCM_I_INUM (x
);
7391 scm_t_inum yy
= SCM_I_INUM (y
);
7392 scm_t_inum z
= xx
+ yy
;
7393 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7395 else if (SCM_BIGP (y
))
7400 else if (SCM_REALP (y
))
7402 scm_t_inum xx
= SCM_I_INUM (x
);
7403 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7405 else if (SCM_COMPLEXP (y
))
7407 scm_t_inum xx
= SCM_I_INUM (x
);
7408 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7409 SCM_COMPLEX_IMAG (y
));
7411 else if (SCM_FRACTIONP (y
))
7412 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7413 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7414 SCM_FRACTION_DENOMINATOR (y
));
7416 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7417 } else if (SCM_BIGP (x
))
7419 if (SCM_I_INUMP (y
))
7424 inum
= SCM_I_INUM (y
);
7427 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7430 SCM result
= scm_i_mkbig ();
7431 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7432 scm_remember_upto_here_1 (x
);
7433 /* we know the result will have to be a bignum */
7436 return scm_i_normbig (result
);
7440 SCM result
= scm_i_mkbig ();
7441 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7442 scm_remember_upto_here_1 (x
);
7443 /* we know the result will have to be a bignum */
7446 return scm_i_normbig (result
);
7449 else if (SCM_BIGP (y
))
7451 SCM result
= scm_i_mkbig ();
7452 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7453 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7454 mpz_add (SCM_I_BIG_MPZ (result
),
7457 scm_remember_upto_here_2 (x
, y
);
7458 /* we know the result will have to be a bignum */
7461 return scm_i_normbig (result
);
7463 else if (SCM_REALP (y
))
7465 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7466 scm_remember_upto_here_1 (x
);
7467 return scm_from_double (result
);
7469 else if (SCM_COMPLEXP (y
))
7471 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7472 + SCM_COMPLEX_REAL (y
));
7473 scm_remember_upto_here_1 (x
);
7474 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7476 else if (SCM_FRACTIONP (y
))
7477 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7478 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7479 SCM_FRACTION_DENOMINATOR (y
));
7481 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7483 else if (SCM_REALP (x
))
7485 if (SCM_I_INUMP (y
))
7486 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7487 else if (SCM_BIGP (y
))
7489 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7490 scm_remember_upto_here_1 (y
);
7491 return scm_from_double (result
);
7493 else if (SCM_REALP (y
))
7494 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7495 else if (SCM_COMPLEXP (y
))
7496 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7497 SCM_COMPLEX_IMAG (y
));
7498 else if (SCM_FRACTIONP (y
))
7499 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7501 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7503 else if (SCM_COMPLEXP (x
))
7505 if (SCM_I_INUMP (y
))
7506 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7507 SCM_COMPLEX_IMAG (x
));
7508 else if (SCM_BIGP (y
))
7510 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7511 + SCM_COMPLEX_REAL (x
));
7512 scm_remember_upto_here_1 (y
);
7513 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7515 else if (SCM_REALP (y
))
7516 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7517 SCM_COMPLEX_IMAG (x
));
7518 else if (SCM_COMPLEXP (y
))
7519 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7520 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7521 else if (SCM_FRACTIONP (y
))
7522 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7523 SCM_COMPLEX_IMAG (x
));
7525 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7527 else if (SCM_FRACTIONP (x
))
7529 if (SCM_I_INUMP (y
))
7530 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7531 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7532 SCM_FRACTION_DENOMINATOR (x
));
7533 else if (SCM_BIGP (y
))
7534 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7535 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7536 SCM_FRACTION_DENOMINATOR (x
));
7537 else if (SCM_REALP (y
))
7538 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7539 else if (SCM_COMPLEXP (y
))
7540 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7541 SCM_COMPLEX_IMAG (y
));
7542 else if (SCM_FRACTIONP (y
))
7543 /* a/b + c/d = (ad + bc) / bd */
7544 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7545 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7546 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7548 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7551 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7555 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7557 "Return @math{@var{x}+1}.")
7558 #define FUNC_NAME s_scm_oneplus
7560 return scm_sum (x
, SCM_INUM1
);
7565 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7566 (SCM x
, SCM y
, SCM rest
),
7567 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7568 "the sum of all but the first argument are subtracted from the first\n"
7570 #define FUNC_NAME s_scm_i_difference
7572 while (!scm_is_null (rest
))
7573 { x
= scm_difference (x
, y
);
7575 rest
= scm_cdr (rest
);
7577 return scm_difference (x
, y
);
7581 #define s_difference s_scm_i_difference
7582 #define g_difference g_scm_i_difference
7585 scm_difference (SCM x
, SCM y
)
7586 #define FUNC_NAME s_difference
7588 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7591 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7593 if (SCM_I_INUMP (x
))
7595 scm_t_inum xx
= -SCM_I_INUM (x
);
7596 if (SCM_FIXABLE (xx
))
7597 return SCM_I_MAKINUM (xx
);
7599 return scm_i_inum2big (xx
);
7601 else if (SCM_BIGP (x
))
7602 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7603 bignum, but negating that gives a fixnum. */
7604 return scm_i_normbig (scm_i_clonebig (x
, 0));
7605 else if (SCM_REALP (x
))
7606 return scm_from_double (-SCM_REAL_VALUE (x
));
7607 else if (SCM_COMPLEXP (x
))
7608 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7609 -SCM_COMPLEX_IMAG (x
));
7610 else if (SCM_FRACTIONP (x
))
7611 return scm_i_make_ratio_already_reduced
7612 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7613 SCM_FRACTION_DENOMINATOR (x
));
7615 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7618 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7620 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7622 scm_t_inum xx
= SCM_I_INUM (x
);
7623 scm_t_inum yy
= SCM_I_INUM (y
);
7624 scm_t_inum z
= xx
- yy
;
7625 if (SCM_FIXABLE (z
))
7626 return SCM_I_MAKINUM (z
);
7628 return scm_i_inum2big (z
);
7630 else if (SCM_BIGP (y
))
7632 /* inum-x - big-y */
7633 scm_t_inum xx
= SCM_I_INUM (x
);
7637 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7638 bignum, but negating that gives a fixnum. */
7639 return scm_i_normbig (scm_i_clonebig (y
, 0));
7643 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7644 SCM result
= scm_i_mkbig ();
7647 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7650 /* x - y == -(y + -x) */
7651 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7652 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7654 scm_remember_upto_here_1 (y
);
7656 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7657 /* we know the result will have to be a bignum */
7660 return scm_i_normbig (result
);
7663 else if (SCM_REALP (y
))
7665 scm_t_inum xx
= SCM_I_INUM (x
);
7668 * We need to handle x == exact 0
7669 * specially because R6RS states that:
7670 * (- 0.0) ==> -0.0 and
7671 * (- 0.0 0.0) ==> 0.0
7672 * and the scheme compiler changes
7673 * (- 0.0) into (- 0 0.0)
7674 * So we need to treat (- 0 0.0) like (- 0.0).
7675 * At the C level, (-x) is different than (0.0 - x).
7676 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7679 return scm_from_double (- SCM_REAL_VALUE (y
));
7681 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7683 else if (SCM_COMPLEXP (y
))
7685 scm_t_inum xx
= SCM_I_INUM (x
);
7687 /* We need to handle x == exact 0 specially.
7688 See the comment above (for SCM_REALP (y)) */
7690 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7691 - SCM_COMPLEX_IMAG (y
));
7693 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7694 - SCM_COMPLEX_IMAG (y
));
7696 else if (SCM_FRACTIONP (y
))
7697 /* a - b/c = (ac - b) / c */
7698 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7699 SCM_FRACTION_NUMERATOR (y
)),
7700 SCM_FRACTION_DENOMINATOR (y
));
7702 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7704 else if (SCM_BIGP (x
))
7706 if (SCM_I_INUMP (y
))
7708 /* big-x - inum-y */
7709 scm_t_inum yy
= SCM_I_INUM (y
);
7710 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7712 scm_remember_upto_here_1 (x
);
7714 return (SCM_FIXABLE (-yy
) ?
7715 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7718 SCM result
= scm_i_mkbig ();
7721 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7723 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7724 scm_remember_upto_here_1 (x
);
7726 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7727 /* we know the result will have to be a bignum */
7730 return scm_i_normbig (result
);
7733 else if (SCM_BIGP (y
))
7735 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7736 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7737 SCM result
= scm_i_mkbig ();
7738 mpz_sub (SCM_I_BIG_MPZ (result
),
7741 scm_remember_upto_here_2 (x
, y
);
7742 /* we know the result will have to be a bignum */
7743 if ((sgn_x
== 1) && (sgn_y
== -1))
7745 if ((sgn_x
== -1) && (sgn_y
== 1))
7747 return scm_i_normbig (result
);
7749 else if (SCM_REALP (y
))
7751 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7752 scm_remember_upto_here_1 (x
);
7753 return scm_from_double (result
);
7755 else if (SCM_COMPLEXP (y
))
7757 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7758 - SCM_COMPLEX_REAL (y
));
7759 scm_remember_upto_here_1 (x
);
7760 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7762 else if (SCM_FRACTIONP (y
))
7763 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7764 SCM_FRACTION_NUMERATOR (y
)),
7765 SCM_FRACTION_DENOMINATOR (y
));
7766 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7768 else if (SCM_REALP (x
))
7770 if (SCM_I_INUMP (y
))
7771 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7772 else if (SCM_BIGP (y
))
7774 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7775 scm_remember_upto_here_1 (x
);
7776 return scm_from_double (result
);
7778 else if (SCM_REALP (y
))
7779 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7780 else if (SCM_COMPLEXP (y
))
7781 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7782 -SCM_COMPLEX_IMAG (y
));
7783 else if (SCM_FRACTIONP (y
))
7784 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7786 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7788 else if (SCM_COMPLEXP (x
))
7790 if (SCM_I_INUMP (y
))
7791 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7792 SCM_COMPLEX_IMAG (x
));
7793 else if (SCM_BIGP (y
))
7795 double real_part
= (SCM_COMPLEX_REAL (x
)
7796 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7797 scm_remember_upto_here_1 (x
);
7798 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7800 else if (SCM_REALP (y
))
7801 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7802 SCM_COMPLEX_IMAG (x
));
7803 else if (SCM_COMPLEXP (y
))
7804 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7805 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7806 else if (SCM_FRACTIONP (y
))
7807 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7808 SCM_COMPLEX_IMAG (x
));
7810 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7812 else if (SCM_FRACTIONP (x
))
7814 if (SCM_I_INUMP (y
))
7815 /* a/b - c = (a - cb) / b */
7816 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7817 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7818 SCM_FRACTION_DENOMINATOR (x
));
7819 else if (SCM_BIGP (y
))
7820 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7821 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7822 SCM_FRACTION_DENOMINATOR (x
));
7823 else if (SCM_REALP (y
))
7824 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7825 else if (SCM_COMPLEXP (y
))
7826 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7827 -SCM_COMPLEX_IMAG (y
));
7828 else if (SCM_FRACTIONP (y
))
7829 /* a/b - c/d = (ad - bc) / bd */
7830 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7831 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7832 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7834 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7837 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7842 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7844 "Return @math{@var{x}-1}.")
7845 #define FUNC_NAME s_scm_oneminus
7847 return scm_difference (x
, SCM_INUM1
);
7852 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7853 (SCM x
, SCM y
, SCM rest
),
7854 "Return the product of all arguments. If called without arguments,\n"
7856 #define FUNC_NAME s_scm_i_product
7858 while (!scm_is_null (rest
))
7859 { x
= scm_product (x
, y
);
7861 rest
= scm_cdr (rest
);
7863 return scm_product (x
, y
);
7867 #define s_product s_scm_i_product
7868 #define g_product g_scm_i_product
7871 scm_product (SCM x
, SCM y
)
7873 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7876 return SCM_I_MAKINUM (1L);
7877 else if (SCM_NUMBERP (x
))
7880 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7883 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7888 xx
= SCM_I_INUM (x
);
7893 /* exact1 is the universal multiplicative identity */
7897 /* exact0 times a fixnum is exact0: optimize this case */
7898 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7900 /* if the other argument is inexact, the result is inexact,
7901 and we must do the multiplication in order to handle
7902 infinities and NaNs properly. */
7903 else if (SCM_REALP (y
))
7904 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7905 else if (SCM_COMPLEXP (y
))
7906 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7907 0.0 * SCM_COMPLEX_IMAG (y
));
7908 /* we've already handled inexact numbers,
7909 so y must be exact, and we return exact0 */
7910 else if (SCM_NUMP (y
))
7913 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7917 * This case is important for more than just optimization.
7918 * It handles the case of negating
7919 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7920 * which is a bignum that must be changed back into a fixnum.
7921 * Failure to do so will cause the following to return #f:
7922 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7924 return scm_difference(y
, SCM_UNDEFINED
);
7928 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7930 scm_t_inum yy
= SCM_I_INUM (y
);
7931 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7932 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7933 if (SCM_FIXABLE (kk
))
7934 return SCM_I_MAKINUM (kk
);
7936 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7937 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7938 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7939 return SCM_I_MAKINUM (xx
* yy
);
7943 SCM result
= scm_i_inum2big (xx
);
7944 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7945 return scm_i_normbig (result
);
7948 else if (SCM_BIGP (y
))
7950 SCM result
= scm_i_mkbig ();
7951 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7952 scm_remember_upto_here_1 (y
);
7955 else if (SCM_REALP (y
))
7956 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7957 else if (SCM_COMPLEXP (y
))
7958 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7959 xx
* SCM_COMPLEX_IMAG (y
));
7960 else if (SCM_FRACTIONP (y
))
7961 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7962 SCM_FRACTION_DENOMINATOR (y
));
7964 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7966 else if (SCM_BIGP (x
))
7968 if (SCM_I_INUMP (y
))
7973 else if (SCM_BIGP (y
))
7975 SCM result
= scm_i_mkbig ();
7976 mpz_mul (SCM_I_BIG_MPZ (result
),
7979 scm_remember_upto_here_2 (x
, y
);
7982 else if (SCM_REALP (y
))
7984 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7985 scm_remember_upto_here_1 (x
);
7986 return scm_from_double (result
);
7988 else if (SCM_COMPLEXP (y
))
7990 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7991 scm_remember_upto_here_1 (x
);
7992 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7993 z
* SCM_COMPLEX_IMAG (y
));
7995 else if (SCM_FRACTIONP (y
))
7996 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7997 SCM_FRACTION_DENOMINATOR (y
));
7999 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8001 else if (SCM_REALP (x
))
8003 if (SCM_I_INUMP (y
))
8008 else if (SCM_BIGP (y
))
8010 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
8011 scm_remember_upto_here_1 (y
);
8012 return scm_from_double (result
);
8014 else if (SCM_REALP (y
))
8015 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
8016 else if (SCM_COMPLEXP (y
))
8017 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
8018 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
8019 else if (SCM_FRACTIONP (y
))
8020 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
8022 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8024 else if (SCM_COMPLEXP (x
))
8026 if (SCM_I_INUMP (y
))
8031 else if (SCM_BIGP (y
))
8033 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8034 scm_remember_upto_here_1 (y
);
8035 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
8036 z
* SCM_COMPLEX_IMAG (x
));
8038 else if (SCM_REALP (y
))
8039 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
8040 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
8041 else if (SCM_COMPLEXP (y
))
8043 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
8044 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
8045 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
8046 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
8048 else if (SCM_FRACTIONP (y
))
8050 double yy
= scm_i_fraction2double (y
);
8051 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
8052 yy
* SCM_COMPLEX_IMAG (x
));
8055 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8057 else if (SCM_FRACTIONP (x
))
8059 if (SCM_I_INUMP (y
))
8060 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8061 SCM_FRACTION_DENOMINATOR (x
));
8062 else if (SCM_BIGP (y
))
8063 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
8064 SCM_FRACTION_DENOMINATOR (x
));
8065 else if (SCM_REALP (y
))
8066 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
8067 else if (SCM_COMPLEXP (y
))
8069 double xx
= scm_i_fraction2double (x
);
8070 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
8071 xx
* SCM_COMPLEX_IMAG (y
));
8073 else if (SCM_FRACTIONP (y
))
8074 /* a/b * c/d = ac / bd */
8075 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
8076 SCM_FRACTION_NUMERATOR (y
)),
8077 scm_product (SCM_FRACTION_DENOMINATOR (x
),
8078 SCM_FRACTION_DENOMINATOR (y
)));
8080 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
8083 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
8086 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8087 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8088 #define ALLOW_DIVIDE_BY_ZERO
8089 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8092 /* The code below for complex division is adapted from the GNU
8093 libstdc++, which adapted it from f2c's libF77, and is subject to
8096 /****************************************************************
8097 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8099 Permission to use, copy, modify, and distribute this software
8100 and its documentation for any purpose and without fee is hereby
8101 granted, provided that the above copyright notice appear in all
8102 copies and that both that the copyright notice and this
8103 permission notice and warranty disclaimer appear in supporting
8104 documentation, and that the names of AT&T Bell Laboratories or
8105 Bellcore or any of their entities not be used in advertising or
8106 publicity pertaining to distribution of the software without
8107 specific, written prior permission.
8109 AT&T and Bellcore disclaim all warranties with regard to this
8110 software, including all implied warranties of merchantability
8111 and fitness. In no event shall AT&T or Bellcore be liable for
8112 any special, indirect or consequential damages or any damages
8113 whatsoever resulting from loss of use, data or profits, whether
8114 in an action of contract, negligence or other tortious action,
8115 arising out of or in connection with the use or performance of
8117 ****************************************************************/
8119 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
8120 (SCM x
, SCM y
, SCM rest
),
8121 "Divide the first argument by the product of the remaining\n"
8122 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8124 #define FUNC_NAME s_scm_i_divide
8126 while (!scm_is_null (rest
))
8127 { x
= scm_divide (x
, y
);
8129 rest
= scm_cdr (rest
);
8131 return scm_divide (x
, y
);
8135 #define s_divide s_scm_i_divide
8136 #define g_divide g_scm_i_divide
8139 scm_divide (SCM x
, SCM y
)
8140 #define FUNC_NAME s_divide
8144 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8147 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8148 else if (SCM_I_INUMP (x
))
8150 scm_t_inum xx
= SCM_I_INUM (x
);
8151 if (xx
== 1 || xx
== -1)
8153 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8155 scm_num_overflow (s_divide
);
8158 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8160 else if (SCM_BIGP (x
))
8161 return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8162 else if (SCM_REALP (x
))
8164 double xx
= SCM_REAL_VALUE (x
);
8165 #ifndef ALLOW_DIVIDE_BY_ZERO
8167 scm_num_overflow (s_divide
);
8170 return scm_from_double (1.0 / xx
);
8172 else if (SCM_COMPLEXP (x
))
8174 double r
= SCM_COMPLEX_REAL (x
);
8175 double i
= SCM_COMPLEX_IMAG (x
);
8176 if (fabs(r
) <= fabs(i
))
8179 double d
= i
* (1.0 + t
* t
);
8180 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8185 double d
= r
* (1.0 + t
* t
);
8186 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8189 else if (SCM_FRACTIONP (x
))
8190 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8191 SCM_FRACTION_NUMERATOR (x
));
8193 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8196 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8198 scm_t_inum xx
= SCM_I_INUM (x
);
8199 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8201 scm_t_inum yy
= SCM_I_INUM (y
);
8204 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8205 scm_num_overflow (s_divide
);
8207 return scm_from_double ((double) xx
/ (double) yy
);
8210 else if (xx
% yy
!= 0)
8211 return scm_i_make_ratio (x
, y
);
8214 scm_t_inum z
= xx
/ yy
;
8215 if (SCM_FIXABLE (z
))
8216 return SCM_I_MAKINUM (z
);
8218 return scm_i_inum2big (z
);
8221 else if (SCM_BIGP (y
))
8222 return scm_i_make_ratio (x
, y
);
8223 else if (SCM_REALP (y
))
8225 double yy
= SCM_REAL_VALUE (y
);
8226 #ifndef ALLOW_DIVIDE_BY_ZERO
8228 scm_num_overflow (s_divide
);
8231 /* FIXME: Precision may be lost here due to:
8232 (1) The cast from 'scm_t_inum' to 'double'
8233 (2) Double rounding */
8234 return scm_from_double ((double) xx
/ yy
);
8236 else if (SCM_COMPLEXP (y
))
8239 complex_div
: /* y _must_ be a complex number */
8241 double r
= SCM_COMPLEX_REAL (y
);
8242 double i
= SCM_COMPLEX_IMAG (y
);
8243 if (fabs(r
) <= fabs(i
))
8246 double d
= i
* (1.0 + t
* t
);
8247 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8252 double d
= r
* (1.0 + t
* t
);
8253 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8257 else if (SCM_FRACTIONP (y
))
8258 /* a / b/c = ac / b */
8259 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8260 SCM_FRACTION_NUMERATOR (y
));
8262 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8264 else if (SCM_BIGP (x
))
8266 if (SCM_I_INUMP (y
))
8268 scm_t_inum yy
= SCM_I_INUM (y
);
8271 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8272 scm_num_overflow (s_divide
);
8274 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8275 scm_remember_upto_here_1 (x
);
8276 return (sgn
== 0) ? scm_nan () : scm_inf ();
8283 /* FIXME: HMM, what are the relative performance issues here?
8284 We need to test. Is it faster on average to test
8285 divisible_p, then perform whichever operation, or is it
8286 faster to perform the integer div opportunistically and
8287 switch to real if there's a remainder? For now we take the
8288 middle ground: test, then if divisible, use the faster div
8291 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8292 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8296 SCM result
= scm_i_mkbig ();
8297 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8298 scm_remember_upto_here_1 (x
);
8300 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8301 return scm_i_normbig (result
);
8304 return scm_i_make_ratio (x
, y
);
8307 else if (SCM_BIGP (y
))
8309 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8313 SCM result
= scm_i_mkbig ();
8314 mpz_divexact (SCM_I_BIG_MPZ (result
),
8317 scm_remember_upto_here_2 (x
, y
);
8318 return scm_i_normbig (result
);
8321 return scm_i_make_ratio (x
, y
);
8323 else if (SCM_REALP (y
))
8325 double yy
= SCM_REAL_VALUE (y
);
8326 #ifndef ALLOW_DIVIDE_BY_ZERO
8328 scm_num_overflow (s_divide
);
8331 /* FIXME: Precision may be lost here due to:
8332 (1) scm_i_big2dbl (2) Double rounding */
8333 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8335 else if (SCM_COMPLEXP (y
))
8337 a
= scm_i_big2dbl (x
);
8340 else if (SCM_FRACTIONP (y
))
8341 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8342 SCM_FRACTION_NUMERATOR (y
));
8344 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8346 else if (SCM_REALP (x
))
8348 double rx
= SCM_REAL_VALUE (x
);
8349 if (SCM_I_INUMP (y
))
8351 scm_t_inum yy
= SCM_I_INUM (y
);
8352 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8354 scm_num_overflow (s_divide
);
8357 /* FIXME: Precision may be lost here due to:
8358 (1) The cast from 'scm_t_inum' to 'double'
8359 (2) Double rounding */
8360 return scm_from_double (rx
/ (double) yy
);
8362 else if (SCM_BIGP (y
))
8364 /* FIXME: Precision may be lost here due to:
8365 (1) The conversion from bignum to double
8366 (2) Double rounding */
8367 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8368 scm_remember_upto_here_1 (y
);
8369 return scm_from_double (rx
/ dby
);
8371 else if (SCM_REALP (y
))
8373 double yy
= SCM_REAL_VALUE (y
);
8374 #ifndef ALLOW_DIVIDE_BY_ZERO
8376 scm_num_overflow (s_divide
);
8379 return scm_from_double (rx
/ yy
);
8381 else if (SCM_COMPLEXP (y
))
8386 else if (SCM_FRACTIONP (y
))
8387 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8389 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8391 else if (SCM_COMPLEXP (x
))
8393 double rx
= SCM_COMPLEX_REAL (x
);
8394 double ix
= SCM_COMPLEX_IMAG (x
);
8395 if (SCM_I_INUMP (y
))
8397 scm_t_inum yy
= SCM_I_INUM (y
);
8398 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8400 scm_num_overflow (s_divide
);
8404 /* FIXME: Precision may be lost here due to:
8405 (1) The conversion from 'scm_t_inum' to double
8406 (2) Double rounding */
8408 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8411 else if (SCM_BIGP (y
))
8413 /* FIXME: Precision may be lost here due to:
8414 (1) The conversion from bignum to double
8415 (2) Double rounding */
8416 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8417 scm_remember_upto_here_1 (y
);
8418 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8420 else if (SCM_REALP (y
))
8422 double yy
= SCM_REAL_VALUE (y
);
8423 #ifndef ALLOW_DIVIDE_BY_ZERO
8425 scm_num_overflow (s_divide
);
8428 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8430 else if (SCM_COMPLEXP (y
))
8432 double ry
= SCM_COMPLEX_REAL (y
);
8433 double iy
= SCM_COMPLEX_IMAG (y
);
8434 if (fabs(ry
) <= fabs(iy
))
8437 double d
= iy
* (1.0 + t
* t
);
8438 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8443 double d
= ry
* (1.0 + t
* t
);
8444 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8447 else if (SCM_FRACTIONP (y
))
8449 /* FIXME: Precision may be lost here due to:
8450 (1) The conversion from fraction to double
8451 (2) Double rounding */
8452 double yy
= scm_i_fraction2double (y
);
8453 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8456 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8458 else if (SCM_FRACTIONP (x
))
8460 if (SCM_I_INUMP (y
))
8462 scm_t_inum yy
= SCM_I_INUM (y
);
8463 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8465 scm_num_overflow (s_divide
);
8468 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8469 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8471 else if (SCM_BIGP (y
))
8473 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8474 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8476 else if (SCM_REALP (y
))
8478 double yy
= SCM_REAL_VALUE (y
);
8479 #ifndef ALLOW_DIVIDE_BY_ZERO
8481 scm_num_overflow (s_divide
);
8484 /* FIXME: Precision may be lost here due to:
8485 (1) The conversion from fraction to double
8486 (2) Double rounding */
8487 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8489 else if (SCM_COMPLEXP (y
))
8491 /* FIXME: Precision may be lost here due to:
8492 (1) The conversion from fraction to double
8493 (2) Double rounding */
8494 a
= scm_i_fraction2double (x
);
8497 else if (SCM_FRACTIONP (y
))
8498 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8499 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8501 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8504 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8510 scm_c_truncate (double x
)
8515 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8516 half-way case (ie. when x is an integer plus 0.5) going upwards.
8517 Then half-way cases are identified and adjusted down if the
8518 round-upwards didn't give the desired even integer.
8520 "plus_half == result" identifies a half-way case. If plus_half, which is
8521 x + 0.5, is an integer then x must be an integer plus 0.5.
8523 An odd "result" value is identified with result/2 != floor(result/2).
8524 This is done with plus_half, since that value is ready for use sooner in
8525 a pipelined cpu, and we're already requiring plus_half == result.
8527 Note however that we need to be careful when x is big and already an
8528 integer. In that case "x+0.5" may round to an adjacent integer, causing
8529 us to return such a value, incorrectly. For instance if the hardware is
8530 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8531 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8532 returned. Or if the hardware is in round-upwards mode, then other bigger
8533 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8534 representable value, 2^128+2^76 (or whatever), again incorrect.
8536 These bad roundings of x+0.5 are avoided by testing at the start whether
8537 x is already an integer. If it is then clearly that's the desired result
8538 already. And if it's not then the exponent must be small enough to allow
8539 an 0.5 to be represented, and hence added without a bad rounding. */
8542 scm_c_round (double x
)
8544 double plus_half
, result
;
8549 plus_half
= x
+ 0.5;
8550 result
= floor (plus_half
);
8551 /* Adjust so that the rounding is towards even. */
8552 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8557 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8559 "Round the number @var{x} towards zero.")
8560 #define FUNC_NAME s_scm_truncate_number
8562 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8564 else if (SCM_REALP (x
))
8565 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8566 else if (SCM_FRACTIONP (x
))
8567 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8568 SCM_FRACTION_DENOMINATOR (x
));
8570 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8571 s_scm_truncate_number
);
8575 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8577 "Round the number @var{x} towards the nearest integer. "
8578 "When it is exactly halfway between two integers, "
8579 "round towards the even one.")
8580 #define FUNC_NAME s_scm_round_number
8582 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8584 else if (SCM_REALP (x
))
8585 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8586 else if (SCM_FRACTIONP (x
))
8587 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8588 SCM_FRACTION_DENOMINATOR (x
));
8590 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8591 s_scm_round_number
);
8595 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8597 "Round the number @var{x} towards minus infinity.")
8598 #define FUNC_NAME s_scm_floor
8600 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8602 else if (SCM_REALP (x
))
8603 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8604 else if (SCM_FRACTIONP (x
))
8605 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8606 SCM_FRACTION_DENOMINATOR (x
));
8608 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8612 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8614 "Round the number @var{x} towards infinity.")
8615 #define FUNC_NAME s_scm_ceiling
8617 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8619 else if (SCM_REALP (x
))
8620 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8621 else if (SCM_FRACTIONP (x
))
8622 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8623 SCM_FRACTION_DENOMINATOR (x
));
8625 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8629 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8631 "Return @var{x} raised to the power of @var{y}.")
8632 #define FUNC_NAME s_scm_expt
8634 if (scm_is_integer (y
))
8636 if (scm_is_true (scm_exact_p (y
)))
8637 return scm_integer_expt (x
, y
);
8640 /* Here we handle the case where the exponent is an inexact
8641 integer. We make the exponent exact in order to use
8642 scm_integer_expt, and thus avoid the spurious imaginary
8643 parts that may result from round-off errors in the general
8644 e^(y log x) method below (for example when squaring a large
8645 negative number). In this case, we must return an inexact
8646 result for correctness. We also make the base inexact so
8647 that scm_integer_expt will use fast inexact arithmetic
8648 internally. Note that making the base inexact is not
8649 sufficient to guarantee an inexact result, because
8650 scm_integer_expt will return an exact 1 when the exponent
8651 is 0, even if the base is inexact. */
8652 return scm_exact_to_inexact
8653 (scm_integer_expt (scm_exact_to_inexact (x
),
8654 scm_inexact_to_exact (y
)));
8657 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8659 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8661 else if (scm_is_complex (x
) && scm_is_complex (y
))
8662 return scm_exp (scm_product (scm_log (x
), y
));
8663 else if (scm_is_complex (x
))
8664 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8666 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8670 /* sin/cos/tan/asin/acos/atan
8671 sinh/cosh/tanh/asinh/acosh/atanh
8672 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8673 Written by Jerry D. Hedden, (C) FSF.
8674 See the file `COPYING' for terms applying to this program. */
8676 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8678 "Compute the sine of @var{z}.")
8679 #define FUNC_NAME s_scm_sin
8681 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8682 return z
; /* sin(exact0) = exact0 */
8683 else if (scm_is_real (z
))
8684 return scm_from_double (sin (scm_to_double (z
)));
8685 else if (SCM_COMPLEXP (z
))
8687 x
= SCM_COMPLEX_REAL (z
);
8688 y
= SCM_COMPLEX_IMAG (z
);
8689 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8690 cos (x
) * sinh (y
));
8693 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8697 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8699 "Compute the cosine of @var{z}.")
8700 #define FUNC_NAME s_scm_cos
8702 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8703 return SCM_INUM1
; /* cos(exact0) = exact1 */
8704 else if (scm_is_real (z
))
8705 return scm_from_double (cos (scm_to_double (z
)));
8706 else if (SCM_COMPLEXP (z
))
8708 x
= SCM_COMPLEX_REAL (z
);
8709 y
= SCM_COMPLEX_IMAG (z
);
8710 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8711 -sin (x
) * sinh (y
));
8714 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8718 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8720 "Compute the tangent of @var{z}.")
8721 #define FUNC_NAME s_scm_tan
8723 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8724 return z
; /* tan(exact0) = exact0 */
8725 else if (scm_is_real (z
))
8726 return scm_from_double (tan (scm_to_double (z
)));
8727 else if (SCM_COMPLEXP (z
))
8729 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8730 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8731 w
= cos (x
) + cosh (y
);
8732 #ifndef ALLOW_DIVIDE_BY_ZERO
8734 scm_num_overflow (s_scm_tan
);
8736 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8739 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8743 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8745 "Compute the hyperbolic sine of @var{z}.")
8746 #define FUNC_NAME s_scm_sinh
8748 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8749 return z
; /* sinh(exact0) = exact0 */
8750 else if (scm_is_real (z
))
8751 return scm_from_double (sinh (scm_to_double (z
)));
8752 else if (SCM_COMPLEXP (z
))
8754 x
= SCM_COMPLEX_REAL (z
);
8755 y
= SCM_COMPLEX_IMAG (z
);
8756 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8757 cosh (x
) * sin (y
));
8760 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8764 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8766 "Compute the hyperbolic cosine of @var{z}.")
8767 #define FUNC_NAME s_scm_cosh
8769 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8770 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8771 else if (scm_is_real (z
))
8772 return scm_from_double (cosh (scm_to_double (z
)));
8773 else if (SCM_COMPLEXP (z
))
8775 x
= SCM_COMPLEX_REAL (z
);
8776 y
= SCM_COMPLEX_IMAG (z
);
8777 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8778 sinh (x
) * sin (y
));
8781 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8785 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8787 "Compute the hyperbolic tangent of @var{z}.")
8788 #define FUNC_NAME s_scm_tanh
8790 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8791 return z
; /* tanh(exact0) = exact0 */
8792 else if (scm_is_real (z
))
8793 return scm_from_double (tanh (scm_to_double (z
)));
8794 else if (SCM_COMPLEXP (z
))
8796 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8797 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8798 w
= cosh (x
) + cos (y
);
8799 #ifndef ALLOW_DIVIDE_BY_ZERO
8801 scm_num_overflow (s_scm_tanh
);
8803 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8806 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8810 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8812 "Compute the arc sine of @var{z}.")
8813 #define FUNC_NAME s_scm_asin
8815 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8816 return z
; /* asin(exact0) = exact0 */
8817 else if (scm_is_real (z
))
8819 double w
= scm_to_double (z
);
8820 if (w
>= -1.0 && w
<= 1.0)
8821 return scm_from_double (asin (w
));
8823 return scm_product (scm_c_make_rectangular (0, -1),
8824 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8826 else if (SCM_COMPLEXP (z
))
8828 x
= SCM_COMPLEX_REAL (z
);
8829 y
= SCM_COMPLEX_IMAG (z
);
8830 return scm_product (scm_c_make_rectangular (0, -1),
8831 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8834 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8838 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8840 "Compute the arc cosine of @var{z}.")
8841 #define FUNC_NAME s_scm_acos
8843 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8844 return SCM_INUM0
; /* acos(exact1) = exact0 */
8845 else if (scm_is_real (z
))
8847 double w
= scm_to_double (z
);
8848 if (w
>= -1.0 && w
<= 1.0)
8849 return scm_from_double (acos (w
));
8851 return scm_sum (scm_from_double (acos (0.0)),
8852 scm_product (scm_c_make_rectangular (0, 1),
8853 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8855 else if (SCM_COMPLEXP (z
))
8857 x
= SCM_COMPLEX_REAL (z
);
8858 y
= SCM_COMPLEX_IMAG (z
);
8859 return scm_sum (scm_from_double (acos (0.0)),
8860 scm_product (scm_c_make_rectangular (0, 1),
8861 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8864 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8868 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8870 "With one argument, compute the arc tangent of @var{z}.\n"
8871 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8872 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8873 #define FUNC_NAME s_scm_atan
8877 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8878 return z
; /* atan(exact0) = exact0 */
8879 else if (scm_is_real (z
))
8880 return scm_from_double (atan (scm_to_double (z
)));
8881 else if (SCM_COMPLEXP (z
))
8884 v
= SCM_COMPLEX_REAL (z
);
8885 w
= SCM_COMPLEX_IMAG (z
);
8886 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8887 scm_c_make_rectangular (v
, w
+ 1.0))),
8888 scm_c_make_rectangular (0, 2));
8891 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8893 else if (scm_is_real (z
))
8895 if (scm_is_real (y
))
8896 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8898 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8901 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8905 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8907 "Compute the inverse hyperbolic sine of @var{z}.")
8908 #define FUNC_NAME s_scm_sys_asinh
8910 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8911 return z
; /* asinh(exact0) = exact0 */
8912 else if (scm_is_real (z
))
8913 return scm_from_double (asinh (scm_to_double (z
)));
8914 else if (scm_is_number (z
))
8915 return scm_log (scm_sum (z
,
8916 scm_sqrt (scm_sum (scm_product (z
, z
),
8919 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8923 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8925 "Compute the inverse hyperbolic cosine of @var{z}.")
8926 #define FUNC_NAME s_scm_sys_acosh
8928 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8929 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8930 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8931 return scm_from_double (acosh (scm_to_double (z
)));
8932 else if (scm_is_number (z
))
8933 return scm_log (scm_sum (z
,
8934 scm_sqrt (scm_difference (scm_product (z
, z
),
8937 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8941 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8943 "Compute the inverse hyperbolic tangent of @var{z}.")
8944 #define FUNC_NAME s_scm_sys_atanh
8946 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8947 return z
; /* atanh(exact0) = exact0 */
8948 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8949 return scm_from_double (atanh (scm_to_double (z
)));
8950 else if (scm_is_number (z
))
8951 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8952 scm_difference (SCM_INUM1
, z
))),
8955 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8960 scm_c_make_rectangular (double re
, double im
)
8964 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8966 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8967 SCM_COMPLEX_REAL (z
) = re
;
8968 SCM_COMPLEX_IMAG (z
) = im
;
8972 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8973 (SCM real_part
, SCM imaginary_part
),
8974 "Return a complex number constructed of the given @var{real_part} "
8975 "and @var{imaginary_part} parts.")
8976 #define FUNC_NAME s_scm_make_rectangular
8978 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8979 SCM_ARG1
, FUNC_NAME
, "real");
8980 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8981 SCM_ARG2
, FUNC_NAME
, "real");
8983 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8984 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8987 return scm_c_make_rectangular (scm_to_double (real_part
),
8988 scm_to_double (imaginary_part
));
8993 scm_c_make_polar (double mag
, double ang
)
8997 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8998 use it on Glibc-based systems that have it (it's a GNU extension). See
8999 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9001 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9002 sincos (ang
, &s
, &c
);
9008 /* If s and c are NaNs, this indicates that the angle is a NaN,
9009 infinite, or perhaps simply too large to determine its value
9010 mod 2*pi. However, we know something that the floating-point
9011 implementation doesn't know: We know that s and c are finite.
9012 Therefore, if the magnitude is zero, return a complex zero.
9014 The reason we check for the NaNs instead of using this case
9015 whenever mag == 0.0 is because when the angle is known, we'd
9016 like to return the correct kind of non-real complex zero:
9017 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9018 on which quadrant the angle is in.
9020 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
9021 return scm_c_make_rectangular (0.0, 0.0);
9023 return scm_c_make_rectangular (mag
* c
, mag
* s
);
9026 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
9028 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9029 #define FUNC_NAME s_scm_make_polar
9031 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
9032 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
9034 /* If mag is exact0, return exact0 */
9035 if (scm_is_eq (mag
, SCM_INUM0
))
9037 /* Return a real if ang is exact0 */
9038 else if (scm_is_eq (ang
, SCM_INUM0
))
9041 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
9046 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
9048 "Return the real part of the number @var{z}.")
9049 #define FUNC_NAME s_scm_real_part
9051 if (SCM_COMPLEXP (z
))
9052 return scm_from_double (SCM_COMPLEX_REAL (z
));
9053 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
9056 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
9061 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
9063 "Return the imaginary part of the number @var{z}.")
9064 #define FUNC_NAME s_scm_imag_part
9066 if (SCM_COMPLEXP (z
))
9067 return scm_from_double (SCM_COMPLEX_IMAG (z
));
9068 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9071 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
9075 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
9077 "Return the numerator of the number @var{z}.")
9078 #define FUNC_NAME s_scm_numerator
9080 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9082 else if (SCM_FRACTIONP (z
))
9083 return SCM_FRACTION_NUMERATOR (z
);
9084 else if (SCM_REALP (z
))
9085 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
9087 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
9092 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
9094 "Return the denominator of the number @var{z}.")
9095 #define FUNC_NAME s_scm_denominator
9097 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
9099 else if (SCM_FRACTIONP (z
))
9100 return SCM_FRACTION_DENOMINATOR (z
);
9101 else if (SCM_REALP (z
))
9102 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
9104 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
9109 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
9111 "Return the magnitude of the number @var{z}. This is the same as\n"
9112 "@code{abs} for real arguments, but also allows complex numbers.")
9113 #define FUNC_NAME s_scm_magnitude
9115 if (SCM_I_INUMP (z
))
9117 scm_t_inum zz
= SCM_I_INUM (z
);
9120 else if (SCM_POSFIXABLE (-zz
))
9121 return SCM_I_MAKINUM (-zz
);
9123 return scm_i_inum2big (-zz
);
9125 else if (SCM_BIGP (z
))
9127 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9128 scm_remember_upto_here_1 (z
);
9130 return scm_i_clonebig (z
, 0);
9134 else if (SCM_REALP (z
))
9135 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9136 else if (SCM_COMPLEXP (z
))
9137 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9138 else if (SCM_FRACTIONP (z
))
9140 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9142 return scm_i_make_ratio_already_reduced
9143 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9144 SCM_FRACTION_DENOMINATOR (z
));
9147 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9152 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9154 "Return the angle of the complex number @var{z}.")
9155 #define FUNC_NAME s_scm_angle
9157 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9158 flo0 to save allocating a new flonum with scm_from_double each time.
9159 But if atan2 follows the floating point rounding mode, then the value
9160 is not a constant. Maybe it'd be close enough though. */
9161 if (SCM_I_INUMP (z
))
9163 if (SCM_I_INUM (z
) >= 0)
9166 return scm_from_double (atan2 (0.0, -1.0));
9168 else if (SCM_BIGP (z
))
9170 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9171 scm_remember_upto_here_1 (z
);
9173 return scm_from_double (atan2 (0.0, -1.0));
9177 else if (SCM_REALP (z
))
9179 double x
= SCM_REAL_VALUE (z
);
9180 if (x
> 0.0 || double_is_non_negative_zero (x
))
9183 return scm_from_double (atan2 (0.0, -1.0));
9185 else if (SCM_COMPLEXP (z
))
9186 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9187 else if (SCM_FRACTIONP (z
))
9189 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9191 else return scm_from_double (atan2 (0.0, -1.0));
9194 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9199 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9201 "Convert the number @var{z} to its inexact representation.\n")
9202 #define FUNC_NAME s_scm_exact_to_inexact
9204 if (SCM_I_INUMP (z
))
9205 return scm_from_double ((double) SCM_I_INUM (z
));
9206 else if (SCM_BIGP (z
))
9207 return scm_from_double (scm_i_big2dbl (z
));
9208 else if (SCM_FRACTIONP (z
))
9209 return scm_from_double (scm_i_fraction2double (z
));
9210 else if (SCM_INEXACTP (z
))
9213 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9218 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9220 "Return an exact number that is numerically closest to @var{z}.")
9221 #define FUNC_NAME s_scm_inexact_to_exact
9223 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9230 val
= SCM_REAL_VALUE (z
);
9231 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9232 val
= SCM_COMPLEX_REAL (z
);
9234 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9236 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9237 SCM_OUT_OF_RANGE (1, z
);
9238 else if (val
== 0.0)
9245 numerator
= scm_i_dbl2big (ldexp (frexp (val
, &expon
),
9247 expon
-= DBL_MANT_DIG
;
9250 int shift
= mpz_scan1 (SCM_I_BIG_MPZ (numerator
), 0);
9254 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator
),
9255 SCM_I_BIG_MPZ (numerator
),
9259 numerator
= scm_i_normbig (numerator
);
9261 return scm_i_make_ratio_already_reduced
9262 (numerator
, left_shift_exact_integer (SCM_INUM1
, -expon
));
9264 return left_shift_exact_integer (numerator
, expon
);
9272 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9274 "Returns the @emph{simplest} rational number differing\n"
9275 "from @var{x} by no more than @var{eps}.\n"
9277 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9278 "exact result when both its arguments are exact. Thus, you might need\n"
9279 "to use @code{inexact->exact} on the arguments.\n"
9282 "(rationalize (inexact->exact 1.2) 1/100)\n"
9285 #define FUNC_NAME s_scm_rationalize
9287 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9288 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9289 eps
= scm_abs (eps
);
9290 if (scm_is_false (scm_positive_p (eps
)))
9292 /* eps is either zero or a NaN */
9293 if (scm_is_true (scm_nan_p (eps
)))
9295 else if (SCM_INEXACTP (eps
))
9296 return scm_exact_to_inexact (x
);
9300 else if (scm_is_false (scm_finite_p (eps
)))
9302 if (scm_is_true (scm_finite_p (x
)))
9307 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9309 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9310 scm_ceiling (scm_difference (x
, eps
)))))
9312 /* There's an integer within range; we want the one closest to zero */
9313 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9315 /* zero is within range */
9316 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9321 else if (scm_is_true (scm_positive_p (x
)))
9322 return scm_ceiling (scm_difference (x
, eps
));
9324 return scm_floor (scm_sum (x
, eps
));
9328 /* Use continued fractions to find closest ratio. All
9329 arithmetic is done with exact numbers.
9332 SCM ex
= scm_inexact_to_exact (x
);
9333 SCM int_part
= scm_floor (ex
);
9335 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9336 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9340 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9341 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9343 /* We stop after a million iterations just to be absolutely sure
9344 that we don't go into an infinite loop. The process normally
9345 converges after less than a dozen iterations.
9348 while (++i
< 1000000)
9350 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9351 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9352 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9354 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9355 eps
))) /* abs(x-a/b) <= eps */
9357 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9358 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9359 return scm_exact_to_inexact (res
);
9363 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9365 tt
= scm_floor (rx
); /* tt = floor (rx) */
9371 scm_num_overflow (s_scm_rationalize
);
9376 /* conversion functions */
9379 scm_is_integer (SCM val
)
9381 return scm_is_true (scm_integer_p (val
));
9385 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9387 if (SCM_I_INUMP (val
))
9389 scm_t_signed_bits n
= SCM_I_INUM (val
);
9390 return n
>= min
&& n
<= max
;
9392 else if (SCM_BIGP (val
))
9394 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9396 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9398 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9400 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9401 return n
>= min
&& n
<= max
;
9411 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9412 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9415 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9416 SCM_I_BIG_MPZ (val
));
9418 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9430 return n
>= min
&& n
<= max
;
9438 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9440 if (SCM_I_INUMP (val
))
9442 scm_t_signed_bits n
= SCM_I_INUM (val
);
9443 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9445 else if (SCM_BIGP (val
))
9447 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9449 else if (max
<= ULONG_MAX
)
9451 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9453 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9454 return n
>= min
&& n
<= max
;
9464 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9467 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9468 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9471 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9472 SCM_I_BIG_MPZ (val
));
9474 return n
>= min
&& n
<= max
;
9482 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9484 scm_error (scm_out_of_range_key
,
9486 "Value out of range ~S to ~S: ~S",
9487 scm_list_3 (min
, max
, bad_val
),
9488 scm_list_1 (bad_val
));
9491 #define TYPE scm_t_intmax
9492 #define TYPE_MIN min
9493 #define TYPE_MAX max
9494 #define SIZEOF_TYPE 0
9495 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9496 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9497 #include "libguile/conv-integer.i.c"
9499 #define TYPE scm_t_uintmax
9500 #define TYPE_MIN min
9501 #define TYPE_MAX max
9502 #define SIZEOF_TYPE 0
9503 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9504 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9505 #include "libguile/conv-uinteger.i.c"
9507 #define TYPE scm_t_int8
9508 #define TYPE_MIN SCM_T_INT8_MIN
9509 #define TYPE_MAX SCM_T_INT8_MAX
9510 #define SIZEOF_TYPE 1
9511 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9512 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9513 #include "libguile/conv-integer.i.c"
9515 #define TYPE scm_t_uint8
9517 #define TYPE_MAX SCM_T_UINT8_MAX
9518 #define SIZEOF_TYPE 1
9519 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9520 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9521 #include "libguile/conv-uinteger.i.c"
9523 #define TYPE scm_t_int16
9524 #define TYPE_MIN SCM_T_INT16_MIN
9525 #define TYPE_MAX SCM_T_INT16_MAX
9526 #define SIZEOF_TYPE 2
9527 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9528 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9529 #include "libguile/conv-integer.i.c"
9531 #define TYPE scm_t_uint16
9533 #define TYPE_MAX SCM_T_UINT16_MAX
9534 #define SIZEOF_TYPE 2
9535 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9536 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9537 #include "libguile/conv-uinteger.i.c"
9539 #define TYPE scm_t_int32
9540 #define TYPE_MIN SCM_T_INT32_MIN
9541 #define TYPE_MAX SCM_T_INT32_MAX
9542 #define SIZEOF_TYPE 4
9543 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9544 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9545 #include "libguile/conv-integer.i.c"
9547 #define TYPE scm_t_uint32
9549 #define TYPE_MAX SCM_T_UINT32_MAX
9550 #define SIZEOF_TYPE 4
9551 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9552 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9553 #include "libguile/conv-uinteger.i.c"
9555 #define TYPE scm_t_wchar
9556 #define TYPE_MIN (scm_t_int32)-1
9557 #define TYPE_MAX (scm_t_int32)0x10ffff
9558 #define SIZEOF_TYPE 4
9559 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9560 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9561 #include "libguile/conv-integer.i.c"
9563 #define TYPE scm_t_int64
9564 #define TYPE_MIN SCM_T_INT64_MIN
9565 #define TYPE_MAX SCM_T_INT64_MAX
9566 #define SIZEOF_TYPE 8
9567 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9568 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9569 #include "libguile/conv-integer.i.c"
9571 #define TYPE scm_t_uint64
9573 #define TYPE_MAX SCM_T_UINT64_MAX
9574 #define SIZEOF_TYPE 8
9575 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9576 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9577 #include "libguile/conv-uinteger.i.c"
9580 scm_to_mpz (SCM val
, mpz_t rop
)
9582 if (SCM_I_INUMP (val
))
9583 mpz_set_si (rop
, SCM_I_INUM (val
));
9584 else if (SCM_BIGP (val
))
9585 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9587 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9591 scm_from_mpz (mpz_t val
)
9593 return scm_i_mpz2num (val
);
9597 scm_is_real (SCM val
)
9599 return scm_is_true (scm_real_p (val
));
9603 scm_is_rational (SCM val
)
9605 return scm_is_true (scm_rational_p (val
));
9609 scm_to_double (SCM val
)
9611 if (SCM_I_INUMP (val
))
9612 return SCM_I_INUM (val
);
9613 else if (SCM_BIGP (val
))
9614 return scm_i_big2dbl (val
);
9615 else if (SCM_FRACTIONP (val
))
9616 return scm_i_fraction2double (val
);
9617 else if (SCM_REALP (val
))
9618 return SCM_REAL_VALUE (val
);
9620 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9624 scm_from_double (double val
)
9628 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9630 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9631 SCM_REAL_VALUE (z
) = val
;
9636 #if SCM_ENABLE_DEPRECATED == 1
9639 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9641 scm_c_issue_deprecation_warning
9642 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9646 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9650 scm_out_of_range (NULL
, num
);
9653 return scm_to_double (num
);
9657 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9659 scm_c_issue_deprecation_warning
9660 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9664 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9668 scm_out_of_range (NULL
, num
);
9671 return scm_to_double (num
);
9677 scm_is_complex (SCM val
)
9679 return scm_is_true (scm_complex_p (val
));
9683 scm_c_real_part (SCM z
)
9685 if (SCM_COMPLEXP (z
))
9686 return SCM_COMPLEX_REAL (z
);
9689 /* Use the scm_real_part to get proper error checking and
9692 return scm_to_double (scm_real_part (z
));
9697 scm_c_imag_part (SCM z
)
9699 if (SCM_COMPLEXP (z
))
9700 return SCM_COMPLEX_IMAG (z
);
9703 /* Use the scm_imag_part to get proper error checking and
9704 dispatching. The result will almost always be 0.0, but not
9707 return scm_to_double (scm_imag_part (z
));
9712 scm_c_magnitude (SCM z
)
9714 return scm_to_double (scm_magnitude (z
));
9720 return scm_to_double (scm_angle (z
));
9724 scm_is_number (SCM z
)
9726 return scm_is_true (scm_number_p (z
));
9730 /* Returns log(x * 2^shift) */
9732 log_of_shifted_double (double x
, long shift
)
9734 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9736 if (x
> 0.0 || double_is_non_negative_zero (x
))
9737 return scm_from_double (ans
);
9739 return scm_c_make_rectangular (ans
, M_PI
);
9742 /* Returns log(n), for exact integer n */
9744 log_of_exact_integer (SCM n
)
9746 if (SCM_I_INUMP (n
))
9747 return log_of_shifted_double (SCM_I_INUM (n
), 0);
9748 else if (SCM_BIGP (n
))
9751 double signif
= scm_i_big2dbl_2exp (n
, &expon
);
9752 return log_of_shifted_double (signif
, expon
);
9755 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1
, n
);
9758 /* Returns log(n/d), for exact non-zero integers n and d */
9760 log_of_fraction (SCM n
, SCM d
)
9762 long n_size
= scm_to_long (scm_integer_length (n
));
9763 long d_size
= scm_to_long (scm_integer_length (d
));
9765 if (abs (n_size
- d_size
) > 1)
9766 return (scm_difference (log_of_exact_integer (n
),
9767 log_of_exact_integer (d
)));
9768 else if (scm_is_false (scm_negative_p (n
)))
9769 return scm_from_double
9770 (log1p (scm_i_divide2double (scm_difference (n
, d
), d
)));
9772 return scm_c_make_rectangular
9773 (log1p (scm_i_divide2double (scm_difference (scm_abs (n
), d
),
9779 /* In the following functions we dispatch to the real-arg funcs like log()
9780 when we know the arg is real, instead of just handing everything to
9781 clog() for instance. This is in case clog() doesn't optimize for a
9782 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9783 well use it to go straight to the applicable C func. */
9785 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9787 "Return the natural logarithm of @var{z}.")
9788 #define FUNC_NAME s_scm_log
9790 if (SCM_COMPLEXP (z
))
9792 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9793 && defined (SCM_COMPLEX_VALUE)
9794 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9796 double re
= SCM_COMPLEX_REAL (z
);
9797 double im
= SCM_COMPLEX_IMAG (z
);
9798 return scm_c_make_rectangular (log (hypot (re
, im
)),
9802 else if (SCM_REALP (z
))
9803 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9804 else if (SCM_I_INUMP (z
))
9806 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9807 if (scm_is_eq (z
, SCM_INUM0
))
9808 scm_num_overflow (s_scm_log
);
9810 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9812 else if (SCM_BIGP (z
))
9813 return log_of_exact_integer (z
);
9814 else if (SCM_FRACTIONP (z
))
9815 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9816 SCM_FRACTION_DENOMINATOR (z
));
9818 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9823 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9825 "Return the base 10 logarithm of @var{z}.")
9826 #define FUNC_NAME s_scm_log10
9828 if (SCM_COMPLEXP (z
))
9830 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9831 clog() and a multiply by M_LOG10E, rather than the fallback
9832 log10+hypot+atan2.) */
9833 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9834 && defined SCM_COMPLEX_VALUE
9835 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9837 double re
= SCM_COMPLEX_REAL (z
);
9838 double im
= SCM_COMPLEX_IMAG (z
);
9839 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9840 M_LOG10E
* atan2 (im
, re
));
9843 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9845 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9846 if (scm_is_eq (z
, SCM_INUM0
))
9847 scm_num_overflow (s_scm_log10
);
9850 double re
= scm_to_double (z
);
9851 double l
= log10 (fabs (re
));
9852 if (re
> 0.0 || double_is_non_negative_zero (re
))
9853 return scm_from_double (l
);
9855 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9858 else if (SCM_BIGP (z
))
9859 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9860 else if (SCM_FRACTIONP (z
))
9861 return scm_product (flo_log10e
,
9862 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9863 SCM_FRACTION_DENOMINATOR (z
)));
9865 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9870 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9872 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9873 "base of natural logarithms (2.71828@dots{}).")
9874 #define FUNC_NAME s_scm_exp
9876 if (SCM_COMPLEXP (z
))
9878 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9879 && defined (SCM_COMPLEX_VALUE)
9880 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9882 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9883 SCM_COMPLEX_IMAG (z
));
9886 else if (SCM_NUMBERP (z
))
9888 /* When z is a negative bignum the conversion to double overflows,
9889 giving -infinity, but that's ok, the exp is still 0.0. */
9890 return scm_from_double (exp (scm_to_double (z
)));
9893 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9898 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9900 "Return two exact non-negative integers @var{s} and @var{r}\n"
9901 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9902 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9903 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9906 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9908 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9912 scm_exact_integer_sqrt (k
, &s
, &r
);
9913 return scm_values (scm_list_2 (s
, r
));
9918 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9920 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9922 scm_t_inum kk
= SCM_I_INUM (k
);
9926 if (SCM_LIKELY (kk
> 0))
9931 uu
= (ss
+ kk
/ss
) / 2;
9933 *sp
= SCM_I_MAKINUM (ss
);
9934 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9936 else if (SCM_LIKELY (kk
== 0))
9937 *sp
= *rp
= SCM_INUM0
;
9939 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9940 "exact non-negative integer");
9942 else if (SCM_LIKELY (SCM_BIGP (k
)))
9946 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9947 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9948 "exact non-negative integer");
9951 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9952 scm_remember_upto_here_1 (k
);
9953 *sp
= scm_i_normbig (s
);
9954 *rp
= scm_i_normbig (r
);
9957 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9958 "exact non-negative integer");
9962 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9964 "Return the square root of @var{z}. Of the two possible roots\n"
9965 "(positive and negative), the one with positive real part\n"
9966 "is returned, or if that's zero then a positive imaginary part.\n"
9970 "(sqrt 9.0) @result{} 3.0\n"
9971 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9972 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9973 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9975 #define FUNC_NAME s_scm_sqrt
9977 if (SCM_COMPLEXP (z
))
9979 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9980 && defined SCM_COMPLEX_VALUE
9981 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9983 double re
= SCM_COMPLEX_REAL (z
);
9984 double im
= SCM_COMPLEX_IMAG (z
);
9985 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9986 0.5 * atan2 (im
, re
));
9989 else if (SCM_NUMBERP (z
))
9991 double xx
= scm_to_double (z
);
9993 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9995 return scm_from_double (sqrt (xx
));
9998 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
10005 scm_init_numbers ()
10007 if (scm_install_gmp_memory_functions
)
10008 mp_set_memory_functions (custom_gmp_malloc
,
10009 custom_gmp_realloc
,
10012 mpz_init_set_si (z_negative_one
, -1);
10014 /* It may be possible to tune the performance of some algorithms by using
10015 * the following constants to avoid the creation of bignums. Please, before
10016 * using these values, remember the two rules of program optimization:
10017 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10018 scm_c_define ("most-positive-fixnum",
10019 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
10020 scm_c_define ("most-negative-fixnum",
10021 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
10023 scm_add_feature ("complex");
10024 scm_add_feature ("inexact");
10025 flo0
= scm_from_double (0.0);
10026 flo_log10e
= scm_from_double (M_LOG10E
);
10028 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
10031 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10032 mpz_init_set_ui (scm_i_divide2double_lo2b
, 1);
10033 mpz_mul_2exp (scm_i_divide2double_lo2b
,
10034 scm_i_divide2double_lo2b
,
10035 DBL_MANT_DIG
+ 1); /* 2 b^p */
10036 mpz_sub_ui (scm_i_divide2double_lo2b
, scm_i_divide2double_lo2b
, 1);
10040 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10041 mpz_init_set_ui (dbl_minimum_normal_mantissa
, 1);
10042 mpz_mul_2exp (dbl_minimum_normal_mantissa
,
10043 dbl_minimum_normal_mantissa
,
10047 #include "libguile/numbers.x"
10052 c-file-style: "gnu"