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.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 typedef scm_t_signed_bits scm_t_inum
;
85 #define scm_from_inum(x) (scm_from_signed_integer (x))
87 /* Tests to see if a C double is neither infinite nor a NaN.
88 TODO: if it's available, use C99's isfinite(x) instead */
89 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
91 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
92 of the infinity, but other platforms return a boolean only. */
93 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
94 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
99 Wonder if this might be faster for some of our code? A switch on
100 the numtag would jump directly to the right case, and the
101 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
103 #define SCM_I_NUMTAG_NOTNUM 0
104 #define SCM_I_NUMTAG_INUM 1
105 #define SCM_I_NUMTAG_BIG scm_tc16_big
106 #define SCM_I_NUMTAG_REAL scm_tc16_real
107 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
108 #define SCM_I_NUMTAG(x) \
109 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
110 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
111 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
112 : SCM_I_NUMTAG_NOTNUM)))
114 /* the macro above will not work as is with fractions */
118 static SCM exactly_one_half
;
119 static SCM flo_log10e
;
121 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
123 /* FLOBUFLEN is the maximum number of characters neccessary for the
124 * printed or scm_string representation of an inexact number.
126 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
129 #if !defined (HAVE_ASINH)
130 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
132 #if !defined (HAVE_ACOSH)
133 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
135 #if !defined (HAVE_ATANH)
136 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
139 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
140 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
141 in March 2006), mpz_cmp_d now handles infinities properly. */
143 #define xmpz_cmp_d(z, d) \
144 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
146 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
150 #if defined (GUILE_I)
151 #if defined HAVE_COMPLEX_DOUBLE
153 /* For an SCM object Z which is a complex number (ie. satisfies
154 SCM_COMPLEXP), return its value as a C level "complex double". */
155 #define SCM_COMPLEX_VALUE(z) \
156 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
158 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
160 /* Convert a C "complex double" to an SCM value. */
162 scm_from_complex_double (complex double z
)
164 return scm_c_make_rectangular (creal (z
), cimag (z
));
167 #endif /* HAVE_COMPLEX_DOUBLE */
172 static mpz_t z_negative_one
;
175 /* Clear the `mpz_t' embedded in bignum PTR. */
177 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
181 bignum
= PTR2SCM (ptr
);
182 mpz_clear (SCM_I_BIG_MPZ (bignum
));
185 /* Return a new uninitialized bignum. */
190 GC_finalization_proc prev_finalizer
;
191 GC_PTR prev_finalizer_data
;
193 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
194 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
198 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
200 &prev_finalizer_data
);
209 /* Return a newly created bignum. */
210 SCM z
= make_bignum ();
211 mpz_init (SCM_I_BIG_MPZ (z
));
216 scm_i_inum2big (scm_t_inum x
)
218 /* Return a newly created bignum initialized to X. */
219 SCM z
= make_bignum ();
220 #if SIZEOF_VOID_P == SIZEOF_LONG
221 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
223 /* Note that in this case, you'll also have to check all mpz_*_ui and
224 mpz_*_si invocations in Guile. */
225 #error creation of mpz not implemented for this inum size
231 scm_i_long2big (long x
)
233 /* Return a newly created bignum initialized to X. */
234 SCM z
= make_bignum ();
235 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
240 scm_i_ulong2big (unsigned long x
)
242 /* Return a newly created bignum initialized to X. */
243 SCM z
= make_bignum ();
244 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
249 scm_i_clonebig (SCM src_big
, int same_sign_p
)
251 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
252 SCM z
= make_bignum ();
253 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
255 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
260 scm_i_bigcmp (SCM x
, SCM y
)
262 /* Return neg if x < y, pos if x > y, and 0 if x == y */
263 /* presume we already know x and y are bignums */
264 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
265 scm_remember_upto_here_2 (x
, y
);
270 scm_i_dbl2big (double d
)
272 /* results are only defined if d is an integer */
273 SCM z
= make_bignum ();
274 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
278 /* Convert a integer in double representation to a SCM number. */
281 scm_i_dbl2num (double u
)
283 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
284 powers of 2, so there's no rounding when making "double" values
285 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
286 get rounded on a 64-bit machine, hence the "+1".
288 The use of floor() to force to an integer value ensures we get a
289 "numerically closest" value without depending on how a
290 double->long cast or how mpz_set_d will round. For reference,
291 double->long probably follows the hardware rounding mode,
292 mpz_set_d truncates towards zero. */
294 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
295 representable as a double? */
297 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
298 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
299 return SCM_I_MAKINUM ((scm_t_inum
) u
);
301 return scm_i_dbl2big (u
);
304 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
305 with R5RS exact->inexact.
307 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
308 (ie. truncate towards zero), then adjust to get the closest double by
309 examining the next lower bit and adding 1 (to the absolute value) if
312 Bignums exactly half way between representable doubles are rounded to the
313 next higher absolute value (ie. away from zero). This seems like an
314 adequate interpretation of R5RS "numerically closest", and it's easier
315 and faster than a full "nearest-even" style.
317 The bit test must be done on the absolute value of the mpz_t, which means
318 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
319 negatives as twos complement.
321 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
322 following the hardware rounding mode, but applied to the absolute
323 value of the mpz_t operand. This is not what we want so we put the
324 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
325 (released in March 2006) mpz_get_d now always truncates towards zero.
327 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
328 before 4.2 is a slowdown. It'd be faster to pick out the relevant
329 high bits with mpz_getlimbn. */
332 scm_i_big2dbl (SCM b
)
337 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
341 /* For GMP earlier than 4.2, force truncation towards zero */
343 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
344 _not_ the number of bits, so this code will break badly on a
345 system with non-binary doubles. */
348 if (bits
> DBL_MANT_DIG
)
350 size_t shift
= bits
- DBL_MANT_DIG
;
351 mpz_init2 (tmp
, DBL_MANT_DIG
);
352 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
353 result
= ldexp (mpz_get_d (tmp
), shift
);
358 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
362 /* GMP 4.2 or later */
363 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
366 if (bits
> DBL_MANT_DIG
)
368 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
369 /* test bit number "pos" in absolute value */
370 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
371 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
373 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
377 scm_remember_upto_here_1 (b
);
382 scm_i_normbig (SCM b
)
384 /* convert a big back to a fixnum if it'll fit */
385 /* presume b is a bignum */
386 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
388 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
389 if (SCM_FIXABLE (val
))
390 b
= SCM_I_MAKINUM (val
);
395 static SCM_C_INLINE_KEYWORD SCM
396 scm_i_mpz2num (mpz_t b
)
398 /* convert a mpz number to a SCM number. */
399 if (mpz_fits_slong_p (b
))
401 scm_t_inum val
= mpz_get_si (b
);
402 if (SCM_FIXABLE (val
))
403 return SCM_I_MAKINUM (val
);
407 SCM z
= make_bignum ();
408 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
413 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
414 static SCM
scm_divide2real (SCM x
, SCM y
);
417 scm_i_make_ratio (SCM numerator
, SCM denominator
)
418 #define FUNC_NAME "make-ratio"
420 /* First make sure the arguments are proper.
422 if (SCM_I_INUMP (denominator
))
424 if (scm_is_eq (denominator
, SCM_INUM0
))
425 scm_num_overflow ("make-ratio");
426 if (scm_is_eq (denominator
, SCM_INUM1
))
431 if (!(SCM_BIGP(denominator
)))
432 SCM_WRONG_TYPE_ARG (2, denominator
);
434 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
435 SCM_WRONG_TYPE_ARG (1, numerator
);
437 /* Then flip signs so that the denominator is positive.
439 if (scm_is_true (scm_negative_p (denominator
)))
441 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
442 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
445 /* Now consider for each of the four fixnum/bignum combinations
446 whether the rational number is really an integer.
448 if (SCM_I_INUMP (numerator
))
450 scm_t_inum x
= SCM_I_INUM (numerator
);
451 if (scm_is_eq (numerator
, SCM_INUM0
))
453 if (SCM_I_INUMP (denominator
))
456 y
= SCM_I_INUM (denominator
);
460 return SCM_I_MAKINUM (x
/ y
);
464 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
465 of that value for the denominator, as a bignum. Apart from
466 that case, abs(bignum) > abs(inum) so inum/bignum is not an
468 if (x
== SCM_MOST_NEGATIVE_FIXNUM
469 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
470 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
471 return SCM_I_MAKINUM(-1);
474 else if (SCM_BIGP (numerator
))
476 if (SCM_I_INUMP (denominator
))
478 scm_t_inum yy
= SCM_I_INUM (denominator
);
479 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
480 return scm_divide (numerator
, denominator
);
484 if (scm_is_eq (numerator
, denominator
))
486 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
487 SCM_I_BIG_MPZ (denominator
)))
488 return scm_divide(numerator
, denominator
);
492 /* No, it's a proper fraction.
495 SCM divisor
= scm_gcd (numerator
, denominator
);
496 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
498 numerator
= scm_divide (numerator
, divisor
);
499 denominator
= scm_divide (denominator
, divisor
);
502 return scm_double_cell (scm_tc16_fraction
,
503 SCM_UNPACK (numerator
),
504 SCM_UNPACK (denominator
), 0);
510 scm_i_fraction2double (SCM z
)
512 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
513 SCM_FRACTION_DENOMINATOR (z
)));
517 double_is_non_negative_zero (double x
)
519 static double zero
= 0.0;
521 return !memcmp (&x
, &zero
, sizeof(double));
524 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
526 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
528 #define FUNC_NAME s_scm_exact_p
530 if (SCM_INEXACTP (x
))
532 else if (SCM_NUMBERP (x
))
535 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
540 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
542 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
544 #define FUNC_NAME s_scm_inexact_p
546 if (SCM_INEXACTP (x
))
548 else if (SCM_NUMBERP (x
))
551 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
556 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
558 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
560 #define FUNC_NAME s_scm_odd_p
564 scm_t_inum val
= SCM_I_INUM (n
);
565 return scm_from_bool ((val
& 1L) != 0);
567 else if (SCM_BIGP (n
))
569 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
570 scm_remember_upto_here_1 (n
);
571 return scm_from_bool (odd_p
);
573 else if (SCM_REALP (n
))
575 double val
= SCM_REAL_VALUE (n
);
576 if (DOUBLE_IS_FINITE (val
))
578 double rem
= fabs (fmod (val
, 2.0));
585 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
590 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
592 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
594 #define FUNC_NAME s_scm_even_p
598 scm_t_inum val
= SCM_I_INUM (n
);
599 return scm_from_bool ((val
& 1L) == 0);
601 else if (SCM_BIGP (n
))
603 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
604 scm_remember_upto_here_1 (n
);
605 return scm_from_bool (even_p
);
607 else if (SCM_REALP (n
))
609 double val
= SCM_REAL_VALUE (n
);
610 if (DOUBLE_IS_FINITE (val
))
612 double rem
= fabs (fmod (val
, 2.0));
619 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
623 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
625 "Return @code{#t} if the real number @var{x} is neither\n"
626 "infinite nor a NaN, @code{#f} otherwise.")
627 #define FUNC_NAME s_scm_finite_p
630 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
631 else if (scm_is_real (x
))
634 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
638 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
640 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
641 "@samp{-inf.0}. Otherwise return @code{#f}.")
642 #define FUNC_NAME s_scm_inf_p
645 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
646 else if (scm_is_real (x
))
649 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
653 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
655 "Return @code{#t} if the real number @var{x} is a NaN,\n"
656 "or @code{#f} otherwise.")
657 #define FUNC_NAME s_scm_nan_p
660 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
661 else if (scm_is_real (x
))
664 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
668 /* Guile's idea of infinity. */
669 static double guile_Inf
;
671 /* Guile's idea of not a number. */
672 static double guile_NaN
;
675 guile_ieee_init (void)
677 /* Some version of gcc on some old version of Linux used to crash when
678 trying to make Inf and NaN. */
681 /* C99 INFINITY, when available.
682 FIXME: The standard allows for INFINITY to be something that overflows
683 at compile time. We ought to have a configure test to check for that
684 before trying to use it. (But in practice we believe this is not a
685 problem on any system guile is likely to target.) */
686 guile_Inf
= INFINITY
;
687 #elif defined HAVE_DINFINITY
689 extern unsigned int DINFINITY
[2];
690 guile_Inf
= (*((double *) (DINFINITY
)));
697 if (guile_Inf
== tmp
)
704 /* C99 NAN, when available */
706 #elif defined HAVE_DQNAN
709 extern unsigned int DQNAN
[2];
710 guile_NaN
= (*((double *)(DQNAN
)));
713 guile_NaN
= guile_Inf
/ guile_Inf
;
717 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
720 #define FUNC_NAME s_scm_inf
722 static int initialized
= 0;
728 return scm_from_double (guile_Inf
);
732 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
735 #define FUNC_NAME s_scm_nan
737 static int initialized
= 0;
743 return scm_from_double (guile_NaN
);
748 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
750 "Return the absolute value of @var{x}.")
751 #define FUNC_NAME s_scm_abs
755 scm_t_inum xx
= SCM_I_INUM (x
);
758 else if (SCM_POSFIXABLE (-xx
))
759 return SCM_I_MAKINUM (-xx
);
761 return scm_i_inum2big (-xx
);
763 else if (SCM_LIKELY (SCM_REALP (x
)))
765 double xx
= SCM_REAL_VALUE (x
);
766 /* If x is a NaN then xx<0 is false so we return x unchanged */
768 return scm_from_double (-xx
);
769 /* Handle signed zeroes properly */
770 else if (SCM_UNLIKELY (xx
== 0.0))
775 else if (SCM_BIGP (x
))
777 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
779 return scm_i_clonebig (x
, 0);
783 else if (SCM_FRACTIONP (x
))
785 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
787 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
788 SCM_FRACTION_DENOMINATOR (x
));
791 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
796 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
798 "Return the quotient of the numbers @var{x} and @var{y}.")
799 #define FUNC_NAME s_scm_quotient
801 if (SCM_LIKELY (scm_is_integer (x
)))
803 if (SCM_LIKELY (scm_is_integer (y
)))
804 return scm_truncate_quotient (x
, y
);
806 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
809 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
813 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
815 "Return the remainder of the numbers @var{x} and @var{y}.\n"
817 "(remainder 13 4) @result{} 1\n"
818 "(remainder -13 4) @result{} -1\n"
820 #define FUNC_NAME s_scm_remainder
822 if (SCM_LIKELY (scm_is_integer (x
)))
824 if (SCM_LIKELY (scm_is_integer (y
)))
825 return scm_truncate_remainder (x
, y
);
827 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
830 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
835 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
837 "Return the modulo of the numbers @var{x} and @var{y}.\n"
839 "(modulo 13 4) @result{} 1\n"
840 "(modulo -13 4) @result{} 3\n"
842 #define FUNC_NAME s_scm_modulo
844 if (SCM_LIKELY (scm_is_integer (x
)))
846 if (SCM_LIKELY (scm_is_integer (y
)))
847 return scm_floor_remainder (x
, y
);
849 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
852 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
856 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
857 two-valued functions. It is called from primitive generics that take
858 two arguments and return two values, when the core procedure is
859 unable to handle the given argument types. If there are GOOPS
860 methods for this primitive generic, it dispatches to GOOPS and, if
861 successful, expects two values to be returned, which are placed in
862 *rp1 and *rp2. If there are no GOOPS methods, it throws a
863 wrong-type-arg exception.
865 FIXME: This obviously belongs somewhere else, but until we decide on
866 the right API, it is here as a static function, because it is needed
867 by the *_divide functions below.
870 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
871 const char *subr
, SCM
*rp1
, SCM
*rp2
)
874 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
876 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
879 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
881 "Return the integer @var{q} such that\n"
882 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
883 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
885 "(euclidean-quotient 123 10) @result{} 12\n"
886 "(euclidean-quotient 123 -10) @result{} -12\n"
887 "(euclidean-quotient -123 10) @result{} -13\n"
888 "(euclidean-quotient -123 -10) @result{} 13\n"
889 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
890 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
892 #define FUNC_NAME s_scm_euclidean_quotient
894 if (scm_is_false (scm_negative_p (y
)))
895 return scm_floor_quotient (x
, y
);
897 return scm_ceiling_quotient (x
, y
);
901 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
903 "Return the real number @var{r} such that\n"
904 "@math{0 <= @var{r} < abs(@var{y})} and\n"
905 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
906 "for some integer @var{q}.\n"
908 "(euclidean-remainder 123 10) @result{} 3\n"
909 "(euclidean-remainder 123 -10) @result{} 3\n"
910 "(euclidean-remainder -123 10) @result{} 7\n"
911 "(euclidean-remainder -123 -10) @result{} 7\n"
912 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
913 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
915 #define FUNC_NAME s_scm_euclidean_remainder
917 if (scm_is_false (scm_negative_p (y
)))
918 return scm_floor_remainder (x
, y
);
920 return scm_ceiling_remainder (x
, y
);
924 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
926 "Return the integer @var{q} and the real number @var{r}\n"
927 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
928 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
930 "(euclidean/ 123 10) @result{} 12 and 3\n"
931 "(euclidean/ 123 -10) @result{} -12 and 3\n"
932 "(euclidean/ -123 10) @result{} -13 and 7\n"
933 "(euclidean/ -123 -10) @result{} 13 and 7\n"
934 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
935 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
937 #define FUNC_NAME s_scm_i_euclidean_divide
939 if (scm_is_false (scm_negative_p (y
)))
940 return scm_i_floor_divide (x
, y
);
942 return scm_i_ceiling_divide (x
, y
);
947 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
949 if (scm_is_false (scm_negative_p (y
)))
950 return scm_floor_divide (x
, y
, qp
, rp
);
952 return scm_ceiling_divide (x
, y
, qp
, rp
);
955 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
956 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
958 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
960 "Return the floor of @math{@var{x} / @var{y}}.\n"
962 "(floor-quotient 123 10) @result{} 12\n"
963 "(floor-quotient 123 -10) @result{} -13\n"
964 "(floor-quotient -123 10) @result{} -13\n"
965 "(floor-quotient -123 -10) @result{} 12\n"
966 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
967 "(floor-quotient 16/3 -10/7) @result{} -4\n"
969 #define FUNC_NAME s_scm_floor_quotient
971 if (SCM_LIKELY (SCM_I_INUMP (x
)))
973 scm_t_inum xx
= SCM_I_INUM (x
);
974 if (SCM_LIKELY (SCM_I_INUMP (y
)))
976 scm_t_inum yy
= SCM_I_INUM (y
);
979 if (SCM_LIKELY (yy
> 0))
981 if (SCM_UNLIKELY (xx
< 0))
984 else if (SCM_UNLIKELY (yy
== 0))
985 scm_num_overflow (s_scm_floor_quotient
);
989 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
990 return SCM_I_MAKINUM (qq
);
992 return scm_i_inum2big (qq
);
994 else if (SCM_BIGP (y
))
996 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
997 scm_remember_upto_here_1 (y
);
999 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1001 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1003 else if (SCM_REALP (y
))
1004 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1005 else if (SCM_FRACTIONP (y
))
1006 return scm_i_exact_rational_floor_quotient (x
, y
);
1008 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1009 s_scm_floor_quotient
);
1011 else if (SCM_BIGP (x
))
1013 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1015 scm_t_inum yy
= SCM_I_INUM (y
);
1016 if (SCM_UNLIKELY (yy
== 0))
1017 scm_num_overflow (s_scm_floor_quotient
);
1018 else if (SCM_UNLIKELY (yy
== 1))
1022 SCM q
= scm_i_mkbig ();
1024 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1027 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1028 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1030 scm_remember_upto_here_1 (x
);
1031 return scm_i_normbig (q
);
1034 else if (SCM_BIGP (y
))
1036 SCM q
= scm_i_mkbig ();
1037 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1040 scm_remember_upto_here_2 (x
, y
);
1041 return scm_i_normbig (q
);
1043 else if (SCM_REALP (y
))
1044 return scm_i_inexact_floor_quotient
1045 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1046 else if (SCM_FRACTIONP (y
))
1047 return scm_i_exact_rational_floor_quotient (x
, y
);
1049 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1050 s_scm_floor_quotient
);
1052 else if (SCM_REALP (x
))
1054 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1055 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1056 return scm_i_inexact_floor_quotient
1057 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1059 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1060 s_scm_floor_quotient
);
1062 else if (SCM_FRACTIONP (x
))
1065 return scm_i_inexact_floor_quotient
1066 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1067 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1068 return scm_i_exact_rational_floor_quotient (x
, y
);
1070 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1071 s_scm_floor_quotient
);
1074 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1075 s_scm_floor_quotient
);
1080 scm_i_inexact_floor_quotient (double x
, double y
)
1082 if (SCM_UNLIKELY (y
== 0))
1083 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1085 return scm_from_double (floor (x
/ y
));
1089 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1091 return scm_floor_quotient
1092 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1093 scm_product (scm_numerator (y
), scm_denominator (x
)));
1096 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1097 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1099 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1101 "Return the real number @var{r} such that\n"
1102 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1103 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1105 "(floor-remainder 123 10) @result{} 3\n"
1106 "(floor-remainder 123 -10) @result{} -7\n"
1107 "(floor-remainder -123 10) @result{} 7\n"
1108 "(floor-remainder -123 -10) @result{} -3\n"
1109 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1110 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1112 #define FUNC_NAME s_scm_floor_remainder
1114 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1116 scm_t_inum xx
= SCM_I_INUM (x
);
1117 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1119 scm_t_inum yy
= SCM_I_INUM (y
);
1120 if (SCM_UNLIKELY (yy
== 0))
1121 scm_num_overflow (s_scm_floor_remainder
);
1124 scm_t_inum rr
= xx
% yy
;
1125 int needs_adjustment
;
1127 if (SCM_LIKELY (yy
> 0))
1128 needs_adjustment
= (rr
< 0);
1130 needs_adjustment
= (rr
> 0);
1132 if (needs_adjustment
)
1134 return SCM_I_MAKINUM (rr
);
1137 else if (SCM_BIGP (y
))
1139 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1140 scm_remember_upto_here_1 (y
);
1145 SCM r
= scm_i_mkbig ();
1146 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1147 scm_remember_upto_here_1 (y
);
1148 return scm_i_normbig (r
);
1157 SCM r
= scm_i_mkbig ();
1158 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1159 scm_remember_upto_here_1 (y
);
1160 return scm_i_normbig (r
);
1163 else if (SCM_REALP (y
))
1164 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1165 else if (SCM_FRACTIONP (y
))
1166 return scm_i_exact_rational_floor_remainder (x
, y
);
1168 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1169 s_scm_floor_remainder
);
1171 else if (SCM_BIGP (x
))
1173 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1175 scm_t_inum yy
= SCM_I_INUM (y
);
1176 if (SCM_UNLIKELY (yy
== 0))
1177 scm_num_overflow (s_scm_floor_remainder
);
1182 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1184 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1185 scm_remember_upto_here_1 (x
);
1186 return SCM_I_MAKINUM (rr
);
1189 else if (SCM_BIGP (y
))
1191 SCM r
= scm_i_mkbig ();
1192 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1195 scm_remember_upto_here_2 (x
, y
);
1196 return scm_i_normbig (r
);
1198 else if (SCM_REALP (y
))
1199 return scm_i_inexact_floor_remainder
1200 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1201 else if (SCM_FRACTIONP (y
))
1202 return scm_i_exact_rational_floor_remainder (x
, y
);
1204 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1205 s_scm_floor_remainder
);
1207 else if (SCM_REALP (x
))
1209 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1210 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1211 return scm_i_inexact_floor_remainder
1212 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1214 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1215 s_scm_floor_remainder
);
1217 else if (SCM_FRACTIONP (x
))
1220 return scm_i_inexact_floor_remainder
1221 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1222 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1223 return scm_i_exact_rational_floor_remainder (x
, y
);
1225 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1226 s_scm_floor_remainder
);
1229 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1230 s_scm_floor_remainder
);
1235 scm_i_inexact_floor_remainder (double x
, double y
)
1237 /* Although it would be more efficient to use fmod here, we can't
1238 because it would in some cases produce results inconsistent with
1239 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1240 close). In particular, when x is very close to a multiple of y,
1241 then r might be either 0.0 or y, but those two cases must
1242 correspond to different choices of q. If r = 0.0 then q must be
1243 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1244 and remainder chooses the other, it would be bad. */
1245 if (SCM_UNLIKELY (y
== 0))
1246 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1248 return scm_from_double (x
- y
* floor (x
/ y
));
1252 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1254 SCM xd
= scm_denominator (x
);
1255 SCM yd
= scm_denominator (y
);
1256 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1257 scm_product (scm_numerator (y
), xd
));
1258 return scm_divide (r1
, scm_product (xd
, yd
));
1262 static void scm_i_inexact_floor_divide (double x
, double y
,
1264 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1267 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1269 "Return the integer @var{q} and the real number @var{r}\n"
1270 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1271 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1273 "(floor/ 123 10) @result{} 12 and 3\n"
1274 "(floor/ 123 -10) @result{} -13 and -7\n"
1275 "(floor/ -123 10) @result{} -13 and 7\n"
1276 "(floor/ -123 -10) @result{} 12 and -3\n"
1277 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1278 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1280 #define FUNC_NAME s_scm_i_floor_divide
1284 scm_floor_divide(x
, y
, &q
, &r
);
1285 return scm_values (scm_list_2 (q
, r
));
1289 #define s_scm_floor_divide s_scm_i_floor_divide
1290 #define g_scm_floor_divide g_scm_i_floor_divide
1293 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1295 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1297 scm_t_inum xx
= SCM_I_INUM (x
);
1298 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1300 scm_t_inum yy
= SCM_I_INUM (y
);
1301 if (SCM_UNLIKELY (yy
== 0))
1302 scm_num_overflow (s_scm_floor_divide
);
1305 scm_t_inum qq
= xx
/ yy
;
1306 scm_t_inum rr
= xx
% yy
;
1307 int needs_adjustment
;
1309 if (SCM_LIKELY (yy
> 0))
1310 needs_adjustment
= (rr
< 0);
1312 needs_adjustment
= (rr
> 0);
1314 if (needs_adjustment
)
1320 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1321 *qp
= SCM_I_MAKINUM (qq
);
1323 *qp
= scm_i_inum2big (qq
);
1324 *rp
= SCM_I_MAKINUM (rr
);
1328 else if (SCM_BIGP (y
))
1330 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1331 scm_remember_upto_here_1 (y
);
1336 SCM r
= scm_i_mkbig ();
1337 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1338 scm_remember_upto_here_1 (y
);
1339 *qp
= SCM_I_MAKINUM (-1);
1340 *rp
= scm_i_normbig (r
);
1355 SCM r
= scm_i_mkbig ();
1356 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1357 scm_remember_upto_here_1 (y
);
1358 *qp
= SCM_I_MAKINUM (-1);
1359 *rp
= scm_i_normbig (r
);
1363 else if (SCM_REALP (y
))
1364 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1365 else if (SCM_FRACTIONP (y
))
1366 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1368 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1369 s_scm_floor_divide
, qp
, rp
);
1371 else if (SCM_BIGP (x
))
1373 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1375 scm_t_inum yy
= SCM_I_INUM (y
);
1376 if (SCM_UNLIKELY (yy
== 0))
1377 scm_num_overflow (s_scm_floor_divide
);
1380 SCM q
= scm_i_mkbig ();
1381 SCM r
= scm_i_mkbig ();
1383 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1384 SCM_I_BIG_MPZ (x
), yy
);
1387 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1388 SCM_I_BIG_MPZ (x
), -yy
);
1389 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1391 scm_remember_upto_here_1 (x
);
1392 *qp
= scm_i_normbig (q
);
1393 *rp
= scm_i_normbig (r
);
1397 else if (SCM_BIGP (y
))
1399 SCM q
= scm_i_mkbig ();
1400 SCM r
= scm_i_mkbig ();
1401 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1402 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1403 scm_remember_upto_here_2 (x
, y
);
1404 *qp
= scm_i_normbig (q
);
1405 *rp
= scm_i_normbig (r
);
1408 else if (SCM_REALP (y
))
1409 return scm_i_inexact_floor_divide
1410 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1411 else if (SCM_FRACTIONP (y
))
1412 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1414 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1415 s_scm_floor_divide
, qp
, rp
);
1417 else if (SCM_REALP (x
))
1419 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1420 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1421 return scm_i_inexact_floor_divide
1422 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1424 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1425 s_scm_floor_divide
, qp
, rp
);
1427 else if (SCM_FRACTIONP (x
))
1430 return scm_i_inexact_floor_divide
1431 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1432 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1433 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1435 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1436 s_scm_floor_divide
, qp
, rp
);
1439 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1440 s_scm_floor_divide
, qp
, rp
);
1444 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1446 if (SCM_UNLIKELY (y
== 0))
1447 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1450 double q
= floor (x
/ y
);
1451 double r
= x
- q
* y
;
1452 *qp
= scm_from_double (q
);
1453 *rp
= scm_from_double (r
);
1458 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1461 SCM xd
= scm_denominator (x
);
1462 SCM yd
= scm_denominator (y
);
1464 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1465 scm_product (scm_numerator (y
), xd
),
1467 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1470 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1471 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1473 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1475 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1477 "(ceiling-quotient 123 10) @result{} 13\n"
1478 "(ceiling-quotient 123 -10) @result{} -12\n"
1479 "(ceiling-quotient -123 10) @result{} -12\n"
1480 "(ceiling-quotient -123 -10) @result{} 13\n"
1481 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1482 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1484 #define FUNC_NAME s_scm_ceiling_quotient
1486 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1488 scm_t_inum xx
= SCM_I_INUM (x
);
1489 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1491 scm_t_inum yy
= SCM_I_INUM (y
);
1492 if (SCM_UNLIKELY (yy
== 0))
1493 scm_num_overflow (s_scm_ceiling_quotient
);
1496 scm_t_inum xx1
= xx
;
1498 if (SCM_LIKELY (yy
> 0))
1500 if (SCM_LIKELY (xx
>= 0))
1503 else if (SCM_UNLIKELY (yy
== 0))
1504 scm_num_overflow (s_scm_ceiling_quotient
);
1508 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1509 return SCM_I_MAKINUM (qq
);
1511 return scm_i_inum2big (qq
);
1514 else if (SCM_BIGP (y
))
1516 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1517 scm_remember_upto_here_1 (y
);
1518 if (SCM_LIKELY (sign
> 0))
1520 if (SCM_LIKELY (xx
> 0))
1522 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1523 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1524 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1526 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1527 scm_remember_upto_here_1 (y
);
1528 return SCM_I_MAKINUM (-1);
1538 else if (SCM_REALP (y
))
1539 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1540 else if (SCM_FRACTIONP (y
))
1541 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1543 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1544 s_scm_ceiling_quotient
);
1546 else if (SCM_BIGP (x
))
1548 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1550 scm_t_inum yy
= SCM_I_INUM (y
);
1551 if (SCM_UNLIKELY (yy
== 0))
1552 scm_num_overflow (s_scm_ceiling_quotient
);
1553 else if (SCM_UNLIKELY (yy
== 1))
1557 SCM q
= scm_i_mkbig ();
1559 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1562 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1563 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1565 scm_remember_upto_here_1 (x
);
1566 return scm_i_normbig (q
);
1569 else if (SCM_BIGP (y
))
1571 SCM q
= scm_i_mkbig ();
1572 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1575 scm_remember_upto_here_2 (x
, y
);
1576 return scm_i_normbig (q
);
1578 else if (SCM_REALP (y
))
1579 return scm_i_inexact_ceiling_quotient
1580 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1581 else if (SCM_FRACTIONP (y
))
1582 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1584 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1585 s_scm_ceiling_quotient
);
1587 else if (SCM_REALP (x
))
1589 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1590 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1591 return scm_i_inexact_ceiling_quotient
1592 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1594 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1595 s_scm_ceiling_quotient
);
1597 else if (SCM_FRACTIONP (x
))
1600 return scm_i_inexact_ceiling_quotient
1601 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1602 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1603 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1605 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1606 s_scm_ceiling_quotient
);
1609 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1610 s_scm_ceiling_quotient
);
1615 scm_i_inexact_ceiling_quotient (double x
, double y
)
1617 if (SCM_UNLIKELY (y
== 0))
1618 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1620 return scm_from_double (ceil (x
/ y
));
1624 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1626 return scm_ceiling_quotient
1627 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1628 scm_product (scm_numerator (y
), scm_denominator (x
)));
1631 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1632 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1634 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1636 "Return the real number @var{r} such that\n"
1637 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1638 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1640 "(ceiling-remainder 123 10) @result{} -7\n"
1641 "(ceiling-remainder 123 -10) @result{} 3\n"
1642 "(ceiling-remainder -123 10) @result{} -3\n"
1643 "(ceiling-remainder -123 -10) @result{} 7\n"
1644 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1645 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1647 #define FUNC_NAME s_scm_ceiling_remainder
1649 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1651 scm_t_inum xx
= SCM_I_INUM (x
);
1652 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1654 scm_t_inum yy
= SCM_I_INUM (y
);
1655 if (SCM_UNLIKELY (yy
== 0))
1656 scm_num_overflow (s_scm_ceiling_remainder
);
1659 scm_t_inum rr
= xx
% yy
;
1660 int needs_adjustment
;
1662 if (SCM_LIKELY (yy
> 0))
1663 needs_adjustment
= (rr
> 0);
1665 needs_adjustment
= (rr
< 0);
1667 if (needs_adjustment
)
1669 return SCM_I_MAKINUM (rr
);
1672 else if (SCM_BIGP (y
))
1674 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1675 scm_remember_upto_here_1 (y
);
1676 if (SCM_LIKELY (sign
> 0))
1678 if (SCM_LIKELY (xx
> 0))
1680 SCM r
= scm_i_mkbig ();
1681 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1682 scm_remember_upto_here_1 (y
);
1683 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1684 return scm_i_normbig (r
);
1686 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1687 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1688 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1690 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1691 scm_remember_upto_here_1 (y
);
1701 SCM r
= scm_i_mkbig ();
1702 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1703 scm_remember_upto_here_1 (y
);
1704 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1705 return scm_i_normbig (r
);
1708 else if (SCM_REALP (y
))
1709 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1710 else if (SCM_FRACTIONP (y
))
1711 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1713 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1714 s_scm_ceiling_remainder
);
1716 else if (SCM_BIGP (x
))
1718 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1720 scm_t_inum yy
= SCM_I_INUM (y
);
1721 if (SCM_UNLIKELY (yy
== 0))
1722 scm_num_overflow (s_scm_ceiling_remainder
);
1727 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1729 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1730 scm_remember_upto_here_1 (x
);
1731 return SCM_I_MAKINUM (rr
);
1734 else if (SCM_BIGP (y
))
1736 SCM r
= scm_i_mkbig ();
1737 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1740 scm_remember_upto_here_2 (x
, y
);
1741 return scm_i_normbig (r
);
1743 else if (SCM_REALP (y
))
1744 return scm_i_inexact_ceiling_remainder
1745 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1746 else if (SCM_FRACTIONP (y
))
1747 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1749 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1750 s_scm_ceiling_remainder
);
1752 else if (SCM_REALP (x
))
1754 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1755 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1756 return scm_i_inexact_ceiling_remainder
1757 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1759 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1760 s_scm_ceiling_remainder
);
1762 else if (SCM_FRACTIONP (x
))
1765 return scm_i_inexact_ceiling_remainder
1766 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1767 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1768 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1770 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1771 s_scm_ceiling_remainder
);
1774 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1775 s_scm_ceiling_remainder
);
1780 scm_i_inexact_ceiling_remainder (double x
, double y
)
1782 /* Although it would be more efficient to use fmod here, we can't
1783 because it would in some cases produce results inconsistent with
1784 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1785 close). In particular, when x is very close to a multiple of y,
1786 then r might be either 0.0 or -y, but those two cases must
1787 correspond to different choices of q. If r = 0.0 then q must be
1788 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1789 and remainder chooses the other, it would be bad. */
1790 if (SCM_UNLIKELY (y
== 0))
1791 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1793 return scm_from_double (x
- y
* ceil (x
/ y
));
1797 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1799 SCM xd
= scm_denominator (x
);
1800 SCM yd
= scm_denominator (y
);
1801 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1802 scm_product (scm_numerator (y
), xd
));
1803 return scm_divide (r1
, scm_product (xd
, yd
));
1806 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1808 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1811 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1813 "Return the integer @var{q} and the real number @var{r}\n"
1814 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1815 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1817 "(ceiling/ 123 10) @result{} 13 and -7\n"
1818 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1819 "(ceiling/ -123 10) @result{} -12 and -3\n"
1820 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1821 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1822 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1824 #define FUNC_NAME s_scm_i_ceiling_divide
1828 scm_ceiling_divide(x
, y
, &q
, &r
);
1829 return scm_values (scm_list_2 (q
, r
));
1833 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1834 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1837 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1839 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1841 scm_t_inum xx
= SCM_I_INUM (x
);
1842 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1844 scm_t_inum yy
= SCM_I_INUM (y
);
1845 if (SCM_UNLIKELY (yy
== 0))
1846 scm_num_overflow (s_scm_ceiling_divide
);
1849 scm_t_inum qq
= xx
/ yy
;
1850 scm_t_inum rr
= xx
% yy
;
1851 int needs_adjustment
;
1853 if (SCM_LIKELY (yy
> 0))
1854 needs_adjustment
= (rr
> 0);
1856 needs_adjustment
= (rr
< 0);
1858 if (needs_adjustment
)
1863 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1864 *qp
= SCM_I_MAKINUM (qq
);
1866 *qp
= scm_i_inum2big (qq
);
1867 *rp
= SCM_I_MAKINUM (rr
);
1871 else if (SCM_BIGP (y
))
1873 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1874 scm_remember_upto_here_1 (y
);
1875 if (SCM_LIKELY (sign
> 0))
1877 if (SCM_LIKELY (xx
> 0))
1879 SCM r
= scm_i_mkbig ();
1880 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1881 scm_remember_upto_here_1 (y
);
1882 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1884 *rp
= scm_i_normbig (r
);
1886 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1887 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1888 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1890 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1891 scm_remember_upto_here_1 (y
);
1892 *qp
= SCM_I_MAKINUM (-1);
1908 SCM r
= scm_i_mkbig ();
1909 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1910 scm_remember_upto_here_1 (y
);
1911 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1913 *rp
= scm_i_normbig (r
);
1917 else if (SCM_REALP (y
))
1918 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1919 else if (SCM_FRACTIONP (y
))
1920 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1922 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1923 s_scm_ceiling_divide
, qp
, rp
);
1925 else if (SCM_BIGP (x
))
1927 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1929 scm_t_inum yy
= SCM_I_INUM (y
);
1930 if (SCM_UNLIKELY (yy
== 0))
1931 scm_num_overflow (s_scm_ceiling_divide
);
1934 SCM q
= scm_i_mkbig ();
1935 SCM r
= scm_i_mkbig ();
1937 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1938 SCM_I_BIG_MPZ (x
), yy
);
1941 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1942 SCM_I_BIG_MPZ (x
), -yy
);
1943 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1945 scm_remember_upto_here_1 (x
);
1946 *qp
= scm_i_normbig (q
);
1947 *rp
= scm_i_normbig (r
);
1951 else if (SCM_BIGP (y
))
1953 SCM q
= scm_i_mkbig ();
1954 SCM r
= scm_i_mkbig ();
1955 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1956 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1957 scm_remember_upto_here_2 (x
, y
);
1958 *qp
= scm_i_normbig (q
);
1959 *rp
= scm_i_normbig (r
);
1962 else if (SCM_REALP (y
))
1963 return scm_i_inexact_ceiling_divide
1964 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1965 else if (SCM_FRACTIONP (y
))
1966 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1968 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1969 s_scm_ceiling_divide
, qp
, rp
);
1971 else if (SCM_REALP (x
))
1973 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1974 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1975 return scm_i_inexact_ceiling_divide
1976 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1978 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1979 s_scm_ceiling_divide
, qp
, rp
);
1981 else if (SCM_FRACTIONP (x
))
1984 return scm_i_inexact_ceiling_divide
1985 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1986 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1987 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1989 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1990 s_scm_ceiling_divide
, qp
, rp
);
1993 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
1994 s_scm_ceiling_divide
, qp
, rp
);
1998 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2000 if (SCM_UNLIKELY (y
== 0))
2001 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2004 double q
= ceil (x
/ y
);
2005 double r
= x
- q
* y
;
2006 *qp
= scm_from_double (q
);
2007 *rp
= scm_from_double (r
);
2012 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2015 SCM xd
= scm_denominator (x
);
2016 SCM yd
= scm_denominator (y
);
2018 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2019 scm_product (scm_numerator (y
), xd
),
2021 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2024 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2025 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2027 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2029 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2031 "(truncate-quotient 123 10) @result{} 12\n"
2032 "(truncate-quotient 123 -10) @result{} -12\n"
2033 "(truncate-quotient -123 10) @result{} -12\n"
2034 "(truncate-quotient -123 -10) @result{} 12\n"
2035 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2036 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2038 #define FUNC_NAME s_scm_truncate_quotient
2040 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2042 scm_t_inum xx
= SCM_I_INUM (x
);
2043 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2045 scm_t_inum yy
= SCM_I_INUM (y
);
2046 if (SCM_UNLIKELY (yy
== 0))
2047 scm_num_overflow (s_scm_truncate_quotient
);
2050 scm_t_inum qq
= xx
/ yy
;
2051 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2052 return SCM_I_MAKINUM (qq
);
2054 return scm_i_inum2big (qq
);
2057 else if (SCM_BIGP (y
))
2059 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2060 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2061 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2063 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2064 scm_remember_upto_here_1 (y
);
2065 return SCM_I_MAKINUM (-1);
2070 else if (SCM_REALP (y
))
2071 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2072 else if (SCM_FRACTIONP (y
))
2073 return scm_i_exact_rational_truncate_quotient (x
, y
);
2075 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2076 s_scm_truncate_quotient
);
2078 else if (SCM_BIGP (x
))
2080 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2082 scm_t_inum yy
= SCM_I_INUM (y
);
2083 if (SCM_UNLIKELY (yy
== 0))
2084 scm_num_overflow (s_scm_truncate_quotient
);
2085 else if (SCM_UNLIKELY (yy
== 1))
2089 SCM q
= scm_i_mkbig ();
2091 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2094 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2095 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2097 scm_remember_upto_here_1 (x
);
2098 return scm_i_normbig (q
);
2101 else if (SCM_BIGP (y
))
2103 SCM q
= scm_i_mkbig ();
2104 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2107 scm_remember_upto_here_2 (x
, y
);
2108 return scm_i_normbig (q
);
2110 else if (SCM_REALP (y
))
2111 return scm_i_inexact_truncate_quotient
2112 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2113 else if (SCM_FRACTIONP (y
))
2114 return scm_i_exact_rational_truncate_quotient (x
, y
);
2116 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2117 s_scm_truncate_quotient
);
2119 else if (SCM_REALP (x
))
2121 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2122 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2123 return scm_i_inexact_truncate_quotient
2124 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2126 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2127 s_scm_truncate_quotient
);
2129 else if (SCM_FRACTIONP (x
))
2132 return scm_i_inexact_truncate_quotient
2133 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2134 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2135 return scm_i_exact_rational_truncate_quotient (x
, y
);
2137 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2138 s_scm_truncate_quotient
);
2141 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2142 s_scm_truncate_quotient
);
2147 scm_i_inexact_truncate_quotient (double x
, double y
)
2149 if (SCM_UNLIKELY (y
== 0))
2150 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2152 return scm_from_double (trunc (x
/ y
));
2156 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2158 return scm_truncate_quotient
2159 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2160 scm_product (scm_numerator (y
), scm_denominator (x
)));
2163 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2164 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2166 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2168 "Return the real number @var{r} such that\n"
2169 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2170 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2172 "(truncate-remainder 123 10) @result{} 3\n"
2173 "(truncate-remainder 123 -10) @result{} 3\n"
2174 "(truncate-remainder -123 10) @result{} -3\n"
2175 "(truncate-remainder -123 -10) @result{} -3\n"
2176 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2177 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2179 #define FUNC_NAME s_scm_truncate_remainder
2181 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2183 scm_t_inum xx
= SCM_I_INUM (x
);
2184 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2186 scm_t_inum yy
= SCM_I_INUM (y
);
2187 if (SCM_UNLIKELY (yy
== 0))
2188 scm_num_overflow (s_scm_truncate_remainder
);
2190 return SCM_I_MAKINUM (xx
% yy
);
2192 else if (SCM_BIGP (y
))
2194 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2195 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2196 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2198 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2199 scm_remember_upto_here_1 (y
);
2205 else if (SCM_REALP (y
))
2206 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2207 else if (SCM_FRACTIONP (y
))
2208 return scm_i_exact_rational_truncate_remainder (x
, y
);
2210 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2211 s_scm_truncate_remainder
);
2213 else if (SCM_BIGP (x
))
2215 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2217 scm_t_inum yy
= SCM_I_INUM (y
);
2218 if (SCM_UNLIKELY (yy
== 0))
2219 scm_num_overflow (s_scm_truncate_remainder
);
2222 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2223 (yy
> 0) ? yy
: -yy
)
2224 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2225 scm_remember_upto_here_1 (x
);
2226 return SCM_I_MAKINUM (rr
);
2229 else if (SCM_BIGP (y
))
2231 SCM r
= scm_i_mkbig ();
2232 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2235 scm_remember_upto_here_2 (x
, y
);
2236 return scm_i_normbig (r
);
2238 else if (SCM_REALP (y
))
2239 return scm_i_inexact_truncate_remainder
2240 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2241 else if (SCM_FRACTIONP (y
))
2242 return scm_i_exact_rational_truncate_remainder (x
, y
);
2244 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2245 s_scm_truncate_remainder
);
2247 else if (SCM_REALP (x
))
2249 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2250 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2251 return scm_i_inexact_truncate_remainder
2252 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2254 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2255 s_scm_truncate_remainder
);
2257 else if (SCM_FRACTIONP (x
))
2260 return scm_i_inexact_truncate_remainder
2261 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2262 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2263 return scm_i_exact_rational_truncate_remainder (x
, y
);
2265 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2266 s_scm_truncate_remainder
);
2269 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2270 s_scm_truncate_remainder
);
2275 scm_i_inexact_truncate_remainder (double x
, double y
)
2277 /* Although it would be more efficient to use fmod here, we can't
2278 because it would in some cases produce results inconsistent with
2279 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2280 close). In particular, when x is very close to a multiple of y,
2281 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2282 correspond to different choices of q. If quotient chooses one and
2283 remainder chooses the other, it would be bad. */
2284 if (SCM_UNLIKELY (y
== 0))
2285 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2287 return scm_from_double (x
- y
* trunc (x
/ y
));
2291 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2293 SCM xd
= scm_denominator (x
);
2294 SCM yd
= scm_denominator (y
);
2295 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2296 scm_product (scm_numerator (y
), xd
));
2297 return scm_divide (r1
, scm_product (xd
, yd
));
2301 static void scm_i_inexact_truncate_divide (double x
, double y
,
2303 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2306 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2308 "Return the integer @var{q} and the real number @var{r}\n"
2309 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2310 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2312 "(truncate/ 123 10) @result{} 12 and 3\n"
2313 "(truncate/ 123 -10) @result{} -12 and 3\n"
2314 "(truncate/ -123 10) @result{} -12 and -3\n"
2315 "(truncate/ -123 -10) @result{} 12 and -3\n"
2316 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2317 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2319 #define FUNC_NAME s_scm_i_truncate_divide
2323 scm_truncate_divide(x
, y
, &q
, &r
);
2324 return scm_values (scm_list_2 (q
, r
));
2328 #define s_scm_truncate_divide s_scm_i_truncate_divide
2329 #define g_scm_truncate_divide g_scm_i_truncate_divide
2332 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2334 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2336 scm_t_inum xx
= SCM_I_INUM (x
);
2337 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2339 scm_t_inum yy
= SCM_I_INUM (y
);
2340 if (SCM_UNLIKELY (yy
== 0))
2341 scm_num_overflow (s_scm_truncate_divide
);
2344 scm_t_inum qq
= xx
/ yy
;
2345 scm_t_inum rr
= xx
% yy
;
2346 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2347 *qp
= SCM_I_MAKINUM (qq
);
2349 *qp
= scm_i_inum2big (qq
);
2350 *rp
= SCM_I_MAKINUM (rr
);
2354 else if (SCM_BIGP (y
))
2356 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2357 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2358 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2360 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2361 scm_remember_upto_here_1 (y
);
2362 *qp
= SCM_I_MAKINUM (-1);
2372 else if (SCM_REALP (y
))
2373 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2374 else if (SCM_FRACTIONP (y
))
2375 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2377 return two_valued_wta_dispatch_2
2378 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2379 s_scm_truncate_divide
, qp
, rp
);
2381 else if (SCM_BIGP (x
))
2383 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2385 scm_t_inum yy
= SCM_I_INUM (y
);
2386 if (SCM_UNLIKELY (yy
== 0))
2387 scm_num_overflow (s_scm_truncate_divide
);
2390 SCM q
= scm_i_mkbig ();
2393 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2394 SCM_I_BIG_MPZ (x
), yy
);
2397 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2398 SCM_I_BIG_MPZ (x
), -yy
);
2399 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2401 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2402 scm_remember_upto_here_1 (x
);
2403 *qp
= scm_i_normbig (q
);
2404 *rp
= SCM_I_MAKINUM (rr
);
2408 else if (SCM_BIGP (y
))
2410 SCM q
= scm_i_mkbig ();
2411 SCM r
= scm_i_mkbig ();
2412 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2413 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2414 scm_remember_upto_here_2 (x
, y
);
2415 *qp
= scm_i_normbig (q
);
2416 *rp
= scm_i_normbig (r
);
2418 else if (SCM_REALP (y
))
2419 return scm_i_inexact_truncate_divide
2420 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2421 else if (SCM_FRACTIONP (y
))
2422 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2424 return two_valued_wta_dispatch_2
2425 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2426 s_scm_truncate_divide
, qp
, rp
);
2428 else if (SCM_REALP (x
))
2430 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2431 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2432 return scm_i_inexact_truncate_divide
2433 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2435 return two_valued_wta_dispatch_2
2436 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2437 s_scm_truncate_divide
, qp
, rp
);
2439 else if (SCM_FRACTIONP (x
))
2442 return scm_i_inexact_truncate_divide
2443 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2444 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2445 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2447 return two_valued_wta_dispatch_2
2448 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2449 s_scm_truncate_divide
, qp
, rp
);
2452 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2453 s_scm_truncate_divide
, qp
, rp
);
2457 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2459 if (SCM_UNLIKELY (y
== 0))
2460 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2463 double q
= trunc (x
/ y
);
2464 double r
= x
- q
* y
;
2465 *qp
= scm_from_double (q
);
2466 *rp
= scm_from_double (r
);
2471 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2474 SCM xd
= scm_denominator (x
);
2475 SCM yd
= scm_denominator (y
);
2477 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2478 scm_product (scm_numerator (y
), xd
),
2480 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2483 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2484 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2485 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2487 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2489 "Return the integer @var{q} such that\n"
2490 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2491 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2493 "(centered-quotient 123 10) @result{} 12\n"
2494 "(centered-quotient 123 -10) @result{} -12\n"
2495 "(centered-quotient -123 10) @result{} -12\n"
2496 "(centered-quotient -123 -10) @result{} 12\n"
2497 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2498 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2500 #define FUNC_NAME s_scm_centered_quotient
2502 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2504 scm_t_inum xx
= SCM_I_INUM (x
);
2505 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2507 scm_t_inum yy
= SCM_I_INUM (y
);
2508 if (SCM_UNLIKELY (yy
== 0))
2509 scm_num_overflow (s_scm_centered_quotient
);
2512 scm_t_inum qq
= xx
/ yy
;
2513 scm_t_inum rr
= xx
% yy
;
2514 if (SCM_LIKELY (xx
> 0))
2516 if (SCM_LIKELY (yy
> 0))
2518 if (rr
>= (yy
+ 1) / 2)
2523 if (rr
>= (1 - yy
) / 2)
2529 if (SCM_LIKELY (yy
> 0))
2540 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2541 return SCM_I_MAKINUM (qq
);
2543 return scm_i_inum2big (qq
);
2546 else if (SCM_BIGP (y
))
2548 /* Pass a denormalized bignum version of x (even though it
2549 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2550 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2552 else if (SCM_REALP (y
))
2553 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2554 else if (SCM_FRACTIONP (y
))
2555 return scm_i_exact_rational_centered_quotient (x
, y
);
2557 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2558 s_scm_centered_quotient
);
2560 else if (SCM_BIGP (x
))
2562 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2564 scm_t_inum yy
= SCM_I_INUM (y
);
2565 if (SCM_UNLIKELY (yy
== 0))
2566 scm_num_overflow (s_scm_centered_quotient
);
2567 else if (SCM_UNLIKELY (yy
== 1))
2571 SCM q
= scm_i_mkbig ();
2573 /* Arrange for rr to initially be non-positive,
2574 because that simplifies the test to see
2575 if it is within the needed bounds. */
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
);
2582 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2583 SCM_I_BIG_MPZ (q
), 1);
2587 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2588 SCM_I_BIG_MPZ (x
), -yy
);
2589 scm_remember_upto_here_1 (x
);
2590 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2592 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2593 SCM_I_BIG_MPZ (q
), 1);
2595 return scm_i_normbig (q
);
2598 else if (SCM_BIGP (y
))
2599 return scm_i_bigint_centered_quotient (x
, y
);
2600 else if (SCM_REALP (y
))
2601 return scm_i_inexact_centered_quotient
2602 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2603 else if (SCM_FRACTIONP (y
))
2604 return scm_i_exact_rational_centered_quotient (x
, y
);
2606 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2607 s_scm_centered_quotient
);
2609 else if (SCM_REALP (x
))
2611 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2612 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2613 return scm_i_inexact_centered_quotient
2614 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2616 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2617 s_scm_centered_quotient
);
2619 else if (SCM_FRACTIONP (x
))
2622 return scm_i_inexact_centered_quotient
2623 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2624 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2625 return scm_i_exact_rational_centered_quotient (x
, y
);
2627 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2628 s_scm_centered_quotient
);
2631 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2632 s_scm_centered_quotient
);
2637 scm_i_inexact_centered_quotient (double x
, double y
)
2639 if (SCM_LIKELY (y
> 0))
2640 return scm_from_double (floor (x
/y
+ 0.5));
2641 else if (SCM_LIKELY (y
< 0))
2642 return scm_from_double (ceil (x
/y
- 0.5));
2644 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2649 /* Assumes that both x and y are bigints, though
2650 x might be able to fit into a fixnum. */
2652 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2656 /* Note that x might be small enough to fit into a
2657 fixnum, so we must not let it escape into the wild */
2661 /* min_r will eventually become -abs(y)/2 */
2662 min_r
= scm_i_mkbig ();
2663 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2664 SCM_I_BIG_MPZ (y
), 1);
2666 /* Arrange for rr to initially be non-positive,
2667 because that simplifies the test to see
2668 if it is within the needed bounds. */
2669 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2671 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2672 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2673 scm_remember_upto_here_2 (x
, y
);
2674 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2675 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2676 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2677 SCM_I_BIG_MPZ (q
), 1);
2681 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2682 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2683 scm_remember_upto_here_2 (x
, y
);
2684 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2685 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2686 SCM_I_BIG_MPZ (q
), 1);
2688 scm_remember_upto_here_2 (r
, min_r
);
2689 return scm_i_normbig (q
);
2693 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2695 return scm_centered_quotient
2696 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2697 scm_product (scm_numerator (y
), scm_denominator (x
)));
2700 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2701 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2702 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2704 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2706 "Return the real number @var{r} such that\n"
2707 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2708 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2709 "for some integer @var{q}.\n"
2711 "(centered-remainder 123 10) @result{} 3\n"
2712 "(centered-remainder 123 -10) @result{} 3\n"
2713 "(centered-remainder -123 10) @result{} -3\n"
2714 "(centered-remainder -123 -10) @result{} -3\n"
2715 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2716 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2718 #define FUNC_NAME s_scm_centered_remainder
2720 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2722 scm_t_inum xx
= SCM_I_INUM (x
);
2723 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2725 scm_t_inum yy
= SCM_I_INUM (y
);
2726 if (SCM_UNLIKELY (yy
== 0))
2727 scm_num_overflow (s_scm_centered_remainder
);
2730 scm_t_inum rr
= xx
% yy
;
2731 if (SCM_LIKELY (xx
> 0))
2733 if (SCM_LIKELY (yy
> 0))
2735 if (rr
>= (yy
+ 1) / 2)
2740 if (rr
>= (1 - yy
) / 2)
2746 if (SCM_LIKELY (yy
> 0))
2757 return SCM_I_MAKINUM (rr
);
2760 else if (SCM_BIGP (y
))
2762 /* Pass a denormalized bignum version of x (even though it
2763 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2764 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2766 else if (SCM_REALP (y
))
2767 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2768 else if (SCM_FRACTIONP (y
))
2769 return scm_i_exact_rational_centered_remainder (x
, y
);
2771 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2772 s_scm_centered_remainder
);
2774 else if (SCM_BIGP (x
))
2776 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2778 scm_t_inum yy
= SCM_I_INUM (y
);
2779 if (SCM_UNLIKELY (yy
== 0))
2780 scm_num_overflow (s_scm_centered_remainder
);
2784 /* Arrange for rr to initially be non-positive,
2785 because that simplifies the test to see
2786 if it is within the needed bounds. */
2789 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2790 scm_remember_upto_here_1 (x
);
2796 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2797 scm_remember_upto_here_1 (x
);
2801 return SCM_I_MAKINUM (rr
);
2804 else if (SCM_BIGP (y
))
2805 return scm_i_bigint_centered_remainder (x
, y
);
2806 else if (SCM_REALP (y
))
2807 return scm_i_inexact_centered_remainder
2808 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2809 else if (SCM_FRACTIONP (y
))
2810 return scm_i_exact_rational_centered_remainder (x
, y
);
2812 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2813 s_scm_centered_remainder
);
2815 else if (SCM_REALP (x
))
2817 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2818 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2819 return scm_i_inexact_centered_remainder
2820 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2822 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2823 s_scm_centered_remainder
);
2825 else if (SCM_FRACTIONP (x
))
2828 return scm_i_inexact_centered_remainder
2829 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2830 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2831 return scm_i_exact_rational_centered_remainder (x
, y
);
2833 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2834 s_scm_centered_remainder
);
2837 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2838 s_scm_centered_remainder
);
2843 scm_i_inexact_centered_remainder (double x
, double y
)
2847 /* Although it would be more efficient to use fmod here, we can't
2848 because it would in some cases produce results inconsistent with
2849 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2850 close). In particular, when x-y/2 is very close to a multiple of
2851 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2852 two cases must correspond to different choices of q. If quotient
2853 chooses one and remainder chooses the other, it would be bad. */
2854 if (SCM_LIKELY (y
> 0))
2855 q
= floor (x
/y
+ 0.5);
2856 else if (SCM_LIKELY (y
< 0))
2857 q
= ceil (x
/y
- 0.5);
2859 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2862 return scm_from_double (x
- q
* y
);
2865 /* Assumes that both x and y are bigints, though
2866 x might be able to fit into a fixnum. */
2868 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2872 /* Note that x might be small enough to fit into a
2873 fixnum, so we must not let it escape into the wild */
2876 /* min_r will eventually become -abs(y)/2 */
2877 min_r
= scm_i_mkbig ();
2878 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2879 SCM_I_BIG_MPZ (y
), 1);
2881 /* Arrange for rr to initially be non-positive,
2882 because that simplifies the test to see
2883 if it is within the needed bounds. */
2884 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2886 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2887 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2888 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2889 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2890 mpz_add (SCM_I_BIG_MPZ (r
),
2896 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2897 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2898 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2899 mpz_sub (SCM_I_BIG_MPZ (r
),
2903 scm_remember_upto_here_2 (x
, y
);
2904 return scm_i_normbig (r
);
2908 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2910 SCM xd
= scm_denominator (x
);
2911 SCM yd
= scm_denominator (y
);
2912 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2913 scm_product (scm_numerator (y
), xd
));
2914 return scm_divide (r1
, scm_product (xd
, yd
));
2918 static void scm_i_inexact_centered_divide (double x
, double y
,
2920 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2921 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2924 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2926 "Return the integer @var{q} and the real number @var{r}\n"
2927 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2928 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2930 "(centered/ 123 10) @result{} 12 and 3\n"
2931 "(centered/ 123 -10) @result{} -12 and 3\n"
2932 "(centered/ -123 10) @result{} -12 and -3\n"
2933 "(centered/ -123 -10) @result{} 12 and -3\n"
2934 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2935 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2937 #define FUNC_NAME s_scm_i_centered_divide
2941 scm_centered_divide(x
, y
, &q
, &r
);
2942 return scm_values (scm_list_2 (q
, r
));
2946 #define s_scm_centered_divide s_scm_i_centered_divide
2947 #define g_scm_centered_divide g_scm_i_centered_divide
2950 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2952 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2954 scm_t_inum xx
= SCM_I_INUM (x
);
2955 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2957 scm_t_inum yy
= SCM_I_INUM (y
);
2958 if (SCM_UNLIKELY (yy
== 0))
2959 scm_num_overflow (s_scm_centered_divide
);
2962 scm_t_inum qq
= xx
/ yy
;
2963 scm_t_inum rr
= xx
% yy
;
2964 if (SCM_LIKELY (xx
> 0))
2966 if (SCM_LIKELY (yy
> 0))
2968 if (rr
>= (yy
+ 1) / 2)
2973 if (rr
>= (1 - yy
) / 2)
2979 if (SCM_LIKELY (yy
> 0))
2990 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2991 *qp
= SCM_I_MAKINUM (qq
);
2993 *qp
= scm_i_inum2big (qq
);
2994 *rp
= SCM_I_MAKINUM (rr
);
2998 else if (SCM_BIGP (y
))
3000 /* Pass a denormalized bignum version of x (even though it
3001 can fit in a fixnum) to scm_i_bigint_centered_divide */
3002 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3004 else if (SCM_REALP (y
))
3005 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3006 else if (SCM_FRACTIONP (y
))
3007 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3009 return two_valued_wta_dispatch_2
3010 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3011 s_scm_centered_divide
, qp
, rp
);
3013 else if (SCM_BIGP (x
))
3015 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3017 scm_t_inum yy
= SCM_I_INUM (y
);
3018 if (SCM_UNLIKELY (yy
== 0))
3019 scm_num_overflow (s_scm_centered_divide
);
3022 SCM q
= scm_i_mkbig ();
3024 /* Arrange for rr to initially be non-positive,
3025 because that simplifies the test to see
3026 if it is within the needed bounds. */
3029 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3030 SCM_I_BIG_MPZ (x
), yy
);
3031 scm_remember_upto_here_1 (x
);
3034 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3035 SCM_I_BIG_MPZ (q
), 1);
3041 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3042 SCM_I_BIG_MPZ (x
), -yy
);
3043 scm_remember_upto_here_1 (x
);
3044 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3047 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3048 SCM_I_BIG_MPZ (q
), 1);
3052 *qp
= scm_i_normbig (q
);
3053 *rp
= SCM_I_MAKINUM (rr
);
3057 else if (SCM_BIGP (y
))
3058 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3059 else if (SCM_REALP (y
))
3060 return scm_i_inexact_centered_divide
3061 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3062 else if (SCM_FRACTIONP (y
))
3063 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3065 return two_valued_wta_dispatch_2
3066 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3067 s_scm_centered_divide
, qp
, rp
);
3069 else if (SCM_REALP (x
))
3071 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3072 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3073 return scm_i_inexact_centered_divide
3074 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3076 return two_valued_wta_dispatch_2
3077 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3078 s_scm_centered_divide
, qp
, rp
);
3080 else if (SCM_FRACTIONP (x
))
3083 return scm_i_inexact_centered_divide
3084 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3085 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3086 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3088 return two_valued_wta_dispatch_2
3089 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3090 s_scm_centered_divide
, qp
, rp
);
3093 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3094 s_scm_centered_divide
, qp
, rp
);
3098 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3102 if (SCM_LIKELY (y
> 0))
3103 q
= floor (x
/y
+ 0.5);
3104 else if (SCM_LIKELY (y
< 0))
3105 q
= ceil (x
/y
- 0.5);
3107 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3111 *qp
= scm_from_double (q
);
3112 *rp
= scm_from_double (r
);
3115 /* Assumes that both x and y are bigints, though
3116 x might be able to fit into a fixnum. */
3118 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3122 /* Note that x might be small enough to fit into a
3123 fixnum, so we must not let it escape into the wild */
3127 /* min_r will eventually become -abs(y/2) */
3128 min_r
= scm_i_mkbig ();
3129 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3130 SCM_I_BIG_MPZ (y
), 1);
3132 /* Arrange for rr to initially be non-positive,
3133 because that simplifies the test to see
3134 if it is within the needed bounds. */
3135 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3137 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3138 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3139 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3140 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3142 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3143 SCM_I_BIG_MPZ (q
), 1);
3144 mpz_add (SCM_I_BIG_MPZ (r
),
3151 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3152 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3153 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3155 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3156 SCM_I_BIG_MPZ (q
), 1);
3157 mpz_sub (SCM_I_BIG_MPZ (r
),
3162 scm_remember_upto_here_2 (x
, y
);
3163 *qp
= scm_i_normbig (q
);
3164 *rp
= scm_i_normbig (r
);
3168 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3171 SCM xd
= scm_denominator (x
);
3172 SCM yd
= scm_denominator (y
);
3174 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3175 scm_product (scm_numerator (y
), xd
),
3177 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3180 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3181 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3182 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3184 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3186 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3187 "with ties going to the nearest even integer.\n"
3189 "(round-quotient 123 10) @result{} 12\n"
3190 "(round-quotient 123 -10) @result{} -12\n"
3191 "(round-quotient -123 10) @result{} -12\n"
3192 "(round-quotient -123 -10) @result{} 12\n"
3193 "(round-quotient 125 10) @result{} 12\n"
3194 "(round-quotient 127 10) @result{} 13\n"
3195 "(round-quotient 135 10) @result{} 14\n"
3196 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3197 "(round-quotient 16/3 -10/7) @result{} -4\n"
3199 #define FUNC_NAME s_scm_round_quotient
3201 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3203 scm_t_inum xx
= SCM_I_INUM (x
);
3204 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3206 scm_t_inum yy
= SCM_I_INUM (y
);
3207 if (SCM_UNLIKELY (yy
== 0))
3208 scm_num_overflow (s_scm_round_quotient
);
3211 scm_t_inum qq
= xx
/ yy
;
3212 scm_t_inum rr
= xx
% yy
;
3214 scm_t_inum r2
= 2 * rr
;
3216 if (SCM_LIKELY (yy
< 0))
3236 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3237 return SCM_I_MAKINUM (qq
);
3239 return scm_i_inum2big (qq
);
3242 else if (SCM_BIGP (y
))
3244 /* Pass a denormalized bignum version of x (even though it
3245 can fit in a fixnum) to scm_i_bigint_round_quotient */
3246 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3248 else if (SCM_REALP (y
))
3249 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3250 else if (SCM_FRACTIONP (y
))
3251 return scm_i_exact_rational_round_quotient (x
, y
);
3253 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3254 s_scm_round_quotient
);
3256 else if (SCM_BIGP (x
))
3258 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3260 scm_t_inum yy
= SCM_I_INUM (y
);
3261 if (SCM_UNLIKELY (yy
== 0))
3262 scm_num_overflow (s_scm_round_quotient
);
3263 else if (SCM_UNLIKELY (yy
== 1))
3267 SCM q
= scm_i_mkbig ();
3269 int needs_adjustment
;
3273 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3274 SCM_I_BIG_MPZ (x
), yy
);
3275 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3276 needs_adjustment
= (2*rr
>= yy
);
3278 needs_adjustment
= (2*rr
> yy
);
3282 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3283 SCM_I_BIG_MPZ (x
), -yy
);
3284 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3285 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3286 needs_adjustment
= (2*rr
<= yy
);
3288 needs_adjustment
= (2*rr
< yy
);
3290 scm_remember_upto_here_1 (x
);
3291 if (needs_adjustment
)
3292 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3293 return scm_i_normbig (q
);
3296 else if (SCM_BIGP (y
))
3297 return scm_i_bigint_round_quotient (x
, y
);
3298 else if (SCM_REALP (y
))
3299 return scm_i_inexact_round_quotient
3300 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3301 else if (SCM_FRACTIONP (y
))
3302 return scm_i_exact_rational_round_quotient (x
, y
);
3304 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3305 s_scm_round_quotient
);
3307 else if (SCM_REALP (x
))
3309 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3310 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3311 return scm_i_inexact_round_quotient
3312 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3314 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3315 s_scm_round_quotient
);
3317 else if (SCM_FRACTIONP (x
))
3320 return scm_i_inexact_round_quotient
3321 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3322 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3323 return scm_i_exact_rational_round_quotient (x
, y
);
3325 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3326 s_scm_round_quotient
);
3329 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3330 s_scm_round_quotient
);
3335 scm_i_inexact_round_quotient (double x
, double y
)
3337 if (SCM_UNLIKELY (y
== 0))
3338 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3340 return scm_from_double (scm_c_round (x
/ y
));
3343 /* Assumes that both x and y are bigints, though
3344 x might be able to fit into a fixnum. */
3346 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3349 int cmp
, needs_adjustment
;
3351 /* Note that x might be small enough to fit into a
3352 fixnum, so we must not let it escape into the wild */
3355 r2
= scm_i_mkbig ();
3357 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3358 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3359 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3360 scm_remember_upto_here_2 (x
, r
);
3362 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3363 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3364 needs_adjustment
= (cmp
>= 0);
3366 needs_adjustment
= (cmp
> 0);
3367 scm_remember_upto_here_2 (r2
, y
);
3369 if (needs_adjustment
)
3370 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3372 return scm_i_normbig (q
);
3376 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3378 return scm_round_quotient
3379 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3380 scm_product (scm_numerator (y
), scm_denominator (x
)));
3383 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3384 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3385 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3387 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3389 "Return the real number @var{r} such that\n"
3390 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3391 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3392 "nearest integer, with ties going to the nearest\n"
3395 "(round-remainder 123 10) @result{} 3\n"
3396 "(round-remainder 123 -10) @result{} 3\n"
3397 "(round-remainder -123 10) @result{} -3\n"
3398 "(round-remainder -123 -10) @result{} -3\n"
3399 "(round-remainder 125 10) @result{} 5\n"
3400 "(round-remainder 127 10) @result{} -3\n"
3401 "(round-remainder 135 10) @result{} -5\n"
3402 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3403 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3405 #define FUNC_NAME s_scm_round_remainder
3407 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3409 scm_t_inum xx
= SCM_I_INUM (x
);
3410 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3412 scm_t_inum yy
= SCM_I_INUM (y
);
3413 if (SCM_UNLIKELY (yy
== 0))
3414 scm_num_overflow (s_scm_round_remainder
);
3417 scm_t_inum qq
= xx
/ yy
;
3418 scm_t_inum rr
= xx
% yy
;
3420 scm_t_inum r2
= 2 * rr
;
3422 if (SCM_LIKELY (yy
< 0))
3442 return SCM_I_MAKINUM (rr
);
3445 else if (SCM_BIGP (y
))
3447 /* Pass a denormalized bignum version of x (even though it
3448 can fit in a fixnum) to scm_i_bigint_round_remainder */
3449 return scm_i_bigint_round_remainder
3450 (scm_i_long2big (xx
), y
);
3452 else if (SCM_REALP (y
))
3453 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3454 else if (SCM_FRACTIONP (y
))
3455 return scm_i_exact_rational_round_remainder (x
, y
);
3457 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3458 s_scm_round_remainder
);
3460 else if (SCM_BIGP (x
))
3462 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3464 scm_t_inum yy
= SCM_I_INUM (y
);
3465 if (SCM_UNLIKELY (yy
== 0))
3466 scm_num_overflow (s_scm_round_remainder
);
3469 SCM q
= scm_i_mkbig ();
3471 int needs_adjustment
;
3475 rr
= mpz_fdiv_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
);
3484 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3485 SCM_I_BIG_MPZ (x
), -yy
);
3486 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3487 needs_adjustment
= (2*rr
<= yy
);
3489 needs_adjustment
= (2*rr
< yy
);
3491 scm_remember_upto_here_2 (x
, q
);
3492 if (needs_adjustment
)
3494 return SCM_I_MAKINUM (rr
);
3497 else if (SCM_BIGP (y
))
3498 return scm_i_bigint_round_remainder (x
, y
);
3499 else if (SCM_REALP (y
))
3500 return scm_i_inexact_round_remainder
3501 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3502 else if (SCM_FRACTIONP (y
))
3503 return scm_i_exact_rational_round_remainder (x
, y
);
3505 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3506 s_scm_round_remainder
);
3508 else if (SCM_REALP (x
))
3510 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3511 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3512 return scm_i_inexact_round_remainder
3513 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3515 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3516 s_scm_round_remainder
);
3518 else if (SCM_FRACTIONP (x
))
3521 return scm_i_inexact_round_remainder
3522 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3523 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3524 return scm_i_exact_rational_round_remainder (x
, y
);
3526 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3527 s_scm_round_remainder
);
3530 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3531 s_scm_round_remainder
);
3536 scm_i_inexact_round_remainder (double x
, double y
)
3538 /* Although it would be more efficient to use fmod here, we can't
3539 because it would in some cases produce results inconsistent with
3540 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3541 close). In particular, when x-y/2 is very close to a multiple of
3542 y, then r might be either -abs(y/2) or abs(y/2), but those two
3543 cases must correspond to different choices of q. If quotient
3544 chooses one and remainder chooses the other, it would be bad. */
3546 if (SCM_UNLIKELY (y
== 0))
3547 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3550 double q
= scm_c_round (x
/ y
);
3551 return scm_from_double (x
- q
* y
);
3555 /* Assumes that both x and y are bigints, though
3556 x might be able to fit into a fixnum. */
3558 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3561 int cmp
, needs_adjustment
;
3563 /* Note that x might be small enough to fit into a
3564 fixnum, so we must not let it escape into the wild */
3567 r2
= scm_i_mkbig ();
3569 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3570 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3571 scm_remember_upto_here_1 (x
);
3572 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3574 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3575 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3576 needs_adjustment
= (cmp
>= 0);
3578 needs_adjustment
= (cmp
> 0);
3579 scm_remember_upto_here_2 (q
, r2
);
3581 if (needs_adjustment
)
3582 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3584 scm_remember_upto_here_1 (y
);
3585 return scm_i_normbig (r
);
3589 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3591 SCM xd
= scm_denominator (x
);
3592 SCM yd
= scm_denominator (y
);
3593 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3594 scm_product (scm_numerator (y
), xd
));
3595 return scm_divide (r1
, scm_product (xd
, yd
));
3599 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3600 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3601 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3603 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3605 "Return the integer @var{q} and the real number @var{r}\n"
3606 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3607 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3608 "nearest integer, with ties going to the nearest even integer.\n"
3610 "(round/ 123 10) @result{} 12 and 3\n"
3611 "(round/ 123 -10) @result{} -12 and 3\n"
3612 "(round/ -123 10) @result{} -12 and -3\n"
3613 "(round/ -123 -10) @result{} 12 and -3\n"
3614 "(round/ 125 10) @result{} 12 and 5\n"
3615 "(round/ 127 10) @result{} 13 and -3\n"
3616 "(round/ 135 10) @result{} 14 and -5\n"
3617 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3618 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3620 #define FUNC_NAME s_scm_i_round_divide
3624 scm_round_divide(x
, y
, &q
, &r
);
3625 return scm_values (scm_list_2 (q
, r
));
3629 #define s_scm_round_divide s_scm_i_round_divide
3630 #define g_scm_round_divide g_scm_i_round_divide
3633 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3635 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3637 scm_t_inum xx
= SCM_I_INUM (x
);
3638 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3640 scm_t_inum yy
= SCM_I_INUM (y
);
3641 if (SCM_UNLIKELY (yy
== 0))
3642 scm_num_overflow (s_scm_round_divide
);
3645 scm_t_inum qq
= xx
/ yy
;
3646 scm_t_inum rr
= xx
% yy
;
3648 scm_t_inum r2
= 2 * rr
;
3650 if (SCM_LIKELY (yy
< 0))
3670 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3671 *qp
= SCM_I_MAKINUM (qq
);
3673 *qp
= scm_i_inum2big (qq
);
3674 *rp
= SCM_I_MAKINUM (rr
);
3678 else if (SCM_BIGP (y
))
3680 /* Pass a denormalized bignum version of x (even though it
3681 can fit in a fixnum) to scm_i_bigint_round_divide */
3682 return scm_i_bigint_round_divide
3683 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3685 else if (SCM_REALP (y
))
3686 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3687 else if (SCM_FRACTIONP (y
))
3688 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3690 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3691 s_scm_round_divide
, qp
, rp
);
3693 else if (SCM_BIGP (x
))
3695 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3697 scm_t_inum yy
= SCM_I_INUM (y
);
3698 if (SCM_UNLIKELY (yy
== 0))
3699 scm_num_overflow (s_scm_round_divide
);
3702 SCM q
= scm_i_mkbig ();
3704 int needs_adjustment
;
3708 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3709 SCM_I_BIG_MPZ (x
), yy
);
3710 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3711 needs_adjustment
= (2*rr
>= yy
);
3713 needs_adjustment
= (2*rr
> yy
);
3717 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3718 SCM_I_BIG_MPZ (x
), -yy
);
3719 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3720 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3721 needs_adjustment
= (2*rr
<= yy
);
3723 needs_adjustment
= (2*rr
< yy
);
3725 scm_remember_upto_here_1 (x
);
3726 if (needs_adjustment
)
3728 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3731 *qp
= scm_i_normbig (q
);
3732 *rp
= SCM_I_MAKINUM (rr
);
3736 else if (SCM_BIGP (y
))
3737 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3738 else if (SCM_REALP (y
))
3739 return scm_i_inexact_round_divide
3740 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3741 else if (SCM_FRACTIONP (y
))
3742 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3744 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3745 s_scm_round_divide
, qp
, rp
);
3747 else if (SCM_REALP (x
))
3749 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3750 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3751 return scm_i_inexact_round_divide
3752 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3754 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3755 s_scm_round_divide
, qp
, rp
);
3757 else if (SCM_FRACTIONP (x
))
3760 return scm_i_inexact_round_divide
3761 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3762 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3763 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3765 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3766 s_scm_round_divide
, qp
, rp
);
3769 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3770 s_scm_round_divide
, qp
, rp
);
3774 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3776 if (SCM_UNLIKELY (y
== 0))
3777 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3780 double q
= scm_c_round (x
/ y
);
3781 double r
= x
- q
* y
;
3782 *qp
= scm_from_double (q
);
3783 *rp
= scm_from_double (r
);
3787 /* Assumes that both x and y are bigints, though
3788 x might be able to fit into a fixnum. */
3790 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3793 int cmp
, needs_adjustment
;
3795 /* Note that x might be small enough to fit into a
3796 fixnum, so we must not let it escape into the wild */
3799 r2
= scm_i_mkbig ();
3801 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3802 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3803 scm_remember_upto_here_1 (x
);
3804 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3806 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3807 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3808 needs_adjustment
= (cmp
>= 0);
3810 needs_adjustment
= (cmp
> 0);
3812 if (needs_adjustment
)
3814 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3815 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3818 scm_remember_upto_here_2 (r2
, y
);
3819 *qp
= scm_i_normbig (q
);
3820 *rp
= scm_i_normbig (r
);
3824 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3827 SCM xd
= scm_denominator (x
);
3828 SCM yd
= scm_denominator (y
);
3830 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3831 scm_product (scm_numerator (y
), xd
),
3833 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3837 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3838 (SCM x
, SCM y
, SCM rest
),
3839 "Return the greatest common divisor of all parameter values.\n"
3840 "If called without arguments, 0 is returned.")
3841 #define FUNC_NAME s_scm_i_gcd
3843 while (!scm_is_null (rest
))
3844 { x
= scm_gcd (x
, y
);
3846 rest
= scm_cdr (rest
);
3848 return scm_gcd (x
, y
);
3852 #define s_gcd s_scm_i_gcd
3853 #define g_gcd g_scm_i_gcd
3856 scm_gcd (SCM x
, SCM y
)
3859 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3861 if (SCM_I_INUMP (x
))
3863 if (SCM_I_INUMP (y
))
3865 scm_t_inum xx
= SCM_I_INUM (x
);
3866 scm_t_inum yy
= SCM_I_INUM (y
);
3867 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3868 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3878 /* Determine a common factor 2^k */
3879 while (!(1 & (u
| v
)))
3885 /* Now, any factor 2^n can be eliminated */
3905 return (SCM_POSFIXABLE (result
)
3906 ? SCM_I_MAKINUM (result
)
3907 : scm_i_inum2big (result
));
3909 else if (SCM_BIGP (y
))
3915 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3917 else if (SCM_BIGP (x
))
3919 if (SCM_I_INUMP (y
))
3924 yy
= SCM_I_INUM (y
);
3929 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3930 scm_remember_upto_here_1 (x
);
3931 return (SCM_POSFIXABLE (result
)
3932 ? SCM_I_MAKINUM (result
)
3933 : scm_from_unsigned_integer (result
));
3935 else if (SCM_BIGP (y
))
3937 SCM result
= scm_i_mkbig ();
3938 mpz_gcd (SCM_I_BIG_MPZ (result
),
3941 scm_remember_upto_here_2 (x
, y
);
3942 return scm_i_normbig (result
);
3945 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3948 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3951 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3952 (SCM x
, SCM y
, SCM rest
),
3953 "Return the least common multiple of the arguments.\n"
3954 "If called without arguments, 1 is returned.")
3955 #define FUNC_NAME s_scm_i_lcm
3957 while (!scm_is_null (rest
))
3958 { x
= scm_lcm (x
, y
);
3960 rest
= scm_cdr (rest
);
3962 return scm_lcm (x
, y
);
3966 #define s_lcm s_scm_i_lcm
3967 #define g_lcm g_scm_i_lcm
3970 scm_lcm (SCM n1
, SCM n2
)
3972 if (SCM_UNBNDP (n2
))
3974 if (SCM_UNBNDP (n1
))
3975 return SCM_I_MAKINUM (1L);
3976 n2
= SCM_I_MAKINUM (1L);
3979 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
3980 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3981 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
3982 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
3984 if (SCM_I_INUMP (n1
))
3986 if (SCM_I_INUMP (n2
))
3988 SCM d
= scm_gcd (n1
, n2
);
3989 if (scm_is_eq (d
, SCM_INUM0
))
3992 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
3996 /* inum n1, big n2 */
3999 SCM result
= scm_i_mkbig ();
4000 scm_t_inum nn1
= SCM_I_INUM (n1
);
4001 if (nn1
== 0) return SCM_INUM0
;
4002 if (nn1
< 0) nn1
= - nn1
;
4003 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4004 scm_remember_upto_here_1 (n2
);
4012 if (SCM_I_INUMP (n2
))
4019 SCM result
= scm_i_mkbig ();
4020 mpz_lcm(SCM_I_BIG_MPZ (result
),
4022 SCM_I_BIG_MPZ (n2
));
4023 scm_remember_upto_here_2(n1
, n2
);
4024 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4030 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4035 + + + x (map digit:logand X Y)
4036 + - + x (map digit:logand X (lognot (+ -1 Y)))
4037 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4038 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4043 + + + (map digit:logior X Y)
4044 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4045 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4046 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4051 + + + (map digit:logxor X Y)
4052 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4053 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4054 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4059 + + (any digit:logand X Y)
4060 + - (any digit:logand X (lognot (+ -1 Y)))
4061 - + (any digit:logand (lognot (+ -1 X)) Y)
4066 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4067 (SCM x
, SCM y
, SCM rest
),
4068 "Return the bitwise AND of the integer arguments.\n\n"
4070 "(logand) @result{} -1\n"
4071 "(logand 7) @result{} 7\n"
4072 "(logand #b111 #b011 #b001) @result{} 1\n"
4074 #define FUNC_NAME s_scm_i_logand
4076 while (!scm_is_null (rest
))
4077 { x
= scm_logand (x
, y
);
4079 rest
= scm_cdr (rest
);
4081 return scm_logand (x
, y
);
4085 #define s_scm_logand s_scm_i_logand
4087 SCM
scm_logand (SCM n1
, SCM n2
)
4088 #define FUNC_NAME s_scm_logand
4092 if (SCM_UNBNDP (n2
))
4094 if (SCM_UNBNDP (n1
))
4095 return SCM_I_MAKINUM (-1);
4096 else if (!SCM_NUMBERP (n1
))
4097 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4098 else if (SCM_NUMBERP (n1
))
4101 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4104 if (SCM_I_INUMP (n1
))
4106 nn1
= SCM_I_INUM (n1
);
4107 if (SCM_I_INUMP (n2
))
4109 scm_t_inum nn2
= SCM_I_INUM (n2
);
4110 return SCM_I_MAKINUM (nn1
& nn2
);
4112 else if SCM_BIGP (n2
)
4118 SCM result_z
= scm_i_mkbig ();
4120 mpz_init_set_si (nn1_z
, nn1
);
4121 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4122 scm_remember_upto_here_1 (n2
);
4124 return scm_i_normbig (result_z
);
4128 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4130 else if (SCM_BIGP (n1
))
4132 if (SCM_I_INUMP (n2
))
4135 nn1
= SCM_I_INUM (n1
);
4138 else if (SCM_BIGP (n2
))
4140 SCM result_z
= scm_i_mkbig ();
4141 mpz_and (SCM_I_BIG_MPZ (result_z
),
4143 SCM_I_BIG_MPZ (n2
));
4144 scm_remember_upto_here_2 (n1
, n2
);
4145 return scm_i_normbig (result_z
);
4148 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4151 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4156 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4157 (SCM x
, SCM y
, SCM rest
),
4158 "Return the bitwise OR of the integer arguments.\n\n"
4160 "(logior) @result{} 0\n"
4161 "(logior 7) @result{} 7\n"
4162 "(logior #b000 #b001 #b011) @result{} 3\n"
4164 #define FUNC_NAME s_scm_i_logior
4166 while (!scm_is_null (rest
))
4167 { x
= scm_logior (x
, y
);
4169 rest
= scm_cdr (rest
);
4171 return scm_logior (x
, y
);
4175 #define s_scm_logior s_scm_i_logior
4177 SCM
scm_logior (SCM n1
, SCM n2
)
4178 #define FUNC_NAME s_scm_logior
4182 if (SCM_UNBNDP (n2
))
4184 if (SCM_UNBNDP (n1
))
4186 else if (SCM_NUMBERP (n1
))
4189 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4192 if (SCM_I_INUMP (n1
))
4194 nn1
= SCM_I_INUM (n1
);
4195 if (SCM_I_INUMP (n2
))
4197 long nn2
= SCM_I_INUM (n2
);
4198 return SCM_I_MAKINUM (nn1
| nn2
);
4200 else if (SCM_BIGP (n2
))
4206 SCM result_z
= scm_i_mkbig ();
4208 mpz_init_set_si (nn1_z
, nn1
);
4209 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4210 scm_remember_upto_here_1 (n2
);
4212 return scm_i_normbig (result_z
);
4216 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4218 else if (SCM_BIGP (n1
))
4220 if (SCM_I_INUMP (n2
))
4223 nn1
= SCM_I_INUM (n1
);
4226 else if (SCM_BIGP (n2
))
4228 SCM result_z
= scm_i_mkbig ();
4229 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4231 SCM_I_BIG_MPZ (n2
));
4232 scm_remember_upto_here_2 (n1
, n2
);
4233 return scm_i_normbig (result_z
);
4236 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4239 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4244 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4245 (SCM x
, SCM y
, SCM rest
),
4246 "Return the bitwise XOR of the integer arguments. A bit is\n"
4247 "set in the result if it is set in an odd number of arguments.\n"
4249 "(logxor) @result{} 0\n"
4250 "(logxor 7) @result{} 7\n"
4251 "(logxor #b000 #b001 #b011) @result{} 2\n"
4252 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4254 #define FUNC_NAME s_scm_i_logxor
4256 while (!scm_is_null (rest
))
4257 { x
= scm_logxor (x
, y
);
4259 rest
= scm_cdr (rest
);
4261 return scm_logxor (x
, y
);
4265 #define s_scm_logxor s_scm_i_logxor
4267 SCM
scm_logxor (SCM n1
, SCM n2
)
4268 #define FUNC_NAME s_scm_logxor
4272 if (SCM_UNBNDP (n2
))
4274 if (SCM_UNBNDP (n1
))
4276 else if (SCM_NUMBERP (n1
))
4279 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4282 if (SCM_I_INUMP (n1
))
4284 nn1
= SCM_I_INUM (n1
);
4285 if (SCM_I_INUMP (n2
))
4287 scm_t_inum nn2
= SCM_I_INUM (n2
);
4288 return SCM_I_MAKINUM (nn1
^ nn2
);
4290 else if (SCM_BIGP (n2
))
4294 SCM result_z
= scm_i_mkbig ();
4296 mpz_init_set_si (nn1_z
, nn1
);
4297 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4298 scm_remember_upto_here_1 (n2
);
4300 return scm_i_normbig (result_z
);
4304 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4306 else if (SCM_BIGP (n1
))
4308 if (SCM_I_INUMP (n2
))
4311 nn1
= SCM_I_INUM (n1
);
4314 else if (SCM_BIGP (n2
))
4316 SCM result_z
= scm_i_mkbig ();
4317 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4319 SCM_I_BIG_MPZ (n2
));
4320 scm_remember_upto_here_2 (n1
, n2
);
4321 return scm_i_normbig (result_z
);
4324 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4327 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4332 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4334 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4335 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4336 "without actually calculating the @code{logand}, just testing\n"
4340 "(logtest #b0100 #b1011) @result{} #f\n"
4341 "(logtest #b0100 #b0111) @result{} #t\n"
4343 #define FUNC_NAME s_scm_logtest
4347 if (SCM_I_INUMP (j
))
4349 nj
= SCM_I_INUM (j
);
4350 if (SCM_I_INUMP (k
))
4352 scm_t_inum nk
= SCM_I_INUM (k
);
4353 return scm_from_bool (nj
& nk
);
4355 else if (SCM_BIGP (k
))
4363 mpz_init_set_si (nj_z
, nj
);
4364 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4365 scm_remember_upto_here_1 (k
);
4366 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4372 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4374 else if (SCM_BIGP (j
))
4376 if (SCM_I_INUMP (k
))
4379 nj
= SCM_I_INUM (j
);
4382 else if (SCM_BIGP (k
))
4386 mpz_init (result_z
);
4390 scm_remember_upto_here_2 (j
, k
);
4391 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4392 mpz_clear (result_z
);
4396 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4399 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4404 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4406 "Test whether bit number @var{index} in @var{j} is set.\n"
4407 "@var{index} starts from 0 for the least significant bit.\n"
4410 "(logbit? 0 #b1101) @result{} #t\n"
4411 "(logbit? 1 #b1101) @result{} #f\n"
4412 "(logbit? 2 #b1101) @result{} #t\n"
4413 "(logbit? 3 #b1101) @result{} #t\n"
4414 "(logbit? 4 #b1101) @result{} #f\n"
4416 #define FUNC_NAME s_scm_logbit_p
4418 unsigned long int iindex
;
4419 iindex
= scm_to_ulong (index
);
4421 if (SCM_I_INUMP (j
))
4423 /* bits above what's in an inum follow the sign bit */
4424 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4425 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4427 else if (SCM_BIGP (j
))
4429 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4430 scm_remember_upto_here_1 (j
);
4431 return scm_from_bool (val
);
4434 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4439 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4441 "Return the integer which is the ones-complement of the integer\n"
4445 "(number->string (lognot #b10000000) 2)\n"
4446 " @result{} \"-10000001\"\n"
4447 "(number->string (lognot #b0) 2)\n"
4448 " @result{} \"-1\"\n"
4450 #define FUNC_NAME s_scm_lognot
4452 if (SCM_I_INUMP (n
)) {
4453 /* No overflow here, just need to toggle all the bits making up the inum.
4454 Enhancement: No need to strip the tag and add it back, could just xor
4455 a block of 1 bits, if that worked with the various debug versions of
4457 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4459 } else if (SCM_BIGP (n
)) {
4460 SCM result
= scm_i_mkbig ();
4461 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4462 scm_remember_upto_here_1 (n
);
4466 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4471 /* returns 0 if IN is not an integer. OUT must already be
4474 coerce_to_big (SCM in
, mpz_t out
)
4477 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4478 else if (SCM_I_INUMP (in
))
4479 mpz_set_si (out
, SCM_I_INUM (in
));
4486 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4487 (SCM n
, SCM k
, SCM m
),
4488 "Return @var{n} raised to the integer exponent\n"
4489 "@var{k}, modulo @var{m}.\n"
4492 "(modulo-expt 2 3 5)\n"
4495 #define FUNC_NAME s_scm_modulo_expt
4501 /* There are two classes of error we might encounter --
4502 1) Math errors, which we'll report by calling scm_num_overflow,
4504 2) wrong-type errors, which of course we'll report by calling
4506 We don't report those errors immediately, however; instead we do
4507 some cleanup first. These variables tell us which error (if
4508 any) we should report after cleaning up.
4510 int report_overflow
= 0;
4512 int position_of_wrong_type
= 0;
4513 SCM value_of_wrong_type
= SCM_INUM0
;
4515 SCM result
= SCM_UNDEFINED
;
4521 if (scm_is_eq (m
, SCM_INUM0
))
4523 report_overflow
= 1;
4527 if (!coerce_to_big (n
, n_tmp
))
4529 value_of_wrong_type
= n
;
4530 position_of_wrong_type
= 1;
4534 if (!coerce_to_big (k
, k_tmp
))
4536 value_of_wrong_type
= k
;
4537 position_of_wrong_type
= 2;
4541 if (!coerce_to_big (m
, m_tmp
))
4543 value_of_wrong_type
= m
;
4544 position_of_wrong_type
= 3;
4548 /* if the exponent K is negative, and we simply call mpz_powm, we
4549 will get a divide-by-zero exception when an inverse 1/n mod m
4550 doesn't exist (or is not unique). Since exceptions are hard to
4551 handle, we'll attempt the inversion "by hand" -- that way, we get
4552 a simple failure code, which is easy to handle. */
4554 if (-1 == mpz_sgn (k_tmp
))
4556 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4558 report_overflow
= 1;
4561 mpz_neg (k_tmp
, k_tmp
);
4564 result
= scm_i_mkbig ();
4565 mpz_powm (SCM_I_BIG_MPZ (result
),
4570 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4571 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4578 if (report_overflow
)
4579 scm_num_overflow (FUNC_NAME
);
4581 if (position_of_wrong_type
)
4582 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4583 value_of_wrong_type
);
4585 return scm_i_normbig (result
);
4589 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4591 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4592 "exact integer, @var{n} can be any number.\n"
4594 "Negative @var{k} is supported, and results in\n"
4595 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4596 "@math{@var{n}^0} is 1, as usual, and that\n"
4597 "includes @math{0^0} is 1.\n"
4600 "(integer-expt 2 5) @result{} 32\n"
4601 "(integer-expt -3 3) @result{} -27\n"
4602 "(integer-expt 5 -3) @result{} 1/125\n"
4603 "(integer-expt 0 0) @result{} 1\n"
4605 #define FUNC_NAME s_scm_integer_expt
4608 SCM z_i2
= SCM_BOOL_F
;
4610 SCM acc
= SCM_I_MAKINUM (1L);
4612 /* Specifically refrain from checking the type of the first argument.
4613 This allows us to exponentiate any object that can be multiplied.
4614 If we must raise to a negative power, we must also be able to
4615 take its reciprocal. */
4616 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4617 SCM_WRONG_TYPE_ARG (2, k
);
4619 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4620 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4621 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4622 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4623 /* The next check is necessary only because R6RS specifies different
4624 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4625 we simply skip this case and move on. */
4626 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4628 /* k cannot be 0 at this point, because we
4629 have already checked for that case above */
4630 if (scm_is_true (scm_positive_p (k
)))
4632 else /* return NaN for (0 ^ k) for negative k per R6RS */
4636 if (SCM_I_INUMP (k
))
4637 i2
= SCM_I_INUM (k
);
4638 else if (SCM_BIGP (k
))
4640 z_i2
= scm_i_clonebig (k
, 1);
4641 scm_remember_upto_here_1 (k
);
4645 SCM_WRONG_TYPE_ARG (2, k
);
4649 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4651 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4652 n
= scm_divide (n
, SCM_UNDEFINED
);
4656 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4660 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4662 return scm_product (acc
, n
);
4664 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4665 acc
= scm_product (acc
, n
);
4666 n
= scm_product (n
, n
);
4667 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4675 n
= scm_divide (n
, SCM_UNDEFINED
);
4682 return scm_product (acc
, n
);
4684 acc
= scm_product (acc
, n
);
4685 n
= scm_product (n
, n
);
4692 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4694 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4695 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4697 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4698 "@var{cnt} is negative it's a division, rounded towards negative\n"
4699 "infinity. (Note that this is not the same rounding as\n"
4700 "@code{quotient} does.)\n"
4702 "With @var{n} viewed as an infinite precision twos complement,\n"
4703 "@code{ash} means a left shift introducing zero bits, or a right\n"
4704 "shift dropping bits.\n"
4707 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4708 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4710 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4711 "(ash -23 -2) @result{} -6\n"
4713 #define FUNC_NAME s_scm_ash
4716 bits_to_shift
= scm_to_long (cnt
);
4718 if (SCM_I_INUMP (n
))
4720 scm_t_inum nn
= SCM_I_INUM (n
);
4722 if (bits_to_shift
> 0)
4724 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4725 overflow a non-zero fixnum. For smaller shifts we check the
4726 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4727 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4728 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4734 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4736 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4739 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4743 SCM result
= scm_i_inum2big (nn
);
4744 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4751 bits_to_shift
= -bits_to_shift
;
4752 if (bits_to_shift
>= SCM_LONG_BIT
)
4753 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4755 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4759 else if (SCM_BIGP (n
))
4763 if (bits_to_shift
== 0)
4766 result
= scm_i_mkbig ();
4767 if (bits_to_shift
>= 0)
4769 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4775 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4776 we have to allocate a bignum even if the result is going to be a
4778 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4780 return scm_i_normbig (result
);
4786 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4792 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4793 (SCM n
, SCM start
, SCM end
),
4794 "Return the integer composed of the @var{start} (inclusive)\n"
4795 "through @var{end} (exclusive) bits of @var{n}. The\n"
4796 "@var{start}th bit becomes the 0-th bit in the result.\n"
4799 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4800 " @result{} \"1010\"\n"
4801 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4802 " @result{} \"10110\"\n"
4804 #define FUNC_NAME s_scm_bit_extract
4806 unsigned long int istart
, iend
, bits
;
4807 istart
= scm_to_ulong (start
);
4808 iend
= scm_to_ulong (end
);
4809 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4811 /* how many bits to keep */
4812 bits
= iend
- istart
;
4814 if (SCM_I_INUMP (n
))
4816 scm_t_inum in
= SCM_I_INUM (n
);
4818 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4819 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4820 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4822 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4824 /* Since we emulate two's complement encoded numbers, this
4825 * special case requires us to produce a result that has
4826 * more bits than can be stored in a fixnum.
4828 SCM result
= scm_i_inum2big (in
);
4829 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4834 /* mask down to requisite bits */
4835 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4836 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4838 else if (SCM_BIGP (n
))
4843 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4847 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4848 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4849 such bits into a ulong. */
4850 result
= scm_i_mkbig ();
4851 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4852 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4853 result
= scm_i_normbig (result
);
4855 scm_remember_upto_here_1 (n
);
4859 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4864 static const char scm_logtab
[] = {
4865 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4868 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4870 "Return the number of bits in integer @var{n}. If integer is\n"
4871 "positive, the 1-bits in its binary representation are counted.\n"
4872 "If negative, the 0-bits in its two's-complement binary\n"
4873 "representation are counted. If 0, 0 is returned.\n"
4876 "(logcount #b10101010)\n"
4883 #define FUNC_NAME s_scm_logcount
4885 if (SCM_I_INUMP (n
))
4887 unsigned long c
= 0;
4888 scm_t_inum nn
= SCM_I_INUM (n
);
4893 c
+= scm_logtab
[15 & nn
];
4896 return SCM_I_MAKINUM (c
);
4898 else if (SCM_BIGP (n
))
4900 unsigned long count
;
4901 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4902 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4904 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4905 scm_remember_upto_here_1 (n
);
4906 return SCM_I_MAKINUM (count
);
4909 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4914 static const char scm_ilentab
[] = {
4915 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4919 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4921 "Return the number of bits necessary to represent @var{n}.\n"
4924 "(integer-length #b10101010)\n"
4926 "(integer-length 0)\n"
4928 "(integer-length #b1111)\n"
4931 #define FUNC_NAME s_scm_integer_length
4933 if (SCM_I_INUMP (n
))
4935 unsigned long c
= 0;
4937 scm_t_inum nn
= SCM_I_INUM (n
);
4943 l
= scm_ilentab
[15 & nn
];
4946 return SCM_I_MAKINUM (c
- 4 + l
);
4948 else if (SCM_BIGP (n
))
4950 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4951 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4952 1 too big, so check for that and adjust. */
4953 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4954 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4955 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4956 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4958 scm_remember_upto_here_1 (n
);
4959 return SCM_I_MAKINUM (size
);
4962 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4966 /*** NUMBERS -> STRINGS ***/
4967 #define SCM_MAX_DBL_PREC 60
4968 #define SCM_MAX_DBL_RADIX 36
4970 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4971 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4972 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4975 void init_dblprec(int *prec
, int radix
) {
4976 /* determine floating point precision by adding successively
4977 smaller increments to 1.0 until it is considered == 1.0 */
4978 double f
= ((double)1.0)/radix
;
4979 double fsum
= 1.0 + f
;
4984 if (++(*prec
) > SCM_MAX_DBL_PREC
)
4996 void init_fx_radix(double *fx_list
, int radix
)
4998 /* initialize a per-radix list of tolerances. When added
4999 to a number < 1.0, we can determine if we should raund
5000 up and quit converting a number to a string. */
5004 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5005 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5008 /* use this array as a way to generate a single digit */
5009 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5012 idbl2str (double f
, char *a
, int radix
)
5014 int efmt
, dpt
, d
, i
, wp
;
5016 #ifdef DBL_MIN_10_EXP
5019 #endif /* DBL_MIN_10_EXP */
5024 radix
> SCM_MAX_DBL_RADIX
)
5026 /* revert to existing behavior */
5030 wp
= scm_dblprec
[radix
-2];
5031 fx
= fx_per_radix
[radix
-2];
5035 #ifdef HAVE_COPYSIGN
5036 double sgn
= copysign (1.0, f
);
5041 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5047 strcpy (a
, "-inf.0");
5049 strcpy (a
, "+inf.0");
5054 strcpy (a
, "+nan.0");
5064 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5065 make-uniform-vector, from causing infinite loops. */
5066 /* just do the checking...if it passes, we do the conversion for our
5067 radix again below */
5074 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5082 while (f_cpy
> 10.0)
5085 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5106 if (f
+ fx
[wp
] >= radix
)
5113 /* adding 9999 makes this equivalent to abs(x) % 3 */
5114 dpt
= (exp
+ 9999) % 3;
5118 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5140 a
[ch
++] = number_chars
[d
];
5143 if (f
+ fx
[wp
] >= 1.0)
5145 a
[ch
- 1] = number_chars
[d
+1];
5157 if ((dpt
> 4) && (exp
> 6))
5159 d
= (a
[0] == '-' ? 2 : 1);
5160 for (i
= ch
++; i
> d
; i
--)
5173 if (a
[ch
- 1] == '.')
5174 a
[ch
++] = '0'; /* trailing zero */
5183 for (i
= radix
; i
<= exp
; i
*= radix
);
5184 for (i
/= radix
; i
; i
/= radix
)
5186 a
[ch
++] = number_chars
[exp
/ i
];
5195 icmplx2str (double real
, double imag
, char *str
, int radix
)
5200 i
= idbl2str (real
, str
, radix
);
5201 #ifdef HAVE_COPYSIGN
5202 sgn
= copysign (1.0, imag
);
5206 /* Don't output a '+' for negative numbers or for Inf and
5207 NaN. They will provide their own sign. */
5208 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5210 i
+= idbl2str (imag
, &str
[i
], radix
);
5216 iflo2str (SCM flt
, char *str
, int radix
)
5219 if (SCM_REALP (flt
))
5220 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5222 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5227 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5228 characters in the result.
5230 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5232 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5237 return scm_iuint2str (-num
, rad
, p
) + 1;
5240 return scm_iuint2str (num
, rad
, p
);
5243 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5244 characters in the result.
5246 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5248 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5252 scm_t_uintmax n
= num
;
5254 if (rad
< 2 || rad
> 36)
5255 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5257 for (n
/= rad
; n
> 0; n
/= rad
)
5267 p
[i
] = number_chars
[d
];
5272 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5274 "Return a string holding the external representation of the\n"
5275 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5276 "inexact, a radix of 10 will be used.")
5277 #define FUNC_NAME s_scm_number_to_string
5281 if (SCM_UNBNDP (radix
))
5284 base
= scm_to_signed_integer (radix
, 2, 36);
5286 if (SCM_I_INUMP (n
))
5288 char num_buf
[SCM_INTBUFLEN
];
5289 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5290 return scm_from_locale_stringn (num_buf
, length
);
5292 else if (SCM_BIGP (n
))
5294 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5295 scm_remember_upto_here_1 (n
);
5296 return scm_take_locale_string (str
);
5298 else if (SCM_FRACTIONP (n
))
5300 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5301 scm_from_locale_string ("/"),
5302 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5304 else if (SCM_INEXACTP (n
))
5306 char num_buf
[FLOBUFLEN
];
5307 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5310 SCM_WRONG_TYPE_ARG (1, n
);
5315 /* These print routines used to be stubbed here so that scm_repl.c
5316 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5319 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5321 char num_buf
[FLOBUFLEN
];
5322 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5327 scm_i_print_double (double val
, SCM port
)
5329 char num_buf
[FLOBUFLEN
];
5330 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5334 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5337 char num_buf
[FLOBUFLEN
];
5338 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5343 scm_i_print_complex (double real
, double imag
, SCM port
)
5345 char num_buf
[FLOBUFLEN
];
5346 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5350 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5353 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5354 scm_display (str
, port
);
5355 scm_remember_upto_here_1 (str
);
5360 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5362 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5363 scm_remember_upto_here_1 (exp
);
5364 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5368 /*** END nums->strs ***/
5371 /*** STRINGS -> NUMBERS ***/
5373 /* The following functions implement the conversion from strings to numbers.
5374 * The implementation somehow follows the grammar for numbers as it is given
5375 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5376 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5377 * points should be noted about the implementation:
5379 * * Each function keeps a local index variable 'idx' that points at the
5380 * current position within the parsed string. The global index is only
5381 * updated if the function could parse the corresponding syntactic unit
5384 * * Similarly, the functions keep track of indicators of inexactness ('#',
5385 * '.' or exponents) using local variables ('hash_seen', 'x').
5387 * * Sequences of digits are parsed into temporary variables holding fixnums.
5388 * Only if these fixnums would overflow, the result variables are updated
5389 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5390 * the temporary variables holding the fixnums are cleared, and the process
5391 * starts over again. If for example fixnums were able to store five decimal
5392 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5393 * and the result was computed as 12345 * 100000 + 67890. In other words,
5394 * only every five digits two bignum operations were performed.
5396 * Notes on the handling of exactness specifiers:
5398 * When parsing non-real complex numbers, we apply exactness specifiers on
5399 * per-component basis, as is done in PLT Scheme. For complex numbers
5400 * written in rectangular form, exactness specifiers are applied to the
5401 * real and imaginary parts before calling scm_make_rectangular. For
5402 * complex numbers written in polar form, exactness specifiers are applied
5403 * to the magnitude and angle before calling scm_make_polar.
5405 * There are two kinds of exactness specifiers: forced and implicit. A
5406 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5407 * the entire number, and applies to both components of a complex number.
5408 * "#e" causes each component to be made exact, and "#i" causes each
5409 * component to be made inexact. If no forced exactness specifier is
5410 * present, then the exactness of each component is determined
5411 * independently by the presence or absence of a decimal point or hash mark
5412 * within that component. If a decimal point or hash mark is present, the
5413 * component is made inexact, otherwise it is made exact.
5415 * After the exactness specifiers have been applied to each component, they
5416 * are passed to either scm_make_rectangular or scm_make_polar to produce
5417 * the final result. Note that this will result in a real number if the
5418 * imaginary part, magnitude, or angle is an exact 0.
5420 * For example, (string->number "#i5.0+0i") does the equivalent of:
5422 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5425 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5427 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5429 /* Caller is responsible for checking that the return value is in range
5430 for the given radix, which should be <= 36. */
5432 char_decimal_value (scm_t_uint32 c
)
5434 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5435 that's certainly above any valid decimal, so we take advantage of
5436 that to elide some tests. */
5437 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5439 /* If that failed, try extended hexadecimals, then. Only accept ascii
5444 if (c
>= (scm_t_uint32
) 'a')
5445 d
= c
- (scm_t_uint32
)'a' + 10U;
5451 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5452 unsigned int radix
, enum t_exactness
*p_exactness
)
5454 unsigned int idx
= *p_idx
;
5455 unsigned int hash_seen
= 0;
5456 scm_t_bits shift
= 1;
5458 unsigned int digit_value
;
5461 size_t len
= scm_i_string_length (mem
);
5466 c
= scm_i_string_ref (mem
, idx
);
5467 digit_value
= char_decimal_value (c
);
5468 if (digit_value
>= radix
)
5472 result
= SCM_I_MAKINUM (digit_value
);
5475 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5485 digit_value
= char_decimal_value (c
);
5486 /* This check catches non-decimals in addition to out-of-range
5488 if (digit_value
>= radix
)
5493 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5495 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5497 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5504 shift
= shift
* radix
;
5505 add
= add
* radix
+ digit_value
;
5510 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5512 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5516 *p_exactness
= INEXACT
;
5522 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5523 * covers the parts of the rules that start at a potential point. The value
5524 * of the digits up to the point have been parsed by the caller and are given
5525 * in variable result. The content of *p_exactness indicates, whether a hash
5526 * has already been seen in the digits before the point.
5529 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5532 mem2decimal_from_point (SCM result
, SCM mem
,
5533 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5535 unsigned int idx
= *p_idx
;
5536 enum t_exactness x
= *p_exactness
;
5537 size_t len
= scm_i_string_length (mem
);
5542 if (scm_i_string_ref (mem
, idx
) == '.')
5544 scm_t_bits shift
= 1;
5546 unsigned int digit_value
;
5547 SCM big_shift
= SCM_INUM1
;
5552 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5553 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5558 digit_value
= DIGIT2UINT (c
);
5569 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5571 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5572 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5574 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5582 add
= add
* 10 + digit_value
;
5588 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5589 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5590 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5593 result
= scm_divide (result
, big_shift
);
5595 /* We've seen a decimal point, thus the value is implicitly inexact. */
5607 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5609 switch (scm_i_string_ref (mem
, idx
))
5621 c
= scm_i_string_ref (mem
, idx
);
5629 c
= scm_i_string_ref (mem
, idx
);
5638 c
= scm_i_string_ref (mem
, idx
);
5643 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5647 exponent
= DIGIT2UINT (c
);
5650 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5651 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5654 if (exponent
<= SCM_MAXEXP
)
5655 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5661 if (exponent
> SCM_MAXEXP
)
5663 size_t exp_len
= idx
- start
;
5664 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5665 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5666 scm_out_of_range ("string->number", exp_num
);
5669 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5671 result
= scm_product (result
, e
);
5673 result
= scm_divide (result
, e
);
5675 /* We've seen an exponent, thus the value is implicitly inexact. */
5693 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5696 mem2ureal (SCM mem
, unsigned int *p_idx
,
5697 unsigned int radix
, enum t_exactness forced_x
)
5699 unsigned int idx
= *p_idx
;
5701 size_t len
= scm_i_string_length (mem
);
5703 /* Start off believing that the number will be exact. This changes
5704 to INEXACT if we see a decimal point or a hash. */
5705 enum t_exactness implicit_x
= EXACT
;
5710 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5716 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5718 /* Cobble up the fractional part. We might want to set the
5719 NaN's mantissa from it. */
5721 mem2uinteger (mem
, &idx
, 10, &implicit_x
);
5726 if (scm_i_string_ref (mem
, idx
) == '.')
5730 else if (idx
+ 1 == len
)
5732 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5735 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5736 p_idx
, &implicit_x
);
5742 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5743 if (scm_is_false (uinteger
))
5748 else if (scm_i_string_ref (mem
, idx
) == '/')
5756 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5757 if (scm_is_false (divisor
))
5760 /* both are int/big here, I assume */
5761 result
= scm_i_make_ratio (uinteger
, divisor
);
5763 else if (radix
== 10)
5765 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5766 if (scm_is_false (result
))
5778 if (SCM_INEXACTP (result
))
5779 return scm_inexact_to_exact (result
);
5783 if (SCM_INEXACTP (result
))
5786 return scm_exact_to_inexact (result
);
5788 if (implicit_x
== INEXACT
)
5790 if (SCM_INEXACTP (result
))
5793 return scm_exact_to_inexact (result
);
5799 /* We should never get here */
5800 scm_syserror ("mem2ureal");
5804 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5807 mem2complex (SCM mem
, unsigned int idx
,
5808 unsigned int radix
, enum t_exactness forced_x
)
5813 size_t len
= scm_i_string_length (mem
);
5818 c
= scm_i_string_ref (mem
, idx
);
5833 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5834 if (scm_is_false (ureal
))
5836 /* input must be either +i or -i */
5841 if (scm_i_string_ref (mem
, idx
) == 'i'
5842 || scm_i_string_ref (mem
, idx
) == 'I')
5848 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5855 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5856 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5861 c
= scm_i_string_ref (mem
, idx
);
5865 /* either +<ureal>i or -<ureal>i */
5872 return scm_make_rectangular (SCM_INUM0
, ureal
);
5875 /* polar input: <real>@<real>. */
5886 c
= scm_i_string_ref (mem
, idx
);
5904 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5905 if (scm_is_false (angle
))
5910 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5911 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5913 result
= scm_make_polar (ureal
, angle
);
5918 /* expecting input matching <real>[+-]<ureal>?i */
5925 int sign
= (c
== '+') ? 1 : -1;
5926 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5928 if (scm_is_false (imag
))
5929 imag
= SCM_I_MAKINUM (sign
);
5930 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5931 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5935 if (scm_i_string_ref (mem
, idx
) != 'i'
5936 && scm_i_string_ref (mem
, idx
) != 'I')
5943 return scm_make_rectangular (ureal
, imag
);
5952 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5954 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5957 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5959 unsigned int idx
= 0;
5960 unsigned int radix
= NO_RADIX
;
5961 enum t_exactness forced_x
= NO_EXACTNESS
;
5962 size_t len
= scm_i_string_length (mem
);
5964 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5965 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5967 switch (scm_i_string_ref (mem
, idx
+ 1))
5970 if (radix
!= NO_RADIX
)
5975 if (radix
!= NO_RADIX
)
5980 if (forced_x
!= NO_EXACTNESS
)
5985 if (forced_x
!= NO_EXACTNESS
)
5990 if (radix
!= NO_RADIX
)
5995 if (radix
!= NO_RADIX
)
6005 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6006 if (radix
== NO_RADIX
)
6007 radix
= default_radix
;
6009 return mem2complex (mem
, idx
, radix
, forced_x
);
6013 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6014 unsigned int default_radix
)
6016 SCM str
= scm_from_locale_stringn (mem
, len
);
6018 return scm_i_string_to_number (str
, default_radix
);
6022 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6023 (SCM string
, SCM radix
),
6024 "Return a number of the maximally precise representation\n"
6025 "expressed by the given @var{string}. @var{radix} must be an\n"
6026 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6027 "is a default radix that may be overridden by an explicit radix\n"
6028 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6029 "supplied, then the default radix is 10. If string is not a\n"
6030 "syntactically valid notation for a number, then\n"
6031 "@code{string->number} returns @code{#f}.")
6032 #define FUNC_NAME s_scm_string_to_number
6036 SCM_VALIDATE_STRING (1, string
);
6038 if (SCM_UNBNDP (radix
))
6041 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6043 answer
= scm_i_string_to_number (string
, base
);
6044 scm_remember_upto_here_1 (string
);
6050 /*** END strs->nums ***/
6053 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6055 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6057 #define FUNC_NAME s_scm_number_p
6059 return scm_from_bool (SCM_NUMBERP (x
));
6063 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6065 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6066 "otherwise. Note that the sets of real, rational and integer\n"
6067 "values form subsets of the set of complex numbers, i. e. the\n"
6068 "predicate will also be fulfilled if @var{x} is a real,\n"
6069 "rational or integer number.")
6070 #define FUNC_NAME s_scm_complex_p
6072 /* all numbers are complex. */
6073 return scm_number_p (x
);
6077 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6079 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6080 "otherwise. Note that the set of integer values forms a subset of\n"
6081 "the set of real numbers, i. e. the predicate will also be\n"
6082 "fulfilled if @var{x} is an integer number.")
6083 #define FUNC_NAME s_scm_real_p
6085 return scm_from_bool
6086 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6090 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6092 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6093 "otherwise. Note that the set of integer values forms a subset of\n"
6094 "the set of rational numbers, i. e. the predicate will also be\n"
6095 "fulfilled if @var{x} is an integer number.")
6096 #define FUNC_NAME s_scm_rational_p
6098 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6100 else if (SCM_REALP (x
))
6101 /* due to their limited precision, finite floating point numbers are
6102 rational as well. (finite means neither infinity nor a NaN) */
6103 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6109 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6111 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6113 #define FUNC_NAME s_scm_integer_p
6115 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6117 else if (SCM_REALP (x
))
6119 double val
= SCM_REAL_VALUE (x
);
6120 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6128 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6129 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6130 (SCM x
, SCM y
, SCM rest
),
6131 "Return @code{#t} if all parameters are numerically equal.")
6132 #define FUNC_NAME s_scm_i_num_eq_p
6134 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6136 while (!scm_is_null (rest
))
6138 if (scm_is_false (scm_num_eq_p (x
, y
)))
6142 rest
= scm_cdr (rest
);
6144 return scm_num_eq_p (x
, y
);
6148 scm_num_eq_p (SCM x
, SCM y
)
6151 if (SCM_I_INUMP (x
))
6153 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6154 if (SCM_I_INUMP (y
))
6156 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6157 return scm_from_bool (xx
== yy
);
6159 else if (SCM_BIGP (y
))
6161 else if (SCM_REALP (y
))
6163 /* On a 32-bit system an inum fits a double, we can cast the inum
6164 to a double and compare.
6166 But on a 64-bit system an inum is bigger than a double and
6167 casting it to a double (call that dxx) will round. dxx is at
6168 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6169 an integer and fits a long. So we cast yy to a long and
6170 compare with plain xx.
6172 An alternative (for any size system actually) would be to check
6173 yy is an integer (with floor) and is in range of an inum
6174 (compare against appropriate powers of 2) then test
6175 xx==(scm_t_signed_bits)yy. It's just a matter of which
6176 casts/comparisons might be fastest or easiest for the cpu. */
6178 double yy
= SCM_REAL_VALUE (y
);
6179 return scm_from_bool ((double) xx
== yy
6180 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6181 || xx
== (scm_t_signed_bits
) yy
));
6183 else if (SCM_COMPLEXP (y
))
6184 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6185 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6186 else if (SCM_FRACTIONP (y
))
6189 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6191 else if (SCM_BIGP (x
))
6193 if (SCM_I_INUMP (y
))
6195 else if (SCM_BIGP (y
))
6197 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6198 scm_remember_upto_here_2 (x
, y
);
6199 return scm_from_bool (0 == cmp
);
6201 else if (SCM_REALP (y
))
6204 if (isnan (SCM_REAL_VALUE (y
)))
6206 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6207 scm_remember_upto_here_1 (x
);
6208 return scm_from_bool (0 == cmp
);
6210 else if (SCM_COMPLEXP (y
))
6213 if (0.0 != SCM_COMPLEX_IMAG (y
))
6215 if (isnan (SCM_COMPLEX_REAL (y
)))
6217 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6218 scm_remember_upto_here_1 (x
);
6219 return scm_from_bool (0 == cmp
);
6221 else if (SCM_FRACTIONP (y
))
6224 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6226 else if (SCM_REALP (x
))
6228 double xx
= SCM_REAL_VALUE (x
);
6229 if (SCM_I_INUMP (y
))
6231 /* see comments with inum/real above */
6232 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6233 return scm_from_bool (xx
== (double) yy
6234 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6235 || (scm_t_signed_bits
) xx
== yy
));
6237 else if (SCM_BIGP (y
))
6240 if (isnan (SCM_REAL_VALUE (x
)))
6242 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6243 scm_remember_upto_here_1 (y
);
6244 return scm_from_bool (0 == cmp
);
6246 else if (SCM_REALP (y
))
6247 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6248 else if (SCM_COMPLEXP (y
))
6249 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6250 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6251 else if (SCM_FRACTIONP (y
))
6253 double xx
= SCM_REAL_VALUE (x
);
6257 return scm_from_bool (xx
< 0.0);
6258 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6262 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6264 else if (SCM_COMPLEXP (x
))
6266 if (SCM_I_INUMP (y
))
6267 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6268 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6269 else if (SCM_BIGP (y
))
6272 if (0.0 != SCM_COMPLEX_IMAG (x
))
6274 if (isnan (SCM_COMPLEX_REAL (x
)))
6276 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6277 scm_remember_upto_here_1 (y
);
6278 return scm_from_bool (0 == cmp
);
6280 else if (SCM_REALP (y
))
6281 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6282 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6283 else if (SCM_COMPLEXP (y
))
6284 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6285 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6286 else if (SCM_FRACTIONP (y
))
6289 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6291 xx
= SCM_COMPLEX_REAL (x
);
6295 return scm_from_bool (xx
< 0.0);
6296 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6300 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6302 else if (SCM_FRACTIONP (x
))
6304 if (SCM_I_INUMP (y
))
6306 else if (SCM_BIGP (y
))
6308 else if (SCM_REALP (y
))
6310 double yy
= SCM_REAL_VALUE (y
);
6314 return scm_from_bool (0.0 < yy
);
6315 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6318 else if (SCM_COMPLEXP (y
))
6321 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6323 yy
= SCM_COMPLEX_REAL (y
);
6327 return scm_from_bool (0.0 < yy
);
6328 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6331 else if (SCM_FRACTIONP (y
))
6332 return scm_i_fraction_equalp (x
, y
);
6334 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6337 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6341 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6342 done are good for inums, but for bignums an answer can almost always be
6343 had by just examining a few high bits of the operands, as done by GMP in
6344 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6345 of the float exponent to take into account. */
6347 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6348 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6349 (SCM x
, SCM y
, SCM rest
),
6350 "Return @code{#t} if the list of parameters is monotonically\n"
6352 #define FUNC_NAME s_scm_i_num_less_p
6354 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6356 while (!scm_is_null (rest
))
6358 if (scm_is_false (scm_less_p (x
, y
)))
6362 rest
= scm_cdr (rest
);
6364 return scm_less_p (x
, y
);
6368 scm_less_p (SCM x
, SCM y
)
6371 if (SCM_I_INUMP (x
))
6373 scm_t_inum xx
= SCM_I_INUM (x
);
6374 if (SCM_I_INUMP (y
))
6376 scm_t_inum yy
= SCM_I_INUM (y
);
6377 return scm_from_bool (xx
< yy
);
6379 else if (SCM_BIGP (y
))
6381 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6382 scm_remember_upto_here_1 (y
);
6383 return scm_from_bool (sgn
> 0);
6385 else if (SCM_REALP (y
))
6386 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6387 else if (SCM_FRACTIONP (y
))
6389 /* "x < a/b" becomes "x*b < a" */
6391 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6392 y
= SCM_FRACTION_NUMERATOR (y
);
6396 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6398 else if (SCM_BIGP (x
))
6400 if (SCM_I_INUMP (y
))
6402 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6403 scm_remember_upto_here_1 (x
);
6404 return scm_from_bool (sgn
< 0);
6406 else if (SCM_BIGP (y
))
6408 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6409 scm_remember_upto_here_2 (x
, y
);
6410 return scm_from_bool (cmp
< 0);
6412 else if (SCM_REALP (y
))
6415 if (isnan (SCM_REAL_VALUE (y
)))
6417 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6418 scm_remember_upto_here_1 (x
);
6419 return scm_from_bool (cmp
< 0);
6421 else if (SCM_FRACTIONP (y
))
6424 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6426 else if (SCM_REALP (x
))
6428 if (SCM_I_INUMP (y
))
6429 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6430 else if (SCM_BIGP (y
))
6433 if (isnan (SCM_REAL_VALUE (x
)))
6435 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6436 scm_remember_upto_here_1 (y
);
6437 return scm_from_bool (cmp
> 0);
6439 else if (SCM_REALP (y
))
6440 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6441 else if (SCM_FRACTIONP (y
))
6443 double xx
= SCM_REAL_VALUE (x
);
6447 return scm_from_bool (xx
< 0.0);
6448 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6452 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6454 else if (SCM_FRACTIONP (x
))
6456 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6458 /* "a/b < y" becomes "a < y*b" */
6459 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6460 x
= SCM_FRACTION_NUMERATOR (x
);
6463 else if (SCM_REALP (y
))
6465 double yy
= SCM_REAL_VALUE (y
);
6469 return scm_from_bool (0.0 < yy
);
6470 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6473 else if (SCM_FRACTIONP (y
))
6475 /* "a/b < c/d" becomes "a*d < c*b" */
6476 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6477 SCM_FRACTION_DENOMINATOR (y
));
6478 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6479 SCM_FRACTION_DENOMINATOR (x
));
6485 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6488 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6492 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6493 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6494 (SCM x
, SCM y
, SCM rest
),
6495 "Return @code{#t} if the list of parameters is monotonically\n"
6497 #define FUNC_NAME s_scm_i_num_gr_p
6499 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6501 while (!scm_is_null (rest
))
6503 if (scm_is_false (scm_gr_p (x
, y
)))
6507 rest
= scm_cdr (rest
);
6509 return scm_gr_p (x
, y
);
6512 #define FUNC_NAME s_scm_i_num_gr_p
6514 scm_gr_p (SCM x
, SCM y
)
6516 if (!SCM_NUMBERP (x
))
6517 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6518 else if (!SCM_NUMBERP (y
))
6519 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6521 return scm_less_p (y
, x
);
6526 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6527 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6528 (SCM x
, SCM y
, SCM rest
),
6529 "Return @code{#t} if the list of parameters is monotonically\n"
6531 #define FUNC_NAME s_scm_i_num_leq_p
6533 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6535 while (!scm_is_null (rest
))
6537 if (scm_is_false (scm_leq_p (x
, y
)))
6541 rest
= scm_cdr (rest
);
6543 return scm_leq_p (x
, y
);
6546 #define FUNC_NAME s_scm_i_num_leq_p
6548 scm_leq_p (SCM x
, SCM y
)
6550 if (!SCM_NUMBERP (x
))
6551 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6552 else if (!SCM_NUMBERP (y
))
6553 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6554 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6557 return scm_not (scm_less_p (y
, x
));
6562 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6563 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6564 (SCM x
, SCM y
, SCM rest
),
6565 "Return @code{#t} if the list of parameters is monotonically\n"
6567 #define FUNC_NAME s_scm_i_num_geq_p
6569 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6571 while (!scm_is_null (rest
))
6573 if (scm_is_false (scm_geq_p (x
, y
)))
6577 rest
= scm_cdr (rest
);
6579 return scm_geq_p (x
, y
);
6582 #define FUNC_NAME s_scm_i_num_geq_p
6584 scm_geq_p (SCM x
, SCM y
)
6586 if (!SCM_NUMBERP (x
))
6587 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6588 else if (!SCM_NUMBERP (y
))
6589 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6590 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6593 return scm_not (scm_less_p (x
, y
));
6598 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6600 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6602 #define FUNC_NAME s_scm_zero_p
6604 if (SCM_I_INUMP (z
))
6605 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6606 else if (SCM_BIGP (z
))
6608 else if (SCM_REALP (z
))
6609 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6610 else if (SCM_COMPLEXP (z
))
6611 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6612 && SCM_COMPLEX_IMAG (z
) == 0.0);
6613 else if (SCM_FRACTIONP (z
))
6616 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6621 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6623 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6625 #define FUNC_NAME s_scm_positive_p
6627 if (SCM_I_INUMP (x
))
6628 return scm_from_bool (SCM_I_INUM (x
) > 0);
6629 else if (SCM_BIGP (x
))
6631 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6632 scm_remember_upto_here_1 (x
);
6633 return scm_from_bool (sgn
> 0);
6635 else if (SCM_REALP (x
))
6636 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6637 else if (SCM_FRACTIONP (x
))
6638 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6640 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6645 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6647 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6649 #define FUNC_NAME s_scm_negative_p
6651 if (SCM_I_INUMP (x
))
6652 return scm_from_bool (SCM_I_INUM (x
) < 0);
6653 else if (SCM_BIGP (x
))
6655 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6656 scm_remember_upto_here_1 (x
);
6657 return scm_from_bool (sgn
< 0);
6659 else if (SCM_REALP (x
))
6660 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6661 else if (SCM_FRACTIONP (x
))
6662 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6664 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6669 /* scm_min and scm_max return an inexact when either argument is inexact, as
6670 required by r5rs. On that basis, for exact/inexact combinations the
6671 exact is converted to inexact to compare and possibly return. This is
6672 unlike scm_less_p above which takes some trouble to preserve all bits in
6673 its test, such trouble is not required for min and max. */
6675 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6676 (SCM x
, SCM y
, SCM rest
),
6677 "Return the maximum of all parameter values.")
6678 #define FUNC_NAME s_scm_i_max
6680 while (!scm_is_null (rest
))
6681 { x
= scm_max (x
, y
);
6683 rest
= scm_cdr (rest
);
6685 return scm_max (x
, y
);
6689 #define s_max s_scm_i_max
6690 #define g_max g_scm_i_max
6693 scm_max (SCM x
, SCM y
)
6698 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6699 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6702 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6705 if (SCM_I_INUMP (x
))
6707 scm_t_inum xx
= SCM_I_INUM (x
);
6708 if (SCM_I_INUMP (y
))
6710 scm_t_inum yy
= SCM_I_INUM (y
);
6711 return (xx
< yy
) ? y
: x
;
6713 else if (SCM_BIGP (y
))
6715 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6716 scm_remember_upto_here_1 (y
);
6717 return (sgn
< 0) ? x
: y
;
6719 else if (SCM_REALP (y
))
6722 double yyd
= SCM_REAL_VALUE (y
);
6725 return scm_from_double (xxd
);
6726 /* If y is a NaN, then "==" is false and we return the NaN */
6727 else if (SCM_LIKELY (!(xxd
== yyd
)))
6729 /* Handle signed zeroes properly */
6735 else if (SCM_FRACTIONP (y
))
6738 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6741 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6743 else if (SCM_BIGP (x
))
6745 if (SCM_I_INUMP (y
))
6747 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6748 scm_remember_upto_here_1 (x
);
6749 return (sgn
< 0) ? y
: x
;
6751 else if (SCM_BIGP (y
))
6753 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6754 scm_remember_upto_here_2 (x
, y
);
6755 return (cmp
> 0) ? x
: y
;
6757 else if (SCM_REALP (y
))
6759 /* if y==NaN then xx>yy is false, so we return the NaN y */
6762 xx
= scm_i_big2dbl (x
);
6763 yy
= SCM_REAL_VALUE (y
);
6764 return (xx
> yy
? scm_from_double (xx
) : y
);
6766 else if (SCM_FRACTIONP (y
))
6771 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6773 else if (SCM_REALP (x
))
6775 if (SCM_I_INUMP (y
))
6777 scm_t_inum yy
= SCM_I_INUM (y
);
6778 double xxd
= SCM_REAL_VALUE (x
);
6782 return scm_from_double (yyd
);
6783 /* If x is a NaN, then "==" is false and we return the NaN */
6784 else if (SCM_LIKELY (!(xxd
== yyd
)))
6786 /* Handle signed zeroes properly */
6792 else if (SCM_BIGP (y
))
6797 else if (SCM_REALP (y
))
6799 double xx
= SCM_REAL_VALUE (x
);
6800 double yy
= SCM_REAL_VALUE (y
);
6802 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6805 else if (SCM_LIKELY (xx
< yy
))
6807 /* If neither (xx > yy) nor (xx < yy), then
6808 either they're equal or one is a NaN */
6809 else if (SCM_UNLIKELY (isnan (xx
)))
6810 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6811 else if (SCM_UNLIKELY (isnan (yy
)))
6812 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6813 /* xx == yy, but handle signed zeroes properly */
6814 else if (double_is_non_negative_zero (yy
))
6819 else if (SCM_FRACTIONP (y
))
6821 double yy
= scm_i_fraction2double (y
);
6822 double xx
= SCM_REAL_VALUE (x
);
6823 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6826 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6828 else if (SCM_FRACTIONP (x
))
6830 if (SCM_I_INUMP (y
))
6834 else if (SCM_BIGP (y
))
6838 else if (SCM_REALP (y
))
6840 double xx
= scm_i_fraction2double (x
);
6841 /* if y==NaN then ">" is false, so we return the NaN y */
6842 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6844 else if (SCM_FRACTIONP (y
))
6849 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6852 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6856 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6857 (SCM x
, SCM y
, SCM rest
),
6858 "Return the minimum of all parameter values.")
6859 #define FUNC_NAME s_scm_i_min
6861 while (!scm_is_null (rest
))
6862 { x
= scm_min (x
, y
);
6864 rest
= scm_cdr (rest
);
6866 return scm_min (x
, y
);
6870 #define s_min s_scm_i_min
6871 #define g_min g_scm_i_min
6874 scm_min (SCM x
, SCM y
)
6879 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6880 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6883 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6886 if (SCM_I_INUMP (x
))
6888 scm_t_inum xx
= SCM_I_INUM (x
);
6889 if (SCM_I_INUMP (y
))
6891 scm_t_inum yy
= SCM_I_INUM (y
);
6892 return (xx
< yy
) ? x
: y
;
6894 else if (SCM_BIGP (y
))
6896 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6897 scm_remember_upto_here_1 (y
);
6898 return (sgn
< 0) ? y
: x
;
6900 else if (SCM_REALP (y
))
6903 /* if y==NaN then "<" is false and we return NaN */
6904 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6906 else if (SCM_FRACTIONP (y
))
6909 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6912 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6914 else if (SCM_BIGP (x
))
6916 if (SCM_I_INUMP (y
))
6918 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6919 scm_remember_upto_here_1 (x
);
6920 return (sgn
< 0) ? x
: y
;
6922 else if (SCM_BIGP (y
))
6924 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6925 scm_remember_upto_here_2 (x
, y
);
6926 return (cmp
> 0) ? y
: x
;
6928 else if (SCM_REALP (y
))
6930 /* if y==NaN then xx<yy is false, so we return the NaN y */
6933 xx
= scm_i_big2dbl (x
);
6934 yy
= SCM_REAL_VALUE (y
);
6935 return (xx
< yy
? scm_from_double (xx
) : y
);
6937 else if (SCM_FRACTIONP (y
))
6942 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6944 else if (SCM_REALP (x
))
6946 if (SCM_I_INUMP (y
))
6948 double z
= SCM_I_INUM (y
);
6949 /* if x==NaN then "<" is false and we return NaN */
6950 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6952 else if (SCM_BIGP (y
))
6957 else if (SCM_REALP (y
))
6959 double xx
= SCM_REAL_VALUE (x
);
6960 double yy
= SCM_REAL_VALUE (y
);
6962 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6965 else if (SCM_LIKELY (xx
> yy
))
6967 /* If neither (xx < yy) nor (xx > yy), then
6968 either they're equal or one is a NaN */
6969 else if (SCM_UNLIKELY (isnan (xx
)))
6970 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6971 else if (SCM_UNLIKELY (isnan (yy
)))
6972 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6973 /* xx == yy, but handle signed zeroes properly */
6974 else if (double_is_non_negative_zero (xx
))
6979 else if (SCM_FRACTIONP (y
))
6981 double yy
= scm_i_fraction2double (y
);
6982 double xx
= SCM_REAL_VALUE (x
);
6983 return (yy
< xx
) ? scm_from_double (yy
) : x
;
6986 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6988 else if (SCM_FRACTIONP (x
))
6990 if (SCM_I_INUMP (y
))
6994 else if (SCM_BIGP (y
))
6998 else if (SCM_REALP (y
))
7000 double xx
= scm_i_fraction2double (x
);
7001 /* if y==NaN then "<" is false, so we return the NaN y */
7002 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7004 else if (SCM_FRACTIONP (y
))
7009 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7012 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7016 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7017 (SCM x
, SCM y
, SCM rest
),
7018 "Return the sum of all parameter values. Return 0 if called without\n"
7020 #define FUNC_NAME s_scm_i_sum
7022 while (!scm_is_null (rest
))
7023 { x
= scm_sum (x
, y
);
7025 rest
= scm_cdr (rest
);
7027 return scm_sum (x
, y
);
7031 #define s_sum s_scm_i_sum
7032 #define g_sum g_scm_i_sum
7035 scm_sum (SCM x
, SCM y
)
7037 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7039 if (SCM_NUMBERP (x
)) return x
;
7040 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7041 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7044 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7046 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7048 scm_t_inum xx
= SCM_I_INUM (x
);
7049 scm_t_inum yy
= SCM_I_INUM (y
);
7050 scm_t_inum z
= xx
+ yy
;
7051 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7053 else if (SCM_BIGP (y
))
7058 else if (SCM_REALP (y
))
7060 scm_t_inum xx
= SCM_I_INUM (x
);
7061 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7063 else if (SCM_COMPLEXP (y
))
7065 scm_t_inum xx
= SCM_I_INUM (x
);
7066 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7067 SCM_COMPLEX_IMAG (y
));
7069 else if (SCM_FRACTIONP (y
))
7070 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7071 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7072 SCM_FRACTION_DENOMINATOR (y
));
7074 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7075 } else if (SCM_BIGP (x
))
7077 if (SCM_I_INUMP (y
))
7082 inum
= SCM_I_INUM (y
);
7085 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7088 SCM result
= scm_i_mkbig ();
7089 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7090 scm_remember_upto_here_1 (x
);
7091 /* we know the result will have to be a bignum */
7094 return scm_i_normbig (result
);
7098 SCM result
= scm_i_mkbig ();
7099 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7100 scm_remember_upto_here_1 (x
);
7101 /* we know the result will have to be a bignum */
7104 return scm_i_normbig (result
);
7107 else if (SCM_BIGP (y
))
7109 SCM result
= scm_i_mkbig ();
7110 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7111 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7112 mpz_add (SCM_I_BIG_MPZ (result
),
7115 scm_remember_upto_here_2 (x
, y
);
7116 /* we know the result will have to be a bignum */
7119 return scm_i_normbig (result
);
7121 else if (SCM_REALP (y
))
7123 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7124 scm_remember_upto_here_1 (x
);
7125 return scm_from_double (result
);
7127 else if (SCM_COMPLEXP (y
))
7129 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7130 + SCM_COMPLEX_REAL (y
));
7131 scm_remember_upto_here_1 (x
);
7132 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7134 else if (SCM_FRACTIONP (y
))
7135 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7136 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7137 SCM_FRACTION_DENOMINATOR (y
));
7139 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7141 else if (SCM_REALP (x
))
7143 if (SCM_I_INUMP (y
))
7144 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7145 else if (SCM_BIGP (y
))
7147 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7148 scm_remember_upto_here_1 (y
);
7149 return scm_from_double (result
);
7151 else if (SCM_REALP (y
))
7152 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7153 else if (SCM_COMPLEXP (y
))
7154 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7155 SCM_COMPLEX_IMAG (y
));
7156 else if (SCM_FRACTIONP (y
))
7157 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7159 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7161 else if (SCM_COMPLEXP (x
))
7163 if (SCM_I_INUMP (y
))
7164 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7165 SCM_COMPLEX_IMAG (x
));
7166 else if (SCM_BIGP (y
))
7168 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7169 + SCM_COMPLEX_REAL (x
));
7170 scm_remember_upto_here_1 (y
);
7171 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7173 else if (SCM_REALP (y
))
7174 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7175 SCM_COMPLEX_IMAG (x
));
7176 else if (SCM_COMPLEXP (y
))
7177 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7178 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7179 else if (SCM_FRACTIONP (y
))
7180 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7181 SCM_COMPLEX_IMAG (x
));
7183 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7185 else if (SCM_FRACTIONP (x
))
7187 if (SCM_I_INUMP (y
))
7188 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7189 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7190 SCM_FRACTION_DENOMINATOR (x
));
7191 else if (SCM_BIGP (y
))
7192 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7193 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7194 SCM_FRACTION_DENOMINATOR (x
));
7195 else if (SCM_REALP (y
))
7196 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7197 else if (SCM_COMPLEXP (y
))
7198 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7199 SCM_COMPLEX_IMAG (y
));
7200 else if (SCM_FRACTIONP (y
))
7201 /* a/b + c/d = (ad + bc) / bd */
7202 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7203 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7204 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7206 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7209 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7213 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7215 "Return @math{@var{x}+1}.")
7216 #define FUNC_NAME s_scm_oneplus
7218 return scm_sum (x
, SCM_INUM1
);
7223 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7224 (SCM x
, SCM y
, SCM rest
),
7225 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7226 "the sum of all but the first argument are subtracted from the first\n"
7228 #define FUNC_NAME s_scm_i_difference
7230 while (!scm_is_null (rest
))
7231 { x
= scm_difference (x
, y
);
7233 rest
= scm_cdr (rest
);
7235 return scm_difference (x
, y
);
7239 #define s_difference s_scm_i_difference
7240 #define g_difference g_scm_i_difference
7243 scm_difference (SCM x
, SCM y
)
7244 #define FUNC_NAME s_difference
7246 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7249 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7251 if (SCM_I_INUMP (x
))
7253 scm_t_inum xx
= -SCM_I_INUM (x
);
7254 if (SCM_FIXABLE (xx
))
7255 return SCM_I_MAKINUM (xx
);
7257 return scm_i_inum2big (xx
);
7259 else if (SCM_BIGP (x
))
7260 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7261 bignum, but negating that gives a fixnum. */
7262 return scm_i_normbig (scm_i_clonebig (x
, 0));
7263 else if (SCM_REALP (x
))
7264 return scm_from_double (-SCM_REAL_VALUE (x
));
7265 else if (SCM_COMPLEXP (x
))
7266 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7267 -SCM_COMPLEX_IMAG (x
));
7268 else if (SCM_FRACTIONP (x
))
7269 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7270 SCM_FRACTION_DENOMINATOR (x
));
7272 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7275 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7277 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7279 scm_t_inum xx
= SCM_I_INUM (x
);
7280 scm_t_inum yy
= SCM_I_INUM (y
);
7281 scm_t_inum z
= xx
- yy
;
7282 if (SCM_FIXABLE (z
))
7283 return SCM_I_MAKINUM (z
);
7285 return scm_i_inum2big (z
);
7287 else if (SCM_BIGP (y
))
7289 /* inum-x - big-y */
7290 scm_t_inum xx
= SCM_I_INUM (x
);
7294 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7295 bignum, but negating that gives a fixnum. */
7296 return scm_i_normbig (scm_i_clonebig (y
, 0));
7300 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7301 SCM result
= scm_i_mkbig ();
7304 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7307 /* x - y == -(y + -x) */
7308 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7309 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7311 scm_remember_upto_here_1 (y
);
7313 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7314 /* we know the result will have to be a bignum */
7317 return scm_i_normbig (result
);
7320 else if (SCM_REALP (y
))
7322 scm_t_inum xx
= SCM_I_INUM (x
);
7325 * We need to handle x == exact 0
7326 * specially because R6RS states that:
7327 * (- 0.0) ==> -0.0 and
7328 * (- 0.0 0.0) ==> 0.0
7329 * and the scheme compiler changes
7330 * (- 0.0) into (- 0 0.0)
7331 * So we need to treat (- 0 0.0) like (- 0.0).
7332 * At the C level, (-x) is different than (0.0 - x).
7333 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7336 return scm_from_double (- SCM_REAL_VALUE (y
));
7338 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7340 else if (SCM_COMPLEXP (y
))
7342 scm_t_inum xx
= SCM_I_INUM (x
);
7344 /* We need to handle x == exact 0 specially.
7345 See the comment above (for SCM_REALP (y)) */
7347 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7348 - SCM_COMPLEX_IMAG (y
));
7350 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7351 - SCM_COMPLEX_IMAG (y
));
7353 else if (SCM_FRACTIONP (y
))
7354 /* a - b/c = (ac - b) / c */
7355 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7356 SCM_FRACTION_NUMERATOR (y
)),
7357 SCM_FRACTION_DENOMINATOR (y
));
7359 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7361 else if (SCM_BIGP (x
))
7363 if (SCM_I_INUMP (y
))
7365 /* big-x - inum-y */
7366 scm_t_inum yy
= SCM_I_INUM (y
);
7367 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7369 scm_remember_upto_here_1 (x
);
7371 return (SCM_FIXABLE (-yy
) ?
7372 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7375 SCM result
= scm_i_mkbig ();
7378 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7380 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7381 scm_remember_upto_here_1 (x
);
7383 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7384 /* we know the result will have to be a bignum */
7387 return scm_i_normbig (result
);
7390 else if (SCM_BIGP (y
))
7392 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7393 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7394 SCM result
= scm_i_mkbig ();
7395 mpz_sub (SCM_I_BIG_MPZ (result
),
7398 scm_remember_upto_here_2 (x
, y
);
7399 /* we know the result will have to be a bignum */
7400 if ((sgn_x
== 1) && (sgn_y
== -1))
7402 if ((sgn_x
== -1) && (sgn_y
== 1))
7404 return scm_i_normbig (result
);
7406 else if (SCM_REALP (y
))
7408 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7409 scm_remember_upto_here_1 (x
);
7410 return scm_from_double (result
);
7412 else if (SCM_COMPLEXP (y
))
7414 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7415 - SCM_COMPLEX_REAL (y
));
7416 scm_remember_upto_here_1 (x
);
7417 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7419 else if (SCM_FRACTIONP (y
))
7420 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7421 SCM_FRACTION_NUMERATOR (y
)),
7422 SCM_FRACTION_DENOMINATOR (y
));
7423 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7425 else if (SCM_REALP (x
))
7427 if (SCM_I_INUMP (y
))
7428 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7429 else if (SCM_BIGP (y
))
7431 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7432 scm_remember_upto_here_1 (x
);
7433 return scm_from_double (result
);
7435 else if (SCM_REALP (y
))
7436 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7437 else if (SCM_COMPLEXP (y
))
7438 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7439 -SCM_COMPLEX_IMAG (y
));
7440 else if (SCM_FRACTIONP (y
))
7441 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7443 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7445 else if (SCM_COMPLEXP (x
))
7447 if (SCM_I_INUMP (y
))
7448 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7449 SCM_COMPLEX_IMAG (x
));
7450 else if (SCM_BIGP (y
))
7452 double real_part
= (SCM_COMPLEX_REAL (x
)
7453 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7454 scm_remember_upto_here_1 (x
);
7455 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7457 else if (SCM_REALP (y
))
7458 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7459 SCM_COMPLEX_IMAG (x
));
7460 else if (SCM_COMPLEXP (y
))
7461 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7462 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7463 else if (SCM_FRACTIONP (y
))
7464 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7465 SCM_COMPLEX_IMAG (x
));
7467 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7469 else if (SCM_FRACTIONP (x
))
7471 if (SCM_I_INUMP (y
))
7472 /* a/b - c = (a - cb) / b */
7473 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7474 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7475 SCM_FRACTION_DENOMINATOR (x
));
7476 else if (SCM_BIGP (y
))
7477 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7478 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7479 SCM_FRACTION_DENOMINATOR (x
));
7480 else if (SCM_REALP (y
))
7481 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7482 else if (SCM_COMPLEXP (y
))
7483 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7484 -SCM_COMPLEX_IMAG (y
));
7485 else if (SCM_FRACTIONP (y
))
7486 /* a/b - c/d = (ad - bc) / bd */
7487 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7488 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7489 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7491 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7494 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7499 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7501 "Return @math{@var{x}-1}.")
7502 #define FUNC_NAME s_scm_oneminus
7504 return scm_difference (x
, SCM_INUM1
);
7509 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7510 (SCM x
, SCM y
, SCM rest
),
7511 "Return the product of all arguments. If called without arguments,\n"
7513 #define FUNC_NAME s_scm_i_product
7515 while (!scm_is_null (rest
))
7516 { x
= scm_product (x
, y
);
7518 rest
= scm_cdr (rest
);
7520 return scm_product (x
, y
);
7524 #define s_product s_scm_i_product
7525 #define g_product g_scm_i_product
7528 scm_product (SCM x
, SCM y
)
7530 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7533 return SCM_I_MAKINUM (1L);
7534 else if (SCM_NUMBERP (x
))
7537 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7540 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7545 xx
= SCM_I_INUM (x
);
7550 /* exact1 is the universal multiplicative identity */
7554 /* exact0 times a fixnum is exact0: optimize this case */
7555 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7557 /* if the other argument is inexact, the result is inexact,
7558 and we must do the multiplication in order to handle
7559 infinities and NaNs properly. */
7560 else if (SCM_REALP (y
))
7561 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7562 else if (SCM_COMPLEXP (y
))
7563 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7564 0.0 * SCM_COMPLEX_IMAG (y
));
7565 /* we've already handled inexact numbers,
7566 so y must be exact, and we return exact0 */
7567 else if (SCM_NUMP (y
))
7570 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7574 * This case is important for more than just optimization.
7575 * It handles the case of negating
7576 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7577 * which is a bignum that must be changed back into a fixnum.
7578 * Failure to do so will cause the following to return #f:
7579 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7581 return scm_difference(y
, SCM_UNDEFINED
);
7585 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7587 scm_t_inum yy
= SCM_I_INUM (y
);
7588 scm_t_inum kk
= xx
* yy
;
7589 SCM k
= SCM_I_MAKINUM (kk
);
7590 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7594 SCM result
= scm_i_inum2big (xx
);
7595 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7596 return scm_i_normbig (result
);
7599 else if (SCM_BIGP (y
))
7601 SCM result
= scm_i_mkbig ();
7602 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7603 scm_remember_upto_here_1 (y
);
7606 else if (SCM_REALP (y
))
7607 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7608 else if (SCM_COMPLEXP (y
))
7609 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7610 xx
* SCM_COMPLEX_IMAG (y
));
7611 else if (SCM_FRACTIONP (y
))
7612 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7613 SCM_FRACTION_DENOMINATOR (y
));
7615 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7617 else if (SCM_BIGP (x
))
7619 if (SCM_I_INUMP (y
))
7624 else if (SCM_BIGP (y
))
7626 SCM result
= scm_i_mkbig ();
7627 mpz_mul (SCM_I_BIG_MPZ (result
),
7630 scm_remember_upto_here_2 (x
, y
);
7633 else if (SCM_REALP (y
))
7635 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7636 scm_remember_upto_here_1 (x
);
7637 return scm_from_double (result
);
7639 else if (SCM_COMPLEXP (y
))
7641 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7642 scm_remember_upto_here_1 (x
);
7643 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7644 z
* SCM_COMPLEX_IMAG (y
));
7646 else if (SCM_FRACTIONP (y
))
7647 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7648 SCM_FRACTION_DENOMINATOR (y
));
7650 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7652 else if (SCM_REALP (x
))
7654 if (SCM_I_INUMP (y
))
7659 else if (SCM_BIGP (y
))
7661 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7662 scm_remember_upto_here_1 (y
);
7663 return scm_from_double (result
);
7665 else if (SCM_REALP (y
))
7666 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7667 else if (SCM_COMPLEXP (y
))
7668 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7669 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7670 else if (SCM_FRACTIONP (y
))
7671 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7673 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7675 else if (SCM_COMPLEXP (x
))
7677 if (SCM_I_INUMP (y
))
7682 else if (SCM_BIGP (y
))
7684 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7685 scm_remember_upto_here_1 (y
);
7686 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7687 z
* SCM_COMPLEX_IMAG (x
));
7689 else if (SCM_REALP (y
))
7690 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7691 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7692 else if (SCM_COMPLEXP (y
))
7694 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7695 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7696 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7697 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7699 else if (SCM_FRACTIONP (y
))
7701 double yy
= scm_i_fraction2double (y
);
7702 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7703 yy
* SCM_COMPLEX_IMAG (x
));
7706 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7708 else if (SCM_FRACTIONP (x
))
7710 if (SCM_I_INUMP (y
))
7711 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7712 SCM_FRACTION_DENOMINATOR (x
));
7713 else if (SCM_BIGP (y
))
7714 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7715 SCM_FRACTION_DENOMINATOR (x
));
7716 else if (SCM_REALP (y
))
7717 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7718 else if (SCM_COMPLEXP (y
))
7720 double xx
= scm_i_fraction2double (x
);
7721 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7722 xx
* SCM_COMPLEX_IMAG (y
));
7724 else if (SCM_FRACTIONP (y
))
7725 /* a/b * c/d = ac / bd */
7726 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7727 SCM_FRACTION_NUMERATOR (y
)),
7728 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7729 SCM_FRACTION_DENOMINATOR (y
)));
7731 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7734 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7737 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7738 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7739 #define ALLOW_DIVIDE_BY_ZERO
7740 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7743 /* The code below for complex division is adapted from the GNU
7744 libstdc++, which adapted it from f2c's libF77, and is subject to
7747 /****************************************************************
7748 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7750 Permission to use, copy, modify, and distribute this software
7751 and its documentation for any purpose and without fee is hereby
7752 granted, provided that the above copyright notice appear in all
7753 copies and that both that the copyright notice and this
7754 permission notice and warranty disclaimer appear in supporting
7755 documentation, and that the names of AT&T Bell Laboratories or
7756 Bellcore or any of their entities not be used in advertising or
7757 publicity pertaining to distribution of the software without
7758 specific, written prior permission.
7760 AT&T and Bellcore disclaim all warranties with regard to this
7761 software, including all implied warranties of merchantability
7762 and fitness. In no event shall AT&T or Bellcore be liable for
7763 any special, indirect or consequential damages or any damages
7764 whatsoever resulting from loss of use, data or profits, whether
7765 in an action of contract, negligence or other tortious action,
7766 arising out of or in connection with the use or performance of
7768 ****************************************************************/
7770 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7771 (SCM x
, SCM y
, SCM rest
),
7772 "Divide the first argument by the product of the remaining\n"
7773 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7775 #define FUNC_NAME s_scm_i_divide
7777 while (!scm_is_null (rest
))
7778 { x
= scm_divide (x
, y
);
7780 rest
= scm_cdr (rest
);
7782 return scm_divide (x
, y
);
7786 #define s_divide s_scm_i_divide
7787 #define g_divide g_scm_i_divide
7790 do_divide (SCM x
, SCM y
, int inexact
)
7791 #define FUNC_NAME s_divide
7795 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7798 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7799 else if (SCM_I_INUMP (x
))
7801 scm_t_inum xx
= SCM_I_INUM (x
);
7802 if (xx
== 1 || xx
== -1)
7804 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7806 scm_num_overflow (s_divide
);
7811 return scm_from_double (1.0 / (double) xx
);
7812 else return scm_i_make_ratio (SCM_INUM1
, x
);
7815 else if (SCM_BIGP (x
))
7818 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7819 else return scm_i_make_ratio (SCM_INUM1
, x
);
7821 else if (SCM_REALP (x
))
7823 double xx
= SCM_REAL_VALUE (x
);
7824 #ifndef ALLOW_DIVIDE_BY_ZERO
7826 scm_num_overflow (s_divide
);
7829 return scm_from_double (1.0 / xx
);
7831 else if (SCM_COMPLEXP (x
))
7833 double r
= SCM_COMPLEX_REAL (x
);
7834 double i
= SCM_COMPLEX_IMAG (x
);
7835 if (fabs(r
) <= fabs(i
))
7838 double d
= i
* (1.0 + t
* t
);
7839 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7844 double d
= r
* (1.0 + t
* t
);
7845 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7848 else if (SCM_FRACTIONP (x
))
7849 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7850 SCM_FRACTION_NUMERATOR (x
));
7852 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7855 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7857 scm_t_inum xx
= SCM_I_INUM (x
);
7858 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7860 scm_t_inum yy
= SCM_I_INUM (y
);
7863 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7864 scm_num_overflow (s_divide
);
7866 return scm_from_double ((double) xx
/ (double) yy
);
7869 else if (xx
% yy
!= 0)
7872 return scm_from_double ((double) xx
/ (double) yy
);
7873 else return scm_i_make_ratio (x
, y
);
7877 scm_t_inum z
= xx
/ yy
;
7878 if (SCM_FIXABLE (z
))
7879 return SCM_I_MAKINUM (z
);
7881 return scm_i_inum2big (z
);
7884 else if (SCM_BIGP (y
))
7887 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7888 else return scm_i_make_ratio (x
, y
);
7890 else if (SCM_REALP (y
))
7892 double yy
= SCM_REAL_VALUE (y
);
7893 #ifndef ALLOW_DIVIDE_BY_ZERO
7895 scm_num_overflow (s_divide
);
7898 return scm_from_double ((double) xx
/ yy
);
7900 else if (SCM_COMPLEXP (y
))
7903 complex_div
: /* y _must_ be a complex number */
7905 double r
= SCM_COMPLEX_REAL (y
);
7906 double i
= SCM_COMPLEX_IMAG (y
);
7907 if (fabs(r
) <= fabs(i
))
7910 double d
= i
* (1.0 + t
* t
);
7911 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7916 double d
= r
* (1.0 + t
* t
);
7917 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7921 else if (SCM_FRACTIONP (y
))
7922 /* a / b/c = ac / b */
7923 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7924 SCM_FRACTION_NUMERATOR (y
));
7926 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7928 else if (SCM_BIGP (x
))
7930 if (SCM_I_INUMP (y
))
7932 scm_t_inum yy
= SCM_I_INUM (y
);
7935 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7936 scm_num_overflow (s_divide
);
7938 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7939 scm_remember_upto_here_1 (x
);
7940 return (sgn
== 0) ? scm_nan () : scm_inf ();
7947 /* FIXME: HMM, what are the relative performance issues here?
7948 We need to test. Is it faster on average to test
7949 divisible_p, then perform whichever operation, or is it
7950 faster to perform the integer div opportunistically and
7951 switch to real if there's a remainder? For now we take the
7952 middle ground: test, then if divisible, use the faster div
7955 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7956 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7960 SCM result
= scm_i_mkbig ();
7961 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7962 scm_remember_upto_here_1 (x
);
7964 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7965 return scm_i_normbig (result
);
7970 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7971 else return scm_i_make_ratio (x
, y
);
7975 else if (SCM_BIGP (y
))
7980 /* It's easily possible for the ratio x/y to fit a double
7981 but one or both x and y be too big to fit a double,
7982 hence the use of mpq_get_d rather than converting and
7985 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
7986 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
7987 return scm_from_double (mpq_get_d (q
));
7991 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
7995 SCM result
= scm_i_mkbig ();
7996 mpz_divexact (SCM_I_BIG_MPZ (result
),
7999 scm_remember_upto_here_2 (x
, y
);
8000 return scm_i_normbig (result
);
8003 return scm_i_make_ratio (x
, y
);
8006 else if (SCM_REALP (y
))
8008 double yy
= SCM_REAL_VALUE (y
);
8009 #ifndef ALLOW_DIVIDE_BY_ZERO
8011 scm_num_overflow (s_divide
);
8014 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8016 else if (SCM_COMPLEXP (y
))
8018 a
= scm_i_big2dbl (x
);
8021 else if (SCM_FRACTIONP (y
))
8022 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8023 SCM_FRACTION_NUMERATOR (y
));
8025 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8027 else if (SCM_REALP (x
))
8029 double rx
= SCM_REAL_VALUE (x
);
8030 if (SCM_I_INUMP (y
))
8032 scm_t_inum yy
= SCM_I_INUM (y
);
8033 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8035 scm_num_overflow (s_divide
);
8038 return scm_from_double (rx
/ (double) yy
);
8040 else if (SCM_BIGP (y
))
8042 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8043 scm_remember_upto_here_1 (y
);
8044 return scm_from_double (rx
/ dby
);
8046 else if (SCM_REALP (y
))
8048 double yy
= SCM_REAL_VALUE (y
);
8049 #ifndef ALLOW_DIVIDE_BY_ZERO
8051 scm_num_overflow (s_divide
);
8054 return scm_from_double (rx
/ yy
);
8056 else if (SCM_COMPLEXP (y
))
8061 else if (SCM_FRACTIONP (y
))
8062 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8064 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8066 else if (SCM_COMPLEXP (x
))
8068 double rx
= SCM_COMPLEX_REAL (x
);
8069 double ix
= SCM_COMPLEX_IMAG (x
);
8070 if (SCM_I_INUMP (y
))
8072 scm_t_inum yy
= SCM_I_INUM (y
);
8073 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8075 scm_num_overflow (s_divide
);
8080 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8083 else if (SCM_BIGP (y
))
8085 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8086 scm_remember_upto_here_1 (y
);
8087 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8089 else if (SCM_REALP (y
))
8091 double yy
= SCM_REAL_VALUE (y
);
8092 #ifndef ALLOW_DIVIDE_BY_ZERO
8094 scm_num_overflow (s_divide
);
8097 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8099 else if (SCM_COMPLEXP (y
))
8101 double ry
= SCM_COMPLEX_REAL (y
);
8102 double iy
= SCM_COMPLEX_IMAG (y
);
8103 if (fabs(ry
) <= fabs(iy
))
8106 double d
= iy
* (1.0 + t
* t
);
8107 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8112 double d
= ry
* (1.0 + t
* t
);
8113 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8116 else if (SCM_FRACTIONP (y
))
8118 double yy
= scm_i_fraction2double (y
);
8119 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8122 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8124 else if (SCM_FRACTIONP (x
))
8126 if (SCM_I_INUMP (y
))
8128 scm_t_inum yy
= SCM_I_INUM (y
);
8129 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8131 scm_num_overflow (s_divide
);
8134 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8135 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8137 else if (SCM_BIGP (y
))
8139 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8140 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8142 else if (SCM_REALP (y
))
8144 double yy
= SCM_REAL_VALUE (y
);
8145 #ifndef ALLOW_DIVIDE_BY_ZERO
8147 scm_num_overflow (s_divide
);
8150 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8152 else if (SCM_COMPLEXP (y
))
8154 a
= scm_i_fraction2double (x
);
8157 else if (SCM_FRACTIONP (y
))
8158 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8159 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8161 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8164 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8168 scm_divide (SCM x
, SCM y
)
8170 return do_divide (x
, y
, 0);
8173 static SCM
scm_divide2real (SCM x
, SCM y
)
8175 return do_divide (x
, y
, 1);
8181 scm_c_truncate (double x
)
8186 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8187 half-way case (ie. when x is an integer plus 0.5) going upwards.
8188 Then half-way cases are identified and adjusted down if the
8189 round-upwards didn't give the desired even integer.
8191 "plus_half == result" identifies a half-way case. If plus_half, which is
8192 x + 0.5, is an integer then x must be an integer plus 0.5.
8194 An odd "result" value is identified with result/2 != floor(result/2).
8195 This is done with plus_half, since that value is ready for use sooner in
8196 a pipelined cpu, and we're already requiring plus_half == result.
8198 Note however that we need to be careful when x is big and already an
8199 integer. In that case "x+0.5" may round to an adjacent integer, causing
8200 us to return such a value, incorrectly. For instance if the hardware is
8201 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8202 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8203 returned. Or if the hardware is in round-upwards mode, then other bigger
8204 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8205 representable value, 2^128+2^76 (or whatever), again incorrect.
8207 These bad roundings of x+0.5 are avoided by testing at the start whether
8208 x is already an integer. If it is then clearly that's the desired result
8209 already. And if it's not then the exponent must be small enough to allow
8210 an 0.5 to be represented, and hence added without a bad rounding. */
8213 scm_c_round (double x
)
8215 double plus_half
, result
;
8220 plus_half
= x
+ 0.5;
8221 result
= floor (plus_half
);
8222 /* Adjust so that the rounding is towards even. */
8223 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8228 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8230 "Round the number @var{x} towards zero.")
8231 #define FUNC_NAME s_scm_truncate_number
8233 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8235 else if (SCM_REALP (x
))
8236 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8237 else if (SCM_FRACTIONP (x
))
8238 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8239 SCM_FRACTION_DENOMINATOR (x
));
8241 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8242 s_scm_truncate_number
);
8246 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8248 "Round the number @var{x} towards the nearest integer. "
8249 "When it is exactly halfway between two integers, "
8250 "round towards the even one.")
8251 #define FUNC_NAME s_scm_round_number
8253 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8255 else if (SCM_REALP (x
))
8256 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8257 else if (SCM_FRACTIONP (x
))
8258 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8259 SCM_FRACTION_DENOMINATOR (x
));
8261 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8262 s_scm_round_number
);
8266 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8268 "Round the number @var{x} towards minus infinity.")
8269 #define FUNC_NAME s_scm_floor
8271 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8273 else if (SCM_REALP (x
))
8274 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8275 else if (SCM_FRACTIONP (x
))
8276 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8277 SCM_FRACTION_DENOMINATOR (x
));
8279 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8283 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8285 "Round the number @var{x} towards infinity.")
8286 #define FUNC_NAME s_scm_ceiling
8288 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8290 else if (SCM_REALP (x
))
8291 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8292 else if (SCM_FRACTIONP (x
))
8293 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8294 SCM_FRACTION_DENOMINATOR (x
));
8296 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8300 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8302 "Return @var{x} raised to the power of @var{y}.")
8303 #define FUNC_NAME s_scm_expt
8305 if (scm_is_integer (y
))
8307 if (scm_is_true (scm_exact_p (y
)))
8308 return scm_integer_expt (x
, y
);
8311 /* Here we handle the case where the exponent is an inexact
8312 integer. We make the exponent exact in order to use
8313 scm_integer_expt, and thus avoid the spurious imaginary
8314 parts that may result from round-off errors in the general
8315 e^(y log x) method below (for example when squaring a large
8316 negative number). In this case, we must return an inexact
8317 result for correctness. We also make the base inexact so
8318 that scm_integer_expt will use fast inexact arithmetic
8319 internally. Note that making the base inexact is not
8320 sufficient to guarantee an inexact result, because
8321 scm_integer_expt will return an exact 1 when the exponent
8322 is 0, even if the base is inexact. */
8323 return scm_exact_to_inexact
8324 (scm_integer_expt (scm_exact_to_inexact (x
),
8325 scm_inexact_to_exact (y
)));
8328 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8330 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8332 else if (scm_is_complex (x
) && scm_is_complex (y
))
8333 return scm_exp (scm_product (scm_log (x
), y
));
8334 else if (scm_is_complex (x
))
8335 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8337 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8341 /* sin/cos/tan/asin/acos/atan
8342 sinh/cosh/tanh/asinh/acosh/atanh
8343 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8344 Written by Jerry D. Hedden, (C) FSF.
8345 See the file `COPYING' for terms applying to this program. */
8347 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8349 "Compute the sine of @var{z}.")
8350 #define FUNC_NAME s_scm_sin
8352 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8353 return z
; /* sin(exact0) = exact0 */
8354 else if (scm_is_real (z
))
8355 return scm_from_double (sin (scm_to_double (z
)));
8356 else if (SCM_COMPLEXP (z
))
8358 x
= SCM_COMPLEX_REAL (z
);
8359 y
= SCM_COMPLEX_IMAG (z
);
8360 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8361 cos (x
) * sinh (y
));
8364 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8368 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8370 "Compute the cosine of @var{z}.")
8371 #define FUNC_NAME s_scm_cos
8373 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8374 return SCM_INUM1
; /* cos(exact0) = exact1 */
8375 else if (scm_is_real (z
))
8376 return scm_from_double (cos (scm_to_double (z
)));
8377 else if (SCM_COMPLEXP (z
))
8379 x
= SCM_COMPLEX_REAL (z
);
8380 y
= SCM_COMPLEX_IMAG (z
);
8381 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8382 -sin (x
) * sinh (y
));
8385 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8389 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8391 "Compute the tangent of @var{z}.")
8392 #define FUNC_NAME s_scm_tan
8394 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8395 return z
; /* tan(exact0) = exact0 */
8396 else if (scm_is_real (z
))
8397 return scm_from_double (tan (scm_to_double (z
)));
8398 else if (SCM_COMPLEXP (z
))
8400 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8401 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8402 w
= cos (x
) + cosh (y
);
8403 #ifndef ALLOW_DIVIDE_BY_ZERO
8405 scm_num_overflow (s_scm_tan
);
8407 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8410 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8414 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8416 "Compute the hyperbolic sine of @var{z}.")
8417 #define FUNC_NAME s_scm_sinh
8419 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8420 return z
; /* sinh(exact0) = exact0 */
8421 else if (scm_is_real (z
))
8422 return scm_from_double (sinh (scm_to_double (z
)));
8423 else if (SCM_COMPLEXP (z
))
8425 x
= SCM_COMPLEX_REAL (z
);
8426 y
= SCM_COMPLEX_IMAG (z
);
8427 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8428 cosh (x
) * sin (y
));
8431 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8435 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8437 "Compute the hyperbolic cosine of @var{z}.")
8438 #define FUNC_NAME s_scm_cosh
8440 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8441 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8442 else if (scm_is_real (z
))
8443 return scm_from_double (cosh (scm_to_double (z
)));
8444 else if (SCM_COMPLEXP (z
))
8446 x
= SCM_COMPLEX_REAL (z
);
8447 y
= SCM_COMPLEX_IMAG (z
);
8448 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8449 sinh (x
) * sin (y
));
8452 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8456 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8458 "Compute the hyperbolic tangent of @var{z}.")
8459 #define FUNC_NAME s_scm_tanh
8461 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8462 return z
; /* tanh(exact0) = exact0 */
8463 else if (scm_is_real (z
))
8464 return scm_from_double (tanh (scm_to_double (z
)));
8465 else if (SCM_COMPLEXP (z
))
8467 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8468 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8469 w
= cosh (x
) + cos (y
);
8470 #ifndef ALLOW_DIVIDE_BY_ZERO
8472 scm_num_overflow (s_scm_tanh
);
8474 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8477 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8481 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8483 "Compute the arc sine of @var{z}.")
8484 #define FUNC_NAME s_scm_asin
8486 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8487 return z
; /* asin(exact0) = exact0 */
8488 else if (scm_is_real (z
))
8490 double w
= scm_to_double (z
);
8491 if (w
>= -1.0 && w
<= 1.0)
8492 return scm_from_double (asin (w
));
8494 return scm_product (scm_c_make_rectangular (0, -1),
8495 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8497 else if (SCM_COMPLEXP (z
))
8499 x
= SCM_COMPLEX_REAL (z
);
8500 y
= SCM_COMPLEX_IMAG (z
);
8501 return scm_product (scm_c_make_rectangular (0, -1),
8502 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8505 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8509 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8511 "Compute the arc cosine of @var{z}.")
8512 #define FUNC_NAME s_scm_acos
8514 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8515 return SCM_INUM0
; /* acos(exact1) = exact0 */
8516 else if (scm_is_real (z
))
8518 double w
= scm_to_double (z
);
8519 if (w
>= -1.0 && w
<= 1.0)
8520 return scm_from_double (acos (w
));
8522 return scm_sum (scm_from_double (acos (0.0)),
8523 scm_product (scm_c_make_rectangular (0, 1),
8524 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8526 else if (SCM_COMPLEXP (z
))
8528 x
= SCM_COMPLEX_REAL (z
);
8529 y
= SCM_COMPLEX_IMAG (z
);
8530 return scm_sum (scm_from_double (acos (0.0)),
8531 scm_product (scm_c_make_rectangular (0, 1),
8532 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8535 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8539 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8541 "With one argument, compute the arc tangent of @var{z}.\n"
8542 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8543 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8544 #define FUNC_NAME s_scm_atan
8548 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8549 return z
; /* atan(exact0) = exact0 */
8550 else if (scm_is_real (z
))
8551 return scm_from_double (atan (scm_to_double (z
)));
8552 else if (SCM_COMPLEXP (z
))
8555 v
= SCM_COMPLEX_REAL (z
);
8556 w
= SCM_COMPLEX_IMAG (z
);
8557 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8558 scm_c_make_rectangular (v
, w
+ 1.0))),
8559 scm_c_make_rectangular (0, 2));
8562 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8564 else if (scm_is_real (z
))
8566 if (scm_is_real (y
))
8567 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8569 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8572 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8576 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8578 "Compute the inverse hyperbolic sine of @var{z}.")
8579 #define FUNC_NAME s_scm_sys_asinh
8581 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8582 return z
; /* asinh(exact0) = exact0 */
8583 else if (scm_is_real (z
))
8584 return scm_from_double (asinh (scm_to_double (z
)));
8585 else if (scm_is_number (z
))
8586 return scm_log (scm_sum (z
,
8587 scm_sqrt (scm_sum (scm_product (z
, z
),
8590 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8594 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8596 "Compute the inverse hyperbolic cosine of @var{z}.")
8597 #define FUNC_NAME s_scm_sys_acosh
8599 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8600 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8601 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8602 return scm_from_double (acosh (scm_to_double (z
)));
8603 else if (scm_is_number (z
))
8604 return scm_log (scm_sum (z
,
8605 scm_sqrt (scm_difference (scm_product (z
, z
),
8608 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8612 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8614 "Compute the inverse hyperbolic tangent of @var{z}.")
8615 #define FUNC_NAME s_scm_sys_atanh
8617 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8618 return z
; /* atanh(exact0) = exact0 */
8619 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8620 return scm_from_double (atanh (scm_to_double (z
)));
8621 else if (scm_is_number (z
))
8622 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8623 scm_difference (SCM_INUM1
, z
))),
8626 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8631 scm_c_make_rectangular (double re
, double im
)
8635 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8637 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8638 SCM_COMPLEX_REAL (z
) = re
;
8639 SCM_COMPLEX_IMAG (z
) = im
;
8643 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8644 (SCM real_part
, SCM imaginary_part
),
8645 "Return a complex number constructed of the given @var{real-part} "
8646 "and @var{imaginary-part} parts.")
8647 #define FUNC_NAME s_scm_make_rectangular
8649 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8650 SCM_ARG1
, FUNC_NAME
, "real");
8651 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8652 SCM_ARG2
, FUNC_NAME
, "real");
8654 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8655 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8658 return scm_c_make_rectangular (scm_to_double (real_part
),
8659 scm_to_double (imaginary_part
));
8664 scm_c_make_polar (double mag
, double ang
)
8668 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8669 use it on Glibc-based systems that have it (it's a GNU extension). See
8670 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8672 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8673 sincos (ang
, &s
, &c
);
8679 /* If s and c are NaNs, this indicates that the angle is a NaN,
8680 infinite, or perhaps simply too large to determine its value
8681 mod 2*pi. However, we know something that the floating-point
8682 implementation doesn't know: We know that s and c are finite.
8683 Therefore, if the magnitude is zero, return a complex zero.
8685 The reason we check for the NaNs instead of using this case
8686 whenever mag == 0.0 is because when the angle is known, we'd
8687 like to return the correct kind of non-real complex zero:
8688 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8689 on which quadrant the angle is in.
8691 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8692 return scm_c_make_rectangular (0.0, 0.0);
8694 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8697 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8699 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8700 #define FUNC_NAME s_scm_make_polar
8702 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8703 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8705 /* If mag is exact0, return exact0 */
8706 if (scm_is_eq (mag
, SCM_INUM0
))
8708 /* Return a real if ang is exact0 */
8709 else if (scm_is_eq (ang
, SCM_INUM0
))
8712 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8717 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8719 "Return the real part of the number @var{z}.")
8720 #define FUNC_NAME s_scm_real_part
8722 if (SCM_COMPLEXP (z
))
8723 return scm_from_double (SCM_COMPLEX_REAL (z
));
8724 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8727 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8732 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8734 "Return the imaginary part of the number @var{z}.")
8735 #define FUNC_NAME s_scm_imag_part
8737 if (SCM_COMPLEXP (z
))
8738 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8739 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8742 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8746 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8748 "Return the numerator of the number @var{z}.")
8749 #define FUNC_NAME s_scm_numerator
8751 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8753 else if (SCM_FRACTIONP (z
))
8754 return SCM_FRACTION_NUMERATOR (z
);
8755 else if (SCM_REALP (z
))
8756 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8758 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8763 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8765 "Return the denominator of the number @var{z}.")
8766 #define FUNC_NAME s_scm_denominator
8768 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8770 else if (SCM_FRACTIONP (z
))
8771 return SCM_FRACTION_DENOMINATOR (z
);
8772 else if (SCM_REALP (z
))
8773 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8775 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8780 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8782 "Return the magnitude of the number @var{z}. This is the same as\n"
8783 "@code{abs} for real arguments, but also allows complex numbers.")
8784 #define FUNC_NAME s_scm_magnitude
8786 if (SCM_I_INUMP (z
))
8788 scm_t_inum zz
= SCM_I_INUM (z
);
8791 else if (SCM_POSFIXABLE (-zz
))
8792 return SCM_I_MAKINUM (-zz
);
8794 return scm_i_inum2big (-zz
);
8796 else if (SCM_BIGP (z
))
8798 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8799 scm_remember_upto_here_1 (z
);
8801 return scm_i_clonebig (z
, 0);
8805 else if (SCM_REALP (z
))
8806 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8807 else if (SCM_COMPLEXP (z
))
8808 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8809 else if (SCM_FRACTIONP (z
))
8811 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8813 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8814 SCM_FRACTION_DENOMINATOR (z
));
8817 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8822 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8824 "Return the angle of the complex number @var{z}.")
8825 #define FUNC_NAME s_scm_angle
8827 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8828 flo0 to save allocating a new flonum with scm_from_double each time.
8829 But if atan2 follows the floating point rounding mode, then the value
8830 is not a constant. Maybe it'd be close enough though. */
8831 if (SCM_I_INUMP (z
))
8833 if (SCM_I_INUM (z
) >= 0)
8836 return scm_from_double (atan2 (0.0, -1.0));
8838 else if (SCM_BIGP (z
))
8840 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8841 scm_remember_upto_here_1 (z
);
8843 return scm_from_double (atan2 (0.0, -1.0));
8847 else if (SCM_REALP (z
))
8849 if (SCM_REAL_VALUE (z
) >= 0)
8852 return scm_from_double (atan2 (0.0, -1.0));
8854 else if (SCM_COMPLEXP (z
))
8855 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8856 else if (SCM_FRACTIONP (z
))
8858 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8860 else return scm_from_double (atan2 (0.0, -1.0));
8863 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8868 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8870 "Convert the number @var{z} to its inexact representation.\n")
8871 #define FUNC_NAME s_scm_exact_to_inexact
8873 if (SCM_I_INUMP (z
))
8874 return scm_from_double ((double) SCM_I_INUM (z
));
8875 else if (SCM_BIGP (z
))
8876 return scm_from_double (scm_i_big2dbl (z
));
8877 else if (SCM_FRACTIONP (z
))
8878 return scm_from_double (scm_i_fraction2double (z
));
8879 else if (SCM_INEXACTP (z
))
8882 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8887 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8889 "Return an exact number that is numerically closest to @var{z}.")
8890 #define FUNC_NAME s_scm_inexact_to_exact
8892 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8899 val
= SCM_REAL_VALUE (z
);
8900 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8901 val
= SCM_COMPLEX_REAL (z
);
8903 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8905 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8906 SCM_OUT_OF_RANGE (1, z
);
8913 mpq_set_d (frac
, val
);
8914 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8915 scm_i_mpz2num (mpq_denref (frac
)));
8917 /* When scm_i_make_ratio throws, we leak the memory allocated
8927 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8929 "Returns the @emph{simplest} rational number differing\n"
8930 "from @var{x} by no more than @var{eps}.\n"
8932 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8933 "exact result when both its arguments are exact. Thus, you might need\n"
8934 "to use @code{inexact->exact} on the arguments.\n"
8937 "(rationalize (inexact->exact 1.2) 1/100)\n"
8940 #define FUNC_NAME s_scm_rationalize
8942 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8943 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8944 eps
= scm_abs (eps
);
8945 if (scm_is_false (scm_positive_p (eps
)))
8947 /* eps is either zero or a NaN */
8948 if (scm_is_true (scm_nan_p (eps
)))
8950 else if (SCM_INEXACTP (eps
))
8951 return scm_exact_to_inexact (x
);
8955 else if (scm_is_false (scm_finite_p (eps
)))
8957 if (scm_is_true (scm_finite_p (x
)))
8962 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8964 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8965 scm_ceiling (scm_difference (x
, eps
)))))
8967 /* There's an integer within range; we want the one closest to zero */
8968 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8970 /* zero is within range */
8971 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8976 else if (scm_is_true (scm_positive_p (x
)))
8977 return scm_ceiling (scm_difference (x
, eps
));
8979 return scm_floor (scm_sum (x
, eps
));
8983 /* Use continued fractions to find closest ratio. All
8984 arithmetic is done with exact numbers.
8987 SCM ex
= scm_inexact_to_exact (x
);
8988 SCM int_part
= scm_floor (ex
);
8990 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
8991 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
8995 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
8996 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
8998 /* We stop after a million iterations just to be absolutely sure
8999 that we don't go into an infinite loop. The process normally
9000 converges after less than a dozen iterations.
9003 while (++i
< 1000000)
9005 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9006 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9007 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9009 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9010 eps
))) /* abs(x-a/b) <= eps */
9012 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9013 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9014 return scm_exact_to_inexact (res
);
9018 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9020 tt
= scm_floor (rx
); /* tt = floor (rx) */
9026 scm_num_overflow (s_scm_rationalize
);
9031 /* conversion functions */
9034 scm_is_integer (SCM val
)
9036 return scm_is_true (scm_integer_p (val
));
9040 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9042 if (SCM_I_INUMP (val
))
9044 scm_t_signed_bits n
= SCM_I_INUM (val
);
9045 return n
>= min
&& n
<= max
;
9047 else if (SCM_BIGP (val
))
9049 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9051 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9053 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9055 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9056 return n
>= min
&& n
<= max
;
9066 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9067 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9070 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9071 SCM_I_BIG_MPZ (val
));
9073 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9085 return n
>= min
&& n
<= max
;
9093 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9095 if (SCM_I_INUMP (val
))
9097 scm_t_signed_bits n
= SCM_I_INUM (val
);
9098 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9100 else if (SCM_BIGP (val
))
9102 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9104 else if (max
<= ULONG_MAX
)
9106 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9108 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9109 return n
>= min
&& n
<= max
;
9119 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9122 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9123 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9126 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9127 SCM_I_BIG_MPZ (val
));
9129 return n
>= min
&& n
<= max
;
9137 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9139 scm_error (scm_out_of_range_key
,
9141 "Value out of range ~S to ~S: ~S",
9142 scm_list_3 (min
, max
, bad_val
),
9143 scm_list_1 (bad_val
));
9146 #define TYPE scm_t_intmax
9147 #define TYPE_MIN min
9148 #define TYPE_MAX max
9149 #define SIZEOF_TYPE 0
9150 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9151 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9152 #include "libguile/conv-integer.i.c"
9154 #define TYPE scm_t_uintmax
9155 #define TYPE_MIN min
9156 #define TYPE_MAX max
9157 #define SIZEOF_TYPE 0
9158 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9159 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9160 #include "libguile/conv-uinteger.i.c"
9162 #define TYPE scm_t_int8
9163 #define TYPE_MIN SCM_T_INT8_MIN
9164 #define TYPE_MAX SCM_T_INT8_MAX
9165 #define SIZEOF_TYPE 1
9166 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9167 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9168 #include "libguile/conv-integer.i.c"
9170 #define TYPE scm_t_uint8
9172 #define TYPE_MAX SCM_T_UINT8_MAX
9173 #define SIZEOF_TYPE 1
9174 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9175 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9176 #include "libguile/conv-uinteger.i.c"
9178 #define TYPE scm_t_int16
9179 #define TYPE_MIN SCM_T_INT16_MIN
9180 #define TYPE_MAX SCM_T_INT16_MAX
9181 #define SIZEOF_TYPE 2
9182 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9183 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9184 #include "libguile/conv-integer.i.c"
9186 #define TYPE scm_t_uint16
9188 #define TYPE_MAX SCM_T_UINT16_MAX
9189 #define SIZEOF_TYPE 2
9190 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9191 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9192 #include "libguile/conv-uinteger.i.c"
9194 #define TYPE scm_t_int32
9195 #define TYPE_MIN SCM_T_INT32_MIN
9196 #define TYPE_MAX SCM_T_INT32_MAX
9197 #define SIZEOF_TYPE 4
9198 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9199 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9200 #include "libguile/conv-integer.i.c"
9202 #define TYPE scm_t_uint32
9204 #define TYPE_MAX SCM_T_UINT32_MAX
9205 #define SIZEOF_TYPE 4
9206 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9207 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9208 #include "libguile/conv-uinteger.i.c"
9210 #define TYPE scm_t_wchar
9211 #define TYPE_MIN (scm_t_int32)-1
9212 #define TYPE_MAX (scm_t_int32)0x10ffff
9213 #define SIZEOF_TYPE 4
9214 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9215 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9216 #include "libguile/conv-integer.i.c"
9218 #define TYPE scm_t_int64
9219 #define TYPE_MIN SCM_T_INT64_MIN
9220 #define TYPE_MAX SCM_T_INT64_MAX
9221 #define SIZEOF_TYPE 8
9222 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9223 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9224 #include "libguile/conv-integer.i.c"
9226 #define TYPE scm_t_uint64
9228 #define TYPE_MAX SCM_T_UINT64_MAX
9229 #define SIZEOF_TYPE 8
9230 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9231 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9232 #include "libguile/conv-uinteger.i.c"
9235 scm_to_mpz (SCM val
, mpz_t rop
)
9237 if (SCM_I_INUMP (val
))
9238 mpz_set_si (rop
, SCM_I_INUM (val
));
9239 else if (SCM_BIGP (val
))
9240 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9242 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9246 scm_from_mpz (mpz_t val
)
9248 return scm_i_mpz2num (val
);
9252 scm_is_real (SCM val
)
9254 return scm_is_true (scm_real_p (val
));
9258 scm_is_rational (SCM val
)
9260 return scm_is_true (scm_rational_p (val
));
9264 scm_to_double (SCM val
)
9266 if (SCM_I_INUMP (val
))
9267 return SCM_I_INUM (val
);
9268 else if (SCM_BIGP (val
))
9269 return scm_i_big2dbl (val
);
9270 else if (SCM_FRACTIONP (val
))
9271 return scm_i_fraction2double (val
);
9272 else if (SCM_REALP (val
))
9273 return SCM_REAL_VALUE (val
);
9275 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9279 scm_from_double (double val
)
9283 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9285 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9286 SCM_REAL_VALUE (z
) = val
;
9291 #if SCM_ENABLE_DEPRECATED == 1
9294 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9296 scm_c_issue_deprecation_warning
9297 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9301 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9305 scm_out_of_range (NULL
, num
);
9308 return scm_to_double (num
);
9312 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9314 scm_c_issue_deprecation_warning
9315 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9319 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9323 scm_out_of_range (NULL
, num
);
9326 return scm_to_double (num
);
9332 scm_is_complex (SCM val
)
9334 return scm_is_true (scm_complex_p (val
));
9338 scm_c_real_part (SCM z
)
9340 if (SCM_COMPLEXP (z
))
9341 return SCM_COMPLEX_REAL (z
);
9344 /* Use the scm_real_part to get proper error checking and
9347 return scm_to_double (scm_real_part (z
));
9352 scm_c_imag_part (SCM z
)
9354 if (SCM_COMPLEXP (z
))
9355 return SCM_COMPLEX_IMAG (z
);
9358 /* Use the scm_imag_part to get proper error checking and
9359 dispatching. The result will almost always be 0.0, but not
9362 return scm_to_double (scm_imag_part (z
));
9367 scm_c_magnitude (SCM z
)
9369 return scm_to_double (scm_magnitude (z
));
9375 return scm_to_double (scm_angle (z
));
9379 scm_is_number (SCM z
)
9381 return scm_is_true (scm_number_p (z
));
9385 /* Returns log(x * 2^shift) */
9387 log_of_shifted_double (double x
, long shift
)
9389 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9391 if (x
> 0.0 || double_is_non_negative_zero (x
))
9392 return scm_from_double (ans
);
9394 return scm_c_make_rectangular (ans
, M_PI
);
9397 /* Returns log(n), for exact integer n of integer-length size */
9399 log_of_exact_integer_with_size (SCM n
, long size
)
9401 long shift
= size
- 2 * scm_dblprec
[0];
9404 return log_of_shifted_double
9405 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9408 return log_of_shifted_double (scm_to_double (n
), 0);
9411 /* Returns log(n), for exact integer n */
9413 log_of_exact_integer (SCM n
)
9415 return log_of_exact_integer_with_size
9416 (n
, scm_to_long (scm_integer_length (n
)));
9419 /* Returns log(n/d), for exact non-zero integers n and d */
9421 log_of_fraction (SCM n
, SCM d
)
9423 long n_size
= scm_to_long (scm_integer_length (n
));
9424 long d_size
= scm_to_long (scm_integer_length (d
));
9426 if (abs (n_size
- d_size
) > 1)
9427 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9428 log_of_exact_integer_with_size (d
, d_size
)));
9429 else if (scm_is_false (scm_negative_p (n
)))
9430 return scm_from_double
9431 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9433 return scm_c_make_rectangular
9434 (log1p (scm_to_double (scm_divide2real
9435 (scm_difference (scm_abs (n
), d
),
9441 /* In the following functions we dispatch to the real-arg funcs like log()
9442 when we know the arg is real, instead of just handing everything to
9443 clog() for instance. This is in case clog() doesn't optimize for a
9444 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9445 well use it to go straight to the applicable C func. */
9447 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9449 "Return the natural logarithm of @var{z}.")
9450 #define FUNC_NAME s_scm_log
9452 if (SCM_COMPLEXP (z
))
9454 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9455 && defined (SCM_COMPLEX_VALUE)
9456 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9458 double re
= SCM_COMPLEX_REAL (z
);
9459 double im
= SCM_COMPLEX_IMAG (z
);
9460 return scm_c_make_rectangular (log (hypot (re
, im
)),
9464 else if (SCM_REALP (z
))
9465 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9466 else if (SCM_I_INUMP (z
))
9468 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9469 if (scm_is_eq (z
, SCM_INUM0
))
9470 scm_num_overflow (s_scm_log
);
9472 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9474 else if (SCM_BIGP (z
))
9475 return log_of_exact_integer (z
);
9476 else if (SCM_FRACTIONP (z
))
9477 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9478 SCM_FRACTION_DENOMINATOR (z
));
9480 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9485 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9487 "Return the base 10 logarithm of @var{z}.")
9488 #define FUNC_NAME s_scm_log10
9490 if (SCM_COMPLEXP (z
))
9492 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9493 clog() and a multiply by M_LOG10E, rather than the fallback
9494 log10+hypot+atan2.) */
9495 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9496 && defined SCM_COMPLEX_VALUE
9497 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9499 double re
= SCM_COMPLEX_REAL (z
);
9500 double im
= SCM_COMPLEX_IMAG (z
);
9501 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9502 M_LOG10E
* atan2 (im
, re
));
9505 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9507 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9508 if (scm_is_eq (z
, SCM_INUM0
))
9509 scm_num_overflow (s_scm_log10
);
9512 double re
= scm_to_double (z
);
9513 double l
= log10 (fabs (re
));
9514 if (re
> 0.0 || double_is_non_negative_zero (re
))
9515 return scm_from_double (l
);
9517 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9520 else if (SCM_BIGP (z
))
9521 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9522 else if (SCM_FRACTIONP (z
))
9523 return scm_product (flo_log10e
,
9524 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9525 SCM_FRACTION_DENOMINATOR (z
)));
9527 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9532 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9534 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9535 "base of natural logarithms (2.71828@dots{}).")
9536 #define FUNC_NAME s_scm_exp
9538 if (SCM_COMPLEXP (z
))
9540 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9541 && defined (SCM_COMPLEX_VALUE)
9542 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9544 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9545 SCM_COMPLEX_IMAG (z
));
9548 else if (SCM_NUMBERP (z
))
9550 /* When z is a negative bignum the conversion to double overflows,
9551 giving -infinity, but that's ok, the exp is still 0.0. */
9552 return scm_from_double (exp (scm_to_double (z
)));
9555 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9560 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9562 "Return two exact non-negative integers @var{s} and @var{r}\n"
9563 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9564 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9565 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9568 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9570 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9574 scm_exact_integer_sqrt (k
, &s
, &r
);
9575 return scm_values (scm_list_2 (s
, r
));
9580 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9582 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9584 scm_t_inum kk
= SCM_I_INUM (k
);
9588 if (SCM_LIKELY (kk
> 0))
9593 uu
= (ss
+ kk
/ss
) / 2;
9595 *sp
= SCM_I_MAKINUM (ss
);
9596 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9598 else if (SCM_LIKELY (kk
== 0))
9599 *sp
= *rp
= SCM_INUM0
;
9601 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9602 "exact non-negative integer");
9604 else if (SCM_LIKELY (SCM_BIGP (k
)))
9608 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9609 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9610 "exact non-negative integer");
9613 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9614 scm_remember_upto_here_1 (k
);
9615 *sp
= scm_i_normbig (s
);
9616 *rp
= scm_i_normbig (r
);
9619 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9620 "exact non-negative integer");
9624 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9626 "Return the square root of @var{z}. Of the two possible roots\n"
9627 "(positive and negative), the one with positive real part\n"
9628 "is returned, or if that's zero then a positive imaginary part.\n"
9632 "(sqrt 9.0) @result{} 3.0\n"
9633 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9634 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9635 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9637 #define FUNC_NAME s_scm_sqrt
9639 if (SCM_COMPLEXP (z
))
9641 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9642 && defined SCM_COMPLEX_VALUE
9643 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9645 double re
= SCM_COMPLEX_REAL (z
);
9646 double im
= SCM_COMPLEX_IMAG (z
);
9647 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9648 0.5 * atan2 (im
, re
));
9651 else if (SCM_NUMBERP (z
))
9653 double xx
= scm_to_double (z
);
9655 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9657 return scm_from_double (sqrt (xx
));
9660 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9671 mpz_init_set_si (z_negative_one
, -1);
9673 /* It may be possible to tune the performance of some algorithms by using
9674 * the following constants to avoid the creation of bignums. Please, before
9675 * using these values, remember the two rules of program optimization:
9676 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9677 scm_c_define ("most-positive-fixnum",
9678 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9679 scm_c_define ("most-negative-fixnum",
9680 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9682 scm_add_feature ("complex");
9683 scm_add_feature ("inexact");
9684 flo0
= scm_from_double (0.0);
9685 flo_log10e
= scm_from_double (M_LOG10E
);
9687 /* determine floating point precision */
9688 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9690 init_dblprec(&scm_dblprec
[i
-2],i
);
9691 init_fx_radix(fx_per_radix
[i
-2],i
);
9694 /* hard code precision for base 10 if the preprocessor tells us to... */
9695 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9698 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9699 #include "libguile/numbers.x"