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_is_exact (SCM val
)
542 return scm_is_true (scm_exact_p (val
));
545 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
547 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
549 #define FUNC_NAME s_scm_inexact_p
551 if (SCM_INEXACTP (x
))
553 else if (SCM_NUMBERP (x
))
556 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
561 scm_is_inexact (SCM val
)
563 return scm_is_true (scm_inexact_p (val
));
566 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
568 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
570 #define FUNC_NAME s_scm_odd_p
574 scm_t_inum val
= SCM_I_INUM (n
);
575 return scm_from_bool ((val
& 1L) != 0);
577 else if (SCM_BIGP (n
))
579 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
580 scm_remember_upto_here_1 (n
);
581 return scm_from_bool (odd_p
);
583 else if (SCM_REALP (n
))
585 double val
= SCM_REAL_VALUE (n
);
586 if (DOUBLE_IS_FINITE (val
))
588 double rem
= fabs (fmod (val
, 2.0));
595 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
600 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
602 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
604 #define FUNC_NAME s_scm_even_p
608 scm_t_inum val
= SCM_I_INUM (n
);
609 return scm_from_bool ((val
& 1L) == 0);
611 else if (SCM_BIGP (n
))
613 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
614 scm_remember_upto_here_1 (n
);
615 return scm_from_bool (even_p
);
617 else if (SCM_REALP (n
))
619 double val
= SCM_REAL_VALUE (n
);
620 if (DOUBLE_IS_FINITE (val
))
622 double rem
= fabs (fmod (val
, 2.0));
629 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
633 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
635 "Return @code{#t} if the real number @var{x} is neither\n"
636 "infinite nor a NaN, @code{#f} otherwise.")
637 #define FUNC_NAME s_scm_finite_p
640 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
641 else if (scm_is_real (x
))
644 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
648 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
650 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
651 "@samp{-inf.0}. Otherwise return @code{#f}.")
652 #define FUNC_NAME s_scm_inf_p
655 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
656 else if (scm_is_real (x
))
659 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
663 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
665 "Return @code{#t} if the real number @var{x} is a NaN,\n"
666 "or @code{#f} otherwise.")
667 #define FUNC_NAME s_scm_nan_p
670 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
671 else if (scm_is_real (x
))
674 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
678 /* Guile's idea of infinity. */
679 static double guile_Inf
;
681 /* Guile's idea of not a number. */
682 static double guile_NaN
;
685 guile_ieee_init (void)
687 /* Some version of gcc on some old version of Linux used to crash when
688 trying to make Inf and NaN. */
691 /* C99 INFINITY, when available.
692 FIXME: The standard allows for INFINITY to be something that overflows
693 at compile time. We ought to have a configure test to check for that
694 before trying to use it. (But in practice we believe this is not a
695 problem on any system guile is likely to target.) */
696 guile_Inf
= INFINITY
;
697 #elif defined HAVE_DINFINITY
699 extern unsigned int DINFINITY
[2];
700 guile_Inf
= (*((double *) (DINFINITY
)));
707 if (guile_Inf
== tmp
)
714 /* C99 NAN, when available */
716 #elif defined HAVE_DQNAN
719 extern unsigned int DQNAN
[2];
720 guile_NaN
= (*((double *)(DQNAN
)));
723 guile_NaN
= guile_Inf
/ guile_Inf
;
727 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
730 #define FUNC_NAME s_scm_inf
732 static int initialized
= 0;
738 return scm_from_double (guile_Inf
);
742 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
745 #define FUNC_NAME s_scm_nan
747 static int initialized
= 0;
753 return scm_from_double (guile_NaN
);
758 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
760 "Return the absolute value of @var{x}.")
761 #define FUNC_NAME s_scm_abs
765 scm_t_inum xx
= SCM_I_INUM (x
);
768 else if (SCM_POSFIXABLE (-xx
))
769 return SCM_I_MAKINUM (-xx
);
771 return scm_i_inum2big (-xx
);
773 else if (SCM_LIKELY (SCM_REALP (x
)))
775 double xx
= SCM_REAL_VALUE (x
);
776 /* If x is a NaN then xx<0 is false so we return x unchanged */
778 return scm_from_double (-xx
);
779 /* Handle signed zeroes properly */
780 else if (SCM_UNLIKELY (xx
== 0.0))
785 else if (SCM_BIGP (x
))
787 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
789 return scm_i_clonebig (x
, 0);
793 else if (SCM_FRACTIONP (x
))
795 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
797 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
798 SCM_FRACTION_DENOMINATOR (x
));
801 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
806 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
808 "Return the quotient of the numbers @var{x} and @var{y}.")
809 #define FUNC_NAME s_scm_quotient
811 if (SCM_LIKELY (scm_is_integer (x
)))
813 if (SCM_LIKELY (scm_is_integer (y
)))
814 return scm_truncate_quotient (x
, y
);
816 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
819 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
823 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
825 "Return the remainder of the numbers @var{x} and @var{y}.\n"
827 "(remainder 13 4) @result{} 1\n"
828 "(remainder -13 4) @result{} -1\n"
830 #define FUNC_NAME s_scm_remainder
832 if (SCM_LIKELY (scm_is_integer (x
)))
834 if (SCM_LIKELY (scm_is_integer (y
)))
835 return scm_truncate_remainder (x
, y
);
837 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
840 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
845 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
847 "Return the modulo of the numbers @var{x} and @var{y}.\n"
849 "(modulo 13 4) @result{} 1\n"
850 "(modulo -13 4) @result{} 3\n"
852 #define FUNC_NAME s_scm_modulo
854 if (SCM_LIKELY (scm_is_integer (x
)))
856 if (SCM_LIKELY (scm_is_integer (y
)))
857 return scm_floor_remainder (x
, y
);
859 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
862 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
866 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
867 two-valued functions. It is called from primitive generics that take
868 two arguments and return two values, when the core procedure is
869 unable to handle the given argument types. If there are GOOPS
870 methods for this primitive generic, it dispatches to GOOPS and, if
871 successful, expects two values to be returned, which are placed in
872 *rp1 and *rp2. If there are no GOOPS methods, it throws a
873 wrong-type-arg exception.
875 FIXME: This obviously belongs somewhere else, but until we decide on
876 the right API, it is here as a static function, because it is needed
877 by the *_divide functions below.
880 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
881 const char *subr
, SCM
*rp1
, SCM
*rp2
)
884 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
886 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
889 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
891 "Return the integer @var{q} such that\n"
892 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
893 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
895 "(euclidean-quotient 123 10) @result{} 12\n"
896 "(euclidean-quotient 123 -10) @result{} -12\n"
897 "(euclidean-quotient -123 10) @result{} -13\n"
898 "(euclidean-quotient -123 -10) @result{} 13\n"
899 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
900 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
902 #define FUNC_NAME s_scm_euclidean_quotient
904 if (scm_is_false (scm_negative_p (y
)))
905 return scm_floor_quotient (x
, y
);
907 return scm_ceiling_quotient (x
, y
);
911 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
913 "Return the real number @var{r} such that\n"
914 "@math{0 <= @var{r} < abs(@var{y})} and\n"
915 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
916 "for some integer @var{q}.\n"
918 "(euclidean-remainder 123 10) @result{} 3\n"
919 "(euclidean-remainder 123 -10) @result{} 3\n"
920 "(euclidean-remainder -123 10) @result{} 7\n"
921 "(euclidean-remainder -123 -10) @result{} 7\n"
922 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
923 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
925 #define FUNC_NAME s_scm_euclidean_remainder
927 if (scm_is_false (scm_negative_p (y
)))
928 return scm_floor_remainder (x
, y
);
930 return scm_ceiling_remainder (x
, y
);
934 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
936 "Return the integer @var{q} and the real number @var{r}\n"
937 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
938 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
940 "(euclidean/ 123 10) @result{} 12 and 3\n"
941 "(euclidean/ 123 -10) @result{} -12 and 3\n"
942 "(euclidean/ -123 10) @result{} -13 and 7\n"
943 "(euclidean/ -123 -10) @result{} 13 and 7\n"
944 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
945 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
947 #define FUNC_NAME s_scm_i_euclidean_divide
949 if (scm_is_false (scm_negative_p (y
)))
950 return scm_i_floor_divide (x
, y
);
952 return scm_i_ceiling_divide (x
, y
);
957 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
959 if (scm_is_false (scm_negative_p (y
)))
960 return scm_floor_divide (x
, y
, qp
, rp
);
962 return scm_ceiling_divide (x
, y
, qp
, rp
);
965 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
966 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
968 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
970 "Return the floor of @math{@var{x} / @var{y}}.\n"
972 "(floor-quotient 123 10) @result{} 12\n"
973 "(floor-quotient 123 -10) @result{} -13\n"
974 "(floor-quotient -123 10) @result{} -13\n"
975 "(floor-quotient -123 -10) @result{} 12\n"
976 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
977 "(floor-quotient 16/3 -10/7) @result{} -4\n"
979 #define FUNC_NAME s_scm_floor_quotient
981 if (SCM_LIKELY (SCM_I_INUMP (x
)))
983 scm_t_inum xx
= SCM_I_INUM (x
);
984 if (SCM_LIKELY (SCM_I_INUMP (y
)))
986 scm_t_inum yy
= SCM_I_INUM (y
);
989 if (SCM_LIKELY (yy
> 0))
991 if (SCM_UNLIKELY (xx
< 0))
994 else if (SCM_UNLIKELY (yy
== 0))
995 scm_num_overflow (s_scm_floor_quotient
);
999 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1000 return SCM_I_MAKINUM (qq
);
1002 return scm_i_inum2big (qq
);
1004 else if (SCM_BIGP (y
))
1006 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1007 scm_remember_upto_here_1 (y
);
1009 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1011 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1013 else if (SCM_REALP (y
))
1014 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1015 else if (SCM_FRACTIONP (y
))
1016 return scm_i_exact_rational_floor_quotient (x
, y
);
1018 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1019 s_scm_floor_quotient
);
1021 else if (SCM_BIGP (x
))
1023 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1025 scm_t_inum yy
= SCM_I_INUM (y
);
1026 if (SCM_UNLIKELY (yy
== 0))
1027 scm_num_overflow (s_scm_floor_quotient
);
1028 else if (SCM_UNLIKELY (yy
== 1))
1032 SCM q
= scm_i_mkbig ();
1034 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1037 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1038 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1040 scm_remember_upto_here_1 (x
);
1041 return scm_i_normbig (q
);
1044 else if (SCM_BIGP (y
))
1046 SCM q
= scm_i_mkbig ();
1047 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1050 scm_remember_upto_here_2 (x
, y
);
1051 return scm_i_normbig (q
);
1053 else if (SCM_REALP (y
))
1054 return scm_i_inexact_floor_quotient
1055 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1056 else if (SCM_FRACTIONP (y
))
1057 return scm_i_exact_rational_floor_quotient (x
, y
);
1059 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1060 s_scm_floor_quotient
);
1062 else if (SCM_REALP (x
))
1064 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1065 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1066 return scm_i_inexact_floor_quotient
1067 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1069 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1070 s_scm_floor_quotient
);
1072 else if (SCM_FRACTIONP (x
))
1075 return scm_i_inexact_floor_quotient
1076 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1077 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1078 return scm_i_exact_rational_floor_quotient (x
, y
);
1080 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1081 s_scm_floor_quotient
);
1084 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1085 s_scm_floor_quotient
);
1090 scm_i_inexact_floor_quotient (double x
, double y
)
1092 if (SCM_UNLIKELY (y
== 0))
1093 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1095 return scm_from_double (floor (x
/ y
));
1099 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1101 return scm_floor_quotient
1102 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1103 scm_product (scm_numerator (y
), scm_denominator (x
)));
1106 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1107 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1109 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1111 "Return the real number @var{r} such that\n"
1112 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1113 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1115 "(floor-remainder 123 10) @result{} 3\n"
1116 "(floor-remainder 123 -10) @result{} -7\n"
1117 "(floor-remainder -123 10) @result{} 7\n"
1118 "(floor-remainder -123 -10) @result{} -3\n"
1119 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1120 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1122 #define FUNC_NAME s_scm_floor_remainder
1124 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1126 scm_t_inum xx
= SCM_I_INUM (x
);
1127 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1129 scm_t_inum yy
= SCM_I_INUM (y
);
1130 if (SCM_UNLIKELY (yy
== 0))
1131 scm_num_overflow (s_scm_floor_remainder
);
1134 scm_t_inum rr
= xx
% yy
;
1135 int needs_adjustment
;
1137 if (SCM_LIKELY (yy
> 0))
1138 needs_adjustment
= (rr
< 0);
1140 needs_adjustment
= (rr
> 0);
1142 if (needs_adjustment
)
1144 return SCM_I_MAKINUM (rr
);
1147 else if (SCM_BIGP (y
))
1149 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1150 scm_remember_upto_here_1 (y
);
1155 SCM r
= scm_i_mkbig ();
1156 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1157 scm_remember_upto_here_1 (y
);
1158 return scm_i_normbig (r
);
1167 SCM r
= scm_i_mkbig ();
1168 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1169 scm_remember_upto_here_1 (y
);
1170 return scm_i_normbig (r
);
1173 else if (SCM_REALP (y
))
1174 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1175 else if (SCM_FRACTIONP (y
))
1176 return scm_i_exact_rational_floor_remainder (x
, y
);
1178 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1179 s_scm_floor_remainder
);
1181 else if (SCM_BIGP (x
))
1183 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1185 scm_t_inum yy
= SCM_I_INUM (y
);
1186 if (SCM_UNLIKELY (yy
== 0))
1187 scm_num_overflow (s_scm_floor_remainder
);
1192 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1194 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1195 scm_remember_upto_here_1 (x
);
1196 return SCM_I_MAKINUM (rr
);
1199 else if (SCM_BIGP (y
))
1201 SCM r
= scm_i_mkbig ();
1202 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1205 scm_remember_upto_here_2 (x
, y
);
1206 return scm_i_normbig (r
);
1208 else if (SCM_REALP (y
))
1209 return scm_i_inexact_floor_remainder
1210 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1211 else if (SCM_FRACTIONP (y
))
1212 return scm_i_exact_rational_floor_remainder (x
, y
);
1214 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1215 s_scm_floor_remainder
);
1217 else if (SCM_REALP (x
))
1219 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1220 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1221 return scm_i_inexact_floor_remainder
1222 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1224 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1225 s_scm_floor_remainder
);
1227 else if (SCM_FRACTIONP (x
))
1230 return scm_i_inexact_floor_remainder
1231 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1232 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1233 return scm_i_exact_rational_floor_remainder (x
, y
);
1235 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1236 s_scm_floor_remainder
);
1239 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1240 s_scm_floor_remainder
);
1245 scm_i_inexact_floor_remainder (double x
, double y
)
1247 /* Although it would be more efficient to use fmod here, we can't
1248 because it would in some cases produce results inconsistent with
1249 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1250 close). In particular, when x is very close to a multiple of y,
1251 then r might be either 0.0 or y, but those two cases must
1252 correspond to different choices of q. If r = 0.0 then q must be
1253 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1254 and remainder chooses the other, it would be bad. */
1255 if (SCM_UNLIKELY (y
== 0))
1256 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1258 return scm_from_double (x
- y
* floor (x
/ y
));
1262 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1264 SCM xd
= scm_denominator (x
);
1265 SCM yd
= scm_denominator (y
);
1266 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1267 scm_product (scm_numerator (y
), xd
));
1268 return scm_divide (r1
, scm_product (xd
, yd
));
1272 static void scm_i_inexact_floor_divide (double x
, double y
,
1274 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1277 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1279 "Return the integer @var{q} and the real number @var{r}\n"
1280 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1281 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1283 "(floor/ 123 10) @result{} 12 and 3\n"
1284 "(floor/ 123 -10) @result{} -13 and -7\n"
1285 "(floor/ -123 10) @result{} -13 and 7\n"
1286 "(floor/ -123 -10) @result{} 12 and -3\n"
1287 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1288 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1290 #define FUNC_NAME s_scm_i_floor_divide
1294 scm_floor_divide(x
, y
, &q
, &r
);
1295 return scm_values (scm_list_2 (q
, r
));
1299 #define s_scm_floor_divide s_scm_i_floor_divide
1300 #define g_scm_floor_divide g_scm_i_floor_divide
1303 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1305 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1307 scm_t_inum xx
= SCM_I_INUM (x
);
1308 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1310 scm_t_inum yy
= SCM_I_INUM (y
);
1311 if (SCM_UNLIKELY (yy
== 0))
1312 scm_num_overflow (s_scm_floor_divide
);
1315 scm_t_inum qq
= xx
/ yy
;
1316 scm_t_inum rr
= xx
% yy
;
1317 int needs_adjustment
;
1319 if (SCM_LIKELY (yy
> 0))
1320 needs_adjustment
= (rr
< 0);
1322 needs_adjustment
= (rr
> 0);
1324 if (needs_adjustment
)
1330 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1331 *qp
= SCM_I_MAKINUM (qq
);
1333 *qp
= scm_i_inum2big (qq
);
1334 *rp
= SCM_I_MAKINUM (rr
);
1338 else if (SCM_BIGP (y
))
1340 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1341 scm_remember_upto_here_1 (y
);
1346 SCM r
= scm_i_mkbig ();
1347 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1348 scm_remember_upto_here_1 (y
);
1349 *qp
= SCM_I_MAKINUM (-1);
1350 *rp
= scm_i_normbig (r
);
1365 SCM r
= scm_i_mkbig ();
1366 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1367 scm_remember_upto_here_1 (y
);
1368 *qp
= SCM_I_MAKINUM (-1);
1369 *rp
= scm_i_normbig (r
);
1373 else if (SCM_REALP (y
))
1374 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1375 else if (SCM_FRACTIONP (y
))
1376 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1378 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1379 s_scm_floor_divide
, qp
, rp
);
1381 else if (SCM_BIGP (x
))
1383 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1385 scm_t_inum yy
= SCM_I_INUM (y
);
1386 if (SCM_UNLIKELY (yy
== 0))
1387 scm_num_overflow (s_scm_floor_divide
);
1390 SCM q
= scm_i_mkbig ();
1391 SCM r
= scm_i_mkbig ();
1393 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1394 SCM_I_BIG_MPZ (x
), yy
);
1397 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1398 SCM_I_BIG_MPZ (x
), -yy
);
1399 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1401 scm_remember_upto_here_1 (x
);
1402 *qp
= scm_i_normbig (q
);
1403 *rp
= scm_i_normbig (r
);
1407 else if (SCM_BIGP (y
))
1409 SCM q
= scm_i_mkbig ();
1410 SCM r
= scm_i_mkbig ();
1411 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1412 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1413 scm_remember_upto_here_2 (x
, y
);
1414 *qp
= scm_i_normbig (q
);
1415 *rp
= scm_i_normbig (r
);
1418 else if (SCM_REALP (y
))
1419 return scm_i_inexact_floor_divide
1420 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1421 else if (SCM_FRACTIONP (y
))
1422 return scm_i_exact_rational_floor_divide (x
, 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_REALP (x
))
1429 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1430 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1431 return scm_i_inexact_floor_divide
1432 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1434 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1435 s_scm_floor_divide
, qp
, rp
);
1437 else if (SCM_FRACTIONP (x
))
1440 return scm_i_inexact_floor_divide
1441 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1442 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1443 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1445 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1446 s_scm_floor_divide
, qp
, rp
);
1449 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1450 s_scm_floor_divide
, qp
, rp
);
1454 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1456 if (SCM_UNLIKELY (y
== 0))
1457 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1460 double q
= floor (x
/ y
);
1461 double r
= x
- q
* y
;
1462 *qp
= scm_from_double (q
);
1463 *rp
= scm_from_double (r
);
1468 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1471 SCM xd
= scm_denominator (x
);
1472 SCM yd
= scm_denominator (y
);
1474 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1475 scm_product (scm_numerator (y
), xd
),
1477 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1480 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1481 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1483 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1485 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1487 "(ceiling-quotient 123 10) @result{} 13\n"
1488 "(ceiling-quotient 123 -10) @result{} -12\n"
1489 "(ceiling-quotient -123 10) @result{} -12\n"
1490 "(ceiling-quotient -123 -10) @result{} 13\n"
1491 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1492 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1494 #define FUNC_NAME s_scm_ceiling_quotient
1496 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1498 scm_t_inum xx
= SCM_I_INUM (x
);
1499 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1501 scm_t_inum yy
= SCM_I_INUM (y
);
1502 if (SCM_UNLIKELY (yy
== 0))
1503 scm_num_overflow (s_scm_ceiling_quotient
);
1506 scm_t_inum xx1
= xx
;
1508 if (SCM_LIKELY (yy
> 0))
1510 if (SCM_LIKELY (xx
>= 0))
1516 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1517 return SCM_I_MAKINUM (qq
);
1519 return scm_i_inum2big (qq
);
1522 else if (SCM_BIGP (y
))
1524 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1525 scm_remember_upto_here_1 (y
);
1526 if (SCM_LIKELY (sign
> 0))
1528 if (SCM_LIKELY (xx
> 0))
1530 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1531 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1532 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1534 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1535 scm_remember_upto_here_1 (y
);
1536 return SCM_I_MAKINUM (-1);
1546 else if (SCM_REALP (y
))
1547 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1548 else if (SCM_FRACTIONP (y
))
1549 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1551 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1552 s_scm_ceiling_quotient
);
1554 else if (SCM_BIGP (x
))
1556 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1558 scm_t_inum yy
= SCM_I_INUM (y
);
1559 if (SCM_UNLIKELY (yy
== 0))
1560 scm_num_overflow (s_scm_ceiling_quotient
);
1561 else if (SCM_UNLIKELY (yy
== 1))
1565 SCM q
= scm_i_mkbig ();
1567 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1570 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1571 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1573 scm_remember_upto_here_1 (x
);
1574 return scm_i_normbig (q
);
1577 else if (SCM_BIGP (y
))
1579 SCM q
= scm_i_mkbig ();
1580 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1583 scm_remember_upto_here_2 (x
, y
);
1584 return scm_i_normbig (q
);
1586 else if (SCM_REALP (y
))
1587 return scm_i_inexact_ceiling_quotient
1588 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1589 else if (SCM_FRACTIONP (y
))
1590 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1592 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1593 s_scm_ceiling_quotient
);
1595 else if (SCM_REALP (x
))
1597 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1598 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1599 return scm_i_inexact_ceiling_quotient
1600 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1602 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1603 s_scm_ceiling_quotient
);
1605 else if (SCM_FRACTIONP (x
))
1608 return scm_i_inexact_ceiling_quotient
1609 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1610 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1611 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1613 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1614 s_scm_ceiling_quotient
);
1617 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1618 s_scm_ceiling_quotient
);
1623 scm_i_inexact_ceiling_quotient (double x
, double y
)
1625 if (SCM_UNLIKELY (y
== 0))
1626 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1628 return scm_from_double (ceil (x
/ y
));
1632 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1634 return scm_ceiling_quotient
1635 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1636 scm_product (scm_numerator (y
), scm_denominator (x
)));
1639 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1640 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1642 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1644 "Return the real number @var{r} such that\n"
1645 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1646 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1648 "(ceiling-remainder 123 10) @result{} -7\n"
1649 "(ceiling-remainder 123 -10) @result{} 3\n"
1650 "(ceiling-remainder -123 10) @result{} -3\n"
1651 "(ceiling-remainder -123 -10) @result{} 7\n"
1652 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1653 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1655 #define FUNC_NAME s_scm_ceiling_remainder
1657 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1659 scm_t_inum xx
= SCM_I_INUM (x
);
1660 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1662 scm_t_inum yy
= SCM_I_INUM (y
);
1663 if (SCM_UNLIKELY (yy
== 0))
1664 scm_num_overflow (s_scm_ceiling_remainder
);
1667 scm_t_inum rr
= xx
% yy
;
1668 int needs_adjustment
;
1670 if (SCM_LIKELY (yy
> 0))
1671 needs_adjustment
= (rr
> 0);
1673 needs_adjustment
= (rr
< 0);
1675 if (needs_adjustment
)
1677 return SCM_I_MAKINUM (rr
);
1680 else if (SCM_BIGP (y
))
1682 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1683 scm_remember_upto_here_1 (y
);
1684 if (SCM_LIKELY (sign
> 0))
1686 if (SCM_LIKELY (xx
> 0))
1688 SCM r
= scm_i_mkbig ();
1689 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1690 scm_remember_upto_here_1 (y
);
1691 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1692 return scm_i_normbig (r
);
1694 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1695 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1696 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1698 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1699 scm_remember_upto_here_1 (y
);
1709 SCM r
= scm_i_mkbig ();
1710 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1711 scm_remember_upto_here_1 (y
);
1712 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1713 return scm_i_normbig (r
);
1716 else if (SCM_REALP (y
))
1717 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1718 else if (SCM_FRACTIONP (y
))
1719 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1721 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1722 s_scm_ceiling_remainder
);
1724 else if (SCM_BIGP (x
))
1726 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1728 scm_t_inum yy
= SCM_I_INUM (y
);
1729 if (SCM_UNLIKELY (yy
== 0))
1730 scm_num_overflow (s_scm_ceiling_remainder
);
1735 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1737 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1738 scm_remember_upto_here_1 (x
);
1739 return SCM_I_MAKINUM (rr
);
1742 else if (SCM_BIGP (y
))
1744 SCM r
= scm_i_mkbig ();
1745 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1748 scm_remember_upto_here_2 (x
, y
);
1749 return scm_i_normbig (r
);
1751 else if (SCM_REALP (y
))
1752 return scm_i_inexact_ceiling_remainder
1753 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1754 else if (SCM_FRACTIONP (y
))
1755 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1757 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1758 s_scm_ceiling_remainder
);
1760 else if (SCM_REALP (x
))
1762 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1763 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1764 return scm_i_inexact_ceiling_remainder
1765 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1767 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1768 s_scm_ceiling_remainder
);
1770 else if (SCM_FRACTIONP (x
))
1773 return scm_i_inexact_ceiling_remainder
1774 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1775 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1776 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1778 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1779 s_scm_ceiling_remainder
);
1782 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1783 s_scm_ceiling_remainder
);
1788 scm_i_inexact_ceiling_remainder (double x
, double y
)
1790 /* Although it would be more efficient to use fmod here, we can't
1791 because it would in some cases produce results inconsistent with
1792 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1793 close). In particular, when x is very close to a multiple of y,
1794 then r might be either 0.0 or -y, but those two cases must
1795 correspond to different choices of q. If r = 0.0 then q must be
1796 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1797 and remainder chooses the other, it would be bad. */
1798 if (SCM_UNLIKELY (y
== 0))
1799 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1801 return scm_from_double (x
- y
* ceil (x
/ y
));
1805 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1807 SCM xd
= scm_denominator (x
);
1808 SCM yd
= scm_denominator (y
);
1809 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1810 scm_product (scm_numerator (y
), xd
));
1811 return scm_divide (r1
, scm_product (xd
, yd
));
1814 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1816 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1819 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1821 "Return the integer @var{q} and the real number @var{r}\n"
1822 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1823 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1825 "(ceiling/ 123 10) @result{} 13 and -7\n"
1826 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1827 "(ceiling/ -123 10) @result{} -12 and -3\n"
1828 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1829 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1830 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1832 #define FUNC_NAME s_scm_i_ceiling_divide
1836 scm_ceiling_divide(x
, y
, &q
, &r
);
1837 return scm_values (scm_list_2 (q
, r
));
1841 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1842 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1845 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1847 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1849 scm_t_inum xx
= SCM_I_INUM (x
);
1850 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1852 scm_t_inum yy
= SCM_I_INUM (y
);
1853 if (SCM_UNLIKELY (yy
== 0))
1854 scm_num_overflow (s_scm_ceiling_divide
);
1857 scm_t_inum qq
= xx
/ yy
;
1858 scm_t_inum rr
= xx
% yy
;
1859 int needs_adjustment
;
1861 if (SCM_LIKELY (yy
> 0))
1862 needs_adjustment
= (rr
> 0);
1864 needs_adjustment
= (rr
< 0);
1866 if (needs_adjustment
)
1871 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1872 *qp
= SCM_I_MAKINUM (qq
);
1874 *qp
= scm_i_inum2big (qq
);
1875 *rp
= SCM_I_MAKINUM (rr
);
1879 else if (SCM_BIGP (y
))
1881 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1882 scm_remember_upto_here_1 (y
);
1883 if (SCM_LIKELY (sign
> 0))
1885 if (SCM_LIKELY (xx
> 0))
1887 SCM r
= scm_i_mkbig ();
1888 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1889 scm_remember_upto_here_1 (y
);
1890 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1892 *rp
= scm_i_normbig (r
);
1894 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1895 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1896 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1898 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1899 scm_remember_upto_here_1 (y
);
1900 *qp
= SCM_I_MAKINUM (-1);
1916 SCM r
= scm_i_mkbig ();
1917 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1918 scm_remember_upto_here_1 (y
);
1919 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1921 *rp
= scm_i_normbig (r
);
1925 else if (SCM_REALP (y
))
1926 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1927 else if (SCM_FRACTIONP (y
))
1928 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1930 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1931 s_scm_ceiling_divide
, qp
, rp
);
1933 else if (SCM_BIGP (x
))
1935 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1937 scm_t_inum yy
= SCM_I_INUM (y
);
1938 if (SCM_UNLIKELY (yy
== 0))
1939 scm_num_overflow (s_scm_ceiling_divide
);
1942 SCM q
= scm_i_mkbig ();
1943 SCM r
= scm_i_mkbig ();
1945 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1946 SCM_I_BIG_MPZ (x
), yy
);
1949 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1950 SCM_I_BIG_MPZ (x
), -yy
);
1951 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1953 scm_remember_upto_here_1 (x
);
1954 *qp
= scm_i_normbig (q
);
1955 *rp
= scm_i_normbig (r
);
1959 else if (SCM_BIGP (y
))
1961 SCM q
= scm_i_mkbig ();
1962 SCM r
= scm_i_mkbig ();
1963 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1964 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1965 scm_remember_upto_here_2 (x
, y
);
1966 *qp
= scm_i_normbig (q
);
1967 *rp
= scm_i_normbig (r
);
1970 else if (SCM_REALP (y
))
1971 return scm_i_inexact_ceiling_divide
1972 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1973 else if (SCM_FRACTIONP (y
))
1974 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1976 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1977 s_scm_ceiling_divide
, qp
, rp
);
1979 else if (SCM_REALP (x
))
1981 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1982 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1983 return scm_i_inexact_ceiling_divide
1984 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1986 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1987 s_scm_ceiling_divide
, qp
, rp
);
1989 else if (SCM_FRACTIONP (x
))
1992 return scm_i_inexact_ceiling_divide
1993 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1994 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1995 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1997 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1998 s_scm_ceiling_divide
, qp
, rp
);
2001 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2002 s_scm_ceiling_divide
, qp
, rp
);
2006 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2008 if (SCM_UNLIKELY (y
== 0))
2009 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2012 double q
= ceil (x
/ y
);
2013 double r
= x
- q
* y
;
2014 *qp
= scm_from_double (q
);
2015 *rp
= scm_from_double (r
);
2020 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2023 SCM xd
= scm_denominator (x
);
2024 SCM yd
= scm_denominator (y
);
2026 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2027 scm_product (scm_numerator (y
), xd
),
2029 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2032 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2033 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2035 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2037 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2039 "(truncate-quotient 123 10) @result{} 12\n"
2040 "(truncate-quotient 123 -10) @result{} -12\n"
2041 "(truncate-quotient -123 10) @result{} -12\n"
2042 "(truncate-quotient -123 -10) @result{} 12\n"
2043 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2044 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2046 #define FUNC_NAME s_scm_truncate_quotient
2048 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2050 scm_t_inum xx
= SCM_I_INUM (x
);
2051 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2053 scm_t_inum yy
= SCM_I_INUM (y
);
2054 if (SCM_UNLIKELY (yy
== 0))
2055 scm_num_overflow (s_scm_truncate_quotient
);
2058 scm_t_inum qq
= xx
/ yy
;
2059 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2060 return SCM_I_MAKINUM (qq
);
2062 return scm_i_inum2big (qq
);
2065 else if (SCM_BIGP (y
))
2067 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2068 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2069 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2071 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2072 scm_remember_upto_here_1 (y
);
2073 return SCM_I_MAKINUM (-1);
2078 else if (SCM_REALP (y
))
2079 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2080 else if (SCM_FRACTIONP (y
))
2081 return scm_i_exact_rational_truncate_quotient (x
, y
);
2083 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2084 s_scm_truncate_quotient
);
2086 else if (SCM_BIGP (x
))
2088 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2090 scm_t_inum yy
= SCM_I_INUM (y
);
2091 if (SCM_UNLIKELY (yy
== 0))
2092 scm_num_overflow (s_scm_truncate_quotient
);
2093 else if (SCM_UNLIKELY (yy
== 1))
2097 SCM q
= scm_i_mkbig ();
2099 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2102 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2103 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2105 scm_remember_upto_here_1 (x
);
2106 return scm_i_normbig (q
);
2109 else if (SCM_BIGP (y
))
2111 SCM q
= scm_i_mkbig ();
2112 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2115 scm_remember_upto_here_2 (x
, y
);
2116 return scm_i_normbig (q
);
2118 else if (SCM_REALP (y
))
2119 return scm_i_inexact_truncate_quotient
2120 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2121 else if (SCM_FRACTIONP (y
))
2122 return scm_i_exact_rational_truncate_quotient (x
, y
);
2124 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2125 s_scm_truncate_quotient
);
2127 else if (SCM_REALP (x
))
2129 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2130 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2131 return scm_i_inexact_truncate_quotient
2132 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2134 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2135 s_scm_truncate_quotient
);
2137 else if (SCM_FRACTIONP (x
))
2140 return scm_i_inexact_truncate_quotient
2141 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2142 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2143 return scm_i_exact_rational_truncate_quotient (x
, y
);
2145 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2146 s_scm_truncate_quotient
);
2149 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2150 s_scm_truncate_quotient
);
2155 scm_i_inexact_truncate_quotient (double x
, double y
)
2157 if (SCM_UNLIKELY (y
== 0))
2158 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2160 return scm_from_double (trunc (x
/ y
));
2164 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2166 return scm_truncate_quotient
2167 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2168 scm_product (scm_numerator (y
), scm_denominator (x
)));
2171 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2172 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2174 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2176 "Return the real number @var{r} such that\n"
2177 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2178 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2180 "(truncate-remainder 123 10) @result{} 3\n"
2181 "(truncate-remainder 123 -10) @result{} 3\n"
2182 "(truncate-remainder -123 10) @result{} -3\n"
2183 "(truncate-remainder -123 -10) @result{} -3\n"
2184 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2185 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2187 #define FUNC_NAME s_scm_truncate_remainder
2189 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2191 scm_t_inum xx
= SCM_I_INUM (x
);
2192 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2194 scm_t_inum yy
= SCM_I_INUM (y
);
2195 if (SCM_UNLIKELY (yy
== 0))
2196 scm_num_overflow (s_scm_truncate_remainder
);
2198 return SCM_I_MAKINUM (xx
% yy
);
2200 else if (SCM_BIGP (y
))
2202 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2203 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2204 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2206 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2207 scm_remember_upto_here_1 (y
);
2213 else if (SCM_REALP (y
))
2214 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2215 else if (SCM_FRACTIONP (y
))
2216 return scm_i_exact_rational_truncate_remainder (x
, y
);
2218 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2219 s_scm_truncate_remainder
);
2221 else if (SCM_BIGP (x
))
2223 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2225 scm_t_inum yy
= SCM_I_INUM (y
);
2226 if (SCM_UNLIKELY (yy
== 0))
2227 scm_num_overflow (s_scm_truncate_remainder
);
2230 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2231 (yy
> 0) ? yy
: -yy
)
2232 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2233 scm_remember_upto_here_1 (x
);
2234 return SCM_I_MAKINUM (rr
);
2237 else if (SCM_BIGP (y
))
2239 SCM r
= scm_i_mkbig ();
2240 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2243 scm_remember_upto_here_2 (x
, y
);
2244 return scm_i_normbig (r
);
2246 else if (SCM_REALP (y
))
2247 return scm_i_inexact_truncate_remainder
2248 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2249 else if (SCM_FRACTIONP (y
))
2250 return scm_i_exact_rational_truncate_remainder (x
, y
);
2252 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2253 s_scm_truncate_remainder
);
2255 else if (SCM_REALP (x
))
2257 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2258 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2259 return scm_i_inexact_truncate_remainder
2260 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2262 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2263 s_scm_truncate_remainder
);
2265 else if (SCM_FRACTIONP (x
))
2268 return scm_i_inexact_truncate_remainder
2269 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2270 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2271 return scm_i_exact_rational_truncate_remainder (x
, y
);
2273 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2274 s_scm_truncate_remainder
);
2277 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2278 s_scm_truncate_remainder
);
2283 scm_i_inexact_truncate_remainder (double x
, double y
)
2285 /* Although it would be more efficient to use fmod here, we can't
2286 because it would in some cases produce results inconsistent with
2287 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2288 close). In particular, when x is very close to a multiple of y,
2289 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2290 correspond to different choices of q. If quotient chooses one and
2291 remainder chooses the other, it would be bad. */
2292 if (SCM_UNLIKELY (y
== 0))
2293 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2295 return scm_from_double (x
- y
* trunc (x
/ y
));
2299 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2301 SCM xd
= scm_denominator (x
);
2302 SCM yd
= scm_denominator (y
);
2303 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2304 scm_product (scm_numerator (y
), xd
));
2305 return scm_divide (r1
, scm_product (xd
, yd
));
2309 static void scm_i_inexact_truncate_divide (double x
, double y
,
2311 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2314 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2316 "Return the integer @var{q} and the real number @var{r}\n"
2317 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2318 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2320 "(truncate/ 123 10) @result{} 12 and 3\n"
2321 "(truncate/ 123 -10) @result{} -12 and 3\n"
2322 "(truncate/ -123 10) @result{} -12 and -3\n"
2323 "(truncate/ -123 -10) @result{} 12 and -3\n"
2324 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2325 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2327 #define FUNC_NAME s_scm_i_truncate_divide
2331 scm_truncate_divide(x
, y
, &q
, &r
);
2332 return scm_values (scm_list_2 (q
, r
));
2336 #define s_scm_truncate_divide s_scm_i_truncate_divide
2337 #define g_scm_truncate_divide g_scm_i_truncate_divide
2340 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2342 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2344 scm_t_inum xx
= SCM_I_INUM (x
);
2345 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2347 scm_t_inum yy
= SCM_I_INUM (y
);
2348 if (SCM_UNLIKELY (yy
== 0))
2349 scm_num_overflow (s_scm_truncate_divide
);
2352 scm_t_inum qq
= xx
/ yy
;
2353 scm_t_inum rr
= xx
% yy
;
2354 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2355 *qp
= SCM_I_MAKINUM (qq
);
2357 *qp
= scm_i_inum2big (qq
);
2358 *rp
= SCM_I_MAKINUM (rr
);
2362 else if (SCM_BIGP (y
))
2364 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2365 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2366 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2368 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2369 scm_remember_upto_here_1 (y
);
2370 *qp
= SCM_I_MAKINUM (-1);
2380 else if (SCM_REALP (y
))
2381 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2382 else if (SCM_FRACTIONP (y
))
2383 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2385 return two_valued_wta_dispatch_2
2386 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2387 s_scm_truncate_divide
, qp
, rp
);
2389 else if (SCM_BIGP (x
))
2391 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2393 scm_t_inum yy
= SCM_I_INUM (y
);
2394 if (SCM_UNLIKELY (yy
== 0))
2395 scm_num_overflow (s_scm_truncate_divide
);
2398 SCM q
= scm_i_mkbig ();
2401 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2402 SCM_I_BIG_MPZ (x
), yy
);
2405 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2406 SCM_I_BIG_MPZ (x
), -yy
);
2407 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2409 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2410 scm_remember_upto_here_1 (x
);
2411 *qp
= scm_i_normbig (q
);
2412 *rp
= SCM_I_MAKINUM (rr
);
2416 else if (SCM_BIGP (y
))
2418 SCM q
= scm_i_mkbig ();
2419 SCM r
= scm_i_mkbig ();
2420 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2421 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2422 scm_remember_upto_here_2 (x
, y
);
2423 *qp
= scm_i_normbig (q
);
2424 *rp
= scm_i_normbig (r
);
2426 else if (SCM_REALP (y
))
2427 return scm_i_inexact_truncate_divide
2428 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2429 else if (SCM_FRACTIONP (y
))
2430 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2432 return two_valued_wta_dispatch_2
2433 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2434 s_scm_truncate_divide
, qp
, rp
);
2436 else if (SCM_REALP (x
))
2438 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2439 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2440 return scm_i_inexact_truncate_divide
2441 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2443 return two_valued_wta_dispatch_2
2444 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2445 s_scm_truncate_divide
, qp
, rp
);
2447 else if (SCM_FRACTIONP (x
))
2450 return scm_i_inexact_truncate_divide
2451 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2452 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2453 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2455 return two_valued_wta_dispatch_2
2456 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2457 s_scm_truncate_divide
, qp
, rp
);
2460 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2461 s_scm_truncate_divide
, qp
, rp
);
2465 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2467 if (SCM_UNLIKELY (y
== 0))
2468 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2471 double q
= trunc (x
/ y
);
2472 double r
= x
- q
* y
;
2473 *qp
= scm_from_double (q
);
2474 *rp
= scm_from_double (r
);
2479 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2482 SCM xd
= scm_denominator (x
);
2483 SCM yd
= scm_denominator (y
);
2485 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2486 scm_product (scm_numerator (y
), xd
),
2488 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2491 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2492 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2493 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2495 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2497 "Return the integer @var{q} such that\n"
2498 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2499 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2501 "(centered-quotient 123 10) @result{} 12\n"
2502 "(centered-quotient 123 -10) @result{} -12\n"
2503 "(centered-quotient -123 10) @result{} -12\n"
2504 "(centered-quotient -123 -10) @result{} 12\n"
2505 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2506 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2508 #define FUNC_NAME s_scm_centered_quotient
2510 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2512 scm_t_inum xx
= SCM_I_INUM (x
);
2513 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2515 scm_t_inum yy
= SCM_I_INUM (y
);
2516 if (SCM_UNLIKELY (yy
== 0))
2517 scm_num_overflow (s_scm_centered_quotient
);
2520 scm_t_inum qq
= xx
/ yy
;
2521 scm_t_inum rr
= xx
% yy
;
2522 if (SCM_LIKELY (xx
> 0))
2524 if (SCM_LIKELY (yy
> 0))
2526 if (rr
>= (yy
+ 1) / 2)
2531 if (rr
>= (1 - yy
) / 2)
2537 if (SCM_LIKELY (yy
> 0))
2548 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2549 return SCM_I_MAKINUM (qq
);
2551 return scm_i_inum2big (qq
);
2554 else if (SCM_BIGP (y
))
2556 /* Pass a denormalized bignum version of x (even though it
2557 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2558 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2560 else if (SCM_REALP (y
))
2561 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2562 else if (SCM_FRACTIONP (y
))
2563 return scm_i_exact_rational_centered_quotient (x
, y
);
2565 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2566 s_scm_centered_quotient
);
2568 else if (SCM_BIGP (x
))
2570 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2572 scm_t_inum yy
= SCM_I_INUM (y
);
2573 if (SCM_UNLIKELY (yy
== 0))
2574 scm_num_overflow (s_scm_centered_quotient
);
2575 else if (SCM_UNLIKELY (yy
== 1))
2579 SCM q
= scm_i_mkbig ();
2581 /* Arrange for rr to initially be non-positive,
2582 because that simplifies the test to see
2583 if it is within the needed bounds. */
2586 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2587 SCM_I_BIG_MPZ (x
), yy
);
2588 scm_remember_upto_here_1 (x
);
2590 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2591 SCM_I_BIG_MPZ (q
), 1);
2595 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2596 SCM_I_BIG_MPZ (x
), -yy
);
2597 scm_remember_upto_here_1 (x
);
2598 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2600 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2601 SCM_I_BIG_MPZ (q
), 1);
2603 return scm_i_normbig (q
);
2606 else if (SCM_BIGP (y
))
2607 return scm_i_bigint_centered_quotient (x
, y
);
2608 else if (SCM_REALP (y
))
2609 return scm_i_inexact_centered_quotient
2610 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2611 else if (SCM_FRACTIONP (y
))
2612 return scm_i_exact_rational_centered_quotient (x
, y
);
2614 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2615 s_scm_centered_quotient
);
2617 else if (SCM_REALP (x
))
2619 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2620 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2621 return scm_i_inexact_centered_quotient
2622 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2624 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2625 s_scm_centered_quotient
);
2627 else if (SCM_FRACTIONP (x
))
2630 return scm_i_inexact_centered_quotient
2631 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2632 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2633 return scm_i_exact_rational_centered_quotient (x
, y
);
2635 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2636 s_scm_centered_quotient
);
2639 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2640 s_scm_centered_quotient
);
2645 scm_i_inexact_centered_quotient (double x
, double y
)
2647 if (SCM_LIKELY (y
> 0))
2648 return scm_from_double (floor (x
/y
+ 0.5));
2649 else if (SCM_LIKELY (y
< 0))
2650 return scm_from_double (ceil (x
/y
- 0.5));
2652 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2657 /* Assumes that both x and y are bigints, though
2658 x might be able to fit into a fixnum. */
2660 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2664 /* Note that x might be small enough to fit into a
2665 fixnum, so we must not let it escape into the wild */
2669 /* min_r will eventually become -abs(y)/2 */
2670 min_r
= scm_i_mkbig ();
2671 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2672 SCM_I_BIG_MPZ (y
), 1);
2674 /* Arrange for rr to initially be non-positive,
2675 because that simplifies the test to see
2676 if it is within the needed bounds. */
2677 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2679 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2680 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2681 scm_remember_upto_here_2 (x
, y
);
2682 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2683 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2684 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2685 SCM_I_BIG_MPZ (q
), 1);
2689 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2690 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2691 scm_remember_upto_here_2 (x
, y
);
2692 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2693 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2694 SCM_I_BIG_MPZ (q
), 1);
2696 scm_remember_upto_here_2 (r
, min_r
);
2697 return scm_i_normbig (q
);
2701 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2703 return scm_centered_quotient
2704 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2705 scm_product (scm_numerator (y
), scm_denominator (x
)));
2708 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2709 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2710 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2712 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2714 "Return the real number @var{r} such that\n"
2715 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2716 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2717 "for some integer @var{q}.\n"
2719 "(centered-remainder 123 10) @result{} 3\n"
2720 "(centered-remainder 123 -10) @result{} 3\n"
2721 "(centered-remainder -123 10) @result{} -3\n"
2722 "(centered-remainder -123 -10) @result{} -3\n"
2723 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2724 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2726 #define FUNC_NAME s_scm_centered_remainder
2728 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2730 scm_t_inum xx
= SCM_I_INUM (x
);
2731 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2733 scm_t_inum yy
= SCM_I_INUM (y
);
2734 if (SCM_UNLIKELY (yy
== 0))
2735 scm_num_overflow (s_scm_centered_remainder
);
2738 scm_t_inum rr
= xx
% yy
;
2739 if (SCM_LIKELY (xx
> 0))
2741 if (SCM_LIKELY (yy
> 0))
2743 if (rr
>= (yy
+ 1) / 2)
2748 if (rr
>= (1 - yy
) / 2)
2754 if (SCM_LIKELY (yy
> 0))
2765 return SCM_I_MAKINUM (rr
);
2768 else if (SCM_BIGP (y
))
2770 /* Pass a denormalized bignum version of x (even though it
2771 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2772 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2774 else if (SCM_REALP (y
))
2775 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2776 else if (SCM_FRACTIONP (y
))
2777 return scm_i_exact_rational_centered_remainder (x
, y
);
2779 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2780 s_scm_centered_remainder
);
2782 else if (SCM_BIGP (x
))
2784 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2786 scm_t_inum yy
= SCM_I_INUM (y
);
2787 if (SCM_UNLIKELY (yy
== 0))
2788 scm_num_overflow (s_scm_centered_remainder
);
2792 /* Arrange for rr to initially be non-positive,
2793 because that simplifies the test to see
2794 if it is within the needed bounds. */
2797 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2798 scm_remember_upto_here_1 (x
);
2804 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2805 scm_remember_upto_here_1 (x
);
2809 return SCM_I_MAKINUM (rr
);
2812 else if (SCM_BIGP (y
))
2813 return scm_i_bigint_centered_remainder (x
, y
);
2814 else if (SCM_REALP (y
))
2815 return scm_i_inexact_centered_remainder
2816 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2817 else if (SCM_FRACTIONP (y
))
2818 return scm_i_exact_rational_centered_remainder (x
, y
);
2820 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2821 s_scm_centered_remainder
);
2823 else if (SCM_REALP (x
))
2825 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2826 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2827 return scm_i_inexact_centered_remainder
2828 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2830 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2831 s_scm_centered_remainder
);
2833 else if (SCM_FRACTIONP (x
))
2836 return scm_i_inexact_centered_remainder
2837 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2838 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2839 return scm_i_exact_rational_centered_remainder (x
, y
);
2841 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2842 s_scm_centered_remainder
);
2845 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2846 s_scm_centered_remainder
);
2851 scm_i_inexact_centered_remainder (double x
, double y
)
2855 /* Although it would be more efficient to use fmod here, we can't
2856 because it would in some cases produce results inconsistent with
2857 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2858 close). In particular, when x-y/2 is very close to a multiple of
2859 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2860 two cases must correspond to different choices of q. If quotient
2861 chooses one and remainder chooses the other, it would be bad. */
2862 if (SCM_LIKELY (y
> 0))
2863 q
= floor (x
/y
+ 0.5);
2864 else if (SCM_LIKELY (y
< 0))
2865 q
= ceil (x
/y
- 0.5);
2867 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2870 return scm_from_double (x
- q
* y
);
2873 /* Assumes that both x and y are bigints, though
2874 x might be able to fit into a fixnum. */
2876 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2880 /* Note that x might be small enough to fit into a
2881 fixnum, so we must not let it escape into the wild */
2884 /* min_r will eventually become -abs(y)/2 */
2885 min_r
= scm_i_mkbig ();
2886 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2887 SCM_I_BIG_MPZ (y
), 1);
2889 /* Arrange for rr to initially be non-positive,
2890 because that simplifies the test to see
2891 if it is within the needed bounds. */
2892 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2894 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2895 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2896 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2897 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2898 mpz_add (SCM_I_BIG_MPZ (r
),
2904 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2905 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2906 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2907 mpz_sub (SCM_I_BIG_MPZ (r
),
2911 scm_remember_upto_here_2 (x
, y
);
2912 return scm_i_normbig (r
);
2916 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2918 SCM xd
= scm_denominator (x
);
2919 SCM yd
= scm_denominator (y
);
2920 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2921 scm_product (scm_numerator (y
), xd
));
2922 return scm_divide (r1
, scm_product (xd
, yd
));
2926 static void scm_i_inexact_centered_divide (double x
, double y
,
2928 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2929 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2932 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2934 "Return the integer @var{q} and the real number @var{r}\n"
2935 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2936 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2938 "(centered/ 123 10) @result{} 12 and 3\n"
2939 "(centered/ 123 -10) @result{} -12 and 3\n"
2940 "(centered/ -123 10) @result{} -12 and -3\n"
2941 "(centered/ -123 -10) @result{} 12 and -3\n"
2942 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2943 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2945 #define FUNC_NAME s_scm_i_centered_divide
2949 scm_centered_divide(x
, y
, &q
, &r
);
2950 return scm_values (scm_list_2 (q
, r
));
2954 #define s_scm_centered_divide s_scm_i_centered_divide
2955 #define g_scm_centered_divide g_scm_i_centered_divide
2958 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2960 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2962 scm_t_inum xx
= SCM_I_INUM (x
);
2963 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2965 scm_t_inum yy
= SCM_I_INUM (y
);
2966 if (SCM_UNLIKELY (yy
== 0))
2967 scm_num_overflow (s_scm_centered_divide
);
2970 scm_t_inum qq
= xx
/ yy
;
2971 scm_t_inum rr
= xx
% yy
;
2972 if (SCM_LIKELY (xx
> 0))
2974 if (SCM_LIKELY (yy
> 0))
2976 if (rr
>= (yy
+ 1) / 2)
2981 if (rr
>= (1 - yy
) / 2)
2987 if (SCM_LIKELY (yy
> 0))
2998 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2999 *qp
= SCM_I_MAKINUM (qq
);
3001 *qp
= scm_i_inum2big (qq
);
3002 *rp
= SCM_I_MAKINUM (rr
);
3006 else if (SCM_BIGP (y
))
3008 /* Pass a denormalized bignum version of x (even though it
3009 can fit in a fixnum) to scm_i_bigint_centered_divide */
3010 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3012 else if (SCM_REALP (y
))
3013 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3014 else if (SCM_FRACTIONP (y
))
3015 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3017 return two_valued_wta_dispatch_2
3018 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3019 s_scm_centered_divide
, qp
, rp
);
3021 else if (SCM_BIGP (x
))
3023 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3025 scm_t_inum yy
= SCM_I_INUM (y
);
3026 if (SCM_UNLIKELY (yy
== 0))
3027 scm_num_overflow (s_scm_centered_divide
);
3030 SCM q
= scm_i_mkbig ();
3032 /* Arrange for rr to initially be non-positive,
3033 because that simplifies the test to see
3034 if it is within the needed bounds. */
3037 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3038 SCM_I_BIG_MPZ (x
), yy
);
3039 scm_remember_upto_here_1 (x
);
3042 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3043 SCM_I_BIG_MPZ (q
), 1);
3049 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3050 SCM_I_BIG_MPZ (x
), -yy
);
3051 scm_remember_upto_here_1 (x
);
3052 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3055 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3056 SCM_I_BIG_MPZ (q
), 1);
3060 *qp
= scm_i_normbig (q
);
3061 *rp
= SCM_I_MAKINUM (rr
);
3065 else if (SCM_BIGP (y
))
3066 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3067 else if (SCM_REALP (y
))
3068 return scm_i_inexact_centered_divide
3069 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3070 else if (SCM_FRACTIONP (y
))
3071 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3073 return two_valued_wta_dispatch_2
3074 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3075 s_scm_centered_divide
, qp
, rp
);
3077 else if (SCM_REALP (x
))
3079 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3080 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3081 return scm_i_inexact_centered_divide
3082 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3084 return two_valued_wta_dispatch_2
3085 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3086 s_scm_centered_divide
, qp
, rp
);
3088 else if (SCM_FRACTIONP (x
))
3091 return scm_i_inexact_centered_divide
3092 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3093 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3094 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3096 return two_valued_wta_dispatch_2
3097 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3098 s_scm_centered_divide
, qp
, rp
);
3101 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3102 s_scm_centered_divide
, qp
, rp
);
3106 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3110 if (SCM_LIKELY (y
> 0))
3111 q
= floor (x
/y
+ 0.5);
3112 else if (SCM_LIKELY (y
< 0))
3113 q
= ceil (x
/y
- 0.5);
3115 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3119 *qp
= scm_from_double (q
);
3120 *rp
= scm_from_double (r
);
3123 /* Assumes that both x and y are bigints, though
3124 x might be able to fit into a fixnum. */
3126 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3130 /* Note that x might be small enough to fit into a
3131 fixnum, so we must not let it escape into the wild */
3135 /* min_r will eventually become -abs(y/2) */
3136 min_r
= scm_i_mkbig ();
3137 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3138 SCM_I_BIG_MPZ (y
), 1);
3140 /* Arrange for rr to initially be non-positive,
3141 because that simplifies the test to see
3142 if it is within the needed bounds. */
3143 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3145 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3146 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3147 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3148 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3150 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3151 SCM_I_BIG_MPZ (q
), 1);
3152 mpz_add (SCM_I_BIG_MPZ (r
),
3159 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3160 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3161 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3163 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3164 SCM_I_BIG_MPZ (q
), 1);
3165 mpz_sub (SCM_I_BIG_MPZ (r
),
3170 scm_remember_upto_here_2 (x
, y
);
3171 *qp
= scm_i_normbig (q
);
3172 *rp
= scm_i_normbig (r
);
3176 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3179 SCM xd
= scm_denominator (x
);
3180 SCM yd
= scm_denominator (y
);
3182 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3183 scm_product (scm_numerator (y
), xd
),
3185 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3188 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3189 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3190 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3192 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3194 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3195 "with ties going to the nearest even integer.\n"
3197 "(round-quotient 123 10) @result{} 12\n"
3198 "(round-quotient 123 -10) @result{} -12\n"
3199 "(round-quotient -123 10) @result{} -12\n"
3200 "(round-quotient -123 -10) @result{} 12\n"
3201 "(round-quotient 125 10) @result{} 12\n"
3202 "(round-quotient 127 10) @result{} 13\n"
3203 "(round-quotient 135 10) @result{} 14\n"
3204 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3205 "(round-quotient 16/3 -10/7) @result{} -4\n"
3207 #define FUNC_NAME s_scm_round_quotient
3209 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3211 scm_t_inum xx
= SCM_I_INUM (x
);
3212 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3214 scm_t_inum yy
= SCM_I_INUM (y
);
3215 if (SCM_UNLIKELY (yy
== 0))
3216 scm_num_overflow (s_scm_round_quotient
);
3219 scm_t_inum qq
= xx
/ yy
;
3220 scm_t_inum rr
= xx
% yy
;
3222 scm_t_inum r2
= 2 * rr
;
3224 if (SCM_LIKELY (yy
< 0))
3244 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3245 return SCM_I_MAKINUM (qq
);
3247 return scm_i_inum2big (qq
);
3250 else if (SCM_BIGP (y
))
3252 /* Pass a denormalized bignum version of x (even though it
3253 can fit in a fixnum) to scm_i_bigint_round_quotient */
3254 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3256 else if (SCM_REALP (y
))
3257 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3258 else if (SCM_FRACTIONP (y
))
3259 return scm_i_exact_rational_round_quotient (x
, y
);
3261 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3262 s_scm_round_quotient
);
3264 else if (SCM_BIGP (x
))
3266 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3268 scm_t_inum yy
= SCM_I_INUM (y
);
3269 if (SCM_UNLIKELY (yy
== 0))
3270 scm_num_overflow (s_scm_round_quotient
);
3271 else if (SCM_UNLIKELY (yy
== 1))
3275 SCM q
= scm_i_mkbig ();
3277 int needs_adjustment
;
3281 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3282 SCM_I_BIG_MPZ (x
), yy
);
3283 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3284 needs_adjustment
= (2*rr
>= yy
);
3286 needs_adjustment
= (2*rr
> yy
);
3290 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3291 SCM_I_BIG_MPZ (x
), -yy
);
3292 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3293 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3294 needs_adjustment
= (2*rr
<= yy
);
3296 needs_adjustment
= (2*rr
< yy
);
3298 scm_remember_upto_here_1 (x
);
3299 if (needs_adjustment
)
3300 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3301 return scm_i_normbig (q
);
3304 else if (SCM_BIGP (y
))
3305 return scm_i_bigint_round_quotient (x
, y
);
3306 else if (SCM_REALP (y
))
3307 return scm_i_inexact_round_quotient
3308 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3309 else if (SCM_FRACTIONP (y
))
3310 return scm_i_exact_rational_round_quotient (x
, y
);
3312 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3313 s_scm_round_quotient
);
3315 else if (SCM_REALP (x
))
3317 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3318 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3319 return scm_i_inexact_round_quotient
3320 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3322 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3323 s_scm_round_quotient
);
3325 else if (SCM_FRACTIONP (x
))
3328 return scm_i_inexact_round_quotient
3329 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3330 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3331 return scm_i_exact_rational_round_quotient (x
, y
);
3333 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3334 s_scm_round_quotient
);
3337 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3338 s_scm_round_quotient
);
3343 scm_i_inexact_round_quotient (double x
, double y
)
3345 if (SCM_UNLIKELY (y
== 0))
3346 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3348 return scm_from_double (scm_c_round (x
/ y
));
3351 /* Assumes that both x and y are bigints, though
3352 x might be able to fit into a fixnum. */
3354 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3357 int cmp
, needs_adjustment
;
3359 /* Note that x might be small enough to fit into a
3360 fixnum, so we must not let it escape into the wild */
3363 r2
= scm_i_mkbig ();
3365 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3366 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3367 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3368 scm_remember_upto_here_2 (x
, r
);
3370 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3371 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3372 needs_adjustment
= (cmp
>= 0);
3374 needs_adjustment
= (cmp
> 0);
3375 scm_remember_upto_here_2 (r2
, y
);
3377 if (needs_adjustment
)
3378 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3380 return scm_i_normbig (q
);
3384 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3386 return scm_round_quotient
3387 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3388 scm_product (scm_numerator (y
), scm_denominator (x
)));
3391 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3392 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3393 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3395 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3397 "Return the real number @var{r} such that\n"
3398 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3399 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3400 "nearest integer, with ties going to the nearest\n"
3403 "(round-remainder 123 10) @result{} 3\n"
3404 "(round-remainder 123 -10) @result{} 3\n"
3405 "(round-remainder -123 10) @result{} -3\n"
3406 "(round-remainder -123 -10) @result{} -3\n"
3407 "(round-remainder 125 10) @result{} 5\n"
3408 "(round-remainder 127 10) @result{} -3\n"
3409 "(round-remainder 135 10) @result{} -5\n"
3410 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3411 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3413 #define FUNC_NAME s_scm_round_remainder
3415 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3417 scm_t_inum xx
= SCM_I_INUM (x
);
3418 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3420 scm_t_inum yy
= SCM_I_INUM (y
);
3421 if (SCM_UNLIKELY (yy
== 0))
3422 scm_num_overflow (s_scm_round_remainder
);
3425 scm_t_inum qq
= xx
/ yy
;
3426 scm_t_inum rr
= xx
% yy
;
3428 scm_t_inum r2
= 2 * rr
;
3430 if (SCM_LIKELY (yy
< 0))
3450 return SCM_I_MAKINUM (rr
);
3453 else if (SCM_BIGP (y
))
3455 /* Pass a denormalized bignum version of x (even though it
3456 can fit in a fixnum) to scm_i_bigint_round_remainder */
3457 return scm_i_bigint_round_remainder
3458 (scm_i_long2big (xx
), y
);
3460 else if (SCM_REALP (y
))
3461 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3462 else if (SCM_FRACTIONP (y
))
3463 return scm_i_exact_rational_round_remainder (x
, y
);
3465 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3466 s_scm_round_remainder
);
3468 else if (SCM_BIGP (x
))
3470 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3472 scm_t_inum yy
= SCM_I_INUM (y
);
3473 if (SCM_UNLIKELY (yy
== 0))
3474 scm_num_overflow (s_scm_round_remainder
);
3477 SCM q
= scm_i_mkbig ();
3479 int needs_adjustment
;
3483 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3484 SCM_I_BIG_MPZ (x
), yy
);
3485 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3486 needs_adjustment
= (2*rr
>= yy
);
3488 needs_adjustment
= (2*rr
> yy
);
3492 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3493 SCM_I_BIG_MPZ (x
), -yy
);
3494 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3495 needs_adjustment
= (2*rr
<= yy
);
3497 needs_adjustment
= (2*rr
< yy
);
3499 scm_remember_upto_here_2 (x
, q
);
3500 if (needs_adjustment
)
3502 return SCM_I_MAKINUM (rr
);
3505 else if (SCM_BIGP (y
))
3506 return scm_i_bigint_round_remainder (x
, y
);
3507 else if (SCM_REALP (y
))
3508 return scm_i_inexact_round_remainder
3509 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3510 else if (SCM_FRACTIONP (y
))
3511 return scm_i_exact_rational_round_remainder (x
, y
);
3513 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3514 s_scm_round_remainder
);
3516 else if (SCM_REALP (x
))
3518 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3519 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3520 return scm_i_inexact_round_remainder
3521 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3523 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3524 s_scm_round_remainder
);
3526 else if (SCM_FRACTIONP (x
))
3529 return scm_i_inexact_round_remainder
3530 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3531 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3532 return scm_i_exact_rational_round_remainder (x
, y
);
3534 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3535 s_scm_round_remainder
);
3538 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3539 s_scm_round_remainder
);
3544 scm_i_inexact_round_remainder (double x
, double y
)
3546 /* Although it would be more efficient to use fmod here, we can't
3547 because it would in some cases produce results inconsistent with
3548 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3549 close). In particular, when x-y/2 is very close to a multiple of
3550 y, then r might be either -abs(y/2) or abs(y/2), but those two
3551 cases must correspond to different choices of q. If quotient
3552 chooses one and remainder chooses the other, it would be bad. */
3554 if (SCM_UNLIKELY (y
== 0))
3555 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3558 double q
= scm_c_round (x
/ y
);
3559 return scm_from_double (x
- q
* y
);
3563 /* Assumes that both x and y are bigints, though
3564 x might be able to fit into a fixnum. */
3566 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3569 int cmp
, needs_adjustment
;
3571 /* Note that x might be small enough to fit into a
3572 fixnum, so we must not let it escape into the wild */
3575 r2
= scm_i_mkbig ();
3577 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3578 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3579 scm_remember_upto_here_1 (x
);
3580 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3582 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3583 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3584 needs_adjustment
= (cmp
>= 0);
3586 needs_adjustment
= (cmp
> 0);
3587 scm_remember_upto_here_2 (q
, r2
);
3589 if (needs_adjustment
)
3590 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3592 scm_remember_upto_here_1 (y
);
3593 return scm_i_normbig (r
);
3597 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3599 SCM xd
= scm_denominator (x
);
3600 SCM yd
= scm_denominator (y
);
3601 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3602 scm_product (scm_numerator (y
), xd
));
3603 return scm_divide (r1
, scm_product (xd
, yd
));
3607 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3608 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3609 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3611 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3613 "Return the integer @var{q} and the real number @var{r}\n"
3614 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3615 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3616 "nearest integer, with ties going to the nearest even integer.\n"
3618 "(round/ 123 10) @result{} 12 and 3\n"
3619 "(round/ 123 -10) @result{} -12 and 3\n"
3620 "(round/ -123 10) @result{} -12 and -3\n"
3621 "(round/ -123 -10) @result{} 12 and -3\n"
3622 "(round/ 125 10) @result{} 12 and 5\n"
3623 "(round/ 127 10) @result{} 13 and -3\n"
3624 "(round/ 135 10) @result{} 14 and -5\n"
3625 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3626 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3628 #define FUNC_NAME s_scm_i_round_divide
3632 scm_round_divide(x
, y
, &q
, &r
);
3633 return scm_values (scm_list_2 (q
, r
));
3637 #define s_scm_round_divide s_scm_i_round_divide
3638 #define g_scm_round_divide g_scm_i_round_divide
3641 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3643 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3645 scm_t_inum xx
= SCM_I_INUM (x
);
3646 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3648 scm_t_inum yy
= SCM_I_INUM (y
);
3649 if (SCM_UNLIKELY (yy
== 0))
3650 scm_num_overflow (s_scm_round_divide
);
3653 scm_t_inum qq
= xx
/ yy
;
3654 scm_t_inum rr
= xx
% yy
;
3656 scm_t_inum r2
= 2 * rr
;
3658 if (SCM_LIKELY (yy
< 0))
3678 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3679 *qp
= SCM_I_MAKINUM (qq
);
3681 *qp
= scm_i_inum2big (qq
);
3682 *rp
= SCM_I_MAKINUM (rr
);
3686 else if (SCM_BIGP (y
))
3688 /* Pass a denormalized bignum version of x (even though it
3689 can fit in a fixnum) to scm_i_bigint_round_divide */
3690 return scm_i_bigint_round_divide
3691 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3693 else if (SCM_REALP (y
))
3694 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3695 else if (SCM_FRACTIONP (y
))
3696 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3698 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3699 s_scm_round_divide
, qp
, rp
);
3701 else if (SCM_BIGP (x
))
3703 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3705 scm_t_inum yy
= SCM_I_INUM (y
);
3706 if (SCM_UNLIKELY (yy
== 0))
3707 scm_num_overflow (s_scm_round_divide
);
3710 SCM q
= scm_i_mkbig ();
3712 int needs_adjustment
;
3716 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3717 SCM_I_BIG_MPZ (x
), yy
);
3718 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3719 needs_adjustment
= (2*rr
>= yy
);
3721 needs_adjustment
= (2*rr
> yy
);
3725 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3726 SCM_I_BIG_MPZ (x
), -yy
);
3727 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3728 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3729 needs_adjustment
= (2*rr
<= yy
);
3731 needs_adjustment
= (2*rr
< yy
);
3733 scm_remember_upto_here_1 (x
);
3734 if (needs_adjustment
)
3736 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3739 *qp
= scm_i_normbig (q
);
3740 *rp
= SCM_I_MAKINUM (rr
);
3744 else if (SCM_BIGP (y
))
3745 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3746 else if (SCM_REALP (y
))
3747 return scm_i_inexact_round_divide
3748 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3749 else if (SCM_FRACTIONP (y
))
3750 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3752 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3753 s_scm_round_divide
, qp
, rp
);
3755 else if (SCM_REALP (x
))
3757 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3758 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3759 return scm_i_inexact_round_divide
3760 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3762 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3763 s_scm_round_divide
, qp
, rp
);
3765 else if (SCM_FRACTIONP (x
))
3768 return scm_i_inexact_round_divide
3769 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3770 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3771 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3773 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3774 s_scm_round_divide
, qp
, rp
);
3777 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3778 s_scm_round_divide
, qp
, rp
);
3782 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3784 if (SCM_UNLIKELY (y
== 0))
3785 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3788 double q
= scm_c_round (x
/ y
);
3789 double r
= x
- q
* y
;
3790 *qp
= scm_from_double (q
);
3791 *rp
= scm_from_double (r
);
3795 /* Assumes that both x and y are bigints, though
3796 x might be able to fit into a fixnum. */
3798 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3801 int cmp
, needs_adjustment
;
3803 /* Note that x might be small enough to fit into a
3804 fixnum, so we must not let it escape into the wild */
3807 r2
= scm_i_mkbig ();
3809 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3810 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3811 scm_remember_upto_here_1 (x
);
3812 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3814 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3815 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3816 needs_adjustment
= (cmp
>= 0);
3818 needs_adjustment
= (cmp
> 0);
3820 if (needs_adjustment
)
3822 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3823 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3826 scm_remember_upto_here_2 (r2
, y
);
3827 *qp
= scm_i_normbig (q
);
3828 *rp
= scm_i_normbig (r
);
3832 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3835 SCM xd
= scm_denominator (x
);
3836 SCM yd
= scm_denominator (y
);
3838 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3839 scm_product (scm_numerator (y
), xd
),
3841 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3845 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3846 (SCM x
, SCM y
, SCM rest
),
3847 "Return the greatest common divisor of all parameter values.\n"
3848 "If called without arguments, 0 is returned.")
3849 #define FUNC_NAME s_scm_i_gcd
3851 while (!scm_is_null (rest
))
3852 { x
= scm_gcd (x
, y
);
3854 rest
= scm_cdr (rest
);
3856 return scm_gcd (x
, y
);
3860 #define s_gcd s_scm_i_gcd
3861 #define g_gcd g_scm_i_gcd
3864 scm_gcd (SCM x
, SCM y
)
3867 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3869 if (SCM_I_INUMP (x
))
3871 if (SCM_I_INUMP (y
))
3873 scm_t_inum xx
= SCM_I_INUM (x
);
3874 scm_t_inum yy
= SCM_I_INUM (y
);
3875 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3876 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3886 /* Determine a common factor 2^k */
3887 while (!(1 & (u
| v
)))
3893 /* Now, any factor 2^n can be eliminated */
3913 return (SCM_POSFIXABLE (result
)
3914 ? SCM_I_MAKINUM (result
)
3915 : scm_i_inum2big (result
));
3917 else if (SCM_BIGP (y
))
3923 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3925 else if (SCM_BIGP (x
))
3927 if (SCM_I_INUMP (y
))
3932 yy
= SCM_I_INUM (y
);
3937 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3938 scm_remember_upto_here_1 (x
);
3939 return (SCM_POSFIXABLE (result
)
3940 ? SCM_I_MAKINUM (result
)
3941 : scm_from_unsigned_integer (result
));
3943 else if (SCM_BIGP (y
))
3945 SCM result
= scm_i_mkbig ();
3946 mpz_gcd (SCM_I_BIG_MPZ (result
),
3949 scm_remember_upto_here_2 (x
, y
);
3950 return scm_i_normbig (result
);
3953 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3956 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3959 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3960 (SCM x
, SCM y
, SCM rest
),
3961 "Return the least common multiple of the arguments.\n"
3962 "If called without arguments, 1 is returned.")
3963 #define FUNC_NAME s_scm_i_lcm
3965 while (!scm_is_null (rest
))
3966 { x
= scm_lcm (x
, y
);
3968 rest
= scm_cdr (rest
);
3970 return scm_lcm (x
, y
);
3974 #define s_lcm s_scm_i_lcm
3975 #define g_lcm g_scm_i_lcm
3978 scm_lcm (SCM n1
, SCM n2
)
3980 if (SCM_UNBNDP (n2
))
3982 if (SCM_UNBNDP (n1
))
3983 return SCM_I_MAKINUM (1L);
3984 n2
= SCM_I_MAKINUM (1L);
3987 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
3988 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3989 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
3990 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
3992 if (SCM_I_INUMP (n1
))
3994 if (SCM_I_INUMP (n2
))
3996 SCM d
= scm_gcd (n1
, n2
);
3997 if (scm_is_eq (d
, SCM_INUM0
))
4000 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4004 /* inum n1, big n2 */
4007 SCM result
= scm_i_mkbig ();
4008 scm_t_inum nn1
= SCM_I_INUM (n1
);
4009 if (nn1
== 0) return SCM_INUM0
;
4010 if (nn1
< 0) nn1
= - nn1
;
4011 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4012 scm_remember_upto_here_1 (n2
);
4020 if (SCM_I_INUMP (n2
))
4027 SCM result
= scm_i_mkbig ();
4028 mpz_lcm(SCM_I_BIG_MPZ (result
),
4030 SCM_I_BIG_MPZ (n2
));
4031 scm_remember_upto_here_2(n1
, n2
);
4032 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4038 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4043 + + + x (map digit:logand X Y)
4044 + - + x (map digit:logand X (lognot (+ -1 Y)))
4045 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4046 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4051 + + + (map digit:logior X Y)
4052 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4053 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4054 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4059 + + + (map digit:logxor X Y)
4060 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4061 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4062 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4067 + + (any digit:logand X Y)
4068 + - (any digit:logand X (lognot (+ -1 Y)))
4069 - + (any digit:logand (lognot (+ -1 X)) Y)
4074 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4075 (SCM x
, SCM y
, SCM rest
),
4076 "Return the bitwise AND of the integer arguments.\n\n"
4078 "(logand) @result{} -1\n"
4079 "(logand 7) @result{} 7\n"
4080 "(logand #b111 #b011 #b001) @result{} 1\n"
4082 #define FUNC_NAME s_scm_i_logand
4084 while (!scm_is_null (rest
))
4085 { x
= scm_logand (x
, y
);
4087 rest
= scm_cdr (rest
);
4089 return scm_logand (x
, y
);
4093 #define s_scm_logand s_scm_i_logand
4095 SCM
scm_logand (SCM n1
, SCM n2
)
4096 #define FUNC_NAME s_scm_logand
4100 if (SCM_UNBNDP (n2
))
4102 if (SCM_UNBNDP (n1
))
4103 return SCM_I_MAKINUM (-1);
4104 else if (!SCM_NUMBERP (n1
))
4105 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4106 else if (SCM_NUMBERP (n1
))
4109 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4112 if (SCM_I_INUMP (n1
))
4114 nn1
= SCM_I_INUM (n1
);
4115 if (SCM_I_INUMP (n2
))
4117 scm_t_inum nn2
= SCM_I_INUM (n2
);
4118 return SCM_I_MAKINUM (nn1
& nn2
);
4120 else if SCM_BIGP (n2
)
4126 SCM result_z
= scm_i_mkbig ();
4128 mpz_init_set_si (nn1_z
, nn1
);
4129 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4130 scm_remember_upto_here_1 (n2
);
4132 return scm_i_normbig (result_z
);
4136 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4138 else if (SCM_BIGP (n1
))
4140 if (SCM_I_INUMP (n2
))
4143 nn1
= SCM_I_INUM (n1
);
4146 else if (SCM_BIGP (n2
))
4148 SCM result_z
= scm_i_mkbig ();
4149 mpz_and (SCM_I_BIG_MPZ (result_z
),
4151 SCM_I_BIG_MPZ (n2
));
4152 scm_remember_upto_here_2 (n1
, n2
);
4153 return scm_i_normbig (result_z
);
4156 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4159 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4164 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4165 (SCM x
, SCM y
, SCM rest
),
4166 "Return the bitwise OR of the integer arguments.\n\n"
4168 "(logior) @result{} 0\n"
4169 "(logior 7) @result{} 7\n"
4170 "(logior #b000 #b001 #b011) @result{} 3\n"
4172 #define FUNC_NAME s_scm_i_logior
4174 while (!scm_is_null (rest
))
4175 { x
= scm_logior (x
, y
);
4177 rest
= scm_cdr (rest
);
4179 return scm_logior (x
, y
);
4183 #define s_scm_logior s_scm_i_logior
4185 SCM
scm_logior (SCM n1
, SCM n2
)
4186 #define FUNC_NAME s_scm_logior
4190 if (SCM_UNBNDP (n2
))
4192 if (SCM_UNBNDP (n1
))
4194 else if (SCM_NUMBERP (n1
))
4197 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4200 if (SCM_I_INUMP (n1
))
4202 nn1
= SCM_I_INUM (n1
);
4203 if (SCM_I_INUMP (n2
))
4205 long nn2
= SCM_I_INUM (n2
);
4206 return SCM_I_MAKINUM (nn1
| nn2
);
4208 else if (SCM_BIGP (n2
))
4214 SCM result_z
= scm_i_mkbig ();
4216 mpz_init_set_si (nn1_z
, nn1
);
4217 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4218 scm_remember_upto_here_1 (n2
);
4220 return scm_i_normbig (result_z
);
4224 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4226 else if (SCM_BIGP (n1
))
4228 if (SCM_I_INUMP (n2
))
4231 nn1
= SCM_I_INUM (n1
);
4234 else if (SCM_BIGP (n2
))
4236 SCM result_z
= scm_i_mkbig ();
4237 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4239 SCM_I_BIG_MPZ (n2
));
4240 scm_remember_upto_here_2 (n1
, n2
);
4241 return scm_i_normbig (result_z
);
4244 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4247 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4252 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4253 (SCM x
, SCM y
, SCM rest
),
4254 "Return the bitwise XOR of the integer arguments. A bit is\n"
4255 "set in the result if it is set in an odd number of arguments.\n"
4257 "(logxor) @result{} 0\n"
4258 "(logxor 7) @result{} 7\n"
4259 "(logxor #b000 #b001 #b011) @result{} 2\n"
4260 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4262 #define FUNC_NAME s_scm_i_logxor
4264 while (!scm_is_null (rest
))
4265 { x
= scm_logxor (x
, y
);
4267 rest
= scm_cdr (rest
);
4269 return scm_logxor (x
, y
);
4273 #define s_scm_logxor s_scm_i_logxor
4275 SCM
scm_logxor (SCM n1
, SCM n2
)
4276 #define FUNC_NAME s_scm_logxor
4280 if (SCM_UNBNDP (n2
))
4282 if (SCM_UNBNDP (n1
))
4284 else if (SCM_NUMBERP (n1
))
4287 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4290 if (SCM_I_INUMP (n1
))
4292 nn1
= SCM_I_INUM (n1
);
4293 if (SCM_I_INUMP (n2
))
4295 scm_t_inum nn2
= SCM_I_INUM (n2
);
4296 return SCM_I_MAKINUM (nn1
^ nn2
);
4298 else if (SCM_BIGP (n2
))
4302 SCM result_z
= scm_i_mkbig ();
4304 mpz_init_set_si (nn1_z
, nn1
);
4305 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4306 scm_remember_upto_here_1 (n2
);
4308 return scm_i_normbig (result_z
);
4312 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4314 else if (SCM_BIGP (n1
))
4316 if (SCM_I_INUMP (n2
))
4319 nn1
= SCM_I_INUM (n1
);
4322 else if (SCM_BIGP (n2
))
4324 SCM result_z
= scm_i_mkbig ();
4325 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4327 SCM_I_BIG_MPZ (n2
));
4328 scm_remember_upto_here_2 (n1
, n2
);
4329 return scm_i_normbig (result_z
);
4332 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4335 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4340 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4342 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4343 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4344 "without actually calculating the @code{logand}, just testing\n"
4348 "(logtest #b0100 #b1011) @result{} #f\n"
4349 "(logtest #b0100 #b0111) @result{} #t\n"
4351 #define FUNC_NAME s_scm_logtest
4355 if (SCM_I_INUMP (j
))
4357 nj
= SCM_I_INUM (j
);
4358 if (SCM_I_INUMP (k
))
4360 scm_t_inum nk
= SCM_I_INUM (k
);
4361 return scm_from_bool (nj
& nk
);
4363 else if (SCM_BIGP (k
))
4371 mpz_init_set_si (nj_z
, nj
);
4372 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4373 scm_remember_upto_here_1 (k
);
4374 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4380 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4382 else if (SCM_BIGP (j
))
4384 if (SCM_I_INUMP (k
))
4387 nj
= SCM_I_INUM (j
);
4390 else if (SCM_BIGP (k
))
4394 mpz_init (result_z
);
4398 scm_remember_upto_here_2 (j
, k
);
4399 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4400 mpz_clear (result_z
);
4404 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4407 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4412 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4414 "Test whether bit number @var{index} in @var{j} is set.\n"
4415 "@var{index} starts from 0 for the least significant bit.\n"
4418 "(logbit? 0 #b1101) @result{} #t\n"
4419 "(logbit? 1 #b1101) @result{} #f\n"
4420 "(logbit? 2 #b1101) @result{} #t\n"
4421 "(logbit? 3 #b1101) @result{} #t\n"
4422 "(logbit? 4 #b1101) @result{} #f\n"
4424 #define FUNC_NAME s_scm_logbit_p
4426 unsigned long int iindex
;
4427 iindex
= scm_to_ulong (index
);
4429 if (SCM_I_INUMP (j
))
4431 /* bits above what's in an inum follow the sign bit */
4432 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4433 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4435 else if (SCM_BIGP (j
))
4437 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4438 scm_remember_upto_here_1 (j
);
4439 return scm_from_bool (val
);
4442 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4447 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4449 "Return the integer which is the ones-complement of the integer\n"
4453 "(number->string (lognot #b10000000) 2)\n"
4454 " @result{} \"-10000001\"\n"
4455 "(number->string (lognot #b0) 2)\n"
4456 " @result{} \"-1\"\n"
4458 #define FUNC_NAME s_scm_lognot
4460 if (SCM_I_INUMP (n
)) {
4461 /* No overflow here, just need to toggle all the bits making up the inum.
4462 Enhancement: No need to strip the tag and add it back, could just xor
4463 a block of 1 bits, if that worked with the various debug versions of
4465 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4467 } else if (SCM_BIGP (n
)) {
4468 SCM result
= scm_i_mkbig ();
4469 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4470 scm_remember_upto_here_1 (n
);
4474 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4479 /* returns 0 if IN is not an integer. OUT must already be
4482 coerce_to_big (SCM in
, mpz_t out
)
4485 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4486 else if (SCM_I_INUMP (in
))
4487 mpz_set_si (out
, SCM_I_INUM (in
));
4494 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4495 (SCM n
, SCM k
, SCM m
),
4496 "Return @var{n} raised to the integer exponent\n"
4497 "@var{k}, modulo @var{m}.\n"
4500 "(modulo-expt 2 3 5)\n"
4503 #define FUNC_NAME s_scm_modulo_expt
4509 /* There are two classes of error we might encounter --
4510 1) Math errors, which we'll report by calling scm_num_overflow,
4512 2) wrong-type errors, which of course we'll report by calling
4514 We don't report those errors immediately, however; instead we do
4515 some cleanup first. These variables tell us which error (if
4516 any) we should report after cleaning up.
4518 int report_overflow
= 0;
4520 int position_of_wrong_type
= 0;
4521 SCM value_of_wrong_type
= SCM_INUM0
;
4523 SCM result
= SCM_UNDEFINED
;
4529 if (scm_is_eq (m
, SCM_INUM0
))
4531 report_overflow
= 1;
4535 if (!coerce_to_big (n
, n_tmp
))
4537 value_of_wrong_type
= n
;
4538 position_of_wrong_type
= 1;
4542 if (!coerce_to_big (k
, k_tmp
))
4544 value_of_wrong_type
= k
;
4545 position_of_wrong_type
= 2;
4549 if (!coerce_to_big (m
, m_tmp
))
4551 value_of_wrong_type
= m
;
4552 position_of_wrong_type
= 3;
4556 /* if the exponent K is negative, and we simply call mpz_powm, we
4557 will get a divide-by-zero exception when an inverse 1/n mod m
4558 doesn't exist (or is not unique). Since exceptions are hard to
4559 handle, we'll attempt the inversion "by hand" -- that way, we get
4560 a simple failure code, which is easy to handle. */
4562 if (-1 == mpz_sgn (k_tmp
))
4564 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4566 report_overflow
= 1;
4569 mpz_neg (k_tmp
, k_tmp
);
4572 result
= scm_i_mkbig ();
4573 mpz_powm (SCM_I_BIG_MPZ (result
),
4578 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4579 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4586 if (report_overflow
)
4587 scm_num_overflow (FUNC_NAME
);
4589 if (position_of_wrong_type
)
4590 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4591 value_of_wrong_type
);
4593 return scm_i_normbig (result
);
4597 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4599 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4600 "exact integer, @var{n} can be any number.\n"
4602 "Negative @var{k} is supported, and results in\n"
4603 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4604 "@math{@var{n}^0} is 1, as usual, and that\n"
4605 "includes @math{0^0} is 1.\n"
4608 "(integer-expt 2 5) @result{} 32\n"
4609 "(integer-expt -3 3) @result{} -27\n"
4610 "(integer-expt 5 -3) @result{} 1/125\n"
4611 "(integer-expt 0 0) @result{} 1\n"
4613 #define FUNC_NAME s_scm_integer_expt
4616 SCM z_i2
= SCM_BOOL_F
;
4618 SCM acc
= SCM_I_MAKINUM (1L);
4620 /* Specifically refrain from checking the type of the first argument.
4621 This allows us to exponentiate any object that can be multiplied.
4622 If we must raise to a negative power, we must also be able to
4623 take its reciprocal. */
4624 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4625 SCM_WRONG_TYPE_ARG (2, k
);
4627 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4628 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4629 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4630 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4631 /* The next check is necessary only because R6RS specifies different
4632 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4633 we simply skip this case and move on. */
4634 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4636 /* k cannot be 0 at this point, because we
4637 have already checked for that case above */
4638 if (scm_is_true (scm_positive_p (k
)))
4640 else /* return NaN for (0 ^ k) for negative k per R6RS */
4644 if (SCM_I_INUMP (k
))
4645 i2
= SCM_I_INUM (k
);
4646 else if (SCM_BIGP (k
))
4648 z_i2
= scm_i_clonebig (k
, 1);
4649 scm_remember_upto_here_1 (k
);
4653 SCM_WRONG_TYPE_ARG (2, k
);
4657 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4659 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4660 n
= scm_divide (n
, SCM_UNDEFINED
);
4664 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4668 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4670 return scm_product (acc
, n
);
4672 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4673 acc
= scm_product (acc
, n
);
4674 n
= scm_product (n
, n
);
4675 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4683 n
= scm_divide (n
, SCM_UNDEFINED
);
4690 return scm_product (acc
, n
);
4692 acc
= scm_product (acc
, n
);
4693 n
= scm_product (n
, n
);
4700 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4702 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4703 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4705 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4706 "@var{cnt} is negative it's a division, rounded towards negative\n"
4707 "infinity. (Note that this is not the same rounding as\n"
4708 "@code{quotient} does.)\n"
4710 "With @var{n} viewed as an infinite precision twos complement,\n"
4711 "@code{ash} means a left shift introducing zero bits, or a right\n"
4712 "shift dropping bits.\n"
4715 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4716 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4718 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4719 "(ash -23 -2) @result{} -6\n"
4721 #define FUNC_NAME s_scm_ash
4724 bits_to_shift
= scm_to_long (cnt
);
4726 if (SCM_I_INUMP (n
))
4728 scm_t_inum nn
= SCM_I_INUM (n
);
4730 if (bits_to_shift
> 0)
4732 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4733 overflow a non-zero fixnum. For smaller shifts we check the
4734 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4735 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4736 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4742 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4744 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4747 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4751 SCM result
= scm_i_inum2big (nn
);
4752 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4759 bits_to_shift
= -bits_to_shift
;
4760 if (bits_to_shift
>= SCM_LONG_BIT
)
4761 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4763 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4767 else if (SCM_BIGP (n
))
4771 if (bits_to_shift
== 0)
4774 result
= scm_i_mkbig ();
4775 if (bits_to_shift
>= 0)
4777 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4783 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4784 we have to allocate a bignum even if the result is going to be a
4786 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4788 return scm_i_normbig (result
);
4794 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4800 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4801 (SCM n
, SCM start
, SCM end
),
4802 "Return the integer composed of the @var{start} (inclusive)\n"
4803 "through @var{end} (exclusive) bits of @var{n}. The\n"
4804 "@var{start}th bit becomes the 0-th bit in the result.\n"
4807 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4808 " @result{} \"1010\"\n"
4809 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4810 " @result{} \"10110\"\n"
4812 #define FUNC_NAME s_scm_bit_extract
4814 unsigned long int istart
, iend
, bits
;
4815 istart
= scm_to_ulong (start
);
4816 iend
= scm_to_ulong (end
);
4817 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4819 /* how many bits to keep */
4820 bits
= iend
- istart
;
4822 if (SCM_I_INUMP (n
))
4824 scm_t_inum in
= SCM_I_INUM (n
);
4826 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4827 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4828 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4830 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4832 /* Since we emulate two's complement encoded numbers, this
4833 * special case requires us to produce a result that has
4834 * more bits than can be stored in a fixnum.
4836 SCM result
= scm_i_inum2big (in
);
4837 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4842 /* mask down to requisite bits */
4843 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4844 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4846 else if (SCM_BIGP (n
))
4851 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4855 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4856 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4857 such bits into a ulong. */
4858 result
= scm_i_mkbig ();
4859 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4860 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4861 result
= scm_i_normbig (result
);
4863 scm_remember_upto_here_1 (n
);
4867 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4872 static const char scm_logtab
[] = {
4873 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4876 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4878 "Return the number of bits in integer @var{n}. If integer is\n"
4879 "positive, the 1-bits in its binary representation are counted.\n"
4880 "If negative, the 0-bits in its two's-complement binary\n"
4881 "representation are counted. If 0, 0 is returned.\n"
4884 "(logcount #b10101010)\n"
4891 #define FUNC_NAME s_scm_logcount
4893 if (SCM_I_INUMP (n
))
4895 unsigned long c
= 0;
4896 scm_t_inum nn
= SCM_I_INUM (n
);
4901 c
+= scm_logtab
[15 & nn
];
4904 return SCM_I_MAKINUM (c
);
4906 else if (SCM_BIGP (n
))
4908 unsigned long count
;
4909 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4910 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4912 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4913 scm_remember_upto_here_1 (n
);
4914 return SCM_I_MAKINUM (count
);
4917 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4922 static const char scm_ilentab
[] = {
4923 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4927 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4929 "Return the number of bits necessary to represent @var{n}.\n"
4932 "(integer-length #b10101010)\n"
4934 "(integer-length 0)\n"
4936 "(integer-length #b1111)\n"
4939 #define FUNC_NAME s_scm_integer_length
4941 if (SCM_I_INUMP (n
))
4943 unsigned long c
= 0;
4945 scm_t_inum nn
= SCM_I_INUM (n
);
4951 l
= scm_ilentab
[15 & nn
];
4954 return SCM_I_MAKINUM (c
- 4 + l
);
4956 else if (SCM_BIGP (n
))
4958 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4959 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4960 1 too big, so check for that and adjust. */
4961 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4962 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4963 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4964 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4966 scm_remember_upto_here_1 (n
);
4967 return SCM_I_MAKINUM (size
);
4970 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4974 /*** NUMBERS -> STRINGS ***/
4975 #define SCM_MAX_DBL_PREC 60
4976 #define SCM_MAX_DBL_RADIX 36
4978 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4979 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4980 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4983 void init_dblprec(int *prec
, int radix
) {
4984 /* determine floating point precision by adding successively
4985 smaller increments to 1.0 until it is considered == 1.0 */
4986 double f
= ((double)1.0)/radix
;
4987 double fsum
= 1.0 + f
;
4992 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5004 void init_fx_radix(double *fx_list
, int radix
)
5006 /* initialize a per-radix list of tolerances. When added
5007 to a number < 1.0, we can determine if we should raund
5008 up and quit converting a number to a string. */
5012 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5013 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5016 /* use this array as a way to generate a single digit */
5017 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5020 idbl2str (double f
, char *a
, int radix
)
5022 int efmt
, dpt
, d
, i
, wp
;
5024 #ifdef DBL_MIN_10_EXP
5027 #endif /* DBL_MIN_10_EXP */
5032 radix
> SCM_MAX_DBL_RADIX
)
5034 /* revert to existing behavior */
5038 wp
= scm_dblprec
[radix
-2];
5039 fx
= fx_per_radix
[radix
-2];
5043 #ifdef HAVE_COPYSIGN
5044 double sgn
= copysign (1.0, f
);
5049 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5055 strcpy (a
, "-inf.0");
5057 strcpy (a
, "+inf.0");
5062 strcpy (a
, "+nan.0");
5072 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5073 make-uniform-vector, from causing infinite loops. */
5074 /* just do the checking...if it passes, we do the conversion for our
5075 radix again below */
5082 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5090 while (f_cpy
> 10.0)
5093 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5114 if (f
+ fx
[wp
] >= radix
)
5121 /* adding 9999 makes this equivalent to abs(x) % 3 */
5122 dpt
= (exp
+ 9999) % 3;
5126 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5148 a
[ch
++] = number_chars
[d
];
5151 if (f
+ fx
[wp
] >= 1.0)
5153 a
[ch
- 1] = number_chars
[d
+1];
5165 if ((dpt
> 4) && (exp
> 6))
5167 d
= (a
[0] == '-' ? 2 : 1);
5168 for (i
= ch
++; i
> d
; i
--)
5181 if (a
[ch
- 1] == '.')
5182 a
[ch
++] = '0'; /* trailing zero */
5191 for (i
= radix
; i
<= exp
; i
*= radix
);
5192 for (i
/= radix
; i
; i
/= radix
)
5194 a
[ch
++] = number_chars
[exp
/ i
];
5203 icmplx2str (double real
, double imag
, char *str
, int radix
)
5208 i
= idbl2str (real
, str
, radix
);
5209 #ifdef HAVE_COPYSIGN
5210 sgn
= copysign (1.0, imag
);
5214 /* Don't output a '+' for negative numbers or for Inf and
5215 NaN. They will provide their own sign. */
5216 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5218 i
+= idbl2str (imag
, &str
[i
], radix
);
5224 iflo2str (SCM flt
, char *str
, int radix
)
5227 if (SCM_REALP (flt
))
5228 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5230 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5235 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5236 characters in the result.
5238 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5240 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5245 return scm_iuint2str (-num
, rad
, p
) + 1;
5248 return scm_iuint2str (num
, rad
, p
);
5251 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5252 characters in the result.
5254 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5256 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5260 scm_t_uintmax n
= num
;
5262 if (rad
< 2 || rad
> 36)
5263 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5265 for (n
/= rad
; n
> 0; n
/= rad
)
5275 p
[i
] = number_chars
[d
];
5280 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5282 "Return a string holding the external representation of the\n"
5283 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5284 "inexact, a radix of 10 will be used.")
5285 #define FUNC_NAME s_scm_number_to_string
5289 if (SCM_UNBNDP (radix
))
5292 base
= scm_to_signed_integer (radix
, 2, 36);
5294 if (SCM_I_INUMP (n
))
5296 char num_buf
[SCM_INTBUFLEN
];
5297 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5298 return scm_from_locale_stringn (num_buf
, length
);
5300 else if (SCM_BIGP (n
))
5302 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5303 scm_remember_upto_here_1 (n
);
5304 return scm_take_locale_string (str
);
5306 else if (SCM_FRACTIONP (n
))
5308 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5309 scm_from_locale_string ("/"),
5310 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5312 else if (SCM_INEXACTP (n
))
5314 char num_buf
[FLOBUFLEN
];
5315 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5318 SCM_WRONG_TYPE_ARG (1, n
);
5323 /* These print routines used to be stubbed here so that scm_repl.c
5324 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5327 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5329 char num_buf
[FLOBUFLEN
];
5330 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5335 scm_i_print_double (double val
, SCM port
)
5337 char num_buf
[FLOBUFLEN
];
5338 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5342 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5345 char num_buf
[FLOBUFLEN
];
5346 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5351 scm_i_print_complex (double real
, double imag
, SCM port
)
5353 char num_buf
[FLOBUFLEN
];
5354 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5358 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5361 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5362 scm_display (str
, port
);
5363 scm_remember_upto_here_1 (str
);
5368 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5370 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5371 scm_remember_upto_here_1 (exp
);
5372 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5376 /*** END nums->strs ***/
5379 /*** STRINGS -> NUMBERS ***/
5381 /* The following functions implement the conversion from strings to numbers.
5382 * The implementation somehow follows the grammar for numbers as it is given
5383 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5384 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5385 * points should be noted about the implementation:
5387 * * Each function keeps a local index variable 'idx' that points at the
5388 * current position within the parsed string. The global index is only
5389 * updated if the function could parse the corresponding syntactic unit
5392 * * Similarly, the functions keep track of indicators of inexactness ('#',
5393 * '.' or exponents) using local variables ('hash_seen', 'x').
5395 * * Sequences of digits are parsed into temporary variables holding fixnums.
5396 * Only if these fixnums would overflow, the result variables are updated
5397 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5398 * the temporary variables holding the fixnums are cleared, and the process
5399 * starts over again. If for example fixnums were able to store five decimal
5400 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5401 * and the result was computed as 12345 * 100000 + 67890. In other words,
5402 * only every five digits two bignum operations were performed.
5404 * Notes on the handling of exactness specifiers:
5406 * When parsing non-real complex numbers, we apply exactness specifiers on
5407 * per-component basis, as is done in PLT Scheme. For complex numbers
5408 * written in rectangular form, exactness specifiers are applied to the
5409 * real and imaginary parts before calling scm_make_rectangular. For
5410 * complex numbers written in polar form, exactness specifiers are applied
5411 * to the magnitude and angle before calling scm_make_polar.
5413 * There are two kinds of exactness specifiers: forced and implicit. A
5414 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5415 * the entire number, and applies to both components of a complex number.
5416 * "#e" causes each component to be made exact, and "#i" causes each
5417 * component to be made inexact. If no forced exactness specifier is
5418 * present, then the exactness of each component is determined
5419 * independently by the presence or absence of a decimal point or hash mark
5420 * within that component. If a decimal point or hash mark is present, the
5421 * component is made inexact, otherwise it is made exact.
5423 * After the exactness specifiers have been applied to each component, they
5424 * are passed to either scm_make_rectangular or scm_make_polar to produce
5425 * the final result. Note that this will result in a real number if the
5426 * imaginary part, magnitude, or angle is an exact 0.
5428 * For example, (string->number "#i5.0+0i") does the equivalent of:
5430 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5433 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5435 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5437 /* Caller is responsible for checking that the return value is in range
5438 for the given radix, which should be <= 36. */
5440 char_decimal_value (scm_t_uint32 c
)
5442 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5443 that's certainly above any valid decimal, so we take advantage of
5444 that to elide some tests. */
5445 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5447 /* If that failed, try extended hexadecimals, then. Only accept ascii
5452 if (c
>= (scm_t_uint32
) 'a')
5453 d
= c
- (scm_t_uint32
)'a' + 10U;
5458 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5459 in base RADIX. Upon success, return the unsigned integer and update
5460 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5462 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5463 unsigned int radix
, enum t_exactness
*p_exactness
)
5465 unsigned int idx
= *p_idx
;
5466 unsigned int hash_seen
= 0;
5467 scm_t_bits shift
= 1;
5469 unsigned int digit_value
;
5472 size_t len
= scm_i_string_length (mem
);
5477 c
= scm_i_string_ref (mem
, idx
);
5478 digit_value
= char_decimal_value (c
);
5479 if (digit_value
>= radix
)
5483 result
= SCM_I_MAKINUM (digit_value
);
5486 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5496 digit_value
= char_decimal_value (c
);
5497 /* This check catches non-decimals in addition to out-of-range
5499 if (digit_value
>= radix
)
5504 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5506 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5508 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5515 shift
= shift
* radix
;
5516 add
= add
* radix
+ digit_value
;
5521 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5523 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5527 *p_exactness
= INEXACT
;
5533 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5534 * covers the parts of the rules that start at a potential point. The value
5535 * of the digits up to the point have been parsed by the caller and are given
5536 * in variable result. The content of *p_exactness indicates, whether a hash
5537 * has already been seen in the digits before the point.
5540 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5543 mem2decimal_from_point (SCM result
, SCM mem
,
5544 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5546 unsigned int idx
= *p_idx
;
5547 enum t_exactness x
= *p_exactness
;
5548 size_t len
= scm_i_string_length (mem
);
5553 if (scm_i_string_ref (mem
, idx
) == '.')
5555 scm_t_bits shift
= 1;
5557 unsigned int digit_value
;
5558 SCM big_shift
= SCM_INUM1
;
5563 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5564 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5569 digit_value
= DIGIT2UINT (c
);
5580 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5582 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5583 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5585 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5593 add
= add
* 10 + digit_value
;
5599 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5600 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5601 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5604 result
= scm_divide (result
, big_shift
);
5606 /* We've seen a decimal point, thus the value is implicitly inexact. */
5618 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5620 switch (scm_i_string_ref (mem
, idx
))
5632 c
= scm_i_string_ref (mem
, idx
);
5640 c
= scm_i_string_ref (mem
, idx
);
5649 c
= scm_i_string_ref (mem
, idx
);
5654 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5658 exponent
= DIGIT2UINT (c
);
5661 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5662 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5665 if (exponent
<= SCM_MAXEXP
)
5666 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5672 if (exponent
> SCM_MAXEXP
)
5674 size_t exp_len
= idx
- start
;
5675 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5676 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5677 scm_out_of_range ("string->number", exp_num
);
5680 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5682 result
= scm_product (result
, e
);
5684 result
= scm_divide (result
, e
);
5686 /* We've seen an exponent, thus the value is implicitly inexact. */
5704 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5707 mem2ureal (SCM mem
, unsigned int *p_idx
,
5708 unsigned int radix
, enum t_exactness forced_x
)
5710 unsigned int idx
= *p_idx
;
5712 size_t len
= scm_i_string_length (mem
);
5714 /* Start off believing that the number will be exact. This changes
5715 to INEXACT if we see a decimal point or a hash. */
5716 enum t_exactness implicit_x
= EXACT
;
5721 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5727 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5729 /* Cobble up the fractional part. We might want to set the
5730 NaN's mantissa from it. */
5732 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5734 #if SCM_ENABLE_DEPRECATED == 1
5735 scm_c_issue_deprecation_warning
5736 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5746 if (scm_i_string_ref (mem
, idx
) == '.')
5750 else if (idx
+ 1 == len
)
5752 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5755 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5756 p_idx
, &implicit_x
);
5762 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5763 if (scm_is_false (uinteger
))
5768 else if (scm_i_string_ref (mem
, idx
) == '/')
5776 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5777 if (scm_is_false (divisor
))
5780 /* both are int/big here, I assume */
5781 result
= scm_i_make_ratio (uinteger
, divisor
);
5783 else if (radix
== 10)
5785 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5786 if (scm_is_false (result
))
5798 if (SCM_INEXACTP (result
))
5799 return scm_inexact_to_exact (result
);
5803 if (SCM_INEXACTP (result
))
5806 return scm_exact_to_inexact (result
);
5808 if (implicit_x
== INEXACT
)
5810 if (SCM_INEXACTP (result
))
5813 return scm_exact_to_inexact (result
);
5819 /* We should never get here */
5820 scm_syserror ("mem2ureal");
5824 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5827 mem2complex (SCM mem
, unsigned int idx
,
5828 unsigned int radix
, enum t_exactness forced_x
)
5833 size_t len
= scm_i_string_length (mem
);
5838 c
= scm_i_string_ref (mem
, idx
);
5853 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5854 if (scm_is_false (ureal
))
5856 /* input must be either +i or -i */
5861 if (scm_i_string_ref (mem
, idx
) == 'i'
5862 || scm_i_string_ref (mem
, idx
) == 'I')
5868 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5875 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5876 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5881 c
= scm_i_string_ref (mem
, idx
);
5885 /* either +<ureal>i or -<ureal>i */
5892 return scm_make_rectangular (SCM_INUM0
, ureal
);
5895 /* polar input: <real>@<real>. */
5906 c
= scm_i_string_ref (mem
, idx
);
5924 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5925 if (scm_is_false (angle
))
5930 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5931 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5933 result
= scm_make_polar (ureal
, angle
);
5938 /* expecting input matching <real>[+-]<ureal>?i */
5945 int sign
= (c
== '+') ? 1 : -1;
5946 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5948 if (scm_is_false (imag
))
5949 imag
= SCM_I_MAKINUM (sign
);
5950 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5951 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5955 if (scm_i_string_ref (mem
, idx
) != 'i'
5956 && scm_i_string_ref (mem
, idx
) != 'I')
5963 return scm_make_rectangular (ureal
, imag
);
5972 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5974 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5977 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5979 unsigned int idx
= 0;
5980 unsigned int radix
= NO_RADIX
;
5981 enum t_exactness forced_x
= NO_EXACTNESS
;
5982 size_t len
= scm_i_string_length (mem
);
5984 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5985 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5987 switch (scm_i_string_ref (mem
, idx
+ 1))
5990 if (radix
!= NO_RADIX
)
5995 if (radix
!= NO_RADIX
)
6000 if (forced_x
!= NO_EXACTNESS
)
6005 if (forced_x
!= NO_EXACTNESS
)
6010 if (radix
!= NO_RADIX
)
6015 if (radix
!= NO_RADIX
)
6025 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6026 if (radix
== NO_RADIX
)
6027 radix
= default_radix
;
6029 return mem2complex (mem
, idx
, radix
, forced_x
);
6033 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6034 unsigned int default_radix
)
6036 SCM str
= scm_from_locale_stringn (mem
, len
);
6038 return scm_i_string_to_number (str
, default_radix
);
6042 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6043 (SCM string
, SCM radix
),
6044 "Return a number of the maximally precise representation\n"
6045 "expressed by the given @var{string}. @var{radix} must be an\n"
6046 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6047 "is a default radix that may be overridden by an explicit radix\n"
6048 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6049 "supplied, then the default radix is 10. If string is not a\n"
6050 "syntactically valid notation for a number, then\n"
6051 "@code{string->number} returns @code{#f}.")
6052 #define FUNC_NAME s_scm_string_to_number
6056 SCM_VALIDATE_STRING (1, string
);
6058 if (SCM_UNBNDP (radix
))
6061 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6063 answer
= scm_i_string_to_number (string
, base
);
6064 scm_remember_upto_here_1 (string
);
6070 /*** END strs->nums ***/
6073 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6075 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6077 #define FUNC_NAME s_scm_number_p
6079 return scm_from_bool (SCM_NUMBERP (x
));
6083 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6085 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6086 "otherwise. Note that the sets of real, rational and integer\n"
6087 "values form subsets of the set of complex numbers, i. e. the\n"
6088 "predicate will also be fulfilled if @var{x} is a real,\n"
6089 "rational or integer number.")
6090 #define FUNC_NAME s_scm_complex_p
6092 /* all numbers are complex. */
6093 return scm_number_p (x
);
6097 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6099 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6100 "otherwise. Note that the set of integer values forms a subset of\n"
6101 "the set of real numbers, i. e. the predicate will also be\n"
6102 "fulfilled if @var{x} is an integer number.")
6103 #define FUNC_NAME s_scm_real_p
6105 return scm_from_bool
6106 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6110 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6112 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6113 "otherwise. Note that the set of integer values forms a subset of\n"
6114 "the set of rational numbers, i. e. the predicate will also be\n"
6115 "fulfilled if @var{x} is an integer number.")
6116 #define FUNC_NAME s_scm_rational_p
6118 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6120 else if (SCM_REALP (x
))
6121 /* due to their limited precision, finite floating point numbers are
6122 rational as well. (finite means neither infinity nor a NaN) */
6123 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6129 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6131 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6133 #define FUNC_NAME s_scm_integer_p
6135 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6137 else if (SCM_REALP (x
))
6139 double val
= SCM_REAL_VALUE (x
);
6140 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6148 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6149 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6150 (SCM x
, SCM y
, SCM rest
),
6151 "Return @code{#t} if all parameters are numerically equal.")
6152 #define FUNC_NAME s_scm_i_num_eq_p
6154 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6156 while (!scm_is_null (rest
))
6158 if (scm_is_false (scm_num_eq_p (x
, y
)))
6162 rest
= scm_cdr (rest
);
6164 return scm_num_eq_p (x
, y
);
6168 scm_num_eq_p (SCM x
, SCM y
)
6171 if (SCM_I_INUMP (x
))
6173 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6174 if (SCM_I_INUMP (y
))
6176 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6177 return scm_from_bool (xx
== yy
);
6179 else if (SCM_BIGP (y
))
6181 else if (SCM_REALP (y
))
6183 /* On a 32-bit system an inum fits a double, we can cast the inum
6184 to a double and compare.
6186 But on a 64-bit system an inum is bigger than a double and
6187 casting it to a double (call that dxx) will round. dxx is at
6188 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6189 an integer and fits a long. So we cast yy to a long and
6190 compare with plain xx.
6192 An alternative (for any size system actually) would be to check
6193 yy is an integer (with floor) and is in range of an inum
6194 (compare against appropriate powers of 2) then test
6195 xx==(scm_t_signed_bits)yy. It's just a matter of which
6196 casts/comparisons might be fastest or easiest for the cpu. */
6198 double yy
= SCM_REAL_VALUE (y
);
6199 return scm_from_bool ((double) xx
== yy
6200 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6201 || xx
== (scm_t_signed_bits
) yy
));
6203 else if (SCM_COMPLEXP (y
))
6204 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6205 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6206 else if (SCM_FRACTIONP (y
))
6209 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6211 else if (SCM_BIGP (x
))
6213 if (SCM_I_INUMP (y
))
6215 else if (SCM_BIGP (y
))
6217 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6218 scm_remember_upto_here_2 (x
, y
);
6219 return scm_from_bool (0 == cmp
);
6221 else if (SCM_REALP (y
))
6224 if (isnan (SCM_REAL_VALUE (y
)))
6226 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6227 scm_remember_upto_here_1 (x
);
6228 return scm_from_bool (0 == cmp
);
6230 else if (SCM_COMPLEXP (y
))
6233 if (0.0 != SCM_COMPLEX_IMAG (y
))
6235 if (isnan (SCM_COMPLEX_REAL (y
)))
6237 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6238 scm_remember_upto_here_1 (x
);
6239 return scm_from_bool (0 == cmp
);
6241 else if (SCM_FRACTIONP (y
))
6244 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6246 else if (SCM_REALP (x
))
6248 double xx
= SCM_REAL_VALUE (x
);
6249 if (SCM_I_INUMP (y
))
6251 /* see comments with inum/real above */
6252 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6253 return scm_from_bool (xx
== (double) yy
6254 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6255 || (scm_t_signed_bits
) xx
== yy
));
6257 else if (SCM_BIGP (y
))
6260 if (isnan (SCM_REAL_VALUE (x
)))
6262 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6263 scm_remember_upto_here_1 (y
);
6264 return scm_from_bool (0 == cmp
);
6266 else if (SCM_REALP (y
))
6267 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6268 else if (SCM_COMPLEXP (y
))
6269 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6270 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6271 else if (SCM_FRACTIONP (y
))
6273 double xx
= SCM_REAL_VALUE (x
);
6277 return scm_from_bool (xx
< 0.0);
6278 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6282 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6284 else if (SCM_COMPLEXP (x
))
6286 if (SCM_I_INUMP (y
))
6287 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6288 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6289 else if (SCM_BIGP (y
))
6292 if (0.0 != SCM_COMPLEX_IMAG (x
))
6294 if (isnan (SCM_COMPLEX_REAL (x
)))
6296 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6297 scm_remember_upto_here_1 (y
);
6298 return scm_from_bool (0 == cmp
);
6300 else if (SCM_REALP (y
))
6301 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6302 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6303 else if (SCM_COMPLEXP (y
))
6304 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6305 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6306 else if (SCM_FRACTIONP (y
))
6309 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6311 xx
= SCM_COMPLEX_REAL (x
);
6315 return scm_from_bool (xx
< 0.0);
6316 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6320 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6322 else if (SCM_FRACTIONP (x
))
6324 if (SCM_I_INUMP (y
))
6326 else if (SCM_BIGP (y
))
6328 else if (SCM_REALP (y
))
6330 double yy
= SCM_REAL_VALUE (y
);
6334 return scm_from_bool (0.0 < yy
);
6335 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6338 else if (SCM_COMPLEXP (y
))
6341 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6343 yy
= SCM_COMPLEX_REAL (y
);
6347 return scm_from_bool (0.0 < yy
);
6348 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6351 else if (SCM_FRACTIONP (y
))
6352 return scm_i_fraction_equalp (x
, y
);
6354 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6357 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6361 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6362 done are good for inums, but for bignums an answer can almost always be
6363 had by just examining a few high bits of the operands, as done by GMP in
6364 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6365 of the float exponent to take into account. */
6367 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6368 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6369 (SCM x
, SCM y
, SCM rest
),
6370 "Return @code{#t} if the list of parameters is monotonically\n"
6372 #define FUNC_NAME s_scm_i_num_less_p
6374 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6376 while (!scm_is_null (rest
))
6378 if (scm_is_false (scm_less_p (x
, y
)))
6382 rest
= scm_cdr (rest
);
6384 return scm_less_p (x
, y
);
6388 scm_less_p (SCM x
, SCM y
)
6391 if (SCM_I_INUMP (x
))
6393 scm_t_inum xx
= SCM_I_INUM (x
);
6394 if (SCM_I_INUMP (y
))
6396 scm_t_inum yy
= SCM_I_INUM (y
);
6397 return scm_from_bool (xx
< yy
);
6399 else if (SCM_BIGP (y
))
6401 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6402 scm_remember_upto_here_1 (y
);
6403 return scm_from_bool (sgn
> 0);
6405 else if (SCM_REALP (y
))
6406 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6407 else if (SCM_FRACTIONP (y
))
6409 /* "x < a/b" becomes "x*b < a" */
6411 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6412 y
= SCM_FRACTION_NUMERATOR (y
);
6416 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6418 else if (SCM_BIGP (x
))
6420 if (SCM_I_INUMP (y
))
6422 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6423 scm_remember_upto_here_1 (x
);
6424 return scm_from_bool (sgn
< 0);
6426 else if (SCM_BIGP (y
))
6428 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6429 scm_remember_upto_here_2 (x
, y
);
6430 return scm_from_bool (cmp
< 0);
6432 else if (SCM_REALP (y
))
6435 if (isnan (SCM_REAL_VALUE (y
)))
6437 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6438 scm_remember_upto_here_1 (x
);
6439 return scm_from_bool (cmp
< 0);
6441 else if (SCM_FRACTIONP (y
))
6444 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6446 else if (SCM_REALP (x
))
6448 if (SCM_I_INUMP (y
))
6449 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6450 else if (SCM_BIGP (y
))
6453 if (isnan (SCM_REAL_VALUE (x
)))
6455 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6456 scm_remember_upto_here_1 (y
);
6457 return scm_from_bool (cmp
> 0);
6459 else if (SCM_REALP (y
))
6460 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6461 else if (SCM_FRACTIONP (y
))
6463 double xx
= SCM_REAL_VALUE (x
);
6467 return scm_from_bool (xx
< 0.0);
6468 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6472 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6474 else if (SCM_FRACTIONP (x
))
6476 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6478 /* "a/b < y" becomes "a < y*b" */
6479 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6480 x
= SCM_FRACTION_NUMERATOR (x
);
6483 else if (SCM_REALP (y
))
6485 double yy
= SCM_REAL_VALUE (y
);
6489 return scm_from_bool (0.0 < yy
);
6490 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6493 else if (SCM_FRACTIONP (y
))
6495 /* "a/b < c/d" becomes "a*d < c*b" */
6496 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6497 SCM_FRACTION_DENOMINATOR (y
));
6498 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6499 SCM_FRACTION_DENOMINATOR (x
));
6505 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6508 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6512 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6513 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6514 (SCM x
, SCM y
, SCM rest
),
6515 "Return @code{#t} if the list of parameters is monotonically\n"
6517 #define FUNC_NAME s_scm_i_num_gr_p
6519 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6521 while (!scm_is_null (rest
))
6523 if (scm_is_false (scm_gr_p (x
, y
)))
6527 rest
= scm_cdr (rest
);
6529 return scm_gr_p (x
, y
);
6532 #define FUNC_NAME s_scm_i_num_gr_p
6534 scm_gr_p (SCM x
, SCM y
)
6536 if (!SCM_NUMBERP (x
))
6537 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6538 else if (!SCM_NUMBERP (y
))
6539 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6541 return scm_less_p (y
, x
);
6546 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6547 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6548 (SCM x
, SCM y
, SCM rest
),
6549 "Return @code{#t} if the list of parameters is monotonically\n"
6551 #define FUNC_NAME s_scm_i_num_leq_p
6553 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6555 while (!scm_is_null (rest
))
6557 if (scm_is_false (scm_leq_p (x
, y
)))
6561 rest
= scm_cdr (rest
);
6563 return scm_leq_p (x
, y
);
6566 #define FUNC_NAME s_scm_i_num_leq_p
6568 scm_leq_p (SCM x
, SCM y
)
6570 if (!SCM_NUMBERP (x
))
6571 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6572 else if (!SCM_NUMBERP (y
))
6573 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6574 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6577 return scm_not (scm_less_p (y
, x
));
6582 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6583 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6584 (SCM x
, SCM y
, SCM rest
),
6585 "Return @code{#t} if the list of parameters is monotonically\n"
6587 #define FUNC_NAME s_scm_i_num_geq_p
6589 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6591 while (!scm_is_null (rest
))
6593 if (scm_is_false (scm_geq_p (x
, y
)))
6597 rest
= scm_cdr (rest
);
6599 return scm_geq_p (x
, y
);
6602 #define FUNC_NAME s_scm_i_num_geq_p
6604 scm_geq_p (SCM x
, SCM y
)
6606 if (!SCM_NUMBERP (x
))
6607 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6608 else if (!SCM_NUMBERP (y
))
6609 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6610 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6613 return scm_not (scm_less_p (x
, y
));
6618 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6620 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6622 #define FUNC_NAME s_scm_zero_p
6624 if (SCM_I_INUMP (z
))
6625 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6626 else if (SCM_BIGP (z
))
6628 else if (SCM_REALP (z
))
6629 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6630 else if (SCM_COMPLEXP (z
))
6631 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6632 && SCM_COMPLEX_IMAG (z
) == 0.0);
6633 else if (SCM_FRACTIONP (z
))
6636 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6641 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6643 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6645 #define FUNC_NAME s_scm_positive_p
6647 if (SCM_I_INUMP (x
))
6648 return scm_from_bool (SCM_I_INUM (x
) > 0);
6649 else if (SCM_BIGP (x
))
6651 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6652 scm_remember_upto_here_1 (x
);
6653 return scm_from_bool (sgn
> 0);
6655 else if (SCM_REALP (x
))
6656 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6657 else if (SCM_FRACTIONP (x
))
6658 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6660 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6665 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6667 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6669 #define FUNC_NAME s_scm_negative_p
6671 if (SCM_I_INUMP (x
))
6672 return scm_from_bool (SCM_I_INUM (x
) < 0);
6673 else if (SCM_BIGP (x
))
6675 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6676 scm_remember_upto_here_1 (x
);
6677 return scm_from_bool (sgn
< 0);
6679 else if (SCM_REALP (x
))
6680 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6681 else if (SCM_FRACTIONP (x
))
6682 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6684 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6689 /* scm_min and scm_max return an inexact when either argument is inexact, as
6690 required by r5rs. On that basis, for exact/inexact combinations the
6691 exact is converted to inexact to compare and possibly return. This is
6692 unlike scm_less_p above which takes some trouble to preserve all bits in
6693 its test, such trouble is not required for min and max. */
6695 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6696 (SCM x
, SCM y
, SCM rest
),
6697 "Return the maximum of all parameter values.")
6698 #define FUNC_NAME s_scm_i_max
6700 while (!scm_is_null (rest
))
6701 { x
= scm_max (x
, y
);
6703 rest
= scm_cdr (rest
);
6705 return scm_max (x
, y
);
6709 #define s_max s_scm_i_max
6710 #define g_max g_scm_i_max
6713 scm_max (SCM x
, SCM y
)
6718 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6719 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6722 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6725 if (SCM_I_INUMP (x
))
6727 scm_t_inum xx
= SCM_I_INUM (x
);
6728 if (SCM_I_INUMP (y
))
6730 scm_t_inum yy
= SCM_I_INUM (y
);
6731 return (xx
< yy
) ? y
: x
;
6733 else if (SCM_BIGP (y
))
6735 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6736 scm_remember_upto_here_1 (y
);
6737 return (sgn
< 0) ? x
: y
;
6739 else if (SCM_REALP (y
))
6742 double yyd
= SCM_REAL_VALUE (y
);
6745 return scm_from_double (xxd
);
6746 /* If y is a NaN, then "==" is false and we return the NaN */
6747 else if (SCM_LIKELY (!(xxd
== yyd
)))
6749 /* Handle signed zeroes properly */
6755 else if (SCM_FRACTIONP (y
))
6758 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6761 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6763 else if (SCM_BIGP (x
))
6765 if (SCM_I_INUMP (y
))
6767 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6768 scm_remember_upto_here_1 (x
);
6769 return (sgn
< 0) ? y
: x
;
6771 else if (SCM_BIGP (y
))
6773 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6774 scm_remember_upto_here_2 (x
, y
);
6775 return (cmp
> 0) ? x
: y
;
6777 else if (SCM_REALP (y
))
6779 /* if y==NaN then xx>yy is false, so we return the NaN y */
6782 xx
= scm_i_big2dbl (x
);
6783 yy
= SCM_REAL_VALUE (y
);
6784 return (xx
> yy
? scm_from_double (xx
) : y
);
6786 else if (SCM_FRACTIONP (y
))
6791 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6793 else if (SCM_REALP (x
))
6795 if (SCM_I_INUMP (y
))
6797 scm_t_inum yy
= SCM_I_INUM (y
);
6798 double xxd
= SCM_REAL_VALUE (x
);
6802 return scm_from_double (yyd
);
6803 /* If x is a NaN, then "==" is false and we return the NaN */
6804 else if (SCM_LIKELY (!(xxd
== yyd
)))
6806 /* Handle signed zeroes properly */
6812 else if (SCM_BIGP (y
))
6817 else if (SCM_REALP (y
))
6819 double xx
= SCM_REAL_VALUE (x
);
6820 double yy
= SCM_REAL_VALUE (y
);
6822 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6825 else if (SCM_LIKELY (xx
< yy
))
6827 /* If neither (xx > yy) nor (xx < yy), then
6828 either they're equal or one is a NaN */
6829 else if (SCM_UNLIKELY (isnan (xx
)))
6830 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6831 else if (SCM_UNLIKELY (isnan (yy
)))
6832 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6833 /* xx == yy, but handle signed zeroes properly */
6834 else if (double_is_non_negative_zero (yy
))
6839 else if (SCM_FRACTIONP (y
))
6841 double yy
= scm_i_fraction2double (y
);
6842 double xx
= SCM_REAL_VALUE (x
);
6843 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6846 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6848 else if (SCM_FRACTIONP (x
))
6850 if (SCM_I_INUMP (y
))
6854 else if (SCM_BIGP (y
))
6858 else if (SCM_REALP (y
))
6860 double xx
= scm_i_fraction2double (x
);
6861 /* if y==NaN then ">" is false, so we return the NaN y */
6862 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6864 else if (SCM_FRACTIONP (y
))
6869 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6872 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6876 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6877 (SCM x
, SCM y
, SCM rest
),
6878 "Return the minimum of all parameter values.")
6879 #define FUNC_NAME s_scm_i_min
6881 while (!scm_is_null (rest
))
6882 { x
= scm_min (x
, y
);
6884 rest
= scm_cdr (rest
);
6886 return scm_min (x
, y
);
6890 #define s_min s_scm_i_min
6891 #define g_min g_scm_i_min
6894 scm_min (SCM x
, SCM y
)
6899 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6900 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6903 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6906 if (SCM_I_INUMP (x
))
6908 scm_t_inum xx
= SCM_I_INUM (x
);
6909 if (SCM_I_INUMP (y
))
6911 scm_t_inum yy
= SCM_I_INUM (y
);
6912 return (xx
< yy
) ? x
: y
;
6914 else if (SCM_BIGP (y
))
6916 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6917 scm_remember_upto_here_1 (y
);
6918 return (sgn
< 0) ? y
: x
;
6920 else if (SCM_REALP (y
))
6923 /* if y==NaN then "<" is false and we return NaN */
6924 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6926 else if (SCM_FRACTIONP (y
))
6929 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6932 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6934 else if (SCM_BIGP (x
))
6936 if (SCM_I_INUMP (y
))
6938 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6939 scm_remember_upto_here_1 (x
);
6940 return (sgn
< 0) ? x
: y
;
6942 else if (SCM_BIGP (y
))
6944 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6945 scm_remember_upto_here_2 (x
, y
);
6946 return (cmp
> 0) ? y
: x
;
6948 else if (SCM_REALP (y
))
6950 /* if y==NaN then xx<yy is false, so we return the NaN y */
6953 xx
= scm_i_big2dbl (x
);
6954 yy
= SCM_REAL_VALUE (y
);
6955 return (xx
< yy
? scm_from_double (xx
) : y
);
6957 else if (SCM_FRACTIONP (y
))
6962 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6964 else if (SCM_REALP (x
))
6966 if (SCM_I_INUMP (y
))
6968 double z
= SCM_I_INUM (y
);
6969 /* if x==NaN then "<" is false and we return NaN */
6970 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6972 else if (SCM_BIGP (y
))
6977 else if (SCM_REALP (y
))
6979 double xx
= SCM_REAL_VALUE (x
);
6980 double yy
= SCM_REAL_VALUE (y
);
6982 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6985 else if (SCM_LIKELY (xx
> yy
))
6987 /* If neither (xx < yy) nor (xx > yy), then
6988 either they're equal or one is a NaN */
6989 else if (SCM_UNLIKELY (isnan (xx
)))
6990 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6991 else if (SCM_UNLIKELY (isnan (yy
)))
6992 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6993 /* xx == yy, but handle signed zeroes properly */
6994 else if (double_is_non_negative_zero (xx
))
6999 else if (SCM_FRACTIONP (y
))
7001 double yy
= scm_i_fraction2double (y
);
7002 double xx
= SCM_REAL_VALUE (x
);
7003 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7006 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7008 else if (SCM_FRACTIONP (x
))
7010 if (SCM_I_INUMP (y
))
7014 else if (SCM_BIGP (y
))
7018 else if (SCM_REALP (y
))
7020 double xx
= scm_i_fraction2double (x
);
7021 /* if y==NaN then "<" is false, so we return the NaN y */
7022 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7024 else if (SCM_FRACTIONP (y
))
7029 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7032 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7036 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7037 (SCM x
, SCM y
, SCM rest
),
7038 "Return the sum of all parameter values. Return 0 if called without\n"
7040 #define FUNC_NAME s_scm_i_sum
7042 while (!scm_is_null (rest
))
7043 { x
= scm_sum (x
, y
);
7045 rest
= scm_cdr (rest
);
7047 return scm_sum (x
, y
);
7051 #define s_sum s_scm_i_sum
7052 #define g_sum g_scm_i_sum
7055 scm_sum (SCM x
, SCM y
)
7057 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7059 if (SCM_NUMBERP (x
)) return x
;
7060 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7061 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7064 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7066 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7068 scm_t_inum xx
= SCM_I_INUM (x
);
7069 scm_t_inum yy
= SCM_I_INUM (y
);
7070 scm_t_inum z
= xx
+ yy
;
7071 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7073 else if (SCM_BIGP (y
))
7078 else if (SCM_REALP (y
))
7080 scm_t_inum xx
= SCM_I_INUM (x
);
7081 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7083 else if (SCM_COMPLEXP (y
))
7085 scm_t_inum xx
= SCM_I_INUM (x
);
7086 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7087 SCM_COMPLEX_IMAG (y
));
7089 else if (SCM_FRACTIONP (y
))
7090 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7091 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7092 SCM_FRACTION_DENOMINATOR (y
));
7094 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7095 } else if (SCM_BIGP (x
))
7097 if (SCM_I_INUMP (y
))
7102 inum
= SCM_I_INUM (y
);
7105 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7108 SCM result
= scm_i_mkbig ();
7109 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7110 scm_remember_upto_here_1 (x
);
7111 /* we know the result will have to be a bignum */
7114 return scm_i_normbig (result
);
7118 SCM result
= scm_i_mkbig ();
7119 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7120 scm_remember_upto_here_1 (x
);
7121 /* we know the result will have to be a bignum */
7124 return scm_i_normbig (result
);
7127 else if (SCM_BIGP (y
))
7129 SCM result
= scm_i_mkbig ();
7130 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7131 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7132 mpz_add (SCM_I_BIG_MPZ (result
),
7135 scm_remember_upto_here_2 (x
, y
);
7136 /* we know the result will have to be a bignum */
7139 return scm_i_normbig (result
);
7141 else if (SCM_REALP (y
))
7143 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7144 scm_remember_upto_here_1 (x
);
7145 return scm_from_double (result
);
7147 else if (SCM_COMPLEXP (y
))
7149 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7150 + SCM_COMPLEX_REAL (y
));
7151 scm_remember_upto_here_1 (x
);
7152 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7154 else if (SCM_FRACTIONP (y
))
7155 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7156 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7157 SCM_FRACTION_DENOMINATOR (y
));
7159 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7161 else if (SCM_REALP (x
))
7163 if (SCM_I_INUMP (y
))
7164 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7165 else if (SCM_BIGP (y
))
7167 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7168 scm_remember_upto_here_1 (y
);
7169 return scm_from_double (result
);
7171 else if (SCM_REALP (y
))
7172 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7173 else if (SCM_COMPLEXP (y
))
7174 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7175 SCM_COMPLEX_IMAG (y
));
7176 else if (SCM_FRACTIONP (y
))
7177 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7179 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7181 else if (SCM_COMPLEXP (x
))
7183 if (SCM_I_INUMP (y
))
7184 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7185 SCM_COMPLEX_IMAG (x
));
7186 else if (SCM_BIGP (y
))
7188 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7189 + SCM_COMPLEX_REAL (x
));
7190 scm_remember_upto_here_1 (y
);
7191 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7193 else if (SCM_REALP (y
))
7194 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7195 SCM_COMPLEX_IMAG (x
));
7196 else if (SCM_COMPLEXP (y
))
7197 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7198 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7199 else if (SCM_FRACTIONP (y
))
7200 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7201 SCM_COMPLEX_IMAG (x
));
7203 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7205 else if (SCM_FRACTIONP (x
))
7207 if (SCM_I_INUMP (y
))
7208 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7209 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7210 SCM_FRACTION_DENOMINATOR (x
));
7211 else if (SCM_BIGP (y
))
7212 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7213 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7214 SCM_FRACTION_DENOMINATOR (x
));
7215 else if (SCM_REALP (y
))
7216 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7217 else if (SCM_COMPLEXP (y
))
7218 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7219 SCM_COMPLEX_IMAG (y
));
7220 else if (SCM_FRACTIONP (y
))
7221 /* a/b + c/d = (ad + bc) / bd */
7222 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7223 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7224 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7226 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7229 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7233 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7235 "Return @math{@var{x}+1}.")
7236 #define FUNC_NAME s_scm_oneplus
7238 return scm_sum (x
, SCM_INUM1
);
7243 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7244 (SCM x
, SCM y
, SCM rest
),
7245 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7246 "the sum of all but the first argument are subtracted from the first\n"
7248 #define FUNC_NAME s_scm_i_difference
7250 while (!scm_is_null (rest
))
7251 { x
= scm_difference (x
, y
);
7253 rest
= scm_cdr (rest
);
7255 return scm_difference (x
, y
);
7259 #define s_difference s_scm_i_difference
7260 #define g_difference g_scm_i_difference
7263 scm_difference (SCM x
, SCM y
)
7264 #define FUNC_NAME s_difference
7266 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7269 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7271 if (SCM_I_INUMP (x
))
7273 scm_t_inum xx
= -SCM_I_INUM (x
);
7274 if (SCM_FIXABLE (xx
))
7275 return SCM_I_MAKINUM (xx
);
7277 return scm_i_inum2big (xx
);
7279 else if (SCM_BIGP (x
))
7280 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7281 bignum, but negating that gives a fixnum. */
7282 return scm_i_normbig (scm_i_clonebig (x
, 0));
7283 else if (SCM_REALP (x
))
7284 return scm_from_double (-SCM_REAL_VALUE (x
));
7285 else if (SCM_COMPLEXP (x
))
7286 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7287 -SCM_COMPLEX_IMAG (x
));
7288 else if (SCM_FRACTIONP (x
))
7289 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7290 SCM_FRACTION_DENOMINATOR (x
));
7292 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7295 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7297 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7299 scm_t_inum xx
= SCM_I_INUM (x
);
7300 scm_t_inum yy
= SCM_I_INUM (y
);
7301 scm_t_inum z
= xx
- yy
;
7302 if (SCM_FIXABLE (z
))
7303 return SCM_I_MAKINUM (z
);
7305 return scm_i_inum2big (z
);
7307 else if (SCM_BIGP (y
))
7309 /* inum-x - big-y */
7310 scm_t_inum xx
= SCM_I_INUM (x
);
7314 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7315 bignum, but negating that gives a fixnum. */
7316 return scm_i_normbig (scm_i_clonebig (y
, 0));
7320 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7321 SCM result
= scm_i_mkbig ();
7324 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7327 /* x - y == -(y + -x) */
7328 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7329 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7331 scm_remember_upto_here_1 (y
);
7333 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7334 /* we know the result will have to be a bignum */
7337 return scm_i_normbig (result
);
7340 else if (SCM_REALP (y
))
7342 scm_t_inum xx
= SCM_I_INUM (x
);
7345 * We need to handle x == exact 0
7346 * specially because R6RS states that:
7347 * (- 0.0) ==> -0.0 and
7348 * (- 0.0 0.0) ==> 0.0
7349 * and the scheme compiler changes
7350 * (- 0.0) into (- 0 0.0)
7351 * So we need to treat (- 0 0.0) like (- 0.0).
7352 * At the C level, (-x) is different than (0.0 - x).
7353 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7356 return scm_from_double (- SCM_REAL_VALUE (y
));
7358 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7360 else if (SCM_COMPLEXP (y
))
7362 scm_t_inum xx
= SCM_I_INUM (x
);
7364 /* We need to handle x == exact 0 specially.
7365 See the comment above (for SCM_REALP (y)) */
7367 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7368 - SCM_COMPLEX_IMAG (y
));
7370 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7371 - SCM_COMPLEX_IMAG (y
));
7373 else if (SCM_FRACTIONP (y
))
7374 /* a - b/c = (ac - b) / c */
7375 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7376 SCM_FRACTION_NUMERATOR (y
)),
7377 SCM_FRACTION_DENOMINATOR (y
));
7379 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7381 else if (SCM_BIGP (x
))
7383 if (SCM_I_INUMP (y
))
7385 /* big-x - inum-y */
7386 scm_t_inum yy
= SCM_I_INUM (y
);
7387 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7389 scm_remember_upto_here_1 (x
);
7391 return (SCM_FIXABLE (-yy
) ?
7392 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7395 SCM result
= scm_i_mkbig ();
7398 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7400 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7401 scm_remember_upto_here_1 (x
);
7403 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7404 /* we know the result will have to be a bignum */
7407 return scm_i_normbig (result
);
7410 else if (SCM_BIGP (y
))
7412 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7413 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7414 SCM result
= scm_i_mkbig ();
7415 mpz_sub (SCM_I_BIG_MPZ (result
),
7418 scm_remember_upto_here_2 (x
, y
);
7419 /* we know the result will have to be a bignum */
7420 if ((sgn_x
== 1) && (sgn_y
== -1))
7422 if ((sgn_x
== -1) && (sgn_y
== 1))
7424 return scm_i_normbig (result
);
7426 else if (SCM_REALP (y
))
7428 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7429 scm_remember_upto_here_1 (x
);
7430 return scm_from_double (result
);
7432 else if (SCM_COMPLEXP (y
))
7434 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7435 - SCM_COMPLEX_REAL (y
));
7436 scm_remember_upto_here_1 (x
);
7437 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7439 else if (SCM_FRACTIONP (y
))
7440 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7441 SCM_FRACTION_NUMERATOR (y
)),
7442 SCM_FRACTION_DENOMINATOR (y
));
7443 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7445 else if (SCM_REALP (x
))
7447 if (SCM_I_INUMP (y
))
7448 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7449 else if (SCM_BIGP (y
))
7451 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7452 scm_remember_upto_here_1 (x
);
7453 return scm_from_double (result
);
7455 else if (SCM_REALP (y
))
7456 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7457 else if (SCM_COMPLEXP (y
))
7458 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7459 -SCM_COMPLEX_IMAG (y
));
7460 else if (SCM_FRACTIONP (y
))
7461 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7463 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7465 else if (SCM_COMPLEXP (x
))
7467 if (SCM_I_INUMP (y
))
7468 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7469 SCM_COMPLEX_IMAG (x
));
7470 else if (SCM_BIGP (y
))
7472 double real_part
= (SCM_COMPLEX_REAL (x
)
7473 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7474 scm_remember_upto_here_1 (x
);
7475 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7477 else if (SCM_REALP (y
))
7478 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7479 SCM_COMPLEX_IMAG (x
));
7480 else if (SCM_COMPLEXP (y
))
7481 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7482 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7483 else if (SCM_FRACTIONP (y
))
7484 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7485 SCM_COMPLEX_IMAG (x
));
7487 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7489 else if (SCM_FRACTIONP (x
))
7491 if (SCM_I_INUMP (y
))
7492 /* a/b - c = (a - cb) / b */
7493 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7494 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7495 SCM_FRACTION_DENOMINATOR (x
));
7496 else if (SCM_BIGP (y
))
7497 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7498 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7499 SCM_FRACTION_DENOMINATOR (x
));
7500 else if (SCM_REALP (y
))
7501 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7502 else if (SCM_COMPLEXP (y
))
7503 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7504 -SCM_COMPLEX_IMAG (y
));
7505 else if (SCM_FRACTIONP (y
))
7506 /* a/b - c/d = (ad - bc) / bd */
7507 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7508 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7509 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7511 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7514 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7519 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7521 "Return @math{@var{x}-1}.")
7522 #define FUNC_NAME s_scm_oneminus
7524 return scm_difference (x
, SCM_INUM1
);
7529 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7530 (SCM x
, SCM y
, SCM rest
),
7531 "Return the product of all arguments. If called without arguments,\n"
7533 #define FUNC_NAME s_scm_i_product
7535 while (!scm_is_null (rest
))
7536 { x
= scm_product (x
, y
);
7538 rest
= scm_cdr (rest
);
7540 return scm_product (x
, y
);
7544 #define s_product s_scm_i_product
7545 #define g_product g_scm_i_product
7548 scm_product (SCM x
, SCM y
)
7550 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7553 return SCM_I_MAKINUM (1L);
7554 else if (SCM_NUMBERP (x
))
7557 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7560 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7565 xx
= SCM_I_INUM (x
);
7570 /* exact1 is the universal multiplicative identity */
7574 /* exact0 times a fixnum is exact0: optimize this case */
7575 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7577 /* if the other argument is inexact, the result is inexact,
7578 and we must do the multiplication in order to handle
7579 infinities and NaNs properly. */
7580 else if (SCM_REALP (y
))
7581 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7582 else if (SCM_COMPLEXP (y
))
7583 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7584 0.0 * SCM_COMPLEX_IMAG (y
));
7585 /* we've already handled inexact numbers,
7586 so y must be exact, and we return exact0 */
7587 else if (SCM_NUMP (y
))
7590 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7594 * This case is important for more than just optimization.
7595 * It handles the case of negating
7596 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7597 * which is a bignum that must be changed back into a fixnum.
7598 * Failure to do so will cause the following to return #f:
7599 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7601 return scm_difference(y
, SCM_UNDEFINED
);
7605 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7607 scm_t_inum yy
= SCM_I_INUM (y
);
7608 scm_t_inum kk
= xx
* yy
;
7609 SCM k
= SCM_I_MAKINUM (kk
);
7610 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7614 SCM result
= scm_i_inum2big (xx
);
7615 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7616 return scm_i_normbig (result
);
7619 else if (SCM_BIGP (y
))
7621 SCM result
= scm_i_mkbig ();
7622 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7623 scm_remember_upto_here_1 (y
);
7626 else if (SCM_REALP (y
))
7627 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7628 else if (SCM_COMPLEXP (y
))
7629 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7630 xx
* SCM_COMPLEX_IMAG (y
));
7631 else if (SCM_FRACTIONP (y
))
7632 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7633 SCM_FRACTION_DENOMINATOR (y
));
7635 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7637 else if (SCM_BIGP (x
))
7639 if (SCM_I_INUMP (y
))
7644 else if (SCM_BIGP (y
))
7646 SCM result
= scm_i_mkbig ();
7647 mpz_mul (SCM_I_BIG_MPZ (result
),
7650 scm_remember_upto_here_2 (x
, y
);
7653 else if (SCM_REALP (y
))
7655 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7656 scm_remember_upto_here_1 (x
);
7657 return scm_from_double (result
);
7659 else if (SCM_COMPLEXP (y
))
7661 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7662 scm_remember_upto_here_1 (x
);
7663 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7664 z
* SCM_COMPLEX_IMAG (y
));
7666 else if (SCM_FRACTIONP (y
))
7667 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7668 SCM_FRACTION_DENOMINATOR (y
));
7670 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7672 else if (SCM_REALP (x
))
7674 if (SCM_I_INUMP (y
))
7679 else if (SCM_BIGP (y
))
7681 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7682 scm_remember_upto_here_1 (y
);
7683 return scm_from_double (result
);
7685 else if (SCM_REALP (y
))
7686 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7687 else if (SCM_COMPLEXP (y
))
7688 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7689 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7690 else if (SCM_FRACTIONP (y
))
7691 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7693 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7695 else if (SCM_COMPLEXP (x
))
7697 if (SCM_I_INUMP (y
))
7702 else if (SCM_BIGP (y
))
7704 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7705 scm_remember_upto_here_1 (y
);
7706 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7707 z
* SCM_COMPLEX_IMAG (x
));
7709 else if (SCM_REALP (y
))
7710 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7711 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7712 else if (SCM_COMPLEXP (y
))
7714 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7715 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7716 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7717 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7719 else if (SCM_FRACTIONP (y
))
7721 double yy
= scm_i_fraction2double (y
);
7722 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7723 yy
* SCM_COMPLEX_IMAG (x
));
7726 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7728 else if (SCM_FRACTIONP (x
))
7730 if (SCM_I_INUMP (y
))
7731 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7732 SCM_FRACTION_DENOMINATOR (x
));
7733 else if (SCM_BIGP (y
))
7734 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7735 SCM_FRACTION_DENOMINATOR (x
));
7736 else if (SCM_REALP (y
))
7737 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7738 else if (SCM_COMPLEXP (y
))
7740 double xx
= scm_i_fraction2double (x
);
7741 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7742 xx
* SCM_COMPLEX_IMAG (y
));
7744 else if (SCM_FRACTIONP (y
))
7745 /* a/b * c/d = ac / bd */
7746 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7747 SCM_FRACTION_NUMERATOR (y
)),
7748 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7749 SCM_FRACTION_DENOMINATOR (y
)));
7751 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7754 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7757 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7758 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7759 #define ALLOW_DIVIDE_BY_ZERO
7760 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7763 /* The code below for complex division is adapted from the GNU
7764 libstdc++, which adapted it from f2c's libF77, and is subject to
7767 /****************************************************************
7768 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7770 Permission to use, copy, modify, and distribute this software
7771 and its documentation for any purpose and without fee is hereby
7772 granted, provided that the above copyright notice appear in all
7773 copies and that both that the copyright notice and this
7774 permission notice and warranty disclaimer appear in supporting
7775 documentation, and that the names of AT&T Bell Laboratories or
7776 Bellcore or any of their entities not be used in advertising or
7777 publicity pertaining to distribution of the software without
7778 specific, written prior permission.
7780 AT&T and Bellcore disclaim all warranties with regard to this
7781 software, including all implied warranties of merchantability
7782 and fitness. In no event shall AT&T or Bellcore be liable for
7783 any special, indirect or consequential damages or any damages
7784 whatsoever resulting from loss of use, data or profits, whether
7785 in an action of contract, negligence or other tortious action,
7786 arising out of or in connection with the use or performance of
7788 ****************************************************************/
7790 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7791 (SCM x
, SCM y
, SCM rest
),
7792 "Divide the first argument by the product of the remaining\n"
7793 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7795 #define FUNC_NAME s_scm_i_divide
7797 while (!scm_is_null (rest
))
7798 { x
= scm_divide (x
, y
);
7800 rest
= scm_cdr (rest
);
7802 return scm_divide (x
, y
);
7806 #define s_divide s_scm_i_divide
7807 #define g_divide g_scm_i_divide
7810 do_divide (SCM x
, SCM y
, int inexact
)
7811 #define FUNC_NAME s_divide
7815 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7818 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7819 else if (SCM_I_INUMP (x
))
7821 scm_t_inum xx
= SCM_I_INUM (x
);
7822 if (xx
== 1 || xx
== -1)
7824 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7826 scm_num_overflow (s_divide
);
7831 return scm_from_double (1.0 / (double) xx
);
7832 else return scm_i_make_ratio (SCM_INUM1
, x
);
7835 else if (SCM_BIGP (x
))
7838 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7839 else return scm_i_make_ratio (SCM_INUM1
, x
);
7841 else if (SCM_REALP (x
))
7843 double xx
= SCM_REAL_VALUE (x
);
7844 #ifndef ALLOW_DIVIDE_BY_ZERO
7846 scm_num_overflow (s_divide
);
7849 return scm_from_double (1.0 / xx
);
7851 else if (SCM_COMPLEXP (x
))
7853 double r
= SCM_COMPLEX_REAL (x
);
7854 double i
= SCM_COMPLEX_IMAG (x
);
7855 if (fabs(r
) <= fabs(i
))
7858 double d
= i
* (1.0 + t
* t
);
7859 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7864 double d
= r
* (1.0 + t
* t
);
7865 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7868 else if (SCM_FRACTIONP (x
))
7869 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7870 SCM_FRACTION_NUMERATOR (x
));
7872 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7875 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7877 scm_t_inum xx
= SCM_I_INUM (x
);
7878 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7880 scm_t_inum yy
= SCM_I_INUM (y
);
7883 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7884 scm_num_overflow (s_divide
);
7886 return scm_from_double ((double) xx
/ (double) yy
);
7889 else if (xx
% yy
!= 0)
7892 return scm_from_double ((double) xx
/ (double) yy
);
7893 else return scm_i_make_ratio (x
, y
);
7897 scm_t_inum z
= xx
/ yy
;
7898 if (SCM_FIXABLE (z
))
7899 return SCM_I_MAKINUM (z
);
7901 return scm_i_inum2big (z
);
7904 else if (SCM_BIGP (y
))
7907 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7908 else return scm_i_make_ratio (x
, y
);
7910 else if (SCM_REALP (y
))
7912 double yy
= SCM_REAL_VALUE (y
);
7913 #ifndef ALLOW_DIVIDE_BY_ZERO
7915 scm_num_overflow (s_divide
);
7918 return scm_from_double ((double) xx
/ yy
);
7920 else if (SCM_COMPLEXP (y
))
7923 complex_div
: /* y _must_ be a complex number */
7925 double r
= SCM_COMPLEX_REAL (y
);
7926 double i
= SCM_COMPLEX_IMAG (y
);
7927 if (fabs(r
) <= fabs(i
))
7930 double d
= i
* (1.0 + t
* t
);
7931 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7936 double d
= r
* (1.0 + t
* t
);
7937 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7941 else if (SCM_FRACTIONP (y
))
7942 /* a / b/c = ac / b */
7943 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7944 SCM_FRACTION_NUMERATOR (y
));
7946 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7948 else if (SCM_BIGP (x
))
7950 if (SCM_I_INUMP (y
))
7952 scm_t_inum yy
= SCM_I_INUM (y
);
7955 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7956 scm_num_overflow (s_divide
);
7958 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7959 scm_remember_upto_here_1 (x
);
7960 return (sgn
== 0) ? scm_nan () : scm_inf ();
7967 /* FIXME: HMM, what are the relative performance issues here?
7968 We need to test. Is it faster on average to test
7969 divisible_p, then perform whichever operation, or is it
7970 faster to perform the integer div opportunistically and
7971 switch to real if there's a remainder? For now we take the
7972 middle ground: test, then if divisible, use the faster div
7975 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7976 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7980 SCM result
= scm_i_mkbig ();
7981 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7982 scm_remember_upto_here_1 (x
);
7984 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7985 return scm_i_normbig (result
);
7990 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7991 else return scm_i_make_ratio (x
, y
);
7995 else if (SCM_BIGP (y
))
8000 /* It's easily possible for the ratio x/y to fit a double
8001 but one or both x and y be too big to fit a double,
8002 hence the use of mpq_get_d rather than converting and
8005 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8006 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8007 return scm_from_double (mpq_get_d (q
));
8011 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8015 SCM result
= scm_i_mkbig ();
8016 mpz_divexact (SCM_I_BIG_MPZ (result
),
8019 scm_remember_upto_here_2 (x
, y
);
8020 return scm_i_normbig (result
);
8023 return scm_i_make_ratio (x
, y
);
8026 else if (SCM_REALP (y
))
8028 double yy
= SCM_REAL_VALUE (y
);
8029 #ifndef ALLOW_DIVIDE_BY_ZERO
8031 scm_num_overflow (s_divide
);
8034 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8036 else if (SCM_COMPLEXP (y
))
8038 a
= scm_i_big2dbl (x
);
8041 else if (SCM_FRACTIONP (y
))
8042 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8043 SCM_FRACTION_NUMERATOR (y
));
8045 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8047 else if (SCM_REALP (x
))
8049 double rx
= SCM_REAL_VALUE (x
);
8050 if (SCM_I_INUMP (y
))
8052 scm_t_inum yy
= SCM_I_INUM (y
);
8053 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8055 scm_num_overflow (s_divide
);
8058 return scm_from_double (rx
/ (double) yy
);
8060 else if (SCM_BIGP (y
))
8062 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8063 scm_remember_upto_here_1 (y
);
8064 return scm_from_double (rx
/ dby
);
8066 else if (SCM_REALP (y
))
8068 double yy
= SCM_REAL_VALUE (y
);
8069 #ifndef ALLOW_DIVIDE_BY_ZERO
8071 scm_num_overflow (s_divide
);
8074 return scm_from_double (rx
/ yy
);
8076 else if (SCM_COMPLEXP (y
))
8081 else if (SCM_FRACTIONP (y
))
8082 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8084 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8086 else if (SCM_COMPLEXP (x
))
8088 double rx
= SCM_COMPLEX_REAL (x
);
8089 double ix
= SCM_COMPLEX_IMAG (x
);
8090 if (SCM_I_INUMP (y
))
8092 scm_t_inum yy
= SCM_I_INUM (y
);
8093 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8095 scm_num_overflow (s_divide
);
8100 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8103 else if (SCM_BIGP (y
))
8105 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8106 scm_remember_upto_here_1 (y
);
8107 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8109 else if (SCM_REALP (y
))
8111 double yy
= SCM_REAL_VALUE (y
);
8112 #ifndef ALLOW_DIVIDE_BY_ZERO
8114 scm_num_overflow (s_divide
);
8117 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8119 else if (SCM_COMPLEXP (y
))
8121 double ry
= SCM_COMPLEX_REAL (y
);
8122 double iy
= SCM_COMPLEX_IMAG (y
);
8123 if (fabs(ry
) <= fabs(iy
))
8126 double d
= iy
* (1.0 + t
* t
);
8127 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8132 double d
= ry
* (1.0 + t
* t
);
8133 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8136 else if (SCM_FRACTIONP (y
))
8138 double yy
= scm_i_fraction2double (y
);
8139 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8142 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8144 else if (SCM_FRACTIONP (x
))
8146 if (SCM_I_INUMP (y
))
8148 scm_t_inum yy
= SCM_I_INUM (y
);
8149 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8151 scm_num_overflow (s_divide
);
8154 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8155 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8157 else if (SCM_BIGP (y
))
8159 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8160 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8162 else if (SCM_REALP (y
))
8164 double yy
= SCM_REAL_VALUE (y
);
8165 #ifndef ALLOW_DIVIDE_BY_ZERO
8167 scm_num_overflow (s_divide
);
8170 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8172 else if (SCM_COMPLEXP (y
))
8174 a
= scm_i_fraction2double (x
);
8177 else if (SCM_FRACTIONP (y
))
8178 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8179 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8181 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8184 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8188 scm_divide (SCM x
, SCM y
)
8190 return do_divide (x
, y
, 0);
8193 static SCM
scm_divide2real (SCM x
, SCM y
)
8195 return do_divide (x
, y
, 1);
8201 scm_c_truncate (double x
)
8206 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8207 half-way case (ie. when x is an integer plus 0.5) going upwards.
8208 Then half-way cases are identified and adjusted down if the
8209 round-upwards didn't give the desired even integer.
8211 "plus_half == result" identifies a half-way case. If plus_half, which is
8212 x + 0.5, is an integer then x must be an integer plus 0.5.
8214 An odd "result" value is identified with result/2 != floor(result/2).
8215 This is done with plus_half, since that value is ready for use sooner in
8216 a pipelined cpu, and we're already requiring plus_half == result.
8218 Note however that we need to be careful when x is big and already an
8219 integer. In that case "x+0.5" may round to an adjacent integer, causing
8220 us to return such a value, incorrectly. For instance if the hardware is
8221 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8222 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8223 returned. Or if the hardware is in round-upwards mode, then other bigger
8224 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8225 representable value, 2^128+2^76 (or whatever), again incorrect.
8227 These bad roundings of x+0.5 are avoided by testing at the start whether
8228 x is already an integer. If it is then clearly that's the desired result
8229 already. And if it's not then the exponent must be small enough to allow
8230 an 0.5 to be represented, and hence added without a bad rounding. */
8233 scm_c_round (double x
)
8235 double plus_half
, result
;
8240 plus_half
= x
+ 0.5;
8241 result
= floor (plus_half
);
8242 /* Adjust so that the rounding is towards even. */
8243 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8248 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8250 "Round the number @var{x} towards zero.")
8251 #define FUNC_NAME s_scm_truncate_number
8253 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8255 else if (SCM_REALP (x
))
8256 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8257 else if (SCM_FRACTIONP (x
))
8258 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8259 SCM_FRACTION_DENOMINATOR (x
));
8261 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8262 s_scm_truncate_number
);
8266 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8268 "Round the number @var{x} towards the nearest integer. "
8269 "When it is exactly halfway between two integers, "
8270 "round towards the even one.")
8271 #define FUNC_NAME s_scm_round_number
8273 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8275 else if (SCM_REALP (x
))
8276 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8277 else if (SCM_FRACTIONP (x
))
8278 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8279 SCM_FRACTION_DENOMINATOR (x
));
8281 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8282 s_scm_round_number
);
8286 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8288 "Round the number @var{x} towards minus infinity.")
8289 #define FUNC_NAME s_scm_floor
8291 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8293 else if (SCM_REALP (x
))
8294 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8295 else if (SCM_FRACTIONP (x
))
8296 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8297 SCM_FRACTION_DENOMINATOR (x
));
8299 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8303 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8305 "Round the number @var{x} towards infinity.")
8306 #define FUNC_NAME s_scm_ceiling
8308 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8310 else if (SCM_REALP (x
))
8311 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8312 else if (SCM_FRACTIONP (x
))
8313 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8314 SCM_FRACTION_DENOMINATOR (x
));
8316 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8320 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8322 "Return @var{x} raised to the power of @var{y}.")
8323 #define FUNC_NAME s_scm_expt
8325 if (scm_is_integer (y
))
8327 if (scm_is_true (scm_exact_p (y
)))
8328 return scm_integer_expt (x
, y
);
8331 /* Here we handle the case where the exponent is an inexact
8332 integer. We make the exponent exact in order to use
8333 scm_integer_expt, and thus avoid the spurious imaginary
8334 parts that may result from round-off errors in the general
8335 e^(y log x) method below (for example when squaring a large
8336 negative number). In this case, we must return an inexact
8337 result for correctness. We also make the base inexact so
8338 that scm_integer_expt will use fast inexact arithmetic
8339 internally. Note that making the base inexact is not
8340 sufficient to guarantee an inexact result, because
8341 scm_integer_expt will return an exact 1 when the exponent
8342 is 0, even if the base is inexact. */
8343 return scm_exact_to_inexact
8344 (scm_integer_expt (scm_exact_to_inexact (x
),
8345 scm_inexact_to_exact (y
)));
8348 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8350 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8352 else if (scm_is_complex (x
) && scm_is_complex (y
))
8353 return scm_exp (scm_product (scm_log (x
), y
));
8354 else if (scm_is_complex (x
))
8355 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8357 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8361 /* sin/cos/tan/asin/acos/atan
8362 sinh/cosh/tanh/asinh/acosh/atanh
8363 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8364 Written by Jerry D. Hedden, (C) FSF.
8365 See the file `COPYING' for terms applying to this program. */
8367 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8369 "Compute the sine of @var{z}.")
8370 #define FUNC_NAME s_scm_sin
8372 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8373 return z
; /* sin(exact0) = exact0 */
8374 else if (scm_is_real (z
))
8375 return scm_from_double (sin (scm_to_double (z
)));
8376 else if (SCM_COMPLEXP (z
))
8378 x
= SCM_COMPLEX_REAL (z
);
8379 y
= SCM_COMPLEX_IMAG (z
);
8380 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8381 cos (x
) * sinh (y
));
8384 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8388 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8390 "Compute the cosine of @var{z}.")
8391 #define FUNC_NAME s_scm_cos
8393 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8394 return SCM_INUM1
; /* cos(exact0) = exact1 */
8395 else if (scm_is_real (z
))
8396 return scm_from_double (cos (scm_to_double (z
)));
8397 else if (SCM_COMPLEXP (z
))
8399 x
= SCM_COMPLEX_REAL (z
);
8400 y
= SCM_COMPLEX_IMAG (z
);
8401 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8402 -sin (x
) * sinh (y
));
8405 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8409 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8411 "Compute the tangent of @var{z}.")
8412 #define FUNC_NAME s_scm_tan
8414 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8415 return z
; /* tan(exact0) = exact0 */
8416 else if (scm_is_real (z
))
8417 return scm_from_double (tan (scm_to_double (z
)));
8418 else if (SCM_COMPLEXP (z
))
8420 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8421 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8422 w
= cos (x
) + cosh (y
);
8423 #ifndef ALLOW_DIVIDE_BY_ZERO
8425 scm_num_overflow (s_scm_tan
);
8427 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8430 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8434 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8436 "Compute the hyperbolic sine of @var{z}.")
8437 #define FUNC_NAME s_scm_sinh
8439 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8440 return z
; /* sinh(exact0) = exact0 */
8441 else if (scm_is_real (z
))
8442 return scm_from_double (sinh (scm_to_double (z
)));
8443 else if (SCM_COMPLEXP (z
))
8445 x
= SCM_COMPLEX_REAL (z
);
8446 y
= SCM_COMPLEX_IMAG (z
);
8447 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8448 cosh (x
) * sin (y
));
8451 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8455 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8457 "Compute the hyperbolic cosine of @var{z}.")
8458 #define FUNC_NAME s_scm_cosh
8460 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8461 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8462 else if (scm_is_real (z
))
8463 return scm_from_double (cosh (scm_to_double (z
)));
8464 else if (SCM_COMPLEXP (z
))
8466 x
= SCM_COMPLEX_REAL (z
);
8467 y
= SCM_COMPLEX_IMAG (z
);
8468 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8469 sinh (x
) * sin (y
));
8472 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8476 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8478 "Compute the hyperbolic tangent of @var{z}.")
8479 #define FUNC_NAME s_scm_tanh
8481 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8482 return z
; /* tanh(exact0) = exact0 */
8483 else if (scm_is_real (z
))
8484 return scm_from_double (tanh (scm_to_double (z
)));
8485 else if (SCM_COMPLEXP (z
))
8487 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8488 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8489 w
= cosh (x
) + cos (y
);
8490 #ifndef ALLOW_DIVIDE_BY_ZERO
8492 scm_num_overflow (s_scm_tanh
);
8494 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8497 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8501 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8503 "Compute the arc sine of @var{z}.")
8504 #define FUNC_NAME s_scm_asin
8506 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8507 return z
; /* asin(exact0) = exact0 */
8508 else if (scm_is_real (z
))
8510 double w
= scm_to_double (z
);
8511 if (w
>= -1.0 && w
<= 1.0)
8512 return scm_from_double (asin (w
));
8514 return scm_product (scm_c_make_rectangular (0, -1),
8515 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8517 else if (SCM_COMPLEXP (z
))
8519 x
= SCM_COMPLEX_REAL (z
);
8520 y
= SCM_COMPLEX_IMAG (z
);
8521 return scm_product (scm_c_make_rectangular (0, -1),
8522 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8525 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8529 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8531 "Compute the arc cosine of @var{z}.")
8532 #define FUNC_NAME s_scm_acos
8534 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8535 return SCM_INUM0
; /* acos(exact1) = exact0 */
8536 else if (scm_is_real (z
))
8538 double w
= scm_to_double (z
);
8539 if (w
>= -1.0 && w
<= 1.0)
8540 return scm_from_double (acos (w
));
8542 return scm_sum (scm_from_double (acos (0.0)),
8543 scm_product (scm_c_make_rectangular (0, 1),
8544 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8546 else if (SCM_COMPLEXP (z
))
8548 x
= SCM_COMPLEX_REAL (z
);
8549 y
= SCM_COMPLEX_IMAG (z
);
8550 return scm_sum (scm_from_double (acos (0.0)),
8551 scm_product (scm_c_make_rectangular (0, 1),
8552 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8555 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8559 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8561 "With one argument, compute the arc tangent of @var{z}.\n"
8562 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8563 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8564 #define FUNC_NAME s_scm_atan
8568 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8569 return z
; /* atan(exact0) = exact0 */
8570 else if (scm_is_real (z
))
8571 return scm_from_double (atan (scm_to_double (z
)));
8572 else if (SCM_COMPLEXP (z
))
8575 v
= SCM_COMPLEX_REAL (z
);
8576 w
= SCM_COMPLEX_IMAG (z
);
8577 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8578 scm_c_make_rectangular (v
, w
+ 1.0))),
8579 scm_c_make_rectangular (0, 2));
8582 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8584 else if (scm_is_real (z
))
8586 if (scm_is_real (y
))
8587 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8589 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8592 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8596 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8598 "Compute the inverse hyperbolic sine of @var{z}.")
8599 #define FUNC_NAME s_scm_sys_asinh
8601 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8602 return z
; /* asinh(exact0) = exact0 */
8603 else if (scm_is_real (z
))
8604 return scm_from_double (asinh (scm_to_double (z
)));
8605 else if (scm_is_number (z
))
8606 return scm_log (scm_sum (z
,
8607 scm_sqrt (scm_sum (scm_product (z
, z
),
8610 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8614 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8616 "Compute the inverse hyperbolic cosine of @var{z}.")
8617 #define FUNC_NAME s_scm_sys_acosh
8619 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8620 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8621 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8622 return scm_from_double (acosh (scm_to_double (z
)));
8623 else if (scm_is_number (z
))
8624 return scm_log (scm_sum (z
,
8625 scm_sqrt (scm_difference (scm_product (z
, z
),
8628 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8632 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8634 "Compute the inverse hyperbolic tangent of @var{z}.")
8635 #define FUNC_NAME s_scm_sys_atanh
8637 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8638 return z
; /* atanh(exact0) = exact0 */
8639 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8640 return scm_from_double (atanh (scm_to_double (z
)));
8641 else if (scm_is_number (z
))
8642 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8643 scm_difference (SCM_INUM1
, z
))),
8646 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8651 scm_c_make_rectangular (double re
, double im
)
8655 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8657 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8658 SCM_COMPLEX_REAL (z
) = re
;
8659 SCM_COMPLEX_IMAG (z
) = im
;
8663 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8664 (SCM real_part
, SCM imaginary_part
),
8665 "Return a complex number constructed of the given @var{real-part} "
8666 "and @var{imaginary-part} parts.")
8667 #define FUNC_NAME s_scm_make_rectangular
8669 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8670 SCM_ARG1
, FUNC_NAME
, "real");
8671 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8672 SCM_ARG2
, FUNC_NAME
, "real");
8674 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8675 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8678 return scm_c_make_rectangular (scm_to_double (real_part
),
8679 scm_to_double (imaginary_part
));
8684 scm_c_make_polar (double mag
, double ang
)
8688 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8689 use it on Glibc-based systems that have it (it's a GNU extension). See
8690 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8692 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8693 sincos (ang
, &s
, &c
);
8699 /* If s and c are NaNs, this indicates that the angle is a NaN,
8700 infinite, or perhaps simply too large to determine its value
8701 mod 2*pi. However, we know something that the floating-point
8702 implementation doesn't know: We know that s and c are finite.
8703 Therefore, if the magnitude is zero, return a complex zero.
8705 The reason we check for the NaNs instead of using this case
8706 whenever mag == 0.0 is because when the angle is known, we'd
8707 like to return the correct kind of non-real complex zero:
8708 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8709 on which quadrant the angle is in.
8711 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8712 return scm_c_make_rectangular (0.0, 0.0);
8714 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8717 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8719 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8720 #define FUNC_NAME s_scm_make_polar
8722 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8723 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8725 /* If mag is exact0, return exact0 */
8726 if (scm_is_eq (mag
, SCM_INUM0
))
8728 /* Return a real if ang is exact0 */
8729 else if (scm_is_eq (ang
, SCM_INUM0
))
8732 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8737 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8739 "Return the real part of the number @var{z}.")
8740 #define FUNC_NAME s_scm_real_part
8742 if (SCM_COMPLEXP (z
))
8743 return scm_from_double (SCM_COMPLEX_REAL (z
));
8744 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8747 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8752 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8754 "Return the imaginary part of the number @var{z}.")
8755 #define FUNC_NAME s_scm_imag_part
8757 if (SCM_COMPLEXP (z
))
8758 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8759 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8762 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8766 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8768 "Return the numerator of the number @var{z}.")
8769 #define FUNC_NAME s_scm_numerator
8771 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8773 else if (SCM_FRACTIONP (z
))
8774 return SCM_FRACTION_NUMERATOR (z
);
8775 else if (SCM_REALP (z
))
8776 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8778 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8783 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8785 "Return the denominator of the number @var{z}.")
8786 #define FUNC_NAME s_scm_denominator
8788 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8790 else if (SCM_FRACTIONP (z
))
8791 return SCM_FRACTION_DENOMINATOR (z
);
8792 else if (SCM_REALP (z
))
8793 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8795 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8800 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8802 "Return the magnitude of the number @var{z}. This is the same as\n"
8803 "@code{abs} for real arguments, but also allows complex numbers.")
8804 #define FUNC_NAME s_scm_magnitude
8806 if (SCM_I_INUMP (z
))
8808 scm_t_inum zz
= SCM_I_INUM (z
);
8811 else if (SCM_POSFIXABLE (-zz
))
8812 return SCM_I_MAKINUM (-zz
);
8814 return scm_i_inum2big (-zz
);
8816 else if (SCM_BIGP (z
))
8818 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8819 scm_remember_upto_here_1 (z
);
8821 return scm_i_clonebig (z
, 0);
8825 else if (SCM_REALP (z
))
8826 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8827 else if (SCM_COMPLEXP (z
))
8828 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8829 else if (SCM_FRACTIONP (z
))
8831 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8833 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8834 SCM_FRACTION_DENOMINATOR (z
));
8837 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8842 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8844 "Return the angle of the complex number @var{z}.")
8845 #define FUNC_NAME s_scm_angle
8847 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8848 flo0 to save allocating a new flonum with scm_from_double each time.
8849 But if atan2 follows the floating point rounding mode, then the value
8850 is not a constant. Maybe it'd be close enough though. */
8851 if (SCM_I_INUMP (z
))
8853 if (SCM_I_INUM (z
) >= 0)
8856 return scm_from_double (atan2 (0.0, -1.0));
8858 else if (SCM_BIGP (z
))
8860 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8861 scm_remember_upto_here_1 (z
);
8863 return scm_from_double (atan2 (0.0, -1.0));
8867 else if (SCM_REALP (z
))
8869 if (SCM_REAL_VALUE (z
) >= 0)
8872 return scm_from_double (atan2 (0.0, -1.0));
8874 else if (SCM_COMPLEXP (z
))
8875 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8876 else if (SCM_FRACTIONP (z
))
8878 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8880 else return scm_from_double (atan2 (0.0, -1.0));
8883 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8888 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8890 "Convert the number @var{z} to its inexact representation.\n")
8891 #define FUNC_NAME s_scm_exact_to_inexact
8893 if (SCM_I_INUMP (z
))
8894 return scm_from_double ((double) SCM_I_INUM (z
));
8895 else if (SCM_BIGP (z
))
8896 return scm_from_double (scm_i_big2dbl (z
));
8897 else if (SCM_FRACTIONP (z
))
8898 return scm_from_double (scm_i_fraction2double (z
));
8899 else if (SCM_INEXACTP (z
))
8902 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8907 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8909 "Return an exact number that is numerically closest to @var{z}.")
8910 #define FUNC_NAME s_scm_inexact_to_exact
8912 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8919 val
= SCM_REAL_VALUE (z
);
8920 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8921 val
= SCM_COMPLEX_REAL (z
);
8923 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8925 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8926 SCM_OUT_OF_RANGE (1, z
);
8933 mpq_set_d (frac
, val
);
8934 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8935 scm_i_mpz2num (mpq_denref (frac
)));
8937 /* When scm_i_make_ratio throws, we leak the memory allocated
8947 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8949 "Returns the @emph{simplest} rational number differing\n"
8950 "from @var{x} by no more than @var{eps}.\n"
8952 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8953 "exact result when both its arguments are exact. Thus, you might need\n"
8954 "to use @code{inexact->exact} on the arguments.\n"
8957 "(rationalize (inexact->exact 1.2) 1/100)\n"
8960 #define FUNC_NAME s_scm_rationalize
8962 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8963 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8964 eps
= scm_abs (eps
);
8965 if (scm_is_false (scm_positive_p (eps
)))
8967 /* eps is either zero or a NaN */
8968 if (scm_is_true (scm_nan_p (eps
)))
8970 else if (SCM_INEXACTP (eps
))
8971 return scm_exact_to_inexact (x
);
8975 else if (scm_is_false (scm_finite_p (eps
)))
8977 if (scm_is_true (scm_finite_p (x
)))
8982 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8984 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8985 scm_ceiling (scm_difference (x
, eps
)))))
8987 /* There's an integer within range; we want the one closest to zero */
8988 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8990 /* zero is within range */
8991 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8996 else if (scm_is_true (scm_positive_p (x
)))
8997 return scm_ceiling (scm_difference (x
, eps
));
8999 return scm_floor (scm_sum (x
, eps
));
9003 /* Use continued fractions to find closest ratio. All
9004 arithmetic is done with exact numbers.
9007 SCM ex
= scm_inexact_to_exact (x
);
9008 SCM int_part
= scm_floor (ex
);
9010 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9011 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9015 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9016 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9018 /* We stop after a million iterations just to be absolutely sure
9019 that we don't go into an infinite loop. The process normally
9020 converges after less than a dozen iterations.
9023 while (++i
< 1000000)
9025 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9026 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9027 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9029 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9030 eps
))) /* abs(x-a/b) <= eps */
9032 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9033 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9034 return scm_exact_to_inexact (res
);
9038 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9040 tt
= scm_floor (rx
); /* tt = floor (rx) */
9046 scm_num_overflow (s_scm_rationalize
);
9051 /* conversion functions */
9054 scm_is_integer (SCM val
)
9056 return scm_is_true (scm_integer_p (val
));
9060 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9062 if (SCM_I_INUMP (val
))
9064 scm_t_signed_bits n
= SCM_I_INUM (val
);
9065 return n
>= min
&& n
<= max
;
9067 else if (SCM_BIGP (val
))
9069 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9071 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9073 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9075 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9076 return n
>= min
&& n
<= max
;
9086 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9087 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9090 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9091 SCM_I_BIG_MPZ (val
));
9093 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9105 return n
>= min
&& n
<= max
;
9113 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9115 if (SCM_I_INUMP (val
))
9117 scm_t_signed_bits n
= SCM_I_INUM (val
);
9118 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9120 else if (SCM_BIGP (val
))
9122 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9124 else if (max
<= ULONG_MAX
)
9126 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9128 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9129 return n
>= min
&& n
<= max
;
9139 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9142 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9143 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9146 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9147 SCM_I_BIG_MPZ (val
));
9149 return n
>= min
&& n
<= max
;
9157 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9159 scm_error (scm_out_of_range_key
,
9161 "Value out of range ~S to ~S: ~S",
9162 scm_list_3 (min
, max
, bad_val
),
9163 scm_list_1 (bad_val
));
9166 #define TYPE scm_t_intmax
9167 #define TYPE_MIN min
9168 #define TYPE_MAX max
9169 #define SIZEOF_TYPE 0
9170 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9171 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9172 #include "libguile/conv-integer.i.c"
9174 #define TYPE scm_t_uintmax
9175 #define TYPE_MIN min
9176 #define TYPE_MAX max
9177 #define SIZEOF_TYPE 0
9178 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9179 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9180 #include "libguile/conv-uinteger.i.c"
9182 #define TYPE scm_t_int8
9183 #define TYPE_MIN SCM_T_INT8_MIN
9184 #define TYPE_MAX SCM_T_INT8_MAX
9185 #define SIZEOF_TYPE 1
9186 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9187 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9188 #include "libguile/conv-integer.i.c"
9190 #define TYPE scm_t_uint8
9192 #define TYPE_MAX SCM_T_UINT8_MAX
9193 #define SIZEOF_TYPE 1
9194 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9195 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9196 #include "libguile/conv-uinteger.i.c"
9198 #define TYPE scm_t_int16
9199 #define TYPE_MIN SCM_T_INT16_MIN
9200 #define TYPE_MAX SCM_T_INT16_MAX
9201 #define SIZEOF_TYPE 2
9202 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9203 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9204 #include "libguile/conv-integer.i.c"
9206 #define TYPE scm_t_uint16
9208 #define TYPE_MAX SCM_T_UINT16_MAX
9209 #define SIZEOF_TYPE 2
9210 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9211 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9212 #include "libguile/conv-uinteger.i.c"
9214 #define TYPE scm_t_int32
9215 #define TYPE_MIN SCM_T_INT32_MIN
9216 #define TYPE_MAX SCM_T_INT32_MAX
9217 #define SIZEOF_TYPE 4
9218 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9219 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9220 #include "libguile/conv-integer.i.c"
9222 #define TYPE scm_t_uint32
9224 #define TYPE_MAX SCM_T_UINT32_MAX
9225 #define SIZEOF_TYPE 4
9226 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9227 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9228 #include "libguile/conv-uinteger.i.c"
9230 #define TYPE scm_t_wchar
9231 #define TYPE_MIN (scm_t_int32)-1
9232 #define TYPE_MAX (scm_t_int32)0x10ffff
9233 #define SIZEOF_TYPE 4
9234 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9235 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9236 #include "libguile/conv-integer.i.c"
9238 #define TYPE scm_t_int64
9239 #define TYPE_MIN SCM_T_INT64_MIN
9240 #define TYPE_MAX SCM_T_INT64_MAX
9241 #define SIZEOF_TYPE 8
9242 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9243 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9244 #include "libguile/conv-integer.i.c"
9246 #define TYPE scm_t_uint64
9248 #define TYPE_MAX SCM_T_UINT64_MAX
9249 #define SIZEOF_TYPE 8
9250 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9251 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9252 #include "libguile/conv-uinteger.i.c"
9255 scm_to_mpz (SCM val
, mpz_t rop
)
9257 if (SCM_I_INUMP (val
))
9258 mpz_set_si (rop
, SCM_I_INUM (val
));
9259 else if (SCM_BIGP (val
))
9260 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9262 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9266 scm_from_mpz (mpz_t val
)
9268 return scm_i_mpz2num (val
);
9272 scm_is_real (SCM val
)
9274 return scm_is_true (scm_real_p (val
));
9278 scm_is_rational (SCM val
)
9280 return scm_is_true (scm_rational_p (val
));
9284 scm_to_double (SCM val
)
9286 if (SCM_I_INUMP (val
))
9287 return SCM_I_INUM (val
);
9288 else if (SCM_BIGP (val
))
9289 return scm_i_big2dbl (val
);
9290 else if (SCM_FRACTIONP (val
))
9291 return scm_i_fraction2double (val
);
9292 else if (SCM_REALP (val
))
9293 return SCM_REAL_VALUE (val
);
9295 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9299 scm_from_double (double val
)
9303 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9305 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9306 SCM_REAL_VALUE (z
) = val
;
9311 #if SCM_ENABLE_DEPRECATED == 1
9314 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9316 scm_c_issue_deprecation_warning
9317 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9321 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9325 scm_out_of_range (NULL
, num
);
9328 return scm_to_double (num
);
9332 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9334 scm_c_issue_deprecation_warning
9335 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9339 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9343 scm_out_of_range (NULL
, num
);
9346 return scm_to_double (num
);
9352 scm_is_complex (SCM val
)
9354 return scm_is_true (scm_complex_p (val
));
9358 scm_c_real_part (SCM z
)
9360 if (SCM_COMPLEXP (z
))
9361 return SCM_COMPLEX_REAL (z
);
9364 /* Use the scm_real_part to get proper error checking and
9367 return scm_to_double (scm_real_part (z
));
9372 scm_c_imag_part (SCM z
)
9374 if (SCM_COMPLEXP (z
))
9375 return SCM_COMPLEX_IMAG (z
);
9378 /* Use the scm_imag_part to get proper error checking and
9379 dispatching. The result will almost always be 0.0, but not
9382 return scm_to_double (scm_imag_part (z
));
9387 scm_c_magnitude (SCM z
)
9389 return scm_to_double (scm_magnitude (z
));
9395 return scm_to_double (scm_angle (z
));
9399 scm_is_number (SCM z
)
9401 return scm_is_true (scm_number_p (z
));
9405 /* Returns log(x * 2^shift) */
9407 log_of_shifted_double (double x
, long shift
)
9409 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9411 if (x
> 0.0 || double_is_non_negative_zero (x
))
9412 return scm_from_double (ans
);
9414 return scm_c_make_rectangular (ans
, M_PI
);
9417 /* Returns log(n), for exact integer n of integer-length size */
9419 log_of_exact_integer_with_size (SCM n
, long size
)
9421 long shift
= size
- 2 * scm_dblprec
[0];
9424 return log_of_shifted_double
9425 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9428 return log_of_shifted_double (scm_to_double (n
), 0);
9431 /* Returns log(n), for exact integer n */
9433 log_of_exact_integer (SCM n
)
9435 return log_of_exact_integer_with_size
9436 (n
, scm_to_long (scm_integer_length (n
)));
9439 /* Returns log(n/d), for exact non-zero integers n and d */
9441 log_of_fraction (SCM n
, SCM d
)
9443 long n_size
= scm_to_long (scm_integer_length (n
));
9444 long d_size
= scm_to_long (scm_integer_length (d
));
9446 if (abs (n_size
- d_size
) > 1)
9447 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9448 log_of_exact_integer_with_size (d
, d_size
)));
9449 else if (scm_is_false (scm_negative_p (n
)))
9450 return scm_from_double
9451 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9453 return scm_c_make_rectangular
9454 (log1p (scm_to_double (scm_divide2real
9455 (scm_difference (scm_abs (n
), d
),
9461 /* In the following functions we dispatch to the real-arg funcs like log()
9462 when we know the arg is real, instead of just handing everything to
9463 clog() for instance. This is in case clog() doesn't optimize for a
9464 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9465 well use it to go straight to the applicable C func. */
9467 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9469 "Return the natural logarithm of @var{z}.")
9470 #define FUNC_NAME s_scm_log
9472 if (SCM_COMPLEXP (z
))
9474 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9475 && defined (SCM_COMPLEX_VALUE)
9476 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9478 double re
= SCM_COMPLEX_REAL (z
);
9479 double im
= SCM_COMPLEX_IMAG (z
);
9480 return scm_c_make_rectangular (log (hypot (re
, im
)),
9484 else if (SCM_REALP (z
))
9485 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9486 else if (SCM_I_INUMP (z
))
9488 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9489 if (scm_is_eq (z
, SCM_INUM0
))
9490 scm_num_overflow (s_scm_log
);
9492 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9494 else if (SCM_BIGP (z
))
9495 return log_of_exact_integer (z
);
9496 else if (SCM_FRACTIONP (z
))
9497 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9498 SCM_FRACTION_DENOMINATOR (z
));
9500 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9505 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9507 "Return the base 10 logarithm of @var{z}.")
9508 #define FUNC_NAME s_scm_log10
9510 if (SCM_COMPLEXP (z
))
9512 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9513 clog() and a multiply by M_LOG10E, rather than the fallback
9514 log10+hypot+atan2.) */
9515 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9516 && defined SCM_COMPLEX_VALUE
9517 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9519 double re
= SCM_COMPLEX_REAL (z
);
9520 double im
= SCM_COMPLEX_IMAG (z
);
9521 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9522 M_LOG10E
* atan2 (im
, re
));
9525 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9527 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9528 if (scm_is_eq (z
, SCM_INUM0
))
9529 scm_num_overflow (s_scm_log10
);
9532 double re
= scm_to_double (z
);
9533 double l
= log10 (fabs (re
));
9534 if (re
> 0.0 || double_is_non_negative_zero (re
))
9535 return scm_from_double (l
);
9537 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9540 else if (SCM_BIGP (z
))
9541 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9542 else if (SCM_FRACTIONP (z
))
9543 return scm_product (flo_log10e
,
9544 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9545 SCM_FRACTION_DENOMINATOR (z
)));
9547 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9552 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9554 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9555 "base of natural logarithms (2.71828@dots{}).")
9556 #define FUNC_NAME s_scm_exp
9558 if (SCM_COMPLEXP (z
))
9560 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9561 && defined (SCM_COMPLEX_VALUE)
9562 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9564 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9565 SCM_COMPLEX_IMAG (z
));
9568 else if (SCM_NUMBERP (z
))
9570 /* When z is a negative bignum the conversion to double overflows,
9571 giving -infinity, but that's ok, the exp is still 0.0. */
9572 return scm_from_double (exp (scm_to_double (z
)));
9575 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9580 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9582 "Return two exact non-negative integers @var{s} and @var{r}\n"
9583 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9584 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9585 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9588 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9590 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9594 scm_exact_integer_sqrt (k
, &s
, &r
);
9595 return scm_values (scm_list_2 (s
, r
));
9600 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9602 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9604 scm_t_inum kk
= SCM_I_INUM (k
);
9608 if (SCM_LIKELY (kk
> 0))
9613 uu
= (ss
+ kk
/ss
) / 2;
9615 *sp
= SCM_I_MAKINUM (ss
);
9616 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9618 else if (SCM_LIKELY (kk
== 0))
9619 *sp
= *rp
= SCM_INUM0
;
9621 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9622 "exact non-negative integer");
9624 else if (SCM_LIKELY (SCM_BIGP (k
)))
9628 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9629 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9630 "exact non-negative integer");
9633 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9634 scm_remember_upto_here_1 (k
);
9635 *sp
= scm_i_normbig (s
);
9636 *rp
= scm_i_normbig (r
);
9639 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9640 "exact non-negative integer");
9644 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9646 "Return the square root of @var{z}. Of the two possible roots\n"
9647 "(positive and negative), the one with positive real part\n"
9648 "is returned, or if that's zero then a positive imaginary part.\n"
9652 "(sqrt 9.0) @result{} 3.0\n"
9653 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9654 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9655 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9657 #define FUNC_NAME s_scm_sqrt
9659 if (SCM_COMPLEXP (z
))
9661 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9662 && defined SCM_COMPLEX_VALUE
9663 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9665 double re
= SCM_COMPLEX_REAL (z
);
9666 double im
= SCM_COMPLEX_IMAG (z
);
9667 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9668 0.5 * atan2 (im
, re
));
9671 else if (SCM_NUMBERP (z
))
9673 double xx
= scm_to_double (z
);
9675 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9677 return scm_from_double (sqrt (xx
));
9680 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9691 mpz_init_set_si (z_negative_one
, -1);
9693 /* It may be possible to tune the performance of some algorithms by using
9694 * the following constants to avoid the creation of bignums. Please, before
9695 * using these values, remember the two rules of program optimization:
9696 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9697 scm_c_define ("most-positive-fixnum",
9698 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9699 scm_c_define ("most-negative-fixnum",
9700 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9702 scm_add_feature ("complex");
9703 scm_add_feature ("inexact");
9704 flo0
= scm_from_double (0.0);
9705 flo_log10e
= scm_from_double (M_LOG10E
);
9707 /* determine floating point precision */
9708 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9710 init_dblprec(&scm_dblprec
[i
-2],i
);
9711 init_fx_radix(fx_per_radix
[i
-2],i
);
9714 /* hard code precision for base 10 if the preprocessor tells us to... */
9715 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9718 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9719 #include "libguile/numbers.x"