1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 /* FIXME: We assume that FLT_RADIX is 2 */
85 verify (FLT_RADIX
== 2);
87 typedef scm_t_signed_bits scm_t_inum
;
88 #define scm_from_inum(x) (scm_from_signed_integer (x))
90 /* Tests to see if a C double is neither infinite nor a NaN.
91 TODO: if it's available, use C99's isfinite(x) instead */
92 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
94 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
95 of the infinity, but other platforms return a boolean only. */
96 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
97 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
102 Wonder if this might be faster for some of our code? A switch on
103 the numtag would jump directly to the right case, and the
104 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
106 #define SCM_I_NUMTAG_NOTNUM 0
107 #define SCM_I_NUMTAG_INUM 1
108 #define SCM_I_NUMTAG_BIG scm_tc16_big
109 #define SCM_I_NUMTAG_REAL scm_tc16_real
110 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
111 #define SCM_I_NUMTAG(x) \
112 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
113 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
114 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
115 : SCM_I_NUMTAG_NOTNUM)))
117 /* the macro above will not work as is with fractions */
120 /* Default to 1, because as we used to hard-code `free' as the
121 deallocator, we know that overriding these functions with
122 instrumented `malloc' / `free' is OK. */
123 int scm_install_gmp_memory_functions
= 1;
125 static SCM exactly_one_half
;
126 static SCM flo_log10e
;
128 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
130 /* FLOBUFLEN is the maximum number of characters neccessary for the
131 * printed or scm_string representation of an inexact number.
133 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
136 #if !defined (HAVE_ASINH)
137 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
139 #if !defined (HAVE_ACOSH)
140 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
142 #if !defined (HAVE_ATANH)
143 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
146 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
147 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
148 in March 2006), mpz_cmp_d now handles infinities properly. */
150 #define xmpz_cmp_d(z, d) \
151 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
153 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
157 #if defined (GUILE_I)
158 #if defined HAVE_COMPLEX_DOUBLE
160 /* For an SCM object Z which is a complex number (ie. satisfies
161 SCM_COMPLEXP), return its value as a C level "complex double". */
162 #define SCM_COMPLEX_VALUE(z) \
163 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
165 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
167 /* Convert a C "complex double" to an SCM value. */
169 scm_from_complex_double (complex double z
)
171 return scm_c_make_rectangular (creal (z
), cimag (z
));
174 #endif /* HAVE_COMPLEX_DOUBLE */
179 static mpz_t z_negative_one
;
183 /* Clear the `mpz_t' embedded in bignum PTR. */
185 finalize_bignum (void *ptr
, void *data
)
189 bignum
= PTR2SCM (ptr
);
190 mpz_clear (SCM_I_BIG_MPZ (bignum
));
193 /* The next three functions (custom_libgmp_*) are passed to
194 mp_set_memory_functions (in GMP) so that memory used by the digits
195 themselves is known to the garbage collector. This is needed so
196 that GC will be run at appropriate times. Otherwise, a program which
197 creates many large bignums would malloc a huge amount of memory
198 before the GC runs. */
200 custom_gmp_malloc (size_t alloc_size
)
202 return scm_malloc (alloc_size
);
206 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
208 return scm_realloc (old_ptr
, new_size
);
212 custom_gmp_free (void *ptr
, size_t size
)
218 /* Return a new uninitialized bignum. */
224 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
225 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
229 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
238 /* Return a newly created bignum. */
239 SCM z
= make_bignum ();
240 mpz_init (SCM_I_BIG_MPZ (z
));
245 scm_i_inum2big (scm_t_inum x
)
247 /* Return a newly created bignum initialized to X. */
248 SCM z
= make_bignum ();
249 #if SIZEOF_VOID_P == SIZEOF_LONG
250 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
252 /* Note that in this case, you'll also have to check all mpz_*_ui and
253 mpz_*_si invocations in Guile. */
254 #error creation of mpz not implemented for this inum size
260 scm_i_long2big (long x
)
262 /* Return a newly created bignum initialized to X. */
263 SCM z
= make_bignum ();
264 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
269 scm_i_ulong2big (unsigned long x
)
271 /* Return a newly created bignum initialized to X. */
272 SCM z
= make_bignum ();
273 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
278 scm_i_clonebig (SCM src_big
, int same_sign_p
)
280 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
281 SCM z
= make_bignum ();
282 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
284 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
289 scm_i_bigcmp (SCM x
, SCM y
)
291 /* Return neg if x < y, pos if x > y, and 0 if x == y */
292 /* presume we already know x and y are bignums */
293 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
294 scm_remember_upto_here_2 (x
, y
);
299 scm_i_dbl2big (double d
)
301 /* results are only defined if d is an integer */
302 SCM z
= make_bignum ();
303 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
307 /* Convert a integer in double representation to a SCM number. */
310 scm_i_dbl2num (double u
)
312 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
313 powers of 2, so there's no rounding when making "double" values
314 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
315 get rounded on a 64-bit machine, hence the "+1".
317 The use of floor() to force to an integer value ensures we get a
318 "numerically closest" value without depending on how a
319 double->long cast or how mpz_set_d will round. For reference,
320 double->long probably follows the hardware rounding mode,
321 mpz_set_d truncates towards zero. */
323 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
324 representable as a double? */
326 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
327 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
328 return SCM_I_MAKINUM ((scm_t_inum
) u
);
330 return scm_i_dbl2big (u
);
333 static SCM
round_right_shift_exact_integer (SCM n
, long count
);
335 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
336 bignum b into a normalized significand and exponent such that
337 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
338 The return value is the significand rounded to the closest
339 representable double, and the exponent is placed into *expon_p.
340 If b is zero, then the returned exponent and significand are both
344 scm_i_big2dbl_2exp (SCM b
, long *expon_p
)
346 size_t bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
349 if (bits
> DBL_MANT_DIG
)
351 shift
= bits
- DBL_MANT_DIG
;
352 b
= round_right_shift_exact_integer (b
, shift
);
356 double signif
= frexp (SCM_I_INUM (b
), &expon
);
357 *expon_p
= expon
+ shift
;
364 double signif
= mpz_get_d_2exp (&expon
, SCM_I_BIG_MPZ (b
));
365 scm_remember_upto_here_1 (b
);
366 *expon_p
= expon
+ shift
;
371 /* scm_i_big2dbl() rounds to the closest representable double,
372 in accordance with R5RS exact->inexact. */
374 scm_i_big2dbl (SCM b
)
377 double signif
= scm_i_big2dbl_2exp (b
, &expon
);
378 return ldexp (signif
, expon
);
382 scm_i_normbig (SCM b
)
384 /* convert a big back to a fixnum if it'll fit */
385 /* presume b is a bignum */
386 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
388 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
389 if (SCM_FIXABLE (val
))
390 b
= SCM_I_MAKINUM (val
);
395 static SCM_C_INLINE_KEYWORD SCM
396 scm_i_mpz2num (mpz_t b
)
398 /* convert a mpz number to a SCM number. */
399 if (mpz_fits_slong_p (b
))
401 scm_t_inum val
= mpz_get_si (b
);
402 if (SCM_FIXABLE (val
))
403 return SCM_I_MAKINUM (val
);
407 SCM z
= make_bignum ();
408 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
413 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
414 static SCM
scm_divide2real (SCM x
, SCM y
);
416 /* Make the ratio NUMERATOR/DENOMINATOR, where:
417 1. NUMERATOR and DENOMINATOR are exact integers
418 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
420 scm_i_make_ratio_already_reduced (SCM numerator
, SCM denominator
)
422 /* Flip signs so that the denominator is positive. */
423 if (scm_is_false (scm_positive_p (denominator
)))
425 if (SCM_UNLIKELY (scm_is_eq (denominator
, SCM_INUM0
)))
426 scm_num_overflow ("make-ratio");
429 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
430 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
434 /* Check for the integer case */
435 if (scm_is_eq (denominator
, SCM_INUM1
))
438 return scm_double_cell (scm_tc16_fraction
,
439 SCM_UNPACK (numerator
),
440 SCM_UNPACK (denominator
), 0);
443 static SCM
scm_exact_integer_quotient (SCM x
, SCM y
);
445 /* Make the ratio NUMERATOR/DENOMINATOR */
447 scm_i_make_ratio (SCM numerator
, SCM denominator
)
448 #define FUNC_NAME "make-ratio"
450 /* Make sure the arguments are proper */
451 if (!SCM_LIKELY (SCM_I_INUMP (numerator
) || SCM_BIGP (numerator
)))
452 SCM_WRONG_TYPE_ARG (1, numerator
);
453 else if (!SCM_LIKELY (SCM_I_INUMP (denominator
) || SCM_BIGP (denominator
)))
454 SCM_WRONG_TYPE_ARG (2, denominator
);
457 SCM the_gcd
= scm_gcd (numerator
, denominator
);
458 if (!(scm_is_eq (the_gcd
, SCM_INUM1
)))
460 /* Reduce to lowest terms */
461 numerator
= scm_exact_integer_quotient (numerator
, the_gcd
);
462 denominator
= scm_exact_integer_quotient (denominator
, the_gcd
);
464 return scm_i_make_ratio_already_reduced (numerator
, denominator
);
470 scm_i_fraction2double (SCM z
)
472 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
473 SCM_FRACTION_DENOMINATOR (z
)));
477 double_is_non_negative_zero (double x
)
479 static double zero
= 0.0;
481 return !memcmp (&x
, &zero
, sizeof(double));
484 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
486 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
488 #define FUNC_NAME s_scm_exact_p
490 if (SCM_INEXACTP (x
))
492 else if (SCM_NUMBERP (x
))
495 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
500 scm_is_exact (SCM val
)
502 return scm_is_true (scm_exact_p (val
));
505 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
507 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
509 #define FUNC_NAME s_scm_inexact_p
511 if (SCM_INEXACTP (x
))
513 else if (SCM_NUMBERP (x
))
516 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
521 scm_is_inexact (SCM val
)
523 return scm_is_true (scm_inexact_p (val
));
526 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
528 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
530 #define FUNC_NAME s_scm_odd_p
534 scm_t_inum val
= SCM_I_INUM (n
);
535 return scm_from_bool ((val
& 1L) != 0);
537 else if (SCM_BIGP (n
))
539 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
540 scm_remember_upto_here_1 (n
);
541 return scm_from_bool (odd_p
);
543 else if (SCM_REALP (n
))
545 double val
= SCM_REAL_VALUE (n
);
546 if (DOUBLE_IS_FINITE (val
))
548 double rem
= fabs (fmod (val
, 2.0));
555 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
560 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
562 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
564 #define FUNC_NAME s_scm_even_p
568 scm_t_inum val
= SCM_I_INUM (n
);
569 return scm_from_bool ((val
& 1L) == 0);
571 else if (SCM_BIGP (n
))
573 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
574 scm_remember_upto_here_1 (n
);
575 return scm_from_bool (even_p
);
577 else if (SCM_REALP (n
))
579 double val
= SCM_REAL_VALUE (n
);
580 if (DOUBLE_IS_FINITE (val
))
582 double rem
= fabs (fmod (val
, 2.0));
589 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
593 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
595 "Return @code{#t} if the real number @var{x} is neither\n"
596 "infinite nor a NaN, @code{#f} otherwise.")
597 #define FUNC_NAME s_scm_finite_p
600 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
601 else if (scm_is_real (x
))
604 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
608 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
610 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
611 "@samp{-inf.0}. Otherwise return @code{#f}.")
612 #define FUNC_NAME s_scm_inf_p
615 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
616 else if (scm_is_real (x
))
619 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
623 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
625 "Return @code{#t} if the real number @var{x} is a NaN,\n"
626 "or @code{#f} otherwise.")
627 #define FUNC_NAME s_scm_nan_p
630 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
631 else if (scm_is_real (x
))
634 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
638 /* Guile's idea of infinity. */
639 static double guile_Inf
;
641 /* Guile's idea of not a number. */
642 static double guile_NaN
;
645 guile_ieee_init (void)
647 /* Some version of gcc on some old version of Linux used to crash when
648 trying to make Inf and NaN. */
651 /* C99 INFINITY, when available.
652 FIXME: The standard allows for INFINITY to be something that overflows
653 at compile time. We ought to have a configure test to check for that
654 before trying to use it. (But in practice we believe this is not a
655 problem on any system guile is likely to target.) */
656 guile_Inf
= INFINITY
;
657 #elif defined HAVE_DINFINITY
659 extern unsigned int DINFINITY
[2];
660 guile_Inf
= (*((double *) (DINFINITY
)));
667 if (guile_Inf
== tmp
)
674 /* C99 NAN, when available */
676 #elif defined HAVE_DQNAN
679 extern unsigned int DQNAN
[2];
680 guile_NaN
= (*((double *)(DQNAN
)));
683 guile_NaN
= guile_Inf
/ guile_Inf
;
687 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
690 #define FUNC_NAME s_scm_inf
692 static int initialized
= 0;
698 return scm_from_double (guile_Inf
);
702 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
705 #define FUNC_NAME s_scm_nan
707 static int initialized
= 0;
713 return scm_from_double (guile_NaN
);
718 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
720 "Return the absolute value of @var{x}.")
721 #define FUNC_NAME s_scm_abs
725 scm_t_inum xx
= SCM_I_INUM (x
);
728 else if (SCM_POSFIXABLE (-xx
))
729 return SCM_I_MAKINUM (-xx
);
731 return scm_i_inum2big (-xx
);
733 else if (SCM_LIKELY (SCM_REALP (x
)))
735 double xx
= SCM_REAL_VALUE (x
);
736 /* If x is a NaN then xx<0 is false so we return x unchanged */
738 return scm_from_double (-xx
);
739 /* Handle signed zeroes properly */
740 else if (SCM_UNLIKELY (xx
== 0.0))
745 else if (SCM_BIGP (x
))
747 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
749 return scm_i_clonebig (x
, 0);
753 else if (SCM_FRACTIONP (x
))
755 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
757 return scm_i_make_ratio_already_reduced
758 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
759 SCM_FRACTION_DENOMINATOR (x
));
762 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
767 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
769 "Return the quotient of the numbers @var{x} and @var{y}.")
770 #define FUNC_NAME s_scm_quotient
772 if (SCM_LIKELY (scm_is_integer (x
)))
774 if (SCM_LIKELY (scm_is_integer (y
)))
775 return scm_truncate_quotient (x
, y
);
777 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
780 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
784 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
786 "Return the remainder of the numbers @var{x} and @var{y}.\n"
788 "(remainder 13 4) @result{} 1\n"
789 "(remainder -13 4) @result{} -1\n"
791 #define FUNC_NAME s_scm_remainder
793 if (SCM_LIKELY (scm_is_integer (x
)))
795 if (SCM_LIKELY (scm_is_integer (y
)))
796 return scm_truncate_remainder (x
, y
);
798 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
801 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
806 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
808 "Return the modulo of the numbers @var{x} and @var{y}.\n"
810 "(modulo 13 4) @result{} 1\n"
811 "(modulo -13 4) @result{} 3\n"
813 #define FUNC_NAME s_scm_modulo
815 if (SCM_LIKELY (scm_is_integer (x
)))
817 if (SCM_LIKELY (scm_is_integer (y
)))
818 return scm_floor_remainder (x
, y
);
820 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
823 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
827 /* Return the exact integer q such that n = q*d, for exact integers n
828 and d, where d is known in advance to divide n evenly (with zero
829 remainder). For large integers, this can be computed more
830 efficiently than when the remainder is unknown. */
832 scm_exact_integer_quotient (SCM n
, SCM d
)
833 #define FUNC_NAME "exact-integer-quotient"
835 if (SCM_LIKELY (SCM_I_INUMP (n
)))
837 scm_t_inum nn
= SCM_I_INUM (n
);
838 if (SCM_LIKELY (SCM_I_INUMP (d
)))
840 scm_t_inum dd
= SCM_I_INUM (d
);
841 if (SCM_UNLIKELY (dd
== 0))
842 scm_num_overflow ("exact-integer-quotient");
845 scm_t_inum qq
= nn
/ dd
;
846 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
847 return SCM_I_MAKINUM (qq
);
849 return scm_i_inum2big (qq
);
852 else if (SCM_LIKELY (SCM_BIGP (d
)))
854 /* n is an inum and d is a bignum. Given that d is known to
855 divide n evenly, there are only two possibilities: n is 0,
856 or else n is fixnum-min and d is abs(fixnum-min). */
860 return SCM_I_MAKINUM (-1);
863 SCM_WRONG_TYPE_ARG (2, d
);
865 else if (SCM_LIKELY (SCM_BIGP (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");
872 else if (SCM_UNLIKELY (dd
== 1))
876 SCM q
= scm_i_mkbig ();
878 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), dd
);
881 mpz_divexact_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), -dd
);
882 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
884 scm_remember_upto_here_1 (n
);
885 return scm_i_normbig (q
);
888 else if (SCM_LIKELY (SCM_BIGP (d
)))
890 SCM q
= scm_i_mkbig ();
891 mpz_divexact (SCM_I_BIG_MPZ (q
),
894 scm_remember_upto_here_2 (n
, d
);
895 return scm_i_normbig (q
);
898 SCM_WRONG_TYPE_ARG (2, d
);
901 SCM_WRONG_TYPE_ARG (1, n
);
905 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
906 two-valued functions. It is called from primitive generics that take
907 two arguments and return two values, when the core procedure is
908 unable to handle the given argument types. If there are GOOPS
909 methods for this primitive generic, it dispatches to GOOPS and, if
910 successful, expects two values to be returned, which are placed in
911 *rp1 and *rp2. If there are no GOOPS methods, it throws a
912 wrong-type-arg exception.
914 FIXME: This obviously belongs somewhere else, but until we decide on
915 the right API, it is here as a static function, because it is needed
916 by the *_divide functions below.
919 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
920 const char *subr
, SCM
*rp1
, SCM
*rp2
)
923 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
925 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
928 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
930 "Return the integer @var{q} such that\n"
931 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
932 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
934 "(euclidean-quotient 123 10) @result{} 12\n"
935 "(euclidean-quotient 123 -10) @result{} -12\n"
936 "(euclidean-quotient -123 10) @result{} -13\n"
937 "(euclidean-quotient -123 -10) @result{} 13\n"
938 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
939 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
941 #define FUNC_NAME s_scm_euclidean_quotient
943 if (scm_is_false (scm_negative_p (y
)))
944 return scm_floor_quotient (x
, y
);
946 return scm_ceiling_quotient (x
, y
);
950 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
952 "Return the real number @var{r} such that\n"
953 "@math{0 <= @var{r} < abs(@var{y})} and\n"
954 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
955 "for some integer @var{q}.\n"
957 "(euclidean-remainder 123 10) @result{} 3\n"
958 "(euclidean-remainder 123 -10) @result{} 3\n"
959 "(euclidean-remainder -123 10) @result{} 7\n"
960 "(euclidean-remainder -123 -10) @result{} 7\n"
961 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
962 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
964 #define FUNC_NAME s_scm_euclidean_remainder
966 if (scm_is_false (scm_negative_p (y
)))
967 return scm_floor_remainder (x
, y
);
969 return scm_ceiling_remainder (x
, y
);
973 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
975 "Return the integer @var{q} and the real number @var{r}\n"
976 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
977 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
979 "(euclidean/ 123 10) @result{} 12 and 3\n"
980 "(euclidean/ 123 -10) @result{} -12 and 3\n"
981 "(euclidean/ -123 10) @result{} -13 and 7\n"
982 "(euclidean/ -123 -10) @result{} 13 and 7\n"
983 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
984 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
986 #define FUNC_NAME s_scm_i_euclidean_divide
988 if (scm_is_false (scm_negative_p (y
)))
989 return scm_i_floor_divide (x
, y
);
991 return scm_i_ceiling_divide (x
, y
);
996 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
998 if (scm_is_false (scm_negative_p (y
)))
999 return scm_floor_divide (x
, y
, qp
, rp
);
1001 return scm_ceiling_divide (x
, y
, qp
, rp
);
1004 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
1005 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
1007 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1009 "Return the floor of @math{@var{x} / @var{y}}.\n"
1011 "(floor-quotient 123 10) @result{} 12\n"
1012 "(floor-quotient 123 -10) @result{} -13\n"
1013 "(floor-quotient -123 10) @result{} -13\n"
1014 "(floor-quotient -123 -10) @result{} 12\n"
1015 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1016 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1018 #define FUNC_NAME s_scm_floor_quotient
1020 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1022 scm_t_inum xx
= SCM_I_INUM (x
);
1023 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1025 scm_t_inum yy
= SCM_I_INUM (y
);
1026 scm_t_inum xx1
= xx
;
1028 if (SCM_LIKELY (yy
> 0))
1030 if (SCM_UNLIKELY (xx
< 0))
1033 else if (SCM_UNLIKELY (yy
== 0))
1034 scm_num_overflow (s_scm_floor_quotient
);
1038 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1039 return SCM_I_MAKINUM (qq
);
1041 return scm_i_inum2big (qq
);
1043 else if (SCM_BIGP (y
))
1045 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1046 scm_remember_upto_here_1 (y
);
1048 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1050 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1052 else if (SCM_REALP (y
))
1053 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1054 else if (SCM_FRACTIONP (y
))
1055 return scm_i_exact_rational_floor_quotient (x
, y
);
1057 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1058 s_scm_floor_quotient
);
1060 else if (SCM_BIGP (x
))
1062 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1064 scm_t_inum yy
= SCM_I_INUM (y
);
1065 if (SCM_UNLIKELY (yy
== 0))
1066 scm_num_overflow (s_scm_floor_quotient
);
1067 else if (SCM_UNLIKELY (yy
== 1))
1071 SCM q
= scm_i_mkbig ();
1073 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1076 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1077 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1079 scm_remember_upto_here_1 (x
);
1080 return scm_i_normbig (q
);
1083 else if (SCM_BIGP (y
))
1085 SCM q
= scm_i_mkbig ();
1086 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1089 scm_remember_upto_here_2 (x
, y
);
1090 return scm_i_normbig (q
);
1092 else if (SCM_REALP (y
))
1093 return scm_i_inexact_floor_quotient
1094 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1095 else if (SCM_FRACTIONP (y
))
1096 return scm_i_exact_rational_floor_quotient (x
, y
);
1098 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1099 s_scm_floor_quotient
);
1101 else if (SCM_REALP (x
))
1103 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1104 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1105 return scm_i_inexact_floor_quotient
1106 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1108 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1109 s_scm_floor_quotient
);
1111 else if (SCM_FRACTIONP (x
))
1114 return scm_i_inexact_floor_quotient
1115 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1116 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1117 return scm_i_exact_rational_floor_quotient (x
, y
);
1119 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1120 s_scm_floor_quotient
);
1123 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1124 s_scm_floor_quotient
);
1129 scm_i_inexact_floor_quotient (double x
, double y
)
1131 if (SCM_UNLIKELY (y
== 0))
1132 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1134 return scm_from_double (floor (x
/ y
));
1138 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1140 return scm_floor_quotient
1141 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1142 scm_product (scm_numerator (y
), scm_denominator (x
)));
1145 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1146 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1148 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1150 "Return the real number @var{r} such that\n"
1151 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1152 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1154 "(floor-remainder 123 10) @result{} 3\n"
1155 "(floor-remainder 123 -10) @result{} -7\n"
1156 "(floor-remainder -123 10) @result{} 7\n"
1157 "(floor-remainder -123 -10) @result{} -3\n"
1158 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1159 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1161 #define FUNC_NAME s_scm_floor_remainder
1163 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1165 scm_t_inum xx
= SCM_I_INUM (x
);
1166 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1168 scm_t_inum yy
= SCM_I_INUM (y
);
1169 if (SCM_UNLIKELY (yy
== 0))
1170 scm_num_overflow (s_scm_floor_remainder
);
1173 scm_t_inum rr
= xx
% yy
;
1174 int needs_adjustment
;
1176 if (SCM_LIKELY (yy
> 0))
1177 needs_adjustment
= (rr
< 0);
1179 needs_adjustment
= (rr
> 0);
1181 if (needs_adjustment
)
1183 return SCM_I_MAKINUM (rr
);
1186 else if (SCM_BIGP (y
))
1188 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1189 scm_remember_upto_here_1 (y
);
1194 SCM r
= scm_i_mkbig ();
1195 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1196 scm_remember_upto_here_1 (y
);
1197 return scm_i_normbig (r
);
1206 SCM r
= scm_i_mkbig ();
1207 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1208 scm_remember_upto_here_1 (y
);
1209 return scm_i_normbig (r
);
1212 else if (SCM_REALP (y
))
1213 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1214 else if (SCM_FRACTIONP (y
))
1215 return scm_i_exact_rational_floor_remainder (x
, y
);
1217 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1218 s_scm_floor_remainder
);
1220 else if (SCM_BIGP (x
))
1222 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1224 scm_t_inum yy
= SCM_I_INUM (y
);
1225 if (SCM_UNLIKELY (yy
== 0))
1226 scm_num_overflow (s_scm_floor_remainder
);
1231 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1233 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1234 scm_remember_upto_here_1 (x
);
1235 return SCM_I_MAKINUM (rr
);
1238 else if (SCM_BIGP (y
))
1240 SCM r
= scm_i_mkbig ();
1241 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1244 scm_remember_upto_here_2 (x
, y
);
1245 return scm_i_normbig (r
);
1247 else if (SCM_REALP (y
))
1248 return scm_i_inexact_floor_remainder
1249 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1250 else if (SCM_FRACTIONP (y
))
1251 return scm_i_exact_rational_floor_remainder (x
, y
);
1253 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1254 s_scm_floor_remainder
);
1256 else if (SCM_REALP (x
))
1258 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1259 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1260 return scm_i_inexact_floor_remainder
1261 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1263 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1264 s_scm_floor_remainder
);
1266 else if (SCM_FRACTIONP (x
))
1269 return scm_i_inexact_floor_remainder
1270 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1271 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1272 return scm_i_exact_rational_floor_remainder (x
, y
);
1274 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1275 s_scm_floor_remainder
);
1278 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1279 s_scm_floor_remainder
);
1284 scm_i_inexact_floor_remainder (double x
, double y
)
1286 /* Although it would be more efficient to use fmod here, we can't
1287 because it would in some cases produce results inconsistent with
1288 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1289 close). In particular, when x is very close to a multiple of y,
1290 then r might be either 0.0 or y, but those two cases must
1291 correspond to different choices of q. If r = 0.0 then q must be
1292 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1293 and remainder chooses the other, it would be bad. */
1294 if (SCM_UNLIKELY (y
== 0))
1295 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1297 return scm_from_double (x
- y
* floor (x
/ y
));
1301 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1303 SCM xd
= scm_denominator (x
);
1304 SCM yd
= scm_denominator (y
);
1305 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1306 scm_product (scm_numerator (y
), xd
));
1307 return scm_divide (r1
, scm_product (xd
, yd
));
1311 static void scm_i_inexact_floor_divide (double x
, double y
,
1313 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1316 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1318 "Return the integer @var{q} and the real number @var{r}\n"
1319 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1320 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1322 "(floor/ 123 10) @result{} 12 and 3\n"
1323 "(floor/ 123 -10) @result{} -13 and -7\n"
1324 "(floor/ -123 10) @result{} -13 and 7\n"
1325 "(floor/ -123 -10) @result{} 12 and -3\n"
1326 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1327 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1329 #define FUNC_NAME s_scm_i_floor_divide
1333 scm_floor_divide(x
, y
, &q
, &r
);
1334 return scm_values (scm_list_2 (q
, r
));
1338 #define s_scm_floor_divide s_scm_i_floor_divide
1339 #define g_scm_floor_divide g_scm_i_floor_divide
1342 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1344 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1346 scm_t_inum xx
= SCM_I_INUM (x
);
1347 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1349 scm_t_inum yy
= SCM_I_INUM (y
);
1350 if (SCM_UNLIKELY (yy
== 0))
1351 scm_num_overflow (s_scm_floor_divide
);
1354 scm_t_inum qq
= xx
/ yy
;
1355 scm_t_inum rr
= xx
% yy
;
1356 int needs_adjustment
;
1358 if (SCM_LIKELY (yy
> 0))
1359 needs_adjustment
= (rr
< 0);
1361 needs_adjustment
= (rr
> 0);
1363 if (needs_adjustment
)
1369 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1370 *qp
= SCM_I_MAKINUM (qq
);
1372 *qp
= scm_i_inum2big (qq
);
1373 *rp
= SCM_I_MAKINUM (rr
);
1377 else if (SCM_BIGP (y
))
1379 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1380 scm_remember_upto_here_1 (y
);
1385 SCM r
= scm_i_mkbig ();
1386 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1387 scm_remember_upto_here_1 (y
);
1388 *qp
= SCM_I_MAKINUM (-1);
1389 *rp
= scm_i_normbig (r
);
1404 SCM r
= scm_i_mkbig ();
1405 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1406 scm_remember_upto_here_1 (y
);
1407 *qp
= SCM_I_MAKINUM (-1);
1408 *rp
= scm_i_normbig (r
);
1412 else if (SCM_REALP (y
))
1413 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1414 else if (SCM_FRACTIONP (y
))
1415 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1417 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1418 s_scm_floor_divide
, qp
, rp
);
1420 else if (SCM_BIGP (x
))
1422 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1424 scm_t_inum yy
= SCM_I_INUM (y
);
1425 if (SCM_UNLIKELY (yy
== 0))
1426 scm_num_overflow (s_scm_floor_divide
);
1429 SCM q
= scm_i_mkbig ();
1430 SCM r
= scm_i_mkbig ();
1432 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1433 SCM_I_BIG_MPZ (x
), yy
);
1436 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1437 SCM_I_BIG_MPZ (x
), -yy
);
1438 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1440 scm_remember_upto_here_1 (x
);
1441 *qp
= scm_i_normbig (q
);
1442 *rp
= scm_i_normbig (r
);
1446 else if (SCM_BIGP (y
))
1448 SCM q
= scm_i_mkbig ();
1449 SCM r
= scm_i_mkbig ();
1450 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1451 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1452 scm_remember_upto_here_2 (x
, y
);
1453 *qp
= scm_i_normbig (q
);
1454 *rp
= scm_i_normbig (r
);
1457 else if (SCM_REALP (y
))
1458 return scm_i_inexact_floor_divide
1459 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1460 else if (SCM_FRACTIONP (y
))
1461 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1463 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1464 s_scm_floor_divide
, qp
, rp
);
1466 else if (SCM_REALP (x
))
1468 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1469 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1470 return scm_i_inexact_floor_divide
1471 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1473 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1474 s_scm_floor_divide
, qp
, rp
);
1476 else if (SCM_FRACTIONP (x
))
1479 return scm_i_inexact_floor_divide
1480 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1481 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1482 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1484 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1485 s_scm_floor_divide
, qp
, rp
);
1488 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1489 s_scm_floor_divide
, qp
, rp
);
1493 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1495 if (SCM_UNLIKELY (y
== 0))
1496 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1499 double q
= floor (x
/ y
);
1500 double r
= x
- q
* y
;
1501 *qp
= scm_from_double (q
);
1502 *rp
= scm_from_double (r
);
1507 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1510 SCM xd
= scm_denominator (x
);
1511 SCM yd
= scm_denominator (y
);
1513 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1514 scm_product (scm_numerator (y
), xd
),
1516 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1519 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1520 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1522 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1524 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1526 "(ceiling-quotient 123 10) @result{} 13\n"
1527 "(ceiling-quotient 123 -10) @result{} -12\n"
1528 "(ceiling-quotient -123 10) @result{} -12\n"
1529 "(ceiling-quotient -123 -10) @result{} 13\n"
1530 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1531 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1533 #define FUNC_NAME s_scm_ceiling_quotient
1535 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1537 scm_t_inum xx
= SCM_I_INUM (x
);
1538 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1540 scm_t_inum yy
= SCM_I_INUM (y
);
1541 if (SCM_UNLIKELY (yy
== 0))
1542 scm_num_overflow (s_scm_ceiling_quotient
);
1545 scm_t_inum xx1
= xx
;
1547 if (SCM_LIKELY (yy
> 0))
1549 if (SCM_LIKELY (xx
>= 0))
1555 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1556 return SCM_I_MAKINUM (qq
);
1558 return scm_i_inum2big (qq
);
1561 else if (SCM_BIGP (y
))
1563 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1564 scm_remember_upto_here_1 (y
);
1565 if (SCM_LIKELY (sign
> 0))
1567 if (SCM_LIKELY (xx
> 0))
1569 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1570 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1571 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1573 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1574 scm_remember_upto_here_1 (y
);
1575 return SCM_I_MAKINUM (-1);
1585 else if (SCM_REALP (y
))
1586 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1587 else if (SCM_FRACTIONP (y
))
1588 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1590 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1591 s_scm_ceiling_quotient
);
1593 else if (SCM_BIGP (x
))
1595 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1597 scm_t_inum yy
= SCM_I_INUM (y
);
1598 if (SCM_UNLIKELY (yy
== 0))
1599 scm_num_overflow (s_scm_ceiling_quotient
);
1600 else if (SCM_UNLIKELY (yy
== 1))
1604 SCM q
= scm_i_mkbig ();
1606 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1609 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1610 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1612 scm_remember_upto_here_1 (x
);
1613 return scm_i_normbig (q
);
1616 else if (SCM_BIGP (y
))
1618 SCM q
= scm_i_mkbig ();
1619 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1622 scm_remember_upto_here_2 (x
, y
);
1623 return scm_i_normbig (q
);
1625 else if (SCM_REALP (y
))
1626 return scm_i_inexact_ceiling_quotient
1627 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1628 else if (SCM_FRACTIONP (y
))
1629 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1631 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1632 s_scm_ceiling_quotient
);
1634 else if (SCM_REALP (x
))
1636 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1637 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1638 return scm_i_inexact_ceiling_quotient
1639 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1641 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1642 s_scm_ceiling_quotient
);
1644 else if (SCM_FRACTIONP (x
))
1647 return scm_i_inexact_ceiling_quotient
1648 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1649 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1650 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1652 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1653 s_scm_ceiling_quotient
);
1656 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1657 s_scm_ceiling_quotient
);
1662 scm_i_inexact_ceiling_quotient (double x
, double y
)
1664 if (SCM_UNLIKELY (y
== 0))
1665 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1667 return scm_from_double (ceil (x
/ y
));
1671 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1673 return scm_ceiling_quotient
1674 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1675 scm_product (scm_numerator (y
), scm_denominator (x
)));
1678 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1679 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1681 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1683 "Return the real number @var{r} such that\n"
1684 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1685 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1687 "(ceiling-remainder 123 10) @result{} -7\n"
1688 "(ceiling-remainder 123 -10) @result{} 3\n"
1689 "(ceiling-remainder -123 10) @result{} -3\n"
1690 "(ceiling-remainder -123 -10) @result{} 7\n"
1691 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1692 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1694 #define FUNC_NAME s_scm_ceiling_remainder
1696 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1698 scm_t_inum xx
= SCM_I_INUM (x
);
1699 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1701 scm_t_inum yy
= SCM_I_INUM (y
);
1702 if (SCM_UNLIKELY (yy
== 0))
1703 scm_num_overflow (s_scm_ceiling_remainder
);
1706 scm_t_inum rr
= xx
% yy
;
1707 int needs_adjustment
;
1709 if (SCM_LIKELY (yy
> 0))
1710 needs_adjustment
= (rr
> 0);
1712 needs_adjustment
= (rr
< 0);
1714 if (needs_adjustment
)
1716 return SCM_I_MAKINUM (rr
);
1719 else if (SCM_BIGP (y
))
1721 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1722 scm_remember_upto_here_1 (y
);
1723 if (SCM_LIKELY (sign
> 0))
1725 if (SCM_LIKELY (xx
> 0))
1727 SCM r
= scm_i_mkbig ();
1728 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1729 scm_remember_upto_here_1 (y
);
1730 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1731 return scm_i_normbig (r
);
1733 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1734 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1735 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1737 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1738 scm_remember_upto_here_1 (y
);
1748 SCM r
= scm_i_mkbig ();
1749 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1750 scm_remember_upto_here_1 (y
);
1751 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1752 return scm_i_normbig (r
);
1755 else if (SCM_REALP (y
))
1756 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1757 else if (SCM_FRACTIONP (y
))
1758 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1760 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1761 s_scm_ceiling_remainder
);
1763 else if (SCM_BIGP (x
))
1765 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1767 scm_t_inum yy
= SCM_I_INUM (y
);
1768 if (SCM_UNLIKELY (yy
== 0))
1769 scm_num_overflow (s_scm_ceiling_remainder
);
1774 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1776 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1777 scm_remember_upto_here_1 (x
);
1778 return SCM_I_MAKINUM (rr
);
1781 else if (SCM_BIGP (y
))
1783 SCM r
= scm_i_mkbig ();
1784 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1787 scm_remember_upto_here_2 (x
, y
);
1788 return scm_i_normbig (r
);
1790 else if (SCM_REALP (y
))
1791 return scm_i_inexact_ceiling_remainder
1792 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1793 else if (SCM_FRACTIONP (y
))
1794 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1796 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1797 s_scm_ceiling_remainder
);
1799 else if (SCM_REALP (x
))
1801 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1802 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1803 return scm_i_inexact_ceiling_remainder
1804 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1806 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1807 s_scm_ceiling_remainder
);
1809 else if (SCM_FRACTIONP (x
))
1812 return scm_i_inexact_ceiling_remainder
1813 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1814 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1815 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1817 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1818 s_scm_ceiling_remainder
);
1821 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1822 s_scm_ceiling_remainder
);
1827 scm_i_inexact_ceiling_remainder (double x
, double y
)
1829 /* Although it would be more efficient to use fmod here, we can't
1830 because it would in some cases produce results inconsistent with
1831 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1832 close). In particular, when x is very close to a multiple of y,
1833 then r might be either 0.0 or -y, but those two cases must
1834 correspond to different choices of q. If r = 0.0 then q must be
1835 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1836 and remainder chooses the other, it would be bad. */
1837 if (SCM_UNLIKELY (y
== 0))
1838 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1840 return scm_from_double (x
- y
* ceil (x
/ y
));
1844 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1846 SCM xd
= scm_denominator (x
);
1847 SCM yd
= scm_denominator (y
);
1848 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1849 scm_product (scm_numerator (y
), xd
));
1850 return scm_divide (r1
, scm_product (xd
, yd
));
1853 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1855 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1858 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1860 "Return the integer @var{q} and the real number @var{r}\n"
1861 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1862 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1864 "(ceiling/ 123 10) @result{} 13 and -7\n"
1865 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1866 "(ceiling/ -123 10) @result{} -12 and -3\n"
1867 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1868 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1869 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1871 #define FUNC_NAME s_scm_i_ceiling_divide
1875 scm_ceiling_divide(x
, y
, &q
, &r
);
1876 return scm_values (scm_list_2 (q
, r
));
1880 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1881 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1884 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1886 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1888 scm_t_inum xx
= SCM_I_INUM (x
);
1889 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1891 scm_t_inum yy
= SCM_I_INUM (y
);
1892 if (SCM_UNLIKELY (yy
== 0))
1893 scm_num_overflow (s_scm_ceiling_divide
);
1896 scm_t_inum qq
= xx
/ yy
;
1897 scm_t_inum rr
= xx
% yy
;
1898 int needs_adjustment
;
1900 if (SCM_LIKELY (yy
> 0))
1901 needs_adjustment
= (rr
> 0);
1903 needs_adjustment
= (rr
< 0);
1905 if (needs_adjustment
)
1910 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1911 *qp
= SCM_I_MAKINUM (qq
);
1913 *qp
= scm_i_inum2big (qq
);
1914 *rp
= SCM_I_MAKINUM (rr
);
1918 else if (SCM_BIGP (y
))
1920 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1921 scm_remember_upto_here_1 (y
);
1922 if (SCM_LIKELY (sign
> 0))
1924 if (SCM_LIKELY (xx
> 0))
1926 SCM r
= scm_i_mkbig ();
1927 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1928 scm_remember_upto_here_1 (y
);
1929 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1931 *rp
= scm_i_normbig (r
);
1933 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1934 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1935 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1937 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1938 scm_remember_upto_here_1 (y
);
1939 *qp
= SCM_I_MAKINUM (-1);
1955 SCM r
= scm_i_mkbig ();
1956 mpz_add_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
);
1964 else if (SCM_REALP (y
))
1965 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1966 else if (SCM_FRACTIONP (y
))
1967 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1969 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1970 s_scm_ceiling_divide
, qp
, rp
);
1972 else if (SCM_BIGP (x
))
1974 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1976 scm_t_inum yy
= SCM_I_INUM (y
);
1977 if (SCM_UNLIKELY (yy
== 0))
1978 scm_num_overflow (s_scm_ceiling_divide
);
1981 SCM q
= scm_i_mkbig ();
1982 SCM r
= scm_i_mkbig ();
1984 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1985 SCM_I_BIG_MPZ (x
), yy
);
1988 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1989 SCM_I_BIG_MPZ (x
), -yy
);
1990 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1992 scm_remember_upto_here_1 (x
);
1993 *qp
= scm_i_normbig (q
);
1994 *rp
= scm_i_normbig (r
);
1998 else if (SCM_BIGP (y
))
2000 SCM q
= scm_i_mkbig ();
2001 SCM r
= scm_i_mkbig ();
2002 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2003 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2004 scm_remember_upto_here_2 (x
, y
);
2005 *qp
= scm_i_normbig (q
);
2006 *rp
= scm_i_normbig (r
);
2009 else if (SCM_REALP (y
))
2010 return scm_i_inexact_ceiling_divide
2011 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2012 else if (SCM_FRACTIONP (y
))
2013 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2015 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2016 s_scm_ceiling_divide
, qp
, rp
);
2018 else if (SCM_REALP (x
))
2020 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2021 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2022 return scm_i_inexact_ceiling_divide
2023 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2025 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2026 s_scm_ceiling_divide
, qp
, rp
);
2028 else if (SCM_FRACTIONP (x
))
2031 return scm_i_inexact_ceiling_divide
2032 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2033 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2034 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2036 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2037 s_scm_ceiling_divide
, qp
, rp
);
2040 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2041 s_scm_ceiling_divide
, qp
, rp
);
2045 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2047 if (SCM_UNLIKELY (y
== 0))
2048 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2051 double q
= ceil (x
/ y
);
2052 double r
= x
- q
* y
;
2053 *qp
= scm_from_double (q
);
2054 *rp
= scm_from_double (r
);
2059 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2062 SCM xd
= scm_denominator (x
);
2063 SCM yd
= scm_denominator (y
);
2065 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2066 scm_product (scm_numerator (y
), xd
),
2068 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2071 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2072 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2074 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2076 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2078 "(truncate-quotient 123 10) @result{} 12\n"
2079 "(truncate-quotient 123 -10) @result{} -12\n"
2080 "(truncate-quotient -123 10) @result{} -12\n"
2081 "(truncate-quotient -123 -10) @result{} 12\n"
2082 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2083 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2085 #define FUNC_NAME s_scm_truncate_quotient
2087 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2089 scm_t_inum xx
= SCM_I_INUM (x
);
2090 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2092 scm_t_inum yy
= SCM_I_INUM (y
);
2093 if (SCM_UNLIKELY (yy
== 0))
2094 scm_num_overflow (s_scm_truncate_quotient
);
2097 scm_t_inum qq
= xx
/ yy
;
2098 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2099 return SCM_I_MAKINUM (qq
);
2101 return scm_i_inum2big (qq
);
2104 else if (SCM_BIGP (y
))
2106 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2107 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2108 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2110 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2111 scm_remember_upto_here_1 (y
);
2112 return SCM_I_MAKINUM (-1);
2117 else if (SCM_REALP (y
))
2118 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2119 else if (SCM_FRACTIONP (y
))
2120 return scm_i_exact_rational_truncate_quotient (x
, y
);
2122 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2123 s_scm_truncate_quotient
);
2125 else if (SCM_BIGP (x
))
2127 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2129 scm_t_inum yy
= SCM_I_INUM (y
);
2130 if (SCM_UNLIKELY (yy
== 0))
2131 scm_num_overflow (s_scm_truncate_quotient
);
2132 else if (SCM_UNLIKELY (yy
== 1))
2136 SCM q
= scm_i_mkbig ();
2138 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2141 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2142 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2144 scm_remember_upto_here_1 (x
);
2145 return scm_i_normbig (q
);
2148 else if (SCM_BIGP (y
))
2150 SCM q
= scm_i_mkbig ();
2151 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2154 scm_remember_upto_here_2 (x
, y
);
2155 return scm_i_normbig (q
);
2157 else if (SCM_REALP (y
))
2158 return scm_i_inexact_truncate_quotient
2159 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2160 else if (SCM_FRACTIONP (y
))
2161 return scm_i_exact_rational_truncate_quotient (x
, y
);
2163 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2164 s_scm_truncate_quotient
);
2166 else if (SCM_REALP (x
))
2168 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2169 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2170 return scm_i_inexact_truncate_quotient
2171 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2173 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2174 s_scm_truncate_quotient
);
2176 else if (SCM_FRACTIONP (x
))
2179 return scm_i_inexact_truncate_quotient
2180 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2181 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2182 return scm_i_exact_rational_truncate_quotient (x
, y
);
2184 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2185 s_scm_truncate_quotient
);
2188 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2189 s_scm_truncate_quotient
);
2194 scm_i_inexact_truncate_quotient (double x
, double y
)
2196 if (SCM_UNLIKELY (y
== 0))
2197 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2199 return scm_from_double (trunc (x
/ y
));
2203 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2205 return scm_truncate_quotient
2206 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2207 scm_product (scm_numerator (y
), scm_denominator (x
)));
2210 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2211 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2213 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2215 "Return the real number @var{r} such that\n"
2216 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2217 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2219 "(truncate-remainder 123 10) @result{} 3\n"
2220 "(truncate-remainder 123 -10) @result{} 3\n"
2221 "(truncate-remainder -123 10) @result{} -3\n"
2222 "(truncate-remainder -123 -10) @result{} -3\n"
2223 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2224 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2226 #define FUNC_NAME s_scm_truncate_remainder
2228 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2230 scm_t_inum xx
= SCM_I_INUM (x
);
2231 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2233 scm_t_inum yy
= SCM_I_INUM (y
);
2234 if (SCM_UNLIKELY (yy
== 0))
2235 scm_num_overflow (s_scm_truncate_remainder
);
2237 return SCM_I_MAKINUM (xx
% yy
);
2239 else if (SCM_BIGP (y
))
2241 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2242 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2243 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2245 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2246 scm_remember_upto_here_1 (y
);
2252 else if (SCM_REALP (y
))
2253 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2254 else if (SCM_FRACTIONP (y
))
2255 return scm_i_exact_rational_truncate_remainder (x
, y
);
2257 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2258 s_scm_truncate_remainder
);
2260 else if (SCM_BIGP (x
))
2262 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2264 scm_t_inum yy
= SCM_I_INUM (y
);
2265 if (SCM_UNLIKELY (yy
== 0))
2266 scm_num_overflow (s_scm_truncate_remainder
);
2269 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2270 (yy
> 0) ? yy
: -yy
)
2271 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2272 scm_remember_upto_here_1 (x
);
2273 return SCM_I_MAKINUM (rr
);
2276 else if (SCM_BIGP (y
))
2278 SCM r
= scm_i_mkbig ();
2279 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2282 scm_remember_upto_here_2 (x
, y
);
2283 return scm_i_normbig (r
);
2285 else if (SCM_REALP (y
))
2286 return scm_i_inexact_truncate_remainder
2287 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2288 else if (SCM_FRACTIONP (y
))
2289 return scm_i_exact_rational_truncate_remainder (x
, y
);
2291 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2292 s_scm_truncate_remainder
);
2294 else if (SCM_REALP (x
))
2296 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2297 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2298 return scm_i_inexact_truncate_remainder
2299 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2301 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2302 s_scm_truncate_remainder
);
2304 else if (SCM_FRACTIONP (x
))
2307 return scm_i_inexact_truncate_remainder
2308 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2309 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2310 return scm_i_exact_rational_truncate_remainder (x
, y
);
2312 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2313 s_scm_truncate_remainder
);
2316 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2317 s_scm_truncate_remainder
);
2322 scm_i_inexact_truncate_remainder (double x
, double y
)
2324 /* Although it would be more efficient to use fmod here, we can't
2325 because it would in some cases produce results inconsistent with
2326 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2327 close). In particular, when x is very close to a multiple of y,
2328 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2329 correspond to different choices of q. If quotient chooses one and
2330 remainder chooses the other, it would be bad. */
2331 if (SCM_UNLIKELY (y
== 0))
2332 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2334 return scm_from_double (x
- y
* trunc (x
/ y
));
2338 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2340 SCM xd
= scm_denominator (x
);
2341 SCM yd
= scm_denominator (y
);
2342 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2343 scm_product (scm_numerator (y
), xd
));
2344 return scm_divide (r1
, scm_product (xd
, yd
));
2348 static void scm_i_inexact_truncate_divide (double x
, double y
,
2350 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2353 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2355 "Return the integer @var{q} and the real number @var{r}\n"
2356 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2357 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2359 "(truncate/ 123 10) @result{} 12 and 3\n"
2360 "(truncate/ 123 -10) @result{} -12 and 3\n"
2361 "(truncate/ -123 10) @result{} -12 and -3\n"
2362 "(truncate/ -123 -10) @result{} 12 and -3\n"
2363 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2364 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2366 #define FUNC_NAME s_scm_i_truncate_divide
2370 scm_truncate_divide(x
, y
, &q
, &r
);
2371 return scm_values (scm_list_2 (q
, r
));
2375 #define s_scm_truncate_divide s_scm_i_truncate_divide
2376 #define g_scm_truncate_divide g_scm_i_truncate_divide
2379 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2381 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2383 scm_t_inum xx
= SCM_I_INUM (x
);
2384 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2386 scm_t_inum yy
= SCM_I_INUM (y
);
2387 if (SCM_UNLIKELY (yy
== 0))
2388 scm_num_overflow (s_scm_truncate_divide
);
2391 scm_t_inum qq
= xx
/ yy
;
2392 scm_t_inum rr
= xx
% yy
;
2393 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2394 *qp
= SCM_I_MAKINUM (qq
);
2396 *qp
= scm_i_inum2big (qq
);
2397 *rp
= SCM_I_MAKINUM (rr
);
2401 else if (SCM_BIGP (y
))
2403 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2404 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2405 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2407 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2408 scm_remember_upto_here_1 (y
);
2409 *qp
= SCM_I_MAKINUM (-1);
2419 else if (SCM_REALP (y
))
2420 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2421 else if (SCM_FRACTIONP (y
))
2422 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2424 return two_valued_wta_dispatch_2
2425 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2426 s_scm_truncate_divide
, qp
, rp
);
2428 else if (SCM_BIGP (x
))
2430 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2432 scm_t_inum yy
= SCM_I_INUM (y
);
2433 if (SCM_UNLIKELY (yy
== 0))
2434 scm_num_overflow (s_scm_truncate_divide
);
2437 SCM q
= scm_i_mkbig ();
2440 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2441 SCM_I_BIG_MPZ (x
), yy
);
2444 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2445 SCM_I_BIG_MPZ (x
), -yy
);
2446 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2448 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2449 scm_remember_upto_here_1 (x
);
2450 *qp
= scm_i_normbig (q
);
2451 *rp
= SCM_I_MAKINUM (rr
);
2455 else if (SCM_BIGP (y
))
2457 SCM q
= scm_i_mkbig ();
2458 SCM r
= scm_i_mkbig ();
2459 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2460 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2461 scm_remember_upto_here_2 (x
, y
);
2462 *qp
= scm_i_normbig (q
);
2463 *rp
= scm_i_normbig (r
);
2465 else if (SCM_REALP (y
))
2466 return scm_i_inexact_truncate_divide
2467 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2468 else if (SCM_FRACTIONP (y
))
2469 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2471 return two_valued_wta_dispatch_2
2472 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2473 s_scm_truncate_divide
, qp
, rp
);
2475 else if (SCM_REALP (x
))
2477 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2478 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2479 return scm_i_inexact_truncate_divide
2480 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2482 return two_valued_wta_dispatch_2
2483 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2484 s_scm_truncate_divide
, qp
, rp
);
2486 else if (SCM_FRACTIONP (x
))
2489 return scm_i_inexact_truncate_divide
2490 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2491 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2492 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2494 return two_valued_wta_dispatch_2
2495 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2496 s_scm_truncate_divide
, qp
, rp
);
2499 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2500 s_scm_truncate_divide
, qp
, rp
);
2504 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2506 if (SCM_UNLIKELY (y
== 0))
2507 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2510 double q
= trunc (x
/ y
);
2511 double r
= x
- q
* y
;
2512 *qp
= scm_from_double (q
);
2513 *rp
= scm_from_double (r
);
2518 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2521 SCM xd
= scm_denominator (x
);
2522 SCM yd
= scm_denominator (y
);
2524 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2525 scm_product (scm_numerator (y
), xd
),
2527 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2530 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2531 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2532 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2534 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2536 "Return the integer @var{q} such that\n"
2537 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2538 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2540 "(centered-quotient 123 10) @result{} 12\n"
2541 "(centered-quotient 123 -10) @result{} -12\n"
2542 "(centered-quotient -123 10) @result{} -12\n"
2543 "(centered-quotient -123 -10) @result{} 12\n"
2544 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2545 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2547 #define FUNC_NAME s_scm_centered_quotient
2549 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2551 scm_t_inum xx
= SCM_I_INUM (x
);
2552 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2554 scm_t_inum yy
= SCM_I_INUM (y
);
2555 if (SCM_UNLIKELY (yy
== 0))
2556 scm_num_overflow (s_scm_centered_quotient
);
2559 scm_t_inum qq
= xx
/ yy
;
2560 scm_t_inum rr
= xx
% yy
;
2561 if (SCM_LIKELY (xx
> 0))
2563 if (SCM_LIKELY (yy
> 0))
2565 if (rr
>= (yy
+ 1) / 2)
2570 if (rr
>= (1 - yy
) / 2)
2576 if (SCM_LIKELY (yy
> 0))
2587 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2588 return SCM_I_MAKINUM (qq
);
2590 return scm_i_inum2big (qq
);
2593 else if (SCM_BIGP (y
))
2595 /* Pass a denormalized bignum version of x (even though it
2596 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2597 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2599 else if (SCM_REALP (y
))
2600 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2601 else if (SCM_FRACTIONP (y
))
2602 return scm_i_exact_rational_centered_quotient (x
, y
);
2604 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2605 s_scm_centered_quotient
);
2607 else if (SCM_BIGP (x
))
2609 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2611 scm_t_inum yy
= SCM_I_INUM (y
);
2612 if (SCM_UNLIKELY (yy
== 0))
2613 scm_num_overflow (s_scm_centered_quotient
);
2614 else if (SCM_UNLIKELY (yy
== 1))
2618 SCM q
= scm_i_mkbig ();
2620 /* Arrange for rr to initially be non-positive,
2621 because that simplifies the test to see
2622 if it is within the needed bounds. */
2625 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2626 SCM_I_BIG_MPZ (x
), yy
);
2627 scm_remember_upto_here_1 (x
);
2629 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2630 SCM_I_BIG_MPZ (q
), 1);
2634 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2635 SCM_I_BIG_MPZ (x
), -yy
);
2636 scm_remember_upto_here_1 (x
);
2637 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2639 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2640 SCM_I_BIG_MPZ (q
), 1);
2642 return scm_i_normbig (q
);
2645 else if (SCM_BIGP (y
))
2646 return scm_i_bigint_centered_quotient (x
, y
);
2647 else if (SCM_REALP (y
))
2648 return scm_i_inexact_centered_quotient
2649 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2650 else if (SCM_FRACTIONP (y
))
2651 return scm_i_exact_rational_centered_quotient (x
, y
);
2653 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2654 s_scm_centered_quotient
);
2656 else if (SCM_REALP (x
))
2658 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2659 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2660 return scm_i_inexact_centered_quotient
2661 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2663 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2664 s_scm_centered_quotient
);
2666 else if (SCM_FRACTIONP (x
))
2669 return scm_i_inexact_centered_quotient
2670 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2671 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2672 return scm_i_exact_rational_centered_quotient (x
, y
);
2674 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2675 s_scm_centered_quotient
);
2678 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2679 s_scm_centered_quotient
);
2684 scm_i_inexact_centered_quotient (double x
, double y
)
2686 if (SCM_LIKELY (y
> 0))
2687 return scm_from_double (floor (x
/y
+ 0.5));
2688 else if (SCM_LIKELY (y
< 0))
2689 return scm_from_double (ceil (x
/y
- 0.5));
2691 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2696 /* Assumes that both x and y are bigints, though
2697 x might be able to fit into a fixnum. */
2699 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2703 /* Note that x might be small enough to fit into a
2704 fixnum, so we must not let it escape into the wild */
2708 /* min_r will eventually become -abs(y)/2 */
2709 min_r
= scm_i_mkbig ();
2710 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2711 SCM_I_BIG_MPZ (y
), 1);
2713 /* Arrange for rr to initially be non-positive,
2714 because that simplifies the test to see
2715 if it is within the needed bounds. */
2716 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2718 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2719 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2720 scm_remember_upto_here_2 (x
, y
);
2721 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2722 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2723 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2724 SCM_I_BIG_MPZ (q
), 1);
2728 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2729 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2730 scm_remember_upto_here_2 (x
, y
);
2731 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2732 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2733 SCM_I_BIG_MPZ (q
), 1);
2735 scm_remember_upto_here_2 (r
, min_r
);
2736 return scm_i_normbig (q
);
2740 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2742 return scm_centered_quotient
2743 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2744 scm_product (scm_numerator (y
), scm_denominator (x
)));
2747 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2748 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2749 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2751 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2753 "Return the real number @var{r} such that\n"
2754 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2755 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2756 "for some integer @var{q}.\n"
2758 "(centered-remainder 123 10) @result{} 3\n"
2759 "(centered-remainder 123 -10) @result{} 3\n"
2760 "(centered-remainder -123 10) @result{} -3\n"
2761 "(centered-remainder -123 -10) @result{} -3\n"
2762 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2763 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2765 #define FUNC_NAME s_scm_centered_remainder
2767 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2769 scm_t_inum xx
= SCM_I_INUM (x
);
2770 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2772 scm_t_inum yy
= SCM_I_INUM (y
);
2773 if (SCM_UNLIKELY (yy
== 0))
2774 scm_num_overflow (s_scm_centered_remainder
);
2777 scm_t_inum rr
= xx
% yy
;
2778 if (SCM_LIKELY (xx
> 0))
2780 if (SCM_LIKELY (yy
> 0))
2782 if (rr
>= (yy
+ 1) / 2)
2787 if (rr
>= (1 - yy
) / 2)
2793 if (SCM_LIKELY (yy
> 0))
2804 return SCM_I_MAKINUM (rr
);
2807 else if (SCM_BIGP (y
))
2809 /* Pass a denormalized bignum version of x (even though it
2810 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2811 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2813 else if (SCM_REALP (y
))
2814 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2815 else if (SCM_FRACTIONP (y
))
2816 return scm_i_exact_rational_centered_remainder (x
, y
);
2818 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2819 s_scm_centered_remainder
);
2821 else if (SCM_BIGP (x
))
2823 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2825 scm_t_inum yy
= SCM_I_INUM (y
);
2826 if (SCM_UNLIKELY (yy
== 0))
2827 scm_num_overflow (s_scm_centered_remainder
);
2831 /* Arrange for rr to initially be non-positive,
2832 because that simplifies the test to see
2833 if it is within the needed bounds. */
2836 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2837 scm_remember_upto_here_1 (x
);
2843 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2844 scm_remember_upto_here_1 (x
);
2848 return SCM_I_MAKINUM (rr
);
2851 else if (SCM_BIGP (y
))
2852 return scm_i_bigint_centered_remainder (x
, y
);
2853 else if (SCM_REALP (y
))
2854 return scm_i_inexact_centered_remainder
2855 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2856 else if (SCM_FRACTIONP (y
))
2857 return scm_i_exact_rational_centered_remainder (x
, y
);
2859 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2860 s_scm_centered_remainder
);
2862 else if (SCM_REALP (x
))
2864 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2865 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2866 return scm_i_inexact_centered_remainder
2867 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2869 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2870 s_scm_centered_remainder
);
2872 else if (SCM_FRACTIONP (x
))
2875 return scm_i_inexact_centered_remainder
2876 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2877 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2878 return scm_i_exact_rational_centered_remainder (x
, y
);
2880 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2881 s_scm_centered_remainder
);
2884 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2885 s_scm_centered_remainder
);
2890 scm_i_inexact_centered_remainder (double x
, double y
)
2894 /* Although it would be more efficient to use fmod here, we can't
2895 because it would in some cases produce results inconsistent with
2896 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2897 close). In particular, when x-y/2 is very close to a multiple of
2898 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2899 two cases must correspond to different choices of q. If quotient
2900 chooses one and remainder chooses the other, it would be bad. */
2901 if (SCM_LIKELY (y
> 0))
2902 q
= floor (x
/y
+ 0.5);
2903 else if (SCM_LIKELY (y
< 0))
2904 q
= ceil (x
/y
- 0.5);
2906 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2909 return scm_from_double (x
- q
* y
);
2912 /* Assumes that both x and y are bigints, though
2913 x might be able to fit into a fixnum. */
2915 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2919 /* Note that x might be small enough to fit into a
2920 fixnum, so we must not let it escape into the wild */
2923 /* min_r will eventually become -abs(y)/2 */
2924 min_r
= scm_i_mkbig ();
2925 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2926 SCM_I_BIG_MPZ (y
), 1);
2928 /* Arrange for rr to initially be non-positive,
2929 because that simplifies the test to see
2930 if it is within the needed bounds. */
2931 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2933 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2934 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2935 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2936 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2937 mpz_add (SCM_I_BIG_MPZ (r
),
2943 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2944 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2945 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2946 mpz_sub (SCM_I_BIG_MPZ (r
),
2950 scm_remember_upto_here_2 (x
, y
);
2951 return scm_i_normbig (r
);
2955 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2957 SCM xd
= scm_denominator (x
);
2958 SCM yd
= scm_denominator (y
);
2959 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2960 scm_product (scm_numerator (y
), xd
));
2961 return scm_divide (r1
, scm_product (xd
, yd
));
2965 static void scm_i_inexact_centered_divide (double x
, double y
,
2967 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2968 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2971 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2973 "Return the integer @var{q} and the real number @var{r}\n"
2974 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2975 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2977 "(centered/ 123 10) @result{} 12 and 3\n"
2978 "(centered/ 123 -10) @result{} -12 and 3\n"
2979 "(centered/ -123 10) @result{} -12 and -3\n"
2980 "(centered/ -123 -10) @result{} 12 and -3\n"
2981 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2982 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2984 #define FUNC_NAME s_scm_i_centered_divide
2988 scm_centered_divide(x
, y
, &q
, &r
);
2989 return scm_values (scm_list_2 (q
, r
));
2993 #define s_scm_centered_divide s_scm_i_centered_divide
2994 #define g_scm_centered_divide g_scm_i_centered_divide
2997 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2999 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3001 scm_t_inum xx
= SCM_I_INUM (x
);
3002 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3004 scm_t_inum yy
= SCM_I_INUM (y
);
3005 if (SCM_UNLIKELY (yy
== 0))
3006 scm_num_overflow (s_scm_centered_divide
);
3009 scm_t_inum qq
= xx
/ yy
;
3010 scm_t_inum rr
= xx
% yy
;
3011 if (SCM_LIKELY (xx
> 0))
3013 if (SCM_LIKELY (yy
> 0))
3015 if (rr
>= (yy
+ 1) / 2)
3020 if (rr
>= (1 - yy
) / 2)
3026 if (SCM_LIKELY (yy
> 0))
3037 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3038 *qp
= SCM_I_MAKINUM (qq
);
3040 *qp
= scm_i_inum2big (qq
);
3041 *rp
= SCM_I_MAKINUM (rr
);
3045 else if (SCM_BIGP (y
))
3047 /* Pass a denormalized bignum version of x (even though it
3048 can fit in a fixnum) to scm_i_bigint_centered_divide */
3049 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3051 else if (SCM_REALP (y
))
3052 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3053 else if (SCM_FRACTIONP (y
))
3054 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3056 return two_valued_wta_dispatch_2
3057 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3058 s_scm_centered_divide
, qp
, rp
);
3060 else if (SCM_BIGP (x
))
3062 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3064 scm_t_inum yy
= SCM_I_INUM (y
);
3065 if (SCM_UNLIKELY (yy
== 0))
3066 scm_num_overflow (s_scm_centered_divide
);
3069 SCM q
= scm_i_mkbig ();
3071 /* Arrange for rr to initially be non-positive,
3072 because that simplifies the test to see
3073 if it is within the needed bounds. */
3076 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3077 SCM_I_BIG_MPZ (x
), yy
);
3078 scm_remember_upto_here_1 (x
);
3081 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3082 SCM_I_BIG_MPZ (q
), 1);
3088 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3089 SCM_I_BIG_MPZ (x
), -yy
);
3090 scm_remember_upto_here_1 (x
);
3091 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3094 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3095 SCM_I_BIG_MPZ (q
), 1);
3099 *qp
= scm_i_normbig (q
);
3100 *rp
= SCM_I_MAKINUM (rr
);
3104 else if (SCM_BIGP (y
))
3105 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3106 else if (SCM_REALP (y
))
3107 return scm_i_inexact_centered_divide
3108 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3109 else if (SCM_FRACTIONP (y
))
3110 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3112 return two_valued_wta_dispatch_2
3113 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3114 s_scm_centered_divide
, qp
, rp
);
3116 else if (SCM_REALP (x
))
3118 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3119 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3120 return scm_i_inexact_centered_divide
3121 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3123 return two_valued_wta_dispatch_2
3124 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3125 s_scm_centered_divide
, qp
, rp
);
3127 else if (SCM_FRACTIONP (x
))
3130 return scm_i_inexact_centered_divide
3131 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3132 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3133 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3135 return two_valued_wta_dispatch_2
3136 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3137 s_scm_centered_divide
, qp
, rp
);
3140 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3141 s_scm_centered_divide
, qp
, rp
);
3145 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3149 if (SCM_LIKELY (y
> 0))
3150 q
= floor (x
/y
+ 0.5);
3151 else if (SCM_LIKELY (y
< 0))
3152 q
= ceil (x
/y
- 0.5);
3154 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3158 *qp
= scm_from_double (q
);
3159 *rp
= scm_from_double (r
);
3162 /* Assumes that both x and y are bigints, though
3163 x might be able to fit into a fixnum. */
3165 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3169 /* Note that x might be small enough to fit into a
3170 fixnum, so we must not let it escape into the wild */
3174 /* min_r will eventually become -abs(y/2) */
3175 min_r
= scm_i_mkbig ();
3176 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3177 SCM_I_BIG_MPZ (y
), 1);
3179 /* Arrange for rr to initially be non-positive,
3180 because that simplifies the test to see
3181 if it is within the needed bounds. */
3182 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3184 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3185 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3186 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3187 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3189 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3190 SCM_I_BIG_MPZ (q
), 1);
3191 mpz_add (SCM_I_BIG_MPZ (r
),
3198 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3199 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3200 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3202 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3203 SCM_I_BIG_MPZ (q
), 1);
3204 mpz_sub (SCM_I_BIG_MPZ (r
),
3209 scm_remember_upto_here_2 (x
, y
);
3210 *qp
= scm_i_normbig (q
);
3211 *rp
= scm_i_normbig (r
);
3215 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3218 SCM xd
= scm_denominator (x
);
3219 SCM yd
= scm_denominator (y
);
3221 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3222 scm_product (scm_numerator (y
), xd
),
3224 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3227 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3228 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3229 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3231 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3233 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3234 "with ties going to the nearest even integer.\n"
3236 "(round-quotient 123 10) @result{} 12\n"
3237 "(round-quotient 123 -10) @result{} -12\n"
3238 "(round-quotient -123 10) @result{} -12\n"
3239 "(round-quotient -123 -10) @result{} 12\n"
3240 "(round-quotient 125 10) @result{} 12\n"
3241 "(round-quotient 127 10) @result{} 13\n"
3242 "(round-quotient 135 10) @result{} 14\n"
3243 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3244 "(round-quotient 16/3 -10/7) @result{} -4\n"
3246 #define FUNC_NAME s_scm_round_quotient
3248 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3250 scm_t_inum xx
= SCM_I_INUM (x
);
3251 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3253 scm_t_inum yy
= SCM_I_INUM (y
);
3254 if (SCM_UNLIKELY (yy
== 0))
3255 scm_num_overflow (s_scm_round_quotient
);
3258 scm_t_inum qq
= xx
/ yy
;
3259 scm_t_inum rr
= xx
% yy
;
3261 scm_t_inum r2
= 2 * rr
;
3263 if (SCM_LIKELY (yy
< 0))
3283 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3284 return SCM_I_MAKINUM (qq
);
3286 return scm_i_inum2big (qq
);
3289 else if (SCM_BIGP (y
))
3291 /* Pass a denormalized bignum version of x (even though it
3292 can fit in a fixnum) to scm_i_bigint_round_quotient */
3293 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3295 else if (SCM_REALP (y
))
3296 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3297 else if (SCM_FRACTIONP (y
))
3298 return scm_i_exact_rational_round_quotient (x
, y
);
3300 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3301 s_scm_round_quotient
);
3303 else if (SCM_BIGP (x
))
3305 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3307 scm_t_inum yy
= SCM_I_INUM (y
);
3308 if (SCM_UNLIKELY (yy
== 0))
3309 scm_num_overflow (s_scm_round_quotient
);
3310 else if (SCM_UNLIKELY (yy
== 1))
3314 SCM q
= scm_i_mkbig ();
3316 int needs_adjustment
;
3320 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3321 SCM_I_BIG_MPZ (x
), yy
);
3322 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3323 needs_adjustment
= (2*rr
>= yy
);
3325 needs_adjustment
= (2*rr
> yy
);
3329 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3330 SCM_I_BIG_MPZ (x
), -yy
);
3331 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3332 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3333 needs_adjustment
= (2*rr
<= yy
);
3335 needs_adjustment
= (2*rr
< yy
);
3337 scm_remember_upto_here_1 (x
);
3338 if (needs_adjustment
)
3339 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3340 return scm_i_normbig (q
);
3343 else if (SCM_BIGP (y
))
3344 return scm_i_bigint_round_quotient (x
, y
);
3345 else if (SCM_REALP (y
))
3346 return scm_i_inexact_round_quotient
3347 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3348 else if (SCM_FRACTIONP (y
))
3349 return scm_i_exact_rational_round_quotient (x
, y
);
3351 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3352 s_scm_round_quotient
);
3354 else if (SCM_REALP (x
))
3356 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3357 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3358 return scm_i_inexact_round_quotient
3359 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3361 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3362 s_scm_round_quotient
);
3364 else if (SCM_FRACTIONP (x
))
3367 return scm_i_inexact_round_quotient
3368 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3369 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3370 return scm_i_exact_rational_round_quotient (x
, y
);
3372 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3373 s_scm_round_quotient
);
3376 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3377 s_scm_round_quotient
);
3382 scm_i_inexact_round_quotient (double x
, double y
)
3384 if (SCM_UNLIKELY (y
== 0))
3385 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3387 return scm_from_double (scm_c_round (x
/ y
));
3390 /* Assumes that both x and y are bigints, though
3391 x might be able to fit into a fixnum. */
3393 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3396 int cmp
, needs_adjustment
;
3398 /* Note that x might be small enough to fit into a
3399 fixnum, so we must not let it escape into the wild */
3402 r2
= scm_i_mkbig ();
3404 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3405 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3406 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3407 scm_remember_upto_here_2 (x
, r
);
3409 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3410 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3411 needs_adjustment
= (cmp
>= 0);
3413 needs_adjustment
= (cmp
> 0);
3414 scm_remember_upto_here_2 (r2
, y
);
3416 if (needs_adjustment
)
3417 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3419 return scm_i_normbig (q
);
3423 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3425 return scm_round_quotient
3426 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3427 scm_product (scm_numerator (y
), scm_denominator (x
)));
3430 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3431 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3432 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3434 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3436 "Return the real number @var{r} such that\n"
3437 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3438 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3439 "nearest integer, with ties going to the nearest\n"
3442 "(round-remainder 123 10) @result{} 3\n"
3443 "(round-remainder 123 -10) @result{} 3\n"
3444 "(round-remainder -123 10) @result{} -3\n"
3445 "(round-remainder -123 -10) @result{} -3\n"
3446 "(round-remainder 125 10) @result{} 5\n"
3447 "(round-remainder 127 10) @result{} -3\n"
3448 "(round-remainder 135 10) @result{} -5\n"
3449 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3450 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3452 #define FUNC_NAME s_scm_round_remainder
3454 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3456 scm_t_inum xx
= SCM_I_INUM (x
);
3457 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3459 scm_t_inum yy
= SCM_I_INUM (y
);
3460 if (SCM_UNLIKELY (yy
== 0))
3461 scm_num_overflow (s_scm_round_remainder
);
3464 scm_t_inum qq
= xx
/ yy
;
3465 scm_t_inum rr
= xx
% yy
;
3467 scm_t_inum r2
= 2 * rr
;
3469 if (SCM_LIKELY (yy
< 0))
3489 return SCM_I_MAKINUM (rr
);
3492 else if (SCM_BIGP (y
))
3494 /* Pass a denormalized bignum version of x (even though it
3495 can fit in a fixnum) to scm_i_bigint_round_remainder */
3496 return scm_i_bigint_round_remainder
3497 (scm_i_long2big (xx
), y
);
3499 else if (SCM_REALP (y
))
3500 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3501 else if (SCM_FRACTIONP (y
))
3502 return scm_i_exact_rational_round_remainder (x
, y
);
3504 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3505 s_scm_round_remainder
);
3507 else if (SCM_BIGP (x
))
3509 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3511 scm_t_inum yy
= SCM_I_INUM (y
);
3512 if (SCM_UNLIKELY (yy
== 0))
3513 scm_num_overflow (s_scm_round_remainder
);
3516 SCM q
= scm_i_mkbig ();
3518 int needs_adjustment
;
3522 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3523 SCM_I_BIG_MPZ (x
), yy
);
3524 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3525 needs_adjustment
= (2*rr
>= yy
);
3527 needs_adjustment
= (2*rr
> yy
);
3531 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3532 SCM_I_BIG_MPZ (x
), -yy
);
3533 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3534 needs_adjustment
= (2*rr
<= yy
);
3536 needs_adjustment
= (2*rr
< yy
);
3538 scm_remember_upto_here_2 (x
, q
);
3539 if (needs_adjustment
)
3541 return SCM_I_MAKINUM (rr
);
3544 else if (SCM_BIGP (y
))
3545 return scm_i_bigint_round_remainder (x
, y
);
3546 else if (SCM_REALP (y
))
3547 return scm_i_inexact_round_remainder
3548 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3549 else if (SCM_FRACTIONP (y
))
3550 return scm_i_exact_rational_round_remainder (x
, y
);
3552 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3553 s_scm_round_remainder
);
3555 else if (SCM_REALP (x
))
3557 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3558 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3559 return scm_i_inexact_round_remainder
3560 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3562 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3563 s_scm_round_remainder
);
3565 else if (SCM_FRACTIONP (x
))
3568 return scm_i_inexact_round_remainder
3569 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3570 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3571 return scm_i_exact_rational_round_remainder (x
, y
);
3573 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3574 s_scm_round_remainder
);
3577 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3578 s_scm_round_remainder
);
3583 scm_i_inexact_round_remainder (double x
, double y
)
3585 /* Although it would be more efficient to use fmod here, we can't
3586 because it would in some cases produce results inconsistent with
3587 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3588 close). In particular, when x-y/2 is very close to a multiple of
3589 y, then r might be either -abs(y/2) or abs(y/2), but those two
3590 cases must correspond to different choices of q. If quotient
3591 chooses one and remainder chooses the other, it would be bad. */
3593 if (SCM_UNLIKELY (y
== 0))
3594 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3597 double q
= scm_c_round (x
/ y
);
3598 return scm_from_double (x
- q
* y
);
3602 /* Assumes that both x and y are bigints, though
3603 x might be able to fit into a fixnum. */
3605 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3608 int cmp
, needs_adjustment
;
3610 /* Note that x might be small enough to fit into a
3611 fixnum, so we must not let it escape into the wild */
3614 r2
= scm_i_mkbig ();
3616 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3617 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3618 scm_remember_upto_here_1 (x
);
3619 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3621 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3622 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3623 needs_adjustment
= (cmp
>= 0);
3625 needs_adjustment
= (cmp
> 0);
3626 scm_remember_upto_here_2 (q
, r2
);
3628 if (needs_adjustment
)
3629 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3631 scm_remember_upto_here_1 (y
);
3632 return scm_i_normbig (r
);
3636 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3638 SCM xd
= scm_denominator (x
);
3639 SCM yd
= scm_denominator (y
);
3640 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3641 scm_product (scm_numerator (y
), xd
));
3642 return scm_divide (r1
, scm_product (xd
, yd
));
3646 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3647 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3648 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3650 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3652 "Return the integer @var{q} and the real number @var{r}\n"
3653 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3654 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3655 "nearest integer, with ties going to the nearest even integer.\n"
3657 "(round/ 123 10) @result{} 12 and 3\n"
3658 "(round/ 123 -10) @result{} -12 and 3\n"
3659 "(round/ -123 10) @result{} -12 and -3\n"
3660 "(round/ -123 -10) @result{} 12 and -3\n"
3661 "(round/ 125 10) @result{} 12 and 5\n"
3662 "(round/ 127 10) @result{} 13 and -3\n"
3663 "(round/ 135 10) @result{} 14 and -5\n"
3664 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3665 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3667 #define FUNC_NAME s_scm_i_round_divide
3671 scm_round_divide(x
, y
, &q
, &r
);
3672 return scm_values (scm_list_2 (q
, r
));
3676 #define s_scm_round_divide s_scm_i_round_divide
3677 #define g_scm_round_divide g_scm_i_round_divide
3680 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3682 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3684 scm_t_inum xx
= SCM_I_INUM (x
);
3685 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3687 scm_t_inum yy
= SCM_I_INUM (y
);
3688 if (SCM_UNLIKELY (yy
== 0))
3689 scm_num_overflow (s_scm_round_divide
);
3692 scm_t_inum qq
= xx
/ yy
;
3693 scm_t_inum rr
= xx
% yy
;
3695 scm_t_inum r2
= 2 * rr
;
3697 if (SCM_LIKELY (yy
< 0))
3717 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3718 *qp
= SCM_I_MAKINUM (qq
);
3720 *qp
= scm_i_inum2big (qq
);
3721 *rp
= SCM_I_MAKINUM (rr
);
3725 else if (SCM_BIGP (y
))
3727 /* Pass a denormalized bignum version of x (even though it
3728 can fit in a fixnum) to scm_i_bigint_round_divide */
3729 return scm_i_bigint_round_divide
3730 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3732 else if (SCM_REALP (y
))
3733 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3734 else if (SCM_FRACTIONP (y
))
3735 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3737 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3738 s_scm_round_divide
, qp
, rp
);
3740 else if (SCM_BIGP (x
))
3742 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3744 scm_t_inum yy
= SCM_I_INUM (y
);
3745 if (SCM_UNLIKELY (yy
== 0))
3746 scm_num_overflow (s_scm_round_divide
);
3749 SCM q
= scm_i_mkbig ();
3751 int needs_adjustment
;
3755 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3756 SCM_I_BIG_MPZ (x
), yy
);
3757 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3758 needs_adjustment
= (2*rr
>= yy
);
3760 needs_adjustment
= (2*rr
> yy
);
3764 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3765 SCM_I_BIG_MPZ (x
), -yy
);
3766 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3767 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3768 needs_adjustment
= (2*rr
<= yy
);
3770 needs_adjustment
= (2*rr
< yy
);
3772 scm_remember_upto_here_1 (x
);
3773 if (needs_adjustment
)
3775 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3778 *qp
= scm_i_normbig (q
);
3779 *rp
= SCM_I_MAKINUM (rr
);
3783 else if (SCM_BIGP (y
))
3784 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3785 else if (SCM_REALP (y
))
3786 return scm_i_inexact_round_divide
3787 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3788 else if (SCM_FRACTIONP (y
))
3789 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3791 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3792 s_scm_round_divide
, qp
, rp
);
3794 else if (SCM_REALP (x
))
3796 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3797 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3798 return scm_i_inexact_round_divide
3799 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3801 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3802 s_scm_round_divide
, qp
, rp
);
3804 else if (SCM_FRACTIONP (x
))
3807 return scm_i_inexact_round_divide
3808 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3809 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3810 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3812 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3813 s_scm_round_divide
, qp
, rp
);
3816 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3817 s_scm_round_divide
, qp
, rp
);
3821 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3823 if (SCM_UNLIKELY (y
== 0))
3824 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3827 double q
= scm_c_round (x
/ y
);
3828 double r
= x
- q
* y
;
3829 *qp
= scm_from_double (q
);
3830 *rp
= scm_from_double (r
);
3834 /* Assumes that both x and y are bigints, though
3835 x might be able to fit into a fixnum. */
3837 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3840 int cmp
, needs_adjustment
;
3842 /* Note that x might be small enough to fit into a
3843 fixnum, so we must not let it escape into the wild */
3846 r2
= scm_i_mkbig ();
3848 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3849 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3850 scm_remember_upto_here_1 (x
);
3851 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3853 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3854 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3855 needs_adjustment
= (cmp
>= 0);
3857 needs_adjustment
= (cmp
> 0);
3859 if (needs_adjustment
)
3861 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3862 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3865 scm_remember_upto_here_2 (r2
, y
);
3866 *qp
= scm_i_normbig (q
);
3867 *rp
= scm_i_normbig (r
);
3871 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3874 SCM xd
= scm_denominator (x
);
3875 SCM yd
= scm_denominator (y
);
3877 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3878 scm_product (scm_numerator (y
), xd
),
3880 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3884 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3885 (SCM x
, SCM y
, SCM rest
),
3886 "Return the greatest common divisor of all parameter values.\n"
3887 "If called without arguments, 0 is returned.")
3888 #define FUNC_NAME s_scm_i_gcd
3890 while (!scm_is_null (rest
))
3891 { x
= scm_gcd (x
, y
);
3893 rest
= scm_cdr (rest
);
3895 return scm_gcd (x
, y
);
3899 #define s_gcd s_scm_i_gcd
3900 #define g_gcd g_scm_i_gcd
3903 scm_gcd (SCM x
, SCM y
)
3905 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
3906 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3908 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3910 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3912 scm_t_inum xx
= SCM_I_INUM (x
);
3913 scm_t_inum yy
= SCM_I_INUM (y
);
3914 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3915 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3917 if (SCM_UNLIKELY (xx
== 0))
3919 else if (SCM_UNLIKELY (yy
== 0))
3924 /* Determine a common factor 2^k */
3925 while (((u
| v
) & 1) == 0)
3931 /* Now, any factor 2^n can be eliminated */
3933 while ((u
& 1) == 0)
3936 while ((v
& 1) == 0)
3938 /* Both u and v are now odd. Subtract the smaller one
3939 from the larger one to produce an even number, remove
3940 more factors of two, and repeat. */
3946 while ((u
& 1) == 0)
3952 while ((v
& 1) == 0)
3958 return (SCM_POSFIXABLE (result
)
3959 ? SCM_I_MAKINUM (result
)
3960 : scm_i_inum2big (result
));
3962 else if (SCM_BIGP (y
))
3968 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3970 else if (SCM_BIGP (x
))
3972 if (SCM_I_INUMP (y
))
3977 yy
= SCM_I_INUM (y
);
3982 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3983 scm_remember_upto_here_1 (x
);
3984 return (SCM_POSFIXABLE (result
)
3985 ? SCM_I_MAKINUM (result
)
3986 : scm_from_unsigned_integer (result
));
3988 else if (SCM_BIGP (y
))
3990 SCM result
= scm_i_mkbig ();
3991 mpz_gcd (SCM_I_BIG_MPZ (result
),
3994 scm_remember_upto_here_2 (x
, y
);
3995 return scm_i_normbig (result
);
3998 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
4001 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
4004 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
4005 (SCM x
, SCM y
, SCM rest
),
4006 "Return the least common multiple of the arguments.\n"
4007 "If called without arguments, 1 is returned.")
4008 #define FUNC_NAME s_scm_i_lcm
4010 while (!scm_is_null (rest
))
4011 { x
= scm_lcm (x
, y
);
4013 rest
= scm_cdr (rest
);
4015 return scm_lcm (x
, y
);
4019 #define s_lcm s_scm_i_lcm
4020 #define g_lcm g_scm_i_lcm
4023 scm_lcm (SCM n1
, SCM n2
)
4025 if (SCM_UNBNDP (n2
))
4027 if (SCM_UNBNDP (n1
))
4028 return SCM_I_MAKINUM (1L);
4029 n2
= SCM_I_MAKINUM (1L);
4032 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4033 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4034 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4035 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4037 if (SCM_I_INUMP (n1
))
4039 if (SCM_I_INUMP (n2
))
4041 SCM d
= scm_gcd (n1
, n2
);
4042 if (scm_is_eq (d
, SCM_INUM0
))
4045 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4049 /* inum n1, big n2 */
4052 SCM result
= scm_i_mkbig ();
4053 scm_t_inum nn1
= SCM_I_INUM (n1
);
4054 if (nn1
== 0) return SCM_INUM0
;
4055 if (nn1
< 0) nn1
= - nn1
;
4056 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4057 scm_remember_upto_here_1 (n2
);
4065 if (SCM_I_INUMP (n2
))
4072 SCM result
= scm_i_mkbig ();
4073 mpz_lcm(SCM_I_BIG_MPZ (result
),
4075 SCM_I_BIG_MPZ (n2
));
4076 scm_remember_upto_here_2(n1
, n2
);
4077 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4083 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4088 + + + x (map digit:logand X Y)
4089 + - + x (map digit:logand X (lognot (+ -1 Y)))
4090 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4091 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4096 + + + (map digit:logior X Y)
4097 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4098 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4099 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4104 + + + (map digit:logxor X Y)
4105 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4106 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4107 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4112 + + (any digit:logand X Y)
4113 + - (any digit:logand X (lognot (+ -1 Y)))
4114 - + (any digit:logand (lognot (+ -1 X)) Y)
4119 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4120 (SCM x
, SCM y
, SCM rest
),
4121 "Return the bitwise AND of the integer arguments.\n\n"
4123 "(logand) @result{} -1\n"
4124 "(logand 7) @result{} 7\n"
4125 "(logand #b111 #b011 #b001) @result{} 1\n"
4127 #define FUNC_NAME s_scm_i_logand
4129 while (!scm_is_null (rest
))
4130 { x
= scm_logand (x
, y
);
4132 rest
= scm_cdr (rest
);
4134 return scm_logand (x
, y
);
4138 #define s_scm_logand s_scm_i_logand
4140 SCM
scm_logand (SCM n1
, SCM n2
)
4141 #define FUNC_NAME s_scm_logand
4145 if (SCM_UNBNDP (n2
))
4147 if (SCM_UNBNDP (n1
))
4148 return SCM_I_MAKINUM (-1);
4149 else if (!SCM_NUMBERP (n1
))
4150 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4151 else if (SCM_NUMBERP (n1
))
4154 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4157 if (SCM_I_INUMP (n1
))
4159 nn1
= SCM_I_INUM (n1
);
4160 if (SCM_I_INUMP (n2
))
4162 scm_t_inum nn2
= SCM_I_INUM (n2
);
4163 return SCM_I_MAKINUM (nn1
& nn2
);
4165 else if SCM_BIGP (n2
)
4171 SCM result_z
= scm_i_mkbig ();
4173 mpz_init_set_si (nn1_z
, nn1
);
4174 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4175 scm_remember_upto_here_1 (n2
);
4177 return scm_i_normbig (result_z
);
4181 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4183 else if (SCM_BIGP (n1
))
4185 if (SCM_I_INUMP (n2
))
4188 nn1
= SCM_I_INUM (n1
);
4191 else if (SCM_BIGP (n2
))
4193 SCM result_z
= scm_i_mkbig ();
4194 mpz_and (SCM_I_BIG_MPZ (result_z
),
4196 SCM_I_BIG_MPZ (n2
));
4197 scm_remember_upto_here_2 (n1
, n2
);
4198 return scm_i_normbig (result_z
);
4201 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4204 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4209 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4210 (SCM x
, SCM y
, SCM rest
),
4211 "Return the bitwise OR of the integer arguments.\n\n"
4213 "(logior) @result{} 0\n"
4214 "(logior 7) @result{} 7\n"
4215 "(logior #b000 #b001 #b011) @result{} 3\n"
4217 #define FUNC_NAME s_scm_i_logior
4219 while (!scm_is_null (rest
))
4220 { x
= scm_logior (x
, y
);
4222 rest
= scm_cdr (rest
);
4224 return scm_logior (x
, y
);
4228 #define s_scm_logior s_scm_i_logior
4230 SCM
scm_logior (SCM n1
, SCM n2
)
4231 #define FUNC_NAME s_scm_logior
4235 if (SCM_UNBNDP (n2
))
4237 if (SCM_UNBNDP (n1
))
4239 else if (SCM_NUMBERP (n1
))
4242 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4245 if (SCM_I_INUMP (n1
))
4247 nn1
= SCM_I_INUM (n1
);
4248 if (SCM_I_INUMP (n2
))
4250 long nn2
= SCM_I_INUM (n2
);
4251 return SCM_I_MAKINUM (nn1
| nn2
);
4253 else if (SCM_BIGP (n2
))
4259 SCM result_z
= scm_i_mkbig ();
4261 mpz_init_set_si (nn1_z
, nn1
);
4262 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4263 scm_remember_upto_here_1 (n2
);
4265 return scm_i_normbig (result_z
);
4269 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4271 else if (SCM_BIGP (n1
))
4273 if (SCM_I_INUMP (n2
))
4276 nn1
= SCM_I_INUM (n1
);
4279 else if (SCM_BIGP (n2
))
4281 SCM result_z
= scm_i_mkbig ();
4282 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4284 SCM_I_BIG_MPZ (n2
));
4285 scm_remember_upto_here_2 (n1
, n2
);
4286 return scm_i_normbig (result_z
);
4289 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4292 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4297 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4298 (SCM x
, SCM y
, SCM rest
),
4299 "Return the bitwise XOR of the integer arguments. A bit is\n"
4300 "set in the result if it is set in an odd number of arguments.\n"
4302 "(logxor) @result{} 0\n"
4303 "(logxor 7) @result{} 7\n"
4304 "(logxor #b000 #b001 #b011) @result{} 2\n"
4305 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4307 #define FUNC_NAME s_scm_i_logxor
4309 while (!scm_is_null (rest
))
4310 { x
= scm_logxor (x
, y
);
4312 rest
= scm_cdr (rest
);
4314 return scm_logxor (x
, y
);
4318 #define s_scm_logxor s_scm_i_logxor
4320 SCM
scm_logxor (SCM n1
, SCM n2
)
4321 #define FUNC_NAME s_scm_logxor
4325 if (SCM_UNBNDP (n2
))
4327 if (SCM_UNBNDP (n1
))
4329 else if (SCM_NUMBERP (n1
))
4332 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4335 if (SCM_I_INUMP (n1
))
4337 nn1
= SCM_I_INUM (n1
);
4338 if (SCM_I_INUMP (n2
))
4340 scm_t_inum nn2
= SCM_I_INUM (n2
);
4341 return SCM_I_MAKINUM (nn1
^ nn2
);
4343 else if (SCM_BIGP (n2
))
4347 SCM result_z
= scm_i_mkbig ();
4349 mpz_init_set_si (nn1_z
, nn1
);
4350 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4351 scm_remember_upto_here_1 (n2
);
4353 return scm_i_normbig (result_z
);
4357 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4359 else if (SCM_BIGP (n1
))
4361 if (SCM_I_INUMP (n2
))
4364 nn1
= SCM_I_INUM (n1
);
4367 else if (SCM_BIGP (n2
))
4369 SCM result_z
= scm_i_mkbig ();
4370 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4372 SCM_I_BIG_MPZ (n2
));
4373 scm_remember_upto_here_2 (n1
, n2
);
4374 return scm_i_normbig (result_z
);
4377 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4380 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4385 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4387 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4388 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4389 "without actually calculating the @code{logand}, just testing\n"
4393 "(logtest #b0100 #b1011) @result{} #f\n"
4394 "(logtest #b0100 #b0111) @result{} #t\n"
4396 #define FUNC_NAME s_scm_logtest
4400 if (SCM_I_INUMP (j
))
4402 nj
= SCM_I_INUM (j
);
4403 if (SCM_I_INUMP (k
))
4405 scm_t_inum nk
= SCM_I_INUM (k
);
4406 return scm_from_bool (nj
& nk
);
4408 else if (SCM_BIGP (k
))
4416 mpz_init_set_si (nj_z
, nj
);
4417 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4418 scm_remember_upto_here_1 (k
);
4419 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4425 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4427 else if (SCM_BIGP (j
))
4429 if (SCM_I_INUMP (k
))
4432 nj
= SCM_I_INUM (j
);
4435 else if (SCM_BIGP (k
))
4439 mpz_init (result_z
);
4443 scm_remember_upto_here_2 (j
, k
);
4444 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4445 mpz_clear (result_z
);
4449 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4452 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4457 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4459 "Test whether bit number @var{index} in @var{j} is set.\n"
4460 "@var{index} starts from 0 for the least significant bit.\n"
4463 "(logbit? 0 #b1101) @result{} #t\n"
4464 "(logbit? 1 #b1101) @result{} #f\n"
4465 "(logbit? 2 #b1101) @result{} #t\n"
4466 "(logbit? 3 #b1101) @result{} #t\n"
4467 "(logbit? 4 #b1101) @result{} #f\n"
4469 #define FUNC_NAME s_scm_logbit_p
4471 unsigned long int iindex
;
4472 iindex
= scm_to_ulong (index
);
4474 if (SCM_I_INUMP (j
))
4476 /* bits above what's in an inum follow the sign bit */
4477 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4478 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4480 else if (SCM_BIGP (j
))
4482 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4483 scm_remember_upto_here_1 (j
);
4484 return scm_from_bool (val
);
4487 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4492 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4494 "Return the integer which is the ones-complement of the integer\n"
4498 "(number->string (lognot #b10000000) 2)\n"
4499 " @result{} \"-10000001\"\n"
4500 "(number->string (lognot #b0) 2)\n"
4501 " @result{} \"-1\"\n"
4503 #define FUNC_NAME s_scm_lognot
4505 if (SCM_I_INUMP (n
)) {
4506 /* No overflow here, just need to toggle all the bits making up the inum.
4507 Enhancement: No need to strip the tag and add it back, could just xor
4508 a block of 1 bits, if that worked with the various debug versions of
4510 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4512 } else if (SCM_BIGP (n
)) {
4513 SCM result
= scm_i_mkbig ();
4514 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4515 scm_remember_upto_here_1 (n
);
4519 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4524 /* returns 0 if IN is not an integer. OUT must already be
4527 coerce_to_big (SCM in
, mpz_t out
)
4530 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4531 else if (SCM_I_INUMP (in
))
4532 mpz_set_si (out
, SCM_I_INUM (in
));
4539 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4540 (SCM n
, SCM k
, SCM m
),
4541 "Return @var{n} raised to the integer exponent\n"
4542 "@var{k}, modulo @var{m}.\n"
4545 "(modulo-expt 2 3 5)\n"
4548 #define FUNC_NAME s_scm_modulo_expt
4554 /* There are two classes of error we might encounter --
4555 1) Math errors, which we'll report by calling scm_num_overflow,
4557 2) wrong-type errors, which of course we'll report by calling
4559 We don't report those errors immediately, however; instead we do
4560 some cleanup first. These variables tell us which error (if
4561 any) we should report after cleaning up.
4563 int report_overflow
= 0;
4565 int position_of_wrong_type
= 0;
4566 SCM value_of_wrong_type
= SCM_INUM0
;
4568 SCM result
= SCM_UNDEFINED
;
4574 if (scm_is_eq (m
, SCM_INUM0
))
4576 report_overflow
= 1;
4580 if (!coerce_to_big (n
, n_tmp
))
4582 value_of_wrong_type
= n
;
4583 position_of_wrong_type
= 1;
4587 if (!coerce_to_big (k
, k_tmp
))
4589 value_of_wrong_type
= k
;
4590 position_of_wrong_type
= 2;
4594 if (!coerce_to_big (m
, m_tmp
))
4596 value_of_wrong_type
= m
;
4597 position_of_wrong_type
= 3;
4601 /* if the exponent K is negative, and we simply call mpz_powm, we
4602 will get a divide-by-zero exception when an inverse 1/n mod m
4603 doesn't exist (or is not unique). Since exceptions are hard to
4604 handle, we'll attempt the inversion "by hand" -- that way, we get
4605 a simple failure code, which is easy to handle. */
4607 if (-1 == mpz_sgn (k_tmp
))
4609 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4611 report_overflow
= 1;
4614 mpz_neg (k_tmp
, k_tmp
);
4617 result
= scm_i_mkbig ();
4618 mpz_powm (SCM_I_BIG_MPZ (result
),
4623 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4624 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4631 if (report_overflow
)
4632 scm_num_overflow (FUNC_NAME
);
4634 if (position_of_wrong_type
)
4635 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4636 value_of_wrong_type
);
4638 return scm_i_normbig (result
);
4642 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4644 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4645 "exact integer, @var{n} can be any number.\n"
4647 "Negative @var{k} is supported, and results in\n"
4648 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4649 "@math{@var{n}^0} is 1, as usual, and that\n"
4650 "includes @math{0^0} is 1.\n"
4653 "(integer-expt 2 5) @result{} 32\n"
4654 "(integer-expt -3 3) @result{} -27\n"
4655 "(integer-expt 5 -3) @result{} 1/125\n"
4656 "(integer-expt 0 0) @result{} 1\n"
4658 #define FUNC_NAME s_scm_integer_expt
4661 SCM z_i2
= SCM_BOOL_F
;
4663 SCM acc
= SCM_I_MAKINUM (1L);
4665 /* Specifically refrain from checking the type of the first argument.
4666 This allows us to exponentiate any object that can be multiplied.
4667 If we must raise to a negative power, we must also be able to
4668 take its reciprocal. */
4669 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4670 SCM_WRONG_TYPE_ARG (2, k
);
4672 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4673 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4674 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4675 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4676 /* The next check is necessary only because R6RS specifies different
4677 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4678 we simply skip this case and move on. */
4679 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4681 /* k cannot be 0 at this point, because we
4682 have already checked for that case above */
4683 if (scm_is_true (scm_positive_p (k
)))
4685 else /* return NaN for (0 ^ k) for negative k per R6RS */
4688 else if (SCM_FRACTIONP (n
))
4690 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4691 needless reduction of intermediate products to lowest terms.
4692 If a and b have no common factors, then a^k and b^k have no
4693 common factors. Use 'scm_i_make_ratio_already_reduced' to
4694 construct the final result, so that no gcd computations are
4695 needed to exponentiate a fraction. */
4696 if (scm_is_true (scm_positive_p (k
)))
4697 return scm_i_make_ratio_already_reduced
4698 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
),
4699 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
));
4702 k
= scm_difference (k
, SCM_UNDEFINED
);
4703 return scm_i_make_ratio_already_reduced
4704 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n
), k
),
4705 scm_integer_expt (SCM_FRACTION_NUMERATOR (n
), k
));
4709 if (SCM_I_INUMP (k
))
4710 i2
= SCM_I_INUM (k
);
4711 else if (SCM_BIGP (k
))
4713 z_i2
= scm_i_clonebig (k
, 1);
4714 scm_remember_upto_here_1 (k
);
4718 SCM_WRONG_TYPE_ARG (2, k
);
4722 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4724 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4725 n
= scm_divide (n
, SCM_UNDEFINED
);
4729 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4733 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4735 return scm_product (acc
, n
);
4737 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4738 acc
= scm_product (acc
, n
);
4739 n
= scm_product (n
, n
);
4740 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4748 n
= scm_divide (n
, SCM_UNDEFINED
);
4755 return scm_product (acc
, n
);
4757 acc
= scm_product (acc
, n
);
4758 n
= scm_product (n
, n
);
4765 /* Efficiently compute (N * 2^COUNT),
4766 where N is an exact integer, and COUNT > 0. */
4768 left_shift_exact_integer (SCM n
, long count
)
4770 if (SCM_I_INUMP (n
))
4772 scm_t_inum nn
= SCM_I_INUM (n
);
4774 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
4775 overflow a non-zero fixnum. For smaller shifts we check the
4776 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4777 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4778 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
4782 else if (count
< SCM_I_FIXNUM_BIT
-1 &&
4783 ((scm_t_bits
) (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - count
)) + 1)
4785 return SCM_I_MAKINUM (nn
<< count
);
4788 SCM result
= scm_i_inum2big (nn
);
4789 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4794 else if (SCM_BIGP (n
))
4796 SCM result
= scm_i_mkbig ();
4797 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
), count
);
4798 scm_remember_upto_here_1 (n
);
4802 scm_syserror ("left_shift_exact_integer");
4805 /* Efficiently compute floor (N / 2^COUNT),
4806 where N is an exact integer and COUNT > 0. */
4808 floor_right_shift_exact_integer (SCM n
, long count
)
4810 if (SCM_I_INUMP (n
))
4812 scm_t_inum nn
= SCM_I_INUM (n
);
4814 if (count
>= SCM_I_FIXNUM_BIT
)
4815 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM (-1));
4817 return SCM_I_MAKINUM (SCM_SRS (nn
, count
));
4819 else if (SCM_BIGP (n
))
4821 SCM result
= scm_i_mkbig ();
4822 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4824 scm_remember_upto_here_1 (n
);
4825 return scm_i_normbig (result
);
4828 scm_syserror ("floor_right_shift_exact_integer");
4831 /* Efficiently compute round (N / 2^COUNT),
4832 where N is an exact integer and COUNT > 0. */
4834 round_right_shift_exact_integer (SCM n
, long count
)
4836 if (SCM_I_INUMP (n
))
4838 if (count
>= SCM_I_FIXNUM_BIT
)
4842 scm_t_inum nn
= SCM_I_INUM (n
);
4843 scm_t_inum qq
= SCM_SRS (nn
, count
);
4845 if (0 == (nn
& (1L << (count
-1))))
4846 return SCM_I_MAKINUM (qq
); /* round down */
4847 else if (nn
& ((1L << (count
-1)) - 1))
4848 return SCM_I_MAKINUM (qq
+ 1); /* round up */
4850 return SCM_I_MAKINUM ((~1L) & (qq
+ 1)); /* round to even */
4853 else if (SCM_BIGP (n
))
4855 SCM q
= scm_i_mkbig ();
4857 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (n
), count
);
4858 if (mpz_tstbit (SCM_I_BIG_MPZ (n
), count
-1)
4859 && (mpz_odd_p (SCM_I_BIG_MPZ (q
))
4860 || (mpz_scan1 (SCM_I_BIG_MPZ (n
), 0) < count
-1)))
4861 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
4862 scm_remember_upto_here_1 (n
);
4863 return scm_i_normbig (q
);
4866 scm_syserror ("round_right_shift_exact_integer");
4869 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4871 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
4872 "@var{n} and @var{count} must be exact integers.\n"
4874 "With @var{n} viewed as an infinite-precision twos-complement\n"
4875 "integer, @code{ash} means a left shift introducing zero bits\n"
4876 "when @var{count} is positive, or a right shift dropping bits\n"
4877 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
4880 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4881 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4883 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4884 "(ash -23 -2) @result{} -6\n"
4886 #define FUNC_NAME s_scm_ash
4888 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
4890 long bits_to_shift
= scm_to_long (count
);
4892 if (bits_to_shift
> 0)
4893 return left_shift_exact_integer (n
, bits_to_shift
);
4894 else if (SCM_LIKELY (bits_to_shift
< 0))
4895 return floor_right_shift_exact_integer (n
, -bits_to_shift
);
4900 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4904 SCM_DEFINE (scm_round_ash
, "round-ash", 2, 0, 0,
4906 "Return @math{round(@var{n} * 2^@var{count})}.\n"
4907 "@var{n} and @var{count} must be exact integers.\n"
4909 "With @var{n} viewed as an infinite-precision twos-complement\n"
4910 "integer, @code{round-ash} means a left shift introducing zero\n"
4911 "bits when @var{count} is positive, or a right shift rounding\n"
4912 "to the nearest integer (with ties going to the nearest even\n"
4913 "integer) when @var{count} is negative. This is a rounded\n"
4914 "``arithmetic'' shift.\n"
4917 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
4918 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
4919 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
4920 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
4921 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
4922 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
4924 #define FUNC_NAME s_scm_round_ash
4926 if (SCM_I_INUMP (n
) || SCM_BIGP (n
))
4928 long bits_to_shift
= scm_to_long (count
);
4930 if (bits_to_shift
> 0)
4931 return left_shift_exact_integer (n
, bits_to_shift
);
4932 else if (SCM_LIKELY (bits_to_shift
< 0))
4933 return round_right_shift_exact_integer (n
, -bits_to_shift
);
4938 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4943 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4944 (SCM n
, SCM start
, SCM end
),
4945 "Return the integer composed of the @var{start} (inclusive)\n"
4946 "through @var{end} (exclusive) bits of @var{n}. The\n"
4947 "@var{start}th bit becomes the 0-th bit in the result.\n"
4950 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4951 " @result{} \"1010\"\n"
4952 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4953 " @result{} \"10110\"\n"
4955 #define FUNC_NAME s_scm_bit_extract
4957 unsigned long int istart
, iend
, bits
;
4958 istart
= scm_to_ulong (start
);
4959 iend
= scm_to_ulong (end
);
4960 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4962 /* how many bits to keep */
4963 bits
= iend
- istart
;
4965 if (SCM_I_INUMP (n
))
4967 scm_t_inum in
= SCM_I_INUM (n
);
4969 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4970 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4971 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4973 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4975 /* Since we emulate two's complement encoded numbers, this
4976 * special case requires us to produce a result that has
4977 * more bits than can be stored in a fixnum.
4979 SCM result
= scm_i_inum2big (in
);
4980 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4985 /* mask down to requisite bits */
4986 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4987 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4989 else if (SCM_BIGP (n
))
4994 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4998 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4999 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5000 such bits into a ulong. */
5001 result
= scm_i_mkbig ();
5002 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
5003 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
5004 result
= scm_i_normbig (result
);
5006 scm_remember_upto_here_1 (n
);
5010 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5015 static const char scm_logtab
[] = {
5016 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5019 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
5021 "Return the number of bits in integer @var{n}. If integer is\n"
5022 "positive, the 1-bits in its binary representation are counted.\n"
5023 "If negative, the 0-bits in its two's-complement binary\n"
5024 "representation are counted. If 0, 0 is returned.\n"
5027 "(logcount #b10101010)\n"
5034 #define FUNC_NAME s_scm_logcount
5036 if (SCM_I_INUMP (n
))
5038 unsigned long c
= 0;
5039 scm_t_inum nn
= SCM_I_INUM (n
);
5044 c
+= scm_logtab
[15 & nn
];
5047 return SCM_I_MAKINUM (c
);
5049 else if (SCM_BIGP (n
))
5051 unsigned long count
;
5052 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
5053 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
5055 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
5056 scm_remember_upto_here_1 (n
);
5057 return SCM_I_MAKINUM (count
);
5060 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5065 static const char scm_ilentab
[] = {
5066 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5070 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
5072 "Return the number of bits necessary to represent @var{n}.\n"
5075 "(integer-length #b10101010)\n"
5077 "(integer-length 0)\n"
5079 "(integer-length #b1111)\n"
5082 #define FUNC_NAME s_scm_integer_length
5084 if (SCM_I_INUMP (n
))
5086 unsigned long c
= 0;
5088 scm_t_inum nn
= SCM_I_INUM (n
);
5094 l
= scm_ilentab
[15 & nn
];
5097 return SCM_I_MAKINUM (c
- 4 + l
);
5099 else if (SCM_BIGP (n
))
5101 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5102 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5103 1 too big, so check for that and adjust. */
5104 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
5105 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
5106 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
5107 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5109 scm_remember_upto_here_1 (n
);
5110 return SCM_I_MAKINUM (size
);
5113 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5117 /*** NUMBERS -> STRINGS ***/
5118 #define SCM_MAX_DBL_PREC 60
5119 #define SCM_MAX_DBL_RADIX 36
5121 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5122 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5123 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5126 void init_dblprec(int *prec
, int radix
) {
5127 /* determine floating point precision by adding successively
5128 smaller increments to 1.0 until it is considered == 1.0 */
5129 double f
= ((double)1.0)/radix
;
5130 double fsum
= 1.0 + f
;
5135 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5147 void init_fx_radix(double *fx_list
, int radix
)
5149 /* initialize a per-radix list of tolerances. When added
5150 to a number < 1.0, we can determine if we should raund
5151 up and quit converting a number to a string. */
5155 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5156 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5159 /* use this array as a way to generate a single digit */
5160 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5163 idbl2str (double f
, char *a
, int radix
)
5165 int efmt
, dpt
, d
, i
, wp
;
5167 #ifdef DBL_MIN_10_EXP
5170 #endif /* DBL_MIN_10_EXP */
5175 radix
> SCM_MAX_DBL_RADIX
)
5177 /* revert to existing behavior */
5181 wp
= scm_dblprec
[radix
-2];
5182 fx
= fx_per_radix
[radix
-2];
5186 #ifdef HAVE_COPYSIGN
5187 double sgn
= copysign (1.0, f
);
5192 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5198 strcpy (a
, "-inf.0");
5200 strcpy (a
, "+inf.0");
5205 strcpy (a
, "+nan.0");
5215 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5216 make-uniform-vector, from causing infinite loops. */
5217 /* just do the checking...if it passes, we do the conversion for our
5218 radix again below */
5225 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5233 while (f_cpy
> 10.0)
5236 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5257 if (f
+ fx
[wp
] >= radix
)
5264 /* adding 9999 makes this equivalent to abs(x) % 3 */
5265 dpt
= (exp
+ 9999) % 3;
5269 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5291 a
[ch
++] = number_chars
[d
];
5294 if (f
+ fx
[wp
] >= 1.0)
5296 a
[ch
- 1] = number_chars
[d
+1];
5308 if ((dpt
> 4) && (exp
> 6))
5310 d
= (a
[0] == '-' ? 2 : 1);
5311 for (i
= ch
++; i
> d
; i
--)
5324 if (a
[ch
- 1] == '.')
5325 a
[ch
++] = '0'; /* trailing zero */
5334 for (i
= radix
; i
<= exp
; i
*= radix
);
5335 for (i
/= radix
; i
; i
/= radix
)
5337 a
[ch
++] = number_chars
[exp
/ i
];
5346 icmplx2str (double real
, double imag
, char *str
, int radix
)
5351 i
= idbl2str (real
, str
, radix
);
5352 #ifdef HAVE_COPYSIGN
5353 sgn
= copysign (1.0, imag
);
5357 /* Don't output a '+' for negative numbers or for Inf and
5358 NaN. They will provide their own sign. */
5359 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5361 i
+= idbl2str (imag
, &str
[i
], radix
);
5367 iflo2str (SCM flt
, char *str
, int radix
)
5370 if (SCM_REALP (flt
))
5371 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5373 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5378 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5379 characters in the result.
5381 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5383 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5388 return scm_iuint2str (-num
, rad
, p
) + 1;
5391 return scm_iuint2str (num
, rad
, p
);
5394 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5395 characters in the result.
5397 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5399 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5403 scm_t_uintmax n
= num
;
5405 if (rad
< 2 || rad
> 36)
5406 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5408 for (n
/= rad
; n
> 0; n
/= rad
)
5418 p
[i
] = number_chars
[d
];
5423 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5425 "Return a string holding the external representation of the\n"
5426 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5427 "inexact, a radix of 10 will be used.")
5428 #define FUNC_NAME s_scm_number_to_string
5432 if (SCM_UNBNDP (radix
))
5435 base
= scm_to_signed_integer (radix
, 2, 36);
5437 if (SCM_I_INUMP (n
))
5439 char num_buf
[SCM_INTBUFLEN
];
5440 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5441 return scm_from_locale_stringn (num_buf
, length
);
5443 else if (SCM_BIGP (n
))
5445 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5446 size_t len
= strlen (str
);
5447 void (*freefunc
) (void *, size_t);
5449 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5450 scm_remember_upto_here_1 (n
);
5451 ret
= scm_from_latin1_stringn (str
, len
);
5452 freefunc (str
, len
+ 1);
5455 else if (SCM_FRACTIONP (n
))
5457 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5458 scm_from_locale_string ("/"),
5459 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5461 else if (SCM_INEXACTP (n
))
5463 char num_buf
[FLOBUFLEN
];
5464 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5467 SCM_WRONG_TYPE_ARG (1, n
);
5472 /* These print routines used to be stubbed here so that scm_repl.c
5473 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5476 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5478 char num_buf
[FLOBUFLEN
];
5479 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5484 scm_i_print_double (double val
, SCM port
)
5486 char num_buf
[FLOBUFLEN
];
5487 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5491 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5494 char num_buf
[FLOBUFLEN
];
5495 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5500 scm_i_print_complex (double real
, double imag
, SCM port
)
5502 char num_buf
[FLOBUFLEN
];
5503 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5507 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5510 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5511 scm_display (str
, port
);
5512 scm_remember_upto_here_1 (str
);
5517 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5519 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5520 size_t len
= strlen (str
);
5521 void (*freefunc
) (void *, size_t);
5522 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5523 scm_remember_upto_here_1 (exp
);
5524 scm_lfwrite (str
, len
, port
);
5525 freefunc (str
, len
+ 1);
5528 /*** END nums->strs ***/
5531 /*** STRINGS -> NUMBERS ***/
5533 /* The following functions implement the conversion from strings to numbers.
5534 * The implementation somehow follows the grammar for numbers as it is given
5535 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5536 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5537 * points should be noted about the implementation:
5539 * * Each function keeps a local index variable 'idx' that points at the
5540 * current position within the parsed string. The global index is only
5541 * updated if the function could parse the corresponding syntactic unit
5544 * * Similarly, the functions keep track of indicators of inexactness ('#',
5545 * '.' or exponents) using local variables ('hash_seen', 'x').
5547 * * Sequences of digits are parsed into temporary variables holding fixnums.
5548 * Only if these fixnums would overflow, the result variables are updated
5549 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5550 * the temporary variables holding the fixnums are cleared, and the process
5551 * starts over again. If for example fixnums were able to store five decimal
5552 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5553 * and the result was computed as 12345 * 100000 + 67890. In other words,
5554 * only every five digits two bignum operations were performed.
5556 * Notes on the handling of exactness specifiers:
5558 * When parsing non-real complex numbers, we apply exactness specifiers on
5559 * per-component basis, as is done in PLT Scheme. For complex numbers
5560 * written in rectangular form, exactness specifiers are applied to the
5561 * real and imaginary parts before calling scm_make_rectangular. For
5562 * complex numbers written in polar form, exactness specifiers are applied
5563 * to the magnitude and angle before calling scm_make_polar.
5565 * There are two kinds of exactness specifiers: forced and implicit. A
5566 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5567 * the entire number, and applies to both components of a complex number.
5568 * "#e" causes each component to be made exact, and "#i" causes each
5569 * component to be made inexact. If no forced exactness specifier is
5570 * present, then the exactness of each component is determined
5571 * independently by the presence or absence of a decimal point or hash mark
5572 * within that component. If a decimal point or hash mark is present, the
5573 * component is made inexact, otherwise it is made exact.
5575 * After the exactness specifiers have been applied to each component, they
5576 * are passed to either scm_make_rectangular or scm_make_polar to produce
5577 * the final result. Note that this will result in a real number if the
5578 * imaginary part, magnitude, or angle is an exact 0.
5580 * For example, (string->number "#i5.0+0i") does the equivalent of:
5582 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5585 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5587 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5589 /* Caller is responsible for checking that the return value is in range
5590 for the given radix, which should be <= 36. */
5592 char_decimal_value (scm_t_uint32 c
)
5594 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5595 that's certainly above any valid decimal, so we take advantage of
5596 that to elide some tests. */
5597 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5599 /* If that failed, try extended hexadecimals, then. Only accept ascii
5604 if (c
>= (scm_t_uint32
) 'a')
5605 d
= c
- (scm_t_uint32
)'a' + 10U;
5610 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5611 in base RADIX. Upon success, return the unsigned integer and update
5612 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5614 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5615 unsigned int radix
, enum t_exactness
*p_exactness
)
5617 unsigned int idx
= *p_idx
;
5618 unsigned int hash_seen
= 0;
5619 scm_t_bits shift
= 1;
5621 unsigned int digit_value
;
5624 size_t len
= scm_i_string_length (mem
);
5629 c
= scm_i_string_ref (mem
, idx
);
5630 digit_value
= char_decimal_value (c
);
5631 if (digit_value
>= radix
)
5635 result
= SCM_I_MAKINUM (digit_value
);
5638 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5648 digit_value
= char_decimal_value (c
);
5649 /* This check catches non-decimals in addition to out-of-range
5651 if (digit_value
>= radix
)
5656 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5658 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5660 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5667 shift
= shift
* radix
;
5668 add
= add
* radix
+ digit_value
;
5673 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5675 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5679 *p_exactness
= INEXACT
;
5685 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5686 * covers the parts of the rules that start at a potential point. The value
5687 * of the digits up to the point have been parsed by the caller and are given
5688 * in variable result. The content of *p_exactness indicates, whether a hash
5689 * has already been seen in the digits before the point.
5692 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5695 mem2decimal_from_point (SCM result
, SCM mem
,
5696 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5698 unsigned int idx
= *p_idx
;
5699 enum t_exactness x
= *p_exactness
;
5700 size_t len
= scm_i_string_length (mem
);
5705 if (scm_i_string_ref (mem
, idx
) == '.')
5707 scm_t_bits shift
= 1;
5709 unsigned int digit_value
;
5710 SCM big_shift
= SCM_INUM1
;
5715 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5716 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5721 digit_value
= DIGIT2UINT (c
);
5732 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5734 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5735 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5737 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5745 add
= add
* 10 + digit_value
;
5751 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5752 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5753 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5756 result
= scm_divide (result
, big_shift
);
5758 /* We've seen a decimal point, thus the value is implicitly inexact. */
5770 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5772 switch (scm_i_string_ref (mem
, idx
))
5784 c
= scm_i_string_ref (mem
, idx
);
5792 c
= scm_i_string_ref (mem
, idx
);
5801 c
= scm_i_string_ref (mem
, idx
);
5806 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5810 exponent
= DIGIT2UINT (c
);
5813 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5814 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5817 if (exponent
<= SCM_MAXEXP
)
5818 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5824 if (exponent
> SCM_MAXEXP
)
5826 size_t exp_len
= idx
- start
;
5827 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5828 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5829 scm_out_of_range ("string->number", exp_num
);
5832 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5834 result
= scm_product (result
, e
);
5836 result
= scm_divide (result
, e
);
5838 /* We've seen an exponent, thus the value is implicitly inexact. */
5856 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5859 mem2ureal (SCM mem
, unsigned int *p_idx
,
5860 unsigned int radix
, enum t_exactness forced_x
,
5861 int allow_inf_or_nan
)
5863 unsigned int idx
= *p_idx
;
5865 size_t len
= scm_i_string_length (mem
);
5867 /* Start off believing that the number will be exact. This changes
5868 to INEXACT if we see a decimal point or a hash. */
5869 enum t_exactness implicit_x
= EXACT
;
5874 if (allow_inf_or_nan
&& forced_x
!= EXACT
&& idx
+5 <= len
)
5875 switch (scm_i_string_ref (mem
, idx
))
5878 switch (scm_i_string_ref (mem
, idx
+ 1))
5881 switch (scm_i_string_ref (mem
, idx
+ 2))
5884 if (scm_i_string_ref (mem
, idx
+ 3) == '.'
5885 && scm_i_string_ref (mem
, idx
+ 4) == '0')
5893 switch (scm_i_string_ref (mem
, idx
+ 1))
5896 switch (scm_i_string_ref (mem
, idx
+ 2))
5899 if (scm_i_string_ref (mem
, idx
+ 3) == '.')
5901 /* Cobble up the fractional part. We might want to
5902 set the NaN's mantissa from it. */
5904 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
),
5907 #if SCM_ENABLE_DEPRECATED == 1
5908 scm_c_issue_deprecation_warning
5909 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5922 if (scm_i_string_ref (mem
, idx
) == '.')
5926 else if (idx
+ 1 == len
)
5928 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5931 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5932 p_idx
, &implicit_x
);
5938 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5939 if (scm_is_false (uinteger
))
5944 else if (scm_i_string_ref (mem
, idx
) == '/')
5952 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5953 if (scm_is_false (divisor
) || scm_is_eq (divisor
, SCM_INUM0
))
5956 /* both are int/big here, I assume */
5957 result
= scm_i_make_ratio (uinteger
, divisor
);
5959 else if (radix
== 10)
5961 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5962 if (scm_is_false (result
))
5974 if (SCM_INEXACTP (result
))
5975 return scm_inexact_to_exact (result
);
5979 if (SCM_INEXACTP (result
))
5982 return scm_exact_to_inexact (result
);
5984 if (implicit_x
== INEXACT
)
5986 if (SCM_INEXACTP (result
))
5989 return scm_exact_to_inexact (result
);
5995 /* We should never get here */
5996 scm_syserror ("mem2ureal");
6000 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6003 mem2complex (SCM mem
, unsigned int idx
,
6004 unsigned int radix
, enum t_exactness forced_x
)
6009 size_t len
= scm_i_string_length (mem
);
6014 c
= scm_i_string_ref (mem
, idx
);
6029 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6030 if (scm_is_false (ureal
))
6032 /* input must be either +i or -i */
6037 if (scm_i_string_ref (mem
, idx
) == 'i'
6038 || scm_i_string_ref (mem
, idx
) == 'I')
6044 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
6051 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6052 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
6057 c
= scm_i_string_ref (mem
, idx
);
6061 /* either +<ureal>i or -<ureal>i */
6068 return scm_make_rectangular (SCM_INUM0
, ureal
);
6071 /* polar input: <real>@<real>. */
6082 c
= scm_i_string_ref (mem
, idx
);
6100 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6101 if (scm_is_false (angle
))
6106 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
6107 angle
= scm_difference (angle
, SCM_UNDEFINED
);
6109 result
= scm_make_polar (ureal
, angle
);
6114 /* expecting input matching <real>[+-]<ureal>?i */
6121 int sign
= (c
== '+') ? 1 : -1;
6122 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
, sign
!= 0);
6124 if (scm_is_false (imag
))
6125 imag
= SCM_I_MAKINUM (sign
);
6126 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
6127 imag
= scm_difference (imag
, SCM_UNDEFINED
);
6131 if (scm_i_string_ref (mem
, idx
) != 'i'
6132 && scm_i_string_ref (mem
, idx
) != 'I')
6139 return scm_make_rectangular (ureal
, imag
);
6148 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6150 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6153 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6155 unsigned int idx
= 0;
6156 unsigned int radix
= NO_RADIX
;
6157 enum t_exactness forced_x
= NO_EXACTNESS
;
6158 size_t len
= scm_i_string_length (mem
);
6160 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6161 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6163 switch (scm_i_string_ref (mem
, idx
+ 1))
6166 if (radix
!= NO_RADIX
)
6171 if (radix
!= NO_RADIX
)
6176 if (forced_x
!= NO_EXACTNESS
)
6181 if (forced_x
!= NO_EXACTNESS
)
6186 if (radix
!= NO_RADIX
)
6191 if (radix
!= NO_RADIX
)
6201 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6202 if (radix
== NO_RADIX
)
6203 radix
= default_radix
;
6205 return mem2complex (mem
, idx
, radix
, forced_x
);
6209 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6210 unsigned int default_radix
)
6212 SCM str
= scm_from_locale_stringn (mem
, len
);
6214 return scm_i_string_to_number (str
, default_radix
);
6218 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6219 (SCM string
, SCM radix
),
6220 "Return a number of the maximally precise representation\n"
6221 "expressed by the given @var{string}. @var{radix} must be an\n"
6222 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6223 "is a default radix that may be overridden by an explicit radix\n"
6224 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6225 "supplied, then the default radix is 10. If string is not a\n"
6226 "syntactically valid notation for a number, then\n"
6227 "@code{string->number} returns @code{#f}.")
6228 #define FUNC_NAME s_scm_string_to_number
6232 SCM_VALIDATE_STRING (1, string
);
6234 if (SCM_UNBNDP (radix
))
6237 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6239 answer
= scm_i_string_to_number (string
, base
);
6240 scm_remember_upto_here_1 (string
);
6246 /*** END strs->nums ***/
6249 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6251 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6253 #define FUNC_NAME s_scm_number_p
6255 return scm_from_bool (SCM_NUMBERP (x
));
6259 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6261 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6262 "otherwise. Note that the sets of real, rational and integer\n"
6263 "values form subsets of the set of complex numbers, i. e. the\n"
6264 "predicate will also be fulfilled if @var{x} is a real,\n"
6265 "rational or integer number.")
6266 #define FUNC_NAME s_scm_complex_p
6268 /* all numbers are complex. */
6269 return scm_number_p (x
);
6273 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6275 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6276 "otherwise. Note that the set of integer values forms a subset of\n"
6277 "the set of real numbers, i. e. the predicate will also be\n"
6278 "fulfilled if @var{x} is an integer number.")
6279 #define FUNC_NAME s_scm_real_p
6281 return scm_from_bool
6282 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6286 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6288 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6289 "otherwise. Note that the set of integer values forms a subset of\n"
6290 "the set of rational numbers, i. e. the predicate will also be\n"
6291 "fulfilled if @var{x} is an integer number.")
6292 #define FUNC_NAME s_scm_rational_p
6294 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6296 else if (SCM_REALP (x
))
6297 /* due to their limited precision, finite floating point numbers are
6298 rational as well. (finite means neither infinity nor a NaN) */
6299 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6305 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6307 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6309 #define FUNC_NAME s_scm_integer_p
6311 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6313 else if (SCM_REALP (x
))
6315 double val
= SCM_REAL_VALUE (x
);
6316 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6324 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6325 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6326 (SCM x
, SCM y
, SCM rest
),
6327 "Return @code{#t} if all parameters are numerically equal.")
6328 #define FUNC_NAME s_scm_i_num_eq_p
6330 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6332 while (!scm_is_null (rest
))
6334 if (scm_is_false (scm_num_eq_p (x
, y
)))
6338 rest
= scm_cdr (rest
);
6340 return scm_num_eq_p (x
, y
);
6344 scm_num_eq_p (SCM x
, SCM y
)
6347 if (SCM_I_INUMP (x
))
6349 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6350 if (SCM_I_INUMP (y
))
6352 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6353 return scm_from_bool (xx
== yy
);
6355 else if (SCM_BIGP (y
))
6357 else if (SCM_REALP (y
))
6359 /* On a 32-bit system an inum fits a double, we can cast the inum
6360 to a double and compare.
6362 But on a 64-bit system an inum is bigger than a double and
6363 casting it to a double (call that dxx) will round. dxx is at
6364 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6365 an integer and fits a long. So we cast yy to a long and
6366 compare with plain xx.
6368 An alternative (for any size system actually) would be to check
6369 yy is an integer (with floor) and is in range of an inum
6370 (compare against appropriate powers of 2) then test
6371 xx==(scm_t_signed_bits)yy. It's just a matter of which
6372 casts/comparisons might be fastest or easiest for the cpu. */
6374 double yy
= SCM_REAL_VALUE (y
);
6375 return scm_from_bool ((double) xx
== yy
6376 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6377 || xx
== (scm_t_signed_bits
) yy
));
6379 else if (SCM_COMPLEXP (y
))
6380 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6381 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6382 else if (SCM_FRACTIONP (y
))
6385 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6387 else if (SCM_BIGP (x
))
6389 if (SCM_I_INUMP (y
))
6391 else if (SCM_BIGP (y
))
6393 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6394 scm_remember_upto_here_2 (x
, y
);
6395 return scm_from_bool (0 == cmp
);
6397 else if (SCM_REALP (y
))
6400 if (isnan (SCM_REAL_VALUE (y
)))
6402 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6403 scm_remember_upto_here_1 (x
);
6404 return scm_from_bool (0 == cmp
);
6406 else if (SCM_COMPLEXP (y
))
6409 if (0.0 != SCM_COMPLEX_IMAG (y
))
6411 if (isnan (SCM_COMPLEX_REAL (y
)))
6413 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6414 scm_remember_upto_here_1 (x
);
6415 return scm_from_bool (0 == cmp
);
6417 else if (SCM_FRACTIONP (y
))
6420 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6422 else if (SCM_REALP (x
))
6424 double xx
= SCM_REAL_VALUE (x
);
6425 if (SCM_I_INUMP (y
))
6427 /* see comments with inum/real above */
6428 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6429 return scm_from_bool (xx
== (double) yy
6430 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6431 || (scm_t_signed_bits
) xx
== yy
));
6433 else if (SCM_BIGP (y
))
6436 if (isnan (SCM_REAL_VALUE (x
)))
6438 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6439 scm_remember_upto_here_1 (y
);
6440 return scm_from_bool (0 == cmp
);
6442 else if (SCM_REALP (y
))
6443 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6444 else if (SCM_COMPLEXP (y
))
6445 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6446 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6447 else if (SCM_FRACTIONP (y
))
6449 double xx
= SCM_REAL_VALUE (x
);
6453 return scm_from_bool (xx
< 0.0);
6454 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6458 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6460 else if (SCM_COMPLEXP (x
))
6462 if (SCM_I_INUMP (y
))
6463 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6464 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6465 else if (SCM_BIGP (y
))
6468 if (0.0 != SCM_COMPLEX_IMAG (x
))
6470 if (isnan (SCM_COMPLEX_REAL (x
)))
6472 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6473 scm_remember_upto_here_1 (y
);
6474 return scm_from_bool (0 == cmp
);
6476 else if (SCM_REALP (y
))
6477 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6478 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6479 else if (SCM_COMPLEXP (y
))
6480 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6481 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6482 else if (SCM_FRACTIONP (y
))
6485 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6487 xx
= SCM_COMPLEX_REAL (x
);
6491 return scm_from_bool (xx
< 0.0);
6492 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6496 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6498 else if (SCM_FRACTIONP (x
))
6500 if (SCM_I_INUMP (y
))
6502 else if (SCM_BIGP (y
))
6504 else if (SCM_REALP (y
))
6506 double yy
= SCM_REAL_VALUE (y
);
6510 return scm_from_bool (0.0 < yy
);
6511 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6514 else if (SCM_COMPLEXP (y
))
6517 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6519 yy
= SCM_COMPLEX_REAL (y
);
6523 return scm_from_bool (0.0 < yy
);
6524 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6527 else if (SCM_FRACTIONP (y
))
6528 return scm_i_fraction_equalp (x
, y
);
6530 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6533 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6537 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6538 done are good for inums, but for bignums an answer can almost always be
6539 had by just examining a few high bits of the operands, as done by GMP in
6540 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6541 of the float exponent to take into account. */
6543 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6544 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6545 (SCM x
, SCM y
, SCM rest
),
6546 "Return @code{#t} if the list of parameters is monotonically\n"
6548 #define FUNC_NAME s_scm_i_num_less_p
6550 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6552 while (!scm_is_null (rest
))
6554 if (scm_is_false (scm_less_p (x
, y
)))
6558 rest
= scm_cdr (rest
);
6560 return scm_less_p (x
, y
);
6564 scm_less_p (SCM x
, SCM y
)
6567 if (SCM_I_INUMP (x
))
6569 scm_t_inum xx
= SCM_I_INUM (x
);
6570 if (SCM_I_INUMP (y
))
6572 scm_t_inum yy
= SCM_I_INUM (y
);
6573 return scm_from_bool (xx
< yy
);
6575 else if (SCM_BIGP (y
))
6577 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6578 scm_remember_upto_here_1 (y
);
6579 return scm_from_bool (sgn
> 0);
6581 else if (SCM_REALP (y
))
6582 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6583 else if (SCM_FRACTIONP (y
))
6585 /* "x < a/b" becomes "x*b < a" */
6587 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6588 y
= SCM_FRACTION_NUMERATOR (y
);
6592 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6594 else if (SCM_BIGP (x
))
6596 if (SCM_I_INUMP (y
))
6598 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6599 scm_remember_upto_here_1 (x
);
6600 return scm_from_bool (sgn
< 0);
6602 else if (SCM_BIGP (y
))
6604 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6605 scm_remember_upto_here_2 (x
, y
);
6606 return scm_from_bool (cmp
< 0);
6608 else if (SCM_REALP (y
))
6611 if (isnan (SCM_REAL_VALUE (y
)))
6613 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6614 scm_remember_upto_here_1 (x
);
6615 return scm_from_bool (cmp
< 0);
6617 else if (SCM_FRACTIONP (y
))
6620 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6622 else if (SCM_REALP (x
))
6624 if (SCM_I_INUMP (y
))
6625 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6626 else if (SCM_BIGP (y
))
6629 if (isnan (SCM_REAL_VALUE (x
)))
6631 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6632 scm_remember_upto_here_1 (y
);
6633 return scm_from_bool (cmp
> 0);
6635 else if (SCM_REALP (y
))
6636 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6637 else if (SCM_FRACTIONP (y
))
6639 double xx
= SCM_REAL_VALUE (x
);
6643 return scm_from_bool (xx
< 0.0);
6644 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6648 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6650 else if (SCM_FRACTIONP (x
))
6652 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6654 /* "a/b < y" becomes "a < y*b" */
6655 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6656 x
= SCM_FRACTION_NUMERATOR (x
);
6659 else if (SCM_REALP (y
))
6661 double yy
= SCM_REAL_VALUE (y
);
6665 return scm_from_bool (0.0 < yy
);
6666 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6669 else if (SCM_FRACTIONP (y
))
6671 /* "a/b < c/d" becomes "a*d < c*b" */
6672 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6673 SCM_FRACTION_DENOMINATOR (y
));
6674 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6675 SCM_FRACTION_DENOMINATOR (x
));
6681 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6684 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6688 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6689 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6690 (SCM x
, SCM y
, SCM rest
),
6691 "Return @code{#t} if the list of parameters is monotonically\n"
6693 #define FUNC_NAME s_scm_i_num_gr_p
6695 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6697 while (!scm_is_null (rest
))
6699 if (scm_is_false (scm_gr_p (x
, y
)))
6703 rest
= scm_cdr (rest
);
6705 return scm_gr_p (x
, y
);
6708 #define FUNC_NAME s_scm_i_num_gr_p
6710 scm_gr_p (SCM x
, SCM y
)
6712 if (!SCM_NUMBERP (x
))
6713 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6714 else if (!SCM_NUMBERP (y
))
6715 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6717 return scm_less_p (y
, x
);
6722 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6723 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6724 (SCM x
, SCM y
, SCM rest
),
6725 "Return @code{#t} if the list of parameters is monotonically\n"
6727 #define FUNC_NAME s_scm_i_num_leq_p
6729 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6731 while (!scm_is_null (rest
))
6733 if (scm_is_false (scm_leq_p (x
, y
)))
6737 rest
= scm_cdr (rest
);
6739 return scm_leq_p (x
, y
);
6742 #define FUNC_NAME s_scm_i_num_leq_p
6744 scm_leq_p (SCM x
, SCM y
)
6746 if (!SCM_NUMBERP (x
))
6747 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6748 else if (!SCM_NUMBERP (y
))
6749 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6750 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6753 return scm_not (scm_less_p (y
, x
));
6758 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6759 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6760 (SCM x
, SCM y
, SCM rest
),
6761 "Return @code{#t} if the list of parameters is monotonically\n"
6763 #define FUNC_NAME s_scm_i_num_geq_p
6765 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6767 while (!scm_is_null (rest
))
6769 if (scm_is_false (scm_geq_p (x
, y
)))
6773 rest
= scm_cdr (rest
);
6775 return scm_geq_p (x
, y
);
6778 #define FUNC_NAME s_scm_i_num_geq_p
6780 scm_geq_p (SCM x
, SCM y
)
6782 if (!SCM_NUMBERP (x
))
6783 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6784 else if (!SCM_NUMBERP (y
))
6785 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6786 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6789 return scm_not (scm_less_p (x
, y
));
6794 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6796 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6798 #define FUNC_NAME s_scm_zero_p
6800 if (SCM_I_INUMP (z
))
6801 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6802 else if (SCM_BIGP (z
))
6804 else if (SCM_REALP (z
))
6805 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6806 else if (SCM_COMPLEXP (z
))
6807 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6808 && SCM_COMPLEX_IMAG (z
) == 0.0);
6809 else if (SCM_FRACTIONP (z
))
6812 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6817 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6819 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6821 #define FUNC_NAME s_scm_positive_p
6823 if (SCM_I_INUMP (x
))
6824 return scm_from_bool (SCM_I_INUM (x
) > 0);
6825 else if (SCM_BIGP (x
))
6827 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6828 scm_remember_upto_here_1 (x
);
6829 return scm_from_bool (sgn
> 0);
6831 else if (SCM_REALP (x
))
6832 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6833 else if (SCM_FRACTIONP (x
))
6834 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6836 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6841 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6843 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6845 #define FUNC_NAME s_scm_negative_p
6847 if (SCM_I_INUMP (x
))
6848 return scm_from_bool (SCM_I_INUM (x
) < 0);
6849 else if (SCM_BIGP (x
))
6851 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6852 scm_remember_upto_here_1 (x
);
6853 return scm_from_bool (sgn
< 0);
6855 else if (SCM_REALP (x
))
6856 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6857 else if (SCM_FRACTIONP (x
))
6858 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6860 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6865 /* scm_min and scm_max return an inexact when either argument is inexact, as
6866 required by r5rs. On that basis, for exact/inexact combinations the
6867 exact is converted to inexact to compare and possibly return. This is
6868 unlike scm_less_p above which takes some trouble to preserve all bits in
6869 its test, such trouble is not required for min and max. */
6871 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6872 (SCM x
, SCM y
, SCM rest
),
6873 "Return the maximum of all parameter values.")
6874 #define FUNC_NAME s_scm_i_max
6876 while (!scm_is_null (rest
))
6877 { x
= scm_max (x
, y
);
6879 rest
= scm_cdr (rest
);
6881 return scm_max (x
, y
);
6885 #define s_max s_scm_i_max
6886 #define g_max g_scm_i_max
6889 scm_max (SCM x
, SCM y
)
6894 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6895 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6898 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6901 if (SCM_I_INUMP (x
))
6903 scm_t_inum xx
= SCM_I_INUM (x
);
6904 if (SCM_I_INUMP (y
))
6906 scm_t_inum yy
= SCM_I_INUM (y
);
6907 return (xx
< yy
) ? y
: x
;
6909 else if (SCM_BIGP (y
))
6911 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6912 scm_remember_upto_here_1 (y
);
6913 return (sgn
< 0) ? x
: y
;
6915 else if (SCM_REALP (y
))
6918 double yyd
= SCM_REAL_VALUE (y
);
6921 return scm_from_double (xxd
);
6922 /* If y is a NaN, then "==" is false and we return the NaN */
6923 else if (SCM_LIKELY (!(xxd
== yyd
)))
6925 /* Handle signed zeroes properly */
6931 else if (SCM_FRACTIONP (y
))
6934 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6937 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6939 else if (SCM_BIGP (x
))
6941 if (SCM_I_INUMP (y
))
6943 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6944 scm_remember_upto_here_1 (x
);
6945 return (sgn
< 0) ? y
: x
;
6947 else if (SCM_BIGP (y
))
6949 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6950 scm_remember_upto_here_2 (x
, y
);
6951 return (cmp
> 0) ? x
: y
;
6953 else if (SCM_REALP (y
))
6955 /* if y==NaN then xx>yy is false, so we return the NaN y */
6958 xx
= scm_i_big2dbl (x
);
6959 yy
= SCM_REAL_VALUE (y
);
6960 return (xx
> yy
? scm_from_double (xx
) : y
);
6962 else if (SCM_FRACTIONP (y
))
6967 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6969 else if (SCM_REALP (x
))
6971 if (SCM_I_INUMP (y
))
6973 scm_t_inum yy
= SCM_I_INUM (y
);
6974 double xxd
= SCM_REAL_VALUE (x
);
6978 return scm_from_double (yyd
);
6979 /* If x is a NaN, then "==" is false and we return the NaN */
6980 else if (SCM_LIKELY (!(xxd
== yyd
)))
6982 /* Handle signed zeroes properly */
6988 else if (SCM_BIGP (y
))
6993 else if (SCM_REALP (y
))
6995 double xx
= SCM_REAL_VALUE (x
);
6996 double yy
= SCM_REAL_VALUE (y
);
6998 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
7001 else if (SCM_LIKELY (xx
< yy
))
7003 /* If neither (xx > yy) nor (xx < yy), then
7004 either they're equal or one is a NaN */
7005 else if (SCM_UNLIKELY (isnan (xx
)))
7006 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
7007 else if (SCM_UNLIKELY (isnan (yy
)))
7008 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
7009 /* xx == yy, but handle signed zeroes properly */
7010 else if (double_is_non_negative_zero (yy
))
7015 else if (SCM_FRACTIONP (y
))
7017 double yy
= scm_i_fraction2double (y
);
7018 double xx
= SCM_REAL_VALUE (x
);
7019 return (xx
< yy
) ? scm_from_double (yy
) : x
;
7022 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7024 else if (SCM_FRACTIONP (x
))
7026 if (SCM_I_INUMP (y
))
7030 else if (SCM_BIGP (y
))
7034 else if (SCM_REALP (y
))
7036 double xx
= scm_i_fraction2double (x
);
7037 /* if y==NaN then ">" is false, so we return the NaN y */
7038 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7040 else if (SCM_FRACTIONP (y
))
7045 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
7048 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
7052 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
7053 (SCM x
, SCM y
, SCM rest
),
7054 "Return the minimum of all parameter values.")
7055 #define FUNC_NAME s_scm_i_min
7057 while (!scm_is_null (rest
))
7058 { x
= scm_min (x
, y
);
7060 rest
= scm_cdr (rest
);
7062 return scm_min (x
, y
);
7066 #define s_min s_scm_i_min
7067 #define g_min g_scm_i_min
7070 scm_min (SCM x
, SCM y
)
7075 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
7076 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
7079 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
7082 if (SCM_I_INUMP (x
))
7084 scm_t_inum xx
= SCM_I_INUM (x
);
7085 if (SCM_I_INUMP (y
))
7087 scm_t_inum yy
= SCM_I_INUM (y
);
7088 return (xx
< yy
) ? x
: y
;
7090 else if (SCM_BIGP (y
))
7092 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7093 scm_remember_upto_here_1 (y
);
7094 return (sgn
< 0) ? y
: x
;
7096 else if (SCM_REALP (y
))
7099 /* if y==NaN then "<" is false and we return NaN */
7100 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
7102 else if (SCM_FRACTIONP (y
))
7105 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
7108 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7110 else if (SCM_BIGP (x
))
7112 if (SCM_I_INUMP (y
))
7114 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7115 scm_remember_upto_here_1 (x
);
7116 return (sgn
< 0) ? x
: y
;
7118 else if (SCM_BIGP (y
))
7120 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
7121 scm_remember_upto_here_2 (x
, y
);
7122 return (cmp
> 0) ? y
: x
;
7124 else if (SCM_REALP (y
))
7126 /* if y==NaN then xx<yy is false, so we return the NaN y */
7129 xx
= scm_i_big2dbl (x
);
7130 yy
= SCM_REAL_VALUE (y
);
7131 return (xx
< yy
? scm_from_double (xx
) : y
);
7133 else if (SCM_FRACTIONP (y
))
7138 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7140 else if (SCM_REALP (x
))
7142 if (SCM_I_INUMP (y
))
7144 double z
= SCM_I_INUM (y
);
7145 /* if x==NaN then "<" is false and we return NaN */
7146 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7148 else if (SCM_BIGP (y
))
7153 else if (SCM_REALP (y
))
7155 double xx
= SCM_REAL_VALUE (x
);
7156 double yy
= SCM_REAL_VALUE (y
);
7158 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7161 else if (SCM_LIKELY (xx
> yy
))
7163 /* If neither (xx < yy) nor (xx > yy), then
7164 either they're equal or one is a NaN */
7165 else if (SCM_UNLIKELY (isnan (xx
)))
7166 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7167 else if (SCM_UNLIKELY (isnan (yy
)))
7168 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7169 /* xx == yy, but handle signed zeroes properly */
7170 else if (double_is_non_negative_zero (xx
))
7175 else if (SCM_FRACTIONP (y
))
7177 double yy
= scm_i_fraction2double (y
);
7178 double xx
= SCM_REAL_VALUE (x
);
7179 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7182 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7184 else if (SCM_FRACTIONP (x
))
7186 if (SCM_I_INUMP (y
))
7190 else if (SCM_BIGP (y
))
7194 else if (SCM_REALP (y
))
7196 double xx
= scm_i_fraction2double (x
);
7197 /* if y==NaN then "<" is false, so we return the NaN y */
7198 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7200 else if (SCM_FRACTIONP (y
))
7205 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7208 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7212 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7213 (SCM x
, SCM y
, SCM rest
),
7214 "Return the sum of all parameter values. Return 0 if called without\n"
7216 #define FUNC_NAME s_scm_i_sum
7218 while (!scm_is_null (rest
))
7219 { x
= scm_sum (x
, y
);
7221 rest
= scm_cdr (rest
);
7223 return scm_sum (x
, y
);
7227 #define s_sum s_scm_i_sum
7228 #define g_sum g_scm_i_sum
7231 scm_sum (SCM x
, SCM y
)
7233 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7235 if (SCM_NUMBERP (x
)) return x
;
7236 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7237 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7240 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7242 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7244 scm_t_inum xx
= SCM_I_INUM (x
);
7245 scm_t_inum yy
= SCM_I_INUM (y
);
7246 scm_t_inum z
= xx
+ yy
;
7247 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7249 else if (SCM_BIGP (y
))
7254 else if (SCM_REALP (y
))
7256 scm_t_inum xx
= SCM_I_INUM (x
);
7257 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7259 else if (SCM_COMPLEXP (y
))
7261 scm_t_inum xx
= SCM_I_INUM (x
);
7262 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7263 SCM_COMPLEX_IMAG (y
));
7265 else if (SCM_FRACTIONP (y
))
7266 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7267 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7268 SCM_FRACTION_DENOMINATOR (y
));
7270 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7271 } else if (SCM_BIGP (x
))
7273 if (SCM_I_INUMP (y
))
7278 inum
= SCM_I_INUM (y
);
7281 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7284 SCM result
= scm_i_mkbig ();
7285 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7286 scm_remember_upto_here_1 (x
);
7287 /* we know the result will have to be a bignum */
7290 return scm_i_normbig (result
);
7294 SCM result
= scm_i_mkbig ();
7295 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7296 scm_remember_upto_here_1 (x
);
7297 /* we know the result will have to be a bignum */
7300 return scm_i_normbig (result
);
7303 else if (SCM_BIGP (y
))
7305 SCM result
= scm_i_mkbig ();
7306 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7307 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7308 mpz_add (SCM_I_BIG_MPZ (result
),
7311 scm_remember_upto_here_2 (x
, y
);
7312 /* we know the result will have to be a bignum */
7315 return scm_i_normbig (result
);
7317 else if (SCM_REALP (y
))
7319 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7320 scm_remember_upto_here_1 (x
);
7321 return scm_from_double (result
);
7323 else if (SCM_COMPLEXP (y
))
7325 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7326 + SCM_COMPLEX_REAL (y
));
7327 scm_remember_upto_here_1 (x
);
7328 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7330 else if (SCM_FRACTIONP (y
))
7331 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7332 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7333 SCM_FRACTION_DENOMINATOR (y
));
7335 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7337 else if (SCM_REALP (x
))
7339 if (SCM_I_INUMP (y
))
7340 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7341 else if (SCM_BIGP (y
))
7343 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7344 scm_remember_upto_here_1 (y
);
7345 return scm_from_double (result
);
7347 else if (SCM_REALP (y
))
7348 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7349 else if (SCM_COMPLEXP (y
))
7350 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7351 SCM_COMPLEX_IMAG (y
));
7352 else if (SCM_FRACTIONP (y
))
7353 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7355 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7357 else if (SCM_COMPLEXP (x
))
7359 if (SCM_I_INUMP (y
))
7360 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7361 SCM_COMPLEX_IMAG (x
));
7362 else if (SCM_BIGP (y
))
7364 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7365 + SCM_COMPLEX_REAL (x
));
7366 scm_remember_upto_here_1 (y
);
7367 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7369 else if (SCM_REALP (y
))
7370 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7371 SCM_COMPLEX_IMAG (x
));
7372 else if (SCM_COMPLEXP (y
))
7373 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7374 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7375 else if (SCM_FRACTIONP (y
))
7376 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7377 SCM_COMPLEX_IMAG (x
));
7379 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7381 else if (SCM_FRACTIONP (x
))
7383 if (SCM_I_INUMP (y
))
7384 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7385 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7386 SCM_FRACTION_DENOMINATOR (x
));
7387 else if (SCM_BIGP (y
))
7388 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7389 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7390 SCM_FRACTION_DENOMINATOR (x
));
7391 else if (SCM_REALP (y
))
7392 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7393 else if (SCM_COMPLEXP (y
))
7394 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7395 SCM_COMPLEX_IMAG (y
));
7396 else if (SCM_FRACTIONP (y
))
7397 /* a/b + c/d = (ad + bc) / bd */
7398 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7399 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7400 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7402 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7405 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7409 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7411 "Return @math{@var{x}+1}.")
7412 #define FUNC_NAME s_scm_oneplus
7414 return scm_sum (x
, SCM_INUM1
);
7419 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7420 (SCM x
, SCM y
, SCM rest
),
7421 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7422 "the sum of all but the first argument are subtracted from the first\n"
7424 #define FUNC_NAME s_scm_i_difference
7426 while (!scm_is_null (rest
))
7427 { x
= scm_difference (x
, y
);
7429 rest
= scm_cdr (rest
);
7431 return scm_difference (x
, y
);
7435 #define s_difference s_scm_i_difference
7436 #define g_difference g_scm_i_difference
7439 scm_difference (SCM x
, SCM y
)
7440 #define FUNC_NAME s_difference
7442 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7445 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7447 if (SCM_I_INUMP (x
))
7449 scm_t_inum xx
= -SCM_I_INUM (x
);
7450 if (SCM_FIXABLE (xx
))
7451 return SCM_I_MAKINUM (xx
);
7453 return scm_i_inum2big (xx
);
7455 else if (SCM_BIGP (x
))
7456 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7457 bignum, but negating that gives a fixnum. */
7458 return scm_i_normbig (scm_i_clonebig (x
, 0));
7459 else if (SCM_REALP (x
))
7460 return scm_from_double (-SCM_REAL_VALUE (x
));
7461 else if (SCM_COMPLEXP (x
))
7462 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7463 -SCM_COMPLEX_IMAG (x
));
7464 else if (SCM_FRACTIONP (x
))
7465 return scm_i_make_ratio_already_reduced
7466 (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7467 SCM_FRACTION_DENOMINATOR (x
));
7469 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7472 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7474 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7476 scm_t_inum xx
= SCM_I_INUM (x
);
7477 scm_t_inum yy
= SCM_I_INUM (y
);
7478 scm_t_inum z
= xx
- yy
;
7479 if (SCM_FIXABLE (z
))
7480 return SCM_I_MAKINUM (z
);
7482 return scm_i_inum2big (z
);
7484 else if (SCM_BIGP (y
))
7486 /* inum-x - big-y */
7487 scm_t_inum xx
= SCM_I_INUM (x
);
7491 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7492 bignum, but negating that gives a fixnum. */
7493 return scm_i_normbig (scm_i_clonebig (y
, 0));
7497 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7498 SCM result
= scm_i_mkbig ();
7501 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7504 /* x - y == -(y + -x) */
7505 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7506 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7508 scm_remember_upto_here_1 (y
);
7510 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7511 /* we know the result will have to be a bignum */
7514 return scm_i_normbig (result
);
7517 else if (SCM_REALP (y
))
7519 scm_t_inum xx
= SCM_I_INUM (x
);
7522 * We need to handle x == exact 0
7523 * specially because R6RS states that:
7524 * (- 0.0) ==> -0.0 and
7525 * (- 0.0 0.0) ==> 0.0
7526 * and the scheme compiler changes
7527 * (- 0.0) into (- 0 0.0)
7528 * So we need to treat (- 0 0.0) like (- 0.0).
7529 * At the C level, (-x) is different than (0.0 - x).
7530 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7533 return scm_from_double (- SCM_REAL_VALUE (y
));
7535 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7537 else if (SCM_COMPLEXP (y
))
7539 scm_t_inum xx
= SCM_I_INUM (x
);
7541 /* We need to handle x == exact 0 specially.
7542 See the comment above (for SCM_REALP (y)) */
7544 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7545 - SCM_COMPLEX_IMAG (y
));
7547 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7548 - SCM_COMPLEX_IMAG (y
));
7550 else if (SCM_FRACTIONP (y
))
7551 /* a - b/c = (ac - b) / c */
7552 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7553 SCM_FRACTION_NUMERATOR (y
)),
7554 SCM_FRACTION_DENOMINATOR (y
));
7556 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7558 else if (SCM_BIGP (x
))
7560 if (SCM_I_INUMP (y
))
7562 /* big-x - inum-y */
7563 scm_t_inum yy
= SCM_I_INUM (y
);
7564 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7566 scm_remember_upto_here_1 (x
);
7568 return (SCM_FIXABLE (-yy
) ?
7569 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7572 SCM result
= scm_i_mkbig ();
7575 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7577 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7578 scm_remember_upto_here_1 (x
);
7580 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7581 /* we know the result will have to be a bignum */
7584 return scm_i_normbig (result
);
7587 else if (SCM_BIGP (y
))
7589 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7590 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7591 SCM result
= scm_i_mkbig ();
7592 mpz_sub (SCM_I_BIG_MPZ (result
),
7595 scm_remember_upto_here_2 (x
, y
);
7596 /* we know the result will have to be a bignum */
7597 if ((sgn_x
== 1) && (sgn_y
== -1))
7599 if ((sgn_x
== -1) && (sgn_y
== 1))
7601 return scm_i_normbig (result
);
7603 else if (SCM_REALP (y
))
7605 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7606 scm_remember_upto_here_1 (x
);
7607 return scm_from_double (result
);
7609 else if (SCM_COMPLEXP (y
))
7611 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7612 - SCM_COMPLEX_REAL (y
));
7613 scm_remember_upto_here_1 (x
);
7614 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7616 else if (SCM_FRACTIONP (y
))
7617 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7618 SCM_FRACTION_NUMERATOR (y
)),
7619 SCM_FRACTION_DENOMINATOR (y
));
7620 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7622 else if (SCM_REALP (x
))
7624 if (SCM_I_INUMP (y
))
7625 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7626 else if (SCM_BIGP (y
))
7628 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7629 scm_remember_upto_here_1 (x
);
7630 return scm_from_double (result
);
7632 else if (SCM_REALP (y
))
7633 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7634 else if (SCM_COMPLEXP (y
))
7635 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7636 -SCM_COMPLEX_IMAG (y
));
7637 else if (SCM_FRACTIONP (y
))
7638 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7640 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7642 else if (SCM_COMPLEXP (x
))
7644 if (SCM_I_INUMP (y
))
7645 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7646 SCM_COMPLEX_IMAG (x
));
7647 else if (SCM_BIGP (y
))
7649 double real_part
= (SCM_COMPLEX_REAL (x
)
7650 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7651 scm_remember_upto_here_1 (x
);
7652 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7654 else if (SCM_REALP (y
))
7655 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7656 SCM_COMPLEX_IMAG (x
));
7657 else if (SCM_COMPLEXP (y
))
7658 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7659 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7660 else if (SCM_FRACTIONP (y
))
7661 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7662 SCM_COMPLEX_IMAG (x
));
7664 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7666 else if (SCM_FRACTIONP (x
))
7668 if (SCM_I_INUMP (y
))
7669 /* a/b - c = (a - cb) / b */
7670 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7671 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7672 SCM_FRACTION_DENOMINATOR (x
));
7673 else if (SCM_BIGP (y
))
7674 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7675 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7676 SCM_FRACTION_DENOMINATOR (x
));
7677 else if (SCM_REALP (y
))
7678 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7679 else if (SCM_COMPLEXP (y
))
7680 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7681 -SCM_COMPLEX_IMAG (y
));
7682 else if (SCM_FRACTIONP (y
))
7683 /* a/b - c/d = (ad - bc) / bd */
7684 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7685 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7686 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7688 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7691 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7696 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7698 "Return @math{@var{x}-1}.")
7699 #define FUNC_NAME s_scm_oneminus
7701 return scm_difference (x
, SCM_INUM1
);
7706 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7707 (SCM x
, SCM y
, SCM rest
),
7708 "Return the product of all arguments. If called without arguments,\n"
7710 #define FUNC_NAME s_scm_i_product
7712 while (!scm_is_null (rest
))
7713 { x
= scm_product (x
, y
);
7715 rest
= scm_cdr (rest
);
7717 return scm_product (x
, y
);
7721 #define s_product s_scm_i_product
7722 #define g_product g_scm_i_product
7725 scm_product (SCM x
, SCM y
)
7727 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7730 return SCM_I_MAKINUM (1L);
7731 else if (SCM_NUMBERP (x
))
7734 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7737 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7742 xx
= SCM_I_INUM (x
);
7747 /* exact1 is the universal multiplicative identity */
7751 /* exact0 times a fixnum is exact0: optimize this case */
7752 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7754 /* if the other argument is inexact, the result is inexact,
7755 and we must do the multiplication in order to handle
7756 infinities and NaNs properly. */
7757 else if (SCM_REALP (y
))
7758 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7759 else if (SCM_COMPLEXP (y
))
7760 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7761 0.0 * SCM_COMPLEX_IMAG (y
));
7762 /* we've already handled inexact numbers,
7763 so y must be exact, and we return exact0 */
7764 else if (SCM_NUMP (y
))
7767 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7771 * This case is important for more than just optimization.
7772 * It handles the case of negating
7773 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7774 * which is a bignum that must be changed back into a fixnum.
7775 * Failure to do so will cause the following to return #f:
7776 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7778 return scm_difference(y
, SCM_UNDEFINED
);
7782 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7784 scm_t_inum yy
= SCM_I_INUM (y
);
7785 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7786 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7787 if (SCM_FIXABLE (kk
))
7788 return SCM_I_MAKINUM (kk
);
7790 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7791 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7792 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7793 return SCM_I_MAKINUM (xx
* yy
);
7797 SCM result
= scm_i_inum2big (xx
);
7798 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7799 return scm_i_normbig (result
);
7802 else if (SCM_BIGP (y
))
7804 SCM result
= scm_i_mkbig ();
7805 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7806 scm_remember_upto_here_1 (y
);
7809 else if (SCM_REALP (y
))
7810 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7811 else if (SCM_COMPLEXP (y
))
7812 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7813 xx
* SCM_COMPLEX_IMAG (y
));
7814 else if (SCM_FRACTIONP (y
))
7815 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7816 SCM_FRACTION_DENOMINATOR (y
));
7818 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7820 else if (SCM_BIGP (x
))
7822 if (SCM_I_INUMP (y
))
7827 else if (SCM_BIGP (y
))
7829 SCM result
= scm_i_mkbig ();
7830 mpz_mul (SCM_I_BIG_MPZ (result
),
7833 scm_remember_upto_here_2 (x
, y
);
7836 else if (SCM_REALP (y
))
7838 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7839 scm_remember_upto_here_1 (x
);
7840 return scm_from_double (result
);
7842 else if (SCM_COMPLEXP (y
))
7844 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7845 scm_remember_upto_here_1 (x
);
7846 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7847 z
* SCM_COMPLEX_IMAG (y
));
7849 else if (SCM_FRACTIONP (y
))
7850 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7851 SCM_FRACTION_DENOMINATOR (y
));
7853 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7855 else if (SCM_REALP (x
))
7857 if (SCM_I_INUMP (y
))
7862 else if (SCM_BIGP (y
))
7864 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7865 scm_remember_upto_here_1 (y
);
7866 return scm_from_double (result
);
7868 else if (SCM_REALP (y
))
7869 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7870 else if (SCM_COMPLEXP (y
))
7871 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7872 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7873 else if (SCM_FRACTIONP (y
))
7874 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7876 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7878 else if (SCM_COMPLEXP (x
))
7880 if (SCM_I_INUMP (y
))
7885 else if (SCM_BIGP (y
))
7887 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7888 scm_remember_upto_here_1 (y
);
7889 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7890 z
* SCM_COMPLEX_IMAG (x
));
7892 else if (SCM_REALP (y
))
7893 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7894 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7895 else if (SCM_COMPLEXP (y
))
7897 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7898 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7899 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7900 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7902 else if (SCM_FRACTIONP (y
))
7904 double yy
= scm_i_fraction2double (y
);
7905 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7906 yy
* SCM_COMPLEX_IMAG (x
));
7909 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7911 else if (SCM_FRACTIONP (x
))
7913 if (SCM_I_INUMP (y
))
7914 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7915 SCM_FRACTION_DENOMINATOR (x
));
7916 else if (SCM_BIGP (y
))
7917 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7918 SCM_FRACTION_DENOMINATOR (x
));
7919 else if (SCM_REALP (y
))
7920 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7921 else if (SCM_COMPLEXP (y
))
7923 double xx
= scm_i_fraction2double (x
);
7924 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7925 xx
* SCM_COMPLEX_IMAG (y
));
7927 else if (SCM_FRACTIONP (y
))
7928 /* a/b * c/d = ac / bd */
7929 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7930 SCM_FRACTION_NUMERATOR (y
)),
7931 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7932 SCM_FRACTION_DENOMINATOR (y
)));
7934 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7937 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7940 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7941 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7942 #define ALLOW_DIVIDE_BY_ZERO
7943 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7946 /* The code below for complex division is adapted from the GNU
7947 libstdc++, which adapted it from f2c's libF77, and is subject to
7950 /****************************************************************
7951 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7953 Permission to use, copy, modify, and distribute this software
7954 and its documentation for any purpose and without fee is hereby
7955 granted, provided that the above copyright notice appear in all
7956 copies and that both that the copyright notice and this
7957 permission notice and warranty disclaimer appear in supporting
7958 documentation, and that the names of AT&T Bell Laboratories or
7959 Bellcore or any of their entities not be used in advertising or
7960 publicity pertaining to distribution of the software without
7961 specific, written prior permission.
7963 AT&T and Bellcore disclaim all warranties with regard to this
7964 software, including all implied warranties of merchantability
7965 and fitness. In no event shall AT&T or Bellcore be liable for
7966 any special, indirect or consequential damages or any damages
7967 whatsoever resulting from loss of use, data or profits, whether
7968 in an action of contract, negligence or other tortious action,
7969 arising out of or in connection with the use or performance of
7971 ****************************************************************/
7973 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7974 (SCM x
, SCM y
, SCM rest
),
7975 "Divide the first argument by the product of the remaining\n"
7976 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7978 #define FUNC_NAME s_scm_i_divide
7980 while (!scm_is_null (rest
))
7981 { x
= scm_divide (x
, y
);
7983 rest
= scm_cdr (rest
);
7985 return scm_divide (x
, y
);
7989 #define s_divide s_scm_i_divide
7990 #define g_divide g_scm_i_divide
7993 do_divide (SCM x
, SCM y
, int inexact
)
7994 #define FUNC_NAME s_divide
7998 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
8001 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
8002 else if (SCM_I_INUMP (x
))
8004 scm_t_inum xx
= SCM_I_INUM (x
);
8005 if (xx
== 1 || xx
== -1)
8007 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8009 scm_num_overflow (s_divide
);
8014 return scm_from_double (1.0 / (double) xx
);
8015 else return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8018 else if (SCM_BIGP (x
))
8021 return scm_from_double (1.0 / scm_i_big2dbl (x
));
8022 else return scm_i_make_ratio_already_reduced (SCM_INUM1
, x
);
8024 else if (SCM_REALP (x
))
8026 double xx
= SCM_REAL_VALUE (x
);
8027 #ifndef ALLOW_DIVIDE_BY_ZERO
8029 scm_num_overflow (s_divide
);
8032 return scm_from_double (1.0 / xx
);
8034 else if (SCM_COMPLEXP (x
))
8036 double r
= SCM_COMPLEX_REAL (x
);
8037 double i
= SCM_COMPLEX_IMAG (x
);
8038 if (fabs(r
) <= fabs(i
))
8041 double d
= i
* (1.0 + t
* t
);
8042 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
8047 double d
= r
* (1.0 + t
* t
);
8048 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
8051 else if (SCM_FRACTIONP (x
))
8052 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x
),
8053 SCM_FRACTION_NUMERATOR (x
));
8055 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
8058 if (SCM_LIKELY (SCM_I_INUMP (x
)))
8060 scm_t_inum xx
= SCM_I_INUM (x
);
8061 if (SCM_LIKELY (SCM_I_INUMP (y
)))
8063 scm_t_inum yy
= SCM_I_INUM (y
);
8066 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8067 scm_num_overflow (s_divide
);
8069 return scm_from_double ((double) xx
/ (double) yy
);
8072 else if (xx
% yy
!= 0)
8075 return scm_from_double ((double) xx
/ (double) yy
);
8076 else return scm_i_make_ratio (x
, y
);
8080 scm_t_inum z
= xx
/ yy
;
8081 if (SCM_FIXABLE (z
))
8082 return SCM_I_MAKINUM (z
);
8084 return scm_i_inum2big (z
);
8087 else if (SCM_BIGP (y
))
8090 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
8091 else return scm_i_make_ratio (x
, y
);
8093 else if (SCM_REALP (y
))
8095 double yy
= SCM_REAL_VALUE (y
);
8096 #ifndef ALLOW_DIVIDE_BY_ZERO
8098 scm_num_overflow (s_divide
);
8101 return scm_from_double ((double) xx
/ yy
);
8103 else if (SCM_COMPLEXP (y
))
8106 complex_div
: /* y _must_ be a complex number */
8108 double r
= SCM_COMPLEX_REAL (y
);
8109 double i
= SCM_COMPLEX_IMAG (y
);
8110 if (fabs(r
) <= fabs(i
))
8113 double d
= i
* (1.0 + t
* t
);
8114 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
8119 double d
= r
* (1.0 + t
* t
);
8120 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
8124 else if (SCM_FRACTIONP (y
))
8125 /* a / b/c = ac / b */
8126 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8127 SCM_FRACTION_NUMERATOR (y
));
8129 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8131 else if (SCM_BIGP (x
))
8133 if (SCM_I_INUMP (y
))
8135 scm_t_inum yy
= SCM_I_INUM (y
);
8138 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8139 scm_num_overflow (s_divide
);
8141 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8142 scm_remember_upto_here_1 (x
);
8143 return (sgn
== 0) ? scm_nan () : scm_inf ();
8150 /* FIXME: HMM, what are the relative performance issues here?
8151 We need to test. Is it faster on average to test
8152 divisible_p, then perform whichever operation, or is it
8153 faster to perform the integer div opportunistically and
8154 switch to real if there's a remainder? For now we take the
8155 middle ground: test, then if divisible, use the faster div
8158 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8159 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8163 SCM result
= scm_i_mkbig ();
8164 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8165 scm_remember_upto_here_1 (x
);
8167 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8168 return scm_i_normbig (result
);
8173 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8174 else return scm_i_make_ratio (x
, y
);
8178 else if (SCM_BIGP (y
))
8183 /* It's easily possible for the ratio x/y to fit a double
8184 but one or both x and y be too big to fit a double,
8185 hence the use of mpq_get_d rather than converting and
8188 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8189 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8190 return scm_from_double (mpq_get_d (q
));
8194 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8198 SCM result
= scm_i_mkbig ();
8199 mpz_divexact (SCM_I_BIG_MPZ (result
),
8202 scm_remember_upto_here_2 (x
, y
);
8203 return scm_i_normbig (result
);
8206 return scm_i_make_ratio (x
, y
);
8209 else if (SCM_REALP (y
))
8211 double yy
= SCM_REAL_VALUE (y
);
8212 #ifndef ALLOW_DIVIDE_BY_ZERO
8214 scm_num_overflow (s_divide
);
8217 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8219 else if (SCM_COMPLEXP (y
))
8221 a
= scm_i_big2dbl (x
);
8224 else if (SCM_FRACTIONP (y
))
8225 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8226 SCM_FRACTION_NUMERATOR (y
));
8228 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8230 else if (SCM_REALP (x
))
8232 double rx
= SCM_REAL_VALUE (x
);
8233 if (SCM_I_INUMP (y
))
8235 scm_t_inum yy
= SCM_I_INUM (y
);
8236 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8238 scm_num_overflow (s_divide
);
8241 return scm_from_double (rx
/ (double) yy
);
8243 else if (SCM_BIGP (y
))
8245 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8246 scm_remember_upto_here_1 (y
);
8247 return scm_from_double (rx
/ dby
);
8249 else if (SCM_REALP (y
))
8251 double yy
= SCM_REAL_VALUE (y
);
8252 #ifndef ALLOW_DIVIDE_BY_ZERO
8254 scm_num_overflow (s_divide
);
8257 return scm_from_double (rx
/ yy
);
8259 else if (SCM_COMPLEXP (y
))
8264 else if (SCM_FRACTIONP (y
))
8265 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8267 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8269 else if (SCM_COMPLEXP (x
))
8271 double rx
= SCM_COMPLEX_REAL (x
);
8272 double ix
= SCM_COMPLEX_IMAG (x
);
8273 if (SCM_I_INUMP (y
))
8275 scm_t_inum yy
= SCM_I_INUM (y
);
8276 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8278 scm_num_overflow (s_divide
);
8283 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8286 else if (SCM_BIGP (y
))
8288 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8289 scm_remember_upto_here_1 (y
);
8290 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8292 else if (SCM_REALP (y
))
8294 double yy
= SCM_REAL_VALUE (y
);
8295 #ifndef ALLOW_DIVIDE_BY_ZERO
8297 scm_num_overflow (s_divide
);
8300 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8302 else if (SCM_COMPLEXP (y
))
8304 double ry
= SCM_COMPLEX_REAL (y
);
8305 double iy
= SCM_COMPLEX_IMAG (y
);
8306 if (fabs(ry
) <= fabs(iy
))
8309 double d
= iy
* (1.0 + t
* t
);
8310 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8315 double d
= ry
* (1.0 + t
* t
);
8316 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8319 else if (SCM_FRACTIONP (y
))
8321 double yy
= scm_i_fraction2double (y
);
8322 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8325 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8327 else if (SCM_FRACTIONP (x
))
8329 if (SCM_I_INUMP (y
))
8331 scm_t_inum yy
= SCM_I_INUM (y
);
8332 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8334 scm_num_overflow (s_divide
);
8337 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8338 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8340 else if (SCM_BIGP (y
))
8342 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8343 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8345 else if (SCM_REALP (y
))
8347 double yy
= SCM_REAL_VALUE (y
);
8348 #ifndef ALLOW_DIVIDE_BY_ZERO
8350 scm_num_overflow (s_divide
);
8353 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8355 else if (SCM_COMPLEXP (y
))
8357 a
= scm_i_fraction2double (x
);
8360 else if (SCM_FRACTIONP (y
))
8361 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8362 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8364 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8367 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8371 scm_divide (SCM x
, SCM y
)
8373 return do_divide (x
, y
, 0);
8376 static SCM
scm_divide2real (SCM x
, SCM y
)
8378 return do_divide (x
, y
, 1);
8384 scm_c_truncate (double x
)
8389 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8390 half-way case (ie. when x is an integer plus 0.5) going upwards.
8391 Then half-way cases are identified and adjusted down if the
8392 round-upwards didn't give the desired even integer.
8394 "plus_half == result" identifies a half-way case. If plus_half, which is
8395 x + 0.5, is an integer then x must be an integer plus 0.5.
8397 An odd "result" value is identified with result/2 != floor(result/2).
8398 This is done with plus_half, since that value is ready for use sooner in
8399 a pipelined cpu, and we're already requiring plus_half == result.
8401 Note however that we need to be careful when x is big and already an
8402 integer. In that case "x+0.5" may round to an adjacent integer, causing
8403 us to return such a value, incorrectly. For instance if the hardware is
8404 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8405 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8406 returned. Or if the hardware is in round-upwards mode, then other bigger
8407 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8408 representable value, 2^128+2^76 (or whatever), again incorrect.
8410 These bad roundings of x+0.5 are avoided by testing at the start whether
8411 x is already an integer. If it is then clearly that's the desired result
8412 already. And if it's not then the exponent must be small enough to allow
8413 an 0.5 to be represented, and hence added without a bad rounding. */
8416 scm_c_round (double x
)
8418 double plus_half
, result
;
8423 plus_half
= x
+ 0.5;
8424 result
= floor (plus_half
);
8425 /* Adjust so that the rounding is towards even. */
8426 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8431 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8433 "Round the number @var{x} towards zero.")
8434 #define FUNC_NAME s_scm_truncate_number
8436 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8438 else if (SCM_REALP (x
))
8439 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8440 else if (SCM_FRACTIONP (x
))
8441 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8442 SCM_FRACTION_DENOMINATOR (x
));
8444 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8445 s_scm_truncate_number
);
8449 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8451 "Round the number @var{x} towards the nearest integer. "
8452 "When it is exactly halfway between two integers, "
8453 "round towards the even one.")
8454 #define FUNC_NAME s_scm_round_number
8456 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8458 else if (SCM_REALP (x
))
8459 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8460 else if (SCM_FRACTIONP (x
))
8461 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8462 SCM_FRACTION_DENOMINATOR (x
));
8464 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8465 s_scm_round_number
);
8469 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8471 "Round the number @var{x} towards minus infinity.")
8472 #define FUNC_NAME s_scm_floor
8474 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8476 else if (SCM_REALP (x
))
8477 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8478 else if (SCM_FRACTIONP (x
))
8479 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8480 SCM_FRACTION_DENOMINATOR (x
));
8482 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8486 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8488 "Round the number @var{x} towards infinity.")
8489 #define FUNC_NAME s_scm_ceiling
8491 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8493 else if (SCM_REALP (x
))
8494 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8495 else if (SCM_FRACTIONP (x
))
8496 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8497 SCM_FRACTION_DENOMINATOR (x
));
8499 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8503 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8505 "Return @var{x} raised to the power of @var{y}.")
8506 #define FUNC_NAME s_scm_expt
8508 if (scm_is_integer (y
))
8510 if (scm_is_true (scm_exact_p (y
)))
8511 return scm_integer_expt (x
, y
);
8514 /* Here we handle the case where the exponent is an inexact
8515 integer. We make the exponent exact in order to use
8516 scm_integer_expt, and thus avoid the spurious imaginary
8517 parts that may result from round-off errors in the general
8518 e^(y log x) method below (for example when squaring a large
8519 negative number). In this case, we must return an inexact
8520 result for correctness. We also make the base inexact so
8521 that scm_integer_expt will use fast inexact arithmetic
8522 internally. Note that making the base inexact is not
8523 sufficient to guarantee an inexact result, because
8524 scm_integer_expt will return an exact 1 when the exponent
8525 is 0, even if the base is inexact. */
8526 return scm_exact_to_inexact
8527 (scm_integer_expt (scm_exact_to_inexact (x
),
8528 scm_inexact_to_exact (y
)));
8531 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8533 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8535 else if (scm_is_complex (x
) && scm_is_complex (y
))
8536 return scm_exp (scm_product (scm_log (x
), y
));
8537 else if (scm_is_complex (x
))
8538 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8540 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8544 /* sin/cos/tan/asin/acos/atan
8545 sinh/cosh/tanh/asinh/acosh/atanh
8546 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8547 Written by Jerry D. Hedden, (C) FSF.
8548 See the file `COPYING' for terms applying to this program. */
8550 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8552 "Compute the sine of @var{z}.")
8553 #define FUNC_NAME s_scm_sin
8555 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8556 return z
; /* sin(exact0) = exact0 */
8557 else if (scm_is_real (z
))
8558 return scm_from_double (sin (scm_to_double (z
)));
8559 else if (SCM_COMPLEXP (z
))
8561 x
= SCM_COMPLEX_REAL (z
);
8562 y
= SCM_COMPLEX_IMAG (z
);
8563 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8564 cos (x
) * sinh (y
));
8567 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8571 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8573 "Compute the cosine of @var{z}.")
8574 #define FUNC_NAME s_scm_cos
8576 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8577 return SCM_INUM1
; /* cos(exact0) = exact1 */
8578 else if (scm_is_real (z
))
8579 return scm_from_double (cos (scm_to_double (z
)));
8580 else if (SCM_COMPLEXP (z
))
8582 x
= SCM_COMPLEX_REAL (z
);
8583 y
= SCM_COMPLEX_IMAG (z
);
8584 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8585 -sin (x
) * sinh (y
));
8588 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8592 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8594 "Compute the tangent of @var{z}.")
8595 #define FUNC_NAME s_scm_tan
8597 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8598 return z
; /* tan(exact0) = exact0 */
8599 else if (scm_is_real (z
))
8600 return scm_from_double (tan (scm_to_double (z
)));
8601 else if (SCM_COMPLEXP (z
))
8603 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8604 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8605 w
= cos (x
) + cosh (y
);
8606 #ifndef ALLOW_DIVIDE_BY_ZERO
8608 scm_num_overflow (s_scm_tan
);
8610 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8613 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8617 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8619 "Compute the hyperbolic sine of @var{z}.")
8620 #define FUNC_NAME s_scm_sinh
8622 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8623 return z
; /* sinh(exact0) = exact0 */
8624 else if (scm_is_real (z
))
8625 return scm_from_double (sinh (scm_to_double (z
)));
8626 else if (SCM_COMPLEXP (z
))
8628 x
= SCM_COMPLEX_REAL (z
);
8629 y
= SCM_COMPLEX_IMAG (z
);
8630 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8631 cosh (x
) * sin (y
));
8634 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8638 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8640 "Compute the hyperbolic cosine of @var{z}.")
8641 #define FUNC_NAME s_scm_cosh
8643 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8644 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8645 else if (scm_is_real (z
))
8646 return scm_from_double (cosh (scm_to_double (z
)));
8647 else if (SCM_COMPLEXP (z
))
8649 x
= SCM_COMPLEX_REAL (z
);
8650 y
= SCM_COMPLEX_IMAG (z
);
8651 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8652 sinh (x
) * sin (y
));
8655 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8659 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8661 "Compute the hyperbolic tangent of @var{z}.")
8662 #define FUNC_NAME s_scm_tanh
8664 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8665 return z
; /* tanh(exact0) = exact0 */
8666 else if (scm_is_real (z
))
8667 return scm_from_double (tanh (scm_to_double (z
)));
8668 else if (SCM_COMPLEXP (z
))
8670 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8671 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8672 w
= cosh (x
) + cos (y
);
8673 #ifndef ALLOW_DIVIDE_BY_ZERO
8675 scm_num_overflow (s_scm_tanh
);
8677 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8680 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8684 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8686 "Compute the arc sine of @var{z}.")
8687 #define FUNC_NAME s_scm_asin
8689 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8690 return z
; /* asin(exact0) = exact0 */
8691 else if (scm_is_real (z
))
8693 double w
= scm_to_double (z
);
8694 if (w
>= -1.0 && w
<= 1.0)
8695 return scm_from_double (asin (w
));
8697 return scm_product (scm_c_make_rectangular (0, -1),
8698 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8700 else if (SCM_COMPLEXP (z
))
8702 x
= SCM_COMPLEX_REAL (z
);
8703 y
= SCM_COMPLEX_IMAG (z
);
8704 return scm_product (scm_c_make_rectangular (0, -1),
8705 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8708 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8712 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8714 "Compute the arc cosine of @var{z}.")
8715 #define FUNC_NAME s_scm_acos
8717 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8718 return SCM_INUM0
; /* acos(exact1) = exact0 */
8719 else if (scm_is_real (z
))
8721 double w
= scm_to_double (z
);
8722 if (w
>= -1.0 && w
<= 1.0)
8723 return scm_from_double (acos (w
));
8725 return scm_sum (scm_from_double (acos (0.0)),
8726 scm_product (scm_c_make_rectangular (0, 1),
8727 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8729 else if (SCM_COMPLEXP (z
))
8731 x
= SCM_COMPLEX_REAL (z
);
8732 y
= SCM_COMPLEX_IMAG (z
);
8733 return scm_sum (scm_from_double (acos (0.0)),
8734 scm_product (scm_c_make_rectangular (0, 1),
8735 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8738 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8742 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8744 "With one argument, compute the arc tangent of @var{z}.\n"
8745 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8746 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8747 #define FUNC_NAME s_scm_atan
8751 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8752 return z
; /* atan(exact0) = exact0 */
8753 else if (scm_is_real (z
))
8754 return scm_from_double (atan (scm_to_double (z
)));
8755 else if (SCM_COMPLEXP (z
))
8758 v
= SCM_COMPLEX_REAL (z
);
8759 w
= SCM_COMPLEX_IMAG (z
);
8760 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8761 scm_c_make_rectangular (v
, w
+ 1.0))),
8762 scm_c_make_rectangular (0, 2));
8765 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8767 else if (scm_is_real (z
))
8769 if (scm_is_real (y
))
8770 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8772 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8775 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8779 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8781 "Compute the inverse hyperbolic sine of @var{z}.")
8782 #define FUNC_NAME s_scm_sys_asinh
8784 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8785 return z
; /* asinh(exact0) = exact0 */
8786 else if (scm_is_real (z
))
8787 return scm_from_double (asinh (scm_to_double (z
)));
8788 else if (scm_is_number (z
))
8789 return scm_log (scm_sum (z
,
8790 scm_sqrt (scm_sum (scm_product (z
, z
),
8793 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8797 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8799 "Compute the inverse hyperbolic cosine of @var{z}.")
8800 #define FUNC_NAME s_scm_sys_acosh
8802 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8803 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8804 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8805 return scm_from_double (acosh (scm_to_double (z
)));
8806 else if (scm_is_number (z
))
8807 return scm_log (scm_sum (z
,
8808 scm_sqrt (scm_difference (scm_product (z
, z
),
8811 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8815 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8817 "Compute the inverse hyperbolic tangent of @var{z}.")
8818 #define FUNC_NAME s_scm_sys_atanh
8820 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8821 return z
; /* atanh(exact0) = exact0 */
8822 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8823 return scm_from_double (atanh (scm_to_double (z
)));
8824 else if (scm_is_number (z
))
8825 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8826 scm_difference (SCM_INUM1
, z
))),
8829 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8834 scm_c_make_rectangular (double re
, double im
)
8838 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8840 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8841 SCM_COMPLEX_REAL (z
) = re
;
8842 SCM_COMPLEX_IMAG (z
) = im
;
8846 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8847 (SCM real_part
, SCM imaginary_part
),
8848 "Return a complex number constructed of the given @var{real_part} "
8849 "and @var{imaginary_part} parts.")
8850 #define FUNC_NAME s_scm_make_rectangular
8852 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8853 SCM_ARG1
, FUNC_NAME
, "real");
8854 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8855 SCM_ARG2
, FUNC_NAME
, "real");
8857 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8858 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8861 return scm_c_make_rectangular (scm_to_double (real_part
),
8862 scm_to_double (imaginary_part
));
8867 scm_c_make_polar (double mag
, double ang
)
8871 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8872 use it on Glibc-based systems that have it (it's a GNU extension). See
8873 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8875 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8876 sincos (ang
, &s
, &c
);
8882 /* If s and c are NaNs, this indicates that the angle is a NaN,
8883 infinite, or perhaps simply too large to determine its value
8884 mod 2*pi. However, we know something that the floating-point
8885 implementation doesn't know: We know that s and c are finite.
8886 Therefore, if the magnitude is zero, return a complex zero.
8888 The reason we check for the NaNs instead of using this case
8889 whenever mag == 0.0 is because when the angle is known, we'd
8890 like to return the correct kind of non-real complex zero:
8891 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8892 on which quadrant the angle is in.
8894 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8895 return scm_c_make_rectangular (0.0, 0.0);
8897 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8900 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8902 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8903 #define FUNC_NAME s_scm_make_polar
8905 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8906 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8908 /* If mag is exact0, return exact0 */
8909 if (scm_is_eq (mag
, SCM_INUM0
))
8911 /* Return a real if ang is exact0 */
8912 else if (scm_is_eq (ang
, SCM_INUM0
))
8915 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8920 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8922 "Return the real part of the number @var{z}.")
8923 #define FUNC_NAME s_scm_real_part
8925 if (SCM_COMPLEXP (z
))
8926 return scm_from_double (SCM_COMPLEX_REAL (z
));
8927 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8930 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8935 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8937 "Return the imaginary part of the number @var{z}.")
8938 #define FUNC_NAME s_scm_imag_part
8940 if (SCM_COMPLEXP (z
))
8941 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8942 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8945 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8949 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8951 "Return the numerator of the number @var{z}.")
8952 #define FUNC_NAME s_scm_numerator
8954 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8956 else if (SCM_FRACTIONP (z
))
8957 return SCM_FRACTION_NUMERATOR (z
);
8958 else if (SCM_REALP (z
))
8959 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8961 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8966 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8968 "Return the denominator of the number @var{z}.")
8969 #define FUNC_NAME s_scm_denominator
8971 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8973 else if (SCM_FRACTIONP (z
))
8974 return SCM_FRACTION_DENOMINATOR (z
);
8975 else if (SCM_REALP (z
))
8976 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8978 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8983 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8985 "Return the magnitude of the number @var{z}. This is the same as\n"
8986 "@code{abs} for real arguments, but also allows complex numbers.")
8987 #define FUNC_NAME s_scm_magnitude
8989 if (SCM_I_INUMP (z
))
8991 scm_t_inum zz
= SCM_I_INUM (z
);
8994 else if (SCM_POSFIXABLE (-zz
))
8995 return SCM_I_MAKINUM (-zz
);
8997 return scm_i_inum2big (-zz
);
8999 else if (SCM_BIGP (z
))
9001 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9002 scm_remember_upto_here_1 (z
);
9004 return scm_i_clonebig (z
, 0);
9008 else if (SCM_REALP (z
))
9009 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
9010 else if (SCM_COMPLEXP (z
))
9011 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
9012 else if (SCM_FRACTIONP (z
))
9014 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9016 return scm_i_make_ratio_already_reduced
9017 (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
9018 SCM_FRACTION_DENOMINATOR (z
));
9021 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
9026 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
9028 "Return the angle of the complex number @var{z}.")
9029 #define FUNC_NAME s_scm_angle
9031 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9032 flo0 to save allocating a new flonum with scm_from_double each time.
9033 But if atan2 follows the floating point rounding mode, then the value
9034 is not a constant. Maybe it'd be close enough though. */
9035 if (SCM_I_INUMP (z
))
9037 if (SCM_I_INUM (z
) >= 0)
9040 return scm_from_double (atan2 (0.0, -1.0));
9042 else if (SCM_BIGP (z
))
9044 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
9045 scm_remember_upto_here_1 (z
);
9047 return scm_from_double (atan2 (0.0, -1.0));
9051 else if (SCM_REALP (z
))
9053 double x
= SCM_REAL_VALUE (z
);
9054 if (x
> 0.0 || double_is_non_negative_zero (x
))
9057 return scm_from_double (atan2 (0.0, -1.0));
9059 else if (SCM_COMPLEXP (z
))
9060 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
9061 else if (SCM_FRACTIONP (z
))
9063 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
9065 else return scm_from_double (atan2 (0.0, -1.0));
9068 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
9073 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
9075 "Convert the number @var{z} to its inexact representation.\n")
9076 #define FUNC_NAME s_scm_exact_to_inexact
9078 if (SCM_I_INUMP (z
))
9079 return scm_from_double ((double) SCM_I_INUM (z
));
9080 else if (SCM_BIGP (z
))
9081 return scm_from_double (scm_i_big2dbl (z
));
9082 else if (SCM_FRACTIONP (z
))
9083 return scm_from_double (scm_i_fraction2double (z
));
9084 else if (SCM_INEXACTP (z
))
9087 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
9092 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
9094 "Return an exact number that is numerically closest to @var{z}.")
9095 #define FUNC_NAME s_scm_inexact_to_exact
9097 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
9104 val
= SCM_REAL_VALUE (z
);
9105 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
9106 val
= SCM_COMPLEX_REAL (z
);
9108 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
9110 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
9111 SCM_OUT_OF_RANGE (1, z
);
9118 mpq_set_d (frac
, val
);
9119 q
= scm_i_make_ratio_already_reduced
9120 (scm_i_mpz2num (mpq_numref (frac
)),
9121 scm_i_mpz2num (mpq_denref (frac
)));
9123 /* When scm_i_make_ratio throws, we leak the memory allocated
9133 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9135 "Returns the @emph{simplest} rational number differing\n"
9136 "from @var{x} by no more than @var{eps}.\n"
9138 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9139 "exact result when both its arguments are exact. Thus, you might need\n"
9140 "to use @code{inexact->exact} on the arguments.\n"
9143 "(rationalize (inexact->exact 1.2) 1/100)\n"
9146 #define FUNC_NAME s_scm_rationalize
9148 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9149 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9150 eps
= scm_abs (eps
);
9151 if (scm_is_false (scm_positive_p (eps
)))
9153 /* eps is either zero or a NaN */
9154 if (scm_is_true (scm_nan_p (eps
)))
9156 else if (SCM_INEXACTP (eps
))
9157 return scm_exact_to_inexact (x
);
9161 else if (scm_is_false (scm_finite_p (eps
)))
9163 if (scm_is_true (scm_finite_p (x
)))
9168 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9170 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9171 scm_ceiling (scm_difference (x
, eps
)))))
9173 /* There's an integer within range; we want the one closest to zero */
9174 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9176 /* zero is within range */
9177 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9182 else if (scm_is_true (scm_positive_p (x
)))
9183 return scm_ceiling (scm_difference (x
, eps
));
9185 return scm_floor (scm_sum (x
, eps
));
9189 /* Use continued fractions to find closest ratio. All
9190 arithmetic is done with exact numbers.
9193 SCM ex
= scm_inexact_to_exact (x
);
9194 SCM int_part
= scm_floor (ex
);
9196 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9197 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9201 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9202 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9204 /* We stop after a million iterations just to be absolutely sure
9205 that we don't go into an infinite loop. The process normally
9206 converges after less than a dozen iterations.
9209 while (++i
< 1000000)
9211 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9212 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9213 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9215 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9216 eps
))) /* abs(x-a/b) <= eps */
9218 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9219 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9220 return scm_exact_to_inexact (res
);
9224 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9226 tt
= scm_floor (rx
); /* tt = floor (rx) */
9232 scm_num_overflow (s_scm_rationalize
);
9237 /* conversion functions */
9240 scm_is_integer (SCM val
)
9242 return scm_is_true (scm_integer_p (val
));
9246 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9248 if (SCM_I_INUMP (val
))
9250 scm_t_signed_bits n
= SCM_I_INUM (val
);
9251 return n
>= min
&& n
<= max
;
9253 else if (SCM_BIGP (val
))
9255 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9257 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9259 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9261 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9262 return n
>= min
&& n
<= max
;
9272 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9273 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9276 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9277 SCM_I_BIG_MPZ (val
));
9279 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9291 return n
>= min
&& n
<= max
;
9299 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9301 if (SCM_I_INUMP (val
))
9303 scm_t_signed_bits n
= SCM_I_INUM (val
);
9304 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9306 else if (SCM_BIGP (val
))
9308 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9310 else if (max
<= ULONG_MAX
)
9312 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9314 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9315 return n
>= min
&& n
<= max
;
9325 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9328 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9329 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9332 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9333 SCM_I_BIG_MPZ (val
));
9335 return n
>= min
&& n
<= max
;
9343 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9345 scm_error (scm_out_of_range_key
,
9347 "Value out of range ~S to ~S: ~S",
9348 scm_list_3 (min
, max
, bad_val
),
9349 scm_list_1 (bad_val
));
9352 #define TYPE scm_t_intmax
9353 #define TYPE_MIN min
9354 #define TYPE_MAX max
9355 #define SIZEOF_TYPE 0
9356 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9357 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9358 #include "libguile/conv-integer.i.c"
9360 #define TYPE scm_t_uintmax
9361 #define TYPE_MIN min
9362 #define TYPE_MAX max
9363 #define SIZEOF_TYPE 0
9364 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9365 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9366 #include "libguile/conv-uinteger.i.c"
9368 #define TYPE scm_t_int8
9369 #define TYPE_MIN SCM_T_INT8_MIN
9370 #define TYPE_MAX SCM_T_INT8_MAX
9371 #define SIZEOF_TYPE 1
9372 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9373 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9374 #include "libguile/conv-integer.i.c"
9376 #define TYPE scm_t_uint8
9378 #define TYPE_MAX SCM_T_UINT8_MAX
9379 #define SIZEOF_TYPE 1
9380 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9381 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9382 #include "libguile/conv-uinteger.i.c"
9384 #define TYPE scm_t_int16
9385 #define TYPE_MIN SCM_T_INT16_MIN
9386 #define TYPE_MAX SCM_T_INT16_MAX
9387 #define SIZEOF_TYPE 2
9388 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9389 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9390 #include "libguile/conv-integer.i.c"
9392 #define TYPE scm_t_uint16
9394 #define TYPE_MAX SCM_T_UINT16_MAX
9395 #define SIZEOF_TYPE 2
9396 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9397 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9398 #include "libguile/conv-uinteger.i.c"
9400 #define TYPE scm_t_int32
9401 #define TYPE_MIN SCM_T_INT32_MIN
9402 #define TYPE_MAX SCM_T_INT32_MAX
9403 #define SIZEOF_TYPE 4
9404 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9405 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9406 #include "libguile/conv-integer.i.c"
9408 #define TYPE scm_t_uint32
9410 #define TYPE_MAX SCM_T_UINT32_MAX
9411 #define SIZEOF_TYPE 4
9412 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9413 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9414 #include "libguile/conv-uinteger.i.c"
9416 #define TYPE scm_t_wchar
9417 #define TYPE_MIN (scm_t_int32)-1
9418 #define TYPE_MAX (scm_t_int32)0x10ffff
9419 #define SIZEOF_TYPE 4
9420 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9421 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9422 #include "libguile/conv-integer.i.c"
9424 #define TYPE scm_t_int64
9425 #define TYPE_MIN SCM_T_INT64_MIN
9426 #define TYPE_MAX SCM_T_INT64_MAX
9427 #define SIZEOF_TYPE 8
9428 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9429 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9430 #include "libguile/conv-integer.i.c"
9432 #define TYPE scm_t_uint64
9434 #define TYPE_MAX SCM_T_UINT64_MAX
9435 #define SIZEOF_TYPE 8
9436 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9437 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9438 #include "libguile/conv-uinteger.i.c"
9441 scm_to_mpz (SCM val
, mpz_t rop
)
9443 if (SCM_I_INUMP (val
))
9444 mpz_set_si (rop
, SCM_I_INUM (val
));
9445 else if (SCM_BIGP (val
))
9446 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9448 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9452 scm_from_mpz (mpz_t val
)
9454 return scm_i_mpz2num (val
);
9458 scm_is_real (SCM val
)
9460 return scm_is_true (scm_real_p (val
));
9464 scm_is_rational (SCM val
)
9466 return scm_is_true (scm_rational_p (val
));
9470 scm_to_double (SCM val
)
9472 if (SCM_I_INUMP (val
))
9473 return SCM_I_INUM (val
);
9474 else if (SCM_BIGP (val
))
9475 return scm_i_big2dbl (val
);
9476 else if (SCM_FRACTIONP (val
))
9477 return scm_i_fraction2double (val
);
9478 else if (SCM_REALP (val
))
9479 return SCM_REAL_VALUE (val
);
9481 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9485 scm_from_double (double val
)
9489 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9491 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9492 SCM_REAL_VALUE (z
) = val
;
9497 #if SCM_ENABLE_DEPRECATED == 1
9500 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9502 scm_c_issue_deprecation_warning
9503 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9507 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9511 scm_out_of_range (NULL
, num
);
9514 return scm_to_double (num
);
9518 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9520 scm_c_issue_deprecation_warning
9521 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9525 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9529 scm_out_of_range (NULL
, num
);
9532 return scm_to_double (num
);
9538 scm_is_complex (SCM val
)
9540 return scm_is_true (scm_complex_p (val
));
9544 scm_c_real_part (SCM z
)
9546 if (SCM_COMPLEXP (z
))
9547 return SCM_COMPLEX_REAL (z
);
9550 /* Use the scm_real_part to get proper error checking and
9553 return scm_to_double (scm_real_part (z
));
9558 scm_c_imag_part (SCM z
)
9560 if (SCM_COMPLEXP (z
))
9561 return SCM_COMPLEX_IMAG (z
);
9564 /* Use the scm_imag_part to get proper error checking and
9565 dispatching. The result will almost always be 0.0, but not
9568 return scm_to_double (scm_imag_part (z
));
9573 scm_c_magnitude (SCM z
)
9575 return scm_to_double (scm_magnitude (z
));
9581 return scm_to_double (scm_angle (z
));
9585 scm_is_number (SCM z
)
9587 return scm_is_true (scm_number_p (z
));
9591 /* Returns log(x * 2^shift) */
9593 log_of_shifted_double (double x
, long shift
)
9595 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9597 if (x
> 0.0 || double_is_non_negative_zero (x
))
9598 return scm_from_double (ans
);
9600 return scm_c_make_rectangular (ans
, M_PI
);
9603 /* Returns log(n), for exact integer n of integer-length size */
9605 log_of_exact_integer_with_size (SCM n
, long size
)
9607 long shift
= size
- 2 * scm_dblprec
[0];
9610 return log_of_shifted_double
9611 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9614 return log_of_shifted_double (scm_to_double (n
), 0);
9617 /* Returns log(n), for exact integer n */
9619 log_of_exact_integer (SCM n
)
9621 return log_of_exact_integer_with_size
9622 (n
, scm_to_long (scm_integer_length (n
)));
9625 /* Returns log(n/d), for exact non-zero integers n and d */
9627 log_of_fraction (SCM n
, SCM d
)
9629 long n_size
= scm_to_long (scm_integer_length (n
));
9630 long d_size
= scm_to_long (scm_integer_length (d
));
9632 if (abs (n_size
- d_size
) > 1)
9633 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9634 log_of_exact_integer_with_size (d
, d_size
)));
9635 else if (scm_is_false (scm_negative_p (n
)))
9636 return scm_from_double
9637 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9639 return scm_c_make_rectangular
9640 (log1p (scm_to_double (scm_divide2real
9641 (scm_difference (scm_abs (n
), d
),
9647 /* In the following functions we dispatch to the real-arg funcs like log()
9648 when we know the arg is real, instead of just handing everything to
9649 clog() for instance. This is in case clog() doesn't optimize for a
9650 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9651 well use it to go straight to the applicable C func. */
9653 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9655 "Return the natural logarithm of @var{z}.")
9656 #define FUNC_NAME s_scm_log
9658 if (SCM_COMPLEXP (z
))
9660 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9661 && defined (SCM_COMPLEX_VALUE)
9662 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9664 double re
= SCM_COMPLEX_REAL (z
);
9665 double im
= SCM_COMPLEX_IMAG (z
);
9666 return scm_c_make_rectangular (log (hypot (re
, im
)),
9670 else if (SCM_REALP (z
))
9671 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9672 else if (SCM_I_INUMP (z
))
9674 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9675 if (scm_is_eq (z
, SCM_INUM0
))
9676 scm_num_overflow (s_scm_log
);
9678 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9680 else if (SCM_BIGP (z
))
9681 return log_of_exact_integer (z
);
9682 else if (SCM_FRACTIONP (z
))
9683 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9684 SCM_FRACTION_DENOMINATOR (z
));
9686 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9691 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9693 "Return the base 10 logarithm of @var{z}.")
9694 #define FUNC_NAME s_scm_log10
9696 if (SCM_COMPLEXP (z
))
9698 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9699 clog() and a multiply by M_LOG10E, rather than the fallback
9700 log10+hypot+atan2.) */
9701 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9702 && defined SCM_COMPLEX_VALUE
9703 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9705 double re
= SCM_COMPLEX_REAL (z
);
9706 double im
= SCM_COMPLEX_IMAG (z
);
9707 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9708 M_LOG10E
* atan2 (im
, re
));
9711 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9713 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9714 if (scm_is_eq (z
, SCM_INUM0
))
9715 scm_num_overflow (s_scm_log10
);
9718 double re
= scm_to_double (z
);
9719 double l
= log10 (fabs (re
));
9720 if (re
> 0.0 || double_is_non_negative_zero (re
))
9721 return scm_from_double (l
);
9723 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9726 else if (SCM_BIGP (z
))
9727 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9728 else if (SCM_FRACTIONP (z
))
9729 return scm_product (flo_log10e
,
9730 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9731 SCM_FRACTION_DENOMINATOR (z
)));
9733 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9738 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9740 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9741 "base of natural logarithms (2.71828@dots{}).")
9742 #define FUNC_NAME s_scm_exp
9744 if (SCM_COMPLEXP (z
))
9746 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9747 && defined (SCM_COMPLEX_VALUE)
9748 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9750 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9751 SCM_COMPLEX_IMAG (z
));
9754 else if (SCM_NUMBERP (z
))
9756 /* When z is a negative bignum the conversion to double overflows,
9757 giving -infinity, but that's ok, the exp is still 0.0. */
9758 return scm_from_double (exp (scm_to_double (z
)));
9761 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9766 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9768 "Return two exact non-negative integers @var{s} and @var{r}\n"
9769 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9770 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9771 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9774 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9776 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9780 scm_exact_integer_sqrt (k
, &s
, &r
);
9781 return scm_values (scm_list_2 (s
, r
));
9786 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9788 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9790 scm_t_inum kk
= SCM_I_INUM (k
);
9794 if (SCM_LIKELY (kk
> 0))
9799 uu
= (ss
+ kk
/ss
) / 2;
9801 *sp
= SCM_I_MAKINUM (ss
);
9802 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9804 else if (SCM_LIKELY (kk
== 0))
9805 *sp
= *rp
= SCM_INUM0
;
9807 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9808 "exact non-negative integer");
9810 else if (SCM_LIKELY (SCM_BIGP (k
)))
9814 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9815 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9816 "exact non-negative integer");
9819 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9820 scm_remember_upto_here_1 (k
);
9821 *sp
= scm_i_normbig (s
);
9822 *rp
= scm_i_normbig (r
);
9825 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9826 "exact non-negative integer");
9830 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9832 "Return the square root of @var{z}. Of the two possible roots\n"
9833 "(positive and negative), the one with positive real part\n"
9834 "is returned, or if that's zero then a positive imaginary part.\n"
9838 "(sqrt 9.0) @result{} 3.0\n"
9839 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9840 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9841 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9843 #define FUNC_NAME s_scm_sqrt
9845 if (SCM_COMPLEXP (z
))
9847 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9848 && defined SCM_COMPLEX_VALUE
9849 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9851 double re
= SCM_COMPLEX_REAL (z
);
9852 double im
= SCM_COMPLEX_IMAG (z
);
9853 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9854 0.5 * atan2 (im
, re
));
9857 else if (SCM_NUMBERP (z
))
9859 double xx
= scm_to_double (z
);
9861 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9863 return scm_from_double (sqrt (xx
));
9866 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9877 if (scm_install_gmp_memory_functions
)
9878 mp_set_memory_functions (custom_gmp_malloc
,
9882 mpz_init_set_si (z_negative_one
, -1);
9884 /* It may be possible to tune the performance of some algorithms by using
9885 * the following constants to avoid the creation of bignums. Please, before
9886 * using these values, remember the two rules of program optimization:
9887 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9888 scm_c_define ("most-positive-fixnum",
9889 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9890 scm_c_define ("most-negative-fixnum",
9891 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9893 scm_add_feature ("complex");
9894 scm_add_feature ("inexact");
9895 flo0
= scm_from_double (0.0);
9896 flo_log10e
= scm_from_double (M_LOG10E
);
9898 /* determine floating point precision */
9899 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9901 init_dblprec(&scm_dblprec
[i
-2],i
);
9902 init_fx_radix(fx_per_radix
[i
-2],i
);
9905 /* hard code precision for base 10 if the preprocessor tells us to... */
9906 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9909 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9910 #include "libguile/numbers.x"