1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 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.
57 #include "libguile/_scm.h"
58 #include "libguile/feature.h"
59 #include "libguile/ports.h"
60 #include "libguile/root.h"
61 #include "libguile/smob.h"
62 #include "libguile/strings.h"
63 #include "libguile/bdw-gc.h"
65 #include "libguile/validate.h"
66 #include "libguile/numbers.h"
67 #include "libguile/deprecation.h"
69 #include "libguile/eq.h"
71 /* values per glibc, if not already defined */
73 #define M_LOG10E 0.43429448190325182765
76 #define M_PI 3.14159265358979323846
79 typedef scm_t_signed_bits scm_t_inum
;
80 #define scm_from_inum(x) (scm_from_signed_integer (x))
82 /* Tests to see if a C double is neither infinite nor a NaN.
83 TODO: if it's available, use C99's isfinite(x) instead */
84 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
86 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
87 of the infinity, but other platforms return a boolean only. */
88 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
89 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
94 Wonder if this might be faster for some of our code? A switch on
95 the numtag would jump directly to the right case, and the
96 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
98 #define SCM_I_NUMTAG_NOTNUM 0
99 #define SCM_I_NUMTAG_INUM 1
100 #define SCM_I_NUMTAG_BIG scm_tc16_big
101 #define SCM_I_NUMTAG_REAL scm_tc16_real
102 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
103 #define SCM_I_NUMTAG(x) \
104 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
105 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
106 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
107 : SCM_I_NUMTAG_NOTNUM)))
109 /* the macro above will not work as is with fractions */
113 static SCM exactly_one_half
;
114 static SCM flo_log10e
;
116 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
118 /* FLOBUFLEN is the maximum number of characters neccessary for the
119 * printed or scm_string representation of an inexact number.
121 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
124 #if !defined (HAVE_ASINH)
125 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
127 #if !defined (HAVE_ACOSH)
128 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
130 #if !defined (HAVE_ATANH)
131 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
134 /* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
135 an explicit check. In some future gmp (don't know what version number),
136 mpz_cmp_d is supposed to do this itself. */
138 #define xmpz_cmp_d(z, d) \
139 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
141 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
145 #if defined (GUILE_I)
146 #if HAVE_COMPLEX_DOUBLE
148 /* For an SCM object Z which is a complex number (ie. satisfies
149 SCM_COMPLEXP), return its value as a C level "complex double". */
150 #define SCM_COMPLEX_VALUE(z) \
151 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
153 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
155 /* Convert a C "complex double" to an SCM value. */
157 scm_from_complex_double (complex double z
)
159 return scm_c_make_rectangular (creal (z
), cimag (z
));
162 #endif /* HAVE_COMPLEX_DOUBLE */
167 static mpz_t z_negative_one
;
170 /* Clear the `mpz_t' embedded in bignum PTR. */
172 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
176 bignum
= PTR2SCM (ptr
);
177 mpz_clear (SCM_I_BIG_MPZ (bignum
));
180 /* Return a new uninitialized bignum. */
185 GC_finalization_proc prev_finalizer
;
186 GC_PTR prev_finalizer_data
;
188 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
189 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
193 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
195 &prev_finalizer_data
);
204 /* Return a newly created bignum. */
205 SCM z
= make_bignum ();
206 mpz_init (SCM_I_BIG_MPZ (z
));
211 scm_i_inum2big (scm_t_inum x
)
213 /* Return a newly created bignum initialized to X. */
214 SCM z
= make_bignum ();
215 #if SIZEOF_VOID_P == SIZEOF_LONG
216 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
218 /* Note that in this case, you'll also have to check all mpz_*_ui and
219 mpz_*_si invocations in Guile. */
220 #error creation of mpz not implemented for this inum size
226 scm_i_long2big (long x
)
228 /* Return a newly created bignum initialized to X. */
229 SCM z
= make_bignum ();
230 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
235 scm_i_ulong2big (unsigned long x
)
237 /* Return a newly created bignum initialized to X. */
238 SCM z
= make_bignum ();
239 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
244 scm_i_clonebig (SCM src_big
, int same_sign_p
)
246 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
247 SCM z
= make_bignum ();
248 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
250 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
255 scm_i_bigcmp (SCM x
, SCM y
)
257 /* Return neg if x < y, pos if x > y, and 0 if x == y */
258 /* presume we already know x and y are bignums */
259 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
260 scm_remember_upto_here_2 (x
, y
);
265 scm_i_dbl2big (double d
)
267 /* results are only defined if d is an integer */
268 SCM z
= make_bignum ();
269 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
273 /* Convert a integer in double representation to a SCM number. */
276 scm_i_dbl2num (double u
)
278 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
279 powers of 2, so there's no rounding when making "double" values
280 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
281 get rounded on a 64-bit machine, hence the "+1".
283 The use of floor() to force to an integer value ensures we get a
284 "numerically closest" value without depending on how a
285 double->long cast or how mpz_set_d will round. For reference,
286 double->long probably follows the hardware rounding mode,
287 mpz_set_d truncates towards zero. */
289 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
290 representable as a double? */
292 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
293 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
294 return SCM_I_MAKINUM ((scm_t_inum
) u
);
296 return scm_i_dbl2big (u
);
299 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
300 with R5RS exact->inexact.
302 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
303 (ie. truncate towards zero), then adjust to get the closest double by
304 examining the next lower bit and adding 1 (to the absolute value) if
307 Bignums exactly half way between representable doubles are rounded to the
308 next higher absolute value (ie. away from zero). This seems like an
309 adequate interpretation of R5RS "numerically closest", and it's easier
310 and faster than a full "nearest-even" style.
312 The bit test must be done on the absolute value of the mpz_t, which means
313 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
314 negatives as twos complement.
316 In current gmp 4.1.3, mpz_get_d rounding is unspecified. It ends up
317 following the hardware rounding mode, but applied to the absolute value
318 of the mpz_t operand. This is not what we want so we put the high
319 DBL_MANT_DIG bits into a temporary. In some future gmp, don't know when,
320 mpz_get_d is supposed to always truncate towards zero.
322 ENHANCE-ME: The temporary init+clear to force the rounding in gmp 4.1.3
323 is a slowdown. It'd be faster to pick out the relevant high bits with
324 mpz_getlimbn if we could be bothered coding that, and if the new
325 truncating gmp doesn't come out. */
328 scm_i_big2dbl (SCM b
)
333 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
337 /* Current GMP, eg. 4.1.3, force truncation towards zero */
339 if (bits
> DBL_MANT_DIG
)
341 size_t shift
= bits
- DBL_MANT_DIG
;
342 mpz_init2 (tmp
, DBL_MANT_DIG
);
343 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
344 result
= ldexp (mpz_get_d (tmp
), shift
);
349 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
354 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
357 if (bits
> DBL_MANT_DIG
)
359 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
360 /* test bit number "pos" in absolute value */
361 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
362 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
364 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
368 scm_remember_upto_here_1 (b
);
373 scm_i_normbig (SCM b
)
375 /* convert a big back to a fixnum if it'll fit */
376 /* presume b is a bignum */
377 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
379 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
380 if (SCM_FIXABLE (val
))
381 b
= SCM_I_MAKINUM (val
);
386 static SCM_C_INLINE_KEYWORD SCM
387 scm_i_mpz2num (mpz_t b
)
389 /* convert a mpz number to a SCM number. */
390 if (mpz_fits_slong_p (b
))
392 scm_t_inum val
= mpz_get_si (b
);
393 if (SCM_FIXABLE (val
))
394 return SCM_I_MAKINUM (val
);
398 SCM z
= make_bignum ();
399 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
404 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
405 static SCM
scm_divide2real (SCM x
, SCM y
);
408 scm_i_make_ratio (SCM numerator
, SCM denominator
)
409 #define FUNC_NAME "make-ratio"
411 /* First make sure the arguments are proper.
413 if (SCM_I_INUMP (denominator
))
415 if (scm_is_eq (denominator
, SCM_INUM0
))
416 scm_num_overflow ("make-ratio");
417 if (scm_is_eq (denominator
, SCM_INUM1
))
422 if (!(SCM_BIGP(denominator
)))
423 SCM_WRONG_TYPE_ARG (2, denominator
);
425 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
426 SCM_WRONG_TYPE_ARG (1, numerator
);
428 /* Then flip signs so that the denominator is positive.
430 if (scm_is_true (scm_negative_p (denominator
)))
432 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
433 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
436 /* Now consider for each of the four fixnum/bignum combinations
437 whether the rational number is really an integer.
439 if (SCM_I_INUMP (numerator
))
441 scm_t_inum x
= SCM_I_INUM (numerator
);
442 if (scm_is_eq (numerator
, SCM_INUM0
))
444 if (SCM_I_INUMP (denominator
))
447 y
= SCM_I_INUM (denominator
);
451 return SCM_I_MAKINUM (x
/ y
);
455 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
456 of that value for the denominator, as a bignum. Apart from
457 that case, abs(bignum) > abs(inum) so inum/bignum is not an
459 if (x
== SCM_MOST_NEGATIVE_FIXNUM
460 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
461 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
462 return SCM_I_MAKINUM(-1);
465 else if (SCM_BIGP (numerator
))
467 if (SCM_I_INUMP (denominator
))
469 scm_t_inum yy
= SCM_I_INUM (denominator
);
470 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
471 return scm_divide (numerator
, denominator
);
475 if (scm_is_eq (numerator
, denominator
))
477 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
478 SCM_I_BIG_MPZ (denominator
)))
479 return scm_divide(numerator
, denominator
);
483 /* No, it's a proper fraction.
486 SCM divisor
= scm_gcd (numerator
, denominator
);
487 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
489 numerator
= scm_divide (numerator
, divisor
);
490 denominator
= scm_divide (denominator
, divisor
);
493 return scm_double_cell (scm_tc16_fraction
,
494 SCM_UNPACK (numerator
),
495 SCM_UNPACK (denominator
), 0);
501 scm_i_fraction2double (SCM z
)
503 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
504 SCM_FRACTION_DENOMINATOR (z
)));
508 double_is_non_negative_zero (double x
)
510 static double zero
= 0.0;
512 return !memcmp (&x
, &zero
, sizeof(double));
515 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
517 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
519 #define FUNC_NAME s_scm_exact_p
521 if (SCM_INEXACTP (x
))
523 else if (SCM_NUMBERP (x
))
526 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
531 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
533 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
535 #define FUNC_NAME s_scm_inexact_p
537 if (SCM_INEXACTP (x
))
539 else if (SCM_NUMBERP (x
))
542 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
547 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
549 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
551 #define FUNC_NAME s_scm_odd_p
555 scm_t_inum val
= SCM_I_INUM (n
);
556 return scm_from_bool ((val
& 1L) != 0);
558 else if (SCM_BIGP (n
))
560 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
561 scm_remember_upto_here_1 (n
);
562 return scm_from_bool (odd_p
);
564 else if (SCM_REALP (n
))
566 double val
= SCM_REAL_VALUE (n
);
567 if (DOUBLE_IS_FINITE (val
))
569 double rem
= fabs (fmod (val
, 2.0));
576 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
581 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
583 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
585 #define FUNC_NAME s_scm_even_p
589 scm_t_inum val
= SCM_I_INUM (n
);
590 return scm_from_bool ((val
& 1L) == 0);
592 else if (SCM_BIGP (n
))
594 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
595 scm_remember_upto_here_1 (n
);
596 return scm_from_bool (even_p
);
598 else if (SCM_REALP (n
))
600 double val
= SCM_REAL_VALUE (n
);
601 if (DOUBLE_IS_FINITE (val
))
603 double rem
= fabs (fmod (val
, 2.0));
610 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
614 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
616 "Return @code{#t} if the real number @var{x} is neither\n"
617 "infinite nor a NaN, @code{#f} otherwise.")
618 #define FUNC_NAME s_scm_finite_p
621 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
622 else if (scm_is_real (x
))
625 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
629 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
631 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
632 "@samp{-inf.0}. Otherwise return @code{#f}.")
633 #define FUNC_NAME s_scm_inf_p
636 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
637 else if (scm_is_real (x
))
640 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
644 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
646 "Return @code{#t} if the real number @var{x} is a NaN,\n"
647 "or @code{#f} otherwise.")
648 #define FUNC_NAME s_scm_nan_p
651 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
652 else if (scm_is_real (x
))
655 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
659 /* Guile's idea of infinity. */
660 static double guile_Inf
;
662 /* Guile's idea of not a number. */
663 static double guile_NaN
;
666 guile_ieee_init (void)
668 /* Some version of gcc on some old version of Linux used to crash when
669 trying to make Inf and NaN. */
672 /* C99 INFINITY, when available.
673 FIXME: The standard allows for INFINITY to be something that overflows
674 at compile time. We ought to have a configure test to check for that
675 before trying to use it. (But in practice we believe this is not a
676 problem on any system guile is likely to target.) */
677 guile_Inf
= INFINITY
;
678 #elif defined HAVE_DINFINITY
680 extern unsigned int DINFINITY
[2];
681 guile_Inf
= (*((double *) (DINFINITY
)));
688 if (guile_Inf
== tmp
)
695 /* C99 NAN, when available */
697 #elif defined HAVE_DQNAN
700 extern unsigned int DQNAN
[2];
701 guile_NaN
= (*((double *)(DQNAN
)));
704 guile_NaN
= guile_Inf
/ guile_Inf
;
708 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
711 #define FUNC_NAME s_scm_inf
713 static int initialized
= 0;
719 return scm_from_double (guile_Inf
);
723 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
726 #define FUNC_NAME s_scm_nan
728 static int initialized
= 0;
734 return scm_from_double (guile_NaN
);
739 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
741 "Return the absolute value of @var{x}.")
742 #define FUNC_NAME s_scm_abs
746 scm_t_inum xx
= SCM_I_INUM (x
);
749 else if (SCM_POSFIXABLE (-xx
))
750 return SCM_I_MAKINUM (-xx
);
752 return scm_i_inum2big (-xx
);
754 else if (SCM_LIKELY (SCM_REALP (x
)))
756 double xx
= SCM_REAL_VALUE (x
);
757 /* If x is a NaN then xx<0 is false so we return x unchanged */
759 return scm_from_double (-xx
);
760 /* Handle signed zeroes properly */
761 else if (SCM_UNLIKELY (xx
== 0.0))
766 else if (SCM_BIGP (x
))
768 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
770 return scm_i_clonebig (x
, 0);
774 else if (SCM_FRACTIONP (x
))
776 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
778 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
779 SCM_FRACTION_DENOMINATOR (x
));
782 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
787 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
789 "Return the quotient of the numbers @var{x} and @var{y}.")
790 #define FUNC_NAME s_scm_quotient
792 if (SCM_LIKELY (SCM_I_INUMP (x
)) || SCM_LIKELY (SCM_BIGP (x
)))
794 if (SCM_LIKELY (SCM_I_INUMP (y
)) || SCM_LIKELY (SCM_BIGP (y
)))
795 return scm_truncate_quotient (x
, y
);
797 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
800 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
804 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
806 "Return the remainder of the numbers @var{x} and @var{y}.\n"
808 "(remainder 13 4) @result{} 1\n"
809 "(remainder -13 4) @result{} -1\n"
811 #define FUNC_NAME s_scm_remainder
813 if (SCM_LIKELY (SCM_I_INUMP (x
)) || SCM_LIKELY (SCM_BIGP (x
)))
815 if (SCM_LIKELY (SCM_I_INUMP (y
)) || SCM_LIKELY (SCM_BIGP (y
)))
816 return scm_truncate_remainder (x
, y
);
818 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
821 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
826 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
828 "Return the modulo of the numbers @var{x} and @var{y}.\n"
830 "(modulo 13 4) @result{} 1\n"
831 "(modulo -13 4) @result{} 3\n"
833 #define FUNC_NAME s_scm_modulo
835 if (SCM_LIKELY (SCM_I_INUMP (x
)) || SCM_LIKELY (SCM_BIGP (x
)))
837 if (SCM_LIKELY (SCM_I_INUMP (y
)) || SCM_LIKELY (SCM_BIGP (y
)))
838 return scm_floor_remainder (x
, y
);
840 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
843 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
847 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
848 two-valued functions. It is called from primitive generics that take
849 two arguments and return two values, when the core procedure is
850 unable to handle the given argument types. If there are GOOPS
851 methods for this primitive generic, it dispatches to GOOPS and, if
852 successful, expects two values to be returned, which are placed in
853 *rp1 and *rp2. If there are no GOOPS methods, it throws a
854 wrong-type-arg exception.
856 FIXME: This obviously belongs somewhere else, but until we decide on
857 the right API, it is here as a static function, because it is needed
858 by the *_divide functions below.
861 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
862 const char *subr
, SCM
*rp1
, SCM
*rp2
)
865 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
867 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
870 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
872 "Return the integer @var{q} such that\n"
873 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
874 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
876 "(euclidean-quotient 123 10) @result{} 12\n"
877 "(euclidean-quotient 123 -10) @result{} -12\n"
878 "(euclidean-quotient -123 10) @result{} -13\n"
879 "(euclidean-quotient -123 -10) @result{} 13\n"
880 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
881 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
883 #define FUNC_NAME s_scm_euclidean_quotient
885 if (scm_is_false (scm_negative_p (y
)))
886 return scm_floor_quotient (x
, y
);
888 return scm_ceiling_quotient (x
, y
);
892 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
894 "Return the real number @var{r} such that\n"
895 "@math{0 <= @var{r} < abs(@var{y})} and\n"
896 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
897 "for some integer @var{q}.\n"
899 "(euclidean-remainder 123 10) @result{} 3\n"
900 "(euclidean-remainder 123 -10) @result{} 3\n"
901 "(euclidean-remainder -123 10) @result{} 7\n"
902 "(euclidean-remainder -123 -10) @result{} 7\n"
903 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
904 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
906 #define FUNC_NAME s_scm_euclidean_remainder
908 if (scm_is_false (scm_negative_p (y
)))
909 return scm_floor_remainder (x
, y
);
911 return scm_ceiling_remainder (x
, y
);
915 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
917 "Return the integer @var{q} and the real number @var{r}\n"
918 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
919 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
921 "(euclidean/ 123 10) @result{} 12 and 3\n"
922 "(euclidean/ 123 -10) @result{} -12 and 3\n"
923 "(euclidean/ -123 10) @result{} -13 and 7\n"
924 "(euclidean/ -123 -10) @result{} 13 and 7\n"
925 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
926 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
928 #define FUNC_NAME s_scm_i_euclidean_divide
930 if (scm_is_false (scm_negative_p (y
)))
931 return scm_i_floor_divide (x
, y
);
933 return scm_i_ceiling_divide (x
, y
);
938 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
940 if (scm_is_false (scm_negative_p (y
)))
941 return scm_floor_divide (x
, y
, qp
, rp
);
943 return scm_ceiling_divide (x
, y
, qp
, rp
);
946 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
947 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
949 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
951 "Return the floor of @math{@var{x} / @var{y}}.\n"
953 "(floor-quotient 123 10) @result{} 12\n"
954 "(floor-quotient 123 -10) @result{} -13\n"
955 "(floor-quotient -123 10) @result{} -13\n"
956 "(floor-quotient -123 -10) @result{} 12\n"
957 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
958 "(floor-quotient 16/3 -10/7) @result{} -4\n"
960 #define FUNC_NAME s_scm_floor_quotient
962 if (SCM_LIKELY (SCM_I_INUMP (x
)))
964 scm_t_inum xx
= SCM_I_INUM (x
);
965 if (SCM_LIKELY (SCM_I_INUMP (y
)))
967 scm_t_inum yy
= SCM_I_INUM (y
);
970 if (SCM_LIKELY (yy
> 0))
972 if (SCM_UNLIKELY (xx
< 0))
975 else if (SCM_UNLIKELY (yy
== 0))
976 scm_num_overflow (s_scm_floor_quotient
);
980 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
981 return SCM_I_MAKINUM (qq
);
983 return scm_i_inum2big (qq
);
985 else if (SCM_BIGP (y
))
987 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
988 scm_remember_upto_here_1 (y
);
990 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
992 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
994 else if (SCM_REALP (y
))
995 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
996 else if (SCM_FRACTIONP (y
))
997 return scm_i_exact_rational_floor_quotient (x
, y
);
999 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1000 s_scm_floor_quotient
);
1002 else if (SCM_BIGP (x
))
1004 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1006 scm_t_inum yy
= SCM_I_INUM (y
);
1007 if (SCM_UNLIKELY (yy
== 0))
1008 scm_num_overflow (s_scm_floor_quotient
);
1009 else if (SCM_UNLIKELY (yy
== 1))
1013 SCM q
= scm_i_mkbig ();
1015 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1018 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1019 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1021 scm_remember_upto_here_1 (x
);
1022 return scm_i_normbig (q
);
1025 else if (SCM_BIGP (y
))
1027 SCM q
= scm_i_mkbig ();
1028 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1031 scm_remember_upto_here_2 (x
, y
);
1032 return scm_i_normbig (q
);
1034 else if (SCM_REALP (y
))
1035 return scm_i_inexact_floor_quotient
1036 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1037 else if (SCM_FRACTIONP (y
))
1038 return scm_i_exact_rational_floor_quotient (x
, y
);
1040 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1041 s_scm_floor_quotient
);
1043 else if (SCM_REALP (x
))
1045 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1046 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1047 return scm_i_inexact_floor_quotient
1048 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1050 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1051 s_scm_floor_quotient
);
1053 else if (SCM_FRACTIONP (x
))
1056 return scm_i_inexact_floor_quotient
1057 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1058 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1059 return scm_i_exact_rational_floor_quotient (x
, y
);
1061 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1062 s_scm_floor_quotient
);
1065 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1066 s_scm_floor_quotient
);
1071 scm_i_inexact_floor_quotient (double x
, double y
)
1073 if (SCM_UNLIKELY (y
== 0))
1074 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1076 return scm_from_double (floor (x
/ y
));
1080 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1082 return scm_floor_quotient
1083 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1084 scm_product (scm_numerator (y
), scm_denominator (x
)));
1087 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1088 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1090 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1092 "Return the real number @var{r} such that\n"
1093 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1094 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1096 "(floor-remainder 123 10) @result{} 3\n"
1097 "(floor-remainder 123 -10) @result{} -7\n"
1098 "(floor-remainder -123 10) @result{} 7\n"
1099 "(floor-remainder -123 -10) @result{} -3\n"
1100 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1101 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1103 #define FUNC_NAME s_scm_floor_remainder
1105 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1107 scm_t_inum xx
= SCM_I_INUM (x
);
1108 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1110 scm_t_inum yy
= SCM_I_INUM (y
);
1111 if (SCM_UNLIKELY (yy
== 0))
1112 scm_num_overflow (s_scm_floor_remainder
);
1115 scm_t_inum rr
= xx
% yy
;
1116 int needs_adjustment
;
1118 if (SCM_LIKELY (yy
> 0))
1119 needs_adjustment
= (rr
< 0);
1121 needs_adjustment
= (rr
> 0);
1123 if (needs_adjustment
)
1125 return SCM_I_MAKINUM (rr
);
1128 else if (SCM_BIGP (y
))
1130 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1131 scm_remember_upto_here_1 (y
);
1136 SCM r
= scm_i_mkbig ();
1137 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1138 scm_remember_upto_here_1 (y
);
1139 return scm_i_normbig (r
);
1148 SCM r
= scm_i_mkbig ();
1149 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1150 scm_remember_upto_here_1 (y
);
1151 return scm_i_normbig (r
);
1154 else if (SCM_REALP (y
))
1155 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1156 else if (SCM_FRACTIONP (y
))
1157 return scm_i_exact_rational_floor_remainder (x
, y
);
1159 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1160 s_scm_floor_remainder
);
1162 else if (SCM_BIGP (x
))
1164 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1166 scm_t_inum yy
= SCM_I_INUM (y
);
1167 if (SCM_UNLIKELY (yy
== 0))
1168 scm_num_overflow (s_scm_floor_remainder
);
1173 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1175 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1176 scm_remember_upto_here_1 (x
);
1177 return SCM_I_MAKINUM (rr
);
1180 else if (SCM_BIGP (y
))
1182 SCM r
= scm_i_mkbig ();
1183 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1186 scm_remember_upto_here_2 (x
, y
);
1187 return scm_i_normbig (r
);
1189 else if (SCM_REALP (y
))
1190 return scm_i_inexact_floor_remainder
1191 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1192 else if (SCM_FRACTIONP (y
))
1193 return scm_i_exact_rational_floor_remainder (x
, y
);
1195 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1196 s_scm_floor_remainder
);
1198 else if (SCM_REALP (x
))
1200 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1201 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1202 return scm_i_inexact_floor_remainder
1203 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1205 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1206 s_scm_floor_remainder
);
1208 else if (SCM_FRACTIONP (x
))
1211 return scm_i_inexact_floor_remainder
1212 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1213 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1214 return scm_i_exact_rational_floor_remainder (x
, y
);
1216 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1217 s_scm_floor_remainder
);
1220 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1221 s_scm_floor_remainder
);
1226 scm_i_inexact_floor_remainder (double x
, double y
)
1228 /* Although it would be more efficient to use fmod here, we can't
1229 because it would in some cases produce results inconsistent with
1230 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1231 close). In particular, when x is very close to a multiple of y,
1232 then r might be either 0.0 or y, but those two cases must
1233 correspond to different choices of q. If r = 0.0 then q must be
1234 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1235 and remainder chooses the other, it would be bad. */
1236 if (SCM_UNLIKELY (y
== 0))
1237 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1239 return scm_from_double (x
- y
* floor (x
/ y
));
1243 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1245 SCM xd
= scm_denominator (x
);
1246 SCM yd
= scm_denominator (y
);
1247 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1248 scm_product (scm_numerator (y
), xd
));
1249 return scm_divide (r1
, scm_product (xd
, yd
));
1253 static void scm_i_inexact_floor_divide (double x
, double y
,
1255 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1258 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1260 "Return the integer @var{q} and the real number @var{r}\n"
1261 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1262 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1264 "(floor/ 123 10) @result{} 12 and 3\n"
1265 "(floor/ 123 -10) @result{} -13 and -7\n"
1266 "(floor/ -123 10) @result{} -13 and 7\n"
1267 "(floor/ -123 -10) @result{} 12 and -3\n"
1268 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1269 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1271 #define FUNC_NAME s_scm_i_floor_divide
1275 scm_floor_divide(x
, y
, &q
, &r
);
1276 return scm_values (scm_list_2 (q
, r
));
1280 #define s_scm_floor_divide s_scm_i_floor_divide
1281 #define g_scm_floor_divide g_scm_i_floor_divide
1284 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1286 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1288 scm_t_inum xx
= SCM_I_INUM (x
);
1289 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1291 scm_t_inum yy
= SCM_I_INUM (y
);
1292 if (SCM_UNLIKELY (yy
== 0))
1293 scm_num_overflow (s_scm_floor_divide
);
1296 scm_t_inum qq
= xx
/ yy
;
1297 scm_t_inum rr
= xx
% yy
;
1298 int needs_adjustment
;
1300 if (SCM_LIKELY (yy
> 0))
1301 needs_adjustment
= (rr
< 0);
1303 needs_adjustment
= (rr
> 0);
1305 if (needs_adjustment
)
1311 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1312 *qp
= SCM_I_MAKINUM (qq
);
1314 *qp
= scm_i_inum2big (qq
);
1315 *rp
= SCM_I_MAKINUM (rr
);
1319 else if (SCM_BIGP (y
))
1321 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1322 scm_remember_upto_here_1 (y
);
1327 SCM r
= scm_i_mkbig ();
1328 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1329 scm_remember_upto_here_1 (y
);
1330 *qp
= SCM_I_MAKINUM (-1);
1331 *rp
= scm_i_normbig (r
);
1346 SCM r
= scm_i_mkbig ();
1347 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1348 scm_remember_upto_here_1 (y
);
1349 *qp
= SCM_I_MAKINUM (-1);
1350 *rp
= scm_i_normbig (r
);
1354 else if (SCM_REALP (y
))
1355 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1356 else if (SCM_FRACTIONP (y
))
1357 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1359 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1360 s_scm_floor_divide
, qp
, rp
);
1362 else if (SCM_BIGP (x
))
1364 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1366 scm_t_inum yy
= SCM_I_INUM (y
);
1367 if (SCM_UNLIKELY (yy
== 0))
1368 scm_num_overflow (s_scm_floor_divide
);
1371 SCM q
= scm_i_mkbig ();
1372 SCM r
= scm_i_mkbig ();
1374 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1375 SCM_I_BIG_MPZ (x
), yy
);
1378 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1379 SCM_I_BIG_MPZ (x
), -yy
);
1380 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1382 scm_remember_upto_here_1 (x
);
1383 *qp
= scm_i_normbig (q
);
1384 *rp
= scm_i_normbig (r
);
1388 else if (SCM_BIGP (y
))
1390 SCM q
= scm_i_mkbig ();
1391 SCM r
= scm_i_mkbig ();
1392 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1393 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1394 scm_remember_upto_here_2 (x
, y
);
1395 *qp
= scm_i_normbig (q
);
1396 *rp
= scm_i_normbig (r
);
1399 else if (SCM_REALP (y
))
1400 return scm_i_inexact_floor_divide
1401 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1402 else if (SCM_FRACTIONP (y
))
1403 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1405 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1406 s_scm_floor_divide
, qp
, rp
);
1408 else if (SCM_REALP (x
))
1410 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1411 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1412 return scm_i_inexact_floor_divide
1413 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1415 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1416 s_scm_floor_divide
, qp
, rp
);
1418 else if (SCM_FRACTIONP (x
))
1421 return scm_i_inexact_floor_divide
1422 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1423 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1424 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1426 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1427 s_scm_floor_divide
, qp
, rp
);
1430 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1431 s_scm_floor_divide
, qp
, rp
);
1435 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1437 if (SCM_UNLIKELY (y
== 0))
1438 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1441 double q
= floor (x
/ y
);
1442 double r
= x
- q
* y
;
1443 *qp
= scm_from_double (q
);
1444 *rp
= scm_from_double (r
);
1449 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1452 SCM xd
= scm_denominator (x
);
1453 SCM yd
= scm_denominator (y
);
1455 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1456 scm_product (scm_numerator (y
), xd
),
1458 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1461 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1462 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1464 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1466 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1468 "(ceiling-quotient 123 10) @result{} 13\n"
1469 "(ceiling-quotient 123 -10) @result{} -12\n"
1470 "(ceiling-quotient -123 10) @result{} -12\n"
1471 "(ceiling-quotient -123 -10) @result{} 13\n"
1472 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1473 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1475 #define FUNC_NAME s_scm_ceiling_quotient
1477 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1479 scm_t_inum xx
= SCM_I_INUM (x
);
1480 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1482 scm_t_inum yy
= SCM_I_INUM (y
);
1483 if (SCM_UNLIKELY (yy
== 0))
1484 scm_num_overflow (s_scm_ceiling_quotient
);
1487 scm_t_inum xx1
= xx
;
1489 if (SCM_LIKELY (yy
> 0))
1491 if (SCM_LIKELY (xx
>= 0))
1494 else if (SCM_UNLIKELY (yy
== 0))
1495 scm_num_overflow (s_scm_ceiling_quotient
);
1499 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1500 return SCM_I_MAKINUM (qq
);
1502 return scm_i_inum2big (qq
);
1505 else if (SCM_BIGP (y
))
1507 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1508 scm_remember_upto_here_1 (y
);
1509 if (SCM_LIKELY (sign
> 0))
1511 if (SCM_LIKELY (xx
> 0))
1513 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1514 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1515 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1517 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1518 scm_remember_upto_here_1 (y
);
1519 return SCM_I_MAKINUM (-1);
1529 else if (SCM_REALP (y
))
1530 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1531 else if (SCM_FRACTIONP (y
))
1532 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1534 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1535 s_scm_ceiling_quotient
);
1537 else if (SCM_BIGP (x
))
1539 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1541 scm_t_inum yy
= SCM_I_INUM (y
);
1542 if (SCM_UNLIKELY (yy
== 0))
1543 scm_num_overflow (s_scm_ceiling_quotient
);
1544 else if (SCM_UNLIKELY (yy
== 1))
1548 SCM q
= scm_i_mkbig ();
1550 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1553 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1554 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1556 scm_remember_upto_here_1 (x
);
1557 return scm_i_normbig (q
);
1560 else if (SCM_BIGP (y
))
1562 SCM q
= scm_i_mkbig ();
1563 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1566 scm_remember_upto_here_2 (x
, y
);
1567 return scm_i_normbig (q
);
1569 else if (SCM_REALP (y
))
1570 return scm_i_inexact_ceiling_quotient
1571 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1572 else if (SCM_FRACTIONP (y
))
1573 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1575 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1576 s_scm_ceiling_quotient
);
1578 else if (SCM_REALP (x
))
1580 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1581 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1582 return scm_i_inexact_ceiling_quotient
1583 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1585 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1586 s_scm_ceiling_quotient
);
1588 else if (SCM_FRACTIONP (x
))
1591 return scm_i_inexact_ceiling_quotient
1592 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1593 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1594 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1596 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1597 s_scm_ceiling_quotient
);
1600 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1601 s_scm_ceiling_quotient
);
1606 scm_i_inexact_ceiling_quotient (double x
, double y
)
1608 if (SCM_UNLIKELY (y
== 0))
1609 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1611 return scm_from_double (ceil (x
/ y
));
1615 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1617 return scm_ceiling_quotient
1618 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1619 scm_product (scm_numerator (y
), scm_denominator (x
)));
1622 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1623 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1625 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1627 "Return the real number @var{r} such that\n"
1628 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1629 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1631 "(ceiling-remainder 123 10) @result{} -7\n"
1632 "(ceiling-remainder 123 -10) @result{} 3\n"
1633 "(ceiling-remainder -123 10) @result{} -3\n"
1634 "(ceiling-remainder -123 -10) @result{} 7\n"
1635 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1636 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1638 #define FUNC_NAME s_scm_ceiling_remainder
1640 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1642 scm_t_inum xx
= SCM_I_INUM (x
);
1643 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1645 scm_t_inum yy
= SCM_I_INUM (y
);
1646 if (SCM_UNLIKELY (yy
== 0))
1647 scm_num_overflow (s_scm_ceiling_remainder
);
1650 scm_t_inum rr
= xx
% yy
;
1651 int needs_adjustment
;
1653 if (SCM_LIKELY (yy
> 0))
1654 needs_adjustment
= (rr
> 0);
1656 needs_adjustment
= (rr
< 0);
1658 if (needs_adjustment
)
1660 return SCM_I_MAKINUM (rr
);
1663 else if (SCM_BIGP (y
))
1665 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1666 scm_remember_upto_here_1 (y
);
1667 if (SCM_LIKELY (sign
> 0))
1669 if (SCM_LIKELY (xx
> 0))
1671 SCM r
= scm_i_mkbig ();
1672 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1673 scm_remember_upto_here_1 (y
);
1674 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1675 return scm_i_normbig (r
);
1677 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1678 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1679 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1681 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1682 scm_remember_upto_here_1 (y
);
1692 SCM r
= scm_i_mkbig ();
1693 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1694 scm_remember_upto_here_1 (y
);
1695 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1696 return scm_i_normbig (r
);
1699 else if (SCM_REALP (y
))
1700 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1701 else if (SCM_FRACTIONP (y
))
1702 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1704 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1705 s_scm_ceiling_remainder
);
1707 else if (SCM_BIGP (x
))
1709 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1711 scm_t_inum yy
= SCM_I_INUM (y
);
1712 if (SCM_UNLIKELY (yy
== 0))
1713 scm_num_overflow (s_scm_ceiling_remainder
);
1718 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1720 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1721 scm_remember_upto_here_1 (x
);
1722 return SCM_I_MAKINUM (rr
);
1725 else if (SCM_BIGP (y
))
1727 SCM r
= scm_i_mkbig ();
1728 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1731 scm_remember_upto_here_2 (x
, y
);
1732 return scm_i_normbig (r
);
1734 else if (SCM_REALP (y
))
1735 return scm_i_inexact_ceiling_remainder
1736 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1737 else if (SCM_FRACTIONP (y
))
1738 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1740 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1741 s_scm_ceiling_remainder
);
1743 else if (SCM_REALP (x
))
1745 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1746 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1747 return scm_i_inexact_ceiling_remainder
1748 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1750 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1751 s_scm_ceiling_remainder
);
1753 else if (SCM_FRACTIONP (x
))
1756 return scm_i_inexact_ceiling_remainder
1757 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1758 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1759 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1761 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1762 s_scm_ceiling_remainder
);
1765 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1766 s_scm_ceiling_remainder
);
1771 scm_i_inexact_ceiling_remainder (double x
, double y
)
1773 /* Although it would be more efficient to use fmod here, we can't
1774 because it would in some cases produce results inconsistent with
1775 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1776 close). In particular, when x is very close to a multiple of y,
1777 then r might be either 0.0 or -y, but those two cases must
1778 correspond to different choices of q. If r = 0.0 then q must be
1779 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1780 and remainder chooses the other, it would be bad. */
1781 if (SCM_UNLIKELY (y
== 0))
1782 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1784 return scm_from_double (x
- y
* ceil (x
/ y
));
1788 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1790 SCM xd
= scm_denominator (x
);
1791 SCM yd
= scm_denominator (y
);
1792 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1793 scm_product (scm_numerator (y
), xd
));
1794 return scm_divide (r1
, scm_product (xd
, yd
));
1797 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1799 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1802 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1804 "Return the integer @var{q} and the real number @var{r}\n"
1805 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1806 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1808 "(ceiling/ 123 10) @result{} 13 and -7\n"
1809 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1810 "(ceiling/ -123 10) @result{} -12 and -3\n"
1811 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1812 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1813 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1815 #define FUNC_NAME s_scm_i_ceiling_divide
1819 scm_ceiling_divide(x
, y
, &q
, &r
);
1820 return scm_values (scm_list_2 (q
, r
));
1824 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1825 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1828 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1830 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1832 scm_t_inum xx
= SCM_I_INUM (x
);
1833 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1835 scm_t_inum yy
= SCM_I_INUM (y
);
1836 if (SCM_UNLIKELY (yy
== 0))
1837 scm_num_overflow (s_scm_ceiling_divide
);
1840 scm_t_inum qq
= xx
/ yy
;
1841 scm_t_inum rr
= xx
% yy
;
1842 int needs_adjustment
;
1844 if (SCM_LIKELY (yy
> 0))
1845 needs_adjustment
= (rr
> 0);
1847 needs_adjustment
= (rr
< 0);
1849 if (needs_adjustment
)
1854 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1855 *qp
= SCM_I_MAKINUM (qq
);
1857 *qp
= scm_i_inum2big (qq
);
1858 *rp
= SCM_I_MAKINUM (rr
);
1862 else if (SCM_BIGP (y
))
1864 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1865 scm_remember_upto_here_1 (y
);
1866 if (SCM_LIKELY (sign
> 0))
1868 if (SCM_LIKELY (xx
> 0))
1870 SCM r
= scm_i_mkbig ();
1871 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1872 scm_remember_upto_here_1 (y
);
1873 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1875 *rp
= scm_i_normbig (r
);
1877 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1878 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1879 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1881 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1882 scm_remember_upto_here_1 (y
);
1883 *qp
= SCM_I_MAKINUM (-1);
1899 SCM r
= scm_i_mkbig ();
1900 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1901 scm_remember_upto_here_1 (y
);
1902 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1904 *rp
= scm_i_normbig (r
);
1908 else if (SCM_REALP (y
))
1909 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1910 else if (SCM_FRACTIONP (y
))
1911 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1913 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1914 s_scm_ceiling_divide
, qp
, rp
);
1916 else if (SCM_BIGP (x
))
1918 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1920 scm_t_inum yy
= SCM_I_INUM (y
);
1921 if (SCM_UNLIKELY (yy
== 0))
1922 scm_num_overflow (s_scm_ceiling_divide
);
1925 SCM q
= scm_i_mkbig ();
1926 SCM r
= scm_i_mkbig ();
1928 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1929 SCM_I_BIG_MPZ (x
), yy
);
1932 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1933 SCM_I_BIG_MPZ (x
), -yy
);
1934 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1936 scm_remember_upto_here_1 (x
);
1937 *qp
= scm_i_normbig (q
);
1938 *rp
= scm_i_normbig (r
);
1942 else if (SCM_BIGP (y
))
1944 SCM q
= scm_i_mkbig ();
1945 SCM r
= scm_i_mkbig ();
1946 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1947 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1948 scm_remember_upto_here_2 (x
, y
);
1949 *qp
= scm_i_normbig (q
);
1950 *rp
= scm_i_normbig (r
);
1953 else if (SCM_REALP (y
))
1954 return scm_i_inexact_ceiling_divide
1955 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1956 else if (SCM_FRACTIONP (y
))
1957 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1959 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1960 s_scm_ceiling_divide
, qp
, rp
);
1962 else if (SCM_REALP (x
))
1964 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1965 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1966 return scm_i_inexact_ceiling_divide
1967 (SCM_REAL_VALUE (x
), scm_to_double (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_FRACTIONP (x
))
1975 return scm_i_inexact_ceiling_divide
1976 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1977 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1978 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1980 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1981 s_scm_ceiling_divide
, qp
, rp
);
1984 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
1985 s_scm_ceiling_divide
, qp
, rp
);
1989 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1991 if (SCM_UNLIKELY (y
== 0))
1992 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
1995 double q
= ceil (x
/ y
);
1996 double r
= x
- q
* y
;
1997 *qp
= scm_from_double (q
);
1998 *rp
= scm_from_double (r
);
2003 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2006 SCM xd
= scm_denominator (x
);
2007 SCM yd
= scm_denominator (y
);
2009 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2010 scm_product (scm_numerator (y
), xd
),
2012 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2015 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2016 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2018 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2020 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2022 "(truncate-quotient 123 10) @result{} 12\n"
2023 "(truncate-quotient 123 -10) @result{} -12\n"
2024 "(truncate-quotient -123 10) @result{} -12\n"
2025 "(truncate-quotient -123 -10) @result{} 12\n"
2026 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2027 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2029 #define FUNC_NAME s_scm_truncate_quotient
2031 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2033 scm_t_inum xx
= SCM_I_INUM (x
);
2034 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2036 scm_t_inum yy
= SCM_I_INUM (y
);
2037 if (SCM_UNLIKELY (yy
== 0))
2038 scm_num_overflow (s_scm_truncate_quotient
);
2041 scm_t_inum qq
= xx
/ yy
;
2042 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2043 return SCM_I_MAKINUM (qq
);
2045 return scm_i_inum2big (qq
);
2048 else if (SCM_BIGP (y
))
2050 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2051 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2052 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2054 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2055 scm_remember_upto_here_1 (y
);
2056 return SCM_I_MAKINUM (-1);
2061 else if (SCM_REALP (y
))
2062 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2063 else if (SCM_FRACTIONP (y
))
2064 return scm_i_exact_rational_truncate_quotient (x
, y
);
2066 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2067 s_scm_truncate_quotient
);
2069 else if (SCM_BIGP (x
))
2071 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2073 scm_t_inum yy
= SCM_I_INUM (y
);
2074 if (SCM_UNLIKELY (yy
== 0))
2075 scm_num_overflow (s_scm_truncate_quotient
);
2076 else if (SCM_UNLIKELY (yy
== 1))
2080 SCM q
= scm_i_mkbig ();
2082 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2085 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2086 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2088 scm_remember_upto_here_1 (x
);
2089 return scm_i_normbig (q
);
2092 else if (SCM_BIGP (y
))
2094 SCM q
= scm_i_mkbig ();
2095 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2098 scm_remember_upto_here_2 (x
, y
);
2099 return scm_i_normbig (q
);
2101 else if (SCM_REALP (y
))
2102 return scm_i_inexact_truncate_quotient
2103 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2104 else if (SCM_FRACTIONP (y
))
2105 return scm_i_exact_rational_truncate_quotient (x
, y
);
2107 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2108 s_scm_truncate_quotient
);
2110 else if (SCM_REALP (x
))
2112 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2113 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2114 return scm_i_inexact_truncate_quotient
2115 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2117 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2118 s_scm_truncate_quotient
);
2120 else if (SCM_FRACTIONP (x
))
2123 return scm_i_inexact_truncate_quotient
2124 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2125 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2126 return scm_i_exact_rational_truncate_quotient (x
, y
);
2128 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2129 s_scm_truncate_quotient
);
2132 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2133 s_scm_truncate_quotient
);
2138 scm_i_inexact_truncate_quotient (double x
, double y
)
2140 if (SCM_UNLIKELY (y
== 0))
2141 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2143 return scm_from_double (trunc (x
/ y
));
2147 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2149 return scm_truncate_quotient
2150 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2151 scm_product (scm_numerator (y
), scm_denominator (x
)));
2154 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2155 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2157 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2159 "Return the real number @var{r} such that\n"
2160 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2161 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2163 "(truncate-remainder 123 10) @result{} 3\n"
2164 "(truncate-remainder 123 -10) @result{} 3\n"
2165 "(truncate-remainder -123 10) @result{} -3\n"
2166 "(truncate-remainder -123 -10) @result{} -3\n"
2167 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2168 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2170 #define FUNC_NAME s_scm_truncate_remainder
2172 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2174 scm_t_inum xx
= SCM_I_INUM (x
);
2175 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2177 scm_t_inum yy
= SCM_I_INUM (y
);
2178 if (SCM_UNLIKELY (yy
== 0))
2179 scm_num_overflow (s_scm_truncate_remainder
);
2181 return SCM_I_MAKINUM (xx
% yy
);
2183 else if (SCM_BIGP (y
))
2185 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2186 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2187 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2189 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2190 scm_remember_upto_here_1 (y
);
2196 else if (SCM_REALP (y
))
2197 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2198 else if (SCM_FRACTIONP (y
))
2199 return scm_i_exact_rational_truncate_remainder (x
, y
);
2201 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2202 s_scm_truncate_remainder
);
2204 else if (SCM_BIGP (x
))
2206 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2208 scm_t_inum yy
= SCM_I_INUM (y
);
2209 if (SCM_UNLIKELY (yy
== 0))
2210 scm_num_overflow (s_scm_truncate_remainder
);
2213 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2214 (yy
> 0) ? yy
: -yy
)
2215 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2216 scm_remember_upto_here_1 (x
);
2217 return SCM_I_MAKINUM (rr
);
2220 else if (SCM_BIGP (y
))
2222 SCM r
= scm_i_mkbig ();
2223 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2226 scm_remember_upto_here_2 (x
, y
);
2227 return scm_i_normbig (r
);
2229 else if (SCM_REALP (y
))
2230 return scm_i_inexact_truncate_remainder
2231 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2232 else if (SCM_FRACTIONP (y
))
2233 return scm_i_exact_rational_truncate_remainder (x
, y
);
2235 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2236 s_scm_truncate_remainder
);
2238 else if (SCM_REALP (x
))
2240 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2241 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2242 return scm_i_inexact_truncate_remainder
2243 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2245 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2246 s_scm_truncate_remainder
);
2248 else if (SCM_FRACTIONP (x
))
2251 return scm_i_inexact_truncate_remainder
2252 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2253 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2254 return scm_i_exact_rational_truncate_remainder (x
, y
);
2256 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2257 s_scm_truncate_remainder
);
2260 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2261 s_scm_truncate_remainder
);
2266 scm_i_inexact_truncate_remainder (double x
, double y
)
2268 /* Although it would be more efficient to use fmod here, we can't
2269 because it would in some cases produce results inconsistent with
2270 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2271 close). In particular, when x is very close to a multiple of y,
2272 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2273 correspond to different choices of q. If quotient chooses one and
2274 remainder chooses the other, it would be bad. */
2275 if (SCM_UNLIKELY (y
== 0))
2276 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2278 return scm_from_double (x
- y
* trunc (x
/ y
));
2282 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2284 SCM xd
= scm_denominator (x
);
2285 SCM yd
= scm_denominator (y
);
2286 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2287 scm_product (scm_numerator (y
), xd
));
2288 return scm_divide (r1
, scm_product (xd
, yd
));
2292 static void scm_i_inexact_truncate_divide (double x
, double y
,
2294 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2297 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2299 "Return the integer @var{q} and the real number @var{r}\n"
2300 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2301 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2303 "(truncate/ 123 10) @result{} 12 and 3\n"
2304 "(truncate/ 123 -10) @result{} -12 and 3\n"
2305 "(truncate/ -123 10) @result{} -12 and -3\n"
2306 "(truncate/ -123 -10) @result{} 12 and -3\n"
2307 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2308 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2310 #define FUNC_NAME s_scm_i_truncate_divide
2314 scm_truncate_divide(x
, y
, &q
, &r
);
2315 return scm_values (scm_list_2 (q
, r
));
2319 #define s_scm_truncate_divide s_scm_i_truncate_divide
2320 #define g_scm_truncate_divide g_scm_i_truncate_divide
2323 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2325 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2327 scm_t_inum xx
= SCM_I_INUM (x
);
2328 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2330 scm_t_inum yy
= SCM_I_INUM (y
);
2331 if (SCM_UNLIKELY (yy
== 0))
2332 scm_num_overflow (s_scm_truncate_divide
);
2335 scm_t_inum qq
= xx
/ yy
;
2336 scm_t_inum rr
= xx
% yy
;
2337 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2338 *qp
= SCM_I_MAKINUM (qq
);
2340 *qp
= scm_i_inum2big (qq
);
2341 *rp
= SCM_I_MAKINUM (rr
);
2345 else if (SCM_BIGP (y
))
2347 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2348 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2349 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2351 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2352 scm_remember_upto_here_1 (y
);
2353 *qp
= SCM_I_MAKINUM (-1);
2363 else if (SCM_REALP (y
))
2364 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2365 else if (SCM_FRACTIONP (y
))
2366 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2368 return two_valued_wta_dispatch_2
2369 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2370 s_scm_truncate_divide
, qp
, rp
);
2372 else if (SCM_BIGP (x
))
2374 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2376 scm_t_inum yy
= SCM_I_INUM (y
);
2377 if (SCM_UNLIKELY (yy
== 0))
2378 scm_num_overflow (s_scm_truncate_divide
);
2381 SCM q
= scm_i_mkbig ();
2384 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2385 SCM_I_BIG_MPZ (x
), yy
);
2388 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2389 SCM_I_BIG_MPZ (x
), -yy
);
2390 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2392 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2393 scm_remember_upto_here_1 (x
);
2394 *qp
= scm_i_normbig (q
);
2395 *rp
= SCM_I_MAKINUM (rr
);
2399 else if (SCM_BIGP (y
))
2401 SCM q
= scm_i_mkbig ();
2402 SCM r
= scm_i_mkbig ();
2403 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2404 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2405 scm_remember_upto_here_2 (x
, y
);
2406 *qp
= scm_i_normbig (q
);
2407 *rp
= scm_i_normbig (r
);
2409 else if (SCM_REALP (y
))
2410 return scm_i_inexact_truncate_divide
2411 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2412 else if (SCM_FRACTIONP (y
))
2413 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2415 return two_valued_wta_dispatch_2
2416 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2417 s_scm_truncate_divide
, qp
, rp
);
2419 else if (SCM_REALP (x
))
2421 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2422 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2423 return scm_i_inexact_truncate_divide
2424 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2426 return two_valued_wta_dispatch_2
2427 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2428 s_scm_truncate_divide
, qp
, rp
);
2430 else if (SCM_FRACTIONP (x
))
2433 return scm_i_inexact_truncate_divide
2434 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2435 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2436 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2438 return two_valued_wta_dispatch_2
2439 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2440 s_scm_truncate_divide
, qp
, rp
);
2443 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2444 s_scm_truncate_divide
, qp
, rp
);
2448 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2450 if (SCM_UNLIKELY (y
== 0))
2451 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2454 double q
= trunc (x
/ y
);
2455 double r
= x
- q
* y
;
2456 *qp
= scm_from_double (q
);
2457 *rp
= scm_from_double (r
);
2462 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2465 SCM xd
= scm_denominator (x
);
2466 SCM yd
= scm_denominator (y
);
2468 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2469 scm_product (scm_numerator (y
), xd
),
2471 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2474 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2475 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2476 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2478 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2480 "Return the integer @var{q} such that\n"
2481 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2482 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2484 "(centered-quotient 123 10) @result{} 12\n"
2485 "(centered-quotient 123 -10) @result{} -12\n"
2486 "(centered-quotient -123 10) @result{} -12\n"
2487 "(centered-quotient -123 -10) @result{} 12\n"
2488 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2489 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2491 #define FUNC_NAME s_scm_centered_quotient
2493 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2495 scm_t_inum xx
= SCM_I_INUM (x
);
2496 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2498 scm_t_inum yy
= SCM_I_INUM (y
);
2499 if (SCM_UNLIKELY (yy
== 0))
2500 scm_num_overflow (s_scm_centered_quotient
);
2503 scm_t_inum qq
= xx
/ yy
;
2504 scm_t_inum rr
= xx
% yy
;
2505 if (SCM_LIKELY (xx
> 0))
2507 if (SCM_LIKELY (yy
> 0))
2509 if (rr
>= (yy
+ 1) / 2)
2514 if (rr
>= (1 - yy
) / 2)
2520 if (SCM_LIKELY (yy
> 0))
2531 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2532 return SCM_I_MAKINUM (qq
);
2534 return scm_i_inum2big (qq
);
2537 else if (SCM_BIGP (y
))
2539 /* Pass a denormalized bignum version of x (even though it
2540 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2541 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2543 else if (SCM_REALP (y
))
2544 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2545 else if (SCM_FRACTIONP (y
))
2546 return scm_i_exact_rational_centered_quotient (x
, y
);
2548 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2549 s_scm_centered_quotient
);
2551 else if (SCM_BIGP (x
))
2553 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2555 scm_t_inum yy
= SCM_I_INUM (y
);
2556 if (SCM_UNLIKELY (yy
== 0))
2557 scm_num_overflow (s_scm_centered_quotient
);
2558 else if (SCM_UNLIKELY (yy
== 1))
2562 SCM q
= scm_i_mkbig ();
2564 /* Arrange for rr to initially be non-positive,
2565 because that simplifies the test to see
2566 if it is within the needed bounds. */
2569 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2570 SCM_I_BIG_MPZ (x
), yy
);
2571 scm_remember_upto_here_1 (x
);
2573 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2574 SCM_I_BIG_MPZ (q
), 1);
2578 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2579 SCM_I_BIG_MPZ (x
), -yy
);
2580 scm_remember_upto_here_1 (x
);
2581 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2583 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2584 SCM_I_BIG_MPZ (q
), 1);
2586 return scm_i_normbig (q
);
2589 else if (SCM_BIGP (y
))
2590 return scm_i_bigint_centered_quotient (x
, y
);
2591 else if (SCM_REALP (y
))
2592 return scm_i_inexact_centered_quotient
2593 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2594 else if (SCM_FRACTIONP (y
))
2595 return scm_i_exact_rational_centered_quotient (x
, y
);
2597 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2598 s_scm_centered_quotient
);
2600 else if (SCM_REALP (x
))
2602 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2603 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2604 return scm_i_inexact_centered_quotient
2605 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2607 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2608 s_scm_centered_quotient
);
2610 else if (SCM_FRACTIONP (x
))
2613 return scm_i_inexact_centered_quotient
2614 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2615 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2616 return scm_i_exact_rational_centered_quotient (x
, y
);
2618 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2619 s_scm_centered_quotient
);
2622 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2623 s_scm_centered_quotient
);
2628 scm_i_inexact_centered_quotient (double x
, double y
)
2630 if (SCM_LIKELY (y
> 0))
2631 return scm_from_double (floor (x
/y
+ 0.5));
2632 else if (SCM_LIKELY (y
< 0))
2633 return scm_from_double (ceil (x
/y
- 0.5));
2635 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2640 /* Assumes that both x and y are bigints, though
2641 x might be able to fit into a fixnum. */
2643 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2647 /* Note that x might be small enough to fit into a
2648 fixnum, so we must not let it escape into the wild */
2652 /* min_r will eventually become -abs(y)/2 */
2653 min_r
= scm_i_mkbig ();
2654 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2655 SCM_I_BIG_MPZ (y
), 1);
2657 /* Arrange for rr to initially be non-positive,
2658 because that simplifies the test to see
2659 if it is within the needed bounds. */
2660 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2662 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2663 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2664 scm_remember_upto_here_2 (x
, y
);
2665 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2666 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2667 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2668 SCM_I_BIG_MPZ (q
), 1);
2672 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2673 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2674 scm_remember_upto_here_2 (x
, y
);
2675 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2676 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2677 SCM_I_BIG_MPZ (q
), 1);
2679 scm_remember_upto_here_2 (r
, min_r
);
2680 return scm_i_normbig (q
);
2684 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2686 return scm_centered_quotient
2687 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2688 scm_product (scm_numerator (y
), scm_denominator (x
)));
2691 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2692 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2693 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2695 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2697 "Return the real number @var{r} such that\n"
2698 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2699 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2700 "for some integer @var{q}.\n"
2702 "(centered-remainder 123 10) @result{} 3\n"
2703 "(centered-remainder 123 -10) @result{} 3\n"
2704 "(centered-remainder -123 10) @result{} -3\n"
2705 "(centered-remainder -123 -10) @result{} -3\n"
2706 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2707 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2709 #define FUNC_NAME s_scm_centered_remainder
2711 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2713 scm_t_inum xx
= SCM_I_INUM (x
);
2714 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2716 scm_t_inum yy
= SCM_I_INUM (y
);
2717 if (SCM_UNLIKELY (yy
== 0))
2718 scm_num_overflow (s_scm_centered_remainder
);
2721 scm_t_inum rr
= xx
% yy
;
2722 if (SCM_LIKELY (xx
> 0))
2724 if (SCM_LIKELY (yy
> 0))
2726 if (rr
>= (yy
+ 1) / 2)
2731 if (rr
>= (1 - yy
) / 2)
2737 if (SCM_LIKELY (yy
> 0))
2748 return SCM_I_MAKINUM (rr
);
2751 else if (SCM_BIGP (y
))
2753 /* Pass a denormalized bignum version of x (even though it
2754 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2755 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2757 else if (SCM_REALP (y
))
2758 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2759 else if (SCM_FRACTIONP (y
))
2760 return scm_i_exact_rational_centered_remainder (x
, y
);
2762 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2763 s_scm_centered_remainder
);
2765 else if (SCM_BIGP (x
))
2767 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2769 scm_t_inum yy
= SCM_I_INUM (y
);
2770 if (SCM_UNLIKELY (yy
== 0))
2771 scm_num_overflow (s_scm_centered_remainder
);
2775 /* Arrange for rr to initially be non-positive,
2776 because that simplifies the test to see
2777 if it is within the needed bounds. */
2780 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2781 scm_remember_upto_here_1 (x
);
2787 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2788 scm_remember_upto_here_1 (x
);
2792 return SCM_I_MAKINUM (rr
);
2795 else if (SCM_BIGP (y
))
2796 return scm_i_bigint_centered_remainder (x
, y
);
2797 else if (SCM_REALP (y
))
2798 return scm_i_inexact_centered_remainder
2799 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2800 else if (SCM_FRACTIONP (y
))
2801 return scm_i_exact_rational_centered_remainder (x
, y
);
2803 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2804 s_scm_centered_remainder
);
2806 else if (SCM_REALP (x
))
2808 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2809 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2810 return scm_i_inexact_centered_remainder
2811 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2813 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2814 s_scm_centered_remainder
);
2816 else if (SCM_FRACTIONP (x
))
2819 return scm_i_inexact_centered_remainder
2820 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2821 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2822 return scm_i_exact_rational_centered_remainder (x
, y
);
2824 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2825 s_scm_centered_remainder
);
2828 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2829 s_scm_centered_remainder
);
2834 scm_i_inexact_centered_remainder (double x
, double y
)
2838 /* Although it would be more efficient to use fmod here, we can't
2839 because it would in some cases produce results inconsistent with
2840 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2841 close). In particular, when x-y/2 is very close to a multiple of
2842 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2843 two cases must correspond to different choices of q. If quotient
2844 chooses one and remainder chooses the other, it would be bad. */
2845 if (SCM_LIKELY (y
> 0))
2846 q
= floor (x
/y
+ 0.5);
2847 else if (SCM_LIKELY (y
< 0))
2848 q
= ceil (x
/y
- 0.5);
2850 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2853 return scm_from_double (x
- q
* y
);
2856 /* Assumes that both x and y are bigints, though
2857 x might be able to fit into a fixnum. */
2859 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2863 /* Note that x might be small enough to fit into a
2864 fixnum, so we must not let it escape into the wild */
2867 /* min_r will eventually become -abs(y)/2 */
2868 min_r
= scm_i_mkbig ();
2869 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2870 SCM_I_BIG_MPZ (y
), 1);
2872 /* Arrange for rr to initially be non-positive,
2873 because that simplifies the test to see
2874 if it is within the needed bounds. */
2875 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2877 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2878 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2879 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2880 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2881 mpz_add (SCM_I_BIG_MPZ (r
),
2887 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2888 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2889 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2890 mpz_sub (SCM_I_BIG_MPZ (r
),
2894 scm_remember_upto_here_2 (x
, y
);
2895 return scm_i_normbig (r
);
2899 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2901 SCM xd
= scm_denominator (x
);
2902 SCM yd
= scm_denominator (y
);
2903 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2904 scm_product (scm_numerator (y
), xd
));
2905 return scm_divide (r1
, scm_product (xd
, yd
));
2909 static void scm_i_inexact_centered_divide (double x
, double y
,
2911 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2912 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2915 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2917 "Return the integer @var{q} and the real number @var{r}\n"
2918 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2919 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2921 "(centered/ 123 10) @result{} 12 and 3\n"
2922 "(centered/ 123 -10) @result{} -12 and 3\n"
2923 "(centered/ -123 10) @result{} -12 and -3\n"
2924 "(centered/ -123 -10) @result{} 12 and -3\n"
2925 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2926 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2928 #define FUNC_NAME s_scm_i_centered_divide
2932 scm_centered_divide(x
, y
, &q
, &r
);
2933 return scm_values (scm_list_2 (q
, r
));
2937 #define s_scm_centered_divide s_scm_i_centered_divide
2938 #define g_scm_centered_divide g_scm_i_centered_divide
2941 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2943 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2945 scm_t_inum xx
= SCM_I_INUM (x
);
2946 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2948 scm_t_inum yy
= SCM_I_INUM (y
);
2949 if (SCM_UNLIKELY (yy
== 0))
2950 scm_num_overflow (s_scm_centered_divide
);
2953 scm_t_inum qq
= xx
/ yy
;
2954 scm_t_inum rr
= xx
% yy
;
2955 if (SCM_LIKELY (xx
> 0))
2957 if (SCM_LIKELY (yy
> 0))
2959 if (rr
>= (yy
+ 1) / 2)
2964 if (rr
>= (1 - yy
) / 2)
2970 if (SCM_LIKELY (yy
> 0))
2981 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2982 *qp
= SCM_I_MAKINUM (qq
);
2984 *qp
= scm_i_inum2big (qq
);
2985 *rp
= SCM_I_MAKINUM (rr
);
2989 else if (SCM_BIGP (y
))
2991 /* Pass a denormalized bignum version of x (even though it
2992 can fit in a fixnum) to scm_i_bigint_centered_divide */
2993 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
2995 else if (SCM_REALP (y
))
2996 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2997 else if (SCM_FRACTIONP (y
))
2998 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3000 return two_valued_wta_dispatch_2
3001 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3002 s_scm_centered_divide
, qp
, rp
);
3004 else if (SCM_BIGP (x
))
3006 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3008 scm_t_inum yy
= SCM_I_INUM (y
);
3009 if (SCM_UNLIKELY (yy
== 0))
3010 scm_num_overflow (s_scm_centered_divide
);
3013 SCM q
= scm_i_mkbig ();
3015 /* Arrange for rr to initially be non-positive,
3016 because that simplifies the test to see
3017 if it is within the needed bounds. */
3020 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3021 SCM_I_BIG_MPZ (x
), yy
);
3022 scm_remember_upto_here_1 (x
);
3025 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3026 SCM_I_BIG_MPZ (q
), 1);
3032 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3033 SCM_I_BIG_MPZ (x
), -yy
);
3034 scm_remember_upto_here_1 (x
);
3035 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3038 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3039 SCM_I_BIG_MPZ (q
), 1);
3043 *qp
= scm_i_normbig (q
);
3044 *rp
= SCM_I_MAKINUM (rr
);
3048 else if (SCM_BIGP (y
))
3049 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3050 else if (SCM_REALP (y
))
3051 return scm_i_inexact_centered_divide
3052 (scm_i_big2dbl (x
), 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_REALP (x
))
3062 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3063 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3064 return scm_i_inexact_centered_divide
3065 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3067 return two_valued_wta_dispatch_2
3068 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3069 s_scm_centered_divide
, qp
, rp
);
3071 else if (SCM_FRACTIONP (x
))
3074 return scm_i_inexact_centered_divide
3075 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3076 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3077 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3079 return two_valued_wta_dispatch_2
3080 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3081 s_scm_centered_divide
, qp
, rp
);
3084 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3085 s_scm_centered_divide
, qp
, rp
);
3089 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3093 if (SCM_LIKELY (y
> 0))
3094 q
= floor (x
/y
+ 0.5);
3095 else if (SCM_LIKELY (y
< 0))
3096 q
= ceil (x
/y
- 0.5);
3098 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3102 *qp
= scm_from_double (q
);
3103 *rp
= scm_from_double (r
);
3106 /* Assumes that both x and y are bigints, though
3107 x might be able to fit into a fixnum. */
3109 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3113 /* Note that x might be small enough to fit into a
3114 fixnum, so we must not let it escape into the wild */
3118 /* min_r will eventually become -abs(y/2) */
3119 min_r
= scm_i_mkbig ();
3120 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3121 SCM_I_BIG_MPZ (y
), 1);
3123 /* Arrange for rr to initially be non-positive,
3124 because that simplifies the test to see
3125 if it is within the needed bounds. */
3126 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3128 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3129 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3130 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3131 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3133 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3134 SCM_I_BIG_MPZ (q
), 1);
3135 mpz_add (SCM_I_BIG_MPZ (r
),
3142 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3143 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3144 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3146 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3147 SCM_I_BIG_MPZ (q
), 1);
3148 mpz_sub (SCM_I_BIG_MPZ (r
),
3153 scm_remember_upto_here_2 (x
, y
);
3154 *qp
= scm_i_normbig (q
);
3155 *rp
= scm_i_normbig (r
);
3159 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3162 SCM xd
= scm_denominator (x
);
3163 SCM yd
= scm_denominator (y
);
3165 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3166 scm_product (scm_numerator (y
), xd
),
3168 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3171 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3172 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3173 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3175 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3177 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3178 "with ties going to the nearest even integer.\n"
3180 "(round-quotient 123 10) @result{} 12\n"
3181 "(round-quotient 123 -10) @result{} -12\n"
3182 "(round-quotient -123 10) @result{} -12\n"
3183 "(round-quotient -123 -10) @result{} 12\n"
3184 "(round-quotient 125 10) @result{} 12\n"
3185 "(round-quotient 127 10) @result{} 13\n"
3186 "(round-quotient 135 10) @result{} 14\n"
3187 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3188 "(round-quotient 16/3 -10/7) @result{} -4\n"
3190 #define FUNC_NAME s_scm_round_quotient
3192 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3194 scm_t_inum xx
= SCM_I_INUM (x
);
3195 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3197 scm_t_inum yy
= SCM_I_INUM (y
);
3198 if (SCM_UNLIKELY (yy
== 0))
3199 scm_num_overflow (s_scm_round_quotient
);
3202 scm_t_inum qq
= xx
/ yy
;
3203 scm_t_inum rr
= xx
% yy
;
3205 scm_t_inum r2
= 2 * rr
;
3207 if (SCM_LIKELY (yy
< 0))
3227 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3228 return SCM_I_MAKINUM (qq
);
3230 return scm_i_inum2big (qq
);
3233 else if (SCM_BIGP (y
))
3235 /* Pass a denormalized bignum version of x (even though it
3236 can fit in a fixnum) to scm_i_bigint_round_quotient */
3237 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3239 else if (SCM_REALP (y
))
3240 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3241 else if (SCM_FRACTIONP (y
))
3242 return scm_i_exact_rational_round_quotient (x
, y
);
3244 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3245 s_scm_round_quotient
);
3247 else if (SCM_BIGP (x
))
3249 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3251 scm_t_inum yy
= SCM_I_INUM (y
);
3252 if (SCM_UNLIKELY (yy
== 0))
3253 scm_num_overflow (s_scm_round_quotient
);
3254 else if (SCM_UNLIKELY (yy
== 1))
3258 SCM q
= scm_i_mkbig ();
3260 int needs_adjustment
;
3264 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3265 SCM_I_BIG_MPZ (x
), yy
);
3266 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3267 needs_adjustment
= (2*rr
>= yy
);
3269 needs_adjustment
= (2*rr
> yy
);
3273 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3274 SCM_I_BIG_MPZ (x
), -yy
);
3275 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3276 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3277 needs_adjustment
= (2*rr
<= yy
);
3279 needs_adjustment
= (2*rr
< yy
);
3281 scm_remember_upto_here_1 (x
);
3282 if (needs_adjustment
)
3283 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3284 return scm_i_normbig (q
);
3287 else if (SCM_BIGP (y
))
3288 return scm_i_bigint_round_quotient (x
, y
);
3289 else if (SCM_REALP (y
))
3290 return scm_i_inexact_round_quotient
3291 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3292 else if (SCM_FRACTIONP (y
))
3293 return scm_i_exact_rational_round_quotient (x
, y
);
3295 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3296 s_scm_round_quotient
);
3298 else if (SCM_REALP (x
))
3300 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3301 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3302 return scm_i_inexact_round_quotient
3303 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3305 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3306 s_scm_round_quotient
);
3308 else if (SCM_FRACTIONP (x
))
3311 return scm_i_inexact_round_quotient
3312 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3313 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3314 return scm_i_exact_rational_round_quotient (x
, y
);
3316 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3317 s_scm_round_quotient
);
3320 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3321 s_scm_round_quotient
);
3326 scm_i_inexact_round_quotient (double x
, double y
)
3328 if (SCM_UNLIKELY (y
== 0))
3329 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3331 return scm_from_double (scm_c_round (x
/ y
));
3334 /* Assumes that both x and y are bigints, though
3335 x might be able to fit into a fixnum. */
3337 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3340 int cmp
, needs_adjustment
;
3342 /* Note that x might be small enough to fit into a
3343 fixnum, so we must not let it escape into the wild */
3346 r2
= scm_i_mkbig ();
3348 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3349 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3350 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3351 scm_remember_upto_here_2 (x
, r
);
3353 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3354 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3355 needs_adjustment
= (cmp
>= 0);
3357 needs_adjustment
= (cmp
> 0);
3358 scm_remember_upto_here_2 (r2
, y
);
3360 if (needs_adjustment
)
3361 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3363 return scm_i_normbig (q
);
3367 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3369 return scm_round_quotient
3370 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3371 scm_product (scm_numerator (y
), scm_denominator (x
)));
3374 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3375 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3376 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3378 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3380 "Return the real number @var{r} such that\n"
3381 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3382 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3383 "nearest integer, with ties going to the nearest\n"
3386 "(round-remainder 123 10) @result{} 3\n"
3387 "(round-remainder 123 -10) @result{} 3\n"
3388 "(round-remainder -123 10) @result{} -3\n"
3389 "(round-remainder -123 -10) @result{} -3\n"
3390 "(round-remainder 125 10) @result{} 5\n"
3391 "(round-remainder 127 10) @result{} -3\n"
3392 "(round-remainder 135 10) @result{} -5\n"
3393 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3394 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3396 #define FUNC_NAME s_scm_round_remainder
3398 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3400 scm_t_inum xx
= SCM_I_INUM (x
);
3401 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3403 scm_t_inum yy
= SCM_I_INUM (y
);
3404 if (SCM_UNLIKELY (yy
== 0))
3405 scm_num_overflow (s_scm_round_remainder
);
3408 scm_t_inum qq
= xx
/ yy
;
3409 scm_t_inum rr
= xx
% yy
;
3411 scm_t_inum r2
= 2 * rr
;
3413 if (SCM_LIKELY (yy
< 0))
3433 return SCM_I_MAKINUM (rr
);
3436 else if (SCM_BIGP (y
))
3438 /* Pass a denormalized bignum version of x (even though it
3439 can fit in a fixnum) to scm_i_bigint_round_remainder */
3440 return scm_i_bigint_round_remainder
3441 (scm_i_long2big (xx
), y
);
3443 else if (SCM_REALP (y
))
3444 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3445 else if (SCM_FRACTIONP (y
))
3446 return scm_i_exact_rational_round_remainder (x
, y
);
3448 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3449 s_scm_round_remainder
);
3451 else if (SCM_BIGP (x
))
3453 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3455 scm_t_inum yy
= SCM_I_INUM (y
);
3456 if (SCM_UNLIKELY (yy
== 0))
3457 scm_num_overflow (s_scm_round_remainder
);
3460 SCM q
= scm_i_mkbig ();
3462 int needs_adjustment
;
3466 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3467 SCM_I_BIG_MPZ (x
), yy
);
3468 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3469 needs_adjustment
= (2*rr
>= yy
);
3471 needs_adjustment
= (2*rr
> yy
);
3475 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3476 SCM_I_BIG_MPZ (x
), -yy
);
3477 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3478 needs_adjustment
= (2*rr
<= yy
);
3480 needs_adjustment
= (2*rr
< yy
);
3482 scm_remember_upto_here_2 (x
, q
);
3483 if (needs_adjustment
)
3485 return SCM_I_MAKINUM (rr
);
3488 else if (SCM_BIGP (y
))
3489 return scm_i_bigint_round_remainder (x
, y
);
3490 else if (SCM_REALP (y
))
3491 return scm_i_inexact_round_remainder
3492 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3493 else if (SCM_FRACTIONP (y
))
3494 return scm_i_exact_rational_round_remainder (x
, y
);
3496 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3497 s_scm_round_remainder
);
3499 else if (SCM_REALP (x
))
3501 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3502 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3503 return scm_i_inexact_round_remainder
3504 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3506 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3507 s_scm_round_remainder
);
3509 else if (SCM_FRACTIONP (x
))
3512 return scm_i_inexact_round_remainder
3513 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3514 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3515 return scm_i_exact_rational_round_remainder (x
, y
);
3517 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3518 s_scm_round_remainder
);
3521 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3522 s_scm_round_remainder
);
3527 scm_i_inexact_round_remainder (double x
, double y
)
3529 /* Although it would be more efficient to use fmod here, we can't
3530 because it would in some cases produce results inconsistent with
3531 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3532 close). In particular, when x-y/2 is very close to a multiple of
3533 y, then r might be either -abs(y/2) or abs(y/2), but those two
3534 cases must correspond to different choices of q. If quotient
3535 chooses one and remainder chooses the other, it would be bad. */
3537 if (SCM_UNLIKELY (y
== 0))
3538 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3541 double q
= scm_c_round (x
/ y
);
3542 return scm_from_double (x
- q
* y
);
3546 /* Assumes that both x and y are bigints, though
3547 x might be able to fit into a fixnum. */
3549 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3552 int cmp
, needs_adjustment
;
3554 /* Note that x might be small enough to fit into a
3555 fixnum, so we must not let it escape into the wild */
3558 r2
= scm_i_mkbig ();
3560 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3561 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3562 scm_remember_upto_here_1 (x
);
3563 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3565 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3566 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3567 needs_adjustment
= (cmp
>= 0);
3569 needs_adjustment
= (cmp
> 0);
3570 scm_remember_upto_here_2 (q
, r2
);
3572 if (needs_adjustment
)
3573 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3575 scm_remember_upto_here_1 (y
);
3576 return scm_i_normbig (r
);
3580 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3582 SCM xd
= scm_denominator (x
);
3583 SCM yd
= scm_denominator (y
);
3584 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3585 scm_product (scm_numerator (y
), xd
));
3586 return scm_divide (r1
, scm_product (xd
, yd
));
3590 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3591 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3592 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3594 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3596 "Return the integer @var{q} and the real number @var{r}\n"
3597 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3598 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3599 "nearest integer, with ties going to the nearest even integer.\n"
3601 "(round/ 123 10) @result{} 12 and 3\n"
3602 "(round/ 123 -10) @result{} -12 and 3\n"
3603 "(round/ -123 10) @result{} -12 and -3\n"
3604 "(round/ -123 -10) @result{} 12 and -3\n"
3605 "(round/ 125 10) @result{} 12 and 5\n"
3606 "(round/ 127 10) @result{} 13 and -3\n"
3607 "(round/ 135 10) @result{} 14 and -5\n"
3608 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3609 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3611 #define FUNC_NAME s_scm_i_round_divide
3615 scm_round_divide(x
, y
, &q
, &r
);
3616 return scm_values (scm_list_2 (q
, r
));
3620 #define s_scm_round_divide s_scm_i_round_divide
3621 #define g_scm_round_divide g_scm_i_round_divide
3624 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3626 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3628 scm_t_inum xx
= SCM_I_INUM (x
);
3629 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3631 scm_t_inum yy
= SCM_I_INUM (y
);
3632 if (SCM_UNLIKELY (yy
== 0))
3633 scm_num_overflow (s_scm_round_divide
);
3636 scm_t_inum qq
= xx
/ yy
;
3637 scm_t_inum rr
= xx
% yy
;
3639 scm_t_inum r2
= 2 * rr
;
3641 if (SCM_LIKELY (yy
< 0))
3661 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3662 *qp
= SCM_I_MAKINUM (qq
);
3664 *qp
= scm_i_inum2big (qq
);
3665 *rp
= SCM_I_MAKINUM (rr
);
3669 else if (SCM_BIGP (y
))
3671 /* Pass a denormalized bignum version of x (even though it
3672 can fit in a fixnum) to scm_i_bigint_round_divide */
3673 return scm_i_bigint_round_divide
3674 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3676 else if (SCM_REALP (y
))
3677 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3678 else if (SCM_FRACTIONP (y
))
3679 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3681 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3682 s_scm_round_divide
, qp
, rp
);
3684 else if (SCM_BIGP (x
))
3686 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3688 scm_t_inum yy
= SCM_I_INUM (y
);
3689 if (SCM_UNLIKELY (yy
== 0))
3690 scm_num_overflow (s_scm_round_divide
);
3693 SCM q
= scm_i_mkbig ();
3695 int needs_adjustment
;
3699 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3700 SCM_I_BIG_MPZ (x
), yy
);
3701 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3702 needs_adjustment
= (2*rr
>= yy
);
3704 needs_adjustment
= (2*rr
> yy
);
3708 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3709 SCM_I_BIG_MPZ (x
), -yy
);
3710 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3711 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3712 needs_adjustment
= (2*rr
<= yy
);
3714 needs_adjustment
= (2*rr
< yy
);
3716 scm_remember_upto_here_1 (x
);
3717 if (needs_adjustment
)
3719 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3722 *qp
= scm_i_normbig (q
);
3723 *rp
= SCM_I_MAKINUM (rr
);
3727 else if (SCM_BIGP (y
))
3728 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3729 else if (SCM_REALP (y
))
3730 return scm_i_inexact_round_divide
3731 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3732 else if (SCM_FRACTIONP (y
))
3733 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3735 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3736 s_scm_round_divide
, qp
, rp
);
3738 else if (SCM_REALP (x
))
3740 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3741 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3742 return scm_i_inexact_round_divide
3743 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3745 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3746 s_scm_round_divide
, qp
, rp
);
3748 else if (SCM_FRACTIONP (x
))
3751 return scm_i_inexact_round_divide
3752 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3753 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3754 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3756 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3757 s_scm_round_divide
, qp
, rp
);
3760 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3761 s_scm_round_divide
, qp
, rp
);
3765 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3767 if (SCM_UNLIKELY (y
== 0))
3768 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3771 double q
= scm_c_round (x
/ y
);
3772 double r
= x
- q
* y
;
3773 *qp
= scm_from_double (q
);
3774 *rp
= scm_from_double (r
);
3778 /* Assumes that both x and y are bigints, though
3779 x might be able to fit into a fixnum. */
3781 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3784 int cmp
, needs_adjustment
;
3786 /* Note that x might be small enough to fit into a
3787 fixnum, so we must not let it escape into the wild */
3790 r2
= scm_i_mkbig ();
3792 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3793 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3794 scm_remember_upto_here_1 (x
);
3795 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3797 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3798 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3799 needs_adjustment
= (cmp
>= 0);
3801 needs_adjustment
= (cmp
> 0);
3803 if (needs_adjustment
)
3805 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3806 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3809 scm_remember_upto_here_2 (r2
, y
);
3810 *qp
= scm_i_normbig (q
);
3811 *rp
= scm_i_normbig (r
);
3815 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3818 SCM xd
= scm_denominator (x
);
3819 SCM yd
= scm_denominator (y
);
3821 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3822 scm_product (scm_numerator (y
), xd
),
3824 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3828 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3829 (SCM x
, SCM y
, SCM rest
),
3830 "Return the greatest common divisor of all parameter values.\n"
3831 "If called without arguments, 0 is returned.")
3832 #define FUNC_NAME s_scm_i_gcd
3834 while (!scm_is_null (rest
))
3835 { x
= scm_gcd (x
, y
);
3837 rest
= scm_cdr (rest
);
3839 return scm_gcd (x
, y
);
3843 #define s_gcd s_scm_i_gcd
3844 #define g_gcd g_scm_i_gcd
3847 scm_gcd (SCM x
, SCM y
)
3850 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3852 if (SCM_I_INUMP (x
))
3854 if (SCM_I_INUMP (y
))
3856 scm_t_inum xx
= SCM_I_INUM (x
);
3857 scm_t_inum yy
= SCM_I_INUM (y
);
3858 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3859 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3869 /* Determine a common factor 2^k */
3870 while (!(1 & (u
| v
)))
3876 /* Now, any factor 2^n can be eliminated */
3896 return (SCM_POSFIXABLE (result
)
3897 ? SCM_I_MAKINUM (result
)
3898 : scm_i_inum2big (result
));
3900 else if (SCM_BIGP (y
))
3906 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3908 else if (SCM_BIGP (x
))
3910 if (SCM_I_INUMP (y
))
3915 yy
= SCM_I_INUM (y
);
3920 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3921 scm_remember_upto_here_1 (x
);
3922 return (SCM_POSFIXABLE (result
)
3923 ? SCM_I_MAKINUM (result
)
3924 : scm_from_unsigned_integer (result
));
3926 else if (SCM_BIGP (y
))
3928 SCM result
= scm_i_mkbig ();
3929 mpz_gcd (SCM_I_BIG_MPZ (result
),
3932 scm_remember_upto_here_2 (x
, y
);
3933 return scm_i_normbig (result
);
3936 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3939 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3942 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3943 (SCM x
, SCM y
, SCM rest
),
3944 "Return the least common multiple of the arguments.\n"
3945 "If called without arguments, 1 is returned.")
3946 #define FUNC_NAME s_scm_i_lcm
3948 while (!scm_is_null (rest
))
3949 { x
= scm_lcm (x
, y
);
3951 rest
= scm_cdr (rest
);
3953 return scm_lcm (x
, y
);
3957 #define s_lcm s_scm_i_lcm
3958 #define g_lcm g_scm_i_lcm
3961 scm_lcm (SCM n1
, SCM n2
)
3963 if (SCM_UNBNDP (n2
))
3965 if (SCM_UNBNDP (n1
))
3966 return SCM_I_MAKINUM (1L);
3967 n2
= SCM_I_MAKINUM (1L);
3970 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
3971 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3972 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
3973 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
3975 if (SCM_I_INUMP (n1
))
3977 if (SCM_I_INUMP (n2
))
3979 SCM d
= scm_gcd (n1
, n2
);
3980 if (scm_is_eq (d
, SCM_INUM0
))
3983 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
3987 /* inum n1, big n2 */
3990 SCM result
= scm_i_mkbig ();
3991 scm_t_inum nn1
= SCM_I_INUM (n1
);
3992 if (nn1
== 0) return SCM_INUM0
;
3993 if (nn1
< 0) nn1
= - nn1
;
3994 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
3995 scm_remember_upto_here_1 (n2
);
4003 if (SCM_I_INUMP (n2
))
4010 SCM result
= scm_i_mkbig ();
4011 mpz_lcm(SCM_I_BIG_MPZ (result
),
4013 SCM_I_BIG_MPZ (n2
));
4014 scm_remember_upto_here_2(n1
, n2
);
4015 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4021 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4026 + + + x (map digit:logand X Y)
4027 + - + x (map digit:logand X (lognot (+ -1 Y)))
4028 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4029 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4034 + + + (map digit:logior X Y)
4035 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4036 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4037 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4042 + + + (map digit:logxor X Y)
4043 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4044 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4045 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4050 + + (any digit:logand X Y)
4051 + - (any digit:logand X (lognot (+ -1 Y)))
4052 - + (any digit:logand (lognot (+ -1 X)) Y)
4057 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4058 (SCM x
, SCM y
, SCM rest
),
4059 "Return the bitwise AND of the integer arguments.\n\n"
4061 "(logand) @result{} -1\n"
4062 "(logand 7) @result{} 7\n"
4063 "(logand #b111 #b011 #b001) @result{} 1\n"
4065 #define FUNC_NAME s_scm_i_logand
4067 while (!scm_is_null (rest
))
4068 { x
= scm_logand (x
, y
);
4070 rest
= scm_cdr (rest
);
4072 return scm_logand (x
, y
);
4076 #define s_scm_logand s_scm_i_logand
4078 SCM
scm_logand (SCM n1
, SCM n2
)
4079 #define FUNC_NAME s_scm_logand
4083 if (SCM_UNBNDP (n2
))
4085 if (SCM_UNBNDP (n1
))
4086 return SCM_I_MAKINUM (-1);
4087 else if (!SCM_NUMBERP (n1
))
4088 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4089 else if (SCM_NUMBERP (n1
))
4092 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4095 if (SCM_I_INUMP (n1
))
4097 nn1
= SCM_I_INUM (n1
);
4098 if (SCM_I_INUMP (n2
))
4100 scm_t_inum nn2
= SCM_I_INUM (n2
);
4101 return SCM_I_MAKINUM (nn1
& nn2
);
4103 else if SCM_BIGP (n2
)
4109 SCM result_z
= scm_i_mkbig ();
4111 mpz_init_set_si (nn1_z
, nn1
);
4112 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4113 scm_remember_upto_here_1 (n2
);
4115 return scm_i_normbig (result_z
);
4119 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4121 else if (SCM_BIGP (n1
))
4123 if (SCM_I_INUMP (n2
))
4126 nn1
= SCM_I_INUM (n1
);
4129 else if (SCM_BIGP (n2
))
4131 SCM result_z
= scm_i_mkbig ();
4132 mpz_and (SCM_I_BIG_MPZ (result_z
),
4134 SCM_I_BIG_MPZ (n2
));
4135 scm_remember_upto_here_2 (n1
, n2
);
4136 return scm_i_normbig (result_z
);
4139 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4142 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4147 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4148 (SCM x
, SCM y
, SCM rest
),
4149 "Return the bitwise OR of the integer arguments.\n\n"
4151 "(logior) @result{} 0\n"
4152 "(logior 7) @result{} 7\n"
4153 "(logior #b000 #b001 #b011) @result{} 3\n"
4155 #define FUNC_NAME s_scm_i_logior
4157 while (!scm_is_null (rest
))
4158 { x
= scm_logior (x
, y
);
4160 rest
= scm_cdr (rest
);
4162 return scm_logior (x
, y
);
4166 #define s_scm_logior s_scm_i_logior
4168 SCM
scm_logior (SCM n1
, SCM n2
)
4169 #define FUNC_NAME s_scm_logior
4173 if (SCM_UNBNDP (n2
))
4175 if (SCM_UNBNDP (n1
))
4177 else if (SCM_NUMBERP (n1
))
4180 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4183 if (SCM_I_INUMP (n1
))
4185 nn1
= SCM_I_INUM (n1
);
4186 if (SCM_I_INUMP (n2
))
4188 long nn2
= SCM_I_INUM (n2
);
4189 return SCM_I_MAKINUM (nn1
| nn2
);
4191 else if (SCM_BIGP (n2
))
4197 SCM result_z
= scm_i_mkbig ();
4199 mpz_init_set_si (nn1_z
, nn1
);
4200 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4201 scm_remember_upto_here_1 (n2
);
4203 return scm_i_normbig (result_z
);
4207 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4209 else if (SCM_BIGP (n1
))
4211 if (SCM_I_INUMP (n2
))
4214 nn1
= SCM_I_INUM (n1
);
4217 else if (SCM_BIGP (n2
))
4219 SCM result_z
= scm_i_mkbig ();
4220 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4222 SCM_I_BIG_MPZ (n2
));
4223 scm_remember_upto_here_2 (n1
, n2
);
4224 return scm_i_normbig (result_z
);
4227 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4230 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4235 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4236 (SCM x
, SCM y
, SCM rest
),
4237 "Return the bitwise XOR of the integer arguments. A bit is\n"
4238 "set in the result if it is set in an odd number of arguments.\n"
4240 "(logxor) @result{} 0\n"
4241 "(logxor 7) @result{} 7\n"
4242 "(logxor #b000 #b001 #b011) @result{} 2\n"
4243 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4245 #define FUNC_NAME s_scm_i_logxor
4247 while (!scm_is_null (rest
))
4248 { x
= scm_logxor (x
, y
);
4250 rest
= scm_cdr (rest
);
4252 return scm_logxor (x
, y
);
4256 #define s_scm_logxor s_scm_i_logxor
4258 SCM
scm_logxor (SCM n1
, SCM n2
)
4259 #define FUNC_NAME s_scm_logxor
4263 if (SCM_UNBNDP (n2
))
4265 if (SCM_UNBNDP (n1
))
4267 else if (SCM_NUMBERP (n1
))
4270 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4273 if (SCM_I_INUMP (n1
))
4275 nn1
= SCM_I_INUM (n1
);
4276 if (SCM_I_INUMP (n2
))
4278 scm_t_inum nn2
= SCM_I_INUM (n2
);
4279 return SCM_I_MAKINUM (nn1
^ nn2
);
4281 else if (SCM_BIGP (n2
))
4285 SCM result_z
= scm_i_mkbig ();
4287 mpz_init_set_si (nn1_z
, nn1
);
4288 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4289 scm_remember_upto_here_1 (n2
);
4291 return scm_i_normbig (result_z
);
4295 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4297 else if (SCM_BIGP (n1
))
4299 if (SCM_I_INUMP (n2
))
4302 nn1
= SCM_I_INUM (n1
);
4305 else if (SCM_BIGP (n2
))
4307 SCM result_z
= scm_i_mkbig ();
4308 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4310 SCM_I_BIG_MPZ (n2
));
4311 scm_remember_upto_here_2 (n1
, n2
);
4312 return scm_i_normbig (result_z
);
4315 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4318 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4323 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4325 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4326 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4327 "without actually calculating the @code{logand}, just testing\n"
4331 "(logtest #b0100 #b1011) @result{} #f\n"
4332 "(logtest #b0100 #b0111) @result{} #t\n"
4334 #define FUNC_NAME s_scm_logtest
4338 if (SCM_I_INUMP (j
))
4340 nj
= SCM_I_INUM (j
);
4341 if (SCM_I_INUMP (k
))
4343 scm_t_inum nk
= SCM_I_INUM (k
);
4344 return scm_from_bool (nj
& nk
);
4346 else if (SCM_BIGP (k
))
4354 mpz_init_set_si (nj_z
, nj
);
4355 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4356 scm_remember_upto_here_1 (k
);
4357 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4363 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4365 else if (SCM_BIGP (j
))
4367 if (SCM_I_INUMP (k
))
4370 nj
= SCM_I_INUM (j
);
4373 else if (SCM_BIGP (k
))
4377 mpz_init (result_z
);
4381 scm_remember_upto_here_2 (j
, k
);
4382 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4383 mpz_clear (result_z
);
4387 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4390 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4395 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4397 "Test whether bit number @var{index} in @var{j} is set.\n"
4398 "@var{index} starts from 0 for the least significant bit.\n"
4401 "(logbit? 0 #b1101) @result{} #t\n"
4402 "(logbit? 1 #b1101) @result{} #f\n"
4403 "(logbit? 2 #b1101) @result{} #t\n"
4404 "(logbit? 3 #b1101) @result{} #t\n"
4405 "(logbit? 4 #b1101) @result{} #f\n"
4407 #define FUNC_NAME s_scm_logbit_p
4409 unsigned long int iindex
;
4410 iindex
= scm_to_ulong (index
);
4412 if (SCM_I_INUMP (j
))
4414 /* bits above what's in an inum follow the sign bit */
4415 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4416 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4418 else if (SCM_BIGP (j
))
4420 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4421 scm_remember_upto_here_1 (j
);
4422 return scm_from_bool (val
);
4425 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4430 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4432 "Return the integer which is the ones-complement of the integer\n"
4436 "(number->string (lognot #b10000000) 2)\n"
4437 " @result{} \"-10000001\"\n"
4438 "(number->string (lognot #b0) 2)\n"
4439 " @result{} \"-1\"\n"
4441 #define FUNC_NAME s_scm_lognot
4443 if (SCM_I_INUMP (n
)) {
4444 /* No overflow here, just need to toggle all the bits making up the inum.
4445 Enhancement: No need to strip the tag and add it back, could just xor
4446 a block of 1 bits, if that worked with the various debug versions of
4448 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4450 } else if (SCM_BIGP (n
)) {
4451 SCM result
= scm_i_mkbig ();
4452 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4453 scm_remember_upto_here_1 (n
);
4457 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4462 /* returns 0 if IN is not an integer. OUT must already be
4465 coerce_to_big (SCM in
, mpz_t out
)
4468 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4469 else if (SCM_I_INUMP (in
))
4470 mpz_set_si (out
, SCM_I_INUM (in
));
4477 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4478 (SCM n
, SCM k
, SCM m
),
4479 "Return @var{n} raised to the integer exponent\n"
4480 "@var{k}, modulo @var{m}.\n"
4483 "(modulo-expt 2 3 5)\n"
4486 #define FUNC_NAME s_scm_modulo_expt
4492 /* There are two classes of error we might encounter --
4493 1) Math errors, which we'll report by calling scm_num_overflow,
4495 2) wrong-type errors, which of course we'll report by calling
4497 We don't report those errors immediately, however; instead we do
4498 some cleanup first. These variables tell us which error (if
4499 any) we should report after cleaning up.
4501 int report_overflow
= 0;
4503 int position_of_wrong_type
= 0;
4504 SCM value_of_wrong_type
= SCM_INUM0
;
4506 SCM result
= SCM_UNDEFINED
;
4512 if (scm_is_eq (m
, SCM_INUM0
))
4514 report_overflow
= 1;
4518 if (!coerce_to_big (n
, n_tmp
))
4520 value_of_wrong_type
= n
;
4521 position_of_wrong_type
= 1;
4525 if (!coerce_to_big (k
, k_tmp
))
4527 value_of_wrong_type
= k
;
4528 position_of_wrong_type
= 2;
4532 if (!coerce_to_big (m
, m_tmp
))
4534 value_of_wrong_type
= m
;
4535 position_of_wrong_type
= 3;
4539 /* if the exponent K is negative, and we simply call mpz_powm, we
4540 will get a divide-by-zero exception when an inverse 1/n mod m
4541 doesn't exist (or is not unique). Since exceptions are hard to
4542 handle, we'll attempt the inversion "by hand" -- that way, we get
4543 a simple failure code, which is easy to handle. */
4545 if (-1 == mpz_sgn (k_tmp
))
4547 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4549 report_overflow
= 1;
4552 mpz_neg (k_tmp
, k_tmp
);
4555 result
= scm_i_mkbig ();
4556 mpz_powm (SCM_I_BIG_MPZ (result
),
4561 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4562 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4569 if (report_overflow
)
4570 scm_num_overflow (FUNC_NAME
);
4572 if (position_of_wrong_type
)
4573 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4574 value_of_wrong_type
);
4576 return scm_i_normbig (result
);
4580 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4582 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4583 "exact integer, @var{n} can be any number.\n"
4585 "Negative @var{k} is supported, and results in\n"
4586 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4587 "@math{@var{n}^0} is 1, as usual, and that\n"
4588 "includes @math{0^0} is 1.\n"
4591 "(integer-expt 2 5) @result{} 32\n"
4592 "(integer-expt -3 3) @result{} -27\n"
4593 "(integer-expt 5 -3) @result{} 1/125\n"
4594 "(integer-expt 0 0) @result{} 1\n"
4596 #define FUNC_NAME s_scm_integer_expt
4599 SCM z_i2
= SCM_BOOL_F
;
4601 SCM acc
= SCM_I_MAKINUM (1L);
4603 /* Specifically refrain from checking the type of the first argument.
4604 This allows us to exponentiate any object that can be multiplied.
4605 If we must raise to a negative power, we must also be able to
4606 take its reciprocal. */
4607 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4608 SCM_WRONG_TYPE_ARG (2, k
);
4610 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4611 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4612 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4613 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4614 /* The next check is necessary only because R6RS specifies different
4615 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4616 we simply skip this case and move on. */
4617 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4619 /* k cannot be 0 at this point, because we
4620 have already checked for that case above */
4621 if (scm_is_true (scm_positive_p (k
)))
4623 else /* return NaN for (0 ^ k) for negative k per R6RS */
4627 if (SCM_I_INUMP (k
))
4628 i2
= SCM_I_INUM (k
);
4629 else if (SCM_BIGP (k
))
4631 z_i2
= scm_i_clonebig (k
, 1);
4632 scm_remember_upto_here_1 (k
);
4636 SCM_WRONG_TYPE_ARG (2, k
);
4640 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4642 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4643 n
= scm_divide (n
, SCM_UNDEFINED
);
4647 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4651 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4653 return scm_product (acc
, n
);
4655 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4656 acc
= scm_product (acc
, n
);
4657 n
= scm_product (n
, n
);
4658 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4666 n
= scm_divide (n
, SCM_UNDEFINED
);
4673 return scm_product (acc
, n
);
4675 acc
= scm_product (acc
, n
);
4676 n
= scm_product (n
, n
);
4683 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4685 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4686 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4688 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4689 "@var{cnt} is negative it's a division, rounded towards negative\n"
4690 "infinity. (Note that this is not the same rounding as\n"
4691 "@code{quotient} does.)\n"
4693 "With @var{n} viewed as an infinite precision twos complement,\n"
4694 "@code{ash} means a left shift introducing zero bits, or a right\n"
4695 "shift dropping bits.\n"
4698 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4699 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4701 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4702 "(ash -23 -2) @result{} -6\n"
4704 #define FUNC_NAME s_scm_ash
4707 bits_to_shift
= scm_to_long (cnt
);
4709 if (SCM_I_INUMP (n
))
4711 scm_t_inum nn
= SCM_I_INUM (n
);
4713 if (bits_to_shift
> 0)
4715 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4716 overflow a non-zero fixnum. For smaller shifts we check the
4717 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4718 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4719 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4725 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4727 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4730 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4734 SCM result
= scm_i_inum2big (nn
);
4735 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4742 bits_to_shift
= -bits_to_shift
;
4743 if (bits_to_shift
>= SCM_LONG_BIT
)
4744 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4746 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4750 else if (SCM_BIGP (n
))
4754 if (bits_to_shift
== 0)
4757 result
= scm_i_mkbig ();
4758 if (bits_to_shift
>= 0)
4760 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4766 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4767 we have to allocate a bignum even if the result is going to be a
4769 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4771 return scm_i_normbig (result
);
4777 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4783 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4784 (SCM n
, SCM start
, SCM end
),
4785 "Return the integer composed of the @var{start} (inclusive)\n"
4786 "through @var{end} (exclusive) bits of @var{n}. The\n"
4787 "@var{start}th bit becomes the 0-th bit in the result.\n"
4790 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4791 " @result{} \"1010\"\n"
4792 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4793 " @result{} \"10110\"\n"
4795 #define FUNC_NAME s_scm_bit_extract
4797 unsigned long int istart
, iend
, bits
;
4798 istart
= scm_to_ulong (start
);
4799 iend
= scm_to_ulong (end
);
4800 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4802 /* how many bits to keep */
4803 bits
= iend
- istart
;
4805 if (SCM_I_INUMP (n
))
4807 scm_t_inum in
= SCM_I_INUM (n
);
4809 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4810 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4811 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4813 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4815 /* Since we emulate two's complement encoded numbers, this
4816 * special case requires us to produce a result that has
4817 * more bits than can be stored in a fixnum.
4819 SCM result
= scm_i_inum2big (in
);
4820 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4825 /* mask down to requisite bits */
4826 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4827 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4829 else if (SCM_BIGP (n
))
4834 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4838 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4839 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4840 such bits into a ulong. */
4841 result
= scm_i_mkbig ();
4842 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4843 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4844 result
= scm_i_normbig (result
);
4846 scm_remember_upto_here_1 (n
);
4850 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4855 static const char scm_logtab
[] = {
4856 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4859 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4861 "Return the number of bits in integer @var{n}. If integer is\n"
4862 "positive, the 1-bits in its binary representation are counted.\n"
4863 "If negative, the 0-bits in its two's-complement binary\n"
4864 "representation are counted. If 0, 0 is returned.\n"
4867 "(logcount #b10101010)\n"
4874 #define FUNC_NAME s_scm_logcount
4876 if (SCM_I_INUMP (n
))
4878 unsigned long c
= 0;
4879 scm_t_inum nn
= SCM_I_INUM (n
);
4884 c
+= scm_logtab
[15 & nn
];
4887 return SCM_I_MAKINUM (c
);
4889 else if (SCM_BIGP (n
))
4891 unsigned long count
;
4892 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4893 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4895 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4896 scm_remember_upto_here_1 (n
);
4897 return SCM_I_MAKINUM (count
);
4900 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4905 static const char scm_ilentab
[] = {
4906 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4910 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4912 "Return the number of bits necessary to represent @var{n}.\n"
4915 "(integer-length #b10101010)\n"
4917 "(integer-length 0)\n"
4919 "(integer-length #b1111)\n"
4922 #define FUNC_NAME s_scm_integer_length
4924 if (SCM_I_INUMP (n
))
4926 unsigned long c
= 0;
4928 scm_t_inum nn
= SCM_I_INUM (n
);
4934 l
= scm_ilentab
[15 & nn
];
4937 return SCM_I_MAKINUM (c
- 4 + l
);
4939 else if (SCM_BIGP (n
))
4941 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4942 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4943 1 too big, so check for that and adjust. */
4944 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4945 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4946 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4947 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4949 scm_remember_upto_here_1 (n
);
4950 return SCM_I_MAKINUM (size
);
4953 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4957 /*** NUMBERS -> STRINGS ***/
4958 #define SCM_MAX_DBL_PREC 60
4959 #define SCM_MAX_DBL_RADIX 36
4961 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4962 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4963 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4966 void init_dblprec(int *prec
, int radix
) {
4967 /* determine floating point precision by adding successively
4968 smaller increments to 1.0 until it is considered == 1.0 */
4969 double f
= ((double)1.0)/radix
;
4970 double fsum
= 1.0 + f
;
4975 if (++(*prec
) > SCM_MAX_DBL_PREC
)
4987 void init_fx_radix(double *fx_list
, int radix
)
4989 /* initialize a per-radix list of tolerances. When added
4990 to a number < 1.0, we can determine if we should raund
4991 up and quit converting a number to a string. */
4995 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
4996 fx_list
[i
] = (fx_list
[i
-1] / radix
);
4999 /* use this array as a way to generate a single digit */
5000 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5003 idbl2str (double f
, char *a
, int radix
)
5005 int efmt
, dpt
, d
, i
, wp
;
5007 #ifdef DBL_MIN_10_EXP
5010 #endif /* DBL_MIN_10_EXP */
5015 radix
> SCM_MAX_DBL_RADIX
)
5017 /* revert to existing behavior */
5021 wp
= scm_dblprec
[radix
-2];
5022 fx
= fx_per_radix
[radix
-2];
5026 #ifdef HAVE_COPYSIGN
5027 double sgn
= copysign (1.0, f
);
5032 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5038 strcpy (a
, "-inf.0");
5040 strcpy (a
, "+inf.0");
5045 strcpy (a
, "+nan.0");
5055 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5056 make-uniform-vector, from causing infinite loops. */
5057 /* just do the checking...if it passes, we do the conversion for our
5058 radix again below */
5065 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5073 while (f_cpy
> 10.0)
5076 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5097 if (f
+ fx
[wp
] >= radix
)
5104 /* adding 9999 makes this equivalent to abs(x) % 3 */
5105 dpt
= (exp
+ 9999) % 3;
5109 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5131 a
[ch
++] = number_chars
[d
];
5134 if (f
+ fx
[wp
] >= 1.0)
5136 a
[ch
- 1] = number_chars
[d
+1];
5148 if ((dpt
> 4) && (exp
> 6))
5150 d
= (a
[0] == '-' ? 2 : 1);
5151 for (i
= ch
++; i
> d
; i
--)
5164 if (a
[ch
- 1] == '.')
5165 a
[ch
++] = '0'; /* trailing zero */
5174 for (i
= radix
; i
<= exp
; i
*= radix
);
5175 for (i
/= radix
; i
; i
/= radix
)
5177 a
[ch
++] = number_chars
[exp
/ i
];
5186 icmplx2str (double real
, double imag
, char *str
, int radix
)
5191 i
= idbl2str (real
, str
, radix
);
5192 #ifdef HAVE_COPYSIGN
5193 sgn
= copysign (1.0, imag
);
5197 /* Don't output a '+' for negative numbers or for Inf and
5198 NaN. They will provide their own sign. */
5199 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5201 i
+= idbl2str (imag
, &str
[i
], radix
);
5207 iflo2str (SCM flt
, char *str
, int radix
)
5210 if (SCM_REALP (flt
))
5211 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5213 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5218 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5219 characters in the result.
5221 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5223 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5228 return scm_iuint2str (-num
, rad
, p
) + 1;
5231 return scm_iuint2str (num
, rad
, p
);
5234 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5235 characters in the result.
5237 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5239 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5243 scm_t_uintmax n
= num
;
5245 if (rad
< 2 || rad
> 36)
5246 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5248 for (n
/= rad
; n
> 0; n
/= rad
)
5258 p
[i
] = number_chars
[d
];
5263 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5265 "Return a string holding the external representation of the\n"
5266 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5267 "inexact, a radix of 10 will be used.")
5268 #define FUNC_NAME s_scm_number_to_string
5272 if (SCM_UNBNDP (radix
))
5275 base
= scm_to_signed_integer (radix
, 2, 36);
5277 if (SCM_I_INUMP (n
))
5279 char num_buf
[SCM_INTBUFLEN
];
5280 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5281 return scm_from_locale_stringn (num_buf
, length
);
5283 else if (SCM_BIGP (n
))
5285 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5286 scm_remember_upto_here_1 (n
);
5287 return scm_take_locale_string (str
);
5289 else if (SCM_FRACTIONP (n
))
5291 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5292 scm_from_locale_string ("/"),
5293 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5295 else if (SCM_INEXACTP (n
))
5297 char num_buf
[FLOBUFLEN
];
5298 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5301 SCM_WRONG_TYPE_ARG (1, n
);
5306 /* These print routines used to be stubbed here so that scm_repl.c
5307 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5310 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5312 char num_buf
[FLOBUFLEN
];
5313 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5318 scm_i_print_double (double val
, SCM port
)
5320 char num_buf
[FLOBUFLEN
];
5321 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5325 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5328 char num_buf
[FLOBUFLEN
];
5329 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5334 scm_i_print_complex (double real
, double imag
, SCM port
)
5336 char num_buf
[FLOBUFLEN
];
5337 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5341 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5344 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5345 scm_display (str
, port
);
5346 scm_remember_upto_here_1 (str
);
5351 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5353 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5354 scm_remember_upto_here_1 (exp
);
5355 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5359 /*** END nums->strs ***/
5362 /*** STRINGS -> NUMBERS ***/
5364 /* The following functions implement the conversion from strings to numbers.
5365 * The implementation somehow follows the grammar for numbers as it is given
5366 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5367 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5368 * points should be noted about the implementation:
5370 * * Each function keeps a local index variable 'idx' that points at the
5371 * current position within the parsed string. The global index is only
5372 * updated if the function could parse the corresponding syntactic unit
5375 * * Similarly, the functions keep track of indicators of inexactness ('#',
5376 * '.' or exponents) using local variables ('hash_seen', 'x').
5378 * * Sequences of digits are parsed into temporary variables holding fixnums.
5379 * Only if these fixnums would overflow, the result variables are updated
5380 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5381 * the temporary variables holding the fixnums are cleared, and the process
5382 * starts over again. If for example fixnums were able to store five decimal
5383 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5384 * and the result was computed as 12345 * 100000 + 67890. In other words,
5385 * only every five digits two bignum operations were performed.
5387 * Notes on the handling of exactness specifiers:
5389 * When parsing non-real complex numbers, we apply exactness specifiers on
5390 * per-component basis, as is done in PLT Scheme. For complex numbers
5391 * written in rectangular form, exactness specifiers are applied to the
5392 * real and imaginary parts before calling scm_make_rectangular. For
5393 * complex numbers written in polar form, exactness specifiers are applied
5394 * to the magnitude and angle before calling scm_make_polar.
5396 * There are two kinds of exactness specifiers: forced and implicit. A
5397 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5398 * the entire number, and applies to both components of a complex number.
5399 * "#e" causes each component to be made exact, and "#i" causes each
5400 * component to be made inexact. If no forced exactness specifier is
5401 * present, then the exactness of each component is determined
5402 * independently by the presence or absence of a decimal point or hash mark
5403 * within that component. If a decimal point or hash mark is present, the
5404 * component is made inexact, otherwise it is made exact.
5406 * After the exactness specifiers have been applied to each component, they
5407 * are passed to either scm_make_rectangular or scm_make_polar to produce
5408 * the final result. Note that this will result in a real number if the
5409 * imaginary part, magnitude, or angle is an exact 0.
5411 * For example, (string->number "#i5.0+0i") does the equivalent of:
5413 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5416 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5418 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5420 /* Caller is responsible for checking that the return value is in range
5421 for the given radix, which should be <= 36. */
5423 char_decimal_value (scm_t_uint32 c
)
5425 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5426 that's certainly above any valid decimal, so we take advantage of
5427 that to elide some tests. */
5428 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5430 /* If that failed, try extended hexadecimals, then. Only accept ascii
5435 if (c
>= (scm_t_uint32
) 'a')
5436 d
= c
- (scm_t_uint32
)'a' + 10U;
5442 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5443 unsigned int radix
, enum t_exactness
*p_exactness
)
5445 unsigned int idx
= *p_idx
;
5446 unsigned int hash_seen
= 0;
5447 scm_t_bits shift
= 1;
5449 unsigned int digit_value
;
5452 size_t len
= scm_i_string_length (mem
);
5457 c
= scm_i_string_ref (mem
, idx
);
5458 digit_value
= char_decimal_value (c
);
5459 if (digit_value
>= radix
)
5463 result
= SCM_I_MAKINUM (digit_value
);
5466 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5476 digit_value
= char_decimal_value (c
);
5477 /* This check catches non-decimals in addition to out-of-range
5479 if (digit_value
>= radix
)
5484 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5486 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5488 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5495 shift
= shift
* radix
;
5496 add
= add
* radix
+ digit_value
;
5501 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5503 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5507 *p_exactness
= INEXACT
;
5513 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5514 * covers the parts of the rules that start at a potential point. The value
5515 * of the digits up to the point have been parsed by the caller and are given
5516 * in variable result. The content of *p_exactness indicates, whether a hash
5517 * has already been seen in the digits before the point.
5520 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5523 mem2decimal_from_point (SCM result
, SCM mem
,
5524 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5526 unsigned int idx
= *p_idx
;
5527 enum t_exactness x
= *p_exactness
;
5528 size_t len
= scm_i_string_length (mem
);
5533 if (scm_i_string_ref (mem
, idx
) == '.')
5535 scm_t_bits shift
= 1;
5537 unsigned int digit_value
;
5538 SCM big_shift
= SCM_INUM1
;
5543 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5544 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5549 digit_value
= DIGIT2UINT (c
);
5560 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5562 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5563 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5565 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5573 add
= add
* 10 + digit_value
;
5579 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5580 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5581 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5584 result
= scm_divide (result
, big_shift
);
5586 /* We've seen a decimal point, thus the value is implicitly inexact. */
5598 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5600 switch (scm_i_string_ref (mem
, idx
))
5612 c
= scm_i_string_ref (mem
, idx
);
5620 c
= scm_i_string_ref (mem
, idx
);
5629 c
= scm_i_string_ref (mem
, idx
);
5634 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5638 exponent
= DIGIT2UINT (c
);
5641 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5642 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5645 if (exponent
<= SCM_MAXEXP
)
5646 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5652 if (exponent
> SCM_MAXEXP
)
5654 size_t exp_len
= idx
- start
;
5655 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5656 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5657 scm_out_of_range ("string->number", exp_num
);
5660 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5662 result
= scm_product (result
, e
);
5664 result
= scm_divide2real (result
, e
);
5666 /* We've seen an exponent, thus the value is implicitly inexact. */
5684 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5687 mem2ureal (SCM mem
, unsigned int *p_idx
,
5688 unsigned int radix
, enum t_exactness forced_x
)
5690 unsigned int idx
= *p_idx
;
5692 size_t len
= scm_i_string_length (mem
);
5694 /* Start off believing that the number will be exact. This changes
5695 to INEXACT if we see a decimal point or a hash. */
5696 enum t_exactness implicit_x
= EXACT
;
5701 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5707 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5709 /* Cobble up the fractional part. We might want to set the
5710 NaN's mantissa from it. */
5712 mem2uinteger (mem
, &idx
, 10, &implicit_x
);
5717 if (scm_i_string_ref (mem
, idx
) == '.')
5721 else if (idx
+ 1 == len
)
5723 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5726 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5727 p_idx
, &implicit_x
);
5733 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5734 if (scm_is_false (uinteger
))
5739 else if (scm_i_string_ref (mem
, idx
) == '/')
5747 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5748 if (scm_is_false (divisor
))
5751 /* both are int/big here, I assume */
5752 result
= scm_i_make_ratio (uinteger
, divisor
);
5754 else if (radix
== 10)
5756 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5757 if (scm_is_false (result
))
5769 if (SCM_INEXACTP (result
))
5770 return scm_inexact_to_exact (result
);
5774 if (SCM_INEXACTP (result
))
5777 return scm_exact_to_inexact (result
);
5779 if (implicit_x
== INEXACT
)
5781 if (SCM_INEXACTP (result
))
5784 return scm_exact_to_inexact (result
);
5790 /* We should never get here */
5791 scm_syserror ("mem2ureal");
5795 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5798 mem2complex (SCM mem
, unsigned int idx
,
5799 unsigned int radix
, enum t_exactness forced_x
)
5804 size_t len
= scm_i_string_length (mem
);
5809 c
= scm_i_string_ref (mem
, idx
);
5824 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5825 if (scm_is_false (ureal
))
5827 /* input must be either +i or -i */
5832 if (scm_i_string_ref (mem
, idx
) == 'i'
5833 || scm_i_string_ref (mem
, idx
) == 'I')
5839 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5846 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5847 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5852 c
= scm_i_string_ref (mem
, idx
);
5856 /* either +<ureal>i or -<ureal>i */
5863 return scm_make_rectangular (SCM_INUM0
, ureal
);
5866 /* polar input: <real>@<real>. */
5877 c
= scm_i_string_ref (mem
, idx
);
5895 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5896 if (scm_is_false (angle
))
5901 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5902 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5904 result
= scm_make_polar (ureal
, angle
);
5909 /* expecting input matching <real>[+-]<ureal>?i */
5916 int sign
= (c
== '+') ? 1 : -1;
5917 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5919 if (scm_is_false (imag
))
5920 imag
= SCM_I_MAKINUM (sign
);
5921 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5922 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5926 if (scm_i_string_ref (mem
, idx
) != 'i'
5927 && scm_i_string_ref (mem
, idx
) != 'I')
5934 return scm_make_rectangular (ureal
, imag
);
5943 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5945 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5948 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5950 unsigned int idx
= 0;
5951 unsigned int radix
= NO_RADIX
;
5952 enum t_exactness forced_x
= NO_EXACTNESS
;
5953 size_t len
= scm_i_string_length (mem
);
5955 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5956 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5958 switch (scm_i_string_ref (mem
, idx
+ 1))
5961 if (radix
!= NO_RADIX
)
5966 if (radix
!= NO_RADIX
)
5971 if (forced_x
!= NO_EXACTNESS
)
5976 if (forced_x
!= NO_EXACTNESS
)
5981 if (radix
!= NO_RADIX
)
5986 if (radix
!= NO_RADIX
)
5996 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5997 if (radix
== NO_RADIX
)
5998 radix
= default_radix
;
6000 return mem2complex (mem
, idx
, radix
, forced_x
);
6004 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6005 unsigned int default_radix
)
6007 SCM str
= scm_from_locale_stringn (mem
, len
);
6009 return scm_i_string_to_number (str
, default_radix
);
6013 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6014 (SCM string
, SCM radix
),
6015 "Return a number of the maximally precise representation\n"
6016 "expressed by the given @var{string}. @var{radix} must be an\n"
6017 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6018 "is a default radix that may be overridden by an explicit radix\n"
6019 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6020 "supplied, then the default radix is 10. If string is not a\n"
6021 "syntactically valid notation for a number, then\n"
6022 "@code{string->number} returns @code{#f}.")
6023 #define FUNC_NAME s_scm_string_to_number
6027 SCM_VALIDATE_STRING (1, string
);
6029 if (SCM_UNBNDP (radix
))
6032 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6034 answer
= scm_i_string_to_number (string
, base
);
6035 scm_remember_upto_here_1 (string
);
6041 /*** END strs->nums ***/
6044 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6046 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6048 #define FUNC_NAME s_scm_number_p
6050 return scm_from_bool (SCM_NUMBERP (x
));
6054 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6056 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6057 "otherwise. Note that the sets of real, rational and integer\n"
6058 "values form subsets of the set of complex numbers, i. e. the\n"
6059 "predicate will also be fulfilled if @var{x} is a real,\n"
6060 "rational or integer number.")
6061 #define FUNC_NAME s_scm_complex_p
6063 /* all numbers are complex. */
6064 return scm_number_p (x
);
6068 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6070 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6071 "otherwise. Note that the set of integer values forms a subset of\n"
6072 "the set of real numbers, i. e. the predicate will also be\n"
6073 "fulfilled if @var{x} is an integer number.")
6074 #define FUNC_NAME s_scm_real_p
6076 return scm_from_bool
6077 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6081 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6083 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6084 "otherwise. Note that the set of integer values forms a subset of\n"
6085 "the set of rational numbers, i. e. the predicate will also be\n"
6086 "fulfilled if @var{x} is an integer number.")
6087 #define FUNC_NAME s_scm_rational_p
6089 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6091 else if (SCM_REALP (x
))
6092 /* due to their limited precision, finite floating point numbers are
6093 rational as well. (finite means neither infinity nor a NaN) */
6094 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6100 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6102 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6104 #define FUNC_NAME s_scm_integer_p
6106 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6108 else if (SCM_REALP (x
))
6110 double val
= SCM_REAL_VALUE (x
);
6111 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6119 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6120 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6121 (SCM x
, SCM y
, SCM rest
),
6122 "Return @code{#t} if all parameters are numerically equal.")
6123 #define FUNC_NAME s_scm_i_num_eq_p
6125 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6127 while (!scm_is_null (rest
))
6129 if (scm_is_false (scm_num_eq_p (x
, y
)))
6133 rest
= scm_cdr (rest
);
6135 return scm_num_eq_p (x
, y
);
6139 scm_num_eq_p (SCM x
, SCM y
)
6142 if (SCM_I_INUMP (x
))
6144 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6145 if (SCM_I_INUMP (y
))
6147 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6148 return scm_from_bool (xx
== yy
);
6150 else if (SCM_BIGP (y
))
6152 else if (SCM_REALP (y
))
6154 /* On a 32-bit system an inum fits a double, we can cast the inum
6155 to a double and compare.
6157 But on a 64-bit system an inum is bigger than a double and
6158 casting it to a double (call that dxx) will round. dxx is at
6159 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6160 an integer and fits a long. So we cast yy to a long and
6161 compare with plain xx.
6163 An alternative (for any size system actually) would be to check
6164 yy is an integer (with floor) and is in range of an inum
6165 (compare against appropriate powers of 2) then test
6166 xx==(scm_t_signed_bits)yy. It's just a matter of which
6167 casts/comparisons might be fastest or easiest for the cpu. */
6169 double yy
= SCM_REAL_VALUE (y
);
6170 return scm_from_bool ((double) xx
== yy
6171 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6172 || xx
== (scm_t_signed_bits
) yy
));
6174 else if (SCM_COMPLEXP (y
))
6175 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6176 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6177 else if (SCM_FRACTIONP (y
))
6180 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6182 else if (SCM_BIGP (x
))
6184 if (SCM_I_INUMP (y
))
6186 else if (SCM_BIGP (y
))
6188 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6189 scm_remember_upto_here_2 (x
, y
);
6190 return scm_from_bool (0 == cmp
);
6192 else if (SCM_REALP (y
))
6195 if (isnan (SCM_REAL_VALUE (y
)))
6197 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6198 scm_remember_upto_here_1 (x
);
6199 return scm_from_bool (0 == cmp
);
6201 else if (SCM_COMPLEXP (y
))
6204 if (0.0 != SCM_COMPLEX_IMAG (y
))
6206 if (isnan (SCM_COMPLEX_REAL (y
)))
6208 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6209 scm_remember_upto_here_1 (x
);
6210 return scm_from_bool (0 == cmp
);
6212 else if (SCM_FRACTIONP (y
))
6215 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6217 else if (SCM_REALP (x
))
6219 double xx
= SCM_REAL_VALUE (x
);
6220 if (SCM_I_INUMP (y
))
6222 /* see comments with inum/real above */
6223 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6224 return scm_from_bool (xx
== (double) yy
6225 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6226 || (scm_t_signed_bits
) xx
== yy
));
6228 else if (SCM_BIGP (y
))
6231 if (isnan (SCM_REAL_VALUE (x
)))
6233 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6234 scm_remember_upto_here_1 (y
);
6235 return scm_from_bool (0 == cmp
);
6237 else if (SCM_REALP (y
))
6238 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6239 else if (SCM_COMPLEXP (y
))
6240 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6241 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6242 else if (SCM_FRACTIONP (y
))
6244 double xx
= SCM_REAL_VALUE (x
);
6248 return scm_from_bool (xx
< 0.0);
6249 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6253 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6255 else if (SCM_COMPLEXP (x
))
6257 if (SCM_I_INUMP (y
))
6258 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6259 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6260 else if (SCM_BIGP (y
))
6263 if (0.0 != SCM_COMPLEX_IMAG (x
))
6265 if (isnan (SCM_COMPLEX_REAL (x
)))
6267 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6268 scm_remember_upto_here_1 (y
);
6269 return scm_from_bool (0 == cmp
);
6271 else if (SCM_REALP (y
))
6272 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6273 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6274 else if (SCM_COMPLEXP (y
))
6275 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6276 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6277 else if (SCM_FRACTIONP (y
))
6280 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6282 xx
= SCM_COMPLEX_REAL (x
);
6286 return scm_from_bool (xx
< 0.0);
6287 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6291 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6293 else if (SCM_FRACTIONP (x
))
6295 if (SCM_I_INUMP (y
))
6297 else if (SCM_BIGP (y
))
6299 else if (SCM_REALP (y
))
6301 double yy
= SCM_REAL_VALUE (y
);
6305 return scm_from_bool (0.0 < yy
);
6306 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6309 else if (SCM_COMPLEXP (y
))
6312 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6314 yy
= SCM_COMPLEX_REAL (y
);
6318 return scm_from_bool (0.0 < yy
);
6319 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6322 else if (SCM_FRACTIONP (y
))
6323 return scm_i_fraction_equalp (x
, y
);
6325 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6328 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6332 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6333 done are good for inums, but for bignums an answer can almost always be
6334 had by just examining a few high bits of the operands, as done by GMP in
6335 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6336 of the float exponent to take into account. */
6338 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6339 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6340 (SCM x
, SCM y
, SCM rest
),
6341 "Return @code{#t} if the list of parameters is monotonically\n"
6343 #define FUNC_NAME s_scm_i_num_less_p
6345 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6347 while (!scm_is_null (rest
))
6349 if (scm_is_false (scm_less_p (x
, y
)))
6353 rest
= scm_cdr (rest
);
6355 return scm_less_p (x
, y
);
6359 scm_less_p (SCM x
, SCM y
)
6362 if (SCM_I_INUMP (x
))
6364 scm_t_inum xx
= SCM_I_INUM (x
);
6365 if (SCM_I_INUMP (y
))
6367 scm_t_inum yy
= SCM_I_INUM (y
);
6368 return scm_from_bool (xx
< yy
);
6370 else if (SCM_BIGP (y
))
6372 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6373 scm_remember_upto_here_1 (y
);
6374 return scm_from_bool (sgn
> 0);
6376 else if (SCM_REALP (y
))
6377 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6378 else if (SCM_FRACTIONP (y
))
6380 /* "x < a/b" becomes "x*b < a" */
6382 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6383 y
= SCM_FRACTION_NUMERATOR (y
);
6387 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6389 else if (SCM_BIGP (x
))
6391 if (SCM_I_INUMP (y
))
6393 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6394 scm_remember_upto_here_1 (x
);
6395 return scm_from_bool (sgn
< 0);
6397 else if (SCM_BIGP (y
))
6399 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6400 scm_remember_upto_here_2 (x
, y
);
6401 return scm_from_bool (cmp
< 0);
6403 else if (SCM_REALP (y
))
6406 if (isnan (SCM_REAL_VALUE (y
)))
6408 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6409 scm_remember_upto_here_1 (x
);
6410 return scm_from_bool (cmp
< 0);
6412 else if (SCM_FRACTIONP (y
))
6415 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6417 else if (SCM_REALP (x
))
6419 if (SCM_I_INUMP (y
))
6420 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6421 else if (SCM_BIGP (y
))
6424 if (isnan (SCM_REAL_VALUE (x
)))
6426 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6427 scm_remember_upto_here_1 (y
);
6428 return scm_from_bool (cmp
> 0);
6430 else if (SCM_REALP (y
))
6431 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6432 else if (SCM_FRACTIONP (y
))
6434 double xx
= SCM_REAL_VALUE (x
);
6438 return scm_from_bool (xx
< 0.0);
6439 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6443 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6445 else if (SCM_FRACTIONP (x
))
6447 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6449 /* "a/b < y" becomes "a < y*b" */
6450 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6451 x
= SCM_FRACTION_NUMERATOR (x
);
6454 else if (SCM_REALP (y
))
6456 double yy
= SCM_REAL_VALUE (y
);
6460 return scm_from_bool (0.0 < yy
);
6461 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6464 else if (SCM_FRACTIONP (y
))
6466 /* "a/b < c/d" becomes "a*d < c*b" */
6467 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6468 SCM_FRACTION_DENOMINATOR (y
));
6469 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6470 SCM_FRACTION_DENOMINATOR (x
));
6476 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6479 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6483 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6484 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6485 (SCM x
, SCM y
, SCM rest
),
6486 "Return @code{#t} if the list of parameters is monotonically\n"
6488 #define FUNC_NAME s_scm_i_num_gr_p
6490 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6492 while (!scm_is_null (rest
))
6494 if (scm_is_false (scm_gr_p (x
, y
)))
6498 rest
= scm_cdr (rest
);
6500 return scm_gr_p (x
, y
);
6503 #define FUNC_NAME s_scm_i_num_gr_p
6505 scm_gr_p (SCM x
, SCM y
)
6507 if (!SCM_NUMBERP (x
))
6508 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6509 else if (!SCM_NUMBERP (y
))
6510 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6512 return scm_less_p (y
, x
);
6517 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6518 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6519 (SCM x
, SCM y
, SCM rest
),
6520 "Return @code{#t} if the list of parameters is monotonically\n"
6522 #define FUNC_NAME s_scm_i_num_leq_p
6524 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6526 while (!scm_is_null (rest
))
6528 if (scm_is_false (scm_leq_p (x
, y
)))
6532 rest
= scm_cdr (rest
);
6534 return scm_leq_p (x
, y
);
6537 #define FUNC_NAME s_scm_i_num_leq_p
6539 scm_leq_p (SCM x
, SCM y
)
6541 if (!SCM_NUMBERP (x
))
6542 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6543 else if (!SCM_NUMBERP (y
))
6544 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6545 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6548 return scm_not (scm_less_p (y
, x
));
6553 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6554 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6555 (SCM x
, SCM y
, SCM rest
),
6556 "Return @code{#t} if the list of parameters is monotonically\n"
6558 #define FUNC_NAME s_scm_i_num_geq_p
6560 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6562 while (!scm_is_null (rest
))
6564 if (scm_is_false (scm_geq_p (x
, y
)))
6568 rest
= scm_cdr (rest
);
6570 return scm_geq_p (x
, y
);
6573 #define FUNC_NAME s_scm_i_num_geq_p
6575 scm_geq_p (SCM x
, SCM y
)
6577 if (!SCM_NUMBERP (x
))
6578 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6579 else if (!SCM_NUMBERP (y
))
6580 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6581 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6584 return scm_not (scm_less_p (x
, y
));
6589 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6591 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6593 #define FUNC_NAME s_scm_zero_p
6595 if (SCM_I_INUMP (z
))
6596 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6597 else if (SCM_BIGP (z
))
6599 else if (SCM_REALP (z
))
6600 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6601 else if (SCM_COMPLEXP (z
))
6602 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6603 && SCM_COMPLEX_IMAG (z
) == 0.0);
6604 else if (SCM_FRACTIONP (z
))
6607 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6612 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6614 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6616 #define FUNC_NAME s_scm_positive_p
6618 if (SCM_I_INUMP (x
))
6619 return scm_from_bool (SCM_I_INUM (x
) > 0);
6620 else if (SCM_BIGP (x
))
6622 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6623 scm_remember_upto_here_1 (x
);
6624 return scm_from_bool (sgn
> 0);
6626 else if (SCM_REALP (x
))
6627 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6628 else if (SCM_FRACTIONP (x
))
6629 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6631 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6636 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6638 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6640 #define FUNC_NAME s_scm_negative_p
6642 if (SCM_I_INUMP (x
))
6643 return scm_from_bool (SCM_I_INUM (x
) < 0);
6644 else if (SCM_BIGP (x
))
6646 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6647 scm_remember_upto_here_1 (x
);
6648 return scm_from_bool (sgn
< 0);
6650 else if (SCM_REALP (x
))
6651 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6652 else if (SCM_FRACTIONP (x
))
6653 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6655 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6660 /* scm_min and scm_max return an inexact when either argument is inexact, as
6661 required by r5rs. On that basis, for exact/inexact combinations the
6662 exact is converted to inexact to compare and possibly return. This is
6663 unlike scm_less_p above which takes some trouble to preserve all bits in
6664 its test, such trouble is not required for min and max. */
6666 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6667 (SCM x
, SCM y
, SCM rest
),
6668 "Return the maximum of all parameter values.")
6669 #define FUNC_NAME s_scm_i_max
6671 while (!scm_is_null (rest
))
6672 { x
= scm_max (x
, y
);
6674 rest
= scm_cdr (rest
);
6676 return scm_max (x
, y
);
6680 #define s_max s_scm_i_max
6681 #define g_max g_scm_i_max
6684 scm_max (SCM x
, SCM y
)
6689 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6690 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6693 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6696 if (SCM_I_INUMP (x
))
6698 scm_t_inum xx
= SCM_I_INUM (x
);
6699 if (SCM_I_INUMP (y
))
6701 scm_t_inum yy
= SCM_I_INUM (y
);
6702 return (xx
< yy
) ? y
: x
;
6704 else if (SCM_BIGP (y
))
6706 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6707 scm_remember_upto_here_1 (y
);
6708 return (sgn
< 0) ? x
: y
;
6710 else if (SCM_REALP (y
))
6713 double yyd
= SCM_REAL_VALUE (y
);
6716 return scm_from_double (xxd
);
6717 /* If y is a NaN, then "==" is false and we return the NaN */
6718 else if (SCM_LIKELY (!(xxd
== yyd
)))
6720 /* Handle signed zeroes properly */
6726 else if (SCM_FRACTIONP (y
))
6729 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6732 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6734 else if (SCM_BIGP (x
))
6736 if (SCM_I_INUMP (y
))
6738 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6739 scm_remember_upto_here_1 (x
);
6740 return (sgn
< 0) ? y
: x
;
6742 else if (SCM_BIGP (y
))
6744 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6745 scm_remember_upto_here_2 (x
, y
);
6746 return (cmp
> 0) ? x
: y
;
6748 else if (SCM_REALP (y
))
6750 /* if y==NaN then xx>yy is false, so we return the NaN y */
6753 xx
= scm_i_big2dbl (x
);
6754 yy
= SCM_REAL_VALUE (y
);
6755 return (xx
> yy
? scm_from_double (xx
) : y
);
6757 else if (SCM_FRACTIONP (y
))
6762 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6764 else if (SCM_REALP (x
))
6766 if (SCM_I_INUMP (y
))
6768 scm_t_inum yy
= SCM_I_INUM (y
);
6769 double xxd
= SCM_REAL_VALUE (x
);
6773 return scm_from_double (yyd
);
6774 /* If x is a NaN, then "==" is false and we return the NaN */
6775 else if (SCM_LIKELY (!(xxd
== yyd
)))
6777 /* Handle signed zeroes properly */
6783 else if (SCM_BIGP (y
))
6788 else if (SCM_REALP (y
))
6790 double xx
= SCM_REAL_VALUE (x
);
6791 double yy
= SCM_REAL_VALUE (y
);
6793 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6796 else if (SCM_LIKELY (xx
< yy
))
6798 /* If neither (xx > yy) nor (xx < yy), then
6799 either they're equal or one is a NaN */
6800 else if (SCM_UNLIKELY (isnan (xx
)))
6801 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6802 else if (SCM_UNLIKELY (isnan (yy
)))
6803 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6804 /* xx == yy, but handle signed zeroes properly */
6805 else if (double_is_non_negative_zero (yy
))
6810 else if (SCM_FRACTIONP (y
))
6812 double yy
= scm_i_fraction2double (y
);
6813 double xx
= SCM_REAL_VALUE (x
);
6814 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6817 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6819 else if (SCM_FRACTIONP (x
))
6821 if (SCM_I_INUMP (y
))
6825 else if (SCM_BIGP (y
))
6829 else if (SCM_REALP (y
))
6831 double xx
= scm_i_fraction2double (x
);
6832 /* if y==NaN then ">" is false, so we return the NaN y */
6833 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6835 else if (SCM_FRACTIONP (y
))
6840 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6843 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6847 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6848 (SCM x
, SCM y
, SCM rest
),
6849 "Return the minimum of all parameter values.")
6850 #define FUNC_NAME s_scm_i_min
6852 while (!scm_is_null (rest
))
6853 { x
= scm_min (x
, y
);
6855 rest
= scm_cdr (rest
);
6857 return scm_min (x
, y
);
6861 #define s_min s_scm_i_min
6862 #define g_min g_scm_i_min
6865 scm_min (SCM x
, SCM y
)
6870 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6871 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6874 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6877 if (SCM_I_INUMP (x
))
6879 scm_t_inum xx
= SCM_I_INUM (x
);
6880 if (SCM_I_INUMP (y
))
6882 scm_t_inum yy
= SCM_I_INUM (y
);
6883 return (xx
< yy
) ? x
: y
;
6885 else if (SCM_BIGP (y
))
6887 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6888 scm_remember_upto_here_1 (y
);
6889 return (sgn
< 0) ? y
: x
;
6891 else if (SCM_REALP (y
))
6894 /* if y==NaN then "<" is false and we return NaN */
6895 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6897 else if (SCM_FRACTIONP (y
))
6900 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6903 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6905 else if (SCM_BIGP (x
))
6907 if (SCM_I_INUMP (y
))
6909 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6910 scm_remember_upto_here_1 (x
);
6911 return (sgn
< 0) ? x
: y
;
6913 else if (SCM_BIGP (y
))
6915 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6916 scm_remember_upto_here_2 (x
, y
);
6917 return (cmp
> 0) ? y
: x
;
6919 else if (SCM_REALP (y
))
6921 /* if y==NaN then xx<yy is false, so we return the NaN y */
6924 xx
= scm_i_big2dbl (x
);
6925 yy
= SCM_REAL_VALUE (y
);
6926 return (xx
< yy
? scm_from_double (xx
) : y
);
6928 else if (SCM_FRACTIONP (y
))
6933 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6935 else if (SCM_REALP (x
))
6937 if (SCM_I_INUMP (y
))
6939 double z
= SCM_I_INUM (y
);
6940 /* if x==NaN then "<" is false and we return NaN */
6941 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6943 else if (SCM_BIGP (y
))
6948 else if (SCM_REALP (y
))
6950 double xx
= SCM_REAL_VALUE (x
);
6951 double yy
= SCM_REAL_VALUE (y
);
6953 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6956 else if (SCM_LIKELY (xx
> yy
))
6958 /* If neither (xx < yy) nor (xx > yy), then
6959 either they're equal or one is a NaN */
6960 else if (SCM_UNLIKELY (isnan (xx
)))
6961 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6962 else if (SCM_UNLIKELY (isnan (yy
)))
6963 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6964 /* xx == yy, but handle signed zeroes properly */
6965 else if (double_is_non_negative_zero (xx
))
6970 else if (SCM_FRACTIONP (y
))
6972 double yy
= scm_i_fraction2double (y
);
6973 double xx
= SCM_REAL_VALUE (x
);
6974 return (yy
< xx
) ? scm_from_double (yy
) : x
;
6977 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6979 else if (SCM_FRACTIONP (x
))
6981 if (SCM_I_INUMP (y
))
6985 else if (SCM_BIGP (y
))
6989 else if (SCM_REALP (y
))
6991 double xx
= scm_i_fraction2double (x
);
6992 /* if y==NaN then "<" is false, so we return the NaN y */
6993 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6995 else if (SCM_FRACTIONP (y
))
7000 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7003 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7007 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7008 (SCM x
, SCM y
, SCM rest
),
7009 "Return the sum of all parameter values. Return 0 if called without\n"
7011 #define FUNC_NAME s_scm_i_sum
7013 while (!scm_is_null (rest
))
7014 { x
= scm_sum (x
, y
);
7016 rest
= scm_cdr (rest
);
7018 return scm_sum (x
, y
);
7022 #define s_sum s_scm_i_sum
7023 #define g_sum g_scm_i_sum
7026 scm_sum (SCM x
, SCM y
)
7028 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7030 if (SCM_NUMBERP (x
)) return x
;
7031 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7032 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7035 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7037 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7039 scm_t_inum xx
= SCM_I_INUM (x
);
7040 scm_t_inum yy
= SCM_I_INUM (y
);
7041 scm_t_inum z
= xx
+ yy
;
7042 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7044 else if (SCM_BIGP (y
))
7049 else if (SCM_REALP (y
))
7051 scm_t_inum xx
= SCM_I_INUM (x
);
7052 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7054 else if (SCM_COMPLEXP (y
))
7056 scm_t_inum xx
= SCM_I_INUM (x
);
7057 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7058 SCM_COMPLEX_IMAG (y
));
7060 else if (SCM_FRACTIONP (y
))
7061 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7062 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7063 SCM_FRACTION_DENOMINATOR (y
));
7065 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7066 } else if (SCM_BIGP (x
))
7068 if (SCM_I_INUMP (y
))
7073 inum
= SCM_I_INUM (y
);
7076 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7079 SCM result
= scm_i_mkbig ();
7080 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7081 scm_remember_upto_here_1 (x
);
7082 /* we know the result will have to be a bignum */
7085 return scm_i_normbig (result
);
7089 SCM result
= scm_i_mkbig ();
7090 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7091 scm_remember_upto_here_1 (x
);
7092 /* we know the result will have to be a bignum */
7095 return scm_i_normbig (result
);
7098 else if (SCM_BIGP (y
))
7100 SCM result
= scm_i_mkbig ();
7101 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7102 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7103 mpz_add (SCM_I_BIG_MPZ (result
),
7106 scm_remember_upto_here_2 (x
, y
);
7107 /* we know the result will have to be a bignum */
7110 return scm_i_normbig (result
);
7112 else if (SCM_REALP (y
))
7114 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7115 scm_remember_upto_here_1 (x
);
7116 return scm_from_double (result
);
7118 else if (SCM_COMPLEXP (y
))
7120 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7121 + SCM_COMPLEX_REAL (y
));
7122 scm_remember_upto_here_1 (x
);
7123 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7125 else if (SCM_FRACTIONP (y
))
7126 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7127 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7128 SCM_FRACTION_DENOMINATOR (y
));
7130 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7132 else if (SCM_REALP (x
))
7134 if (SCM_I_INUMP (y
))
7135 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7136 else if (SCM_BIGP (y
))
7138 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7139 scm_remember_upto_here_1 (y
);
7140 return scm_from_double (result
);
7142 else if (SCM_REALP (y
))
7143 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7144 else if (SCM_COMPLEXP (y
))
7145 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7146 SCM_COMPLEX_IMAG (y
));
7147 else if (SCM_FRACTIONP (y
))
7148 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7150 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7152 else if (SCM_COMPLEXP (x
))
7154 if (SCM_I_INUMP (y
))
7155 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7156 SCM_COMPLEX_IMAG (x
));
7157 else if (SCM_BIGP (y
))
7159 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7160 + SCM_COMPLEX_REAL (x
));
7161 scm_remember_upto_here_1 (y
);
7162 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7164 else if (SCM_REALP (y
))
7165 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7166 SCM_COMPLEX_IMAG (x
));
7167 else if (SCM_COMPLEXP (y
))
7168 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7169 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7170 else if (SCM_FRACTIONP (y
))
7171 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7172 SCM_COMPLEX_IMAG (x
));
7174 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7176 else if (SCM_FRACTIONP (x
))
7178 if (SCM_I_INUMP (y
))
7179 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7180 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7181 SCM_FRACTION_DENOMINATOR (x
));
7182 else if (SCM_BIGP (y
))
7183 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7184 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7185 SCM_FRACTION_DENOMINATOR (x
));
7186 else if (SCM_REALP (y
))
7187 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7188 else if (SCM_COMPLEXP (y
))
7189 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7190 SCM_COMPLEX_IMAG (y
));
7191 else if (SCM_FRACTIONP (y
))
7192 /* a/b + c/d = (ad + bc) / bd */
7193 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7194 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7195 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7197 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7200 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7204 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7206 "Return @math{@var{x}+1}.")
7207 #define FUNC_NAME s_scm_oneplus
7209 return scm_sum (x
, SCM_INUM1
);
7214 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7215 (SCM x
, SCM y
, SCM rest
),
7216 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7217 "the sum of all but the first argument are subtracted from the first\n"
7219 #define FUNC_NAME s_scm_i_difference
7221 while (!scm_is_null (rest
))
7222 { x
= scm_difference (x
, y
);
7224 rest
= scm_cdr (rest
);
7226 return scm_difference (x
, y
);
7230 #define s_difference s_scm_i_difference
7231 #define g_difference g_scm_i_difference
7234 scm_difference (SCM x
, SCM y
)
7235 #define FUNC_NAME s_difference
7237 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7240 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7242 if (SCM_I_INUMP (x
))
7244 scm_t_inum xx
= -SCM_I_INUM (x
);
7245 if (SCM_FIXABLE (xx
))
7246 return SCM_I_MAKINUM (xx
);
7248 return scm_i_inum2big (xx
);
7250 else if (SCM_BIGP (x
))
7251 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7252 bignum, but negating that gives a fixnum. */
7253 return scm_i_normbig (scm_i_clonebig (x
, 0));
7254 else if (SCM_REALP (x
))
7255 return scm_from_double (-SCM_REAL_VALUE (x
));
7256 else if (SCM_COMPLEXP (x
))
7257 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7258 -SCM_COMPLEX_IMAG (x
));
7259 else if (SCM_FRACTIONP (x
))
7260 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7261 SCM_FRACTION_DENOMINATOR (x
));
7263 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7266 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7268 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7270 scm_t_inum xx
= SCM_I_INUM (x
);
7271 scm_t_inum yy
= SCM_I_INUM (y
);
7272 scm_t_inum z
= xx
- yy
;
7273 if (SCM_FIXABLE (z
))
7274 return SCM_I_MAKINUM (z
);
7276 return scm_i_inum2big (z
);
7278 else if (SCM_BIGP (y
))
7280 /* inum-x - big-y */
7281 scm_t_inum xx
= SCM_I_INUM (x
);
7285 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7286 bignum, but negating that gives a fixnum. */
7287 return scm_i_normbig (scm_i_clonebig (y
, 0));
7291 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7292 SCM result
= scm_i_mkbig ();
7295 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7298 /* x - y == -(y + -x) */
7299 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7300 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7302 scm_remember_upto_here_1 (y
);
7304 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7305 /* we know the result will have to be a bignum */
7308 return scm_i_normbig (result
);
7311 else if (SCM_REALP (y
))
7313 scm_t_inum xx
= SCM_I_INUM (x
);
7316 * We need to handle x == exact 0
7317 * specially because R6RS states that:
7318 * (- 0.0) ==> -0.0 and
7319 * (- 0.0 0.0) ==> 0.0
7320 * and the scheme compiler changes
7321 * (- 0.0) into (- 0 0.0)
7322 * So we need to treat (- 0 0.0) like (- 0.0).
7323 * At the C level, (-x) is different than (0.0 - x).
7324 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7327 return scm_from_double (- SCM_REAL_VALUE (y
));
7329 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7331 else if (SCM_COMPLEXP (y
))
7333 scm_t_inum xx
= SCM_I_INUM (x
);
7335 /* We need to handle x == exact 0 specially.
7336 See the comment above (for SCM_REALP (y)) */
7338 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7339 - SCM_COMPLEX_IMAG (y
));
7341 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7342 - SCM_COMPLEX_IMAG (y
));
7344 else if (SCM_FRACTIONP (y
))
7345 /* a - b/c = (ac - b) / c */
7346 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7347 SCM_FRACTION_NUMERATOR (y
)),
7348 SCM_FRACTION_DENOMINATOR (y
));
7350 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7352 else if (SCM_BIGP (x
))
7354 if (SCM_I_INUMP (y
))
7356 /* big-x - inum-y */
7357 scm_t_inum yy
= SCM_I_INUM (y
);
7358 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7360 scm_remember_upto_here_1 (x
);
7362 return (SCM_FIXABLE (-yy
) ?
7363 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7366 SCM result
= scm_i_mkbig ();
7369 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7371 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7372 scm_remember_upto_here_1 (x
);
7374 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7375 /* we know the result will have to be a bignum */
7378 return scm_i_normbig (result
);
7381 else if (SCM_BIGP (y
))
7383 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7384 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7385 SCM result
= scm_i_mkbig ();
7386 mpz_sub (SCM_I_BIG_MPZ (result
),
7389 scm_remember_upto_here_2 (x
, y
);
7390 /* we know the result will have to be a bignum */
7391 if ((sgn_x
== 1) && (sgn_y
== -1))
7393 if ((sgn_x
== -1) && (sgn_y
== 1))
7395 return scm_i_normbig (result
);
7397 else if (SCM_REALP (y
))
7399 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7400 scm_remember_upto_here_1 (x
);
7401 return scm_from_double (result
);
7403 else if (SCM_COMPLEXP (y
))
7405 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7406 - SCM_COMPLEX_REAL (y
));
7407 scm_remember_upto_here_1 (x
);
7408 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7410 else if (SCM_FRACTIONP (y
))
7411 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7412 SCM_FRACTION_NUMERATOR (y
)),
7413 SCM_FRACTION_DENOMINATOR (y
));
7414 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7416 else if (SCM_REALP (x
))
7418 if (SCM_I_INUMP (y
))
7419 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7420 else if (SCM_BIGP (y
))
7422 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7423 scm_remember_upto_here_1 (x
);
7424 return scm_from_double (result
);
7426 else if (SCM_REALP (y
))
7427 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7428 else if (SCM_COMPLEXP (y
))
7429 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7430 -SCM_COMPLEX_IMAG (y
));
7431 else if (SCM_FRACTIONP (y
))
7432 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7434 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7436 else if (SCM_COMPLEXP (x
))
7438 if (SCM_I_INUMP (y
))
7439 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7440 SCM_COMPLEX_IMAG (x
));
7441 else if (SCM_BIGP (y
))
7443 double real_part
= (SCM_COMPLEX_REAL (x
)
7444 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7445 scm_remember_upto_here_1 (x
);
7446 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7448 else if (SCM_REALP (y
))
7449 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7450 SCM_COMPLEX_IMAG (x
));
7451 else if (SCM_COMPLEXP (y
))
7452 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7453 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7454 else if (SCM_FRACTIONP (y
))
7455 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7456 SCM_COMPLEX_IMAG (x
));
7458 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7460 else if (SCM_FRACTIONP (x
))
7462 if (SCM_I_INUMP (y
))
7463 /* a/b - c = (a - cb) / b */
7464 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7465 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7466 SCM_FRACTION_DENOMINATOR (x
));
7467 else if (SCM_BIGP (y
))
7468 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7469 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7470 SCM_FRACTION_DENOMINATOR (x
));
7471 else if (SCM_REALP (y
))
7472 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7473 else if (SCM_COMPLEXP (y
))
7474 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7475 -SCM_COMPLEX_IMAG (y
));
7476 else if (SCM_FRACTIONP (y
))
7477 /* a/b - c/d = (ad - bc) / bd */
7478 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7479 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7480 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7482 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7485 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7490 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7492 "Return @math{@var{x}-1}.")
7493 #define FUNC_NAME s_scm_oneminus
7495 return scm_difference (x
, SCM_INUM1
);
7500 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7501 (SCM x
, SCM y
, SCM rest
),
7502 "Return the product of all arguments. If called without arguments,\n"
7504 #define FUNC_NAME s_scm_i_product
7506 while (!scm_is_null (rest
))
7507 { x
= scm_product (x
, y
);
7509 rest
= scm_cdr (rest
);
7511 return scm_product (x
, y
);
7515 #define s_product s_scm_i_product
7516 #define g_product g_scm_i_product
7519 scm_product (SCM x
, SCM y
)
7521 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7524 return SCM_I_MAKINUM (1L);
7525 else if (SCM_NUMBERP (x
))
7528 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7531 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7536 xx
= SCM_I_INUM (x
);
7541 /* exact1 is the universal multiplicative identity */
7545 /* exact0 times a fixnum is exact0: optimize this case */
7546 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7548 /* if the other argument is inexact, the result is inexact,
7549 and we must do the multiplication in order to handle
7550 infinities and NaNs properly. */
7551 else if (SCM_REALP (y
))
7552 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7553 else if (SCM_COMPLEXP (y
))
7554 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7555 0.0 * SCM_COMPLEX_IMAG (y
));
7556 /* we've already handled inexact numbers,
7557 so y must be exact, and we return exact0 */
7558 else if (SCM_NUMP (y
))
7561 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7565 * This case is important for more than just optimization.
7566 * It handles the case of negating
7567 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7568 * which is a bignum that must be changed back into a fixnum.
7569 * Failure to do so will cause the following to return #f:
7570 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7572 return scm_difference(y
, SCM_UNDEFINED
);
7576 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7578 scm_t_inum yy
= SCM_I_INUM (y
);
7579 scm_t_inum kk
= xx
* yy
;
7580 SCM k
= SCM_I_MAKINUM (kk
);
7581 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7585 SCM result
= scm_i_inum2big (xx
);
7586 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7587 return scm_i_normbig (result
);
7590 else if (SCM_BIGP (y
))
7592 SCM result
= scm_i_mkbig ();
7593 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7594 scm_remember_upto_here_1 (y
);
7597 else if (SCM_REALP (y
))
7598 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7599 else if (SCM_COMPLEXP (y
))
7600 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7601 xx
* SCM_COMPLEX_IMAG (y
));
7602 else if (SCM_FRACTIONP (y
))
7603 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7604 SCM_FRACTION_DENOMINATOR (y
));
7606 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7608 else if (SCM_BIGP (x
))
7610 if (SCM_I_INUMP (y
))
7615 else if (SCM_BIGP (y
))
7617 SCM result
= scm_i_mkbig ();
7618 mpz_mul (SCM_I_BIG_MPZ (result
),
7621 scm_remember_upto_here_2 (x
, y
);
7624 else if (SCM_REALP (y
))
7626 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7627 scm_remember_upto_here_1 (x
);
7628 return scm_from_double (result
);
7630 else if (SCM_COMPLEXP (y
))
7632 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7633 scm_remember_upto_here_1 (x
);
7634 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7635 z
* SCM_COMPLEX_IMAG (y
));
7637 else if (SCM_FRACTIONP (y
))
7638 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7639 SCM_FRACTION_DENOMINATOR (y
));
7641 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7643 else if (SCM_REALP (x
))
7645 if (SCM_I_INUMP (y
))
7650 else if (SCM_BIGP (y
))
7652 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7653 scm_remember_upto_here_1 (y
);
7654 return scm_from_double (result
);
7656 else if (SCM_REALP (y
))
7657 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7658 else if (SCM_COMPLEXP (y
))
7659 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7660 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7661 else if (SCM_FRACTIONP (y
))
7662 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7664 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7666 else if (SCM_COMPLEXP (x
))
7668 if (SCM_I_INUMP (y
))
7673 else if (SCM_BIGP (y
))
7675 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7676 scm_remember_upto_here_1 (y
);
7677 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7678 z
* SCM_COMPLEX_IMAG (x
));
7680 else if (SCM_REALP (y
))
7681 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7682 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7683 else if (SCM_COMPLEXP (y
))
7685 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7686 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7687 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7688 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7690 else if (SCM_FRACTIONP (y
))
7692 double yy
= scm_i_fraction2double (y
);
7693 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7694 yy
* SCM_COMPLEX_IMAG (x
));
7697 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7699 else if (SCM_FRACTIONP (x
))
7701 if (SCM_I_INUMP (y
))
7702 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7703 SCM_FRACTION_DENOMINATOR (x
));
7704 else if (SCM_BIGP (y
))
7705 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7706 SCM_FRACTION_DENOMINATOR (x
));
7707 else if (SCM_REALP (y
))
7708 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7709 else if (SCM_COMPLEXP (y
))
7711 double xx
= scm_i_fraction2double (x
);
7712 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7713 xx
* SCM_COMPLEX_IMAG (y
));
7715 else if (SCM_FRACTIONP (y
))
7716 /* a/b * c/d = ac / bd */
7717 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7718 SCM_FRACTION_NUMERATOR (y
)),
7719 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7720 SCM_FRACTION_DENOMINATOR (y
)));
7722 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7725 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7728 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7729 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7730 #define ALLOW_DIVIDE_BY_ZERO
7731 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7734 /* The code below for complex division is adapted from the GNU
7735 libstdc++, which adapted it from f2c's libF77, and is subject to
7738 /****************************************************************
7739 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7741 Permission to use, copy, modify, and distribute this software
7742 and its documentation for any purpose and without fee is hereby
7743 granted, provided that the above copyright notice appear in all
7744 copies and that both that the copyright notice and this
7745 permission notice and warranty disclaimer appear in supporting
7746 documentation, and that the names of AT&T Bell Laboratories or
7747 Bellcore or any of their entities not be used in advertising or
7748 publicity pertaining to distribution of the software without
7749 specific, written prior permission.
7751 AT&T and Bellcore disclaim all warranties with regard to this
7752 software, including all implied warranties of merchantability
7753 and fitness. In no event shall AT&T or Bellcore be liable for
7754 any special, indirect or consequential damages or any damages
7755 whatsoever resulting from loss of use, data or profits, whether
7756 in an action of contract, negligence or other tortious action,
7757 arising out of or in connection with the use or performance of
7759 ****************************************************************/
7761 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7762 (SCM x
, SCM y
, SCM rest
),
7763 "Divide the first argument by the product of the remaining\n"
7764 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7766 #define FUNC_NAME s_scm_i_divide
7768 while (!scm_is_null (rest
))
7769 { x
= scm_divide (x
, y
);
7771 rest
= scm_cdr (rest
);
7773 return scm_divide (x
, y
);
7777 #define s_divide s_scm_i_divide
7778 #define g_divide g_scm_i_divide
7781 do_divide (SCM x
, SCM y
, int inexact
)
7782 #define FUNC_NAME s_divide
7786 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7789 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7790 else if (SCM_I_INUMP (x
))
7792 scm_t_inum xx
= SCM_I_INUM (x
);
7793 if (xx
== 1 || xx
== -1)
7795 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7797 scm_num_overflow (s_divide
);
7802 return scm_from_double (1.0 / (double) xx
);
7803 else return scm_i_make_ratio (SCM_INUM1
, x
);
7806 else if (SCM_BIGP (x
))
7809 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7810 else return scm_i_make_ratio (SCM_INUM1
, x
);
7812 else if (SCM_REALP (x
))
7814 double xx
= SCM_REAL_VALUE (x
);
7815 #ifndef ALLOW_DIVIDE_BY_ZERO
7817 scm_num_overflow (s_divide
);
7820 return scm_from_double (1.0 / xx
);
7822 else if (SCM_COMPLEXP (x
))
7824 double r
= SCM_COMPLEX_REAL (x
);
7825 double i
= SCM_COMPLEX_IMAG (x
);
7826 if (fabs(r
) <= fabs(i
))
7829 double d
= i
* (1.0 + t
* t
);
7830 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7835 double d
= r
* (1.0 + t
* t
);
7836 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7839 else if (SCM_FRACTIONP (x
))
7840 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7841 SCM_FRACTION_NUMERATOR (x
));
7843 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7846 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7848 scm_t_inum xx
= SCM_I_INUM (x
);
7849 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7851 scm_t_inum yy
= SCM_I_INUM (y
);
7854 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7855 scm_num_overflow (s_divide
);
7857 return scm_from_double ((double) xx
/ (double) yy
);
7860 else if (xx
% yy
!= 0)
7863 return scm_from_double ((double) xx
/ (double) yy
);
7864 else return scm_i_make_ratio (x
, y
);
7868 scm_t_inum z
= xx
/ yy
;
7869 if (SCM_FIXABLE (z
))
7870 return SCM_I_MAKINUM (z
);
7872 return scm_i_inum2big (z
);
7875 else if (SCM_BIGP (y
))
7878 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7879 else return scm_i_make_ratio (x
, y
);
7881 else if (SCM_REALP (y
))
7883 double yy
= SCM_REAL_VALUE (y
);
7884 #ifndef ALLOW_DIVIDE_BY_ZERO
7886 scm_num_overflow (s_divide
);
7889 return scm_from_double ((double) xx
/ yy
);
7891 else if (SCM_COMPLEXP (y
))
7894 complex_div
: /* y _must_ be a complex number */
7896 double r
= SCM_COMPLEX_REAL (y
);
7897 double i
= SCM_COMPLEX_IMAG (y
);
7898 if (fabs(r
) <= fabs(i
))
7901 double d
= i
* (1.0 + t
* t
);
7902 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7907 double d
= r
* (1.0 + t
* t
);
7908 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7912 else if (SCM_FRACTIONP (y
))
7913 /* a / b/c = ac / b */
7914 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7915 SCM_FRACTION_NUMERATOR (y
));
7917 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7919 else if (SCM_BIGP (x
))
7921 if (SCM_I_INUMP (y
))
7923 scm_t_inum yy
= SCM_I_INUM (y
);
7926 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7927 scm_num_overflow (s_divide
);
7929 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7930 scm_remember_upto_here_1 (x
);
7931 return (sgn
== 0) ? scm_nan () : scm_inf ();
7938 /* FIXME: HMM, what are the relative performance issues here?
7939 We need to test. Is it faster on average to test
7940 divisible_p, then perform whichever operation, or is it
7941 faster to perform the integer div opportunistically and
7942 switch to real if there's a remainder? For now we take the
7943 middle ground: test, then if divisible, use the faster div
7946 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7947 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7951 SCM result
= scm_i_mkbig ();
7952 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7953 scm_remember_upto_here_1 (x
);
7955 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7956 return scm_i_normbig (result
);
7961 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7962 else return scm_i_make_ratio (x
, y
);
7966 else if (SCM_BIGP (y
))
7971 /* It's easily possible for the ratio x/y to fit a double
7972 but one or both x and y be too big to fit a double,
7973 hence the use of mpq_get_d rather than converting and
7976 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
7977 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
7978 return scm_from_double (mpq_get_d (q
));
7982 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
7986 SCM result
= scm_i_mkbig ();
7987 mpz_divexact (SCM_I_BIG_MPZ (result
),
7990 scm_remember_upto_here_2 (x
, y
);
7991 return scm_i_normbig (result
);
7994 return scm_i_make_ratio (x
, y
);
7997 else if (SCM_REALP (y
))
7999 double yy
= SCM_REAL_VALUE (y
);
8000 #ifndef ALLOW_DIVIDE_BY_ZERO
8002 scm_num_overflow (s_divide
);
8005 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8007 else if (SCM_COMPLEXP (y
))
8009 a
= scm_i_big2dbl (x
);
8012 else if (SCM_FRACTIONP (y
))
8013 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8014 SCM_FRACTION_NUMERATOR (y
));
8016 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8018 else if (SCM_REALP (x
))
8020 double rx
= SCM_REAL_VALUE (x
);
8021 if (SCM_I_INUMP (y
))
8023 scm_t_inum yy
= SCM_I_INUM (y
);
8024 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8026 scm_num_overflow (s_divide
);
8029 return scm_from_double (rx
/ (double) yy
);
8031 else if (SCM_BIGP (y
))
8033 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8034 scm_remember_upto_here_1 (y
);
8035 return scm_from_double (rx
/ dby
);
8037 else if (SCM_REALP (y
))
8039 double yy
= SCM_REAL_VALUE (y
);
8040 #ifndef ALLOW_DIVIDE_BY_ZERO
8042 scm_num_overflow (s_divide
);
8045 return scm_from_double (rx
/ yy
);
8047 else if (SCM_COMPLEXP (y
))
8052 else if (SCM_FRACTIONP (y
))
8053 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8055 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8057 else if (SCM_COMPLEXP (x
))
8059 double rx
= SCM_COMPLEX_REAL (x
);
8060 double ix
= SCM_COMPLEX_IMAG (x
);
8061 if (SCM_I_INUMP (y
))
8063 scm_t_inum yy
= SCM_I_INUM (y
);
8064 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8066 scm_num_overflow (s_divide
);
8071 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8074 else if (SCM_BIGP (y
))
8076 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8077 scm_remember_upto_here_1 (y
);
8078 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8080 else if (SCM_REALP (y
))
8082 double yy
= SCM_REAL_VALUE (y
);
8083 #ifndef ALLOW_DIVIDE_BY_ZERO
8085 scm_num_overflow (s_divide
);
8088 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8090 else if (SCM_COMPLEXP (y
))
8092 double ry
= SCM_COMPLEX_REAL (y
);
8093 double iy
= SCM_COMPLEX_IMAG (y
);
8094 if (fabs(ry
) <= fabs(iy
))
8097 double d
= iy
* (1.0 + t
* t
);
8098 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8103 double d
= ry
* (1.0 + t
* t
);
8104 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8107 else if (SCM_FRACTIONP (y
))
8109 double yy
= scm_i_fraction2double (y
);
8110 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8113 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8115 else if (SCM_FRACTIONP (x
))
8117 if (SCM_I_INUMP (y
))
8119 scm_t_inum yy
= SCM_I_INUM (y
);
8120 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8122 scm_num_overflow (s_divide
);
8125 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8126 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8128 else if (SCM_BIGP (y
))
8130 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8131 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8133 else if (SCM_REALP (y
))
8135 double yy
= SCM_REAL_VALUE (y
);
8136 #ifndef ALLOW_DIVIDE_BY_ZERO
8138 scm_num_overflow (s_divide
);
8141 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8143 else if (SCM_COMPLEXP (y
))
8145 a
= scm_i_fraction2double (x
);
8148 else if (SCM_FRACTIONP (y
))
8149 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8150 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8152 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8155 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8159 scm_divide (SCM x
, SCM y
)
8161 return do_divide (x
, y
, 0);
8164 static SCM
scm_divide2real (SCM x
, SCM y
)
8166 return do_divide (x
, y
, 1);
8172 scm_c_truncate (double x
)
8177 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8178 half-way case (ie. when x is an integer plus 0.5) going upwards.
8179 Then half-way cases are identified and adjusted down if the
8180 round-upwards didn't give the desired even integer.
8182 "plus_half == result" identifies a half-way case. If plus_half, which is
8183 x + 0.5, is an integer then x must be an integer plus 0.5.
8185 An odd "result" value is identified with result/2 != floor(result/2).
8186 This is done with plus_half, since that value is ready for use sooner in
8187 a pipelined cpu, and we're already requiring plus_half == result.
8189 Note however that we need to be careful when x is big and already an
8190 integer. In that case "x+0.5" may round to an adjacent integer, causing
8191 us to return such a value, incorrectly. For instance if the hardware is
8192 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8193 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8194 returned. Or if the hardware is in round-upwards mode, then other bigger
8195 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8196 representable value, 2^128+2^76 (or whatever), again incorrect.
8198 These bad roundings of x+0.5 are avoided by testing at the start whether
8199 x is already an integer. If it is then clearly that's the desired result
8200 already. And if it's not then the exponent must be small enough to allow
8201 an 0.5 to be represented, and hence added without a bad rounding. */
8204 scm_c_round (double x
)
8206 double plus_half
, result
;
8211 plus_half
= x
+ 0.5;
8212 result
= floor (plus_half
);
8213 /* Adjust so that the rounding is towards even. */
8214 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8219 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8221 "Round the number @var{x} towards zero.")
8222 #define FUNC_NAME s_scm_truncate_number
8224 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8226 else if (SCM_REALP (x
))
8227 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8228 else if (SCM_FRACTIONP (x
))
8229 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8230 SCM_FRACTION_DENOMINATOR (x
));
8232 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8233 s_scm_truncate_number
);
8237 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8239 "Round the number @var{x} towards the nearest integer. "
8240 "When it is exactly halfway between two integers, "
8241 "round towards the even one.")
8242 #define FUNC_NAME s_scm_round_number
8244 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8246 else if (SCM_REALP (x
))
8247 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8248 else if (SCM_FRACTIONP (x
))
8249 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8250 SCM_FRACTION_DENOMINATOR (x
));
8252 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8253 s_scm_round_number
);
8257 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8259 "Round the number @var{x} towards minus infinity.")
8260 #define FUNC_NAME s_scm_floor
8262 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8264 else if (SCM_REALP (x
))
8265 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8266 else if (SCM_FRACTIONP (x
))
8267 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8268 SCM_FRACTION_DENOMINATOR (x
));
8270 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8274 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8276 "Round the number @var{x} towards infinity.")
8277 #define FUNC_NAME s_scm_ceiling
8279 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8281 else if (SCM_REALP (x
))
8282 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8283 else if (SCM_FRACTIONP (x
))
8284 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8285 SCM_FRACTION_DENOMINATOR (x
));
8287 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8291 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8293 "Return @var{x} raised to the power of @var{y}.")
8294 #define FUNC_NAME s_scm_expt
8296 if (scm_is_integer (y
))
8298 if (scm_is_true (scm_exact_p (y
)))
8299 return scm_integer_expt (x
, y
);
8302 /* Here we handle the case where the exponent is an inexact
8303 integer. We make the exponent exact in order to use
8304 scm_integer_expt, and thus avoid the spurious imaginary
8305 parts that may result from round-off errors in the general
8306 e^(y log x) method below (for example when squaring a large
8307 negative number). In this case, we must return an inexact
8308 result for correctness. We also make the base inexact so
8309 that scm_integer_expt will use fast inexact arithmetic
8310 internally. Note that making the base inexact is not
8311 sufficient to guarantee an inexact result, because
8312 scm_integer_expt will return an exact 1 when the exponent
8313 is 0, even if the base is inexact. */
8314 return scm_exact_to_inexact
8315 (scm_integer_expt (scm_exact_to_inexact (x
),
8316 scm_inexact_to_exact (y
)));
8319 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8321 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8323 else if (scm_is_complex (x
) && scm_is_complex (y
))
8324 return scm_exp (scm_product (scm_log (x
), y
));
8325 else if (scm_is_complex (x
))
8326 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8328 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8332 /* sin/cos/tan/asin/acos/atan
8333 sinh/cosh/tanh/asinh/acosh/atanh
8334 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8335 Written by Jerry D. Hedden, (C) FSF.
8336 See the file `COPYING' for terms applying to this program. */
8338 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8340 "Compute the sine of @var{z}.")
8341 #define FUNC_NAME s_scm_sin
8343 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8344 return z
; /* sin(exact0) = exact0 */
8345 else if (scm_is_real (z
))
8346 return scm_from_double (sin (scm_to_double (z
)));
8347 else if (SCM_COMPLEXP (z
))
8349 x
= SCM_COMPLEX_REAL (z
);
8350 y
= SCM_COMPLEX_IMAG (z
);
8351 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8352 cos (x
) * sinh (y
));
8355 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8359 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8361 "Compute the cosine of @var{z}.")
8362 #define FUNC_NAME s_scm_cos
8364 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8365 return SCM_INUM1
; /* cos(exact0) = exact1 */
8366 else if (scm_is_real (z
))
8367 return scm_from_double (cos (scm_to_double (z
)));
8368 else if (SCM_COMPLEXP (z
))
8370 x
= SCM_COMPLEX_REAL (z
);
8371 y
= SCM_COMPLEX_IMAG (z
);
8372 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8373 -sin (x
) * sinh (y
));
8376 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8380 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8382 "Compute the tangent of @var{z}.")
8383 #define FUNC_NAME s_scm_tan
8385 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8386 return z
; /* tan(exact0) = exact0 */
8387 else if (scm_is_real (z
))
8388 return scm_from_double (tan (scm_to_double (z
)));
8389 else if (SCM_COMPLEXP (z
))
8391 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8392 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8393 w
= cos (x
) + cosh (y
);
8394 #ifndef ALLOW_DIVIDE_BY_ZERO
8396 scm_num_overflow (s_scm_tan
);
8398 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8401 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8405 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8407 "Compute the hyperbolic sine of @var{z}.")
8408 #define FUNC_NAME s_scm_sinh
8410 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8411 return z
; /* sinh(exact0) = exact0 */
8412 else if (scm_is_real (z
))
8413 return scm_from_double (sinh (scm_to_double (z
)));
8414 else if (SCM_COMPLEXP (z
))
8416 x
= SCM_COMPLEX_REAL (z
);
8417 y
= SCM_COMPLEX_IMAG (z
);
8418 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8419 cosh (x
) * sin (y
));
8422 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8426 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8428 "Compute the hyperbolic cosine of @var{z}.")
8429 #define FUNC_NAME s_scm_cosh
8431 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8432 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8433 else if (scm_is_real (z
))
8434 return scm_from_double (cosh (scm_to_double (z
)));
8435 else if (SCM_COMPLEXP (z
))
8437 x
= SCM_COMPLEX_REAL (z
);
8438 y
= SCM_COMPLEX_IMAG (z
);
8439 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8440 sinh (x
) * sin (y
));
8443 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8447 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8449 "Compute the hyperbolic tangent of @var{z}.")
8450 #define FUNC_NAME s_scm_tanh
8452 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8453 return z
; /* tanh(exact0) = exact0 */
8454 else if (scm_is_real (z
))
8455 return scm_from_double (tanh (scm_to_double (z
)));
8456 else if (SCM_COMPLEXP (z
))
8458 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8459 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8460 w
= cosh (x
) + cos (y
);
8461 #ifndef ALLOW_DIVIDE_BY_ZERO
8463 scm_num_overflow (s_scm_tanh
);
8465 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8468 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8472 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8474 "Compute the arc sine of @var{z}.")
8475 #define FUNC_NAME s_scm_asin
8477 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8478 return z
; /* asin(exact0) = exact0 */
8479 else if (scm_is_real (z
))
8481 double w
= scm_to_double (z
);
8482 if (w
>= -1.0 && w
<= 1.0)
8483 return scm_from_double (asin (w
));
8485 return scm_product (scm_c_make_rectangular (0, -1),
8486 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8488 else if (SCM_COMPLEXP (z
))
8490 x
= SCM_COMPLEX_REAL (z
);
8491 y
= SCM_COMPLEX_IMAG (z
);
8492 return scm_product (scm_c_make_rectangular (0, -1),
8493 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8496 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8500 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8502 "Compute the arc cosine of @var{z}.")
8503 #define FUNC_NAME s_scm_acos
8505 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8506 return SCM_INUM0
; /* acos(exact1) = exact0 */
8507 else if (scm_is_real (z
))
8509 double w
= scm_to_double (z
);
8510 if (w
>= -1.0 && w
<= 1.0)
8511 return scm_from_double (acos (w
));
8513 return scm_sum (scm_from_double (acos (0.0)),
8514 scm_product (scm_c_make_rectangular (0, 1),
8515 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8517 else if (SCM_COMPLEXP (z
))
8519 x
= SCM_COMPLEX_REAL (z
);
8520 y
= SCM_COMPLEX_IMAG (z
);
8521 return scm_sum (scm_from_double (acos (0.0)),
8522 scm_product (scm_c_make_rectangular (0, 1),
8523 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8526 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8530 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8532 "With one argument, compute the arc tangent of @var{z}.\n"
8533 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8534 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8535 #define FUNC_NAME s_scm_atan
8539 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8540 return z
; /* atan(exact0) = exact0 */
8541 else if (scm_is_real (z
))
8542 return scm_from_double (atan (scm_to_double (z
)));
8543 else if (SCM_COMPLEXP (z
))
8546 v
= SCM_COMPLEX_REAL (z
);
8547 w
= SCM_COMPLEX_IMAG (z
);
8548 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8549 scm_c_make_rectangular (v
, w
+ 1.0))),
8550 scm_c_make_rectangular (0, 2));
8553 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8555 else if (scm_is_real (z
))
8557 if (scm_is_real (y
))
8558 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8560 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8563 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8567 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8569 "Compute the inverse hyperbolic sine of @var{z}.")
8570 #define FUNC_NAME s_scm_sys_asinh
8572 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8573 return z
; /* asinh(exact0) = exact0 */
8574 else if (scm_is_real (z
))
8575 return scm_from_double (asinh (scm_to_double (z
)));
8576 else if (scm_is_number (z
))
8577 return scm_log (scm_sum (z
,
8578 scm_sqrt (scm_sum (scm_product (z
, z
),
8581 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8585 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8587 "Compute the inverse hyperbolic cosine of @var{z}.")
8588 #define FUNC_NAME s_scm_sys_acosh
8590 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8591 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8592 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8593 return scm_from_double (acosh (scm_to_double (z
)));
8594 else if (scm_is_number (z
))
8595 return scm_log (scm_sum (z
,
8596 scm_sqrt (scm_difference (scm_product (z
, z
),
8599 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8603 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8605 "Compute the inverse hyperbolic tangent of @var{z}.")
8606 #define FUNC_NAME s_scm_sys_atanh
8608 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8609 return z
; /* atanh(exact0) = exact0 */
8610 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8611 return scm_from_double (atanh (scm_to_double (z
)));
8612 else if (scm_is_number (z
))
8613 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8614 scm_difference (SCM_INUM1
, z
))),
8617 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8622 scm_c_make_rectangular (double re
, double im
)
8626 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8628 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8629 SCM_COMPLEX_REAL (z
) = re
;
8630 SCM_COMPLEX_IMAG (z
) = im
;
8634 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8635 (SCM real_part
, SCM imaginary_part
),
8636 "Return a complex number constructed of the given @var{real-part} "
8637 "and @var{imaginary-part} parts.")
8638 #define FUNC_NAME s_scm_make_rectangular
8640 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8641 SCM_ARG1
, FUNC_NAME
, "real");
8642 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8643 SCM_ARG2
, FUNC_NAME
, "real");
8645 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8646 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8649 return scm_c_make_rectangular (scm_to_double (real_part
),
8650 scm_to_double (imaginary_part
));
8655 scm_c_make_polar (double mag
, double ang
)
8659 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8660 use it on Glibc-based systems that have it (it's a GNU extension). See
8661 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8663 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8664 sincos (ang
, &s
, &c
);
8670 /* If s and c are NaNs, this indicates that the angle is a NaN,
8671 infinite, or perhaps simply too large to determine its value
8672 mod 2*pi. However, we know something that the floating-point
8673 implementation doesn't know: We know that s and c are finite.
8674 Therefore, if the magnitude is zero, return a complex zero.
8676 The reason we check for the NaNs instead of using this case
8677 whenever mag == 0.0 is because when the angle is known, we'd
8678 like to return the correct kind of non-real complex zero:
8679 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8680 on which quadrant the angle is in.
8682 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8683 return scm_c_make_rectangular (0.0, 0.0);
8685 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8688 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8690 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8691 #define FUNC_NAME s_scm_make_polar
8693 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8694 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8696 /* If mag is exact0, return exact0 */
8697 if (scm_is_eq (mag
, SCM_INUM0
))
8699 /* Return a real if ang is exact0 */
8700 else if (scm_is_eq (ang
, SCM_INUM0
))
8703 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8708 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8710 "Return the real part of the number @var{z}.")
8711 #define FUNC_NAME s_scm_real_part
8713 if (SCM_COMPLEXP (z
))
8714 return scm_from_double (SCM_COMPLEX_REAL (z
));
8715 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8718 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8723 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8725 "Return the imaginary part of the number @var{z}.")
8726 #define FUNC_NAME s_scm_imag_part
8728 if (SCM_COMPLEXP (z
))
8729 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8730 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8733 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8737 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8739 "Return the numerator of the number @var{z}.")
8740 #define FUNC_NAME s_scm_numerator
8742 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8744 else if (SCM_FRACTIONP (z
))
8745 return SCM_FRACTION_NUMERATOR (z
);
8746 else if (SCM_REALP (z
))
8747 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8749 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8754 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8756 "Return the denominator of the number @var{z}.")
8757 #define FUNC_NAME s_scm_denominator
8759 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8761 else if (SCM_FRACTIONP (z
))
8762 return SCM_FRACTION_DENOMINATOR (z
);
8763 else if (SCM_REALP (z
))
8764 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8766 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8771 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8773 "Return the magnitude of the number @var{z}. This is the same as\n"
8774 "@code{abs} for real arguments, but also allows complex numbers.")
8775 #define FUNC_NAME s_scm_magnitude
8777 if (SCM_I_INUMP (z
))
8779 scm_t_inum zz
= SCM_I_INUM (z
);
8782 else if (SCM_POSFIXABLE (-zz
))
8783 return SCM_I_MAKINUM (-zz
);
8785 return scm_i_inum2big (-zz
);
8787 else if (SCM_BIGP (z
))
8789 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8790 scm_remember_upto_here_1 (z
);
8792 return scm_i_clonebig (z
, 0);
8796 else if (SCM_REALP (z
))
8797 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8798 else if (SCM_COMPLEXP (z
))
8799 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8800 else if (SCM_FRACTIONP (z
))
8802 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8804 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8805 SCM_FRACTION_DENOMINATOR (z
));
8808 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8813 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8815 "Return the angle of the complex number @var{z}.")
8816 #define FUNC_NAME s_scm_angle
8818 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8819 flo0 to save allocating a new flonum with scm_from_double each time.
8820 But if atan2 follows the floating point rounding mode, then the value
8821 is not a constant. Maybe it'd be close enough though. */
8822 if (SCM_I_INUMP (z
))
8824 if (SCM_I_INUM (z
) >= 0)
8827 return scm_from_double (atan2 (0.0, -1.0));
8829 else if (SCM_BIGP (z
))
8831 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8832 scm_remember_upto_here_1 (z
);
8834 return scm_from_double (atan2 (0.0, -1.0));
8838 else if (SCM_REALP (z
))
8840 if (SCM_REAL_VALUE (z
) >= 0)
8843 return scm_from_double (atan2 (0.0, -1.0));
8845 else if (SCM_COMPLEXP (z
))
8846 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8847 else if (SCM_FRACTIONP (z
))
8849 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8851 else return scm_from_double (atan2 (0.0, -1.0));
8854 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8859 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8861 "Convert the number @var{z} to its inexact representation.\n")
8862 #define FUNC_NAME s_scm_exact_to_inexact
8864 if (SCM_I_INUMP (z
))
8865 return scm_from_double ((double) SCM_I_INUM (z
));
8866 else if (SCM_BIGP (z
))
8867 return scm_from_double (scm_i_big2dbl (z
));
8868 else if (SCM_FRACTIONP (z
))
8869 return scm_from_double (scm_i_fraction2double (z
));
8870 else if (SCM_INEXACTP (z
))
8873 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8878 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8880 "Return an exact number that is numerically closest to @var{z}.")
8881 #define FUNC_NAME s_scm_inexact_to_exact
8883 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8890 val
= SCM_REAL_VALUE (z
);
8891 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8892 val
= SCM_COMPLEX_REAL (z
);
8894 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8896 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8897 SCM_OUT_OF_RANGE (1, z
);
8904 mpq_set_d (frac
, val
);
8905 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8906 scm_i_mpz2num (mpq_denref (frac
)));
8908 /* When scm_i_make_ratio throws, we leak the memory allocated
8918 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8920 "Returns the @emph{simplest} rational number differing\n"
8921 "from @var{x} by no more than @var{eps}.\n"
8923 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8924 "exact result when both its arguments are exact. Thus, you might need\n"
8925 "to use @code{inexact->exact} on the arguments.\n"
8928 "(rationalize (inexact->exact 1.2) 1/100)\n"
8931 #define FUNC_NAME s_scm_rationalize
8933 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8934 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8935 eps
= scm_abs (eps
);
8936 if (scm_is_false (scm_positive_p (eps
)))
8938 /* eps is either zero or a NaN */
8939 if (scm_is_true (scm_nan_p (eps
)))
8941 else if (SCM_INEXACTP (eps
))
8942 return scm_exact_to_inexact (x
);
8946 else if (scm_is_false (scm_finite_p (eps
)))
8948 if (scm_is_true (scm_finite_p (x
)))
8953 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8955 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8956 scm_ceiling (scm_difference (x
, eps
)))))
8958 /* There's an integer within range; we want the one closest to zero */
8959 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8961 /* zero is within range */
8962 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8967 else if (scm_is_true (scm_positive_p (x
)))
8968 return scm_ceiling (scm_difference (x
, eps
));
8970 return scm_floor (scm_sum (x
, eps
));
8974 /* Use continued fractions to find closest ratio. All
8975 arithmetic is done with exact numbers.
8978 SCM ex
= scm_inexact_to_exact (x
);
8979 SCM int_part
= scm_floor (ex
);
8981 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
8982 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
8986 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
8987 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
8989 /* We stop after a million iterations just to be absolutely sure
8990 that we don't go into an infinite loop. The process normally
8991 converges after less than a dozen iterations.
8994 while (++i
< 1000000)
8996 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
8997 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
8998 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9000 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9001 eps
))) /* abs(x-a/b) <= eps */
9003 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9004 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9005 return scm_exact_to_inexact (res
);
9009 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9011 tt
= scm_floor (rx
); /* tt = floor (rx) */
9017 scm_num_overflow (s_scm_rationalize
);
9022 /* conversion functions */
9025 scm_is_integer (SCM val
)
9027 return scm_is_true (scm_integer_p (val
));
9031 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9033 if (SCM_I_INUMP (val
))
9035 scm_t_signed_bits n
= SCM_I_INUM (val
);
9036 return n
>= min
&& n
<= max
;
9038 else if (SCM_BIGP (val
))
9040 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9042 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9044 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9046 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9047 return n
>= min
&& n
<= max
;
9057 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9058 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9061 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9062 SCM_I_BIG_MPZ (val
));
9064 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9076 return n
>= min
&& n
<= max
;
9084 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9086 if (SCM_I_INUMP (val
))
9088 scm_t_signed_bits n
= SCM_I_INUM (val
);
9089 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9091 else if (SCM_BIGP (val
))
9093 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9095 else if (max
<= ULONG_MAX
)
9097 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9099 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9100 return n
>= min
&& n
<= max
;
9110 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9113 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9114 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9117 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9118 SCM_I_BIG_MPZ (val
));
9120 return n
>= min
&& n
<= max
;
9128 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9130 scm_error (scm_out_of_range_key
,
9132 "Value out of range ~S to ~S: ~S",
9133 scm_list_3 (min
, max
, bad_val
),
9134 scm_list_1 (bad_val
));
9137 #define TYPE scm_t_intmax
9138 #define TYPE_MIN min
9139 #define TYPE_MAX max
9140 #define SIZEOF_TYPE 0
9141 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9142 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9143 #include "libguile/conv-integer.i.c"
9145 #define TYPE scm_t_uintmax
9146 #define TYPE_MIN min
9147 #define TYPE_MAX max
9148 #define SIZEOF_TYPE 0
9149 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9150 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9151 #include "libguile/conv-uinteger.i.c"
9153 #define TYPE scm_t_int8
9154 #define TYPE_MIN SCM_T_INT8_MIN
9155 #define TYPE_MAX SCM_T_INT8_MAX
9156 #define SIZEOF_TYPE 1
9157 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9158 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9159 #include "libguile/conv-integer.i.c"
9161 #define TYPE scm_t_uint8
9163 #define TYPE_MAX SCM_T_UINT8_MAX
9164 #define SIZEOF_TYPE 1
9165 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9166 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9167 #include "libguile/conv-uinteger.i.c"
9169 #define TYPE scm_t_int16
9170 #define TYPE_MIN SCM_T_INT16_MIN
9171 #define TYPE_MAX SCM_T_INT16_MAX
9172 #define SIZEOF_TYPE 2
9173 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9174 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9175 #include "libguile/conv-integer.i.c"
9177 #define TYPE scm_t_uint16
9179 #define TYPE_MAX SCM_T_UINT16_MAX
9180 #define SIZEOF_TYPE 2
9181 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9182 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9183 #include "libguile/conv-uinteger.i.c"
9185 #define TYPE scm_t_int32
9186 #define TYPE_MIN SCM_T_INT32_MIN
9187 #define TYPE_MAX SCM_T_INT32_MAX
9188 #define SIZEOF_TYPE 4
9189 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9190 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9191 #include "libguile/conv-integer.i.c"
9193 #define TYPE scm_t_uint32
9195 #define TYPE_MAX SCM_T_UINT32_MAX
9196 #define SIZEOF_TYPE 4
9197 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9198 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9199 #include "libguile/conv-uinteger.i.c"
9201 #define TYPE scm_t_wchar
9202 #define TYPE_MIN (scm_t_int32)-1
9203 #define TYPE_MAX (scm_t_int32)0x10ffff
9204 #define SIZEOF_TYPE 4
9205 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9206 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9207 #include "libguile/conv-integer.i.c"
9209 #define TYPE scm_t_int64
9210 #define TYPE_MIN SCM_T_INT64_MIN
9211 #define TYPE_MAX SCM_T_INT64_MAX
9212 #define SIZEOF_TYPE 8
9213 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9214 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9215 #include "libguile/conv-integer.i.c"
9217 #define TYPE scm_t_uint64
9219 #define TYPE_MAX SCM_T_UINT64_MAX
9220 #define SIZEOF_TYPE 8
9221 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9222 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9223 #include "libguile/conv-uinteger.i.c"
9226 scm_to_mpz (SCM val
, mpz_t rop
)
9228 if (SCM_I_INUMP (val
))
9229 mpz_set_si (rop
, SCM_I_INUM (val
));
9230 else if (SCM_BIGP (val
))
9231 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9233 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9237 scm_from_mpz (mpz_t val
)
9239 return scm_i_mpz2num (val
);
9243 scm_is_real (SCM val
)
9245 return scm_is_true (scm_real_p (val
));
9249 scm_is_rational (SCM val
)
9251 return scm_is_true (scm_rational_p (val
));
9255 scm_to_double (SCM val
)
9257 if (SCM_I_INUMP (val
))
9258 return SCM_I_INUM (val
);
9259 else if (SCM_BIGP (val
))
9260 return scm_i_big2dbl (val
);
9261 else if (SCM_FRACTIONP (val
))
9262 return scm_i_fraction2double (val
);
9263 else if (SCM_REALP (val
))
9264 return SCM_REAL_VALUE (val
);
9266 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9270 scm_from_double (double val
)
9274 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9276 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9277 SCM_REAL_VALUE (z
) = val
;
9282 #if SCM_ENABLE_DEPRECATED == 1
9285 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9287 scm_c_issue_deprecation_warning
9288 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9292 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9296 scm_out_of_range (NULL
, num
);
9299 return scm_to_double (num
);
9303 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9305 scm_c_issue_deprecation_warning
9306 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9310 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9314 scm_out_of_range (NULL
, num
);
9317 return scm_to_double (num
);
9323 scm_is_complex (SCM val
)
9325 return scm_is_true (scm_complex_p (val
));
9329 scm_c_real_part (SCM z
)
9331 if (SCM_COMPLEXP (z
))
9332 return SCM_COMPLEX_REAL (z
);
9335 /* Use the scm_real_part to get proper error checking and
9338 return scm_to_double (scm_real_part (z
));
9343 scm_c_imag_part (SCM z
)
9345 if (SCM_COMPLEXP (z
))
9346 return SCM_COMPLEX_IMAG (z
);
9349 /* Use the scm_imag_part to get proper error checking and
9350 dispatching. The result will almost always be 0.0, but not
9353 return scm_to_double (scm_imag_part (z
));
9358 scm_c_magnitude (SCM z
)
9360 return scm_to_double (scm_magnitude (z
));
9366 return scm_to_double (scm_angle (z
));
9370 scm_is_number (SCM z
)
9372 return scm_is_true (scm_number_p (z
));
9376 /* Returns log(x * 2^shift) */
9378 log_of_shifted_double (double x
, long shift
)
9380 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9382 if (x
> 0.0 || double_is_non_negative_zero (x
))
9383 return scm_from_double (ans
);
9385 return scm_c_make_rectangular (ans
, M_PI
);
9388 /* Returns log(n), for exact integer n of integer-length size */
9390 log_of_exact_integer_with_size (SCM n
, long size
)
9392 long shift
= size
- 2 * scm_dblprec
[0];
9395 return log_of_shifted_double
9396 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9399 return log_of_shifted_double (scm_to_double (n
), 0);
9402 /* Returns log(n), for exact integer n of integer-length size */
9404 log_of_exact_integer (SCM n
)
9406 return log_of_exact_integer_with_size
9407 (n
, scm_to_long (scm_integer_length (n
)));
9410 /* Returns log(n/d), for exact non-zero integers n and d */
9412 log_of_fraction (SCM n
, SCM d
)
9414 long n_size
= scm_to_long (scm_integer_length (n
));
9415 long d_size
= scm_to_long (scm_integer_length (d
));
9417 if (abs (n_size
- d_size
) > 1)
9418 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9419 log_of_exact_integer_with_size (d
, d_size
)));
9420 else if (scm_is_false (scm_negative_p (n
)))
9421 return scm_from_double
9422 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9424 return scm_c_make_rectangular
9425 (log1p (scm_to_double (scm_divide2real
9426 (scm_difference (scm_abs (n
), d
),
9432 /* In the following functions we dispatch to the real-arg funcs like log()
9433 when we know the arg is real, instead of just handing everything to
9434 clog() for instance. This is in case clog() doesn't optimize for a
9435 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9436 well use it to go straight to the applicable C func. */
9438 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9440 "Return the natural logarithm of @var{z}.")
9441 #define FUNC_NAME s_scm_log
9443 if (SCM_COMPLEXP (z
))
9445 #if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
9446 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9448 double re
= SCM_COMPLEX_REAL (z
);
9449 double im
= SCM_COMPLEX_IMAG (z
);
9450 return scm_c_make_rectangular (log (hypot (re
, im
)),
9454 else if (SCM_REALP (z
))
9455 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9456 else if (SCM_I_INUMP (z
))
9458 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9459 if (scm_is_eq (z
, SCM_INUM0
))
9460 scm_num_overflow (s_scm_log
);
9462 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9464 else if (SCM_BIGP (z
))
9465 return log_of_exact_integer (z
);
9466 else if (SCM_FRACTIONP (z
))
9467 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9468 SCM_FRACTION_DENOMINATOR (z
));
9470 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9475 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9477 "Return the base 10 logarithm of @var{z}.")
9478 #define FUNC_NAME s_scm_log10
9480 if (SCM_COMPLEXP (z
))
9482 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9483 clog() and a multiply by M_LOG10E, rather than the fallback
9484 log10+hypot+atan2.) */
9485 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9486 && defined SCM_COMPLEX_VALUE
9487 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9489 double re
= SCM_COMPLEX_REAL (z
);
9490 double im
= SCM_COMPLEX_IMAG (z
);
9491 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9492 M_LOG10E
* atan2 (im
, re
));
9495 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9497 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9498 if (scm_is_eq (z
, SCM_INUM0
))
9499 scm_num_overflow (s_scm_log10
);
9502 double re
= scm_to_double (z
);
9503 double l
= log10 (fabs (re
));
9504 if (re
> 0.0 || double_is_non_negative_zero (re
))
9505 return scm_from_double (l
);
9507 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9510 else if (SCM_BIGP (z
))
9511 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9512 else if (SCM_FRACTIONP (z
))
9513 return scm_product (flo_log10e
,
9514 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9515 SCM_FRACTION_DENOMINATOR (z
)));
9517 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9522 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9524 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9525 "base of natural logarithms (2.71828@dots{}).")
9526 #define FUNC_NAME s_scm_exp
9528 if (SCM_COMPLEXP (z
))
9530 #if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
9531 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9533 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9534 SCM_COMPLEX_IMAG (z
));
9537 else if (SCM_NUMBERP (z
))
9539 /* When z is a negative bignum the conversion to double overflows,
9540 giving -infinity, but that's ok, the exp is still 0.0. */
9541 return scm_from_double (exp (scm_to_double (z
)));
9544 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9549 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9551 "Return the square root of @var{z}. Of the two possible roots\n"
9552 "(positive and negative), the one with positive real part\n"
9553 "is returned, or if that's zero then a positive imaginary part.\n"
9557 "(sqrt 9.0) @result{} 3.0\n"
9558 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9559 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9560 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9562 #define FUNC_NAME s_scm_sqrt
9564 if (SCM_COMPLEXP (z
))
9566 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9567 && defined SCM_COMPLEX_VALUE
9568 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9570 double re
= SCM_COMPLEX_REAL (z
);
9571 double im
= SCM_COMPLEX_IMAG (z
);
9572 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9573 0.5 * atan2 (im
, re
));
9576 else if (SCM_NUMBERP (z
))
9578 double xx
= scm_to_double (z
);
9580 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9582 return scm_from_double (sqrt (xx
));
9585 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9596 mpz_init_set_si (z_negative_one
, -1);
9598 /* It may be possible to tune the performance of some algorithms by using
9599 * the following constants to avoid the creation of bignums. Please, before
9600 * using these values, remember the two rules of program optimization:
9601 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9602 scm_c_define ("most-positive-fixnum",
9603 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9604 scm_c_define ("most-negative-fixnum",
9605 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9607 scm_add_feature ("complex");
9608 scm_add_feature ("inexact");
9609 flo0
= scm_from_double (0.0);
9610 flo_log10e
= scm_from_double (M_LOG10E
);
9612 /* determine floating point precision */
9613 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9615 init_dblprec(&scm_dblprec
[i
-2],i
);
9616 init_fx_radix(fx_per_radix
[i
-2],i
);
9619 /* hard code precision for base 10 if the preprocessor tells us to... */
9620 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9623 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9624 #include "libguile/numbers.x"