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 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
334 with R5RS exact->inexact.
336 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
337 (ie. truncate towards zero), then adjust to get the closest double by
338 examining the next lower bit and adding 1 (to the absolute value) if
341 Bignums exactly half way between representable doubles are rounded to the
342 next higher absolute value (ie. away from zero). This seems like an
343 adequate interpretation of R5RS "numerically closest", and it's easier
344 and faster than a full "nearest-even" style.
346 The bit test must be done on the absolute value of the mpz_t, which means
347 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
348 negatives as twos complement.
350 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
351 following the hardware rounding mode, but applied to the absolute
352 value of the mpz_t operand. This is not what we want so we put the
353 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
354 (released in March 2006) mpz_get_d now always truncates towards zero.
356 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
357 before 4.2 is a slowdown. It'd be faster to pick out the relevant
358 high bits with mpz_getlimbn. */
361 scm_i_big2dbl (SCM b
)
366 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
370 /* For GMP earlier than 4.2, force truncation towards zero */
372 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
373 _not_ the number of bits, so this code will break badly on a
374 system with non-binary doubles. */
377 if (bits
> DBL_MANT_DIG
)
379 size_t shift
= bits
- DBL_MANT_DIG
;
380 mpz_init2 (tmp
, DBL_MANT_DIG
);
381 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
382 result
= ldexp (mpz_get_d (tmp
), shift
);
387 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
391 /* GMP 4.2 or later */
392 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
395 if (bits
> DBL_MANT_DIG
)
397 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
398 /* test bit number "pos" in absolute value */
399 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
400 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
402 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
406 scm_remember_upto_here_1 (b
);
411 scm_i_normbig (SCM b
)
413 /* convert a big back to a fixnum if it'll fit */
414 /* presume b is a bignum */
415 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
417 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
418 if (SCM_FIXABLE (val
))
419 b
= SCM_I_MAKINUM (val
);
424 static SCM_C_INLINE_KEYWORD SCM
425 scm_i_mpz2num (mpz_t b
)
427 /* convert a mpz number to a SCM number. */
428 if (mpz_fits_slong_p (b
))
430 scm_t_inum val
= mpz_get_si (b
);
431 if (SCM_FIXABLE (val
))
432 return SCM_I_MAKINUM (val
);
436 SCM z
= make_bignum ();
437 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
442 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
443 static SCM
scm_divide2real (SCM x
, SCM y
);
445 /* Make the ratio NUMERATOR/DENOMINATOR, where:
446 1. NUMERATOR and DENOMINATOR are exact integers
447 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
449 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
451 /* Flip signs so that the denominator is positive. */
452 if (scm_is_false (scm_positive_p (denominator
)))
454 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
455 scm_num_overflow ("make-ratio");
458 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
459 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
463 /* Check for the integer case */
464 if (scm_is_eq (denominator
, SCM_INUM1
))
467 return scm_double_cell (scm_tc16_fraction
,
468 SCM_UNPACK (numerator
),
469 SCM_UNPACK (denominator
), 0);
472 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
474 /* Make the ratio NUMERATOR/DENOMINATOR */
476 scm_i_make_ratio (SCM numerator
, SCM denominator
)
477 #define FUNC_NAME "make-ratio"
479 /* Make sure the arguments are proper */
480 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
481 SCM_WRONG_TYPE_ARG (1, numerator
);
482 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
483 SCM_WRONG_TYPE_ARG (2, denominator
);
486 SCM the_gcd
= scm_gcd (numerator
, denominator
);
487 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
489 /* Reduce to lowest terms */
490 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
491 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
493 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
499 scm_i_fraction2double (SCM z
)
501 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
502 SCM_FRACTION_DENOMINATOR (z
)));
506 double_is_non_negative_zero (double x
)
508 static double zero
= 0.0;
510 return !memcmp (&x
, &zero
, sizeof(double));
513 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
515 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
517 #define FUNC_NAME s_scm_exact_p
519 if (SCM_INEXACTP (x
))
521 else if (SCM_NUMBERP (x
))
524 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
529 scm_is_exact (SCM val
)
531 return scm_is_true (scm_exact_p (val
));
534 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
536 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
538 #define FUNC_NAME s_scm_inexact_p
540 if (SCM_INEXACTP (x
))
542 else if (SCM_NUMBERP (x
))
545 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
550 scm_is_inexact (SCM val
)
552 return scm_is_true (scm_inexact_p (val
));
555 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
557 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
559 #define FUNC_NAME s_scm_odd_p
563 scm_t_inum val
= SCM_I_INUM (n
);
564 return scm_from_bool ((val
& 1L) != 0);
566 else if (SCM_BIGP (n
))
568 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
569 scm_remember_upto_here_1 (n
);
570 return scm_from_bool (odd_p
);
572 else if (SCM_REALP (n
))
574 double val
= SCM_REAL_VALUE (n
);
575 if (DOUBLE_IS_FINITE (val
))
577 double rem
= fabs (fmod (val
, 2.0));
584 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
589 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
591 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
593 #define FUNC_NAME s_scm_even_p
597 scm_t_inum val
= SCM_I_INUM (n
);
598 return scm_from_bool ((val
& 1L) == 0);
600 else if (SCM_BIGP (n
))
602 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
603 scm_remember_upto_here_1 (n
);
604 return scm_from_bool (even_p
);
606 else if (SCM_REALP (n
))
608 double val
= SCM_REAL_VALUE (n
);
609 if (DOUBLE_IS_FINITE (val
))
611 double rem
= fabs (fmod (val
, 2.0));
618 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
622 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
624 "Return @code{#t} if the real number @var{x} is neither\n"
625 "infinite nor a NaN, @code{#f} otherwise.")
626 #define FUNC_NAME s_scm_finite_p
629 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
630 else if (scm_is_real (x
))
633 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
637 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
639 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
640 "@samp{-inf.0}. Otherwise return @code{#f}.")
641 #define FUNC_NAME s_scm_inf_p
644 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
645 else if (scm_is_real (x
))
648 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
652 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
654 "Return @code{#t} if the real number @var{x} is a NaN,\n"
655 "or @code{#f} otherwise.")
656 #define FUNC_NAME s_scm_nan_p
659 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
660 else if (scm_is_real (x
))
663 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
667 /* Guile's idea of infinity. */
668 static double guile_Inf
;
670 /* Guile's idea of not a number. */
671 static double guile_NaN
;
674 guile_ieee_init (void)
676 /* Some version of gcc on some old version of Linux used to crash when
677 trying to make Inf and NaN. */
680 /* C99 INFINITY, when available.
681 FIXME: The standard allows for INFINITY to be something that overflows
682 at compile time. We ought to have a configure test to check for that
683 before trying to use it. (But in practice we believe this is not a
684 problem on any system guile is likely to target.) */
685 guile_Inf
= INFINITY
;
686 #elif defined HAVE_DINFINITY
688 extern unsigned int DINFINITY
[2];
689 guile_Inf
= (*((double *) (DINFINITY
)));
696 if (guile_Inf
== tmp
)
703 /* C99 NAN, when available */
705 #elif defined HAVE_DQNAN
708 extern unsigned int DQNAN
[2];
709 guile_NaN
= (*((double *)(DQNAN
)));
712 guile_NaN
= guile_Inf
/ guile_Inf
;
716 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
719 #define FUNC_NAME s_scm_inf
721 static int initialized
= 0;
727 return scm_from_double (guile_Inf
);
731 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
734 #define FUNC_NAME s_scm_nan
736 static int initialized
= 0;
742 return scm_from_double (guile_NaN
);
747 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
749 "Return the absolute value of @var{x}.")
750 #define FUNC_NAME s_scm_abs
754 scm_t_inum xx
= SCM_I_INUM (x
);
757 else if (SCM_POSFIXABLE (-xx
))
758 return SCM_I_MAKINUM (-xx
);
760 return scm_i_inum2big (-xx
);
762 else if (SCM_LIKELY (SCM_REALP (x
)))
764 double xx
= SCM_REAL_VALUE (x
);
765 /* If x is a NaN then xx<0 is false so we return x unchanged */
767 return scm_from_double (-xx
);
768 /* Handle signed zeroes properly */
769 else if (SCM_UNLIKELY (xx
== 0.0))
774 else if (SCM_BIGP (x
))
776 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
778 return scm_i_clonebig (x
, 0);
782 else if (SCM_FRACTIONP (x
))
784 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
786 return scm_i_make_ratio_already_reduced
787 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
788 SCM_FRACTION_DENOMINATOR (x
));
791 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
796 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
798 "Return the quotient of the numbers @var{x} and @var{y}.")
799 #define FUNC_NAME s_scm_quotient
801 if (SCM_LIKELY (scm_is_integer (x
)))
803 if (SCM_LIKELY (scm_is_integer (y
)))
804 return scm_truncate_quotient (x
, y
);
806 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
809 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
813 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
815 "Return the remainder of the numbers @var{x} and @var{y}.\n"
817 "(remainder 13 4) @result{} 1\n"
818 "(remainder -13 4) @result{} -1\n"
820 #define FUNC_NAME s_scm_remainder
822 if (SCM_LIKELY (scm_is_integer (x
)))
824 if (SCM_LIKELY (scm_is_integer (y
)))
825 return scm_truncate_remainder (x
, y
);
827 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
830 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
835 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
837 "Return the modulo of the numbers @var{x} and @var{y}.\n"
839 "(modulo 13 4) @result{} 1\n"
840 "(modulo -13 4) @result{} 3\n"
842 #define FUNC_NAME s_scm_modulo
844 if (SCM_LIKELY (scm_is_integer (x
)))
846 if (SCM_LIKELY (scm_is_integer (y
)))
847 return scm_floor_remainder (x
, y
);
849 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
852 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
856 /* Return the exact integer q such that n = q*d, for exact integers n
857 and d, where d is known in advance to divide n evenly (with zero
858 remainder). For large integers, this can be computed more
859 efficiently than when the remainder is unknown. */
861 scm_exact_integer_quotient (SCM n
, SCM d
)
862 #define FUNC_NAME "exact-integer-quotient"
864 if (SCM_LIKELY (SCM_I_INUMP (n
)))
866 scm_t_inum nn
= SCM_I_INUM (n
);
867 if (SCM_LIKELY (SCM_I_INUMP (d
)))
869 scm_t_inum dd
= SCM_I_INUM (d
);
870 if (SCM_UNLIKELY (dd
== 0))
871 scm_num_overflow ("exact-integer-quotient");
874 scm_t_inum qq
= nn
/ dd
;
875 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
876 return SCM_I_MAKINUM (qq
);
878 return scm_i_inum2big (qq
);
881 else if (SCM_LIKELY (SCM_BIGP (d
)))
883 /* n is an inum and d is a bignum. Given that d is known to
884 divide n evenly, there are only two possibilities: n is 0,
885 or else n is fixnum-min and d is abs(fixnum-min). */
889 return SCM_I_MAKINUM (-1);
892 SCM_WRONG_TYPE_ARG (2, d
);
894 else if (SCM_LIKELY (SCM_BIGP (n
)))
896 if (SCM_LIKELY (SCM_I_INUMP (d
)))
898 scm_t_inum dd
= SCM_I_INUM (d
);
899 if (SCM_UNLIKELY (dd
== 0))
900 scm_num_overflow ("exact-integer-quotient");
901 else if (SCM_UNLIKELY (dd
== 1))
905 SCM q
= scm_i_mkbig ();
907 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
910 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
911 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
913 scm_remember_upto_here_1 (n
);
914 return scm_i_normbig (q
);
917 else if (SCM_LIKELY (SCM_BIGP (d
)))
919 SCM q
= scm_i_mkbig ();
920 mpz_divexact (SCM_I_BIG_MPZ (q
),
923 scm_remember_upto_here_2 (n
, d
);
924 return scm_i_normbig (q
);
927 SCM_WRONG_TYPE_ARG (2, d
);
930 SCM_WRONG_TYPE_ARG (1, n
);
934 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
935 two-valued functions. It is called from primitive generics that take
936 two arguments and return two values, when the core procedure is
937 unable to handle the given argument types. If there are GOOPS
938 methods for this primitive generic, it dispatches to GOOPS and, if
939 successful, expects two values to be returned, which are placed in
940 *rp1 and *rp2. If there are no GOOPS methods, it throws a
941 wrong-type-arg exception.
943 FIXME: This obviously belongs somewhere else, but until we decide on
944 the right API, it is here as a static function, because it is needed
945 by the *_divide functions below.
948 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
949 const char *subr
, SCM
*rp1
, SCM
*rp2
)
952 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
954 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
957 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
959 "Return the integer @var{q} such that\n"
960 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
961 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
963 "(euclidean-quotient 123 10) @result{} 12\n"
964 "(euclidean-quotient 123 -10) @result{} -12\n"
965 "(euclidean-quotient -123 10) @result{} -13\n"
966 "(euclidean-quotient -123 -10) @result{} 13\n"
967 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
968 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
970 #define FUNC_NAME s_scm_euclidean_quotient
972 if (scm_is_false (scm_negative_p (y
)))
973 return scm_floor_quotient (x
, y
);
975 return scm_ceiling_quotient (x
, y
);
979 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
981 "Return the real number @var{r} such that\n"
982 "@math{0 <= @var{r} < abs(@var{y})} and\n"
983 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
984 "for some integer @var{q}.\n"
986 "(euclidean-remainder 123 10) @result{} 3\n"
987 "(euclidean-remainder 123 -10) @result{} 3\n"
988 "(euclidean-remainder -123 10) @result{} 7\n"
989 "(euclidean-remainder -123 -10) @result{} 7\n"
990 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
991 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
993 #define FUNC_NAME s_scm_euclidean_remainder
995 if (scm_is_false (scm_negative_p (y
)))
996 return scm_floor_remainder (x
, y
);
998 return scm_ceiling_remainder (x
, y
);
1002 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
1004 "Return the integer @var{q} and the real number @var{r}\n"
1005 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1006 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1008 "(euclidean/ 123 10) @result{} 12 and 3\n"
1009 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1010 "(euclidean/ -123 10) @result{} -13 and 7\n"
1011 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1012 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1013 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1015 #define FUNC_NAME s_scm_i_euclidean_divide
1017 if (scm_is_false (scm_negative_p (y
)))
1018 return scm_i_floor_divide (x
, y
);
1020 return scm_i_ceiling_divide (x
, y
);
1025 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1027 if (scm_is_false (scm_negative_p (y
)))
1028 return scm_floor_divide (x
, y
, qp
, rp
);
1030 return scm_ceiling_divide (x
, y
, qp
, rp
);
1033 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1034 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1036 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1038 "Return the floor of @math{@var{x} / @var{y}}.\n"
1040 "(floor-quotient 123 10) @result{} 12\n"
1041 "(floor-quotient 123 -10) @result{} -13\n"
1042 "(floor-quotient -123 10) @result{} -13\n"
1043 "(floor-quotient -123 -10) @result{} 12\n"
1044 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1045 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1047 #define FUNC_NAME s_scm_floor_quotient
1049 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1051 scm_t_inum xx
= SCM_I_INUM (x
);
1052 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1054 scm_t_inum yy
= SCM_I_INUM (y
);
1055 scm_t_inum xx1
= xx
;
1057 if (SCM_LIKELY (yy
> 0))
1059 if (SCM_UNLIKELY (xx
< 0))
1062 else if (SCM_UNLIKELY (yy
== 0))
1063 scm_num_overflow (s_scm_floor_quotient
);
1067 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1068 return SCM_I_MAKINUM (qq
);
1070 return scm_i_inum2big (qq
);
1072 else if (SCM_BIGP (y
))
1074 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1075 scm_remember_upto_here_1 (y
);
1077 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1079 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1081 else if (SCM_REALP (y
))
1082 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1083 else if (SCM_FRACTIONP (y
))
1084 return scm_i_exact_rational_floor_quotient (x
, y
);
1086 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1087 s_scm_floor_quotient
);
1089 else if (SCM_BIGP (x
))
1091 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1093 scm_t_inum yy
= SCM_I_INUM (y
);
1094 if (SCM_UNLIKELY (yy
== 0))
1095 scm_num_overflow (s_scm_floor_quotient
);
1096 else if (SCM_UNLIKELY (yy
== 1))
1100 SCM q
= scm_i_mkbig ();
1102 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1105 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1106 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1108 scm_remember_upto_here_1 (x
);
1109 return scm_i_normbig (q
);
1112 else if (SCM_BIGP (y
))
1114 SCM q
= scm_i_mkbig ();
1115 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1118 scm_remember_upto_here_2 (x
, y
);
1119 return scm_i_normbig (q
);
1121 else if (SCM_REALP (y
))
1122 return scm_i_inexact_floor_quotient
1123 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1124 else if (SCM_FRACTIONP (y
))
1125 return scm_i_exact_rational_floor_quotient (x
, y
);
1127 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1128 s_scm_floor_quotient
);
1130 else if (SCM_REALP (x
))
1132 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1133 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1134 return scm_i_inexact_floor_quotient
1135 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1137 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1138 s_scm_floor_quotient
);
1140 else if (SCM_FRACTIONP (x
))
1143 return scm_i_inexact_floor_quotient
1144 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1145 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1146 return scm_i_exact_rational_floor_quotient (x
, y
);
1148 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1149 s_scm_floor_quotient
);
1152 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1153 s_scm_floor_quotient
);
1158 scm_i_inexact_floor_quotient (double x
, double y
)
1160 if (SCM_UNLIKELY (y
== 0))
1161 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1163 return scm_from_double (floor (x
/ y
));
1167 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1169 return scm_floor_quotient
1170 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1171 scm_product (scm_numerator (y
), scm_denominator (x
)));
1174 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1175 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1177 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1179 "Return the real number @var{r} such that\n"
1180 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1181 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1183 "(floor-remainder 123 10) @result{} 3\n"
1184 "(floor-remainder 123 -10) @result{} -7\n"
1185 "(floor-remainder -123 10) @result{} 7\n"
1186 "(floor-remainder -123 -10) @result{} -3\n"
1187 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1188 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1190 #define FUNC_NAME s_scm_floor_remainder
1192 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1194 scm_t_inum xx
= SCM_I_INUM (x
);
1195 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1197 scm_t_inum yy
= SCM_I_INUM (y
);
1198 if (SCM_UNLIKELY (yy
== 0))
1199 scm_num_overflow (s_scm_floor_remainder
);
1202 scm_t_inum rr
= xx
% yy
;
1203 int needs_adjustment
;
1205 if (SCM_LIKELY (yy
> 0))
1206 needs_adjustment
= (rr
< 0);
1208 needs_adjustment
= (rr
> 0);
1210 if (needs_adjustment
)
1212 return SCM_I_MAKINUM (rr
);
1215 else if (SCM_BIGP (y
))
1217 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1218 scm_remember_upto_here_1 (y
);
1223 SCM r
= scm_i_mkbig ();
1224 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1225 scm_remember_upto_here_1 (y
);
1226 return scm_i_normbig (r
);
1235 SCM r
= scm_i_mkbig ();
1236 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1237 scm_remember_upto_here_1 (y
);
1238 return scm_i_normbig (r
);
1241 else if (SCM_REALP (y
))
1242 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1243 else if (SCM_FRACTIONP (y
))
1244 return scm_i_exact_rational_floor_remainder (x
, y
);
1246 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1247 s_scm_floor_remainder
);
1249 else if (SCM_BIGP (x
))
1251 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1253 scm_t_inum yy
= SCM_I_INUM (y
);
1254 if (SCM_UNLIKELY (yy
== 0))
1255 scm_num_overflow (s_scm_floor_remainder
);
1260 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1262 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1263 scm_remember_upto_here_1 (x
);
1264 return SCM_I_MAKINUM (rr
);
1267 else if (SCM_BIGP (y
))
1269 SCM r
= scm_i_mkbig ();
1270 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1273 scm_remember_upto_here_2 (x
, y
);
1274 return scm_i_normbig (r
);
1276 else if (SCM_REALP (y
))
1277 return scm_i_inexact_floor_remainder
1278 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1279 else if (SCM_FRACTIONP (y
))
1280 return scm_i_exact_rational_floor_remainder (x
, y
);
1282 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1283 s_scm_floor_remainder
);
1285 else if (SCM_REALP (x
))
1287 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1288 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1289 return scm_i_inexact_floor_remainder
1290 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1292 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1293 s_scm_floor_remainder
);
1295 else if (SCM_FRACTIONP (x
))
1298 return scm_i_inexact_floor_remainder
1299 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1300 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1301 return scm_i_exact_rational_floor_remainder (x
, y
);
1303 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1304 s_scm_floor_remainder
);
1307 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1308 s_scm_floor_remainder
);
1313 scm_i_inexact_floor_remainder (double x
, double y
)
1315 /* Although it would be more efficient to use fmod here, we can't
1316 because it would in some cases produce results inconsistent with
1317 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1318 close). In particular, when x is very close to a multiple of y,
1319 then r might be either 0.0 or y, but those two cases must
1320 correspond to different choices of q. If r = 0.0 then q must be
1321 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1322 and remainder chooses the other, it would be bad. */
1323 if (SCM_UNLIKELY (y
== 0))
1324 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1326 return scm_from_double (x
- y
* floor (x
/ y
));
1330 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1332 SCM xd
= scm_denominator (x
);
1333 SCM yd
= scm_denominator (y
);
1334 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1335 scm_product (scm_numerator (y
), xd
));
1336 return scm_divide (r1
, scm_product (xd
, yd
));
1340 static void scm_i_inexact_floor_divide (double x
, double y
,
1342 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1345 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1347 "Return the integer @var{q} and the real number @var{r}\n"
1348 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1349 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1351 "(floor/ 123 10) @result{} 12 and 3\n"
1352 "(floor/ 123 -10) @result{} -13 and -7\n"
1353 "(floor/ -123 10) @result{} -13 and 7\n"
1354 "(floor/ -123 -10) @result{} 12 and -3\n"
1355 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1356 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1358 #define FUNC_NAME s_scm_i_floor_divide
1362 scm_floor_divide(x
, y
, &q
, &r
);
1363 return scm_values (scm_list_2 (q
, r
));
1367 #define s_scm_floor_divide s_scm_i_floor_divide
1368 #define g_scm_floor_divide g_scm_i_floor_divide
1371 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1373 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1375 scm_t_inum xx
= SCM_I_INUM (x
);
1376 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1378 scm_t_inum yy
= SCM_I_INUM (y
);
1379 if (SCM_UNLIKELY (yy
== 0))
1380 scm_num_overflow (s_scm_floor_divide
);
1383 scm_t_inum qq
= xx
/ yy
;
1384 scm_t_inum rr
= xx
% yy
;
1385 int needs_adjustment
;
1387 if (SCM_LIKELY (yy
> 0))
1388 needs_adjustment
= (rr
< 0);
1390 needs_adjustment
= (rr
> 0);
1392 if (needs_adjustment
)
1398 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1399 *qp
= SCM_I_MAKINUM (qq
);
1401 *qp
= scm_i_inum2big (qq
);
1402 *rp
= SCM_I_MAKINUM (rr
);
1406 else if (SCM_BIGP (y
))
1408 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1409 scm_remember_upto_here_1 (y
);
1414 SCM r
= scm_i_mkbig ();
1415 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1416 scm_remember_upto_here_1 (y
);
1417 *qp
= SCM_I_MAKINUM (-1);
1418 *rp
= scm_i_normbig (r
);
1433 SCM r
= scm_i_mkbig ();
1434 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1435 scm_remember_upto_here_1 (y
);
1436 *qp
= SCM_I_MAKINUM (-1);
1437 *rp
= scm_i_normbig (r
);
1441 else if (SCM_REALP (y
))
1442 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1443 else if (SCM_FRACTIONP (y
))
1444 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1446 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1447 s_scm_floor_divide
, qp
, rp
);
1449 else if (SCM_BIGP (x
))
1451 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1453 scm_t_inum yy
= SCM_I_INUM (y
);
1454 if (SCM_UNLIKELY (yy
== 0))
1455 scm_num_overflow (s_scm_floor_divide
);
1458 SCM q
= scm_i_mkbig ();
1459 SCM r
= scm_i_mkbig ();
1461 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1462 SCM_I_BIG_MPZ (x
), yy
);
1465 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1466 SCM_I_BIG_MPZ (x
), -yy
);
1467 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1469 scm_remember_upto_here_1 (x
);
1470 *qp
= scm_i_normbig (q
);
1471 *rp
= scm_i_normbig (r
);
1475 else if (SCM_BIGP (y
))
1477 SCM q
= scm_i_mkbig ();
1478 SCM r
= scm_i_mkbig ();
1479 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1480 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1481 scm_remember_upto_here_2 (x
, y
);
1482 *qp
= scm_i_normbig (q
);
1483 *rp
= scm_i_normbig (r
);
1486 else if (SCM_REALP (y
))
1487 return scm_i_inexact_floor_divide
1488 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1489 else if (SCM_FRACTIONP (y
))
1490 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1492 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1493 s_scm_floor_divide
, qp
, rp
);
1495 else if (SCM_REALP (x
))
1497 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1498 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1499 return scm_i_inexact_floor_divide
1500 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1502 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1503 s_scm_floor_divide
, qp
, rp
);
1505 else if (SCM_FRACTIONP (x
))
1508 return scm_i_inexact_floor_divide
1509 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1510 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1511 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1513 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1514 s_scm_floor_divide
, qp
, rp
);
1517 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1518 s_scm_floor_divide
, qp
, rp
);
1522 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1524 if (SCM_UNLIKELY (y
== 0))
1525 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1528 double q
= floor (x
/ y
);
1529 double r
= x
- q
* y
;
1530 *qp
= scm_from_double (q
);
1531 *rp
= scm_from_double (r
);
1536 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1539 SCM xd
= scm_denominator (x
);
1540 SCM yd
= scm_denominator (y
);
1542 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1543 scm_product (scm_numerator (y
), xd
),
1545 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1548 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1549 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1551 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1553 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1555 "(ceiling-quotient 123 10) @result{} 13\n"
1556 "(ceiling-quotient 123 -10) @result{} -12\n"
1557 "(ceiling-quotient -123 10) @result{} -12\n"
1558 "(ceiling-quotient -123 -10) @result{} 13\n"
1559 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1560 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1562 #define FUNC_NAME s_scm_ceiling_quotient
1564 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1566 scm_t_inum xx
= SCM_I_INUM (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_ceiling_quotient
);
1574 scm_t_inum xx1
= xx
;
1576 if (SCM_LIKELY (yy
> 0))
1578 if (SCM_LIKELY (xx
>= 0))
1584 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1585 return SCM_I_MAKINUM (qq
);
1587 return scm_i_inum2big (qq
);
1590 else if (SCM_BIGP (y
))
1592 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1593 scm_remember_upto_here_1 (y
);
1594 if (SCM_LIKELY (sign
> 0))
1596 if (SCM_LIKELY (xx
> 0))
1598 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1599 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1600 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1602 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1603 scm_remember_upto_here_1 (y
);
1604 return SCM_I_MAKINUM (-1);
1614 else if (SCM_REALP (y
))
1615 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1616 else if (SCM_FRACTIONP (y
))
1617 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1619 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1620 s_scm_ceiling_quotient
);
1622 else if (SCM_BIGP (x
))
1624 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1626 scm_t_inum yy
= SCM_I_INUM (y
);
1627 if (SCM_UNLIKELY (yy
== 0))
1628 scm_num_overflow (s_scm_ceiling_quotient
);
1629 else if (SCM_UNLIKELY (yy
== 1))
1633 SCM q
= scm_i_mkbig ();
1635 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1638 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1639 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1641 scm_remember_upto_here_1 (x
);
1642 return scm_i_normbig (q
);
1645 else if (SCM_BIGP (y
))
1647 SCM q
= scm_i_mkbig ();
1648 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1651 scm_remember_upto_here_2 (x
, y
);
1652 return scm_i_normbig (q
);
1654 else if (SCM_REALP (y
))
1655 return scm_i_inexact_ceiling_quotient
1656 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1657 else if (SCM_FRACTIONP (y
))
1658 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1660 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1661 s_scm_ceiling_quotient
);
1663 else if (SCM_REALP (x
))
1665 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1666 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1667 return scm_i_inexact_ceiling_quotient
1668 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1670 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1671 s_scm_ceiling_quotient
);
1673 else if (SCM_FRACTIONP (x
))
1676 return scm_i_inexact_ceiling_quotient
1677 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1678 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1679 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1681 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1682 s_scm_ceiling_quotient
);
1685 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1686 s_scm_ceiling_quotient
);
1691 scm_i_inexact_ceiling_quotient (double x
, double y
)
1693 if (SCM_UNLIKELY (y
== 0))
1694 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1696 return scm_from_double (ceil (x
/ y
));
1700 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1702 return scm_ceiling_quotient
1703 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1704 scm_product (scm_numerator (y
), scm_denominator (x
)));
1707 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1708 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1710 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1712 "Return the real number @var{r} such that\n"
1713 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1714 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1716 "(ceiling-remainder 123 10) @result{} -7\n"
1717 "(ceiling-remainder 123 -10) @result{} 3\n"
1718 "(ceiling-remainder -123 10) @result{} -3\n"
1719 "(ceiling-remainder -123 -10) @result{} 7\n"
1720 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1721 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1723 #define FUNC_NAME s_scm_ceiling_remainder
1725 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1727 scm_t_inum xx
= SCM_I_INUM (x
);
1728 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1730 scm_t_inum yy
= SCM_I_INUM (y
);
1731 if (SCM_UNLIKELY (yy
== 0))
1732 scm_num_overflow (s_scm_ceiling_remainder
);
1735 scm_t_inum rr
= xx
% yy
;
1736 int needs_adjustment
;
1738 if (SCM_LIKELY (yy
> 0))
1739 needs_adjustment
= (rr
> 0);
1741 needs_adjustment
= (rr
< 0);
1743 if (needs_adjustment
)
1745 return SCM_I_MAKINUM (rr
);
1748 else if (SCM_BIGP (y
))
1750 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1751 scm_remember_upto_here_1 (y
);
1752 if (SCM_LIKELY (sign
> 0))
1754 if (SCM_LIKELY (xx
> 0))
1756 SCM r
= scm_i_mkbig ();
1757 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1758 scm_remember_upto_here_1 (y
);
1759 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1760 return scm_i_normbig (r
);
1762 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1763 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1764 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1766 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1767 scm_remember_upto_here_1 (y
);
1777 SCM r
= scm_i_mkbig ();
1778 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1779 scm_remember_upto_here_1 (y
);
1780 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1781 return scm_i_normbig (r
);
1784 else if (SCM_REALP (y
))
1785 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1786 else if (SCM_FRACTIONP (y
))
1787 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1789 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1790 s_scm_ceiling_remainder
);
1792 else if (SCM_BIGP (x
))
1794 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1796 scm_t_inum yy
= SCM_I_INUM (y
);
1797 if (SCM_UNLIKELY (yy
== 0))
1798 scm_num_overflow (s_scm_ceiling_remainder
);
1803 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1805 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1806 scm_remember_upto_here_1 (x
);
1807 return SCM_I_MAKINUM (rr
);
1810 else if (SCM_BIGP (y
))
1812 SCM r
= scm_i_mkbig ();
1813 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1816 scm_remember_upto_here_2 (x
, y
);
1817 return scm_i_normbig (r
);
1819 else if (SCM_REALP (y
))
1820 return scm_i_inexact_ceiling_remainder
1821 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1822 else if (SCM_FRACTIONP (y
))
1823 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1825 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1826 s_scm_ceiling_remainder
);
1828 else if (SCM_REALP (x
))
1830 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1831 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1832 return scm_i_inexact_ceiling_remainder
1833 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1835 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1836 s_scm_ceiling_remainder
);
1838 else if (SCM_FRACTIONP (x
))
1841 return scm_i_inexact_ceiling_remainder
1842 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1843 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1844 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1846 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1847 s_scm_ceiling_remainder
);
1850 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1851 s_scm_ceiling_remainder
);
1856 scm_i_inexact_ceiling_remainder (double x
, double y
)
1858 /* Although it would be more efficient to use fmod here, we can't
1859 because it would in some cases produce results inconsistent with
1860 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1861 close). In particular, when x is very close to a multiple of y,
1862 then r might be either 0.0 or -y, but those two cases must
1863 correspond to different choices of q. If r = 0.0 then q must be
1864 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1865 and remainder chooses the other, it would be bad. */
1866 if (SCM_UNLIKELY (y
== 0))
1867 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1869 return scm_from_double (x
- y
* ceil (x
/ y
));
1873 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1875 SCM xd
= scm_denominator (x
);
1876 SCM yd
= scm_denominator (y
);
1877 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1878 scm_product (scm_numerator (y
), xd
));
1879 return scm_divide (r1
, scm_product (xd
, yd
));
1882 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1884 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1887 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1889 "Return the integer @var{q} and the real number @var{r}\n"
1890 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1891 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1893 "(ceiling/ 123 10) @result{} 13 and -7\n"
1894 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1895 "(ceiling/ -123 10) @result{} -12 and -3\n"
1896 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1897 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1898 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1900 #define FUNC_NAME s_scm_i_ceiling_divide
1904 scm_ceiling_divide(x
, y
, &q
, &r
);
1905 return scm_values (scm_list_2 (q
, r
));
1909 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1910 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1913 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1915 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1917 scm_t_inum xx
= SCM_I_INUM (x
);
1918 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1920 scm_t_inum yy
= SCM_I_INUM (y
);
1921 if (SCM_UNLIKELY (yy
== 0))
1922 scm_num_overflow (s_scm_ceiling_divide
);
1925 scm_t_inum qq
= xx
/ yy
;
1926 scm_t_inum rr
= xx
% yy
;
1927 int needs_adjustment
;
1929 if (SCM_LIKELY (yy
> 0))
1930 needs_adjustment
= (rr
> 0);
1932 needs_adjustment
= (rr
< 0);
1934 if (needs_adjustment
)
1939 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1940 *qp
= SCM_I_MAKINUM (qq
);
1942 *qp
= scm_i_inum2big (qq
);
1943 *rp
= SCM_I_MAKINUM (rr
);
1947 else if (SCM_BIGP (y
))
1949 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1950 scm_remember_upto_here_1 (y
);
1951 if (SCM_LIKELY (sign
> 0))
1953 if (SCM_LIKELY (xx
> 0))
1955 SCM r
= scm_i_mkbig ();
1956 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1957 scm_remember_upto_here_1 (y
);
1958 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1960 *rp
= scm_i_normbig (r
);
1962 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1963 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1964 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1966 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1967 scm_remember_upto_here_1 (y
);
1968 *qp
= SCM_I_MAKINUM (-1);
1984 SCM r
= scm_i_mkbig ();
1985 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1986 scm_remember_upto_here_1 (y
);
1987 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1989 *rp
= scm_i_normbig (r
);
1993 else if (SCM_REALP (y
))
1994 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1995 else if (SCM_FRACTIONP (y
))
1996 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1998 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1999 s_scm_ceiling_divide
, qp
, rp
);
2001 else if (SCM_BIGP (x
))
2003 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2005 scm_t_inum yy
= SCM_I_INUM (y
);
2006 if (SCM_UNLIKELY (yy
== 0))
2007 scm_num_overflow (s_scm_ceiling_divide
);
2010 SCM q
= scm_i_mkbig ();
2011 SCM r
= scm_i_mkbig ();
2013 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2014 SCM_I_BIG_MPZ (x
), yy
);
2017 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2018 SCM_I_BIG_MPZ (x
), -yy
);
2019 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2021 scm_remember_upto_here_1 (x
);
2022 *qp
= scm_i_normbig (q
);
2023 *rp
= scm_i_normbig (r
);
2027 else if (SCM_BIGP (y
))
2029 SCM q
= scm_i_mkbig ();
2030 SCM r
= scm_i_mkbig ();
2031 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2032 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2033 scm_remember_upto_here_2 (x
, y
);
2034 *qp
= scm_i_normbig (q
);
2035 *rp
= scm_i_normbig (r
);
2038 else if (SCM_REALP (y
))
2039 return scm_i_inexact_ceiling_divide
2040 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2041 else if (SCM_FRACTIONP (y
))
2042 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2044 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2045 s_scm_ceiling_divide
, qp
, rp
);
2047 else if (SCM_REALP (x
))
2049 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2050 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2051 return scm_i_inexact_ceiling_divide
2052 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2054 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2055 s_scm_ceiling_divide
, qp
, rp
);
2057 else if (SCM_FRACTIONP (x
))
2060 return scm_i_inexact_ceiling_divide
2061 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2062 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2063 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2065 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2066 s_scm_ceiling_divide
, qp
, rp
);
2069 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2070 s_scm_ceiling_divide
, qp
, rp
);
2074 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2076 if (SCM_UNLIKELY (y
== 0))
2077 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2080 double q
= ceil (x
/ y
);
2081 double r
= x
- q
* y
;
2082 *qp
= scm_from_double (q
);
2083 *rp
= scm_from_double (r
);
2088 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2091 SCM xd
= scm_denominator (x
);
2092 SCM yd
= scm_denominator (y
);
2094 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2095 scm_product (scm_numerator (y
), xd
),
2097 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2100 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2101 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2103 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2105 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2107 "(truncate-quotient 123 10) @result{} 12\n"
2108 "(truncate-quotient 123 -10) @result{} -12\n"
2109 "(truncate-quotient -123 10) @result{} -12\n"
2110 "(truncate-quotient -123 -10) @result{} 12\n"
2111 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2112 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2114 #define FUNC_NAME s_scm_truncate_quotient
2116 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2118 scm_t_inum xx
= SCM_I_INUM (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_truncate_quotient
);
2126 scm_t_inum qq
= xx
/ yy
;
2127 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2128 return SCM_I_MAKINUM (qq
);
2130 return scm_i_inum2big (qq
);
2133 else if (SCM_BIGP (y
))
2135 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2136 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2137 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2139 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2140 scm_remember_upto_here_1 (y
);
2141 return SCM_I_MAKINUM (-1);
2146 else if (SCM_REALP (y
))
2147 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2148 else if (SCM_FRACTIONP (y
))
2149 return scm_i_exact_rational_truncate_quotient (x
, y
);
2151 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2152 s_scm_truncate_quotient
);
2154 else if (SCM_BIGP (x
))
2156 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2158 scm_t_inum yy
= SCM_I_INUM (y
);
2159 if (SCM_UNLIKELY (yy
== 0))
2160 scm_num_overflow (s_scm_truncate_quotient
);
2161 else if (SCM_UNLIKELY (yy
== 1))
2165 SCM q
= scm_i_mkbig ();
2167 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2170 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2171 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2173 scm_remember_upto_here_1 (x
);
2174 return scm_i_normbig (q
);
2177 else if (SCM_BIGP (y
))
2179 SCM q
= scm_i_mkbig ();
2180 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2183 scm_remember_upto_here_2 (x
, y
);
2184 return scm_i_normbig (q
);
2186 else if (SCM_REALP (y
))
2187 return scm_i_inexact_truncate_quotient
2188 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2189 else if (SCM_FRACTIONP (y
))
2190 return scm_i_exact_rational_truncate_quotient (x
, y
);
2192 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2193 s_scm_truncate_quotient
);
2195 else if (SCM_REALP (x
))
2197 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2198 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2199 return scm_i_inexact_truncate_quotient
2200 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2202 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2203 s_scm_truncate_quotient
);
2205 else if (SCM_FRACTIONP (x
))
2208 return scm_i_inexact_truncate_quotient
2209 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2210 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2211 return scm_i_exact_rational_truncate_quotient (x
, y
);
2213 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2214 s_scm_truncate_quotient
);
2217 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2218 s_scm_truncate_quotient
);
2223 scm_i_inexact_truncate_quotient (double x
, double y
)
2225 if (SCM_UNLIKELY (y
== 0))
2226 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2228 return scm_from_double (trunc (x
/ y
));
2232 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2234 return scm_truncate_quotient
2235 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2236 scm_product (scm_numerator (y
), scm_denominator (x
)));
2239 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2240 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2242 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2244 "Return the real number @var{r} such that\n"
2245 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2246 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2248 "(truncate-remainder 123 10) @result{} 3\n"
2249 "(truncate-remainder 123 -10) @result{} 3\n"
2250 "(truncate-remainder -123 10) @result{} -3\n"
2251 "(truncate-remainder -123 -10) @result{} -3\n"
2252 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2253 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2255 #define FUNC_NAME s_scm_truncate_remainder
2257 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2259 scm_t_inum xx
= SCM_I_INUM (x
);
2260 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2262 scm_t_inum yy
= SCM_I_INUM (y
);
2263 if (SCM_UNLIKELY (yy
== 0))
2264 scm_num_overflow (s_scm_truncate_remainder
);
2266 return SCM_I_MAKINUM (xx
% yy
);
2268 else if (SCM_BIGP (y
))
2270 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2271 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2272 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2274 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2275 scm_remember_upto_here_1 (y
);
2281 else if (SCM_REALP (y
))
2282 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2283 else if (SCM_FRACTIONP (y
))
2284 return scm_i_exact_rational_truncate_remainder (x
, y
);
2286 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2287 s_scm_truncate_remainder
);
2289 else if (SCM_BIGP (x
))
2291 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2293 scm_t_inum yy
= SCM_I_INUM (y
);
2294 if (SCM_UNLIKELY (yy
== 0))
2295 scm_num_overflow (s_scm_truncate_remainder
);
2298 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2299 (yy
> 0) ? yy
: -yy
)
2300 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2301 scm_remember_upto_here_1 (x
);
2302 return SCM_I_MAKINUM (rr
);
2305 else if (SCM_BIGP (y
))
2307 SCM r
= scm_i_mkbig ();
2308 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2311 scm_remember_upto_here_2 (x
, y
);
2312 return scm_i_normbig (r
);
2314 else if (SCM_REALP (y
))
2315 return scm_i_inexact_truncate_remainder
2316 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2317 else if (SCM_FRACTIONP (y
))
2318 return scm_i_exact_rational_truncate_remainder (x
, y
);
2320 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2321 s_scm_truncate_remainder
);
2323 else if (SCM_REALP (x
))
2325 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2326 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2327 return scm_i_inexact_truncate_remainder
2328 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2330 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2331 s_scm_truncate_remainder
);
2333 else if (SCM_FRACTIONP (x
))
2336 return scm_i_inexact_truncate_remainder
2337 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2338 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2339 return scm_i_exact_rational_truncate_remainder (x
, y
);
2341 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2342 s_scm_truncate_remainder
);
2345 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2346 s_scm_truncate_remainder
);
2351 scm_i_inexact_truncate_remainder (double x
, double y
)
2353 /* Although it would be more efficient to use fmod here, we can't
2354 because it would in some cases produce results inconsistent with
2355 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2356 close). In particular, when x is very close to a multiple of y,
2357 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2358 correspond to different choices of q. If quotient chooses one and
2359 remainder chooses the other, it would be bad. */
2360 if (SCM_UNLIKELY (y
== 0))
2361 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2363 return scm_from_double (x
- y
* trunc (x
/ y
));
2367 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2369 SCM xd
= scm_denominator (x
);
2370 SCM yd
= scm_denominator (y
);
2371 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2372 scm_product (scm_numerator (y
), xd
));
2373 return scm_divide (r1
, scm_product (xd
, yd
));
2377 static void scm_i_inexact_truncate_divide (double x
, double y
,
2379 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2382 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2384 "Return the integer @var{q} and the real number @var{r}\n"
2385 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2386 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2388 "(truncate/ 123 10) @result{} 12 and 3\n"
2389 "(truncate/ 123 -10) @result{} -12 and 3\n"
2390 "(truncate/ -123 10) @result{} -12 and -3\n"
2391 "(truncate/ -123 -10) @result{} 12 and -3\n"
2392 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2393 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2395 #define FUNC_NAME s_scm_i_truncate_divide
2399 scm_truncate_divide(x
, y
, &q
, &r
);
2400 return scm_values (scm_list_2 (q
, r
));
2404 #define s_scm_truncate_divide s_scm_i_truncate_divide
2405 #define g_scm_truncate_divide g_scm_i_truncate_divide
2408 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2410 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2412 scm_t_inum xx
= SCM_I_INUM (x
);
2413 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2415 scm_t_inum yy
= SCM_I_INUM (y
);
2416 if (SCM_UNLIKELY (yy
== 0))
2417 scm_num_overflow (s_scm_truncate_divide
);
2420 scm_t_inum qq
= xx
/ yy
;
2421 scm_t_inum rr
= xx
% yy
;
2422 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2423 *qp
= SCM_I_MAKINUM (qq
);
2425 *qp
= scm_i_inum2big (qq
);
2426 *rp
= SCM_I_MAKINUM (rr
);
2430 else if (SCM_BIGP (y
))
2432 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2433 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2434 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2436 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2437 scm_remember_upto_here_1 (y
);
2438 *qp
= SCM_I_MAKINUM (-1);
2448 else if (SCM_REALP (y
))
2449 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2450 else if (SCM_FRACTIONP (y
))
2451 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2453 return two_valued_wta_dispatch_2
2454 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2455 s_scm_truncate_divide
, qp
, rp
);
2457 else if (SCM_BIGP (x
))
2459 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2461 scm_t_inum yy
= SCM_I_INUM (y
);
2462 if (SCM_UNLIKELY (yy
== 0))
2463 scm_num_overflow (s_scm_truncate_divide
);
2466 SCM q
= scm_i_mkbig ();
2469 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2470 SCM_I_BIG_MPZ (x
), yy
);
2473 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2474 SCM_I_BIG_MPZ (x
), -yy
);
2475 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2477 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2478 scm_remember_upto_here_1 (x
);
2479 *qp
= scm_i_normbig (q
);
2480 *rp
= SCM_I_MAKINUM (rr
);
2484 else if (SCM_BIGP (y
))
2486 SCM q
= scm_i_mkbig ();
2487 SCM r
= scm_i_mkbig ();
2488 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2489 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2490 scm_remember_upto_here_2 (x
, y
);
2491 *qp
= scm_i_normbig (q
);
2492 *rp
= scm_i_normbig (r
);
2494 else if (SCM_REALP (y
))
2495 return scm_i_inexact_truncate_divide
2496 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2497 else if (SCM_FRACTIONP (y
))
2498 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2500 return two_valued_wta_dispatch_2
2501 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2502 s_scm_truncate_divide
, qp
, rp
);
2504 else if (SCM_REALP (x
))
2506 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2507 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2508 return scm_i_inexact_truncate_divide
2509 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2511 return two_valued_wta_dispatch_2
2512 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2513 s_scm_truncate_divide
, qp
, rp
);
2515 else if (SCM_FRACTIONP (x
))
2518 return scm_i_inexact_truncate_divide
2519 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2520 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2521 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2523 return two_valued_wta_dispatch_2
2524 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2525 s_scm_truncate_divide
, qp
, rp
);
2528 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2529 s_scm_truncate_divide
, qp
, rp
);
2533 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2535 if (SCM_UNLIKELY (y
== 0))
2536 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2539 double q
= trunc (x
/ y
);
2540 double r
= x
- q
* y
;
2541 *qp
= scm_from_double (q
);
2542 *rp
= scm_from_double (r
);
2547 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2550 SCM xd
= scm_denominator (x
);
2551 SCM yd
= scm_denominator (y
);
2553 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2554 scm_product (scm_numerator (y
), xd
),
2556 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2559 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2560 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2561 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2563 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2565 "Return the integer @var{q} such that\n"
2566 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2567 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2569 "(centered-quotient 123 10) @result{} 12\n"
2570 "(centered-quotient 123 -10) @result{} -12\n"
2571 "(centered-quotient -123 10) @result{} -12\n"
2572 "(centered-quotient -123 -10) @result{} 12\n"
2573 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2574 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2576 #define FUNC_NAME s_scm_centered_quotient
2578 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2580 scm_t_inum xx
= SCM_I_INUM (x
);
2581 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2583 scm_t_inum yy
= SCM_I_INUM (y
);
2584 if (SCM_UNLIKELY (yy
== 0))
2585 scm_num_overflow (s_scm_centered_quotient
);
2588 scm_t_inum qq
= xx
/ yy
;
2589 scm_t_inum rr
= xx
% yy
;
2590 if (SCM_LIKELY (xx
> 0))
2592 if (SCM_LIKELY (yy
> 0))
2594 if (rr
>= (yy
+ 1) / 2)
2599 if (rr
>= (1 - yy
) / 2)
2605 if (SCM_LIKELY (yy
> 0))
2616 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2617 return SCM_I_MAKINUM (qq
);
2619 return scm_i_inum2big (qq
);
2622 else if (SCM_BIGP (y
))
2624 /* Pass a denormalized bignum version of x (even though it
2625 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2626 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2628 else if (SCM_REALP (y
))
2629 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2630 else if (SCM_FRACTIONP (y
))
2631 return scm_i_exact_rational_centered_quotient (x
, y
);
2633 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2634 s_scm_centered_quotient
);
2636 else if (SCM_BIGP (x
))
2638 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2640 scm_t_inum yy
= SCM_I_INUM (y
);
2641 if (SCM_UNLIKELY (yy
== 0))
2642 scm_num_overflow (s_scm_centered_quotient
);
2643 else if (SCM_UNLIKELY (yy
== 1))
2647 SCM q
= scm_i_mkbig ();
2649 /* Arrange for rr to initially be non-positive,
2650 because that simplifies the test to see
2651 if it is within the needed bounds. */
2654 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2655 SCM_I_BIG_MPZ (x
), yy
);
2656 scm_remember_upto_here_1 (x
);
2658 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2659 SCM_I_BIG_MPZ (q
), 1);
2663 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2664 SCM_I_BIG_MPZ (x
), -yy
);
2665 scm_remember_upto_here_1 (x
);
2666 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2668 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2669 SCM_I_BIG_MPZ (q
), 1);
2671 return scm_i_normbig (q
);
2674 else if (SCM_BIGP (y
))
2675 return scm_i_bigint_centered_quotient (x
, y
);
2676 else if (SCM_REALP (y
))
2677 return scm_i_inexact_centered_quotient
2678 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2679 else if (SCM_FRACTIONP (y
))
2680 return scm_i_exact_rational_centered_quotient (x
, y
);
2682 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2683 s_scm_centered_quotient
);
2685 else if (SCM_REALP (x
))
2687 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2688 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2689 return scm_i_inexact_centered_quotient
2690 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2692 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2693 s_scm_centered_quotient
);
2695 else if (SCM_FRACTIONP (x
))
2698 return scm_i_inexact_centered_quotient
2699 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2700 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2701 return scm_i_exact_rational_centered_quotient (x
, y
);
2703 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2704 s_scm_centered_quotient
);
2707 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2708 s_scm_centered_quotient
);
2713 scm_i_inexact_centered_quotient (double x
, double y
)
2715 if (SCM_LIKELY (y
> 0))
2716 return scm_from_double (floor (x
/y
+ 0.5));
2717 else if (SCM_LIKELY (y
< 0))
2718 return scm_from_double (ceil (x
/y
- 0.5));
2720 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2725 /* Assumes that both x and y are bigints, though
2726 x might be able to fit into a fixnum. */
2728 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2732 /* Note that x might be small enough to fit into a
2733 fixnum, so we must not let it escape into the wild */
2737 /* min_r will eventually become -abs(y)/2 */
2738 min_r
= scm_i_mkbig ();
2739 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2740 SCM_I_BIG_MPZ (y
), 1);
2742 /* Arrange for rr to initially be non-positive,
2743 because that simplifies the test to see
2744 if it is within the needed bounds. */
2745 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2747 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2748 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2749 scm_remember_upto_here_2 (x
, y
);
2750 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2751 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2752 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2753 SCM_I_BIG_MPZ (q
), 1);
2757 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2758 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2759 scm_remember_upto_here_2 (x
, y
);
2760 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2761 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2762 SCM_I_BIG_MPZ (q
), 1);
2764 scm_remember_upto_here_2 (r
, min_r
);
2765 return scm_i_normbig (q
);
2769 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2771 return scm_centered_quotient
2772 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2773 scm_product (scm_numerator (y
), scm_denominator (x
)));
2776 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2777 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2778 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2780 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2782 "Return the real number @var{r} such that\n"
2783 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2784 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2785 "for some integer @var{q}.\n"
2787 "(centered-remainder 123 10) @result{} 3\n"
2788 "(centered-remainder 123 -10) @result{} 3\n"
2789 "(centered-remainder -123 10) @result{} -3\n"
2790 "(centered-remainder -123 -10) @result{} -3\n"
2791 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2792 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2794 #define FUNC_NAME s_scm_centered_remainder
2796 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2798 scm_t_inum xx
= SCM_I_INUM (x
);
2799 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2801 scm_t_inum yy
= SCM_I_INUM (y
);
2802 if (SCM_UNLIKELY (yy
== 0))
2803 scm_num_overflow (s_scm_centered_remainder
);
2806 scm_t_inum rr
= xx
% yy
;
2807 if (SCM_LIKELY (xx
> 0))
2809 if (SCM_LIKELY (yy
> 0))
2811 if (rr
>= (yy
+ 1) / 2)
2816 if (rr
>= (1 - yy
) / 2)
2822 if (SCM_LIKELY (yy
> 0))
2833 return SCM_I_MAKINUM (rr
);
2836 else if (SCM_BIGP (y
))
2838 /* Pass a denormalized bignum version of x (even though it
2839 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2840 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2842 else if (SCM_REALP (y
))
2843 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2844 else if (SCM_FRACTIONP (y
))
2845 return scm_i_exact_rational_centered_remainder (x
, y
);
2847 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2848 s_scm_centered_remainder
);
2850 else if (SCM_BIGP (x
))
2852 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2854 scm_t_inum yy
= SCM_I_INUM (y
);
2855 if (SCM_UNLIKELY (yy
== 0))
2856 scm_num_overflow (s_scm_centered_remainder
);
2860 /* Arrange for rr to initially be non-positive,
2861 because that simplifies the test to see
2862 if it is within the needed bounds. */
2865 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2866 scm_remember_upto_here_1 (x
);
2872 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2873 scm_remember_upto_here_1 (x
);
2877 return SCM_I_MAKINUM (rr
);
2880 else if (SCM_BIGP (y
))
2881 return scm_i_bigint_centered_remainder (x
, y
);
2882 else if (SCM_REALP (y
))
2883 return scm_i_inexact_centered_remainder
2884 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2885 else if (SCM_FRACTIONP (y
))
2886 return scm_i_exact_rational_centered_remainder (x
, y
);
2888 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2889 s_scm_centered_remainder
);
2891 else if (SCM_REALP (x
))
2893 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2894 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2895 return scm_i_inexact_centered_remainder
2896 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2898 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2899 s_scm_centered_remainder
);
2901 else if (SCM_FRACTIONP (x
))
2904 return scm_i_inexact_centered_remainder
2905 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2906 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2907 return scm_i_exact_rational_centered_remainder (x
, y
);
2909 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2910 s_scm_centered_remainder
);
2913 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2914 s_scm_centered_remainder
);
2919 scm_i_inexact_centered_remainder (double x
, double y
)
2923 /* Although it would be more efficient to use fmod here, we can't
2924 because it would in some cases produce results inconsistent with
2925 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2926 close). In particular, when x-y/2 is very close to a multiple of
2927 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2928 two cases must correspond to different choices of q. If quotient
2929 chooses one and remainder chooses the other, it would be bad. */
2930 if (SCM_LIKELY (y
> 0))
2931 q
= floor (x
/y
+ 0.5);
2932 else if (SCM_LIKELY (y
< 0))
2933 q
= ceil (x
/y
- 0.5);
2935 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2938 return scm_from_double (x
- q
* y
);
2941 /* Assumes that both x and y are bigints, though
2942 x might be able to fit into a fixnum. */
2944 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2948 /* Note that x might be small enough to fit into a
2949 fixnum, so we must not let it escape into the wild */
2952 /* min_r will eventually become -abs(y)/2 */
2953 min_r
= scm_i_mkbig ();
2954 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2955 SCM_I_BIG_MPZ (y
), 1);
2957 /* Arrange for rr to initially be non-positive,
2958 because that simplifies the test to see
2959 if it is within the needed bounds. */
2960 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2962 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2963 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2964 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2965 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2966 mpz_add (SCM_I_BIG_MPZ (r
),
2972 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2973 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2974 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2975 mpz_sub (SCM_I_BIG_MPZ (r
),
2979 scm_remember_upto_here_2 (x
, y
);
2980 return scm_i_normbig (r
);
2984 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2986 SCM xd
= scm_denominator (x
);
2987 SCM yd
= scm_denominator (y
);
2988 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2989 scm_product (scm_numerator (y
), xd
));
2990 return scm_divide (r1
, scm_product (xd
, yd
));
2994 static void scm_i_inexact_centered_divide (double x
, double y
,
2996 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2997 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
3000 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
3002 "Return the integer @var{q} and the real number @var{r}\n"
3003 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3004 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3006 "(centered/ 123 10) @result{} 12 and 3\n"
3007 "(centered/ 123 -10) @result{} -12 and 3\n"
3008 "(centered/ -123 10) @result{} -12 and -3\n"
3009 "(centered/ -123 -10) @result{} 12 and -3\n"
3010 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3011 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3013 #define FUNC_NAME s_scm_i_centered_divide
3017 scm_centered_divide(x
, y
, &q
, &r
);
3018 return scm_values (scm_list_2 (q
, r
));
3022 #define s_scm_centered_divide s_scm_i_centered_divide
3023 #define g_scm_centered_divide g_scm_i_centered_divide
3026 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3028 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3030 scm_t_inum xx
= SCM_I_INUM (x
);
3031 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3033 scm_t_inum yy
= SCM_I_INUM (y
);
3034 if (SCM_UNLIKELY (yy
== 0))
3035 scm_num_overflow (s_scm_centered_divide
);
3038 scm_t_inum qq
= xx
/ yy
;
3039 scm_t_inum rr
= xx
% yy
;
3040 if (SCM_LIKELY (xx
> 0))
3042 if (SCM_LIKELY (yy
> 0))
3044 if (rr
>= (yy
+ 1) / 2)
3049 if (rr
>= (1 - yy
) / 2)
3055 if (SCM_LIKELY (yy
> 0))
3066 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3067 *qp
= SCM_I_MAKINUM (qq
);
3069 *qp
= scm_i_inum2big (qq
);
3070 *rp
= SCM_I_MAKINUM (rr
);
3074 else if (SCM_BIGP (y
))
3076 /* Pass a denormalized bignum version of x (even though it
3077 can fit in a fixnum) to scm_i_bigint_centered_divide */
3078 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3080 else if (SCM_REALP (y
))
3081 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3082 else if (SCM_FRACTIONP (y
))
3083 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3085 return two_valued_wta_dispatch_2
3086 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3087 s_scm_centered_divide
, qp
, rp
);
3089 else if (SCM_BIGP (x
))
3091 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3093 scm_t_inum yy
= SCM_I_INUM (y
);
3094 if (SCM_UNLIKELY (yy
== 0))
3095 scm_num_overflow (s_scm_centered_divide
);
3098 SCM q
= scm_i_mkbig ();
3100 /* Arrange for rr to initially be non-positive,
3101 because that simplifies the test to see
3102 if it is within the needed bounds. */
3105 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3106 SCM_I_BIG_MPZ (x
), yy
);
3107 scm_remember_upto_here_1 (x
);
3110 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3111 SCM_I_BIG_MPZ (q
), 1);
3117 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3118 SCM_I_BIG_MPZ (x
), -yy
);
3119 scm_remember_upto_here_1 (x
);
3120 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3123 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3124 SCM_I_BIG_MPZ (q
), 1);
3128 *qp
= scm_i_normbig (q
);
3129 *rp
= SCM_I_MAKINUM (rr
);
3133 else if (SCM_BIGP (y
))
3134 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3135 else if (SCM_REALP (y
))
3136 return scm_i_inexact_centered_divide
3137 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3138 else if (SCM_FRACTIONP (y
))
3139 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3141 return two_valued_wta_dispatch_2
3142 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3143 s_scm_centered_divide
, qp
, rp
);
3145 else if (SCM_REALP (x
))
3147 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3148 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3149 return scm_i_inexact_centered_divide
3150 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3152 return two_valued_wta_dispatch_2
3153 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3154 s_scm_centered_divide
, qp
, rp
);
3156 else if (SCM_FRACTIONP (x
))
3159 return scm_i_inexact_centered_divide
3160 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3161 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3162 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3164 return two_valued_wta_dispatch_2
3165 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3166 s_scm_centered_divide
, qp
, rp
);
3169 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3170 s_scm_centered_divide
, qp
, rp
);
3174 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3178 if (SCM_LIKELY (y
> 0))
3179 q
= floor (x
/y
+ 0.5);
3180 else if (SCM_LIKELY (y
< 0))
3181 q
= ceil (x
/y
- 0.5);
3183 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3187 *qp
= scm_from_double (q
);
3188 *rp
= scm_from_double (r
);
3191 /* Assumes that both x and y are bigints, though
3192 x might be able to fit into a fixnum. */
3194 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3198 /* Note that x might be small enough to fit into a
3199 fixnum, so we must not let it escape into the wild */
3203 /* min_r will eventually become -abs(y/2) */
3204 min_r
= scm_i_mkbig ();
3205 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3206 SCM_I_BIG_MPZ (y
), 1);
3208 /* Arrange for rr to initially be non-positive,
3209 because that simplifies the test to see
3210 if it is within the needed bounds. */
3211 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3213 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3214 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3215 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3216 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3218 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3219 SCM_I_BIG_MPZ (q
), 1);
3220 mpz_add (SCM_I_BIG_MPZ (r
),
3227 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3228 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3229 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3231 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3232 SCM_I_BIG_MPZ (q
), 1);
3233 mpz_sub (SCM_I_BIG_MPZ (r
),
3238 scm_remember_upto_here_2 (x
, y
);
3239 *qp
= scm_i_normbig (q
);
3240 *rp
= scm_i_normbig (r
);
3244 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3247 SCM xd
= scm_denominator (x
);
3248 SCM yd
= scm_denominator (y
);
3250 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3251 scm_product (scm_numerator (y
), xd
),
3253 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3256 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3257 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3258 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3260 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3262 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3263 "with ties going to the nearest even integer.\n"
3265 "(round-quotient 123 10) @result{} 12\n"
3266 "(round-quotient 123 -10) @result{} -12\n"
3267 "(round-quotient -123 10) @result{} -12\n"
3268 "(round-quotient -123 -10) @result{} 12\n"
3269 "(round-quotient 125 10) @result{} 12\n"
3270 "(round-quotient 127 10) @result{} 13\n"
3271 "(round-quotient 135 10) @result{} 14\n"
3272 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3273 "(round-quotient 16/3 -10/7) @result{} -4\n"
3275 #define FUNC_NAME s_scm_round_quotient
3277 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3279 scm_t_inum xx
= SCM_I_INUM (x
);
3280 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3282 scm_t_inum yy
= SCM_I_INUM (y
);
3283 if (SCM_UNLIKELY (yy
== 0))
3284 scm_num_overflow (s_scm_round_quotient
);
3287 scm_t_inum qq
= xx
/ yy
;
3288 scm_t_inum rr
= xx
% yy
;
3290 scm_t_inum r2
= 2 * rr
;
3292 if (SCM_LIKELY (yy
< 0))
3312 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3313 return SCM_I_MAKINUM (qq
);
3315 return scm_i_inum2big (qq
);
3318 else if (SCM_BIGP (y
))
3320 /* Pass a denormalized bignum version of x (even though it
3321 can fit in a fixnum) to scm_i_bigint_round_quotient */
3322 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3324 else if (SCM_REALP (y
))
3325 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3326 else if (SCM_FRACTIONP (y
))
3327 return scm_i_exact_rational_round_quotient (x
, y
);
3329 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3330 s_scm_round_quotient
);
3332 else if (SCM_BIGP (x
))
3334 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3336 scm_t_inum yy
= SCM_I_INUM (y
);
3337 if (SCM_UNLIKELY (yy
== 0))
3338 scm_num_overflow (s_scm_round_quotient
);
3339 else if (SCM_UNLIKELY (yy
== 1))
3343 SCM q
= scm_i_mkbig ();
3345 int needs_adjustment
;
3349 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3350 SCM_I_BIG_MPZ (x
), yy
);
3351 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3352 needs_adjustment
= (2*rr
>= yy
);
3354 needs_adjustment
= (2*rr
> yy
);
3358 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3359 SCM_I_BIG_MPZ (x
), -yy
);
3360 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3361 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3362 needs_adjustment
= (2*rr
<= yy
);
3364 needs_adjustment
= (2*rr
< yy
);
3366 scm_remember_upto_here_1 (x
);
3367 if (needs_adjustment
)
3368 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3369 return scm_i_normbig (q
);
3372 else if (SCM_BIGP (y
))
3373 return scm_i_bigint_round_quotient (x
, y
);
3374 else if (SCM_REALP (y
))
3375 return scm_i_inexact_round_quotient
3376 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3377 else if (SCM_FRACTIONP (y
))
3378 return scm_i_exact_rational_round_quotient (x
, y
);
3380 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3381 s_scm_round_quotient
);
3383 else if (SCM_REALP (x
))
3385 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3386 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3387 return scm_i_inexact_round_quotient
3388 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3390 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3391 s_scm_round_quotient
);
3393 else if (SCM_FRACTIONP (x
))
3396 return scm_i_inexact_round_quotient
3397 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3398 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3399 return scm_i_exact_rational_round_quotient (x
, y
);
3401 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3402 s_scm_round_quotient
);
3405 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3406 s_scm_round_quotient
);
3411 scm_i_inexact_round_quotient (double x
, double y
)
3413 if (SCM_UNLIKELY (y
== 0))
3414 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3416 return scm_from_double (scm_c_round (x
/ y
));
3419 /* Assumes that both x and y are bigints, though
3420 x might be able to fit into a fixnum. */
3422 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3425 int cmp
, needs_adjustment
;
3427 /* Note that x might be small enough to fit into a
3428 fixnum, so we must not let it escape into the wild */
3431 r2
= scm_i_mkbig ();
3433 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3434 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3435 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3436 scm_remember_upto_here_2 (x
, r
);
3438 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3439 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3440 needs_adjustment
= (cmp
>= 0);
3442 needs_adjustment
= (cmp
> 0);
3443 scm_remember_upto_here_2 (r2
, y
);
3445 if (needs_adjustment
)
3446 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3448 return scm_i_normbig (q
);
3452 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3454 return scm_round_quotient
3455 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3456 scm_product (scm_numerator (y
), scm_denominator (x
)));
3459 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3460 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3461 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3463 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3465 "Return the real number @var{r} such that\n"
3466 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3467 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3468 "nearest integer, with ties going to the nearest\n"
3471 "(round-remainder 123 10) @result{} 3\n"
3472 "(round-remainder 123 -10) @result{} 3\n"
3473 "(round-remainder -123 10) @result{} -3\n"
3474 "(round-remainder -123 -10) @result{} -3\n"
3475 "(round-remainder 125 10) @result{} 5\n"
3476 "(round-remainder 127 10) @result{} -3\n"
3477 "(round-remainder 135 10) @result{} -5\n"
3478 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3479 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3481 #define FUNC_NAME s_scm_round_remainder
3483 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3485 scm_t_inum xx
= SCM_I_INUM (x
);
3486 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3488 scm_t_inum yy
= SCM_I_INUM (y
);
3489 if (SCM_UNLIKELY (yy
== 0))
3490 scm_num_overflow (s_scm_round_remainder
);
3493 scm_t_inum qq
= xx
/ yy
;
3494 scm_t_inum rr
= xx
% yy
;
3496 scm_t_inum r2
= 2 * rr
;
3498 if (SCM_LIKELY (yy
< 0))
3518 return SCM_I_MAKINUM (rr
);
3521 else if (SCM_BIGP (y
))
3523 /* Pass a denormalized bignum version of x (even though it
3524 can fit in a fixnum) to scm_i_bigint_round_remainder */
3525 return scm_i_bigint_round_remainder
3526 (scm_i_long2big (xx
), y
);
3528 else if (SCM_REALP (y
))
3529 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3530 else if (SCM_FRACTIONP (y
))
3531 return scm_i_exact_rational_round_remainder (x
, y
);
3533 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3534 s_scm_round_remainder
);
3536 else if (SCM_BIGP (x
))
3538 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3540 scm_t_inum yy
= SCM_I_INUM (y
);
3541 if (SCM_UNLIKELY (yy
== 0))
3542 scm_num_overflow (s_scm_round_remainder
);
3545 SCM q
= scm_i_mkbig ();
3547 int needs_adjustment
;
3551 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3552 SCM_I_BIG_MPZ (x
), yy
);
3553 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3554 needs_adjustment
= (2*rr
>= yy
);
3556 needs_adjustment
= (2*rr
> yy
);
3560 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3561 SCM_I_BIG_MPZ (x
), -yy
);
3562 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3563 needs_adjustment
= (2*rr
<= yy
);
3565 needs_adjustment
= (2*rr
< yy
);
3567 scm_remember_upto_here_2 (x
, q
);
3568 if (needs_adjustment
)
3570 return SCM_I_MAKINUM (rr
);
3573 else if (SCM_BIGP (y
))
3574 return scm_i_bigint_round_remainder (x
, y
);
3575 else if (SCM_REALP (y
))
3576 return scm_i_inexact_round_remainder
3577 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3578 else if (SCM_FRACTIONP (y
))
3579 return scm_i_exact_rational_round_remainder (x
, y
);
3581 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3582 s_scm_round_remainder
);
3584 else if (SCM_REALP (x
))
3586 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3587 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3588 return scm_i_inexact_round_remainder
3589 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3591 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3592 s_scm_round_remainder
);
3594 else if (SCM_FRACTIONP (x
))
3597 return scm_i_inexact_round_remainder
3598 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3599 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3600 return scm_i_exact_rational_round_remainder (x
, y
);
3602 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3603 s_scm_round_remainder
);
3606 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3607 s_scm_round_remainder
);
3612 scm_i_inexact_round_remainder (double x
, double y
)
3614 /* Although it would be more efficient to use fmod here, we can't
3615 because it would in some cases produce results inconsistent with
3616 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3617 close). In particular, when x-y/2 is very close to a multiple of
3618 y, then r might be either -abs(y/2) or abs(y/2), but those two
3619 cases must correspond to different choices of q. If quotient
3620 chooses one and remainder chooses the other, it would be bad. */
3622 if (SCM_UNLIKELY (y
== 0))
3623 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3626 double q
= scm_c_round (x
/ y
);
3627 return scm_from_double (x
- q
* y
);
3631 /* Assumes that both x and y are bigints, though
3632 x might be able to fit into a fixnum. */
3634 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3637 int cmp
, needs_adjustment
;
3639 /* Note that x might be small enough to fit into a
3640 fixnum, so we must not let it escape into the wild */
3643 r2
= scm_i_mkbig ();
3645 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3646 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3647 scm_remember_upto_here_1 (x
);
3648 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3650 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3651 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3652 needs_adjustment
= (cmp
>= 0);
3654 needs_adjustment
= (cmp
> 0);
3655 scm_remember_upto_here_2 (q
, r2
);
3657 if (needs_adjustment
)
3658 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3660 scm_remember_upto_here_1 (y
);
3661 return scm_i_normbig (r
);
3665 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3667 SCM xd
= scm_denominator (x
);
3668 SCM yd
= scm_denominator (y
);
3669 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3670 scm_product (scm_numerator (y
), xd
));
3671 return scm_divide (r1
, scm_product (xd
, yd
));
3675 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3676 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3677 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3679 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3681 "Return the integer @var{q} and the real number @var{r}\n"
3682 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3683 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3684 "nearest integer, with ties going to the nearest even integer.\n"
3686 "(round/ 123 10) @result{} 12 and 3\n"
3687 "(round/ 123 -10) @result{} -12 and 3\n"
3688 "(round/ -123 10) @result{} -12 and -3\n"
3689 "(round/ -123 -10) @result{} 12 and -3\n"
3690 "(round/ 125 10) @result{} 12 and 5\n"
3691 "(round/ 127 10) @result{} 13 and -3\n"
3692 "(round/ 135 10) @result{} 14 and -5\n"
3693 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3694 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3696 #define FUNC_NAME s_scm_i_round_divide
3700 scm_round_divide(x
, y
, &q
, &r
);
3701 return scm_values (scm_list_2 (q
, r
));
3705 #define s_scm_round_divide s_scm_i_round_divide
3706 #define g_scm_round_divide g_scm_i_round_divide
3709 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3711 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3713 scm_t_inum xx
= SCM_I_INUM (x
);
3714 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3716 scm_t_inum yy
= SCM_I_INUM (y
);
3717 if (SCM_UNLIKELY (yy
== 0))
3718 scm_num_overflow (s_scm_round_divide
);
3721 scm_t_inum qq
= xx
/ yy
;
3722 scm_t_inum rr
= xx
% yy
;
3724 scm_t_inum r2
= 2 * rr
;
3726 if (SCM_LIKELY (yy
< 0))
3746 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3747 *qp
= SCM_I_MAKINUM (qq
);
3749 *qp
= scm_i_inum2big (qq
);
3750 *rp
= SCM_I_MAKINUM (rr
);
3754 else if (SCM_BIGP (y
))
3756 /* Pass a denormalized bignum version of x (even though it
3757 can fit in a fixnum) to scm_i_bigint_round_divide */
3758 return scm_i_bigint_round_divide
3759 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3761 else if (SCM_REALP (y
))
3762 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3763 else if (SCM_FRACTIONP (y
))
3764 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3766 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3767 s_scm_round_divide
, qp
, rp
);
3769 else if (SCM_BIGP (x
))
3771 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3773 scm_t_inum yy
= SCM_I_INUM (y
);
3774 if (SCM_UNLIKELY (yy
== 0))
3775 scm_num_overflow (s_scm_round_divide
);
3778 SCM q
= scm_i_mkbig ();
3780 int needs_adjustment
;
3784 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3785 SCM_I_BIG_MPZ (x
), yy
);
3786 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3787 needs_adjustment
= (2*rr
>= yy
);
3789 needs_adjustment
= (2*rr
> yy
);
3793 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3794 SCM_I_BIG_MPZ (x
), -yy
);
3795 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3796 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3797 needs_adjustment
= (2*rr
<= yy
);
3799 needs_adjustment
= (2*rr
< yy
);
3801 scm_remember_upto_here_1 (x
);
3802 if (needs_adjustment
)
3804 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3807 *qp
= scm_i_normbig (q
);
3808 *rp
= SCM_I_MAKINUM (rr
);
3812 else if (SCM_BIGP (y
))
3813 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3814 else if (SCM_REALP (y
))
3815 return scm_i_inexact_round_divide
3816 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3817 else if (SCM_FRACTIONP (y
))
3818 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3820 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3821 s_scm_round_divide
, qp
, rp
);
3823 else if (SCM_REALP (x
))
3825 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3826 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3827 return scm_i_inexact_round_divide
3828 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3830 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3831 s_scm_round_divide
, qp
, rp
);
3833 else if (SCM_FRACTIONP (x
))
3836 return scm_i_inexact_round_divide
3837 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3838 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3839 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3841 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3842 s_scm_round_divide
, qp
, rp
);
3845 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3846 s_scm_round_divide
, qp
, rp
);
3850 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3852 if (SCM_UNLIKELY (y
== 0))
3853 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3856 double q
= scm_c_round (x
/ y
);
3857 double r
= x
- q
* y
;
3858 *qp
= scm_from_double (q
);
3859 *rp
= scm_from_double (r
);
3863 /* Assumes that both x and y are bigints, though
3864 x might be able to fit into a fixnum. */
3866 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3869 int cmp
, needs_adjustment
;
3871 /* Note that x might be small enough to fit into a
3872 fixnum, so we must not let it escape into the wild */
3875 r2
= scm_i_mkbig ();
3877 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3878 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3879 scm_remember_upto_here_1 (x
);
3880 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3882 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3883 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3884 needs_adjustment
= (cmp
>= 0);
3886 needs_adjustment
= (cmp
> 0);
3888 if (needs_adjustment
)
3890 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3891 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3894 scm_remember_upto_here_2 (r2
, y
);
3895 *qp
= scm_i_normbig (q
);
3896 *rp
= scm_i_normbig (r
);
3900 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3903 SCM xd
= scm_denominator (x
);
3904 SCM yd
= scm_denominator (y
);
3906 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3907 scm_product (scm_numerator (y
), xd
),
3909 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3913 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3914 (SCM x
, SCM y
, SCM rest
),
3915 "Return the greatest common divisor of all parameter values.\n"
3916 "If called without arguments, 0 is returned.")
3917 #define FUNC_NAME s_scm_i_gcd
3919 while (!scm_is_null (rest
))
3920 { x
= scm_gcd (x
, y
);
3922 rest
= scm_cdr (rest
);
3924 return scm_gcd (x
, y
);
3928 #define s_gcd s_scm_i_gcd
3929 #define g_gcd g_scm_i_gcd
3932 scm_gcd (SCM x
, SCM y
)
3934 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
3935 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3937 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3939 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3941 scm_t_inum xx
= SCM_I_INUM (x
);
3942 scm_t_inum yy
= SCM_I_INUM (y
);
3943 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3944 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3946 if (SCM_UNLIKELY (xx
== 0))
3948 else if (SCM_UNLIKELY (yy
== 0))
3953 /* Determine a common factor 2^k */
3954 while (((u
| v
) & 1) == 0)
3960 /* Now, any factor 2^n can be eliminated */
3962 while ((u
& 1) == 0)
3965 while ((v
& 1) == 0)
3967 /* Both u and v are now odd. Subtract the smaller one
3968 from the larger one to produce an even number, remove
3969 more factors of two, and repeat. */
3975 while ((u
& 1) == 0)
3981 while ((v
& 1) == 0)
3987 return (SCM_POSFIXABLE (result
)
3988 ? SCM_I_MAKINUM (result
)
3989 : scm_i_inum2big (result
));
3991 else if (SCM_BIGP (y
))
3997 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3999 else if (SCM_BIGP (x
))
4001 if (SCM_I_INUMP (y
))
4006 yy
= SCM_I_INUM (y
);
4011 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
4012 scm_remember_upto_here_1 (x
);
4013 return (SCM_POSFIXABLE (result
)
4014 ? SCM_I_MAKINUM (result
)
4015 : scm_from_unsigned_integer (result
));
4017 else if (SCM_BIGP (y
))
4019 SCM result
= scm_i_mkbig ();
4020 mpz_gcd (SCM_I_BIG_MPZ (result
),
4023 scm_remember_upto_here_2 (x
, y
);
4024 return scm_i_normbig (result
);
4027 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4030 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4033 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4034 (SCM x
, SCM y
, SCM rest
),
4035 "Return the least common multiple of the arguments.\n"
4036 "If called without arguments, 1 is returned.")
4037 #define FUNC_NAME s_scm_i_lcm
4039 while (!scm_is_null (rest
))
4040 { x
= scm_lcm (x
, y
);
4042 rest
= scm_cdr (rest
);
4044 return scm_lcm (x
, y
);
4048 #define s_lcm s_scm_i_lcm
4049 #define g_lcm g_scm_i_lcm
4052 scm_lcm (SCM n1
, SCM n2
)
4054 if (SCM_UNBNDP (n2
))
4056 if (SCM_UNBNDP (n1
))
4057 return SCM_I_MAKINUM (1L);
4058 n2
= SCM_I_MAKINUM (1L);
4061 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4062 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4063 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4064 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4066 if (SCM_I_INUMP (n1
))
4068 if (SCM_I_INUMP (n2
))
4070 SCM d
= scm_gcd (n1
, n2
);
4071 if (scm_is_eq (d
, SCM_INUM0
))
4074 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4078 /* inum n1, big n2 */
4081 SCM result
= scm_i_mkbig ();
4082 scm_t_inum nn1
= SCM_I_INUM (n1
);
4083 if (nn1
== 0) return SCM_INUM0
;
4084 if (nn1
< 0) nn1
= - nn1
;
4085 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4086 scm_remember_upto_here_1 (n2
);
4094 if (SCM_I_INUMP (n2
))
4101 SCM result
= scm_i_mkbig ();
4102 mpz_lcm(SCM_I_BIG_MPZ (result
),
4104 SCM_I_BIG_MPZ (n2
));
4105 scm_remember_upto_here_2(n1
, n2
);
4106 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4112 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4117 + + + x (map digit:logand X Y)
4118 + - + x (map digit:logand X (lognot (+ -1 Y)))
4119 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4120 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4125 + + + (map digit:logior X Y)
4126 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4127 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4128 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4133 + + + (map digit:logxor X Y)
4134 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4135 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4136 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4141 + + (any digit:logand X Y)
4142 + - (any digit:logand X (lognot (+ -1 Y)))
4143 - + (any digit:logand (lognot (+ -1 X)) Y)
4148 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4149 (SCM x
, SCM y
, SCM rest
),
4150 "Return the bitwise AND of the integer arguments.\n\n"
4152 "(logand) @result{} -1\n"
4153 "(logand 7) @result{} 7\n"
4154 "(logand #b111 #b011 #b001) @result{} 1\n"
4156 #define FUNC_NAME s_scm_i_logand
4158 while (!scm_is_null (rest
))
4159 { x
= scm_logand (x
, y
);
4161 rest
= scm_cdr (rest
);
4163 return scm_logand (x
, y
);
4167 #define s_scm_logand s_scm_i_logand
4169 SCM
scm_logand (SCM n1
, SCM n2
)
4170 #define FUNC_NAME s_scm_logand
4174 if (SCM_UNBNDP (n2
))
4176 if (SCM_UNBNDP (n1
))
4177 return SCM_I_MAKINUM (-1);
4178 else if (!SCM_NUMBERP (n1
))
4179 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4180 else if (SCM_NUMBERP (n1
))
4183 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4186 if (SCM_I_INUMP (n1
))
4188 nn1
= SCM_I_INUM (n1
);
4189 if (SCM_I_INUMP (n2
))
4191 scm_t_inum nn2
= SCM_I_INUM (n2
);
4192 return SCM_I_MAKINUM (nn1
& nn2
);
4194 else if SCM_BIGP (n2
)
4200 SCM result_z
= scm_i_mkbig ();
4202 mpz_init_set_si (nn1_z
, nn1
);
4203 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4204 scm_remember_upto_here_1 (n2
);
4206 return scm_i_normbig (result_z
);
4210 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4212 else if (SCM_BIGP (n1
))
4214 if (SCM_I_INUMP (n2
))
4217 nn1
= SCM_I_INUM (n1
);
4220 else if (SCM_BIGP (n2
))
4222 SCM result_z
= scm_i_mkbig ();
4223 mpz_and (SCM_I_BIG_MPZ (result_z
),
4225 SCM_I_BIG_MPZ (n2
));
4226 scm_remember_upto_here_2 (n1
, n2
);
4227 return scm_i_normbig (result_z
);
4230 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4233 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4238 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4239 (SCM x
, SCM y
, SCM rest
),
4240 "Return the bitwise OR of the integer arguments.\n\n"
4242 "(logior) @result{} 0\n"
4243 "(logior 7) @result{} 7\n"
4244 "(logior #b000 #b001 #b011) @result{} 3\n"
4246 #define FUNC_NAME s_scm_i_logior
4248 while (!scm_is_null (rest
))
4249 { x
= scm_logior (x
, y
);
4251 rest
= scm_cdr (rest
);
4253 return scm_logior (x
, y
);
4257 #define s_scm_logior s_scm_i_logior
4259 SCM
scm_logior (SCM n1
, SCM n2
)
4260 #define FUNC_NAME s_scm_logior
4264 if (SCM_UNBNDP (n2
))
4266 if (SCM_UNBNDP (n1
))
4268 else if (SCM_NUMBERP (n1
))
4271 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4274 if (SCM_I_INUMP (n1
))
4276 nn1
= SCM_I_INUM (n1
);
4277 if (SCM_I_INUMP (n2
))
4279 long nn2
= SCM_I_INUM (n2
);
4280 return SCM_I_MAKINUM (nn1
| nn2
);
4282 else if (SCM_BIGP (n2
))
4288 SCM result_z
= scm_i_mkbig ();
4290 mpz_init_set_si (nn1_z
, nn1
);
4291 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4292 scm_remember_upto_here_1 (n2
);
4294 return scm_i_normbig (result_z
);
4298 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4300 else if (SCM_BIGP (n1
))
4302 if (SCM_I_INUMP (n2
))
4305 nn1
= SCM_I_INUM (n1
);
4308 else if (SCM_BIGP (n2
))
4310 SCM result_z
= scm_i_mkbig ();
4311 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4313 SCM_I_BIG_MPZ (n2
));
4314 scm_remember_upto_here_2 (n1
, n2
);
4315 return scm_i_normbig (result_z
);
4318 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4321 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4326 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4327 (SCM x
, SCM y
, SCM rest
),
4328 "Return the bitwise XOR of the integer arguments. A bit is\n"
4329 "set in the result if it is set in an odd number of arguments.\n"
4331 "(logxor) @result{} 0\n"
4332 "(logxor 7) @result{} 7\n"
4333 "(logxor #b000 #b001 #b011) @result{} 2\n"
4334 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4336 #define FUNC_NAME s_scm_i_logxor
4338 while (!scm_is_null (rest
))
4339 { x
= scm_logxor (x
, y
);
4341 rest
= scm_cdr (rest
);
4343 return scm_logxor (x
, y
);
4347 #define s_scm_logxor s_scm_i_logxor
4349 SCM
scm_logxor (SCM n1
, SCM n2
)
4350 #define FUNC_NAME s_scm_logxor
4354 if (SCM_UNBNDP (n2
))
4356 if (SCM_UNBNDP (n1
))
4358 else if (SCM_NUMBERP (n1
))
4361 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4364 if (SCM_I_INUMP (n1
))
4366 nn1
= SCM_I_INUM (n1
);
4367 if (SCM_I_INUMP (n2
))
4369 scm_t_inum nn2
= SCM_I_INUM (n2
);
4370 return SCM_I_MAKINUM (nn1
^ nn2
);
4372 else if (SCM_BIGP (n2
))
4376 SCM result_z
= scm_i_mkbig ();
4378 mpz_init_set_si (nn1_z
, nn1
);
4379 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4380 scm_remember_upto_here_1 (n2
);
4382 return scm_i_normbig (result_z
);
4386 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4388 else if (SCM_BIGP (n1
))
4390 if (SCM_I_INUMP (n2
))
4393 nn1
= SCM_I_INUM (n1
);
4396 else if (SCM_BIGP (n2
))
4398 SCM result_z
= scm_i_mkbig ();
4399 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4401 SCM_I_BIG_MPZ (n2
));
4402 scm_remember_upto_here_2 (n1
, n2
);
4403 return scm_i_normbig (result_z
);
4406 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4409 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4414 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4416 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4417 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4418 "without actually calculating the @code{logand}, just testing\n"
4422 "(logtest #b0100 #b1011) @result{} #f\n"
4423 "(logtest #b0100 #b0111) @result{} #t\n"
4425 #define FUNC_NAME s_scm_logtest
4429 if (SCM_I_INUMP (j
))
4431 nj
= SCM_I_INUM (j
);
4432 if (SCM_I_INUMP (k
))
4434 scm_t_inum nk
= SCM_I_INUM (k
);
4435 return scm_from_bool (nj
& nk
);
4437 else if (SCM_BIGP (k
))
4445 mpz_init_set_si (nj_z
, nj
);
4446 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4447 scm_remember_upto_here_1 (k
);
4448 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4454 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4456 else if (SCM_BIGP (j
))
4458 if (SCM_I_INUMP (k
))
4461 nj
= SCM_I_INUM (j
);
4464 else if (SCM_BIGP (k
))
4468 mpz_init (result_z
);
4472 scm_remember_upto_here_2 (j
, k
);
4473 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4474 mpz_clear (result_z
);
4478 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4481 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4486 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4488 "Test whether bit number @var{index} in @var{j} is set.\n"
4489 "@var{index} starts from 0 for the least significant bit.\n"
4492 "(logbit? 0 #b1101) @result{} #t\n"
4493 "(logbit? 1 #b1101) @result{} #f\n"
4494 "(logbit? 2 #b1101) @result{} #t\n"
4495 "(logbit? 3 #b1101) @result{} #t\n"
4496 "(logbit? 4 #b1101) @result{} #f\n"
4498 #define FUNC_NAME s_scm_logbit_p
4500 unsigned long int iindex
;
4501 iindex
= scm_to_ulong (index
);
4503 if (SCM_I_INUMP (j
))
4505 /* bits above what's in an inum follow the sign bit */
4506 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4507 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4509 else if (SCM_BIGP (j
))
4511 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4512 scm_remember_upto_here_1 (j
);
4513 return scm_from_bool (val
);
4516 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4521 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4523 "Return the integer which is the ones-complement of the integer\n"
4527 "(number->string (lognot #b10000000) 2)\n"
4528 " @result{} \"-10000001\"\n"
4529 "(number->string (lognot #b0) 2)\n"
4530 " @result{} \"-1\"\n"
4532 #define FUNC_NAME s_scm_lognot
4534 if (SCM_I_INUMP (n
)) {
4535 /* No overflow here, just need to toggle all the bits making up the inum.
4536 Enhancement: No need to strip the tag and add it back, could just xor
4537 a block of 1 bits, if that worked with the various debug versions of
4539 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4541 } else if (SCM_BIGP (n
)) {
4542 SCM result
= scm_i_mkbig ();
4543 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4544 scm_remember_upto_here_1 (n
);
4548 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4553 /* returns 0 if IN is not an integer. OUT must already be
4556 coerce_to_big (SCM in
, mpz_t out
)
4559 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4560 else if (SCM_I_INUMP (in
))
4561 mpz_set_si (out
, SCM_I_INUM (in
));
4568 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4569 (SCM n
, SCM k
, SCM m
),
4570 "Return @var{n} raised to the integer exponent\n"
4571 "@var{k}, modulo @var{m}.\n"
4574 "(modulo-expt 2 3 5)\n"
4577 #define FUNC_NAME s_scm_modulo_expt
4583 /* There are two classes of error we might encounter --
4584 1) Math errors, which we'll report by calling scm_num_overflow,
4586 2) wrong-type errors, which of course we'll report by calling
4588 We don't report those errors immediately, however; instead we do
4589 some cleanup first. These variables tell us which error (if
4590 any) we should report after cleaning up.
4592 int report_overflow
= 0;
4594 int position_of_wrong_type
= 0;
4595 SCM value_of_wrong_type
= SCM_INUM0
;
4597 SCM result
= SCM_UNDEFINED
;
4603 if (scm_is_eq (m
, SCM_INUM0
))
4605 report_overflow
= 1;
4609 if (!coerce_to_big (n
, n_tmp
))
4611 value_of_wrong_type
= n
;
4612 position_of_wrong_type
= 1;
4616 if (!coerce_to_big (k
, k_tmp
))
4618 value_of_wrong_type
= k
;
4619 position_of_wrong_type
= 2;
4623 if (!coerce_to_big (m
, m_tmp
))
4625 value_of_wrong_type
= m
;
4626 position_of_wrong_type
= 3;
4630 /* if the exponent K is negative, and we simply call mpz_powm, we
4631 will get a divide-by-zero exception when an inverse 1/n mod m
4632 doesn't exist (or is not unique). Since exceptions are hard to
4633 handle, we'll attempt the inversion "by hand" -- that way, we get
4634 a simple failure code, which is easy to handle. */
4636 if (-1 == mpz_sgn (k_tmp
))
4638 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4640 report_overflow
= 1;
4643 mpz_neg (k_tmp
, k_tmp
);
4646 result
= scm_i_mkbig ();
4647 mpz_powm (SCM_I_BIG_MPZ (result
),
4652 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4653 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4660 if (report_overflow
)
4661 scm_num_overflow (FUNC_NAME
);
4663 if (position_of_wrong_type
)
4664 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4665 value_of_wrong_type
);
4667 return scm_i_normbig (result
);
4671 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4673 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4674 "exact integer, @var{n} can be any number.\n"
4676 "Negative @var{k} is supported, and results in\n"
4677 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4678 "@math{@var{n}^0} is 1, as usual, and that\n"
4679 "includes @math{0^0} is 1.\n"
4682 "(integer-expt 2 5) @result{} 32\n"
4683 "(integer-expt -3 3) @result{} -27\n"
4684 "(integer-expt 5 -3) @result{} 1/125\n"
4685 "(integer-expt 0 0) @result{} 1\n"
4687 #define FUNC_NAME s_scm_integer_expt
4690 SCM z_i2
= SCM_BOOL_F
;
4692 SCM acc
= SCM_I_MAKINUM (1L);
4694 /* Specifically refrain from checking the type of the first argument.
4695 This allows us to exponentiate any object that can be multiplied.
4696 If we must raise to a negative power, we must also be able to
4697 take its reciprocal. */
4698 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4699 SCM_WRONG_TYPE_ARG (2, k
);
4701 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4702 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4703 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4704 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4705 /* The next check is necessary only because R6RS specifies different
4706 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4707 we simply skip this case and move on. */
4708 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4710 /* k cannot be 0 at this point, because we
4711 have already checked for that case above */
4712 if (scm_is_true (scm_positive_p (k
)))
4714 else /* return NaN for (0 ^ k) for negative k per R6RS */
4717 else if (SCM_FRACTIONP (n
))
4719 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4720 needless reduction of intermediate products to lowest terms.
4721 If a and b have no common factors, then a^k and b^k have no
4722 common factors. Use 'scm_i_make_ratio_already_reduced' to
4723 construct the final result, so that no gcd computations are
4724 needed to exponentiate a fraction. */
4725 if (scm_is_true (scm_positive_p (k
)))
4726 return scm_i_make_ratio_already_reduced
4727 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4728 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4731 k
= scm_difference (k
, SCM_UNDEFINED
);
4732 return scm_i_make_ratio_already_reduced
4733 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4734 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4738 if (SCM_I_INUMP (k
))
4739 i2
= SCM_I_INUM (k
);
4740 else if (SCM_BIGP (k
))
4742 z_i2
= scm_i_clonebig (k
, 1);
4743 scm_remember_upto_here_1 (k
);
4747 SCM_WRONG_TYPE_ARG (2, k
);
4751 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4753 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4754 n
= scm_divide (n
, SCM_UNDEFINED
);
4758 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4762 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4764 return scm_product (acc
, n
);
4766 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4767 acc
= scm_product (acc
, n
);
4768 n
= scm_product (n
, n
);
4769 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4777 n
= scm_divide (n
, SCM_UNDEFINED
);
4784 return scm_product (acc
, n
);
4786 acc
= scm_product (acc
, n
);
4787 n
= scm_product (n
, n
);
4794 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4796 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4797 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4799 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4800 "@var{cnt} is negative it's a division, rounded towards negative\n"
4801 "infinity. (Note that this is not the same rounding as\n"
4802 "@code{quotient} does.)\n"
4804 "With @var{n} viewed as an infinite precision twos complement,\n"
4805 "@code{ash} means a left shift introducing zero bits, or a right\n"
4806 "shift dropping bits.\n"
4809 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4810 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4812 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4813 "(ash -23 -2) @result{} -6\n"
4815 #define FUNC_NAME s_scm_ash
4818 bits_to_shift
= scm_to_long (cnt
);
4820 if (SCM_I_INUMP (n
))
4822 scm_t_inum nn
= SCM_I_INUM (n
);
4824 if (bits_to_shift
> 0)
4826 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4827 overflow a non-zero fixnum. For smaller shifts we check the
4828 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4829 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4830 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4836 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4838 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4841 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4845 SCM result
= scm_i_inum2big (nn
);
4846 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4853 bits_to_shift
= -bits_to_shift
;
4854 if (bits_to_shift
>= SCM_LONG_BIT
)
4855 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4857 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4861 else if (SCM_BIGP (n
))
4865 if (bits_to_shift
== 0)
4868 result
= scm_i_mkbig ();
4869 if (bits_to_shift
>= 0)
4871 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4877 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4878 we have to allocate a bignum even if the result is going to be a
4880 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4882 return scm_i_normbig (result
);
4888 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4894 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4895 (SCM n
, SCM start
, SCM end
),
4896 "Return the integer composed of the @var{start} (inclusive)\n"
4897 "through @var{end} (exclusive) bits of @var{n}. The\n"
4898 "@var{start}th bit becomes the 0-th bit in the result.\n"
4901 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4902 " @result{} \"1010\"\n"
4903 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4904 " @result{} \"10110\"\n"
4906 #define FUNC_NAME s_scm_bit_extract
4908 unsigned long int istart
, iend
, bits
;
4909 istart
= scm_to_ulong (start
);
4910 iend
= scm_to_ulong (end
);
4911 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4913 /* how many bits to keep */
4914 bits
= iend
- istart
;
4916 if (SCM_I_INUMP (n
))
4918 scm_t_inum in
= SCM_I_INUM (n
);
4920 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4921 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4922 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4924 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4926 /* Since we emulate two's complement encoded numbers, this
4927 * special case requires us to produce a result that has
4928 * more bits than can be stored in a fixnum.
4930 SCM result
= scm_i_inum2big (in
);
4931 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4936 /* mask down to requisite bits */
4937 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4938 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4940 else if (SCM_BIGP (n
))
4945 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4949 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4950 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4951 such bits into a ulong. */
4952 result
= scm_i_mkbig ();
4953 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4954 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4955 result
= scm_i_normbig (result
);
4957 scm_remember_upto_here_1 (n
);
4961 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4966 static const char scm_logtab
[] = {
4967 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4970 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4972 "Return the number of bits in integer @var{n}. If integer is\n"
4973 "positive, the 1-bits in its binary representation are counted.\n"
4974 "If negative, the 0-bits in its two's-complement binary\n"
4975 "representation are counted. If 0, 0 is returned.\n"
4978 "(logcount #b10101010)\n"
4985 #define FUNC_NAME s_scm_logcount
4987 if (SCM_I_INUMP (n
))
4989 unsigned long c
= 0;
4990 scm_t_inum nn
= SCM_I_INUM (n
);
4995 c
+= scm_logtab
[15 & nn
];
4998 return SCM_I_MAKINUM (c
);
5000 else if (SCM_BIGP (n
))
5002 unsigned long count
;
5003 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5004 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5006 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5007 scm_remember_upto_here_1 (n
);
5008 return SCM_I_MAKINUM (count
);
5011 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5016 static const char scm_ilentab
[] = {
5017 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5021 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5023 "Return the number of bits necessary to represent @var{n}.\n"
5026 "(integer-length #b10101010)\n"
5028 "(integer-length 0)\n"
5030 "(integer-length #b1111)\n"
5033 #define FUNC_NAME s_scm_integer_length
5035 if (SCM_I_INUMP (n
))
5037 unsigned long c
= 0;
5039 scm_t_inum nn
= SCM_I_INUM (n
);
5045 l
= scm_ilentab
[15 & nn
];
5048 return SCM_I_MAKINUM (c
- 4 + l
);
5050 else if (SCM_BIGP (n
))
5052 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5053 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5054 1 too big, so check for that and adjust. */
5055 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5056 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5057 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5058 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5060 scm_remember_upto_here_1 (n
);
5061 return SCM_I_MAKINUM (size
);
5064 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5068 /*** NUMBERS -> STRINGS ***/
5069 #define SCM_MAX_DBL_PREC 60
5070 #define SCM_MAX_DBL_RADIX 36
5072 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5073 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5074 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5077 void init_dblprec(int *prec
, int radix
) {
5078 /* determine floating point precision by adding successively
5079 smaller increments to 1.0 until it is considered == 1.0 */
5080 double f
= ((double)1.0)/radix
;
5081 double fsum
= 1.0 + f
;
5086 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5098 void init_fx_radix(double *fx_list
, int radix
)
5100 /* initialize a per-radix list of tolerances. When added
5101 to a number < 1.0, we can determine if we should raund
5102 up and quit converting a number to a string. */
5106 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5107 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5110 /* use this array as a way to generate a single digit */
5111 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5114 idbl2str (double f
, char *a
, int radix
)
5116 int efmt
, dpt
, d
, i
, wp
;
5118 #ifdef DBL_MIN_10_EXP
5121 #endif /* DBL_MIN_10_EXP */
5126 radix
> SCM_MAX_DBL_RADIX
)
5128 /* revert to existing behavior */
5132 wp
= scm_dblprec
[radix
-2];
5133 fx
= fx_per_radix
[radix
-2];
5137 #ifdef HAVE_COPYSIGN
5138 double sgn
= copysign (1.0, f
);
5143 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5149 strcpy (a
, "-inf.0");
5151 strcpy (a
, "+inf.0");
5156 strcpy (a
, "+nan.0");
5166 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5167 make-uniform-vector, from causing infinite loops. */
5168 /* just do the checking...if it passes, we do the conversion for our
5169 radix again below */
5176 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5184 while (f_cpy
> 10.0)
5187 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5208 if (f
+ fx
[wp
] >= radix
)
5215 /* adding 9999 makes this equivalent to abs(x) % 3 */
5216 dpt
= (exp
+ 9999) % 3;
5220 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5242 a
[ch
++] = number_chars
[d
];
5245 if (f
+ fx
[wp
] >= 1.0)
5247 a
[ch
- 1] = number_chars
[d
+1];
5259 if ((dpt
> 4) && (exp
> 6))
5261 d
= (a
[0] == '-' ? 2 : 1);
5262 for (i
= ch
++; i
> d
; i
--)
5275 if (a
[ch
- 1] == '.')
5276 a
[ch
++] = '0'; /* trailing zero */
5285 for (i
= radix
; i
<= exp
; i
*= radix
);
5286 for (i
/= radix
; i
; i
/= radix
)
5288 a
[ch
++] = number_chars
[exp
/ i
];
5297 icmplx2str (double real
, double imag
, char *str
, int radix
)
5302 i
= idbl2str (real
, str
, radix
);
5303 #ifdef HAVE_COPYSIGN
5304 sgn
= copysign (1.0, imag
);
5308 /* Don't output a '+' for negative numbers or for Inf and
5309 NaN. They will provide their own sign. */
5310 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5312 i
+= idbl2str (imag
, &str
[i
], radix
);
5318 iflo2str (SCM flt
, char *str
, int radix
)
5321 if (SCM_REALP (flt
))
5322 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5324 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5329 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5330 characters in the result.
5332 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5334 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5339 return scm_iuint2str (-num
, rad
, p
) + 1;
5342 return scm_iuint2str (num
, rad
, p
);
5345 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5346 characters in the result.
5348 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5350 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5354 scm_t_uintmax n
= num
;
5356 if (rad
< 2 || rad
> 36)
5357 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5359 for (n
/= rad
; n
> 0; n
/= rad
)
5369 p
[i
] = number_chars
[d
];
5374 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5376 "Return a string holding the external representation of the\n"
5377 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5378 "inexact, a radix of 10 will be used.")
5379 #define FUNC_NAME s_scm_number_to_string
5383 if (SCM_UNBNDP (radix
))
5386 base
= scm_to_signed_integer (radix
, 2, 36);
5388 if (SCM_I_INUMP (n
))
5390 char num_buf
[SCM_INTBUFLEN
];
5391 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5392 return scm_from_locale_stringn (num_buf
, length
);
5394 else if (SCM_BIGP (n
))
5396 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5397 size_t len
= strlen (str
);
5398 void (*freefunc
) (void *, size_t);
5400 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5401 scm_remember_upto_here_1 (n
);
5402 ret
= scm_from_latin1_stringn (str
, len
);
5403 freefunc (str
, len
+ 1);
5406 else if (SCM_FRACTIONP (n
))
5408 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5409 scm_from_locale_string ("/"),
5410 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5412 else if (SCM_INEXACTP (n
))
5414 char num_buf
[FLOBUFLEN
];
5415 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5418 SCM_WRONG_TYPE_ARG (1, n
);
5423 /* These print routines used to be stubbed here so that scm_repl.c
5424 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5427 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5429 char num_buf
[FLOBUFLEN
];
5430 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5435 scm_i_print_double (double val
, SCM port
)
5437 char num_buf
[FLOBUFLEN
];
5438 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5442 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5445 char num_buf
[FLOBUFLEN
];
5446 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5451 scm_i_print_complex (double real
, double imag
, SCM port
)
5453 char num_buf
[FLOBUFLEN
];
5454 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5458 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5461 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5462 scm_display (str
, port
);
5463 scm_remember_upto_here_1 (str
);
5468 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5470 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5471 size_t len
= strlen (str
);
5472 void (*freefunc
) (void *, size_t);
5473 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5474 scm_remember_upto_here_1 (exp
);
5475 scm_lfwrite (str
, len
, port
);
5476 freefunc (str
, len
+ 1);
5479 /*** END nums->strs ***/
5482 /*** STRINGS -> NUMBERS ***/
5484 /* The following functions implement the conversion from strings to numbers.
5485 * The implementation somehow follows the grammar for numbers as it is given
5486 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5487 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5488 * points should be noted about the implementation:
5490 * * Each function keeps a local index variable 'idx' that points at the
5491 * current position within the parsed string. The global index is only
5492 * updated if the function could parse the corresponding syntactic unit
5495 * * Similarly, the functions keep track of indicators of inexactness ('#',
5496 * '.' or exponents) using local variables ('hash_seen', 'x').
5498 * * Sequences of digits are parsed into temporary variables holding fixnums.
5499 * Only if these fixnums would overflow, the result variables are updated
5500 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5501 * the temporary variables holding the fixnums are cleared, and the process
5502 * starts over again. If for example fixnums were able to store five decimal
5503 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5504 * and the result was computed as 12345 * 100000 + 67890. In other words,
5505 * only every five digits two bignum operations were performed.
5507 * Notes on the handling of exactness specifiers:
5509 * When parsing non-real complex numbers, we apply exactness specifiers on
5510 * per-component basis, as is done in PLT Scheme. For complex numbers
5511 * written in rectangular form, exactness specifiers are applied to the
5512 * real and imaginary parts before calling scm_make_rectangular. For
5513 * complex numbers written in polar form, exactness specifiers are applied
5514 * to the magnitude and angle before calling scm_make_polar.
5516 * There are two kinds of exactness specifiers: forced and implicit. A
5517 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5518 * the entire number, and applies to both components of a complex number.
5519 * "#e" causes each component to be made exact, and "#i" causes each
5520 * component to be made inexact. If no forced exactness specifier is
5521 * present, then the exactness of each component is determined
5522 * independently by the presence or absence of a decimal point or hash mark
5523 * within that component. If a decimal point or hash mark is present, the
5524 * component is made inexact, otherwise it is made exact.
5526 * After the exactness specifiers have been applied to each component, they
5527 * are passed to either scm_make_rectangular or scm_make_polar to produce
5528 * the final result. Note that this will result in a real number if the
5529 * imaginary part, magnitude, or angle is an exact 0.
5531 * For example, (string->number "#i5.0+0i") does the equivalent of:
5533 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5536 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5538 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5540 /* Caller is responsible for checking that the return value is in range
5541 for the given radix, which should be <= 36. */
5543 char_decimal_value (scm_t_uint32 c
)
5545 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5546 that's certainly above any valid decimal, so we take advantage of
5547 that to elide some tests. */
5548 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5550 /* If that failed, try extended hexadecimals, then. Only accept ascii
5555 if (c
>= (scm_t_uint32
) 'a')
5556 d
= c
- (scm_t_uint32
)'a' + 10U;
5561 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5562 in base RADIX. Upon success, return the unsigned integer and update
5563 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5565 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5566 unsigned int radix
, enum t_exactness
*p_exactness
)
5568 unsigned int idx
= *p_idx
;
5569 unsigned int hash_seen
= 0;
5570 scm_t_bits shift
= 1;
5572 unsigned int digit_value
;
5575 size_t len
= scm_i_string_length (mem
);
5580 c
= scm_i_string_ref (mem
, idx
);
5581 digit_value
= char_decimal_value (c
);
5582 if (digit_value
>= radix
)
5586 result
= SCM_I_MAKINUM (digit_value
);
5589 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5599 digit_value
= char_decimal_value (c
);
5600 /* This check catches non-decimals in addition to out-of-range
5602 if (digit_value
>= radix
)
5607 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5609 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5611 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5618 shift
= shift
* radix
;
5619 add
= add
* radix
+ digit_value
;
5624 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5626 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5630 *p_exactness
= INEXACT
;
5636 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5637 * covers the parts of the rules that start at a potential point. The value
5638 * of the digits up to the point have been parsed by the caller and are given
5639 * in variable result. The content of *p_exactness indicates, whether a hash
5640 * has already been seen in the digits before the point.
5643 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5646 mem2decimal_from_point (SCM result
, SCM mem
,
5647 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5649 unsigned int idx
= *p_idx
;
5650 enum t_exactness x
= *p_exactness
;
5651 size_t len
= scm_i_string_length (mem
);
5656 if (scm_i_string_ref (mem
, idx
) == '.')
5658 scm_t_bits shift
= 1;
5660 unsigned int digit_value
;
5661 SCM big_shift
= SCM_INUM1
;
5666 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5667 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5672 digit_value
= DIGIT2UINT (c
);
5683 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5685 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5686 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5688 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5696 add
= add
* 10 + digit_value
;
5702 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5703 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5704 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5707 result
= scm_divide (result
, big_shift
);
5709 /* We've seen a decimal point, thus the value is implicitly inexact. */
5721 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5723 switch (scm_i_string_ref (mem
, idx
))
5735 c
= scm_i_string_ref (mem
, idx
);
5743 c
= scm_i_string_ref (mem
, idx
);
5752 c
= scm_i_string_ref (mem
, idx
);
5757 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5761 exponent
= DIGIT2UINT (c
);
5764 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5765 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5768 if (exponent
<= SCM_MAXEXP
)
5769 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5775 if (exponent
> SCM_MAXEXP
)
5777 size_t exp_len
= idx
- start
;
5778 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5779 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5780 scm_out_of_range ("string->number", exp_num
);
5783 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5785 result
= scm_product (result
, e
);
5787 result
= scm_divide (result
, e
);
5789 /* We've seen an exponent, thus the value is implicitly inexact. */
5807 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5810 mem2ureal (SCM mem
, unsigned int *p_idx
,
5811 unsigned int radix
, enum t_exactness forced_x
,
5812 int allow_inf_or_nan
)
5814 unsigned int idx
= *p_idx
;
5816 size_t len
= scm_i_string_length (mem
);
5818 /* Start off believing that the number will be exact. This changes
5819 to INEXACT if we see a decimal point or a hash. */
5820 enum t_exactness implicit_x
= EXACT
;
5825 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
5826 switch (scm_i_string_ref (mem
, idx
))
5829 switch (scm_i_string_ref (mem
, idx
+ 1))
5832 switch (scm_i_string_ref (mem
, idx
+ 2))
5835 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
5836 && scm_i_string_ref (mem
, idx
+ 4) == '0')
5844 switch (scm_i_string_ref (mem
, idx
+ 1))
5847 switch (scm_i_string_ref (mem
, idx
+ 2))
5850 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
5852 /* Cobble up the fractional part. We might want to
5853 set the NaN's mantissa from it. */
5855 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
5858 #if SCM_ENABLE_DEPRECATED == 1
5859 scm_c_issue_deprecation_warning
5860 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5873 if (scm_i_string_ref (mem
, idx
) == '.')
5877 else if (idx
+ 1 == len
)
5879 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5882 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5883 p_idx
, &implicit_x
);
5889 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5890 if (scm_is_false (uinteger
))
5895 else if (scm_i_string_ref (mem
, idx
) == '/')
5903 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5904 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
5907 /* both are int/big here, I assume */
5908 result
= scm_i_make_ratio (uinteger
, divisor
);
5910 else if (radix
== 10)
5912 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5913 if (scm_is_false (result
))
5925 if (SCM_INEXACTP (result
))
5926 return scm_inexact_to_exact (result
);
5930 if (SCM_INEXACTP (result
))
5933 return scm_exact_to_inexact (result
);
5935 if (implicit_x
== INEXACT
)
5937 if (SCM_INEXACTP (result
))
5940 return scm_exact_to_inexact (result
);
5946 /* We should never get here */
5947 scm_syserror ("mem2ureal");
5951 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5954 mem2complex (SCM mem
, unsigned int idx
,
5955 unsigned int radix
, enum t_exactness forced_x
)
5960 size_t len
= scm_i_string_length (mem
);
5965 c
= scm_i_string_ref (mem
, idx
);
5980 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
5981 if (scm_is_false (ureal
))
5983 /* input must be either +i or -i */
5988 if (scm_i_string_ref (mem
, idx
) == 'i'
5989 || scm_i_string_ref (mem
, idx
) == 'I')
5995 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6002 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6003 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6008 c
= scm_i_string_ref (mem
, idx
);
6012 /* either +<ureal>i or -<ureal>i */
6019 return scm_make_rectangular (SCM_INUM0
, ureal
);
6022 /* polar input: <real>@<real>. */
6033 c
= scm_i_string_ref (mem
, idx
);
6051 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6052 if (scm_is_false (angle
))
6057 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6058 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6060 result
= scm_make_polar (ureal
, angle
);
6065 /* expecting input matching <real>[+-]<ureal>?i */
6072 int sign
= (c
== '+') ? 1 : -1;
6073 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6075 if (scm_is_false (imag
))
6076 imag
= SCM_I_MAKINUM (sign
);
6077 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6078 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6082 if (scm_i_string_ref (mem
, idx
) != 'i'
6083 && scm_i_string_ref (mem
, idx
) != 'I')
6090 return scm_make_rectangular (ureal
, imag
);
6099 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6101 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6104 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6106 unsigned int idx
= 0;
6107 unsigned int radix
= NO_RADIX
;
6108 enum t_exactness forced_x
= NO_EXACTNESS
;
6109 size_t len
= scm_i_string_length (mem
);
6111 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6112 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6114 switch (scm_i_string_ref (mem
, idx
+ 1))
6117 if (radix
!= NO_RADIX
)
6122 if (radix
!= NO_RADIX
)
6127 if (forced_x
!= NO_EXACTNESS
)
6132 if (forced_x
!= NO_EXACTNESS
)
6137 if (radix
!= NO_RADIX
)
6142 if (radix
!= NO_RADIX
)
6152 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6153 if (radix
== NO_RADIX
)
6154 radix
= default_radix
;
6156 return mem2complex (mem
, idx
, radix
, forced_x
);
6160 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6161 unsigned int default_radix
)
6163 SCM str
= scm_from_locale_stringn (mem
, len
);
6165 return scm_i_string_to_number (str
, default_radix
);
6169 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6170 (SCM string
, SCM radix
),
6171 "Return a number of the maximally precise representation\n"
6172 "expressed by the given @var{string}. @var{radix} must be an\n"
6173 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6174 "is a default radix that may be overridden by an explicit radix\n"
6175 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6176 "supplied, then the default radix is 10. If string is not a\n"
6177 "syntactically valid notation for a number, then\n"
6178 "@code{string->number} returns @code{#f}.")
6179 #define FUNC_NAME s_scm_string_to_number
6183 SCM_VALIDATE_STRING (1, string
);
6185 if (SCM_UNBNDP (radix
))
6188 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6190 answer
= scm_i_string_to_number (string
, base
);
6191 scm_remember_upto_here_1 (string
);
6197 /*** END strs->nums ***/
6200 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6202 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6204 #define FUNC_NAME s_scm_number_p
6206 return scm_from_bool (SCM_NUMBERP (x
));
6210 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6212 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6213 "otherwise. Note that the sets of real, rational and integer\n"
6214 "values form subsets of the set of complex numbers, i. e. the\n"
6215 "predicate will also be fulfilled if @var{x} is a real,\n"
6216 "rational or integer number.")
6217 #define FUNC_NAME s_scm_complex_p
6219 /* all numbers are complex. */
6220 return scm_number_p (x
);
6224 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6226 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6227 "otherwise. Note that the set of integer values forms a subset of\n"
6228 "the set of real numbers, i. e. the predicate will also be\n"
6229 "fulfilled if @var{x} is an integer number.")
6230 #define FUNC_NAME s_scm_real_p
6232 return scm_from_bool
6233 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6237 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6239 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6240 "otherwise. Note that the set of integer values forms a subset of\n"
6241 "the set of rational numbers, i. e. the predicate will also be\n"
6242 "fulfilled if @var{x} is an integer number.")
6243 #define FUNC_NAME s_scm_rational_p
6245 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6247 else if (SCM_REALP (x
))
6248 /* due to their limited precision, finite floating point numbers are
6249 rational as well. (finite means neither infinity nor a NaN) */
6250 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6256 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6258 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6260 #define FUNC_NAME s_scm_integer_p
6262 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6264 else if (SCM_REALP (x
))
6266 double val
= SCM_REAL_VALUE (x
);
6267 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6275 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6276 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6277 (SCM x
, SCM y
, SCM rest
),
6278 "Return @code{#t} if all parameters are numerically equal.")
6279 #define FUNC_NAME s_scm_i_num_eq_p
6281 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6283 while (!scm_is_null (rest
))
6285 if (scm_is_false (scm_num_eq_p (x
, y
)))
6289 rest
= scm_cdr (rest
);
6291 return scm_num_eq_p (x
, y
);
6295 scm_num_eq_p (SCM x
, SCM y
)
6298 if (SCM_I_INUMP (x
))
6300 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6301 if (SCM_I_INUMP (y
))
6303 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6304 return scm_from_bool (xx
== yy
);
6306 else if (SCM_BIGP (y
))
6308 else if (SCM_REALP (y
))
6310 /* On a 32-bit system an inum fits a double, we can cast the inum
6311 to a double and compare.
6313 But on a 64-bit system an inum is bigger than a double and
6314 casting it to a double (call that dxx) will round. dxx is at
6315 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6316 an integer and fits a long. So we cast yy to a long and
6317 compare with plain xx.
6319 An alternative (for any size system actually) would be to check
6320 yy is an integer (with floor) and is in range of an inum
6321 (compare against appropriate powers of 2) then test
6322 xx==(scm_t_signed_bits)yy. It's just a matter of which
6323 casts/comparisons might be fastest or easiest for the cpu. */
6325 double yy
= SCM_REAL_VALUE (y
);
6326 return scm_from_bool ((double) xx
== yy
6327 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6328 || xx
== (scm_t_signed_bits
) yy
));
6330 else if (SCM_COMPLEXP (y
))
6331 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6332 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6333 else if (SCM_FRACTIONP (y
))
6336 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6338 else if (SCM_BIGP (x
))
6340 if (SCM_I_INUMP (y
))
6342 else if (SCM_BIGP (y
))
6344 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6345 scm_remember_upto_here_2 (x
, y
);
6346 return scm_from_bool (0 == cmp
);
6348 else if (SCM_REALP (y
))
6351 if (isnan (SCM_REAL_VALUE (y
)))
6353 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6354 scm_remember_upto_here_1 (x
);
6355 return scm_from_bool (0 == cmp
);
6357 else if (SCM_COMPLEXP (y
))
6360 if (0.0 != SCM_COMPLEX_IMAG (y
))
6362 if (isnan (SCM_COMPLEX_REAL (y
)))
6364 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6365 scm_remember_upto_here_1 (x
);
6366 return scm_from_bool (0 == cmp
);
6368 else if (SCM_FRACTIONP (y
))
6371 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6373 else if (SCM_REALP (x
))
6375 double xx
= SCM_REAL_VALUE (x
);
6376 if (SCM_I_INUMP (y
))
6378 /* see comments with inum/real above */
6379 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6380 return scm_from_bool (xx
== (double) yy
6381 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6382 || (scm_t_signed_bits
) xx
== yy
));
6384 else if (SCM_BIGP (y
))
6387 if (isnan (SCM_REAL_VALUE (x
)))
6389 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6390 scm_remember_upto_here_1 (y
);
6391 return scm_from_bool (0 == cmp
);
6393 else if (SCM_REALP (y
))
6394 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6395 else if (SCM_COMPLEXP (y
))
6396 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6397 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6398 else if (SCM_FRACTIONP (y
))
6400 double xx
= SCM_REAL_VALUE (x
);
6404 return scm_from_bool (xx
< 0.0);
6405 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6409 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6411 else if (SCM_COMPLEXP (x
))
6413 if (SCM_I_INUMP (y
))
6414 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6415 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6416 else if (SCM_BIGP (y
))
6419 if (0.0 != SCM_COMPLEX_IMAG (x
))
6421 if (isnan (SCM_COMPLEX_REAL (x
)))
6423 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6424 scm_remember_upto_here_1 (y
);
6425 return scm_from_bool (0 == cmp
);
6427 else if (SCM_REALP (y
))
6428 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6429 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6430 else if (SCM_COMPLEXP (y
))
6431 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6432 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6433 else if (SCM_FRACTIONP (y
))
6436 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6438 xx
= SCM_COMPLEX_REAL (x
);
6442 return scm_from_bool (xx
< 0.0);
6443 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6447 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6449 else if (SCM_FRACTIONP (x
))
6451 if (SCM_I_INUMP (y
))
6453 else if (SCM_BIGP (y
))
6455 else if (SCM_REALP (y
))
6457 double yy
= SCM_REAL_VALUE (y
);
6461 return scm_from_bool (0.0 < yy
);
6462 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6465 else if (SCM_COMPLEXP (y
))
6468 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6470 yy
= SCM_COMPLEX_REAL (y
);
6474 return scm_from_bool (0.0 < yy
);
6475 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6478 else if (SCM_FRACTIONP (y
))
6479 return scm_i_fraction_equalp (x
, y
);
6481 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6484 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6488 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6489 done are good for inums, but for bignums an answer can almost always be
6490 had by just examining a few high bits of the operands, as done by GMP in
6491 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6492 of the float exponent to take into account. */
6494 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6495 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6496 (SCM x
, SCM y
, SCM rest
),
6497 "Return @code{#t} if the list of parameters is monotonically\n"
6499 #define FUNC_NAME s_scm_i_num_less_p
6501 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6503 while (!scm_is_null (rest
))
6505 if (scm_is_false (scm_less_p (x
, y
)))
6509 rest
= scm_cdr (rest
);
6511 return scm_less_p (x
, y
);
6515 scm_less_p (SCM x
, SCM y
)
6518 if (SCM_I_INUMP (x
))
6520 scm_t_inum xx
= SCM_I_INUM (x
);
6521 if (SCM_I_INUMP (y
))
6523 scm_t_inum yy
= SCM_I_INUM (y
);
6524 return scm_from_bool (xx
< yy
);
6526 else if (SCM_BIGP (y
))
6528 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6529 scm_remember_upto_here_1 (y
);
6530 return scm_from_bool (sgn
> 0);
6532 else if (SCM_REALP (y
))
6533 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6534 else if (SCM_FRACTIONP (y
))
6536 /* "x < a/b" becomes "x*b < a" */
6538 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6539 y
= SCM_FRACTION_NUMERATOR (y
);
6543 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6545 else if (SCM_BIGP (x
))
6547 if (SCM_I_INUMP (y
))
6549 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6550 scm_remember_upto_here_1 (x
);
6551 return scm_from_bool (sgn
< 0);
6553 else if (SCM_BIGP (y
))
6555 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6556 scm_remember_upto_here_2 (x
, y
);
6557 return scm_from_bool (cmp
< 0);
6559 else if (SCM_REALP (y
))
6562 if (isnan (SCM_REAL_VALUE (y
)))
6564 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6565 scm_remember_upto_here_1 (x
);
6566 return scm_from_bool (cmp
< 0);
6568 else if (SCM_FRACTIONP (y
))
6571 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6573 else if (SCM_REALP (x
))
6575 if (SCM_I_INUMP (y
))
6576 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6577 else if (SCM_BIGP (y
))
6580 if (isnan (SCM_REAL_VALUE (x
)))
6582 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6583 scm_remember_upto_here_1 (y
);
6584 return scm_from_bool (cmp
> 0);
6586 else if (SCM_REALP (y
))
6587 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6588 else if (SCM_FRACTIONP (y
))
6590 double xx
= SCM_REAL_VALUE (x
);
6594 return scm_from_bool (xx
< 0.0);
6595 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6599 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6601 else if (SCM_FRACTIONP (x
))
6603 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6605 /* "a/b < y" becomes "a < y*b" */
6606 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6607 x
= SCM_FRACTION_NUMERATOR (x
);
6610 else if (SCM_REALP (y
))
6612 double yy
= SCM_REAL_VALUE (y
);
6616 return scm_from_bool (0.0 < yy
);
6617 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6620 else if (SCM_FRACTIONP (y
))
6622 /* "a/b < c/d" becomes "a*d < c*b" */
6623 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6624 SCM_FRACTION_DENOMINATOR (y
));
6625 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6626 SCM_FRACTION_DENOMINATOR (x
));
6632 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6635 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6639 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6640 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6641 (SCM x
, SCM y
, SCM rest
),
6642 "Return @code{#t} if the list of parameters is monotonically\n"
6644 #define FUNC_NAME s_scm_i_num_gr_p
6646 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6648 while (!scm_is_null (rest
))
6650 if (scm_is_false (scm_gr_p (x
, y
)))
6654 rest
= scm_cdr (rest
);
6656 return scm_gr_p (x
, y
);
6659 #define FUNC_NAME s_scm_i_num_gr_p
6661 scm_gr_p (SCM x
, SCM y
)
6663 if (!SCM_NUMBERP (x
))
6664 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6665 else if (!SCM_NUMBERP (y
))
6666 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6668 return scm_less_p (y
, x
);
6673 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6674 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6675 (SCM x
, SCM y
, SCM rest
),
6676 "Return @code{#t} if the list of parameters is monotonically\n"
6678 #define FUNC_NAME s_scm_i_num_leq_p
6680 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6682 while (!scm_is_null (rest
))
6684 if (scm_is_false (scm_leq_p (x
, y
)))
6688 rest
= scm_cdr (rest
);
6690 return scm_leq_p (x
, y
);
6693 #define FUNC_NAME s_scm_i_num_leq_p
6695 scm_leq_p (SCM x
, SCM y
)
6697 if (!SCM_NUMBERP (x
))
6698 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6699 else if (!SCM_NUMBERP (y
))
6700 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6701 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6704 return scm_not (scm_less_p (y
, x
));
6709 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6710 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6711 (SCM x
, SCM y
, SCM rest
),
6712 "Return @code{#t} if the list of parameters is monotonically\n"
6714 #define FUNC_NAME s_scm_i_num_geq_p
6716 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6718 while (!scm_is_null (rest
))
6720 if (scm_is_false (scm_geq_p (x
, y
)))
6724 rest
= scm_cdr (rest
);
6726 return scm_geq_p (x
, y
);
6729 #define FUNC_NAME s_scm_i_num_geq_p
6731 scm_geq_p (SCM x
, SCM y
)
6733 if (!SCM_NUMBERP (x
))
6734 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6735 else if (!SCM_NUMBERP (y
))
6736 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6737 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6740 return scm_not (scm_less_p (x
, y
));
6745 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6747 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6749 #define FUNC_NAME s_scm_zero_p
6751 if (SCM_I_INUMP (z
))
6752 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6753 else if (SCM_BIGP (z
))
6755 else if (SCM_REALP (z
))
6756 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6757 else if (SCM_COMPLEXP (z
))
6758 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6759 && SCM_COMPLEX_IMAG (z
) == 0.0);
6760 else if (SCM_FRACTIONP (z
))
6763 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6768 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6770 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6772 #define FUNC_NAME s_scm_positive_p
6774 if (SCM_I_INUMP (x
))
6775 return scm_from_bool (SCM_I_INUM (x
) > 0);
6776 else if (SCM_BIGP (x
))
6778 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6779 scm_remember_upto_here_1 (x
);
6780 return scm_from_bool (sgn
> 0);
6782 else if (SCM_REALP (x
))
6783 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6784 else if (SCM_FRACTIONP (x
))
6785 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6787 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6792 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6794 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6796 #define FUNC_NAME s_scm_negative_p
6798 if (SCM_I_INUMP (x
))
6799 return scm_from_bool (SCM_I_INUM (x
) < 0);
6800 else if (SCM_BIGP (x
))
6802 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6803 scm_remember_upto_here_1 (x
);
6804 return scm_from_bool (sgn
< 0);
6806 else if (SCM_REALP (x
))
6807 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6808 else if (SCM_FRACTIONP (x
))
6809 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6811 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6816 /* scm_min and scm_max return an inexact when either argument is inexact, as
6817 required by r5rs. On that basis, for exact/inexact combinations the
6818 exact is converted to inexact to compare and possibly return. This is
6819 unlike scm_less_p above which takes some trouble to preserve all bits in
6820 its test, such trouble is not required for min and max. */
6822 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6823 (SCM x
, SCM y
, SCM rest
),
6824 "Return the maximum of all parameter values.")
6825 #define FUNC_NAME s_scm_i_max
6827 while (!scm_is_null (rest
))
6828 { x
= scm_max (x
, y
);
6830 rest
= scm_cdr (rest
);
6832 return scm_max (x
, y
);
6836 #define s_max s_scm_i_max
6837 #define g_max g_scm_i_max
6840 scm_max (SCM x
, SCM y
)
6845 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6846 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6849 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6852 if (SCM_I_INUMP (x
))
6854 scm_t_inum xx
= SCM_I_INUM (x
);
6855 if (SCM_I_INUMP (y
))
6857 scm_t_inum yy
= SCM_I_INUM (y
);
6858 return (xx
< yy
) ? y
: x
;
6860 else if (SCM_BIGP (y
))
6862 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6863 scm_remember_upto_here_1 (y
);
6864 return (sgn
< 0) ? x
: y
;
6866 else if (SCM_REALP (y
))
6869 double yyd
= SCM_REAL_VALUE (y
);
6872 return scm_from_double (xxd
);
6873 /* If y is a NaN, then "==" is false and we return the NaN */
6874 else if (SCM_LIKELY (!(xxd
== yyd
)))
6876 /* Handle signed zeroes properly */
6882 else if (SCM_FRACTIONP (y
))
6885 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6888 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6890 else if (SCM_BIGP (x
))
6892 if (SCM_I_INUMP (y
))
6894 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6895 scm_remember_upto_here_1 (x
);
6896 return (sgn
< 0) ? y
: x
;
6898 else if (SCM_BIGP (y
))
6900 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6901 scm_remember_upto_here_2 (x
, y
);
6902 return (cmp
> 0) ? x
: y
;
6904 else if (SCM_REALP (y
))
6906 /* if y==NaN then xx>yy is false, so we return the NaN y */
6909 xx
= scm_i_big2dbl (x
);
6910 yy
= SCM_REAL_VALUE (y
);
6911 return (xx
> yy
? scm_from_double (xx
) : y
);
6913 else if (SCM_FRACTIONP (y
))
6918 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6920 else if (SCM_REALP (x
))
6922 if (SCM_I_INUMP (y
))
6924 scm_t_inum yy
= SCM_I_INUM (y
);
6925 double xxd
= SCM_REAL_VALUE (x
);
6929 return scm_from_double (yyd
);
6930 /* If x is a NaN, then "==" is false and we return the NaN */
6931 else if (SCM_LIKELY (!(xxd
== yyd
)))
6933 /* Handle signed zeroes properly */
6939 else if (SCM_BIGP (y
))
6944 else if (SCM_REALP (y
))
6946 double xx
= SCM_REAL_VALUE (x
);
6947 double yy
= SCM_REAL_VALUE (y
);
6949 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6952 else if (SCM_LIKELY (xx
< yy
))
6954 /* If neither (xx > yy) nor (xx < yy), then
6955 either they're equal or one is a NaN */
6956 else if (SCM_UNLIKELY (isnan (xx
)))
6957 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6958 else if (SCM_UNLIKELY (isnan (yy
)))
6959 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6960 /* xx == yy, but handle signed zeroes properly */
6961 else if (double_is_non_negative_zero (yy
))
6966 else if (SCM_FRACTIONP (y
))
6968 double yy
= scm_i_fraction2double (y
);
6969 double xx
= SCM_REAL_VALUE (x
);
6970 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6973 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6975 else if (SCM_FRACTIONP (x
))
6977 if (SCM_I_INUMP (y
))
6981 else if (SCM_BIGP (y
))
6985 else if (SCM_REALP (y
))
6987 double xx
= scm_i_fraction2double (x
);
6988 /* if y==NaN then ">" is false, so we return the NaN y */
6989 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6991 else if (SCM_FRACTIONP (y
))
6996 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6999 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7003 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7004 (SCM x
, SCM y
, SCM rest
),
7005 "Return the minimum of all parameter values.")
7006 #define FUNC_NAME s_scm_i_min
7008 while (!scm_is_null (rest
))
7009 { x
= scm_min (x
, y
);
7011 rest
= scm_cdr (rest
);
7013 return scm_min (x
, y
);
7017 #define s_min s_scm_i_min
7018 #define g_min g_scm_i_min
7021 scm_min (SCM x
, SCM y
)
7026 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7027 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7030 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7033 if (SCM_I_INUMP (x
))
7035 scm_t_inum xx
= SCM_I_INUM (x
);
7036 if (SCM_I_INUMP (y
))
7038 scm_t_inum yy
= SCM_I_INUM (y
);
7039 return (xx
< yy
) ? x
: y
;
7041 else if (SCM_BIGP (y
))
7043 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7044 scm_remember_upto_here_1 (y
);
7045 return (sgn
< 0) ? y
: x
;
7047 else if (SCM_REALP (y
))
7050 /* if y==NaN then "<" is false and we return NaN */
7051 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7053 else if (SCM_FRACTIONP (y
))
7056 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7059 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7061 else if (SCM_BIGP (x
))
7063 if (SCM_I_INUMP (y
))
7065 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7066 scm_remember_upto_here_1 (x
);
7067 return (sgn
< 0) ? x
: y
;
7069 else if (SCM_BIGP (y
))
7071 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7072 scm_remember_upto_here_2 (x
, y
);
7073 return (cmp
> 0) ? y
: x
;
7075 else if (SCM_REALP (y
))
7077 /* if y==NaN then xx<yy is false, so we return the NaN y */
7080 xx
= scm_i_big2dbl (x
);
7081 yy
= SCM_REAL_VALUE (y
);
7082 return (xx
< yy
? scm_from_double (xx
) : y
);
7084 else if (SCM_FRACTIONP (y
))
7089 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7091 else if (SCM_REALP (x
))
7093 if (SCM_I_INUMP (y
))
7095 double z
= SCM_I_INUM (y
);
7096 /* if x==NaN then "<" is false and we return NaN */
7097 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7099 else if (SCM_BIGP (y
))
7104 else if (SCM_REALP (y
))
7106 double xx
= SCM_REAL_VALUE (x
);
7107 double yy
= SCM_REAL_VALUE (y
);
7109 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7112 else if (SCM_LIKELY (xx
> yy
))
7114 /* If neither (xx < yy) nor (xx > yy), then
7115 either they're equal or one is a NaN */
7116 else if (SCM_UNLIKELY (isnan (xx
)))
7117 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7118 else if (SCM_UNLIKELY (isnan (yy
)))
7119 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7120 /* xx == yy, but handle signed zeroes properly */
7121 else if (double_is_non_negative_zero (xx
))
7126 else if (SCM_FRACTIONP (y
))
7128 double yy
= scm_i_fraction2double (y
);
7129 double xx
= SCM_REAL_VALUE (x
);
7130 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7133 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7135 else if (SCM_FRACTIONP (x
))
7137 if (SCM_I_INUMP (y
))
7141 else if (SCM_BIGP (y
))
7145 else if (SCM_REALP (y
))
7147 double xx
= scm_i_fraction2double (x
);
7148 /* if y==NaN then "<" is false, so we return the NaN y */
7149 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7151 else if (SCM_FRACTIONP (y
))
7156 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7159 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7163 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7164 (SCM x
, SCM y
, SCM rest
),
7165 "Return the sum of all parameter values. Return 0 if called without\n"
7167 #define FUNC_NAME s_scm_i_sum
7169 while (!scm_is_null (rest
))
7170 { x
= scm_sum (x
, y
);
7172 rest
= scm_cdr (rest
);
7174 return scm_sum (x
, y
);
7178 #define s_sum s_scm_i_sum
7179 #define g_sum g_scm_i_sum
7182 scm_sum (SCM x
, SCM y
)
7184 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7186 if (SCM_NUMBERP (x
)) return x
;
7187 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7188 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7191 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7193 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7195 scm_t_inum xx
= SCM_I_INUM (x
);
7196 scm_t_inum yy
= SCM_I_INUM (y
);
7197 scm_t_inum z
= xx
+ yy
;
7198 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7200 else if (SCM_BIGP (y
))
7205 else if (SCM_REALP (y
))
7207 scm_t_inum xx
= SCM_I_INUM (x
);
7208 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7210 else if (SCM_COMPLEXP (y
))
7212 scm_t_inum xx
= SCM_I_INUM (x
);
7213 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7214 SCM_COMPLEX_IMAG (y
));
7216 else if (SCM_FRACTIONP (y
))
7217 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7218 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7219 SCM_FRACTION_DENOMINATOR (y
));
7221 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7222 } else if (SCM_BIGP (x
))
7224 if (SCM_I_INUMP (y
))
7229 inum
= SCM_I_INUM (y
);
7232 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7235 SCM result
= scm_i_mkbig ();
7236 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7237 scm_remember_upto_here_1 (x
);
7238 /* we know the result will have to be a bignum */
7241 return scm_i_normbig (result
);
7245 SCM result
= scm_i_mkbig ();
7246 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7247 scm_remember_upto_here_1 (x
);
7248 /* we know the result will have to be a bignum */
7251 return scm_i_normbig (result
);
7254 else if (SCM_BIGP (y
))
7256 SCM result
= scm_i_mkbig ();
7257 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7258 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7259 mpz_add (SCM_I_BIG_MPZ (result
),
7262 scm_remember_upto_here_2 (x
, y
);
7263 /* we know the result will have to be a bignum */
7266 return scm_i_normbig (result
);
7268 else if (SCM_REALP (y
))
7270 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7271 scm_remember_upto_here_1 (x
);
7272 return scm_from_double (result
);
7274 else if (SCM_COMPLEXP (y
))
7276 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7277 + SCM_COMPLEX_REAL (y
));
7278 scm_remember_upto_here_1 (x
);
7279 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7281 else if (SCM_FRACTIONP (y
))
7282 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7283 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7284 SCM_FRACTION_DENOMINATOR (y
));
7286 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7288 else if (SCM_REALP (x
))
7290 if (SCM_I_INUMP (y
))
7291 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7292 else if (SCM_BIGP (y
))
7294 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7295 scm_remember_upto_here_1 (y
);
7296 return scm_from_double (result
);
7298 else if (SCM_REALP (y
))
7299 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7300 else if (SCM_COMPLEXP (y
))
7301 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7302 SCM_COMPLEX_IMAG (y
));
7303 else if (SCM_FRACTIONP (y
))
7304 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7306 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7308 else if (SCM_COMPLEXP (x
))
7310 if (SCM_I_INUMP (y
))
7311 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7312 SCM_COMPLEX_IMAG (x
));
7313 else if (SCM_BIGP (y
))
7315 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7316 + SCM_COMPLEX_REAL (x
));
7317 scm_remember_upto_here_1 (y
);
7318 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7320 else if (SCM_REALP (y
))
7321 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7322 SCM_COMPLEX_IMAG (x
));
7323 else if (SCM_COMPLEXP (y
))
7324 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7325 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7326 else if (SCM_FRACTIONP (y
))
7327 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7328 SCM_COMPLEX_IMAG (x
));
7330 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7332 else if (SCM_FRACTIONP (x
))
7334 if (SCM_I_INUMP (y
))
7335 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7336 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7337 SCM_FRACTION_DENOMINATOR (x
));
7338 else if (SCM_BIGP (y
))
7339 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7340 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7341 SCM_FRACTION_DENOMINATOR (x
));
7342 else if (SCM_REALP (y
))
7343 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7344 else if (SCM_COMPLEXP (y
))
7345 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7346 SCM_COMPLEX_IMAG (y
));
7347 else if (SCM_FRACTIONP (y
))
7348 /* a/b + c/d = (ad + bc) / bd */
7349 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7350 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7351 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7353 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7356 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7360 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7362 "Return @math{@var{x}+1}.")
7363 #define FUNC_NAME s_scm_oneplus
7365 return scm_sum (x
, SCM_INUM1
);
7370 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7371 (SCM x
, SCM y
, SCM rest
),
7372 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7373 "the sum of all but the first argument are subtracted from the first\n"
7375 #define FUNC_NAME s_scm_i_difference
7377 while (!scm_is_null (rest
))
7378 { x
= scm_difference (x
, y
);
7380 rest
= scm_cdr (rest
);
7382 return scm_difference (x
, y
);
7386 #define s_difference s_scm_i_difference
7387 #define g_difference g_scm_i_difference
7390 scm_difference (SCM x
, SCM y
)
7391 #define FUNC_NAME s_difference
7393 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7396 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7398 if (SCM_I_INUMP (x
))
7400 scm_t_inum xx
= -SCM_I_INUM (x
);
7401 if (SCM_FIXABLE (xx
))
7402 return SCM_I_MAKINUM (xx
);
7404 return scm_i_inum2big (xx
);
7406 else if (SCM_BIGP (x
))
7407 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7408 bignum, but negating that gives a fixnum. */
7409 return scm_i_normbig (scm_i_clonebig (x
, 0));
7410 else if (SCM_REALP (x
))
7411 return scm_from_double (-SCM_REAL_VALUE (x
));
7412 else if (SCM_COMPLEXP (x
))
7413 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7414 -SCM_COMPLEX_IMAG (x
));
7415 else if (SCM_FRACTIONP (x
))
7416 return scm_i_make_ratio_already_reduced
7417 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7418 SCM_FRACTION_DENOMINATOR (x
));
7420 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7423 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7425 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7427 scm_t_inum xx
= SCM_I_INUM (x
);
7428 scm_t_inum yy
= SCM_I_INUM (y
);
7429 scm_t_inum z
= xx
- yy
;
7430 if (SCM_FIXABLE (z
))
7431 return SCM_I_MAKINUM (z
);
7433 return scm_i_inum2big (z
);
7435 else if (SCM_BIGP (y
))
7437 /* inum-x - big-y */
7438 scm_t_inum xx
= SCM_I_INUM (x
);
7442 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7443 bignum, but negating that gives a fixnum. */
7444 return scm_i_normbig (scm_i_clonebig (y
, 0));
7448 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7449 SCM result
= scm_i_mkbig ();
7452 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7455 /* x - y == -(y + -x) */
7456 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7457 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7459 scm_remember_upto_here_1 (y
);
7461 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7462 /* we know the result will have to be a bignum */
7465 return scm_i_normbig (result
);
7468 else if (SCM_REALP (y
))
7470 scm_t_inum xx
= SCM_I_INUM (x
);
7473 * We need to handle x == exact 0
7474 * specially because R6RS states that:
7475 * (- 0.0) ==> -0.0 and
7476 * (- 0.0 0.0) ==> 0.0
7477 * and the scheme compiler changes
7478 * (- 0.0) into (- 0 0.0)
7479 * So we need to treat (- 0 0.0) like (- 0.0).
7480 * At the C level, (-x) is different than (0.0 - x).
7481 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7484 return scm_from_double (- SCM_REAL_VALUE (y
));
7486 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7488 else if (SCM_COMPLEXP (y
))
7490 scm_t_inum xx
= SCM_I_INUM (x
);
7492 /* We need to handle x == exact 0 specially.
7493 See the comment above (for SCM_REALP (y)) */
7495 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7496 - SCM_COMPLEX_IMAG (y
));
7498 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7499 - SCM_COMPLEX_IMAG (y
));
7501 else if (SCM_FRACTIONP (y
))
7502 /* a - b/c = (ac - b) / c */
7503 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7504 SCM_FRACTION_NUMERATOR (y
)),
7505 SCM_FRACTION_DENOMINATOR (y
));
7507 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7509 else if (SCM_BIGP (x
))
7511 if (SCM_I_INUMP (y
))
7513 /* big-x - inum-y */
7514 scm_t_inum yy
= SCM_I_INUM (y
);
7515 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7517 scm_remember_upto_here_1 (x
);
7519 return (SCM_FIXABLE (-yy
) ?
7520 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7523 SCM result
= scm_i_mkbig ();
7526 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7528 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7529 scm_remember_upto_here_1 (x
);
7531 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7532 /* we know the result will have to be a bignum */
7535 return scm_i_normbig (result
);
7538 else if (SCM_BIGP (y
))
7540 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7541 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7542 SCM result
= scm_i_mkbig ();
7543 mpz_sub (SCM_I_BIG_MPZ (result
),
7546 scm_remember_upto_here_2 (x
, y
);
7547 /* we know the result will have to be a bignum */
7548 if ((sgn_x
== 1) && (sgn_y
== -1))
7550 if ((sgn_x
== -1) && (sgn_y
== 1))
7552 return scm_i_normbig (result
);
7554 else if (SCM_REALP (y
))
7556 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7557 scm_remember_upto_here_1 (x
);
7558 return scm_from_double (result
);
7560 else if (SCM_COMPLEXP (y
))
7562 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7563 - SCM_COMPLEX_REAL (y
));
7564 scm_remember_upto_here_1 (x
);
7565 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7567 else if (SCM_FRACTIONP (y
))
7568 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7569 SCM_FRACTION_NUMERATOR (y
)),
7570 SCM_FRACTION_DENOMINATOR (y
));
7571 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7573 else if (SCM_REALP (x
))
7575 if (SCM_I_INUMP (y
))
7576 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7577 else if (SCM_BIGP (y
))
7579 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7580 scm_remember_upto_here_1 (x
);
7581 return scm_from_double (result
);
7583 else if (SCM_REALP (y
))
7584 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7585 else if (SCM_COMPLEXP (y
))
7586 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7587 -SCM_COMPLEX_IMAG (y
));
7588 else if (SCM_FRACTIONP (y
))
7589 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7591 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7593 else if (SCM_COMPLEXP (x
))
7595 if (SCM_I_INUMP (y
))
7596 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7597 SCM_COMPLEX_IMAG (x
));
7598 else if (SCM_BIGP (y
))
7600 double real_part
= (SCM_COMPLEX_REAL (x
)
7601 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7602 scm_remember_upto_here_1 (x
);
7603 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7605 else if (SCM_REALP (y
))
7606 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7607 SCM_COMPLEX_IMAG (x
));
7608 else if (SCM_COMPLEXP (y
))
7609 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7610 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7611 else if (SCM_FRACTIONP (y
))
7612 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7613 SCM_COMPLEX_IMAG (x
));
7615 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7617 else if (SCM_FRACTIONP (x
))
7619 if (SCM_I_INUMP (y
))
7620 /* a/b - c = (a - cb) / b */
7621 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7622 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7623 SCM_FRACTION_DENOMINATOR (x
));
7624 else if (SCM_BIGP (y
))
7625 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7626 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7627 SCM_FRACTION_DENOMINATOR (x
));
7628 else if (SCM_REALP (y
))
7629 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7630 else if (SCM_COMPLEXP (y
))
7631 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7632 -SCM_COMPLEX_IMAG (y
));
7633 else if (SCM_FRACTIONP (y
))
7634 /* a/b - c/d = (ad - bc) / bd */
7635 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7636 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7637 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7639 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7642 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7647 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7649 "Return @math{@var{x}-1}.")
7650 #define FUNC_NAME s_scm_oneminus
7652 return scm_difference (x
, SCM_INUM1
);
7657 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7658 (SCM x
, SCM y
, SCM rest
),
7659 "Return the product of all arguments. If called without arguments,\n"
7661 #define FUNC_NAME s_scm_i_product
7663 while (!scm_is_null (rest
))
7664 { x
= scm_product (x
, y
);
7666 rest
= scm_cdr (rest
);
7668 return scm_product (x
, y
);
7672 #define s_product s_scm_i_product
7673 #define g_product g_scm_i_product
7676 scm_product (SCM x
, SCM y
)
7678 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7681 return SCM_I_MAKINUM (1L);
7682 else if (SCM_NUMBERP (x
))
7685 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7688 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7693 xx
= SCM_I_INUM (x
);
7698 /* exact1 is the universal multiplicative identity */
7702 /* exact0 times a fixnum is exact0: optimize this case */
7703 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7705 /* if the other argument is inexact, the result is inexact,
7706 and we must do the multiplication in order to handle
7707 infinities and NaNs properly. */
7708 else if (SCM_REALP (y
))
7709 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7710 else if (SCM_COMPLEXP (y
))
7711 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7712 0.0 * SCM_COMPLEX_IMAG (y
));
7713 /* we've already handled inexact numbers,
7714 so y must be exact, and we return exact0 */
7715 else if (SCM_NUMP (y
))
7718 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7722 * This case is important for more than just optimization.
7723 * It handles the case of negating
7724 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7725 * which is a bignum that must be changed back into a fixnum.
7726 * Failure to do so will cause the following to return #f:
7727 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7729 return scm_difference(y
, SCM_UNDEFINED
);
7733 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7735 scm_t_inum yy
= SCM_I_INUM (y
);
7736 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7737 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7738 if (SCM_FIXABLE (kk
))
7739 return SCM_I_MAKINUM (kk
);
7741 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7742 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7743 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7744 return SCM_I_MAKINUM (xx
* yy
);
7748 SCM result
= scm_i_inum2big (xx
);
7749 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7750 return scm_i_normbig (result
);
7753 else if (SCM_BIGP (y
))
7755 SCM result
= scm_i_mkbig ();
7756 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7757 scm_remember_upto_here_1 (y
);
7760 else if (SCM_REALP (y
))
7761 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7762 else if (SCM_COMPLEXP (y
))
7763 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7764 xx
* SCM_COMPLEX_IMAG (y
));
7765 else if (SCM_FRACTIONP (y
))
7766 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7767 SCM_FRACTION_DENOMINATOR (y
));
7769 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7771 else if (SCM_BIGP (x
))
7773 if (SCM_I_INUMP (y
))
7778 else if (SCM_BIGP (y
))
7780 SCM result
= scm_i_mkbig ();
7781 mpz_mul (SCM_I_BIG_MPZ (result
),
7784 scm_remember_upto_here_2 (x
, y
);
7787 else if (SCM_REALP (y
))
7789 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7790 scm_remember_upto_here_1 (x
);
7791 return scm_from_double (result
);
7793 else if (SCM_COMPLEXP (y
))
7795 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7796 scm_remember_upto_here_1 (x
);
7797 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7798 z
* SCM_COMPLEX_IMAG (y
));
7800 else if (SCM_FRACTIONP (y
))
7801 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7802 SCM_FRACTION_DENOMINATOR (y
));
7804 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7806 else if (SCM_REALP (x
))
7808 if (SCM_I_INUMP (y
))
7813 else if (SCM_BIGP (y
))
7815 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7816 scm_remember_upto_here_1 (y
);
7817 return scm_from_double (result
);
7819 else if (SCM_REALP (y
))
7820 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7821 else if (SCM_COMPLEXP (y
))
7822 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7823 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7824 else if (SCM_FRACTIONP (y
))
7825 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7827 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7829 else if (SCM_COMPLEXP (x
))
7831 if (SCM_I_INUMP (y
))
7836 else if (SCM_BIGP (y
))
7838 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7839 scm_remember_upto_here_1 (y
);
7840 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7841 z
* SCM_COMPLEX_IMAG (x
));
7843 else if (SCM_REALP (y
))
7844 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7845 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7846 else if (SCM_COMPLEXP (y
))
7848 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7849 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7850 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7851 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7853 else if (SCM_FRACTIONP (y
))
7855 double yy
= scm_i_fraction2double (y
);
7856 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7857 yy
* SCM_COMPLEX_IMAG (x
));
7860 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7862 else if (SCM_FRACTIONP (x
))
7864 if (SCM_I_INUMP (y
))
7865 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7866 SCM_FRACTION_DENOMINATOR (x
));
7867 else if (SCM_BIGP (y
))
7868 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7869 SCM_FRACTION_DENOMINATOR (x
));
7870 else if (SCM_REALP (y
))
7871 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7872 else if (SCM_COMPLEXP (y
))
7874 double xx
= scm_i_fraction2double (x
);
7875 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7876 xx
* SCM_COMPLEX_IMAG (y
));
7878 else if (SCM_FRACTIONP (y
))
7879 /* a/b * c/d = ac / bd */
7880 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7881 SCM_FRACTION_NUMERATOR (y
)),
7882 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7883 SCM_FRACTION_DENOMINATOR (y
)));
7885 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7888 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7891 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7892 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7893 #define ALLOW_DIVIDE_BY_ZERO
7894 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7897 /* The code below for complex division is adapted from the GNU
7898 libstdc++, which adapted it from f2c's libF77, and is subject to
7901 /****************************************************************
7902 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7904 Permission to use, copy, modify, and distribute this software
7905 and its documentation for any purpose and without fee is hereby
7906 granted, provided that the above copyright notice appear in all
7907 copies and that both that the copyright notice and this
7908 permission notice and warranty disclaimer appear in supporting
7909 documentation, and that the names of AT&T Bell Laboratories or
7910 Bellcore or any of their entities not be used in advertising or
7911 publicity pertaining to distribution of the software without
7912 specific, written prior permission.
7914 AT&T and Bellcore disclaim all warranties with regard to this
7915 software, including all implied warranties of merchantability
7916 and fitness. In no event shall AT&T or Bellcore be liable for
7917 any special, indirect or consequential damages or any damages
7918 whatsoever resulting from loss of use, data or profits, whether
7919 in an action of contract, negligence or other tortious action,
7920 arising out of or in connection with the use or performance of
7922 ****************************************************************/
7924 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7925 (SCM x
, SCM y
, SCM rest
),
7926 "Divide the first argument by the product of the remaining\n"
7927 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7929 #define FUNC_NAME s_scm_i_divide
7931 while (!scm_is_null (rest
))
7932 { x
= scm_divide (x
, y
);
7934 rest
= scm_cdr (rest
);
7936 return scm_divide (x
, y
);
7940 #define s_divide s_scm_i_divide
7941 #define g_divide g_scm_i_divide
7944 do_divide (SCM x
, SCM y
, int inexact
)
7945 #define FUNC_NAME s_divide
7949 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7952 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7953 else if (SCM_I_INUMP (x
))
7955 scm_t_inum xx
= SCM_I_INUM (x
);
7956 if (xx
== 1 || xx
== -1)
7958 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7960 scm_num_overflow (s_divide
);
7965 return scm_from_double (1.0 / (double) xx
);
7966 else return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
7969 else if (SCM_BIGP (x
))
7972 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7973 else return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
7975 else if (SCM_REALP (x
))
7977 double xx
= SCM_REAL_VALUE (x
);
7978 #ifndef ALLOW_DIVIDE_BY_ZERO
7980 scm_num_overflow (s_divide
);
7983 return scm_from_double (1.0 / xx
);
7985 else if (SCM_COMPLEXP (x
))
7987 double r
= SCM_COMPLEX_REAL (x
);
7988 double i
= SCM_COMPLEX_IMAG (x
);
7989 if (fabs(r
) <= fabs(i
))
7992 double d
= i
* (1.0 + t
* t
);
7993 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7998 double d
= r
* (1.0 + t
* t
);
7999 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8002 else if (SCM_FRACTIONP (x
))
8003 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8004 SCM_FRACTION_NUMERATOR (x
));
8006 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8009 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8011 scm_t_inum xx
= SCM_I_INUM (x
);
8012 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8014 scm_t_inum yy
= SCM_I_INUM (y
);
8017 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8018 scm_num_overflow (s_divide
);
8020 return scm_from_double ((double) xx
/ (double) yy
);
8023 else if (xx
% yy
!= 0)
8026 return scm_from_double ((double) xx
/ (double) yy
);
8027 else return scm_i_make_ratio (x
, y
);
8031 scm_t_inum z
= xx
/ yy
;
8032 if (SCM_FIXABLE (z
))
8033 return SCM_I_MAKINUM (z
);
8035 return scm_i_inum2big (z
);
8038 else if (SCM_BIGP (y
))
8041 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
8042 else return scm_i_make_ratio (x
, y
);
8044 else if (SCM_REALP (y
))
8046 double yy
= SCM_REAL_VALUE (y
);
8047 #ifndef ALLOW_DIVIDE_BY_ZERO
8049 scm_num_overflow (s_divide
);
8052 return scm_from_double ((double) xx
/ yy
);
8054 else if (SCM_COMPLEXP (y
))
8057 complex_div
: /* y _must_ be a complex number */
8059 double r
= SCM_COMPLEX_REAL (y
);
8060 double i
= SCM_COMPLEX_IMAG (y
);
8061 if (fabs(r
) <= fabs(i
))
8064 double d
= i
* (1.0 + t
* t
);
8065 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8070 double d
= r
* (1.0 + t
* t
);
8071 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8075 else if (SCM_FRACTIONP (y
))
8076 /* a / b/c = ac / b */
8077 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8078 SCM_FRACTION_NUMERATOR (y
));
8080 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8082 else if (SCM_BIGP (x
))
8084 if (SCM_I_INUMP (y
))
8086 scm_t_inum yy
= SCM_I_INUM (y
);
8089 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8090 scm_num_overflow (s_divide
);
8092 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8093 scm_remember_upto_here_1 (x
);
8094 return (sgn
== 0) ? scm_nan () : scm_inf ();
8101 /* FIXME: HMM, what are the relative performance issues here?
8102 We need to test. Is it faster on average to test
8103 divisible_p, then perform whichever operation, or is it
8104 faster to perform the integer div opportunistically and
8105 switch to real if there's a remainder? For now we take the
8106 middle ground: test, then if divisible, use the faster div
8109 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8110 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8114 SCM result
= scm_i_mkbig ();
8115 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8116 scm_remember_upto_here_1 (x
);
8118 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8119 return scm_i_normbig (result
);
8124 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8125 else return scm_i_make_ratio (x
, y
);
8129 else if (SCM_BIGP (y
))
8134 /* It's easily possible for the ratio x/y to fit a double
8135 but one or both x and y be too big to fit a double,
8136 hence the use of mpq_get_d rather than converting and
8139 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8140 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8141 return scm_from_double (mpq_get_d (q
));
8145 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8149 SCM result
= scm_i_mkbig ();
8150 mpz_divexact (SCM_I_BIG_MPZ (result
),
8153 scm_remember_upto_here_2 (x
, y
);
8154 return scm_i_normbig (result
);
8157 return scm_i_make_ratio (x
, y
);
8160 else if (SCM_REALP (y
))
8162 double yy
= SCM_REAL_VALUE (y
);
8163 #ifndef ALLOW_DIVIDE_BY_ZERO
8165 scm_num_overflow (s_divide
);
8168 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8170 else if (SCM_COMPLEXP (y
))
8172 a
= scm_i_big2dbl (x
);
8175 else if (SCM_FRACTIONP (y
))
8176 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8177 SCM_FRACTION_NUMERATOR (y
));
8179 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8181 else if (SCM_REALP (x
))
8183 double rx
= SCM_REAL_VALUE (x
);
8184 if (SCM_I_INUMP (y
))
8186 scm_t_inum yy
= SCM_I_INUM (y
);
8187 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8189 scm_num_overflow (s_divide
);
8192 return scm_from_double (rx
/ (double) yy
);
8194 else if (SCM_BIGP (y
))
8196 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8197 scm_remember_upto_here_1 (y
);
8198 return scm_from_double (rx
/ dby
);
8200 else if (SCM_REALP (y
))
8202 double yy
= SCM_REAL_VALUE (y
);
8203 #ifndef ALLOW_DIVIDE_BY_ZERO
8205 scm_num_overflow (s_divide
);
8208 return scm_from_double (rx
/ yy
);
8210 else if (SCM_COMPLEXP (y
))
8215 else if (SCM_FRACTIONP (y
))
8216 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8218 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8220 else if (SCM_COMPLEXP (x
))
8222 double rx
= SCM_COMPLEX_REAL (x
);
8223 double ix
= SCM_COMPLEX_IMAG (x
);
8224 if (SCM_I_INUMP (y
))
8226 scm_t_inum yy
= SCM_I_INUM (y
);
8227 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8229 scm_num_overflow (s_divide
);
8234 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8237 else if (SCM_BIGP (y
))
8239 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8240 scm_remember_upto_here_1 (y
);
8241 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8243 else if (SCM_REALP (y
))
8245 double yy
= SCM_REAL_VALUE (y
);
8246 #ifndef ALLOW_DIVIDE_BY_ZERO
8248 scm_num_overflow (s_divide
);
8251 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8253 else if (SCM_COMPLEXP (y
))
8255 double ry
= SCM_COMPLEX_REAL (y
);
8256 double iy
= SCM_COMPLEX_IMAG (y
);
8257 if (fabs(ry
) <= fabs(iy
))
8260 double d
= iy
* (1.0 + t
* t
);
8261 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8266 double d
= ry
* (1.0 + t
* t
);
8267 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8270 else if (SCM_FRACTIONP (y
))
8272 double yy
= scm_i_fraction2double (y
);
8273 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8276 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8278 else if (SCM_FRACTIONP (x
))
8280 if (SCM_I_INUMP (y
))
8282 scm_t_inum yy
= SCM_I_INUM (y
);
8283 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8285 scm_num_overflow (s_divide
);
8288 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8289 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8291 else if (SCM_BIGP (y
))
8293 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8294 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8296 else if (SCM_REALP (y
))
8298 double yy
= SCM_REAL_VALUE (y
);
8299 #ifndef ALLOW_DIVIDE_BY_ZERO
8301 scm_num_overflow (s_divide
);
8304 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8306 else if (SCM_COMPLEXP (y
))
8308 a
= scm_i_fraction2double (x
);
8311 else if (SCM_FRACTIONP (y
))
8312 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8313 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8315 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8318 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8322 scm_divide (SCM x
, SCM y
)
8324 return do_divide (x
, y
, 0);
8327 static SCM
scm_divide2real (SCM x
, SCM y
)
8329 return do_divide (x
, y
, 1);
8335 scm_c_truncate (double x
)
8340 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8341 half-way case (ie. when x is an integer plus 0.5) going upwards.
8342 Then half-way cases are identified and adjusted down if the
8343 round-upwards didn't give the desired even integer.
8345 "plus_half == result" identifies a half-way case. If plus_half, which is
8346 x + 0.5, is an integer then x must be an integer plus 0.5.
8348 An odd "result" value is identified with result/2 != floor(result/2).
8349 This is done with plus_half, since that value is ready for use sooner in
8350 a pipelined cpu, and we're already requiring plus_half == result.
8352 Note however that we need to be careful when x is big and already an
8353 integer. In that case "x+0.5" may round to an adjacent integer, causing
8354 us to return such a value, incorrectly. For instance if the hardware is
8355 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8356 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8357 returned. Or if the hardware is in round-upwards mode, then other bigger
8358 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8359 representable value, 2^128+2^76 (or whatever), again incorrect.
8361 These bad roundings of x+0.5 are avoided by testing at the start whether
8362 x is already an integer. If it is then clearly that's the desired result
8363 already. And if it's not then the exponent must be small enough to allow
8364 an 0.5 to be represented, and hence added without a bad rounding. */
8367 scm_c_round (double x
)
8369 double plus_half
, result
;
8374 plus_half
= x
+ 0.5;
8375 result
= floor (plus_half
);
8376 /* Adjust so that the rounding is towards even. */
8377 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8382 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8384 "Round the number @var{x} towards zero.")
8385 #define FUNC_NAME s_scm_truncate_number
8387 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8389 else if (SCM_REALP (x
))
8390 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8391 else if (SCM_FRACTIONP (x
))
8392 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8393 SCM_FRACTION_DENOMINATOR (x
));
8395 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8396 s_scm_truncate_number
);
8400 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8402 "Round the number @var{x} towards the nearest integer. "
8403 "When it is exactly halfway between two integers, "
8404 "round towards the even one.")
8405 #define FUNC_NAME s_scm_round_number
8407 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8409 else if (SCM_REALP (x
))
8410 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8411 else if (SCM_FRACTIONP (x
))
8412 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8413 SCM_FRACTION_DENOMINATOR (x
));
8415 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8416 s_scm_round_number
);
8420 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8422 "Round the number @var{x} towards minus infinity.")
8423 #define FUNC_NAME s_scm_floor
8425 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8427 else if (SCM_REALP (x
))
8428 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8429 else if (SCM_FRACTIONP (x
))
8430 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8431 SCM_FRACTION_DENOMINATOR (x
));
8433 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8437 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8439 "Round the number @var{x} towards infinity.")
8440 #define FUNC_NAME s_scm_ceiling
8442 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8444 else if (SCM_REALP (x
))
8445 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8446 else if (SCM_FRACTIONP (x
))
8447 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8448 SCM_FRACTION_DENOMINATOR (x
));
8450 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8454 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8456 "Return @var{x} raised to the power of @var{y}.")
8457 #define FUNC_NAME s_scm_expt
8459 if (scm_is_integer (y
))
8461 if (scm_is_true (scm_exact_p (y
)))
8462 return scm_integer_expt (x
, y
);
8465 /* Here we handle the case where the exponent is an inexact
8466 integer. We make the exponent exact in order to use
8467 scm_integer_expt, and thus avoid the spurious imaginary
8468 parts that may result from round-off errors in the general
8469 e^(y log x) method below (for example when squaring a large
8470 negative number). In this case, we must return an inexact
8471 result for correctness. We also make the base inexact so
8472 that scm_integer_expt will use fast inexact arithmetic
8473 internally. Note that making the base inexact is not
8474 sufficient to guarantee an inexact result, because
8475 scm_integer_expt will return an exact 1 when the exponent
8476 is 0, even if the base is inexact. */
8477 return scm_exact_to_inexact
8478 (scm_integer_expt (scm_exact_to_inexact (x
),
8479 scm_inexact_to_exact (y
)));
8482 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8484 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8486 else if (scm_is_complex (x
) && scm_is_complex (y
))
8487 return scm_exp (scm_product (scm_log (x
), y
));
8488 else if (scm_is_complex (x
))
8489 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8491 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8495 /* sin/cos/tan/asin/acos/atan
8496 sinh/cosh/tanh/asinh/acosh/atanh
8497 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8498 Written by Jerry D. Hedden, (C) FSF.
8499 See the file `COPYING' for terms applying to this program. */
8501 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8503 "Compute the sine of @var{z}.")
8504 #define FUNC_NAME s_scm_sin
8506 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8507 return z
; /* sin(exact0) = exact0 */
8508 else if (scm_is_real (z
))
8509 return scm_from_double (sin (scm_to_double (z
)));
8510 else if (SCM_COMPLEXP (z
))
8512 x
= SCM_COMPLEX_REAL (z
);
8513 y
= SCM_COMPLEX_IMAG (z
);
8514 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8515 cos (x
) * sinh (y
));
8518 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8522 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8524 "Compute the cosine of @var{z}.")
8525 #define FUNC_NAME s_scm_cos
8527 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8528 return SCM_INUM1
; /* cos(exact0) = exact1 */
8529 else if (scm_is_real (z
))
8530 return scm_from_double (cos (scm_to_double (z
)));
8531 else if (SCM_COMPLEXP (z
))
8533 x
= SCM_COMPLEX_REAL (z
);
8534 y
= SCM_COMPLEX_IMAG (z
);
8535 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8536 -sin (x
) * sinh (y
));
8539 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8543 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8545 "Compute the tangent of @var{z}.")
8546 #define FUNC_NAME s_scm_tan
8548 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8549 return z
; /* tan(exact0) = exact0 */
8550 else if (scm_is_real (z
))
8551 return scm_from_double (tan (scm_to_double (z
)));
8552 else if (SCM_COMPLEXP (z
))
8554 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8555 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8556 w
= cos (x
) + cosh (y
);
8557 #ifndef ALLOW_DIVIDE_BY_ZERO
8559 scm_num_overflow (s_scm_tan
);
8561 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8564 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8568 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8570 "Compute the hyperbolic sine of @var{z}.")
8571 #define FUNC_NAME s_scm_sinh
8573 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8574 return z
; /* sinh(exact0) = exact0 */
8575 else if (scm_is_real (z
))
8576 return scm_from_double (sinh (scm_to_double (z
)));
8577 else if (SCM_COMPLEXP (z
))
8579 x
= SCM_COMPLEX_REAL (z
);
8580 y
= SCM_COMPLEX_IMAG (z
);
8581 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8582 cosh (x
) * sin (y
));
8585 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8589 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8591 "Compute the hyperbolic cosine of @var{z}.")
8592 #define FUNC_NAME s_scm_cosh
8594 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8595 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8596 else if (scm_is_real (z
))
8597 return scm_from_double (cosh (scm_to_double (z
)));
8598 else if (SCM_COMPLEXP (z
))
8600 x
= SCM_COMPLEX_REAL (z
);
8601 y
= SCM_COMPLEX_IMAG (z
);
8602 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8603 sinh (x
) * sin (y
));
8606 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8610 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8612 "Compute the hyperbolic tangent of @var{z}.")
8613 #define FUNC_NAME s_scm_tanh
8615 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8616 return z
; /* tanh(exact0) = exact0 */
8617 else if (scm_is_real (z
))
8618 return scm_from_double (tanh (scm_to_double (z
)));
8619 else if (SCM_COMPLEXP (z
))
8621 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8622 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8623 w
= cosh (x
) + cos (y
);
8624 #ifndef ALLOW_DIVIDE_BY_ZERO
8626 scm_num_overflow (s_scm_tanh
);
8628 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8631 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8635 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8637 "Compute the arc sine of @var{z}.")
8638 #define FUNC_NAME s_scm_asin
8640 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8641 return z
; /* asin(exact0) = exact0 */
8642 else if (scm_is_real (z
))
8644 double w
= scm_to_double (z
);
8645 if (w
>= -1.0 && w
<= 1.0)
8646 return scm_from_double (asin (w
));
8648 return scm_product (scm_c_make_rectangular (0, -1),
8649 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8651 else if (SCM_COMPLEXP (z
))
8653 x
= SCM_COMPLEX_REAL (z
);
8654 y
= SCM_COMPLEX_IMAG (z
);
8655 return scm_product (scm_c_make_rectangular (0, -1),
8656 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8659 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8663 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8665 "Compute the arc cosine of @var{z}.")
8666 #define FUNC_NAME s_scm_acos
8668 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8669 return SCM_INUM0
; /* acos(exact1) = exact0 */
8670 else if (scm_is_real (z
))
8672 double w
= scm_to_double (z
);
8673 if (w
>= -1.0 && w
<= 1.0)
8674 return scm_from_double (acos (w
));
8676 return scm_sum (scm_from_double (acos (0.0)),
8677 scm_product (scm_c_make_rectangular (0, 1),
8678 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8680 else if (SCM_COMPLEXP (z
))
8682 x
= SCM_COMPLEX_REAL (z
);
8683 y
= SCM_COMPLEX_IMAG (z
);
8684 return scm_sum (scm_from_double (acos (0.0)),
8685 scm_product (scm_c_make_rectangular (0, 1),
8686 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8689 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8693 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8695 "With one argument, compute the arc tangent of @var{z}.\n"
8696 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8697 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8698 #define FUNC_NAME s_scm_atan
8702 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8703 return z
; /* atan(exact0) = exact0 */
8704 else if (scm_is_real (z
))
8705 return scm_from_double (atan (scm_to_double (z
)));
8706 else if (SCM_COMPLEXP (z
))
8709 v
= SCM_COMPLEX_REAL (z
);
8710 w
= SCM_COMPLEX_IMAG (z
);
8711 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8712 scm_c_make_rectangular (v
, w
+ 1.0))),
8713 scm_c_make_rectangular (0, 2));
8716 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8718 else if (scm_is_real (z
))
8720 if (scm_is_real (y
))
8721 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8723 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8726 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8730 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8732 "Compute the inverse hyperbolic sine of @var{z}.")
8733 #define FUNC_NAME s_scm_sys_asinh
8735 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8736 return z
; /* asinh(exact0) = exact0 */
8737 else if (scm_is_real (z
))
8738 return scm_from_double (asinh (scm_to_double (z
)));
8739 else if (scm_is_number (z
))
8740 return scm_log (scm_sum (z
,
8741 scm_sqrt (scm_sum (scm_product (z
, z
),
8744 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8748 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8750 "Compute the inverse hyperbolic cosine of @var{z}.")
8751 #define FUNC_NAME s_scm_sys_acosh
8753 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8754 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8755 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8756 return scm_from_double (acosh (scm_to_double (z
)));
8757 else if (scm_is_number (z
))
8758 return scm_log (scm_sum (z
,
8759 scm_sqrt (scm_difference (scm_product (z
, z
),
8762 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8766 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8768 "Compute the inverse hyperbolic tangent of @var{z}.")
8769 #define FUNC_NAME s_scm_sys_atanh
8771 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8772 return z
; /* atanh(exact0) = exact0 */
8773 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8774 return scm_from_double (atanh (scm_to_double (z
)));
8775 else if (scm_is_number (z
))
8776 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8777 scm_difference (SCM_INUM1
, z
))),
8780 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8785 scm_c_make_rectangular (double re
, double im
)
8789 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8791 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8792 SCM_COMPLEX_REAL (z
) = re
;
8793 SCM_COMPLEX_IMAG (z
) = im
;
8797 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8798 (SCM real_part
, SCM imaginary_part
),
8799 "Return a complex number constructed of the given @var{real_part} "
8800 "and @var{imaginary_part} parts.")
8801 #define FUNC_NAME s_scm_make_rectangular
8803 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8804 SCM_ARG1
, FUNC_NAME
, "real");
8805 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8806 SCM_ARG2
, FUNC_NAME
, "real");
8808 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8809 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8812 return scm_c_make_rectangular (scm_to_double (real_part
),
8813 scm_to_double (imaginary_part
));
8818 scm_c_make_polar (double mag
, double ang
)
8822 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8823 use it on Glibc-based systems that have it (it's a GNU extension). See
8824 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8826 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8827 sincos (ang
, &s
, &c
);
8833 /* If s and c are NaNs, this indicates that the angle is a NaN,
8834 infinite, or perhaps simply too large to determine its value
8835 mod 2*pi. However, we know something that the floating-point
8836 implementation doesn't know: We know that s and c are finite.
8837 Therefore, if the magnitude is zero, return a complex zero.
8839 The reason we check for the NaNs instead of using this case
8840 whenever mag == 0.0 is because when the angle is known, we'd
8841 like to return the correct kind of non-real complex zero:
8842 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8843 on which quadrant the angle is in.
8845 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8846 return scm_c_make_rectangular (0.0, 0.0);
8848 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8851 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8853 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8854 #define FUNC_NAME s_scm_make_polar
8856 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8857 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8859 /* If mag is exact0, return exact0 */
8860 if (scm_is_eq (mag
, SCM_INUM0
))
8862 /* Return a real if ang is exact0 */
8863 else if (scm_is_eq (ang
, SCM_INUM0
))
8866 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8871 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8873 "Return the real part of the number @var{z}.")
8874 #define FUNC_NAME s_scm_real_part
8876 if (SCM_COMPLEXP (z
))
8877 return scm_from_double (SCM_COMPLEX_REAL (z
));
8878 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8881 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8886 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8888 "Return the imaginary part of the number @var{z}.")
8889 #define FUNC_NAME s_scm_imag_part
8891 if (SCM_COMPLEXP (z
))
8892 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8893 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8896 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8900 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8902 "Return the numerator of the number @var{z}.")
8903 #define FUNC_NAME s_scm_numerator
8905 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8907 else if (SCM_FRACTIONP (z
))
8908 return SCM_FRACTION_NUMERATOR (z
);
8909 else if (SCM_REALP (z
))
8910 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8912 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8917 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8919 "Return the denominator of the number @var{z}.")
8920 #define FUNC_NAME s_scm_denominator
8922 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8924 else if (SCM_FRACTIONP (z
))
8925 return SCM_FRACTION_DENOMINATOR (z
);
8926 else if (SCM_REALP (z
))
8927 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8929 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8934 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8936 "Return the magnitude of the number @var{z}. This is the same as\n"
8937 "@code{abs} for real arguments, but also allows complex numbers.")
8938 #define FUNC_NAME s_scm_magnitude
8940 if (SCM_I_INUMP (z
))
8942 scm_t_inum zz
= SCM_I_INUM (z
);
8945 else if (SCM_POSFIXABLE (-zz
))
8946 return SCM_I_MAKINUM (-zz
);
8948 return scm_i_inum2big (-zz
);
8950 else if (SCM_BIGP (z
))
8952 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8953 scm_remember_upto_here_1 (z
);
8955 return scm_i_clonebig (z
, 0);
8959 else if (SCM_REALP (z
))
8960 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8961 else if (SCM_COMPLEXP (z
))
8962 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8963 else if (SCM_FRACTIONP (z
))
8965 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8967 return scm_i_make_ratio_already_reduced
8968 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8969 SCM_FRACTION_DENOMINATOR (z
));
8972 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8977 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8979 "Return the angle of the complex number @var{z}.")
8980 #define FUNC_NAME s_scm_angle
8982 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8983 flo0 to save allocating a new flonum with scm_from_double each time.
8984 But if atan2 follows the floating point rounding mode, then the value
8985 is not a constant. Maybe it'd be close enough though. */
8986 if (SCM_I_INUMP (z
))
8988 if (SCM_I_INUM (z
) >= 0)
8991 return scm_from_double (atan2 (0.0, -1.0));
8993 else if (SCM_BIGP (z
))
8995 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8996 scm_remember_upto_here_1 (z
);
8998 return scm_from_double (atan2 (0.0, -1.0));
9002 else if (SCM_REALP (z
))
9004 double x
= SCM_REAL_VALUE (z
);
9005 if (x
> 0.0 || double_is_non_negative_zero (x
))
9008 return scm_from_double (atan2 (0.0, -1.0));
9010 else if (SCM_COMPLEXP (z
))
9011 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9012 else if (SCM_FRACTIONP (z
))
9014 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9016 else return scm_from_double (atan2 (0.0, -1.0));
9019 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9024 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9026 "Convert the number @var{z} to its inexact representation.\n")
9027 #define FUNC_NAME s_scm_exact_to_inexact
9029 if (SCM_I_INUMP (z
))
9030 return scm_from_double ((double) SCM_I_INUM (z
));
9031 else if (SCM_BIGP (z
))
9032 return scm_from_double (scm_i_big2dbl (z
));
9033 else if (SCM_FRACTIONP (z
))
9034 return scm_from_double (scm_i_fraction2double (z
));
9035 else if (SCM_INEXACTP (z
))
9038 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9043 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9045 "Return an exact number that is numerically closest to @var{z}.")
9046 #define FUNC_NAME s_scm_inexact_to_exact
9048 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9055 val
= SCM_REAL_VALUE (z
);
9056 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9057 val
= SCM_COMPLEX_REAL (z
);
9059 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9061 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9062 SCM_OUT_OF_RANGE (1, z
);
9069 mpq_set_d (frac
, val
);
9070 q
= scm_i_make_ratio_already_reduced
9071 (scm_i_mpz2num (mpq_numref (frac
)),
9072 scm_i_mpz2num (mpq_denref (frac
)));
9074 /* When scm_i_make_ratio throws, we leak the memory allocated
9084 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9086 "Returns the @emph{simplest} rational number differing\n"
9087 "from @var{x} by no more than @var{eps}.\n"
9089 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9090 "exact result when both its arguments are exact. Thus, you might need\n"
9091 "to use @code{inexact->exact} on the arguments.\n"
9094 "(rationalize (inexact->exact 1.2) 1/100)\n"
9097 #define FUNC_NAME s_scm_rationalize
9099 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9100 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9101 eps
= scm_abs (eps
);
9102 if (scm_is_false (scm_positive_p (eps
)))
9104 /* eps is either zero or a NaN */
9105 if (scm_is_true (scm_nan_p (eps
)))
9107 else if (SCM_INEXACTP (eps
))
9108 return scm_exact_to_inexact (x
);
9112 else if (scm_is_false (scm_finite_p (eps
)))
9114 if (scm_is_true (scm_finite_p (x
)))
9119 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9121 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9122 scm_ceiling (scm_difference (x
, eps
)))))
9124 /* There's an integer within range; we want the one closest to zero */
9125 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9127 /* zero is within range */
9128 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9133 else if (scm_is_true (scm_positive_p (x
)))
9134 return scm_ceiling (scm_difference (x
, eps
));
9136 return scm_floor (scm_sum (x
, eps
));
9140 /* Use continued fractions to find closest ratio. All
9141 arithmetic is done with exact numbers.
9144 SCM ex
= scm_inexact_to_exact (x
);
9145 SCM int_part
= scm_floor (ex
);
9147 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9148 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9152 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9153 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9155 /* We stop after a million iterations just to be absolutely sure
9156 that we don't go into an infinite loop. The process normally
9157 converges after less than a dozen iterations.
9160 while (++i
< 1000000)
9162 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9163 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9164 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9166 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9167 eps
))) /* abs(x-a/b) <= eps */
9169 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9170 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9171 return scm_exact_to_inexact (res
);
9175 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9177 tt
= scm_floor (rx
); /* tt = floor (rx) */
9183 scm_num_overflow (s_scm_rationalize
);
9188 /* conversion functions */
9191 scm_is_integer (SCM val
)
9193 return scm_is_true (scm_integer_p (val
));
9197 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9199 if (SCM_I_INUMP (val
))
9201 scm_t_signed_bits n
= SCM_I_INUM (val
);
9202 return n
>= min
&& n
<= max
;
9204 else if (SCM_BIGP (val
))
9206 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9208 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9210 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9212 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9213 return n
>= min
&& n
<= max
;
9223 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9224 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9227 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9228 SCM_I_BIG_MPZ (val
));
9230 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9242 return n
>= min
&& n
<= max
;
9250 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9252 if (SCM_I_INUMP (val
))
9254 scm_t_signed_bits n
= SCM_I_INUM (val
);
9255 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9257 else if (SCM_BIGP (val
))
9259 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9261 else if (max
<= ULONG_MAX
)
9263 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9265 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9266 return n
>= min
&& n
<= max
;
9276 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9279 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9280 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9283 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9284 SCM_I_BIG_MPZ (val
));
9286 return n
>= min
&& n
<= max
;
9294 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9296 scm_error (scm_out_of_range_key
,
9298 "Value out of range ~S to ~S: ~S",
9299 scm_list_3 (min
, max
, bad_val
),
9300 scm_list_1 (bad_val
));
9303 #define TYPE scm_t_intmax
9304 #define TYPE_MIN min
9305 #define TYPE_MAX max
9306 #define SIZEOF_TYPE 0
9307 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9308 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9309 #include "libguile/conv-integer.i.c"
9311 #define TYPE scm_t_uintmax
9312 #define TYPE_MIN min
9313 #define TYPE_MAX max
9314 #define SIZEOF_TYPE 0
9315 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9316 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9317 #include "libguile/conv-uinteger.i.c"
9319 #define TYPE scm_t_int8
9320 #define TYPE_MIN SCM_T_INT8_MIN
9321 #define TYPE_MAX SCM_T_INT8_MAX
9322 #define SIZEOF_TYPE 1
9323 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9324 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9325 #include "libguile/conv-integer.i.c"
9327 #define TYPE scm_t_uint8
9329 #define TYPE_MAX SCM_T_UINT8_MAX
9330 #define SIZEOF_TYPE 1
9331 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9332 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9333 #include "libguile/conv-uinteger.i.c"
9335 #define TYPE scm_t_int16
9336 #define TYPE_MIN SCM_T_INT16_MIN
9337 #define TYPE_MAX SCM_T_INT16_MAX
9338 #define SIZEOF_TYPE 2
9339 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9340 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9341 #include "libguile/conv-integer.i.c"
9343 #define TYPE scm_t_uint16
9345 #define TYPE_MAX SCM_T_UINT16_MAX
9346 #define SIZEOF_TYPE 2
9347 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9348 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9349 #include "libguile/conv-uinteger.i.c"
9351 #define TYPE scm_t_int32
9352 #define TYPE_MIN SCM_T_INT32_MIN
9353 #define TYPE_MAX SCM_T_INT32_MAX
9354 #define SIZEOF_TYPE 4
9355 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9356 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9357 #include "libguile/conv-integer.i.c"
9359 #define TYPE scm_t_uint32
9361 #define TYPE_MAX SCM_T_UINT32_MAX
9362 #define SIZEOF_TYPE 4
9363 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9364 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9365 #include "libguile/conv-uinteger.i.c"
9367 #define TYPE scm_t_wchar
9368 #define TYPE_MIN (scm_t_int32)-1
9369 #define TYPE_MAX (scm_t_int32)0x10ffff
9370 #define SIZEOF_TYPE 4
9371 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9372 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9373 #include "libguile/conv-integer.i.c"
9375 #define TYPE scm_t_int64
9376 #define TYPE_MIN SCM_T_INT64_MIN
9377 #define TYPE_MAX SCM_T_INT64_MAX
9378 #define SIZEOF_TYPE 8
9379 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9380 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9381 #include "libguile/conv-integer.i.c"
9383 #define TYPE scm_t_uint64
9385 #define TYPE_MAX SCM_T_UINT64_MAX
9386 #define SIZEOF_TYPE 8
9387 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9388 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9389 #include "libguile/conv-uinteger.i.c"
9392 scm_to_mpz (SCM val
, mpz_t rop
)
9394 if (SCM_I_INUMP (val
))
9395 mpz_set_si (rop
, SCM_I_INUM (val
));
9396 else if (SCM_BIGP (val
))
9397 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9399 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9403 scm_from_mpz (mpz_t val
)
9405 return scm_i_mpz2num (val
);
9409 scm_is_real (SCM val
)
9411 return scm_is_true (scm_real_p (val
));
9415 scm_is_rational (SCM val
)
9417 return scm_is_true (scm_rational_p (val
));
9421 scm_to_double (SCM val
)
9423 if (SCM_I_INUMP (val
))
9424 return SCM_I_INUM (val
);
9425 else if (SCM_BIGP (val
))
9426 return scm_i_big2dbl (val
);
9427 else if (SCM_FRACTIONP (val
))
9428 return scm_i_fraction2double (val
);
9429 else if (SCM_REALP (val
))
9430 return SCM_REAL_VALUE (val
);
9432 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9436 scm_from_double (double val
)
9440 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9442 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9443 SCM_REAL_VALUE (z
) = val
;
9448 #if SCM_ENABLE_DEPRECATED == 1
9451 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9453 scm_c_issue_deprecation_warning
9454 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9458 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9462 scm_out_of_range (NULL
, num
);
9465 return scm_to_double (num
);
9469 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9471 scm_c_issue_deprecation_warning
9472 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9476 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9480 scm_out_of_range (NULL
, num
);
9483 return scm_to_double (num
);
9489 scm_is_complex (SCM val
)
9491 return scm_is_true (scm_complex_p (val
));
9495 scm_c_real_part (SCM z
)
9497 if (SCM_COMPLEXP (z
))
9498 return SCM_COMPLEX_REAL (z
);
9501 /* Use the scm_real_part to get proper error checking and
9504 return scm_to_double (scm_real_part (z
));
9509 scm_c_imag_part (SCM z
)
9511 if (SCM_COMPLEXP (z
))
9512 return SCM_COMPLEX_IMAG (z
);
9515 /* Use the scm_imag_part to get proper error checking and
9516 dispatching. The result will almost always be 0.0, but not
9519 return scm_to_double (scm_imag_part (z
));
9524 scm_c_magnitude (SCM z
)
9526 return scm_to_double (scm_magnitude (z
));
9532 return scm_to_double (scm_angle (z
));
9536 scm_is_number (SCM z
)
9538 return scm_is_true (scm_number_p (z
));
9542 /* Returns log(x * 2^shift) */
9544 log_of_shifted_double (double x
, long shift
)
9546 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9548 if (x
> 0.0 || double_is_non_negative_zero (x
))
9549 return scm_from_double (ans
);
9551 return scm_c_make_rectangular (ans
, M_PI
);
9554 /* Returns log(n), for exact integer n of integer-length size */
9556 log_of_exact_integer_with_size (SCM n
, long size
)
9558 long shift
= size
- 2 * scm_dblprec
[0];
9561 return log_of_shifted_double
9562 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9565 return log_of_shifted_double (scm_to_double (n
), 0);
9568 /* Returns log(n), for exact integer n */
9570 log_of_exact_integer (SCM n
)
9572 return log_of_exact_integer_with_size
9573 (n
, scm_to_long (scm_integer_length (n
)));
9576 /* Returns log(n/d), for exact non-zero integers n and d */
9578 log_of_fraction (SCM n
, SCM d
)
9580 long n_size
= scm_to_long (scm_integer_length (n
));
9581 long d_size
= scm_to_long (scm_integer_length (d
));
9583 if (abs (n_size
- d_size
) > 1)
9584 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9585 log_of_exact_integer_with_size (d
, d_size
)));
9586 else if (scm_is_false (scm_negative_p (n
)))
9587 return scm_from_double
9588 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9590 return scm_c_make_rectangular
9591 (log1p (scm_to_double (scm_divide2real
9592 (scm_difference (scm_abs (n
), d
),
9598 /* In the following functions we dispatch to the real-arg funcs like log()
9599 when we know the arg is real, instead of just handing everything to
9600 clog() for instance. This is in case clog() doesn't optimize for a
9601 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9602 well use it to go straight to the applicable C func. */
9604 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9606 "Return the natural logarithm of @var{z}.")
9607 #define FUNC_NAME s_scm_log
9609 if (SCM_COMPLEXP (z
))
9611 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9612 && defined (SCM_COMPLEX_VALUE)
9613 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9615 double re
= SCM_COMPLEX_REAL (z
);
9616 double im
= SCM_COMPLEX_IMAG (z
);
9617 return scm_c_make_rectangular (log (hypot (re
, im
)),
9621 else if (SCM_REALP (z
))
9622 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9623 else if (SCM_I_INUMP (z
))
9625 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9626 if (scm_is_eq (z
, SCM_INUM0
))
9627 scm_num_overflow (s_scm_log
);
9629 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9631 else if (SCM_BIGP (z
))
9632 return log_of_exact_integer (z
);
9633 else if (SCM_FRACTIONP (z
))
9634 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9635 SCM_FRACTION_DENOMINATOR (z
));
9637 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9642 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9644 "Return the base 10 logarithm of @var{z}.")
9645 #define FUNC_NAME s_scm_log10
9647 if (SCM_COMPLEXP (z
))
9649 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9650 clog() and a multiply by M_LOG10E, rather than the fallback
9651 log10+hypot+atan2.) */
9652 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9653 && defined SCM_COMPLEX_VALUE
9654 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9656 double re
= SCM_COMPLEX_REAL (z
);
9657 double im
= SCM_COMPLEX_IMAG (z
);
9658 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9659 M_LOG10E
* atan2 (im
, re
));
9662 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9664 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9665 if (scm_is_eq (z
, SCM_INUM0
))
9666 scm_num_overflow (s_scm_log10
);
9669 double re
= scm_to_double (z
);
9670 double l
= log10 (fabs (re
));
9671 if (re
> 0.0 || double_is_non_negative_zero (re
))
9672 return scm_from_double (l
);
9674 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9677 else if (SCM_BIGP (z
))
9678 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9679 else if (SCM_FRACTIONP (z
))
9680 return scm_product (flo_log10e
,
9681 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9682 SCM_FRACTION_DENOMINATOR (z
)));
9684 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9689 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9691 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9692 "base of natural logarithms (2.71828@dots{}).")
9693 #define FUNC_NAME s_scm_exp
9695 if (SCM_COMPLEXP (z
))
9697 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9698 && defined (SCM_COMPLEX_VALUE)
9699 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9701 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9702 SCM_COMPLEX_IMAG (z
));
9705 else if (SCM_NUMBERP (z
))
9707 /* When z is a negative bignum the conversion to double overflows,
9708 giving -infinity, but that's ok, the exp is still 0.0. */
9709 return scm_from_double (exp (scm_to_double (z
)));
9712 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9717 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9719 "Return two exact non-negative integers @var{s} and @var{r}\n"
9720 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9721 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9722 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9725 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9727 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9731 scm_exact_integer_sqrt (k
, &s
, &r
);
9732 return scm_values (scm_list_2 (s
, r
));
9737 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9739 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9741 scm_t_inum kk
= SCM_I_INUM (k
);
9745 if (SCM_LIKELY (kk
> 0))
9750 uu
= (ss
+ kk
/ss
) / 2;
9752 *sp
= SCM_I_MAKINUM (ss
);
9753 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9755 else if (SCM_LIKELY (kk
== 0))
9756 *sp
= *rp
= SCM_INUM0
;
9758 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9759 "exact non-negative integer");
9761 else if (SCM_LIKELY (SCM_BIGP (k
)))
9765 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9766 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9767 "exact non-negative integer");
9770 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9771 scm_remember_upto_here_1 (k
);
9772 *sp
= scm_i_normbig (s
);
9773 *rp
= scm_i_normbig (r
);
9776 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9777 "exact non-negative integer");
9781 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9783 "Return the square root of @var{z}. Of the two possible roots\n"
9784 "(positive and negative), the one with positive real part\n"
9785 "is returned, or if that's zero then a positive imaginary part.\n"
9789 "(sqrt 9.0) @result{} 3.0\n"
9790 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9791 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9792 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9794 #define FUNC_NAME s_scm_sqrt
9796 if (SCM_COMPLEXP (z
))
9798 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9799 && defined SCM_COMPLEX_VALUE
9800 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9802 double re
= SCM_COMPLEX_REAL (z
);
9803 double im
= SCM_COMPLEX_IMAG (z
);
9804 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9805 0.5 * atan2 (im
, re
));
9808 else if (SCM_NUMBERP (z
))
9810 double xx
= scm_to_double (z
);
9812 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9814 return scm_from_double (sqrt (xx
));
9817 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9828 if (scm_install_gmp_memory_functions
)
9829 mp_set_memory_functions (custom_gmp_malloc
,
9833 mpz_init_set_si (z_negative_one
, -1);
9835 /* It may be possible to tune the performance of some algorithms by using
9836 * the following constants to avoid the creation of bignums. Please, before
9837 * using these values, remember the two rules of program optimization:
9838 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9839 scm_c_define ("most-positive-fixnum",
9840 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9841 scm_c_define ("most-negative-fixnum",
9842 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9844 scm_add_feature ("complex");
9845 scm_add_feature ("inexact");
9846 flo0
= scm_from_double (0.0);
9847 flo_log10e
= scm_from_double (M_LOG10E
);
9849 /* determine floating point precision */
9850 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9852 init_dblprec(&scm_dblprec
[i
-2],i
);
9853 init_fx_radix(fx_per_radix
[i
-2],i
);
9856 /* hard code precision for base 10 if the preprocessor tells us to... */
9857 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9860 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9861 #include "libguile/numbers.x"