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 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
540 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
542 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
544 #define FUNC_NAME s_scm_inexact_p
546 if (SCM_INEXACTP (x
))
548 else if (SCM_NUMBERP (x
))
551 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
556 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
558 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
560 #define FUNC_NAME s_scm_odd_p
564 scm_t_inum val
= SCM_I_INUM (n
);
565 return scm_from_bool ((val
& 1L) != 0);
567 else if (SCM_BIGP (n
))
569 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
570 scm_remember_upto_here_1 (n
);
571 return scm_from_bool (odd_p
);
573 else if (SCM_REALP (n
))
575 double val
= SCM_REAL_VALUE (n
);
576 if (DOUBLE_IS_FINITE (val
))
578 double rem
= fabs (fmod (val
, 2.0));
585 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
590 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
592 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
594 #define FUNC_NAME s_scm_even_p
598 scm_t_inum val
= SCM_I_INUM (n
);
599 return scm_from_bool ((val
& 1L) == 0);
601 else if (SCM_BIGP (n
))
603 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
604 scm_remember_upto_here_1 (n
);
605 return scm_from_bool (even_p
);
607 else if (SCM_REALP (n
))
609 double val
= SCM_REAL_VALUE (n
);
610 if (DOUBLE_IS_FINITE (val
))
612 double rem
= fabs (fmod (val
, 2.0));
619 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
623 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
625 "Return @code{#t} if the real number @var{x} is neither\n"
626 "infinite nor a NaN, @code{#f} otherwise.")
627 #define FUNC_NAME s_scm_finite_p
630 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
631 else if (scm_is_real (x
))
634 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
638 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
640 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
641 "@samp{-inf.0}. Otherwise return @code{#f}.")
642 #define FUNC_NAME s_scm_inf_p
645 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
646 else if (scm_is_real (x
))
649 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
653 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
655 "Return @code{#t} if the real number @var{x} is a NaN,\n"
656 "or @code{#f} otherwise.")
657 #define FUNC_NAME s_scm_nan_p
660 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
661 else if (scm_is_real (x
))
664 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
668 /* Guile's idea of infinity. */
669 static double guile_Inf
;
671 /* Guile's idea of not a number. */
672 static double guile_NaN
;
675 guile_ieee_init (void)
677 /* Some version of gcc on some old version of Linux used to crash when
678 trying to make Inf and NaN. */
681 /* C99 INFINITY, when available.
682 FIXME: The standard allows for INFINITY to be something that overflows
683 at compile time. We ought to have a configure test to check for that
684 before trying to use it. (But in practice we believe this is not a
685 problem on any system guile is likely to target.) */
686 guile_Inf
= INFINITY
;
687 #elif defined HAVE_DINFINITY
689 extern unsigned int DINFINITY
[2];
690 guile_Inf
= (*((double *) (DINFINITY
)));
697 if (guile_Inf
== tmp
)
704 /* C99 NAN, when available */
706 #elif defined HAVE_DQNAN
709 extern unsigned int DQNAN
[2];
710 guile_NaN
= (*((double *)(DQNAN
)));
713 guile_NaN
= guile_Inf
/ guile_Inf
;
717 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
720 #define FUNC_NAME s_scm_inf
722 static int initialized
= 0;
728 return scm_from_double (guile_Inf
);
732 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
735 #define FUNC_NAME s_scm_nan
737 static int initialized
= 0;
743 return scm_from_double (guile_NaN
);
748 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
750 "Return the absolute value of @var{x}.")
751 #define FUNC_NAME s_scm_abs
755 scm_t_inum xx
= SCM_I_INUM (x
);
758 else if (SCM_POSFIXABLE (-xx
))
759 return SCM_I_MAKINUM (-xx
);
761 return scm_i_inum2big (-xx
);
763 else if (SCM_LIKELY (SCM_REALP (x
)))
765 double xx
= SCM_REAL_VALUE (x
);
766 /* If x is a NaN then xx<0 is false so we return x unchanged */
768 return scm_from_double (-xx
);
769 /* Handle signed zeroes properly */
770 else if (SCM_UNLIKELY (xx
== 0.0))
775 else if (SCM_BIGP (x
))
777 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
779 return scm_i_clonebig (x
, 0);
783 else if (SCM_FRACTIONP (x
))
785 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
787 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
788 SCM_FRACTION_DENOMINATOR (x
));
791 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
796 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
798 "Return the quotient of the numbers @var{x} and @var{y}.")
799 #define FUNC_NAME s_scm_quotient
801 if (SCM_LIKELY (scm_is_integer (x
)))
803 if (SCM_LIKELY (scm_is_integer (y
)))
804 return scm_truncate_quotient (x
, y
);
806 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
809 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
813 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
815 "Return the remainder of the numbers @var{x} and @var{y}.\n"
817 "(remainder 13 4) @result{} 1\n"
818 "(remainder -13 4) @result{} -1\n"
820 #define FUNC_NAME s_scm_remainder
822 if (SCM_LIKELY (scm_is_integer (x
)))
824 if (SCM_LIKELY (scm_is_integer (y
)))
825 return scm_truncate_remainder (x
, y
);
827 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
830 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
835 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
837 "Return the modulo of the numbers @var{x} and @var{y}.\n"
839 "(modulo 13 4) @result{} 1\n"
840 "(modulo -13 4) @result{} 3\n"
842 #define FUNC_NAME s_scm_modulo
844 if (SCM_LIKELY (scm_is_integer (x
)))
846 if (SCM_LIKELY (scm_is_integer (y
)))
847 return scm_floor_remainder (x
, y
);
849 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
852 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
856 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
857 two-valued functions. It is called from primitive generics that take
858 two arguments and return two values, when the core procedure is
859 unable to handle the given argument types. If there are GOOPS
860 methods for this primitive generic, it dispatches to GOOPS and, if
861 successful, expects two values to be returned, which are placed in
862 *rp1 and *rp2. If there are no GOOPS methods, it throws a
863 wrong-type-arg exception.
865 FIXME: This obviously belongs somewhere else, but until we decide on
866 the right API, it is here as a static function, because it is needed
867 by the *_divide functions below.
870 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
871 const char *subr
, SCM
*rp1
, SCM
*rp2
)
873 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
875 scm_i_extract_values_2 (vals
, rp1
, rp2
);
878 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
880 "Return the integer @var{q} such that\n"
881 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
882 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
884 "(euclidean-quotient 123 10) @result{} 12\n"
885 "(euclidean-quotient 123 -10) @result{} -12\n"
886 "(euclidean-quotient -123 10) @result{} -13\n"
887 "(euclidean-quotient -123 -10) @result{} 13\n"
888 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
889 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
891 #define FUNC_NAME s_scm_euclidean_quotient
893 if (scm_is_false (scm_negative_p (y
)))
894 return scm_floor_quotient (x
, y
);
896 return scm_ceiling_quotient (x
, y
);
900 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
902 "Return the real number @var{r} such that\n"
903 "@math{0 <= @var{r} < abs(@var{y})} and\n"
904 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
905 "for some integer @var{q}.\n"
907 "(euclidean-remainder 123 10) @result{} 3\n"
908 "(euclidean-remainder 123 -10) @result{} 3\n"
909 "(euclidean-remainder -123 10) @result{} 7\n"
910 "(euclidean-remainder -123 -10) @result{} 7\n"
911 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
912 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
914 #define FUNC_NAME s_scm_euclidean_remainder
916 if (scm_is_false (scm_negative_p (y
)))
917 return scm_floor_remainder (x
, y
);
919 return scm_ceiling_remainder (x
, y
);
923 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
925 "Return the integer @var{q} and the real number @var{r}\n"
926 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
927 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
929 "(euclidean/ 123 10) @result{} 12 and 3\n"
930 "(euclidean/ 123 -10) @result{} -12 and 3\n"
931 "(euclidean/ -123 10) @result{} -13 and 7\n"
932 "(euclidean/ -123 -10) @result{} 13 and 7\n"
933 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
934 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
936 #define FUNC_NAME s_scm_i_euclidean_divide
938 if (scm_is_false (scm_negative_p (y
)))
939 return scm_i_floor_divide (x
, y
);
941 return scm_i_ceiling_divide (x
, y
);
946 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
948 if (scm_is_false (scm_negative_p (y
)))
949 return scm_floor_divide (x
, y
, qp
, rp
);
951 return scm_ceiling_divide (x
, y
, qp
, rp
);
954 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
955 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
957 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
959 "Return the floor of @math{@var{x} / @var{y}}.\n"
961 "(floor-quotient 123 10) @result{} 12\n"
962 "(floor-quotient 123 -10) @result{} -13\n"
963 "(floor-quotient -123 10) @result{} -13\n"
964 "(floor-quotient -123 -10) @result{} 12\n"
965 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
966 "(floor-quotient 16/3 -10/7) @result{} -4\n"
968 #define FUNC_NAME s_scm_floor_quotient
970 if (SCM_LIKELY (SCM_I_INUMP (x
)))
972 scm_t_inum xx
= SCM_I_INUM (x
);
973 if (SCM_LIKELY (SCM_I_INUMP (y
)))
975 scm_t_inum yy
= SCM_I_INUM (y
);
978 if (SCM_LIKELY (yy
> 0))
980 if (SCM_UNLIKELY (xx
< 0))
983 else if (SCM_UNLIKELY (yy
== 0))
984 scm_num_overflow (s_scm_floor_quotient
);
988 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
989 return SCM_I_MAKINUM (qq
);
991 return scm_i_inum2big (qq
);
993 else if (SCM_BIGP (y
))
995 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
996 scm_remember_upto_here_1 (y
);
998 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1000 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1002 else if (SCM_REALP (y
))
1003 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1004 else if (SCM_FRACTIONP (y
))
1005 return scm_i_exact_rational_floor_quotient (x
, y
);
1007 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1008 s_scm_floor_quotient
);
1010 else if (SCM_BIGP (x
))
1012 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1014 scm_t_inum yy
= SCM_I_INUM (y
);
1015 if (SCM_UNLIKELY (yy
== 0))
1016 scm_num_overflow (s_scm_floor_quotient
);
1017 else if (SCM_UNLIKELY (yy
== 1))
1021 SCM q
= scm_i_mkbig ();
1023 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1026 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1027 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1029 scm_remember_upto_here_1 (x
);
1030 return scm_i_normbig (q
);
1033 else if (SCM_BIGP (y
))
1035 SCM q
= scm_i_mkbig ();
1036 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1039 scm_remember_upto_here_2 (x
, y
);
1040 return scm_i_normbig (q
);
1042 else if (SCM_REALP (y
))
1043 return scm_i_inexact_floor_quotient
1044 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1045 else if (SCM_FRACTIONP (y
))
1046 return scm_i_exact_rational_floor_quotient (x
, y
);
1048 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1049 s_scm_floor_quotient
);
1051 else if (SCM_REALP (x
))
1053 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1054 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1055 return scm_i_inexact_floor_quotient
1056 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1058 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1059 s_scm_floor_quotient
);
1061 else if (SCM_FRACTIONP (x
))
1064 return scm_i_inexact_floor_quotient
1065 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1066 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1067 return scm_i_exact_rational_floor_quotient (x
, y
);
1069 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1070 s_scm_floor_quotient
);
1073 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1074 s_scm_floor_quotient
);
1079 scm_i_inexact_floor_quotient (double x
, double y
)
1081 if (SCM_UNLIKELY (y
== 0))
1082 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1084 return scm_from_double (floor (x
/ y
));
1088 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1090 return scm_floor_quotient
1091 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1092 scm_product (scm_numerator (y
), scm_denominator (x
)));
1095 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1096 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1098 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1100 "Return the real number @var{r} such that\n"
1101 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1102 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1104 "(floor-remainder 123 10) @result{} 3\n"
1105 "(floor-remainder 123 -10) @result{} -7\n"
1106 "(floor-remainder -123 10) @result{} 7\n"
1107 "(floor-remainder -123 -10) @result{} -3\n"
1108 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1109 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1111 #define FUNC_NAME s_scm_floor_remainder
1113 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1115 scm_t_inum xx
= SCM_I_INUM (x
);
1116 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1118 scm_t_inum yy
= SCM_I_INUM (y
);
1119 if (SCM_UNLIKELY (yy
== 0))
1120 scm_num_overflow (s_scm_floor_remainder
);
1123 scm_t_inum rr
= xx
% yy
;
1124 int needs_adjustment
;
1126 if (SCM_LIKELY (yy
> 0))
1127 needs_adjustment
= (rr
< 0);
1129 needs_adjustment
= (rr
> 0);
1131 if (needs_adjustment
)
1133 return SCM_I_MAKINUM (rr
);
1136 else if (SCM_BIGP (y
))
1138 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1139 scm_remember_upto_here_1 (y
);
1144 SCM r
= scm_i_mkbig ();
1145 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1146 scm_remember_upto_here_1 (y
);
1147 return scm_i_normbig (r
);
1156 SCM r
= scm_i_mkbig ();
1157 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1158 scm_remember_upto_here_1 (y
);
1159 return scm_i_normbig (r
);
1162 else if (SCM_REALP (y
))
1163 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1164 else if (SCM_FRACTIONP (y
))
1165 return scm_i_exact_rational_floor_remainder (x
, y
);
1167 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1168 s_scm_floor_remainder
);
1170 else if (SCM_BIGP (x
))
1172 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1174 scm_t_inum yy
= SCM_I_INUM (y
);
1175 if (SCM_UNLIKELY (yy
== 0))
1176 scm_num_overflow (s_scm_floor_remainder
);
1181 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1183 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1184 scm_remember_upto_here_1 (x
);
1185 return SCM_I_MAKINUM (rr
);
1188 else if (SCM_BIGP (y
))
1190 SCM r
= scm_i_mkbig ();
1191 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1194 scm_remember_upto_here_2 (x
, y
);
1195 return scm_i_normbig (r
);
1197 else if (SCM_REALP (y
))
1198 return scm_i_inexact_floor_remainder
1199 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1200 else if (SCM_FRACTIONP (y
))
1201 return scm_i_exact_rational_floor_remainder (x
, y
);
1203 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1204 s_scm_floor_remainder
);
1206 else if (SCM_REALP (x
))
1208 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1209 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1210 return scm_i_inexact_floor_remainder
1211 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1213 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1214 s_scm_floor_remainder
);
1216 else if (SCM_FRACTIONP (x
))
1219 return scm_i_inexact_floor_remainder
1220 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1221 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1222 return scm_i_exact_rational_floor_remainder (x
, y
);
1224 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1225 s_scm_floor_remainder
);
1228 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1229 s_scm_floor_remainder
);
1234 scm_i_inexact_floor_remainder (double x
, double y
)
1236 /* Although it would be more efficient to use fmod here, we can't
1237 because it would in some cases produce results inconsistent with
1238 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1239 close). In particular, when x is very close to a multiple of y,
1240 then r might be either 0.0 or y, but those two cases must
1241 correspond to different choices of q. If r = 0.0 then q must be
1242 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1243 and remainder chooses the other, it would be bad. */
1244 if (SCM_UNLIKELY (y
== 0))
1245 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1247 return scm_from_double (x
- y
* floor (x
/ y
));
1251 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1253 SCM xd
= scm_denominator (x
);
1254 SCM yd
= scm_denominator (y
);
1255 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1256 scm_product (scm_numerator (y
), xd
));
1257 return scm_divide (r1
, scm_product (xd
, yd
));
1261 static void scm_i_inexact_floor_divide (double x
, double y
,
1263 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1266 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1268 "Return the integer @var{q} and the real number @var{r}\n"
1269 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1270 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1272 "(floor/ 123 10) @result{} 12 and 3\n"
1273 "(floor/ 123 -10) @result{} -13 and -7\n"
1274 "(floor/ -123 10) @result{} -13 and 7\n"
1275 "(floor/ -123 -10) @result{} 12 and -3\n"
1276 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1277 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1279 #define FUNC_NAME s_scm_i_floor_divide
1283 scm_floor_divide(x
, y
, &q
, &r
);
1284 return scm_values (scm_list_2 (q
, r
));
1288 #define s_scm_floor_divide s_scm_i_floor_divide
1289 #define g_scm_floor_divide g_scm_i_floor_divide
1292 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1294 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1296 scm_t_inum xx
= SCM_I_INUM (x
);
1297 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1299 scm_t_inum yy
= SCM_I_INUM (y
);
1300 if (SCM_UNLIKELY (yy
== 0))
1301 scm_num_overflow (s_scm_floor_divide
);
1304 scm_t_inum qq
= xx
/ yy
;
1305 scm_t_inum rr
= xx
% yy
;
1306 int needs_adjustment
;
1308 if (SCM_LIKELY (yy
> 0))
1309 needs_adjustment
= (rr
< 0);
1311 needs_adjustment
= (rr
> 0);
1313 if (needs_adjustment
)
1319 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1320 *qp
= SCM_I_MAKINUM (qq
);
1322 *qp
= scm_i_inum2big (qq
);
1323 *rp
= SCM_I_MAKINUM (rr
);
1327 else if (SCM_BIGP (y
))
1329 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1330 scm_remember_upto_here_1 (y
);
1335 SCM r
= scm_i_mkbig ();
1336 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1337 scm_remember_upto_here_1 (y
);
1338 *qp
= SCM_I_MAKINUM (-1);
1339 *rp
= scm_i_normbig (r
);
1354 SCM r
= scm_i_mkbig ();
1355 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1356 scm_remember_upto_here_1 (y
);
1357 *qp
= SCM_I_MAKINUM (-1);
1358 *rp
= scm_i_normbig (r
);
1362 else if (SCM_REALP (y
))
1363 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1364 else if (SCM_FRACTIONP (y
))
1365 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1367 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1368 s_scm_floor_divide
, qp
, rp
);
1370 else if (SCM_BIGP (x
))
1372 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1374 scm_t_inum yy
= SCM_I_INUM (y
);
1375 if (SCM_UNLIKELY (yy
== 0))
1376 scm_num_overflow (s_scm_floor_divide
);
1379 SCM q
= scm_i_mkbig ();
1380 SCM r
= scm_i_mkbig ();
1382 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1383 SCM_I_BIG_MPZ (x
), yy
);
1386 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1387 SCM_I_BIG_MPZ (x
), -yy
);
1388 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1390 scm_remember_upto_here_1 (x
);
1391 *qp
= scm_i_normbig (q
);
1392 *rp
= scm_i_normbig (r
);
1396 else if (SCM_BIGP (y
))
1398 SCM q
= scm_i_mkbig ();
1399 SCM r
= scm_i_mkbig ();
1400 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1401 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1402 scm_remember_upto_here_2 (x
, y
);
1403 *qp
= scm_i_normbig (q
);
1404 *rp
= scm_i_normbig (r
);
1407 else if (SCM_REALP (y
))
1408 return scm_i_inexact_floor_divide
1409 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1410 else if (SCM_FRACTIONP (y
))
1411 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1413 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1414 s_scm_floor_divide
, qp
, rp
);
1416 else if (SCM_REALP (x
))
1418 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1419 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1420 return scm_i_inexact_floor_divide
1421 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1423 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1424 s_scm_floor_divide
, qp
, rp
);
1426 else if (SCM_FRACTIONP (x
))
1429 return scm_i_inexact_floor_divide
1430 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1431 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1432 return scm_i_exact_rational_floor_divide (x
, 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
);
1438 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1439 s_scm_floor_divide
, qp
, rp
);
1443 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1445 if (SCM_UNLIKELY (y
== 0))
1446 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1449 double q
= floor (x
/ y
);
1450 double r
= x
- q
* y
;
1451 *qp
= scm_from_double (q
);
1452 *rp
= scm_from_double (r
);
1457 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1460 SCM xd
= scm_denominator (x
);
1461 SCM yd
= scm_denominator (y
);
1463 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1464 scm_product (scm_numerator (y
), xd
),
1466 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1469 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1470 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1472 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1474 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1476 "(ceiling-quotient 123 10) @result{} 13\n"
1477 "(ceiling-quotient 123 -10) @result{} -12\n"
1478 "(ceiling-quotient -123 10) @result{} -12\n"
1479 "(ceiling-quotient -123 -10) @result{} 13\n"
1480 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1481 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1483 #define FUNC_NAME s_scm_ceiling_quotient
1485 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1487 scm_t_inum xx
= SCM_I_INUM (x
);
1488 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1490 scm_t_inum yy
= SCM_I_INUM (y
);
1491 if (SCM_UNLIKELY (yy
== 0))
1492 scm_num_overflow (s_scm_ceiling_quotient
);
1495 scm_t_inum xx1
= xx
;
1497 if (SCM_LIKELY (yy
> 0))
1499 if (SCM_LIKELY (xx
>= 0))
1502 else if (SCM_UNLIKELY (yy
== 0))
1503 scm_num_overflow (s_scm_ceiling_quotient
);
1507 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1508 return SCM_I_MAKINUM (qq
);
1510 return scm_i_inum2big (qq
);
1513 else if (SCM_BIGP (y
))
1515 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1516 scm_remember_upto_here_1 (y
);
1517 if (SCM_LIKELY (sign
> 0))
1519 if (SCM_LIKELY (xx
> 0))
1521 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1522 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1523 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1525 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1526 scm_remember_upto_here_1 (y
);
1527 return SCM_I_MAKINUM (-1);
1537 else if (SCM_REALP (y
))
1538 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1539 else if (SCM_FRACTIONP (y
))
1540 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1542 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1543 s_scm_ceiling_quotient
);
1545 else if (SCM_BIGP (x
))
1547 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1549 scm_t_inum yy
= SCM_I_INUM (y
);
1550 if (SCM_UNLIKELY (yy
== 0))
1551 scm_num_overflow (s_scm_ceiling_quotient
);
1552 else if (SCM_UNLIKELY (yy
== 1))
1556 SCM q
= scm_i_mkbig ();
1558 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1561 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1562 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1564 scm_remember_upto_here_1 (x
);
1565 return scm_i_normbig (q
);
1568 else if (SCM_BIGP (y
))
1570 SCM q
= scm_i_mkbig ();
1571 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1574 scm_remember_upto_here_2 (x
, y
);
1575 return scm_i_normbig (q
);
1577 else if (SCM_REALP (y
))
1578 return scm_i_inexact_ceiling_quotient
1579 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1580 else if (SCM_FRACTIONP (y
))
1581 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1583 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1584 s_scm_ceiling_quotient
);
1586 else if (SCM_REALP (x
))
1588 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1589 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1590 return scm_i_inexact_ceiling_quotient
1591 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1593 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1594 s_scm_ceiling_quotient
);
1596 else if (SCM_FRACTIONP (x
))
1599 return scm_i_inexact_ceiling_quotient
1600 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1601 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1602 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1604 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1605 s_scm_ceiling_quotient
);
1608 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1609 s_scm_ceiling_quotient
);
1614 scm_i_inexact_ceiling_quotient (double x
, double y
)
1616 if (SCM_UNLIKELY (y
== 0))
1617 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1619 return scm_from_double (ceil (x
/ y
));
1623 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1625 return scm_ceiling_quotient
1626 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1627 scm_product (scm_numerator (y
), scm_denominator (x
)));
1630 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1631 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1633 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1635 "Return the real number @var{r} such that\n"
1636 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1637 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1639 "(ceiling-remainder 123 10) @result{} -7\n"
1640 "(ceiling-remainder 123 -10) @result{} 3\n"
1641 "(ceiling-remainder -123 10) @result{} -3\n"
1642 "(ceiling-remainder -123 -10) @result{} 7\n"
1643 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1644 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1646 #define FUNC_NAME s_scm_ceiling_remainder
1648 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1650 scm_t_inum xx
= SCM_I_INUM (x
);
1651 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1653 scm_t_inum yy
= SCM_I_INUM (y
);
1654 if (SCM_UNLIKELY (yy
== 0))
1655 scm_num_overflow (s_scm_ceiling_remainder
);
1658 scm_t_inum rr
= xx
% yy
;
1659 int needs_adjustment
;
1661 if (SCM_LIKELY (yy
> 0))
1662 needs_adjustment
= (rr
> 0);
1664 needs_adjustment
= (rr
< 0);
1666 if (needs_adjustment
)
1668 return SCM_I_MAKINUM (rr
);
1671 else if (SCM_BIGP (y
))
1673 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1674 scm_remember_upto_here_1 (y
);
1675 if (SCM_LIKELY (sign
> 0))
1677 if (SCM_LIKELY (xx
> 0))
1679 SCM r
= scm_i_mkbig ();
1680 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1681 scm_remember_upto_here_1 (y
);
1682 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1683 return scm_i_normbig (r
);
1685 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1686 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1687 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1689 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1690 scm_remember_upto_here_1 (y
);
1700 SCM r
= scm_i_mkbig ();
1701 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1702 scm_remember_upto_here_1 (y
);
1703 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1704 return scm_i_normbig (r
);
1707 else if (SCM_REALP (y
))
1708 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1709 else if (SCM_FRACTIONP (y
))
1710 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1712 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1713 s_scm_ceiling_remainder
);
1715 else if (SCM_BIGP (x
))
1717 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1719 scm_t_inum yy
= SCM_I_INUM (y
);
1720 if (SCM_UNLIKELY (yy
== 0))
1721 scm_num_overflow (s_scm_ceiling_remainder
);
1726 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1728 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1729 scm_remember_upto_here_1 (x
);
1730 return SCM_I_MAKINUM (rr
);
1733 else if (SCM_BIGP (y
))
1735 SCM r
= scm_i_mkbig ();
1736 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1739 scm_remember_upto_here_2 (x
, y
);
1740 return scm_i_normbig (r
);
1742 else if (SCM_REALP (y
))
1743 return scm_i_inexact_ceiling_remainder
1744 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1745 else if (SCM_FRACTIONP (y
))
1746 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1748 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1749 s_scm_ceiling_remainder
);
1751 else if (SCM_REALP (x
))
1753 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1754 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1755 return scm_i_inexact_ceiling_remainder
1756 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1758 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1759 s_scm_ceiling_remainder
);
1761 else if (SCM_FRACTIONP (x
))
1764 return scm_i_inexact_ceiling_remainder
1765 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1766 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1767 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1769 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1770 s_scm_ceiling_remainder
);
1773 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1774 s_scm_ceiling_remainder
);
1779 scm_i_inexact_ceiling_remainder (double x
, double y
)
1781 /* Although it would be more efficient to use fmod here, we can't
1782 because it would in some cases produce results inconsistent with
1783 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1784 close). In particular, when x is very close to a multiple of y,
1785 then r might be either 0.0 or -y, but those two cases must
1786 correspond to different choices of q. If r = 0.0 then q must be
1787 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1788 and remainder chooses the other, it would be bad. */
1789 if (SCM_UNLIKELY (y
== 0))
1790 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1792 return scm_from_double (x
- y
* ceil (x
/ y
));
1796 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1798 SCM xd
= scm_denominator (x
);
1799 SCM yd
= scm_denominator (y
);
1800 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1801 scm_product (scm_numerator (y
), xd
));
1802 return scm_divide (r1
, scm_product (xd
, yd
));
1805 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1807 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1810 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1812 "Return the integer @var{q} and the real number @var{r}\n"
1813 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1814 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1816 "(ceiling/ 123 10) @result{} 13 and -7\n"
1817 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1818 "(ceiling/ -123 10) @result{} -12 and -3\n"
1819 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1820 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1821 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1823 #define FUNC_NAME s_scm_i_ceiling_divide
1827 scm_ceiling_divide(x
, y
, &q
, &r
);
1828 return scm_values (scm_list_2 (q
, r
));
1832 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1833 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1836 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1838 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1840 scm_t_inum xx
= SCM_I_INUM (x
);
1841 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1843 scm_t_inum yy
= SCM_I_INUM (y
);
1844 if (SCM_UNLIKELY (yy
== 0))
1845 scm_num_overflow (s_scm_ceiling_divide
);
1848 scm_t_inum qq
= xx
/ yy
;
1849 scm_t_inum rr
= xx
% yy
;
1850 int needs_adjustment
;
1852 if (SCM_LIKELY (yy
> 0))
1853 needs_adjustment
= (rr
> 0);
1855 needs_adjustment
= (rr
< 0);
1857 if (needs_adjustment
)
1862 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1863 *qp
= SCM_I_MAKINUM (qq
);
1865 *qp
= scm_i_inum2big (qq
);
1866 *rp
= SCM_I_MAKINUM (rr
);
1870 else if (SCM_BIGP (y
))
1872 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1873 scm_remember_upto_here_1 (y
);
1874 if (SCM_LIKELY (sign
> 0))
1876 if (SCM_LIKELY (xx
> 0))
1878 SCM r
= scm_i_mkbig ();
1879 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1880 scm_remember_upto_here_1 (y
);
1881 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1883 *rp
= scm_i_normbig (r
);
1885 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1886 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1887 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1889 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1890 scm_remember_upto_here_1 (y
);
1891 *qp
= SCM_I_MAKINUM (-1);
1907 SCM r
= scm_i_mkbig ();
1908 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1909 scm_remember_upto_here_1 (y
);
1910 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1912 *rp
= scm_i_normbig (r
);
1916 else if (SCM_REALP (y
))
1917 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1918 else if (SCM_FRACTIONP (y
))
1919 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1921 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1922 s_scm_ceiling_divide
, qp
, rp
);
1924 else if (SCM_BIGP (x
))
1926 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1928 scm_t_inum yy
= SCM_I_INUM (y
);
1929 if (SCM_UNLIKELY (yy
== 0))
1930 scm_num_overflow (s_scm_ceiling_divide
);
1933 SCM q
= scm_i_mkbig ();
1934 SCM r
= scm_i_mkbig ();
1936 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1937 SCM_I_BIG_MPZ (x
), yy
);
1940 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1941 SCM_I_BIG_MPZ (x
), -yy
);
1942 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1944 scm_remember_upto_here_1 (x
);
1945 *qp
= scm_i_normbig (q
);
1946 *rp
= scm_i_normbig (r
);
1950 else if (SCM_BIGP (y
))
1952 SCM q
= scm_i_mkbig ();
1953 SCM r
= scm_i_mkbig ();
1954 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1955 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1956 scm_remember_upto_here_2 (x
, y
);
1957 *qp
= scm_i_normbig (q
);
1958 *rp
= scm_i_normbig (r
);
1961 else if (SCM_REALP (y
))
1962 return scm_i_inexact_ceiling_divide
1963 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1964 else if (SCM_FRACTIONP (y
))
1965 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1967 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1968 s_scm_ceiling_divide
, qp
, rp
);
1970 else if (SCM_REALP (x
))
1972 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1973 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1974 return scm_i_inexact_ceiling_divide
1975 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1977 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1978 s_scm_ceiling_divide
, qp
, rp
);
1980 else if (SCM_FRACTIONP (x
))
1983 return scm_i_inexact_ceiling_divide
1984 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1985 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1986 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1988 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1989 s_scm_ceiling_divide
, qp
, rp
);
1992 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
1993 s_scm_ceiling_divide
, qp
, rp
);
1997 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1999 if (SCM_UNLIKELY (y
== 0))
2000 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2003 double q
= ceil (x
/ y
);
2004 double r
= x
- q
* y
;
2005 *qp
= scm_from_double (q
);
2006 *rp
= scm_from_double (r
);
2011 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2014 SCM xd
= scm_denominator (x
);
2015 SCM yd
= scm_denominator (y
);
2017 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2018 scm_product (scm_numerator (y
), xd
),
2020 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2023 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2024 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2026 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2028 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2030 "(truncate-quotient 123 10) @result{} 12\n"
2031 "(truncate-quotient 123 -10) @result{} -12\n"
2032 "(truncate-quotient -123 10) @result{} -12\n"
2033 "(truncate-quotient -123 -10) @result{} 12\n"
2034 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2035 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2037 #define FUNC_NAME s_scm_truncate_quotient
2039 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2041 scm_t_inum xx
= SCM_I_INUM (x
);
2042 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2044 scm_t_inum yy
= SCM_I_INUM (y
);
2045 if (SCM_UNLIKELY (yy
== 0))
2046 scm_num_overflow (s_scm_truncate_quotient
);
2049 scm_t_inum qq
= xx
/ yy
;
2050 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2051 return SCM_I_MAKINUM (qq
);
2053 return scm_i_inum2big (qq
);
2056 else if (SCM_BIGP (y
))
2058 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2059 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2060 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2062 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2063 scm_remember_upto_here_1 (y
);
2064 return SCM_I_MAKINUM (-1);
2069 else if (SCM_REALP (y
))
2070 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2071 else if (SCM_FRACTIONP (y
))
2072 return scm_i_exact_rational_truncate_quotient (x
, y
);
2074 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2075 s_scm_truncate_quotient
);
2077 else if (SCM_BIGP (x
))
2079 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2081 scm_t_inum yy
= SCM_I_INUM (y
);
2082 if (SCM_UNLIKELY (yy
== 0))
2083 scm_num_overflow (s_scm_truncate_quotient
);
2084 else if (SCM_UNLIKELY (yy
== 1))
2088 SCM q
= scm_i_mkbig ();
2090 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2093 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2094 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2096 scm_remember_upto_here_1 (x
);
2097 return scm_i_normbig (q
);
2100 else if (SCM_BIGP (y
))
2102 SCM q
= scm_i_mkbig ();
2103 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2106 scm_remember_upto_here_2 (x
, y
);
2107 return scm_i_normbig (q
);
2109 else if (SCM_REALP (y
))
2110 return scm_i_inexact_truncate_quotient
2111 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2112 else if (SCM_FRACTIONP (y
))
2113 return scm_i_exact_rational_truncate_quotient (x
, y
);
2115 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2116 s_scm_truncate_quotient
);
2118 else if (SCM_REALP (x
))
2120 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2121 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2122 return scm_i_inexact_truncate_quotient
2123 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2125 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2126 s_scm_truncate_quotient
);
2128 else if (SCM_FRACTIONP (x
))
2131 return scm_i_inexact_truncate_quotient
2132 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2133 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2134 return scm_i_exact_rational_truncate_quotient (x
, y
);
2136 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2137 s_scm_truncate_quotient
);
2140 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2141 s_scm_truncate_quotient
);
2146 scm_i_inexact_truncate_quotient (double x
, double y
)
2148 if (SCM_UNLIKELY (y
== 0))
2149 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2151 return scm_from_double (trunc (x
/ y
));
2155 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2157 return scm_truncate_quotient
2158 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2159 scm_product (scm_numerator (y
), scm_denominator (x
)));
2162 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2163 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2165 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2167 "Return the real number @var{r} such that\n"
2168 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2169 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2171 "(truncate-remainder 123 10) @result{} 3\n"
2172 "(truncate-remainder 123 -10) @result{} 3\n"
2173 "(truncate-remainder -123 10) @result{} -3\n"
2174 "(truncate-remainder -123 -10) @result{} -3\n"
2175 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2176 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2178 #define FUNC_NAME s_scm_truncate_remainder
2180 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2182 scm_t_inum xx
= SCM_I_INUM (x
);
2183 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2185 scm_t_inum yy
= SCM_I_INUM (y
);
2186 if (SCM_UNLIKELY (yy
== 0))
2187 scm_num_overflow (s_scm_truncate_remainder
);
2189 return SCM_I_MAKINUM (xx
% yy
);
2191 else if (SCM_BIGP (y
))
2193 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2194 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2195 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2197 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2198 scm_remember_upto_here_1 (y
);
2204 else if (SCM_REALP (y
))
2205 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2206 else if (SCM_FRACTIONP (y
))
2207 return scm_i_exact_rational_truncate_remainder (x
, y
);
2209 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2210 s_scm_truncate_remainder
);
2212 else if (SCM_BIGP (x
))
2214 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2216 scm_t_inum yy
= SCM_I_INUM (y
);
2217 if (SCM_UNLIKELY (yy
== 0))
2218 scm_num_overflow (s_scm_truncate_remainder
);
2221 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2222 (yy
> 0) ? yy
: -yy
)
2223 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2224 scm_remember_upto_here_1 (x
);
2225 return SCM_I_MAKINUM (rr
);
2228 else if (SCM_BIGP (y
))
2230 SCM r
= scm_i_mkbig ();
2231 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2234 scm_remember_upto_here_2 (x
, y
);
2235 return scm_i_normbig (r
);
2237 else if (SCM_REALP (y
))
2238 return scm_i_inexact_truncate_remainder
2239 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2240 else if (SCM_FRACTIONP (y
))
2241 return scm_i_exact_rational_truncate_remainder (x
, y
);
2243 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2244 s_scm_truncate_remainder
);
2246 else if (SCM_REALP (x
))
2248 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2249 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2250 return scm_i_inexact_truncate_remainder
2251 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2253 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2254 s_scm_truncate_remainder
);
2256 else if (SCM_FRACTIONP (x
))
2259 return scm_i_inexact_truncate_remainder
2260 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2261 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2262 return scm_i_exact_rational_truncate_remainder (x
, y
);
2264 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2265 s_scm_truncate_remainder
);
2268 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2269 s_scm_truncate_remainder
);
2274 scm_i_inexact_truncate_remainder (double x
, double y
)
2276 /* Although it would be more efficient to use fmod here, we can't
2277 because it would in some cases produce results inconsistent with
2278 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2279 close). In particular, when x is very close to a multiple of y,
2280 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2281 correspond to different choices of q. If quotient chooses one and
2282 remainder chooses the other, it would be bad. */
2283 if (SCM_UNLIKELY (y
== 0))
2284 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2286 return scm_from_double (x
- y
* trunc (x
/ y
));
2290 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2292 SCM xd
= scm_denominator (x
);
2293 SCM yd
= scm_denominator (y
);
2294 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2295 scm_product (scm_numerator (y
), xd
));
2296 return scm_divide (r1
, scm_product (xd
, yd
));
2300 static void scm_i_inexact_truncate_divide (double x
, double y
,
2302 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2305 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2307 "Return the integer @var{q} and the real number @var{r}\n"
2308 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2309 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2311 "(truncate/ 123 10) @result{} 12 and 3\n"
2312 "(truncate/ 123 -10) @result{} -12 and 3\n"
2313 "(truncate/ -123 10) @result{} -12 and -3\n"
2314 "(truncate/ -123 -10) @result{} 12 and -3\n"
2315 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2316 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2318 #define FUNC_NAME s_scm_i_truncate_divide
2322 scm_truncate_divide(x
, y
, &q
, &r
);
2323 return scm_values (scm_list_2 (q
, r
));
2327 #define s_scm_truncate_divide s_scm_i_truncate_divide
2328 #define g_scm_truncate_divide g_scm_i_truncate_divide
2331 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2333 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2335 scm_t_inum xx
= SCM_I_INUM (x
);
2336 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2338 scm_t_inum yy
= SCM_I_INUM (y
);
2339 if (SCM_UNLIKELY (yy
== 0))
2340 scm_num_overflow (s_scm_truncate_divide
);
2343 scm_t_inum qq
= xx
/ yy
;
2344 scm_t_inum rr
= xx
% yy
;
2345 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2346 *qp
= SCM_I_MAKINUM (qq
);
2348 *qp
= scm_i_inum2big (qq
);
2349 *rp
= SCM_I_MAKINUM (rr
);
2353 else if (SCM_BIGP (y
))
2355 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2356 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2357 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2359 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2360 scm_remember_upto_here_1 (y
);
2361 *qp
= SCM_I_MAKINUM (-1);
2371 else if (SCM_REALP (y
))
2372 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2373 else if (SCM_FRACTIONP (y
))
2374 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2376 return two_valued_wta_dispatch_2
2377 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2378 s_scm_truncate_divide
, qp
, rp
);
2380 else if (SCM_BIGP (x
))
2382 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2384 scm_t_inum yy
= SCM_I_INUM (y
);
2385 if (SCM_UNLIKELY (yy
== 0))
2386 scm_num_overflow (s_scm_truncate_divide
);
2389 SCM q
= scm_i_mkbig ();
2392 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2393 SCM_I_BIG_MPZ (x
), yy
);
2396 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2397 SCM_I_BIG_MPZ (x
), -yy
);
2398 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2400 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2401 scm_remember_upto_here_1 (x
);
2402 *qp
= scm_i_normbig (q
);
2403 *rp
= SCM_I_MAKINUM (rr
);
2407 else if (SCM_BIGP (y
))
2409 SCM q
= scm_i_mkbig ();
2410 SCM r
= scm_i_mkbig ();
2411 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2412 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2413 scm_remember_upto_here_2 (x
, y
);
2414 *qp
= scm_i_normbig (q
);
2415 *rp
= scm_i_normbig (r
);
2417 else if (SCM_REALP (y
))
2418 return scm_i_inexact_truncate_divide
2419 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2420 else if (SCM_FRACTIONP (y
))
2421 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2423 return two_valued_wta_dispatch_2
2424 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2425 s_scm_truncate_divide
, qp
, rp
);
2427 else if (SCM_REALP (x
))
2429 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2430 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2431 return scm_i_inexact_truncate_divide
2432 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2434 return two_valued_wta_dispatch_2
2435 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2436 s_scm_truncate_divide
, qp
, rp
);
2438 else if (SCM_FRACTIONP (x
))
2441 return scm_i_inexact_truncate_divide
2442 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2443 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2444 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2446 return two_valued_wta_dispatch_2
2447 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2448 s_scm_truncate_divide
, qp
, rp
);
2451 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2452 s_scm_truncate_divide
, qp
, rp
);
2456 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2458 if (SCM_UNLIKELY (y
== 0))
2459 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2462 double q
= trunc (x
/ y
);
2463 double r
= x
- q
* y
;
2464 *qp
= scm_from_double (q
);
2465 *rp
= scm_from_double (r
);
2470 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2473 SCM xd
= scm_denominator (x
);
2474 SCM yd
= scm_denominator (y
);
2476 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2477 scm_product (scm_numerator (y
), xd
),
2479 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2482 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2483 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2484 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2486 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2488 "Return the integer @var{q} such that\n"
2489 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2490 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2492 "(centered-quotient 123 10) @result{} 12\n"
2493 "(centered-quotient 123 -10) @result{} -12\n"
2494 "(centered-quotient -123 10) @result{} -12\n"
2495 "(centered-quotient -123 -10) @result{} 12\n"
2496 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2497 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2499 #define FUNC_NAME s_scm_centered_quotient
2501 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2503 scm_t_inum xx
= SCM_I_INUM (x
);
2504 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2506 scm_t_inum yy
= SCM_I_INUM (y
);
2507 if (SCM_UNLIKELY (yy
== 0))
2508 scm_num_overflow (s_scm_centered_quotient
);
2511 scm_t_inum qq
= xx
/ yy
;
2512 scm_t_inum rr
= xx
% yy
;
2513 if (SCM_LIKELY (xx
> 0))
2515 if (SCM_LIKELY (yy
> 0))
2517 if (rr
>= (yy
+ 1) / 2)
2522 if (rr
>= (1 - yy
) / 2)
2528 if (SCM_LIKELY (yy
> 0))
2539 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2540 return SCM_I_MAKINUM (qq
);
2542 return scm_i_inum2big (qq
);
2545 else if (SCM_BIGP (y
))
2547 /* Pass a denormalized bignum version of x (even though it
2548 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2549 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2551 else if (SCM_REALP (y
))
2552 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2553 else if (SCM_FRACTIONP (y
))
2554 return scm_i_exact_rational_centered_quotient (x
, y
);
2556 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2557 s_scm_centered_quotient
);
2559 else if (SCM_BIGP (x
))
2561 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2563 scm_t_inum yy
= SCM_I_INUM (y
);
2564 if (SCM_UNLIKELY (yy
== 0))
2565 scm_num_overflow (s_scm_centered_quotient
);
2566 else if (SCM_UNLIKELY (yy
== 1))
2570 SCM q
= scm_i_mkbig ();
2572 /* Arrange for rr to initially be non-positive,
2573 because that simplifies the test to see
2574 if it is within the needed bounds. */
2577 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2578 SCM_I_BIG_MPZ (x
), yy
);
2579 scm_remember_upto_here_1 (x
);
2581 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2582 SCM_I_BIG_MPZ (q
), 1);
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
);
2589 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2591 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2592 SCM_I_BIG_MPZ (q
), 1);
2594 return scm_i_normbig (q
);
2597 else if (SCM_BIGP (y
))
2598 return scm_i_bigint_centered_quotient (x
, y
);
2599 else if (SCM_REALP (y
))
2600 return scm_i_inexact_centered_quotient
2601 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2602 else if (SCM_FRACTIONP (y
))
2603 return scm_i_exact_rational_centered_quotient (x
, y
);
2605 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2606 s_scm_centered_quotient
);
2608 else if (SCM_REALP (x
))
2610 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2611 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2612 return scm_i_inexact_centered_quotient
2613 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2615 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2616 s_scm_centered_quotient
);
2618 else if (SCM_FRACTIONP (x
))
2621 return scm_i_inexact_centered_quotient
2622 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2623 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2624 return scm_i_exact_rational_centered_quotient (x
, y
);
2626 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2627 s_scm_centered_quotient
);
2630 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2631 s_scm_centered_quotient
);
2636 scm_i_inexact_centered_quotient (double x
, double y
)
2638 if (SCM_LIKELY (y
> 0))
2639 return scm_from_double (floor (x
/y
+ 0.5));
2640 else if (SCM_LIKELY (y
< 0))
2641 return scm_from_double (ceil (x
/y
- 0.5));
2643 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2648 /* Assumes that both x and y are bigints, though
2649 x might be able to fit into a fixnum. */
2651 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2655 /* Note that x might be small enough to fit into a
2656 fixnum, so we must not let it escape into the wild */
2660 /* min_r will eventually become -abs(y)/2 */
2661 min_r
= scm_i_mkbig ();
2662 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2663 SCM_I_BIG_MPZ (y
), 1);
2665 /* Arrange for rr to initially be non-positive,
2666 because that simplifies the test to see
2667 if it is within the needed bounds. */
2668 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2670 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2671 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2672 scm_remember_upto_here_2 (x
, y
);
2673 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2674 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2675 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2676 SCM_I_BIG_MPZ (q
), 1);
2680 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2681 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2682 scm_remember_upto_here_2 (x
, y
);
2683 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2684 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2685 SCM_I_BIG_MPZ (q
), 1);
2687 scm_remember_upto_here_2 (r
, min_r
);
2688 return scm_i_normbig (q
);
2692 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2694 return scm_centered_quotient
2695 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2696 scm_product (scm_numerator (y
), scm_denominator (x
)));
2699 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2700 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2701 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2703 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2705 "Return the real number @var{r} such that\n"
2706 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2707 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2708 "for some integer @var{q}.\n"
2710 "(centered-remainder 123 10) @result{} 3\n"
2711 "(centered-remainder 123 -10) @result{} 3\n"
2712 "(centered-remainder -123 10) @result{} -3\n"
2713 "(centered-remainder -123 -10) @result{} -3\n"
2714 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2715 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2717 #define FUNC_NAME s_scm_centered_remainder
2719 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2721 scm_t_inum xx
= SCM_I_INUM (x
);
2722 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2724 scm_t_inum yy
= SCM_I_INUM (y
);
2725 if (SCM_UNLIKELY (yy
== 0))
2726 scm_num_overflow (s_scm_centered_remainder
);
2729 scm_t_inum rr
= xx
% yy
;
2730 if (SCM_LIKELY (xx
> 0))
2732 if (SCM_LIKELY (yy
> 0))
2734 if (rr
>= (yy
+ 1) / 2)
2739 if (rr
>= (1 - yy
) / 2)
2745 if (SCM_LIKELY (yy
> 0))
2756 return SCM_I_MAKINUM (rr
);
2759 else if (SCM_BIGP (y
))
2761 /* Pass a denormalized bignum version of x (even though it
2762 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2763 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2765 else if (SCM_REALP (y
))
2766 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2767 else if (SCM_FRACTIONP (y
))
2768 return scm_i_exact_rational_centered_remainder (x
, y
);
2770 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2771 s_scm_centered_remainder
);
2773 else if (SCM_BIGP (x
))
2775 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2777 scm_t_inum yy
= SCM_I_INUM (y
);
2778 if (SCM_UNLIKELY (yy
== 0))
2779 scm_num_overflow (s_scm_centered_remainder
);
2783 /* Arrange for rr to initially be non-positive,
2784 because that simplifies the test to see
2785 if it is within the needed bounds. */
2788 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2789 scm_remember_upto_here_1 (x
);
2795 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2796 scm_remember_upto_here_1 (x
);
2800 return SCM_I_MAKINUM (rr
);
2803 else if (SCM_BIGP (y
))
2804 return scm_i_bigint_centered_remainder (x
, y
);
2805 else if (SCM_REALP (y
))
2806 return scm_i_inexact_centered_remainder
2807 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2808 else if (SCM_FRACTIONP (y
))
2809 return scm_i_exact_rational_centered_remainder (x
, y
);
2811 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2812 s_scm_centered_remainder
);
2814 else if (SCM_REALP (x
))
2816 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2817 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2818 return scm_i_inexact_centered_remainder
2819 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2821 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2822 s_scm_centered_remainder
);
2824 else if (SCM_FRACTIONP (x
))
2827 return scm_i_inexact_centered_remainder
2828 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2829 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2830 return scm_i_exact_rational_centered_remainder (x
, y
);
2832 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2833 s_scm_centered_remainder
);
2836 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2837 s_scm_centered_remainder
);
2842 scm_i_inexact_centered_remainder (double x
, double y
)
2846 /* Although it would be more efficient to use fmod here, we can't
2847 because it would in some cases produce results inconsistent with
2848 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2849 close). In particular, when x-y/2 is very close to a multiple of
2850 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2851 two cases must correspond to different choices of q. If quotient
2852 chooses one and remainder chooses the other, it would be bad. */
2853 if (SCM_LIKELY (y
> 0))
2854 q
= floor (x
/y
+ 0.5);
2855 else if (SCM_LIKELY (y
< 0))
2856 q
= ceil (x
/y
- 0.5);
2858 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2861 return scm_from_double (x
- q
* y
);
2864 /* Assumes that both x and y are bigints, though
2865 x might be able to fit into a fixnum. */
2867 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2871 /* Note that x might be small enough to fit into a
2872 fixnum, so we must not let it escape into the wild */
2875 /* min_r will eventually become -abs(y)/2 */
2876 min_r
= scm_i_mkbig ();
2877 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2878 SCM_I_BIG_MPZ (y
), 1);
2880 /* Arrange for rr to initially be non-positive,
2881 because that simplifies the test to see
2882 if it is within the needed bounds. */
2883 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2885 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2886 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2887 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2888 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2889 mpz_add (SCM_I_BIG_MPZ (r
),
2895 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2896 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2897 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2898 mpz_sub (SCM_I_BIG_MPZ (r
),
2902 scm_remember_upto_here_2 (x
, y
);
2903 return scm_i_normbig (r
);
2907 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2909 SCM xd
= scm_denominator (x
);
2910 SCM yd
= scm_denominator (y
);
2911 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2912 scm_product (scm_numerator (y
), xd
));
2913 return scm_divide (r1
, scm_product (xd
, yd
));
2917 static void scm_i_inexact_centered_divide (double x
, double y
,
2919 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2920 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2923 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2925 "Return the integer @var{q} and the real number @var{r}\n"
2926 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2927 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2929 "(centered/ 123 10) @result{} 12 and 3\n"
2930 "(centered/ 123 -10) @result{} -12 and 3\n"
2931 "(centered/ -123 10) @result{} -12 and -3\n"
2932 "(centered/ -123 -10) @result{} 12 and -3\n"
2933 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2934 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2936 #define FUNC_NAME s_scm_i_centered_divide
2940 scm_centered_divide(x
, y
, &q
, &r
);
2941 return scm_values (scm_list_2 (q
, r
));
2945 #define s_scm_centered_divide s_scm_i_centered_divide
2946 #define g_scm_centered_divide g_scm_i_centered_divide
2949 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2951 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2953 scm_t_inum xx
= SCM_I_INUM (x
);
2954 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2956 scm_t_inum yy
= SCM_I_INUM (y
);
2957 if (SCM_UNLIKELY (yy
== 0))
2958 scm_num_overflow (s_scm_centered_divide
);
2961 scm_t_inum qq
= xx
/ yy
;
2962 scm_t_inum rr
= xx
% yy
;
2963 if (SCM_LIKELY (xx
> 0))
2965 if (SCM_LIKELY (yy
> 0))
2967 if (rr
>= (yy
+ 1) / 2)
2972 if (rr
>= (1 - yy
) / 2)
2978 if (SCM_LIKELY (yy
> 0))
2989 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2990 *qp
= SCM_I_MAKINUM (qq
);
2992 *qp
= scm_i_inum2big (qq
);
2993 *rp
= SCM_I_MAKINUM (rr
);
2997 else if (SCM_BIGP (y
))
2999 /* Pass a denormalized bignum version of x (even though it
3000 can fit in a fixnum) to scm_i_bigint_centered_divide */
3001 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3003 else if (SCM_REALP (y
))
3004 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3005 else if (SCM_FRACTIONP (y
))
3006 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3008 return two_valued_wta_dispatch_2
3009 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3010 s_scm_centered_divide
, qp
, rp
);
3012 else if (SCM_BIGP (x
))
3014 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3016 scm_t_inum yy
= SCM_I_INUM (y
);
3017 if (SCM_UNLIKELY (yy
== 0))
3018 scm_num_overflow (s_scm_centered_divide
);
3021 SCM q
= scm_i_mkbig ();
3023 /* Arrange for rr to initially be non-positive,
3024 because that simplifies the test to see
3025 if it is within the needed bounds. */
3028 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3029 SCM_I_BIG_MPZ (x
), yy
);
3030 scm_remember_upto_here_1 (x
);
3033 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3034 SCM_I_BIG_MPZ (q
), 1);
3040 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3041 SCM_I_BIG_MPZ (x
), -yy
);
3042 scm_remember_upto_here_1 (x
);
3043 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3046 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3047 SCM_I_BIG_MPZ (q
), 1);
3051 *qp
= scm_i_normbig (q
);
3052 *rp
= SCM_I_MAKINUM (rr
);
3056 else if (SCM_BIGP (y
))
3057 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3058 else if (SCM_REALP (y
))
3059 return scm_i_inexact_centered_divide
3060 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3061 else if (SCM_FRACTIONP (y
))
3062 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3064 return two_valued_wta_dispatch_2
3065 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3066 s_scm_centered_divide
, qp
, rp
);
3068 else if (SCM_REALP (x
))
3070 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3071 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3072 return scm_i_inexact_centered_divide
3073 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3075 return two_valued_wta_dispatch_2
3076 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3077 s_scm_centered_divide
, qp
, rp
);
3079 else if (SCM_FRACTIONP (x
))
3082 return scm_i_inexact_centered_divide
3083 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3084 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3085 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3087 return two_valued_wta_dispatch_2
3088 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3089 s_scm_centered_divide
, qp
, rp
);
3092 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3093 s_scm_centered_divide
, qp
, rp
);
3097 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3101 if (SCM_LIKELY (y
> 0))
3102 q
= floor (x
/y
+ 0.5);
3103 else if (SCM_LIKELY (y
< 0))
3104 q
= ceil (x
/y
- 0.5);
3106 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3110 *qp
= scm_from_double (q
);
3111 *rp
= scm_from_double (r
);
3114 /* Assumes that both x and y are bigints, though
3115 x might be able to fit into a fixnum. */
3117 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3121 /* Note that x might be small enough to fit into a
3122 fixnum, so we must not let it escape into the wild */
3126 /* min_r will eventually become -abs(y/2) */
3127 min_r
= scm_i_mkbig ();
3128 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3129 SCM_I_BIG_MPZ (y
), 1);
3131 /* Arrange for rr to initially be non-positive,
3132 because that simplifies the test to see
3133 if it is within the needed bounds. */
3134 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3136 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3137 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3138 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3139 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3141 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3142 SCM_I_BIG_MPZ (q
), 1);
3143 mpz_add (SCM_I_BIG_MPZ (r
),
3150 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3151 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3152 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3154 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3155 SCM_I_BIG_MPZ (q
), 1);
3156 mpz_sub (SCM_I_BIG_MPZ (r
),
3161 scm_remember_upto_here_2 (x
, y
);
3162 *qp
= scm_i_normbig (q
);
3163 *rp
= scm_i_normbig (r
);
3167 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3170 SCM xd
= scm_denominator (x
);
3171 SCM yd
= scm_denominator (y
);
3173 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3174 scm_product (scm_numerator (y
), xd
),
3176 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3179 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3180 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3181 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3183 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3185 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3186 "with ties going to the nearest even integer.\n"
3188 "(round-quotient 123 10) @result{} 12\n"
3189 "(round-quotient 123 -10) @result{} -12\n"
3190 "(round-quotient -123 10) @result{} -12\n"
3191 "(round-quotient -123 -10) @result{} 12\n"
3192 "(round-quotient 125 10) @result{} 12\n"
3193 "(round-quotient 127 10) @result{} 13\n"
3194 "(round-quotient 135 10) @result{} 14\n"
3195 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3196 "(round-quotient 16/3 -10/7) @result{} -4\n"
3198 #define FUNC_NAME s_scm_round_quotient
3200 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3202 scm_t_inum xx
= SCM_I_INUM (x
);
3203 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3205 scm_t_inum yy
= SCM_I_INUM (y
);
3206 if (SCM_UNLIKELY (yy
== 0))
3207 scm_num_overflow (s_scm_round_quotient
);
3210 scm_t_inum qq
= xx
/ yy
;
3211 scm_t_inum rr
= xx
% yy
;
3213 scm_t_inum r2
= 2 * rr
;
3215 if (SCM_LIKELY (yy
< 0))
3235 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3236 return SCM_I_MAKINUM (qq
);
3238 return scm_i_inum2big (qq
);
3241 else if (SCM_BIGP (y
))
3243 /* Pass a denormalized bignum version of x (even though it
3244 can fit in a fixnum) to scm_i_bigint_round_quotient */
3245 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3247 else if (SCM_REALP (y
))
3248 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3249 else if (SCM_FRACTIONP (y
))
3250 return scm_i_exact_rational_round_quotient (x
, y
);
3252 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3253 s_scm_round_quotient
);
3255 else if (SCM_BIGP (x
))
3257 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3259 scm_t_inum yy
= SCM_I_INUM (y
);
3260 if (SCM_UNLIKELY (yy
== 0))
3261 scm_num_overflow (s_scm_round_quotient
);
3262 else if (SCM_UNLIKELY (yy
== 1))
3266 SCM q
= scm_i_mkbig ();
3268 int needs_adjustment
;
3272 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3273 SCM_I_BIG_MPZ (x
), yy
);
3274 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3275 needs_adjustment
= (2*rr
>= yy
);
3277 needs_adjustment
= (2*rr
> yy
);
3281 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3282 SCM_I_BIG_MPZ (x
), -yy
);
3283 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3284 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3285 needs_adjustment
= (2*rr
<= yy
);
3287 needs_adjustment
= (2*rr
< yy
);
3289 scm_remember_upto_here_1 (x
);
3290 if (needs_adjustment
)
3291 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3292 return scm_i_normbig (q
);
3295 else if (SCM_BIGP (y
))
3296 return scm_i_bigint_round_quotient (x
, y
);
3297 else if (SCM_REALP (y
))
3298 return scm_i_inexact_round_quotient
3299 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3300 else if (SCM_FRACTIONP (y
))
3301 return scm_i_exact_rational_round_quotient (x
, y
);
3303 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3304 s_scm_round_quotient
);
3306 else if (SCM_REALP (x
))
3308 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3309 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3310 return scm_i_inexact_round_quotient
3311 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3313 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3314 s_scm_round_quotient
);
3316 else if (SCM_FRACTIONP (x
))
3319 return scm_i_inexact_round_quotient
3320 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3321 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3322 return scm_i_exact_rational_round_quotient (x
, y
);
3324 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3325 s_scm_round_quotient
);
3328 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3329 s_scm_round_quotient
);
3334 scm_i_inexact_round_quotient (double x
, double y
)
3336 if (SCM_UNLIKELY (y
== 0))
3337 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3339 return scm_from_double (scm_c_round (x
/ y
));
3342 /* Assumes that both x and y are bigints, though
3343 x might be able to fit into a fixnum. */
3345 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3348 int cmp
, needs_adjustment
;
3350 /* Note that x might be small enough to fit into a
3351 fixnum, so we must not let it escape into the wild */
3354 r2
= scm_i_mkbig ();
3356 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3357 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3358 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3359 scm_remember_upto_here_2 (x
, r
);
3361 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3362 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3363 needs_adjustment
= (cmp
>= 0);
3365 needs_adjustment
= (cmp
> 0);
3366 scm_remember_upto_here_2 (r2
, y
);
3368 if (needs_adjustment
)
3369 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3371 return scm_i_normbig (q
);
3375 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3377 return scm_round_quotient
3378 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3379 scm_product (scm_numerator (y
), scm_denominator (x
)));
3382 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3383 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3384 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3386 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3388 "Return the real number @var{r} such that\n"
3389 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3390 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3391 "nearest integer, with ties going to the nearest\n"
3394 "(round-remainder 123 10) @result{} 3\n"
3395 "(round-remainder 123 -10) @result{} 3\n"
3396 "(round-remainder -123 10) @result{} -3\n"
3397 "(round-remainder -123 -10) @result{} -3\n"
3398 "(round-remainder 125 10) @result{} 5\n"
3399 "(round-remainder 127 10) @result{} -3\n"
3400 "(round-remainder 135 10) @result{} -5\n"
3401 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3402 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3404 #define FUNC_NAME s_scm_round_remainder
3406 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3408 scm_t_inum xx
= SCM_I_INUM (x
);
3409 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3411 scm_t_inum yy
= SCM_I_INUM (y
);
3412 if (SCM_UNLIKELY (yy
== 0))
3413 scm_num_overflow (s_scm_round_remainder
);
3416 scm_t_inum qq
= xx
/ yy
;
3417 scm_t_inum rr
= xx
% yy
;
3419 scm_t_inum r2
= 2 * rr
;
3421 if (SCM_LIKELY (yy
< 0))
3441 return SCM_I_MAKINUM (rr
);
3444 else if (SCM_BIGP (y
))
3446 /* Pass a denormalized bignum version of x (even though it
3447 can fit in a fixnum) to scm_i_bigint_round_remainder */
3448 return scm_i_bigint_round_remainder
3449 (scm_i_long2big (xx
), y
);
3451 else if (SCM_REALP (y
))
3452 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3453 else if (SCM_FRACTIONP (y
))
3454 return scm_i_exact_rational_round_remainder (x
, y
);
3456 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3457 s_scm_round_remainder
);
3459 else if (SCM_BIGP (x
))
3461 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3463 scm_t_inum yy
= SCM_I_INUM (y
);
3464 if (SCM_UNLIKELY (yy
== 0))
3465 scm_num_overflow (s_scm_round_remainder
);
3468 SCM q
= scm_i_mkbig ();
3470 int needs_adjustment
;
3474 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3475 SCM_I_BIG_MPZ (x
), yy
);
3476 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3477 needs_adjustment
= (2*rr
>= yy
);
3479 needs_adjustment
= (2*rr
> yy
);
3483 rr
= - mpz_cdiv_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
);
3490 scm_remember_upto_here_2 (x
, q
);
3491 if (needs_adjustment
)
3493 return SCM_I_MAKINUM (rr
);
3496 else if (SCM_BIGP (y
))
3497 return scm_i_bigint_round_remainder (x
, y
);
3498 else if (SCM_REALP (y
))
3499 return scm_i_inexact_round_remainder
3500 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3501 else if (SCM_FRACTIONP (y
))
3502 return scm_i_exact_rational_round_remainder (x
, y
);
3504 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3505 s_scm_round_remainder
);
3507 else if (SCM_REALP (x
))
3509 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3510 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3511 return scm_i_inexact_round_remainder
3512 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3514 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3515 s_scm_round_remainder
);
3517 else if (SCM_FRACTIONP (x
))
3520 return scm_i_inexact_round_remainder
3521 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3522 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3523 return scm_i_exact_rational_round_remainder (x
, y
);
3525 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3526 s_scm_round_remainder
);
3529 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3530 s_scm_round_remainder
);
3535 scm_i_inexact_round_remainder (double x
, double y
)
3537 /* Although it would be more efficient to use fmod here, we can't
3538 because it would in some cases produce results inconsistent with
3539 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3540 close). In particular, when x-y/2 is very close to a multiple of
3541 y, then r might be either -abs(y/2) or abs(y/2), but those two
3542 cases must correspond to different choices of q. If quotient
3543 chooses one and remainder chooses the other, it would be bad. */
3545 if (SCM_UNLIKELY (y
== 0))
3546 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3549 double q
= scm_c_round (x
/ y
);
3550 return scm_from_double (x
- q
* y
);
3554 /* Assumes that both x and y are bigints, though
3555 x might be able to fit into a fixnum. */
3557 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3560 int cmp
, needs_adjustment
;
3562 /* Note that x might be small enough to fit into a
3563 fixnum, so we must not let it escape into the wild */
3566 r2
= scm_i_mkbig ();
3568 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3569 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3570 scm_remember_upto_here_1 (x
);
3571 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3573 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3574 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3575 needs_adjustment
= (cmp
>= 0);
3577 needs_adjustment
= (cmp
> 0);
3578 scm_remember_upto_here_2 (q
, r2
);
3580 if (needs_adjustment
)
3581 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3583 scm_remember_upto_here_1 (y
);
3584 return scm_i_normbig (r
);
3588 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3590 SCM xd
= scm_denominator (x
);
3591 SCM yd
= scm_denominator (y
);
3592 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3593 scm_product (scm_numerator (y
), xd
));
3594 return scm_divide (r1
, scm_product (xd
, yd
));
3598 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3599 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3600 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3602 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3604 "Return the integer @var{q} and the real number @var{r}\n"
3605 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3606 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3607 "nearest integer, with ties going to the nearest even integer.\n"
3609 "(round/ 123 10) @result{} 12 and 3\n"
3610 "(round/ 123 -10) @result{} -12 and 3\n"
3611 "(round/ -123 10) @result{} -12 and -3\n"
3612 "(round/ -123 -10) @result{} 12 and -3\n"
3613 "(round/ 125 10) @result{} 12 and 5\n"
3614 "(round/ 127 10) @result{} 13 and -3\n"
3615 "(round/ 135 10) @result{} 14 and -5\n"
3616 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3617 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3619 #define FUNC_NAME s_scm_i_round_divide
3623 scm_round_divide(x
, y
, &q
, &r
);
3624 return scm_values (scm_list_2 (q
, r
));
3628 #define s_scm_round_divide s_scm_i_round_divide
3629 #define g_scm_round_divide g_scm_i_round_divide
3632 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3634 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3636 scm_t_inum xx
= SCM_I_INUM (x
);
3637 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3639 scm_t_inum yy
= SCM_I_INUM (y
);
3640 if (SCM_UNLIKELY (yy
== 0))
3641 scm_num_overflow (s_scm_round_divide
);
3644 scm_t_inum qq
= xx
/ yy
;
3645 scm_t_inum rr
= xx
% yy
;
3647 scm_t_inum r2
= 2 * rr
;
3649 if (SCM_LIKELY (yy
< 0))
3669 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3670 *qp
= SCM_I_MAKINUM (qq
);
3672 *qp
= scm_i_inum2big (qq
);
3673 *rp
= SCM_I_MAKINUM (rr
);
3677 else if (SCM_BIGP (y
))
3679 /* Pass a denormalized bignum version of x (even though it
3680 can fit in a fixnum) to scm_i_bigint_round_divide */
3681 return scm_i_bigint_round_divide
3682 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3684 else if (SCM_REALP (y
))
3685 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3686 else if (SCM_FRACTIONP (y
))
3687 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3689 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3690 s_scm_round_divide
, qp
, rp
);
3692 else if (SCM_BIGP (x
))
3694 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3696 scm_t_inum yy
= SCM_I_INUM (y
);
3697 if (SCM_UNLIKELY (yy
== 0))
3698 scm_num_overflow (s_scm_round_divide
);
3701 SCM q
= scm_i_mkbig ();
3703 int needs_adjustment
;
3707 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3708 SCM_I_BIG_MPZ (x
), yy
);
3709 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3710 needs_adjustment
= (2*rr
>= yy
);
3712 needs_adjustment
= (2*rr
> yy
);
3716 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3717 SCM_I_BIG_MPZ (x
), -yy
);
3718 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3719 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3720 needs_adjustment
= (2*rr
<= yy
);
3722 needs_adjustment
= (2*rr
< yy
);
3724 scm_remember_upto_here_1 (x
);
3725 if (needs_adjustment
)
3727 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3730 *qp
= scm_i_normbig (q
);
3731 *rp
= SCM_I_MAKINUM (rr
);
3735 else if (SCM_BIGP (y
))
3736 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3737 else if (SCM_REALP (y
))
3738 return scm_i_inexact_round_divide
3739 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3740 else if (SCM_FRACTIONP (y
))
3741 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3743 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3744 s_scm_round_divide
, qp
, rp
);
3746 else if (SCM_REALP (x
))
3748 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3749 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3750 return scm_i_inexact_round_divide
3751 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3753 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3754 s_scm_round_divide
, qp
, rp
);
3756 else if (SCM_FRACTIONP (x
))
3759 return scm_i_inexact_round_divide
3760 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3761 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3762 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3764 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3765 s_scm_round_divide
, qp
, rp
);
3768 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3769 s_scm_round_divide
, qp
, rp
);
3773 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3775 if (SCM_UNLIKELY (y
== 0))
3776 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3779 double q
= scm_c_round (x
/ y
);
3780 double r
= x
- q
* y
;
3781 *qp
= scm_from_double (q
);
3782 *rp
= scm_from_double (r
);
3786 /* Assumes that both x and y are bigints, though
3787 x might be able to fit into a fixnum. */
3789 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3792 int cmp
, needs_adjustment
;
3794 /* Note that x might be small enough to fit into a
3795 fixnum, so we must not let it escape into the wild */
3798 r2
= scm_i_mkbig ();
3800 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3801 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3802 scm_remember_upto_here_1 (x
);
3803 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3805 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3806 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3807 needs_adjustment
= (cmp
>= 0);
3809 needs_adjustment
= (cmp
> 0);
3811 if (needs_adjustment
)
3813 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3814 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3817 scm_remember_upto_here_2 (r2
, y
);
3818 *qp
= scm_i_normbig (q
);
3819 *rp
= scm_i_normbig (r
);
3823 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3826 SCM xd
= scm_denominator (x
);
3827 SCM yd
= scm_denominator (y
);
3829 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3830 scm_product (scm_numerator (y
), xd
),
3832 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3836 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3837 (SCM x
, SCM y
, SCM rest
),
3838 "Return the greatest common divisor of all parameter values.\n"
3839 "If called without arguments, 0 is returned.")
3840 #define FUNC_NAME s_scm_i_gcd
3842 while (!scm_is_null (rest
))
3843 { x
= scm_gcd (x
, y
);
3845 rest
= scm_cdr (rest
);
3847 return scm_gcd (x
, y
);
3851 #define s_gcd s_scm_i_gcd
3852 #define g_gcd g_scm_i_gcd
3855 scm_gcd (SCM x
, SCM y
)
3858 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3860 if (SCM_I_INUMP (x
))
3862 if (SCM_I_INUMP (y
))
3864 scm_t_inum xx
= SCM_I_INUM (x
);
3865 scm_t_inum yy
= SCM_I_INUM (y
);
3866 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3867 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3877 /* Determine a common factor 2^k */
3878 while (!(1 & (u
| v
)))
3884 /* Now, any factor 2^n can be eliminated */
3904 return (SCM_POSFIXABLE (result
)
3905 ? SCM_I_MAKINUM (result
)
3906 : scm_i_inum2big (result
));
3908 else if (SCM_BIGP (y
))
3914 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3916 else if (SCM_BIGP (x
))
3918 if (SCM_I_INUMP (y
))
3923 yy
= SCM_I_INUM (y
);
3928 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3929 scm_remember_upto_here_1 (x
);
3930 return (SCM_POSFIXABLE (result
)
3931 ? SCM_I_MAKINUM (result
)
3932 : scm_from_unsigned_integer (result
));
3934 else if (SCM_BIGP (y
))
3936 SCM result
= scm_i_mkbig ();
3937 mpz_gcd (SCM_I_BIG_MPZ (result
),
3940 scm_remember_upto_here_2 (x
, y
);
3941 return scm_i_normbig (result
);
3944 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3947 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3950 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3951 (SCM x
, SCM y
, SCM rest
),
3952 "Return the least common multiple of the arguments.\n"
3953 "If called without arguments, 1 is returned.")
3954 #define FUNC_NAME s_scm_i_lcm
3956 while (!scm_is_null (rest
))
3957 { x
= scm_lcm (x
, y
);
3959 rest
= scm_cdr (rest
);
3961 return scm_lcm (x
, y
);
3965 #define s_lcm s_scm_i_lcm
3966 #define g_lcm g_scm_i_lcm
3969 scm_lcm (SCM n1
, SCM n2
)
3971 if (SCM_UNBNDP (n2
))
3973 if (SCM_UNBNDP (n1
))
3974 return SCM_I_MAKINUM (1L);
3975 n2
= SCM_I_MAKINUM (1L);
3978 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
3979 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3981 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
3982 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
3984 if (SCM_I_INUMP (n1
))
3986 if (SCM_I_INUMP (n2
))
3988 SCM d
= scm_gcd (n1
, n2
);
3989 if (scm_is_eq (d
, SCM_INUM0
))
3992 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
3996 /* inum n1, big n2 */
3999 SCM result
= scm_i_mkbig ();
4000 scm_t_inum nn1
= SCM_I_INUM (n1
);
4001 if (nn1
== 0) return SCM_INUM0
;
4002 if (nn1
< 0) nn1
= - nn1
;
4003 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4004 scm_remember_upto_here_1 (n2
);
4012 if (SCM_I_INUMP (n2
))
4019 SCM result
= scm_i_mkbig ();
4020 mpz_lcm(SCM_I_BIG_MPZ (result
),
4022 SCM_I_BIG_MPZ (n2
));
4023 scm_remember_upto_here_2(n1
, n2
);
4024 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4030 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4035 + + + x (map digit:logand X Y)
4036 + - + x (map digit:logand X (lognot (+ -1 Y)))
4037 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4038 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4043 + + + (map digit:logior X Y)
4044 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4045 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4046 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4051 + + + (map digit:logxor X Y)
4052 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4053 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4054 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4059 + + (any digit:logand X Y)
4060 + - (any digit:logand X (lognot (+ -1 Y)))
4061 - + (any digit:logand (lognot (+ -1 X)) Y)
4066 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4067 (SCM x
, SCM y
, SCM rest
),
4068 "Return the bitwise AND of the integer arguments.\n\n"
4070 "(logand) @result{} -1\n"
4071 "(logand 7) @result{} 7\n"
4072 "(logand #b111 #b011 #b001) @result{} 1\n"
4074 #define FUNC_NAME s_scm_i_logand
4076 while (!scm_is_null (rest
))
4077 { x
= scm_logand (x
, y
);
4079 rest
= scm_cdr (rest
);
4081 return scm_logand (x
, y
);
4085 #define s_scm_logand s_scm_i_logand
4087 SCM
scm_logand (SCM n1
, SCM n2
)
4088 #define FUNC_NAME s_scm_logand
4092 if (SCM_UNBNDP (n2
))
4094 if (SCM_UNBNDP (n1
))
4095 return SCM_I_MAKINUM (-1);
4096 else if (!SCM_NUMBERP (n1
))
4097 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4098 else if (SCM_NUMBERP (n1
))
4101 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4104 if (SCM_I_INUMP (n1
))
4106 nn1
= SCM_I_INUM (n1
);
4107 if (SCM_I_INUMP (n2
))
4109 scm_t_inum nn2
= SCM_I_INUM (n2
);
4110 return SCM_I_MAKINUM (nn1
& nn2
);
4112 else if SCM_BIGP (n2
)
4118 SCM result_z
= scm_i_mkbig ();
4120 mpz_init_set_si (nn1_z
, nn1
);
4121 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4122 scm_remember_upto_here_1 (n2
);
4124 return scm_i_normbig (result_z
);
4128 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4130 else if (SCM_BIGP (n1
))
4132 if (SCM_I_INUMP (n2
))
4135 nn1
= SCM_I_INUM (n1
);
4138 else if (SCM_BIGP (n2
))
4140 SCM result_z
= scm_i_mkbig ();
4141 mpz_and (SCM_I_BIG_MPZ (result_z
),
4143 SCM_I_BIG_MPZ (n2
));
4144 scm_remember_upto_here_2 (n1
, n2
);
4145 return scm_i_normbig (result_z
);
4148 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4151 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4156 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4157 (SCM x
, SCM y
, SCM rest
),
4158 "Return the bitwise OR of the integer arguments.\n\n"
4160 "(logior) @result{} 0\n"
4161 "(logior 7) @result{} 7\n"
4162 "(logior #b000 #b001 #b011) @result{} 3\n"
4164 #define FUNC_NAME s_scm_i_logior
4166 while (!scm_is_null (rest
))
4167 { x
= scm_logior (x
, y
);
4169 rest
= scm_cdr (rest
);
4171 return scm_logior (x
, y
);
4175 #define s_scm_logior s_scm_i_logior
4177 SCM
scm_logior (SCM n1
, SCM n2
)
4178 #define FUNC_NAME s_scm_logior
4182 if (SCM_UNBNDP (n2
))
4184 if (SCM_UNBNDP (n1
))
4186 else if (SCM_NUMBERP (n1
))
4189 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4192 if (SCM_I_INUMP (n1
))
4194 nn1
= SCM_I_INUM (n1
);
4195 if (SCM_I_INUMP (n2
))
4197 long nn2
= SCM_I_INUM (n2
);
4198 return SCM_I_MAKINUM (nn1
| nn2
);
4200 else if (SCM_BIGP (n2
))
4206 SCM result_z
= scm_i_mkbig ();
4208 mpz_init_set_si (nn1_z
, nn1
);
4209 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4210 scm_remember_upto_here_1 (n2
);
4212 return scm_i_normbig (result_z
);
4216 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4218 else if (SCM_BIGP (n1
))
4220 if (SCM_I_INUMP (n2
))
4223 nn1
= SCM_I_INUM (n1
);
4226 else if (SCM_BIGP (n2
))
4228 SCM result_z
= scm_i_mkbig ();
4229 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4231 SCM_I_BIG_MPZ (n2
));
4232 scm_remember_upto_here_2 (n1
, n2
);
4233 return scm_i_normbig (result_z
);
4236 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4239 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4244 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4245 (SCM x
, SCM y
, SCM rest
),
4246 "Return the bitwise XOR of the integer arguments. A bit is\n"
4247 "set in the result if it is set in an odd number of arguments.\n"
4249 "(logxor) @result{} 0\n"
4250 "(logxor 7) @result{} 7\n"
4251 "(logxor #b000 #b001 #b011) @result{} 2\n"
4252 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4254 #define FUNC_NAME s_scm_i_logxor
4256 while (!scm_is_null (rest
))
4257 { x
= scm_logxor (x
, y
);
4259 rest
= scm_cdr (rest
);
4261 return scm_logxor (x
, y
);
4265 #define s_scm_logxor s_scm_i_logxor
4267 SCM
scm_logxor (SCM n1
, SCM n2
)
4268 #define FUNC_NAME s_scm_logxor
4272 if (SCM_UNBNDP (n2
))
4274 if (SCM_UNBNDP (n1
))
4276 else if (SCM_NUMBERP (n1
))
4279 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4282 if (SCM_I_INUMP (n1
))
4284 nn1
= SCM_I_INUM (n1
);
4285 if (SCM_I_INUMP (n2
))
4287 scm_t_inum nn2
= SCM_I_INUM (n2
);
4288 return SCM_I_MAKINUM (nn1
^ nn2
);
4290 else if (SCM_BIGP (n2
))
4294 SCM result_z
= scm_i_mkbig ();
4296 mpz_init_set_si (nn1_z
, nn1
);
4297 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4298 scm_remember_upto_here_1 (n2
);
4300 return scm_i_normbig (result_z
);
4304 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4306 else if (SCM_BIGP (n1
))
4308 if (SCM_I_INUMP (n2
))
4311 nn1
= SCM_I_INUM (n1
);
4314 else if (SCM_BIGP (n2
))
4316 SCM result_z
= scm_i_mkbig ();
4317 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4319 SCM_I_BIG_MPZ (n2
));
4320 scm_remember_upto_here_2 (n1
, n2
);
4321 return scm_i_normbig (result_z
);
4324 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4327 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4332 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4334 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4335 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4336 "without actually calculating the @code{logand}, just testing\n"
4340 "(logtest #b0100 #b1011) @result{} #f\n"
4341 "(logtest #b0100 #b0111) @result{} #t\n"
4343 #define FUNC_NAME s_scm_logtest
4347 if (SCM_I_INUMP (j
))
4349 nj
= SCM_I_INUM (j
);
4350 if (SCM_I_INUMP (k
))
4352 scm_t_inum nk
= SCM_I_INUM (k
);
4353 return scm_from_bool (nj
& nk
);
4355 else if (SCM_BIGP (k
))
4363 mpz_init_set_si (nj_z
, nj
);
4364 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4365 scm_remember_upto_here_1 (k
);
4366 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4372 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4374 else if (SCM_BIGP (j
))
4376 if (SCM_I_INUMP (k
))
4379 nj
= SCM_I_INUM (j
);
4382 else if (SCM_BIGP (k
))
4386 mpz_init (result_z
);
4390 scm_remember_upto_here_2 (j
, k
);
4391 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4392 mpz_clear (result_z
);
4396 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4399 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4404 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4406 "Test whether bit number @var{index} in @var{j} is set.\n"
4407 "@var{index} starts from 0 for the least significant bit.\n"
4410 "(logbit? 0 #b1101) @result{} #t\n"
4411 "(logbit? 1 #b1101) @result{} #f\n"
4412 "(logbit? 2 #b1101) @result{} #t\n"
4413 "(logbit? 3 #b1101) @result{} #t\n"
4414 "(logbit? 4 #b1101) @result{} #f\n"
4416 #define FUNC_NAME s_scm_logbit_p
4418 unsigned long int iindex
;
4419 iindex
= scm_to_ulong (index
);
4421 if (SCM_I_INUMP (j
))
4423 /* bits above what's in an inum follow the sign bit */
4424 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4425 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4427 else if (SCM_BIGP (j
))
4429 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4430 scm_remember_upto_here_1 (j
);
4431 return scm_from_bool (val
);
4434 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4439 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4441 "Return the integer which is the ones-complement of the integer\n"
4445 "(number->string (lognot #b10000000) 2)\n"
4446 " @result{} \"-10000001\"\n"
4447 "(number->string (lognot #b0) 2)\n"
4448 " @result{} \"-1\"\n"
4450 #define FUNC_NAME s_scm_lognot
4452 if (SCM_I_INUMP (n
)) {
4453 /* No overflow here, just need to toggle all the bits making up the inum.
4454 Enhancement: No need to strip the tag and add it back, could just xor
4455 a block of 1 bits, if that worked with the various debug versions of
4457 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4459 } else if (SCM_BIGP (n
)) {
4460 SCM result
= scm_i_mkbig ();
4461 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4462 scm_remember_upto_here_1 (n
);
4466 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4471 /* returns 0 if IN is not an integer. OUT must already be
4474 coerce_to_big (SCM in
, mpz_t out
)
4477 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4478 else if (SCM_I_INUMP (in
))
4479 mpz_set_si (out
, SCM_I_INUM (in
));
4486 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4487 (SCM n
, SCM k
, SCM m
),
4488 "Return @var{n} raised to the integer exponent\n"
4489 "@var{k}, modulo @var{m}.\n"
4492 "(modulo-expt 2 3 5)\n"
4495 #define FUNC_NAME s_scm_modulo_expt
4501 /* There are two classes of error we might encounter --
4502 1) Math errors, which we'll report by calling scm_num_overflow,
4504 2) wrong-type errors, which of course we'll report by calling
4506 We don't report those errors immediately, however; instead we do
4507 some cleanup first. These variables tell us which error (if
4508 any) we should report after cleaning up.
4510 int report_overflow
= 0;
4512 int position_of_wrong_type
= 0;
4513 SCM value_of_wrong_type
= SCM_INUM0
;
4515 SCM result
= SCM_UNDEFINED
;
4521 if (scm_is_eq (m
, SCM_INUM0
))
4523 report_overflow
= 1;
4527 if (!coerce_to_big (n
, n_tmp
))
4529 value_of_wrong_type
= n
;
4530 position_of_wrong_type
= 1;
4534 if (!coerce_to_big (k
, k_tmp
))
4536 value_of_wrong_type
= k
;
4537 position_of_wrong_type
= 2;
4541 if (!coerce_to_big (m
, m_tmp
))
4543 value_of_wrong_type
= m
;
4544 position_of_wrong_type
= 3;
4548 /* if the exponent K is negative, and we simply call mpz_powm, we
4549 will get a divide-by-zero exception when an inverse 1/n mod m
4550 doesn't exist (or is not unique). Since exceptions are hard to
4551 handle, we'll attempt the inversion "by hand" -- that way, we get
4552 a simple failure code, which is easy to handle. */
4554 if (-1 == mpz_sgn (k_tmp
))
4556 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4558 report_overflow
= 1;
4561 mpz_neg (k_tmp
, k_tmp
);
4564 result
= scm_i_mkbig ();
4565 mpz_powm (SCM_I_BIG_MPZ (result
),
4570 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4571 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4578 if (report_overflow
)
4579 scm_num_overflow (FUNC_NAME
);
4581 if (position_of_wrong_type
)
4582 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4583 value_of_wrong_type
);
4585 return scm_i_normbig (result
);
4589 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4591 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4592 "exact integer, @var{n} can be any number.\n"
4594 "Negative @var{k} is supported, and results in\n"
4595 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4596 "@math{@var{n}^0} is 1, as usual, and that\n"
4597 "includes @math{0^0} is 1.\n"
4600 "(integer-expt 2 5) @result{} 32\n"
4601 "(integer-expt -3 3) @result{} -27\n"
4602 "(integer-expt 5 -3) @result{} 1/125\n"
4603 "(integer-expt 0 0) @result{} 1\n"
4605 #define FUNC_NAME s_scm_integer_expt
4608 SCM z_i2
= SCM_BOOL_F
;
4610 SCM acc
= SCM_I_MAKINUM (1L);
4612 /* Specifically refrain from checking the type of the first argument.
4613 This allows us to exponentiate any object that can be multiplied.
4614 If we must raise to a negative power, we must also be able to
4615 take its reciprocal. */
4616 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4617 SCM_WRONG_TYPE_ARG (2, k
);
4619 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4620 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4621 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4622 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4623 /* The next check is necessary only because R6RS specifies different
4624 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4625 we simply skip this case and move on. */
4626 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4628 /* k cannot be 0 at this point, because we
4629 have already checked for that case above */
4630 if (scm_is_true (scm_positive_p (k
)))
4632 else /* return NaN for (0 ^ k) for negative k per R6RS */
4636 if (SCM_I_INUMP (k
))
4637 i2
= SCM_I_INUM (k
);
4638 else if (SCM_BIGP (k
))
4640 z_i2
= scm_i_clonebig (k
, 1);
4641 scm_remember_upto_here_1 (k
);
4645 SCM_WRONG_TYPE_ARG (2, k
);
4649 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4651 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4652 n
= scm_divide (n
, SCM_UNDEFINED
);
4656 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4660 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4662 return scm_product (acc
, n
);
4664 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4665 acc
= scm_product (acc
, n
);
4666 n
= scm_product (n
, n
);
4667 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4675 n
= scm_divide (n
, SCM_UNDEFINED
);
4682 return scm_product (acc
, n
);
4684 acc
= scm_product (acc
, n
);
4685 n
= scm_product (n
, n
);
4692 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4694 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4695 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4697 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4698 "@var{cnt} is negative it's a division, rounded towards negative\n"
4699 "infinity. (Note that this is not the same rounding as\n"
4700 "@code{quotient} does.)\n"
4702 "With @var{n} viewed as an infinite precision twos complement,\n"
4703 "@code{ash} means a left shift introducing zero bits, or a right\n"
4704 "shift dropping bits.\n"
4707 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4708 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4710 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4711 "(ash -23 -2) @result{} -6\n"
4713 #define FUNC_NAME s_scm_ash
4716 bits_to_shift
= scm_to_long (cnt
);
4718 if (SCM_I_INUMP (n
))
4720 scm_t_inum nn
= SCM_I_INUM (n
);
4722 if (bits_to_shift
> 0)
4724 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4725 overflow a non-zero fixnum. For smaller shifts we check the
4726 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4727 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4728 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4734 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4736 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4739 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4743 SCM result
= scm_i_inum2big (nn
);
4744 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4751 bits_to_shift
= -bits_to_shift
;
4752 if (bits_to_shift
>= SCM_LONG_BIT
)
4753 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4755 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4759 else if (SCM_BIGP (n
))
4763 if (bits_to_shift
== 0)
4766 result
= scm_i_mkbig ();
4767 if (bits_to_shift
>= 0)
4769 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4775 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4776 we have to allocate a bignum even if the result is going to be a
4778 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4780 return scm_i_normbig (result
);
4786 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4792 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4793 (SCM n
, SCM start
, SCM end
),
4794 "Return the integer composed of the @var{start} (inclusive)\n"
4795 "through @var{end} (exclusive) bits of @var{n}. The\n"
4796 "@var{start}th bit becomes the 0-th bit in the result.\n"
4799 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4800 " @result{} \"1010\"\n"
4801 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4802 " @result{} \"10110\"\n"
4804 #define FUNC_NAME s_scm_bit_extract
4806 unsigned long int istart
, iend
, bits
;
4807 istart
= scm_to_ulong (start
);
4808 iend
= scm_to_ulong (end
);
4809 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4811 /* how many bits to keep */
4812 bits
= iend
- istart
;
4814 if (SCM_I_INUMP (n
))
4816 scm_t_inum in
= SCM_I_INUM (n
);
4818 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4819 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4820 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4822 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4824 /* Since we emulate two's complement encoded numbers, this
4825 * special case requires us to produce a result that has
4826 * more bits than can be stored in a fixnum.
4828 SCM result
= scm_i_inum2big (in
);
4829 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4834 /* mask down to requisite bits */
4835 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4836 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4838 else if (SCM_BIGP (n
))
4843 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4847 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4848 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4849 such bits into a ulong. */
4850 result
= scm_i_mkbig ();
4851 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4852 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4853 result
= scm_i_normbig (result
);
4855 scm_remember_upto_here_1 (n
);
4859 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4864 static const char scm_logtab
[] = {
4865 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4868 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4870 "Return the number of bits in integer @var{n}. If integer is\n"
4871 "positive, the 1-bits in its binary representation are counted.\n"
4872 "If negative, the 0-bits in its two's-complement binary\n"
4873 "representation are counted. If 0, 0 is returned.\n"
4876 "(logcount #b10101010)\n"
4883 #define FUNC_NAME s_scm_logcount
4885 if (SCM_I_INUMP (n
))
4887 unsigned long c
= 0;
4888 scm_t_inum nn
= SCM_I_INUM (n
);
4893 c
+= scm_logtab
[15 & nn
];
4896 return SCM_I_MAKINUM (c
);
4898 else if (SCM_BIGP (n
))
4900 unsigned long count
;
4901 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4902 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4904 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4905 scm_remember_upto_here_1 (n
);
4906 return SCM_I_MAKINUM (count
);
4909 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4914 static const char scm_ilentab
[] = {
4915 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4919 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4921 "Return the number of bits necessary to represent @var{n}.\n"
4924 "(integer-length #b10101010)\n"
4926 "(integer-length 0)\n"
4928 "(integer-length #b1111)\n"
4931 #define FUNC_NAME s_scm_integer_length
4933 if (SCM_I_INUMP (n
))
4935 unsigned long c
= 0;
4937 scm_t_inum nn
= SCM_I_INUM (n
);
4943 l
= scm_ilentab
[15 & nn
];
4946 return SCM_I_MAKINUM (c
- 4 + l
);
4948 else if (SCM_BIGP (n
))
4950 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4951 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4952 1 too big, so check for that and adjust. */
4953 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4954 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4955 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4956 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4958 scm_remember_upto_here_1 (n
);
4959 return SCM_I_MAKINUM (size
);
4962 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4966 /*** NUMBERS -> STRINGS ***/
4967 #define SCM_MAX_DBL_PREC 60
4968 #define SCM_MAX_DBL_RADIX 36
4970 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4971 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4972 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4975 void init_dblprec(int *prec
, int radix
) {
4976 /* determine floating point precision by adding successively
4977 smaller increments to 1.0 until it is considered == 1.0 */
4978 double f
= ((double)1.0)/radix
;
4979 double fsum
= 1.0 + f
;
4984 if (++(*prec
) > SCM_MAX_DBL_PREC
)
4996 void init_fx_radix(double *fx_list
, int radix
)
4998 /* initialize a per-radix list of tolerances. When added
4999 to a number < 1.0, we can determine if we should raund
5000 up and quit converting a number to a string. */
5004 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5005 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5008 /* use this array as a way to generate a single digit */
5009 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5012 idbl2str (double f
, char *a
, int radix
)
5014 int efmt
, dpt
, d
, i
, wp
;
5016 #ifdef DBL_MIN_10_EXP
5019 #endif /* DBL_MIN_10_EXP */
5024 radix
> SCM_MAX_DBL_RADIX
)
5026 /* revert to existing behavior */
5030 wp
= scm_dblprec
[radix
-2];
5031 fx
= fx_per_radix
[radix
-2];
5035 #ifdef HAVE_COPYSIGN
5036 double sgn
= copysign (1.0, f
);
5041 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5047 strcpy (a
, "-inf.0");
5049 strcpy (a
, "+inf.0");
5054 strcpy (a
, "+nan.0");
5064 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5065 make-uniform-vector, from causing infinite loops. */
5066 /* just do the checking...if it passes, we do the conversion for our
5067 radix again below */
5074 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5082 while (f_cpy
> 10.0)
5085 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5106 if (f
+ fx
[wp
] >= radix
)
5112 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5133 a
[ch
++] = number_chars
[d
];
5136 if (f
+ fx
[wp
] >= 1.0)
5138 a
[ch
- 1] = number_chars
[d
+1];
5149 if ((dpt
> 4) && (exp
> 6))
5151 d
= (a
[0] == '-' ? 2 : 1);
5152 for (i
= ch
++; i
> d
; i
--)
5164 if (a
[ch
- 1] == '.')
5165 a
[ch
++] = '0'; /* trailing zero */
5174 for (i
= radix
; i
<= exp
; i
*= radix
);
5175 for (i
/= radix
; i
; i
/= radix
)
5177 a
[ch
++] = number_chars
[exp
/ i
];
5186 icmplx2str (double real
, double imag
, char *str
, int radix
)
5191 i
= idbl2str (real
, str
, radix
);
5192 #ifdef HAVE_COPYSIGN
5193 sgn
= copysign (1.0, imag
);
5197 /* Don't output a '+' for negative numbers or for Inf and
5198 NaN. They will provide their own sign. */
5199 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5201 i
+= idbl2str (imag
, &str
[i
], radix
);
5207 iflo2str (SCM flt
, char *str
, int radix
)
5210 if (SCM_REALP (flt
))
5211 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5213 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5218 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5219 characters in the result.
5221 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5223 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5228 return scm_iuint2str (-num
, rad
, p
) + 1;
5231 return scm_iuint2str (num
, rad
, p
);
5234 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5235 characters in the result.
5237 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5239 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5243 scm_t_uintmax n
= num
;
5245 if (rad
< 2 || rad
> 36)
5246 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5248 for (n
/= rad
; n
> 0; n
/= rad
)
5258 p
[i
] = number_chars
[d
];
5263 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5265 "Return a string holding the external representation of the\n"
5266 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5267 "inexact, a radix of 10 will be used.")
5268 #define FUNC_NAME s_scm_number_to_string
5272 if (SCM_UNBNDP (radix
))
5275 base
= scm_to_signed_integer (radix
, 2, 36);
5277 if (SCM_I_INUMP (n
))
5279 char num_buf
[SCM_INTBUFLEN
];
5280 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5281 return scm_from_locale_stringn (num_buf
, length
);
5283 else if (SCM_BIGP (n
))
5285 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5286 scm_remember_upto_here_1 (n
);
5287 return scm_take_locale_string (str
);
5289 else if (SCM_FRACTIONP (n
))
5291 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5292 scm_from_locale_string ("/"),
5293 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5295 else if (SCM_INEXACTP (n
))
5297 char num_buf
[FLOBUFLEN
];
5298 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5301 SCM_WRONG_TYPE_ARG (1, n
);
5306 /* These print routines used to be stubbed here so that scm_repl.c
5307 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5310 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5312 char num_buf
[FLOBUFLEN
];
5313 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5318 scm_i_print_double (double val
, SCM port
)
5320 char num_buf
[FLOBUFLEN
];
5321 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5325 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5328 char num_buf
[FLOBUFLEN
];
5329 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5334 scm_i_print_complex (double real
, double imag
, SCM port
)
5336 char num_buf
[FLOBUFLEN
];
5337 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5341 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5344 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5345 scm_display (str
, port
);
5346 scm_remember_upto_here_1 (str
);
5351 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5353 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5354 scm_remember_upto_here_1 (exp
);
5355 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5359 /*** END nums->strs ***/
5362 /*** STRINGS -> NUMBERS ***/
5364 /* The following functions implement the conversion from strings to numbers.
5365 * The implementation somehow follows the grammar for numbers as it is given
5366 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5367 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5368 * points should be noted about the implementation:
5370 * * Each function keeps a local index variable 'idx' that points at the
5371 * current position within the parsed string. The global index is only
5372 * updated if the function could parse the corresponding syntactic unit
5375 * * Similarly, the functions keep track of indicators of inexactness ('#',
5376 * '.' or exponents) using local variables ('hash_seen', 'x').
5378 * * Sequences of digits are parsed into temporary variables holding fixnums.
5379 * Only if these fixnums would overflow, the result variables are updated
5380 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5381 * the temporary variables holding the fixnums are cleared, and the process
5382 * starts over again. If for example fixnums were able to store five decimal
5383 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5384 * and the result was computed as 12345 * 100000 + 67890. In other words,
5385 * only every five digits two bignum operations were performed.
5387 * Notes on the handling of exactness specifiers:
5389 * When parsing non-real complex numbers, we apply exactness specifiers on
5390 * per-component basis, as is done in PLT Scheme. For complex numbers
5391 * written in rectangular form, exactness specifiers are applied to the
5392 * real and imaginary parts before calling scm_make_rectangular. For
5393 * complex numbers written in polar form, exactness specifiers are applied
5394 * to the magnitude and angle before calling scm_make_polar.
5396 * There are two kinds of exactness specifiers: forced and implicit. A
5397 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5398 * the entire number, and applies to both components of a complex number.
5399 * "#e" causes each component to be made exact, and "#i" causes each
5400 * component to be made inexact. If no forced exactness specifier is
5401 * present, then the exactness of each component is determined
5402 * independently by the presence or absence of a decimal point or hash mark
5403 * within that component. If a decimal point or hash mark is present, the
5404 * component is made inexact, otherwise it is made exact.
5406 * After the exactness specifiers have been applied to each component, they
5407 * are passed to either scm_make_rectangular or scm_make_polar to produce
5408 * the final result. Note that this will result in a real number if the
5409 * imaginary part, magnitude, or angle is an exact 0.
5411 * For example, (string->number "#i5.0+0i") does the equivalent of:
5413 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5416 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5418 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5420 /* Caller is responsible for checking that the return value is in range
5421 for the given radix, which should be <= 36. */
5423 char_decimal_value (scm_t_uint32 c
)
5425 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5426 that's certainly above any valid decimal, so we take advantage of
5427 that to elide some tests. */
5428 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5430 /* If that failed, try extended hexadecimals, then. Only accept ascii
5435 if (c
>= (scm_t_uint32
) 'a')
5436 d
= c
- (scm_t_uint32
)'a' + 10U;
5442 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5443 unsigned int radix
, enum t_exactness
*p_exactness
)
5445 unsigned int idx
= *p_idx
;
5446 unsigned int hash_seen
= 0;
5447 scm_t_bits shift
= 1;
5449 unsigned int digit_value
;
5452 size_t len
= scm_i_string_length (mem
);
5457 c
= scm_i_string_ref (mem
, idx
);
5458 digit_value
= char_decimal_value (c
);
5459 if (digit_value
>= radix
)
5463 result
= SCM_I_MAKINUM (digit_value
);
5466 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5476 digit_value
= char_decimal_value (c
);
5477 /* This check catches non-decimals in addition to out-of-range
5479 if (digit_value
>= radix
)
5484 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5486 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5488 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5495 shift
= shift
* radix
;
5496 add
= add
* radix
+ digit_value
;
5501 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5503 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5507 *p_exactness
= INEXACT
;
5513 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5514 * covers the parts of the rules that start at a potential point. The value
5515 * of the digits up to the point have been parsed by the caller and are given
5516 * in variable result. The content of *p_exactness indicates, whether a hash
5517 * has already been seen in the digits before the point.
5520 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5523 mem2decimal_from_point (SCM result
, SCM mem
,
5524 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5526 unsigned int idx
= *p_idx
;
5527 enum t_exactness x
= *p_exactness
;
5528 size_t len
= scm_i_string_length (mem
);
5533 if (scm_i_string_ref (mem
, idx
) == '.')
5535 scm_t_bits shift
= 1;
5537 unsigned int digit_value
;
5538 SCM big_shift
= SCM_INUM1
;
5543 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5544 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5549 digit_value
= DIGIT2UINT (c
);
5560 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5562 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5563 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5565 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5573 add
= add
* 10 + digit_value
;
5579 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5580 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5581 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5584 result
= scm_divide (result
, big_shift
);
5586 /* We've seen a decimal point, thus the value is implicitly inexact. */
5598 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5600 switch (scm_i_string_ref (mem
, idx
))
5612 c
= scm_i_string_ref (mem
, idx
);
5620 c
= scm_i_string_ref (mem
, idx
);
5629 c
= scm_i_string_ref (mem
, idx
);
5634 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5638 exponent
= DIGIT2UINT (c
);
5641 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5642 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5645 if (exponent
<= SCM_MAXEXP
)
5646 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5652 if (exponent
> SCM_MAXEXP
)
5654 size_t exp_len
= idx
- start
;
5655 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5656 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5657 scm_out_of_range ("string->number", exp_num
);
5660 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5662 result
= scm_product (result
, e
);
5664 result
= scm_divide (result
, e
);
5666 /* We've seen an exponent, thus the value is implicitly inexact. */
5684 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5687 mem2ureal (SCM mem
, unsigned int *p_idx
,
5688 unsigned int radix
, enum t_exactness forced_x
)
5690 unsigned int idx
= *p_idx
;
5692 size_t len
= scm_i_string_length (mem
);
5694 /* Start off believing that the number will be exact. This changes
5695 to INEXACT if we see a decimal point or a hash. */
5696 enum t_exactness implicit_x
= EXACT
;
5701 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5707 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5709 /* Cobble up the fractional part. We might want to set the
5710 NaN's mantissa from it. */
5712 mem2uinteger (mem
, &idx
, 10, &implicit_x
);
5717 if (scm_i_string_ref (mem
, idx
) == '.')
5721 else if (idx
+ 1 == len
)
5723 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5726 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5727 p_idx
, &implicit_x
);
5733 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5734 if (scm_is_false (uinteger
))
5739 else if (scm_i_string_ref (mem
, idx
) == '/')
5747 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5748 if (scm_is_false (divisor
))
5751 /* both are int/big here, I assume */
5752 result
= scm_i_make_ratio (uinteger
, divisor
);
5754 else if (radix
== 10)
5756 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5757 if (scm_is_false (result
))
5769 if (SCM_INEXACTP (result
))
5770 return scm_inexact_to_exact (result
);
5774 if (SCM_INEXACTP (result
))
5777 return scm_exact_to_inexact (result
);
5779 if (implicit_x
== INEXACT
)
5781 if (SCM_INEXACTP (result
))
5784 return scm_exact_to_inexact (result
);
5790 /* We should never get here */
5791 scm_syserror ("mem2ureal");
5795 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5798 mem2complex (SCM mem
, unsigned int idx
,
5799 unsigned int radix
, enum t_exactness forced_x
)
5804 size_t len
= scm_i_string_length (mem
);
5809 c
= scm_i_string_ref (mem
, idx
);
5824 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5825 if (scm_is_false (ureal
))
5827 /* input must be either +i or -i */
5832 if (scm_i_string_ref (mem
, idx
) == 'i'
5833 || scm_i_string_ref (mem
, idx
) == 'I')
5839 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5846 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5847 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5852 c
= scm_i_string_ref (mem
, idx
);
5856 /* either +<ureal>i or -<ureal>i */
5863 return scm_make_rectangular (SCM_INUM0
, ureal
);
5866 /* polar input: <real>@<real>. */
5877 c
= scm_i_string_ref (mem
, idx
);
5895 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5896 if (scm_is_false (angle
))
5901 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5902 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5904 result
= scm_make_polar (ureal
, angle
);
5909 /* expecting input matching <real>[+-]<ureal>?i */
5916 int sign
= (c
== '+') ? 1 : -1;
5917 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5919 if (scm_is_false (imag
))
5920 imag
= SCM_I_MAKINUM (sign
);
5921 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5922 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5926 if (scm_i_string_ref (mem
, idx
) != 'i'
5927 && scm_i_string_ref (mem
, idx
) != 'I')
5934 return scm_make_rectangular (ureal
, imag
);
5943 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5945 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5948 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5950 unsigned int idx
= 0;
5951 unsigned int radix
= NO_RADIX
;
5952 enum t_exactness forced_x
= NO_EXACTNESS
;
5953 size_t len
= scm_i_string_length (mem
);
5955 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5956 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5958 switch (scm_i_string_ref (mem
, idx
+ 1))
5961 if (radix
!= NO_RADIX
)
5966 if (radix
!= NO_RADIX
)
5971 if (forced_x
!= NO_EXACTNESS
)
5976 if (forced_x
!= NO_EXACTNESS
)
5981 if (radix
!= NO_RADIX
)
5986 if (radix
!= NO_RADIX
)
5996 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5997 if (radix
== NO_RADIX
)
5998 radix
= default_radix
;
6000 return mem2complex (mem
, idx
, radix
, forced_x
);
6004 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6005 unsigned int default_radix
)
6007 SCM str
= scm_from_locale_stringn (mem
, len
);
6009 return scm_i_string_to_number (str
, default_radix
);
6013 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6014 (SCM string
, SCM radix
),
6015 "Return a number of the maximally precise representation\n"
6016 "expressed by the given @var{string}. @var{radix} must be an\n"
6017 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6018 "is a default radix that may be overridden by an explicit radix\n"
6019 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6020 "supplied, then the default radix is 10. If string is not a\n"
6021 "syntactically valid notation for a number, then\n"
6022 "@code{string->number} returns @code{#f}.")
6023 #define FUNC_NAME s_scm_string_to_number
6027 SCM_VALIDATE_STRING (1, string
);
6029 if (SCM_UNBNDP (radix
))
6032 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6034 answer
= scm_i_string_to_number (string
, base
);
6035 scm_remember_upto_here_1 (string
);
6041 /*** END strs->nums ***/
6044 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6046 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6048 #define FUNC_NAME s_scm_number_p
6050 return scm_from_bool (SCM_NUMBERP (x
));
6054 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6056 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6057 "otherwise. Note that the sets of real, rational and integer\n"
6058 "values form subsets of the set of complex numbers, i. e. the\n"
6059 "predicate will also be fulfilled if @var{x} is a real,\n"
6060 "rational or integer number.")
6061 #define FUNC_NAME s_scm_complex_p
6063 /* all numbers are complex. */
6064 return scm_number_p (x
);
6068 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6070 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6071 "otherwise. Note that the set of integer values forms a subset of\n"
6072 "the set of real numbers, i. e. the predicate will also be\n"
6073 "fulfilled if @var{x} is an integer number.")
6074 #define FUNC_NAME s_scm_real_p
6076 return scm_from_bool
6077 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6081 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6083 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6084 "otherwise. Note that the set of integer values forms a subset of\n"
6085 "the set of rational numbers, i. e. the predicate will also be\n"
6086 "fulfilled if @var{x} is an integer number.")
6087 #define FUNC_NAME s_scm_rational_p
6089 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6091 else if (SCM_REALP (x
))
6092 /* due to their limited precision, finite floating point numbers are
6093 rational as well. (finite means neither infinity nor a NaN) */
6094 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6100 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6102 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6104 #define FUNC_NAME s_scm_integer_p
6106 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6108 else if (SCM_REALP (x
))
6110 double val
= SCM_REAL_VALUE (x
);
6111 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6119 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6120 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6121 (SCM x
, SCM y
, SCM rest
),
6122 "Return @code{#t} if all parameters are numerically equal.")
6123 #define FUNC_NAME s_scm_i_num_eq_p
6125 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6127 while (!scm_is_null (rest
))
6129 if (scm_is_false (scm_num_eq_p (x
, y
)))
6133 rest
= scm_cdr (rest
);
6135 return scm_num_eq_p (x
, y
);
6139 scm_num_eq_p (SCM x
, SCM y
)
6142 if (SCM_I_INUMP (x
))
6144 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6145 if (SCM_I_INUMP (y
))
6147 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6148 return scm_from_bool (xx
== yy
);
6150 else if (SCM_BIGP (y
))
6152 else if (SCM_REALP (y
))
6154 /* On a 32-bit system an inum fits a double, we can cast the inum
6155 to a double and compare.
6157 But on a 64-bit system an inum is bigger than a double and
6158 casting it to a double (call that dxx) will round. dxx is at
6159 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6160 an integer and fits a long. So we cast yy to a long and
6161 compare with plain xx.
6163 An alternative (for any size system actually) would be to check
6164 yy is an integer (with floor) and is in range of an inum
6165 (compare against appropriate powers of 2) then test
6166 xx==(scm_t_signed_bits)yy. It's just a matter of which
6167 casts/comparisons might be fastest or easiest for the cpu. */
6169 double yy
= SCM_REAL_VALUE (y
);
6170 return scm_from_bool ((double) xx
== yy
6171 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6172 || xx
== (scm_t_signed_bits
) yy
));
6174 else if (SCM_COMPLEXP (y
))
6175 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6176 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6177 else if (SCM_FRACTIONP (y
))
6180 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6183 else if (SCM_BIGP (x
))
6185 if (SCM_I_INUMP (y
))
6187 else if (SCM_BIGP (y
))
6189 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6190 scm_remember_upto_here_2 (x
, y
);
6191 return scm_from_bool (0 == cmp
);
6193 else if (SCM_REALP (y
))
6196 if (isnan (SCM_REAL_VALUE (y
)))
6198 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6199 scm_remember_upto_here_1 (x
);
6200 return scm_from_bool (0 == cmp
);
6202 else if (SCM_COMPLEXP (y
))
6205 if (0.0 != SCM_COMPLEX_IMAG (y
))
6207 if (isnan (SCM_COMPLEX_REAL (y
)))
6209 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6210 scm_remember_upto_here_1 (x
);
6211 return scm_from_bool (0 == cmp
);
6213 else if (SCM_FRACTIONP (y
))
6216 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6219 else if (SCM_REALP (x
))
6221 double xx
= SCM_REAL_VALUE (x
);
6222 if (SCM_I_INUMP (y
))
6224 /* see comments with inum/real above */
6225 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6226 return scm_from_bool (xx
== (double) yy
6227 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6228 || (scm_t_signed_bits
) xx
== yy
));
6230 else if (SCM_BIGP (y
))
6233 if (isnan (SCM_REAL_VALUE (x
)))
6235 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6236 scm_remember_upto_here_1 (y
);
6237 return scm_from_bool (0 == cmp
);
6239 else if (SCM_REALP (y
))
6240 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6241 else if (SCM_COMPLEXP (y
))
6242 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6243 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6244 else if (SCM_FRACTIONP (y
))
6246 double xx
= SCM_REAL_VALUE (x
);
6250 return scm_from_bool (xx
< 0.0);
6251 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6255 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6258 else if (SCM_COMPLEXP (x
))
6260 if (SCM_I_INUMP (y
))
6261 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6262 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6263 else if (SCM_BIGP (y
))
6266 if (0.0 != SCM_COMPLEX_IMAG (x
))
6268 if (isnan (SCM_COMPLEX_REAL (x
)))
6270 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6271 scm_remember_upto_here_1 (y
);
6272 return scm_from_bool (0 == cmp
);
6274 else if (SCM_REALP (y
))
6275 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6276 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6277 else if (SCM_COMPLEXP (y
))
6278 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6279 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6280 else if (SCM_FRACTIONP (y
))
6283 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6285 xx
= SCM_COMPLEX_REAL (x
);
6289 return scm_from_bool (xx
< 0.0);
6290 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6294 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6297 else if (SCM_FRACTIONP (x
))
6299 if (SCM_I_INUMP (y
))
6301 else if (SCM_BIGP (y
))
6303 else if (SCM_REALP (y
))
6305 double yy
= SCM_REAL_VALUE (y
);
6309 return scm_from_bool (0.0 < yy
);
6310 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6313 else if (SCM_COMPLEXP (y
))
6316 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6318 yy
= SCM_COMPLEX_REAL (y
);
6322 return scm_from_bool (0.0 < yy
);
6323 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6326 else if (SCM_FRACTIONP (y
))
6327 return scm_i_fraction_equalp (x
, y
);
6329 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6333 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6338 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6339 done are good for inums, but for bignums an answer can almost always be
6340 had by just examining a few high bits of the operands, as done by GMP in
6341 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6342 of the float exponent to take into account. */
6344 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6345 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6346 (SCM x
, SCM y
, SCM rest
),
6347 "Return @code{#t} if the list of parameters is monotonically\n"
6349 #define FUNC_NAME s_scm_i_num_less_p
6351 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6353 while (!scm_is_null (rest
))
6355 if (scm_is_false (scm_less_p (x
, y
)))
6359 rest
= scm_cdr (rest
);
6361 return scm_less_p (x
, y
);
6365 scm_less_p (SCM x
, SCM y
)
6368 if (SCM_I_INUMP (x
))
6370 scm_t_inum xx
= SCM_I_INUM (x
);
6371 if (SCM_I_INUMP (y
))
6373 scm_t_inum yy
= SCM_I_INUM (y
);
6374 return scm_from_bool (xx
< yy
);
6376 else if (SCM_BIGP (y
))
6378 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6379 scm_remember_upto_here_1 (y
);
6380 return scm_from_bool (sgn
> 0);
6382 else if (SCM_REALP (y
))
6383 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6384 else if (SCM_FRACTIONP (y
))
6386 /* "x < a/b" becomes "x*b < a" */
6388 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6389 y
= SCM_FRACTION_NUMERATOR (y
);
6393 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6394 s_scm_i_num_less_p
);
6396 else if (SCM_BIGP (x
))
6398 if (SCM_I_INUMP (y
))
6400 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6401 scm_remember_upto_here_1 (x
);
6402 return scm_from_bool (sgn
< 0);
6404 else if (SCM_BIGP (y
))
6406 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6407 scm_remember_upto_here_2 (x
, y
);
6408 return scm_from_bool (cmp
< 0);
6410 else if (SCM_REALP (y
))
6413 if (isnan (SCM_REAL_VALUE (y
)))
6415 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6416 scm_remember_upto_here_1 (x
);
6417 return scm_from_bool (cmp
< 0);
6419 else if (SCM_FRACTIONP (y
))
6422 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6423 s_scm_i_num_less_p
);
6425 else if (SCM_REALP (x
))
6427 if (SCM_I_INUMP (y
))
6428 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6429 else if (SCM_BIGP (y
))
6432 if (isnan (SCM_REAL_VALUE (x
)))
6434 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6435 scm_remember_upto_here_1 (y
);
6436 return scm_from_bool (cmp
> 0);
6438 else if (SCM_REALP (y
))
6439 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6440 else if (SCM_FRACTIONP (y
))
6442 double xx
= SCM_REAL_VALUE (x
);
6446 return scm_from_bool (xx
< 0.0);
6447 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6451 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6452 s_scm_i_num_less_p
);
6454 else if (SCM_FRACTIONP (x
))
6456 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6458 /* "a/b < y" becomes "a < y*b" */
6459 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6460 x
= SCM_FRACTION_NUMERATOR (x
);
6463 else if (SCM_REALP (y
))
6465 double yy
= SCM_REAL_VALUE (y
);
6469 return scm_from_bool (0.0 < yy
);
6470 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6473 else if (SCM_FRACTIONP (y
))
6475 /* "a/b < c/d" becomes "a*d < c*b" */
6476 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6477 SCM_FRACTION_DENOMINATOR (y
));
6478 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6479 SCM_FRACTION_DENOMINATOR (x
));
6485 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6486 s_scm_i_num_less_p
);
6489 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6490 s_scm_i_num_less_p
);
6494 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6495 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6496 (SCM x
, SCM y
, SCM rest
),
6497 "Return @code{#t} if the list of parameters is monotonically\n"
6499 #define FUNC_NAME s_scm_i_num_gr_p
6501 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6503 while (!scm_is_null (rest
))
6505 if (scm_is_false (scm_gr_p (x
, y
)))
6509 rest
= scm_cdr (rest
);
6511 return scm_gr_p (x
, y
);
6514 #define FUNC_NAME s_scm_i_num_gr_p
6516 scm_gr_p (SCM x
, SCM y
)
6518 if (!SCM_NUMBERP (x
))
6519 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6520 else if (!SCM_NUMBERP (y
))
6521 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6523 return scm_less_p (y
, x
);
6528 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6529 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6530 (SCM x
, SCM y
, SCM rest
),
6531 "Return @code{#t} if the list of parameters is monotonically\n"
6533 #define FUNC_NAME s_scm_i_num_leq_p
6535 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6537 while (!scm_is_null (rest
))
6539 if (scm_is_false (scm_leq_p (x
, y
)))
6543 rest
= scm_cdr (rest
);
6545 return scm_leq_p (x
, y
);
6548 #define FUNC_NAME s_scm_i_num_leq_p
6550 scm_leq_p (SCM x
, SCM y
)
6552 if (!SCM_NUMBERP (x
))
6553 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6554 else if (!SCM_NUMBERP (y
))
6555 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6556 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6559 return scm_not (scm_less_p (y
, x
));
6564 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6565 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6566 (SCM x
, SCM y
, SCM rest
),
6567 "Return @code{#t} if the list of parameters is monotonically\n"
6569 #define FUNC_NAME s_scm_i_num_geq_p
6571 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6573 while (!scm_is_null (rest
))
6575 if (scm_is_false (scm_geq_p (x
, y
)))
6579 rest
= scm_cdr (rest
);
6581 return scm_geq_p (x
, y
);
6584 #define FUNC_NAME s_scm_i_num_geq_p
6586 scm_geq_p (SCM x
, SCM y
)
6588 if (!SCM_NUMBERP (x
))
6589 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6590 else if (!SCM_NUMBERP (y
))
6591 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6592 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6595 return scm_not (scm_less_p (x
, y
));
6600 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6602 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6604 #define FUNC_NAME s_scm_zero_p
6606 if (SCM_I_INUMP (z
))
6607 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6608 else if (SCM_BIGP (z
))
6610 else if (SCM_REALP (z
))
6611 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6612 else if (SCM_COMPLEXP (z
))
6613 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6614 && SCM_COMPLEX_IMAG (z
) == 0.0);
6615 else if (SCM_FRACTIONP (z
))
6618 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6623 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6625 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6627 #define FUNC_NAME s_scm_positive_p
6629 if (SCM_I_INUMP (x
))
6630 return scm_from_bool (SCM_I_INUM (x
) > 0);
6631 else if (SCM_BIGP (x
))
6633 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6634 scm_remember_upto_here_1 (x
);
6635 return scm_from_bool (sgn
> 0);
6637 else if (SCM_REALP (x
))
6638 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6639 else if (SCM_FRACTIONP (x
))
6640 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6642 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6647 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6649 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6651 #define FUNC_NAME s_scm_negative_p
6653 if (SCM_I_INUMP (x
))
6654 return scm_from_bool (SCM_I_INUM (x
) < 0);
6655 else if (SCM_BIGP (x
))
6657 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6658 scm_remember_upto_here_1 (x
);
6659 return scm_from_bool (sgn
< 0);
6661 else if (SCM_REALP (x
))
6662 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6663 else if (SCM_FRACTIONP (x
))
6664 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6666 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6671 /* scm_min and scm_max return an inexact when either argument is inexact, as
6672 required by r5rs. On that basis, for exact/inexact combinations the
6673 exact is converted to inexact to compare and possibly return. This is
6674 unlike scm_less_p above which takes some trouble to preserve all bits in
6675 its test, such trouble is not required for min and max. */
6677 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6678 (SCM x
, SCM y
, SCM rest
),
6679 "Return the maximum of all parameter values.")
6680 #define FUNC_NAME s_scm_i_max
6682 while (!scm_is_null (rest
))
6683 { x
= scm_max (x
, y
);
6685 rest
= scm_cdr (rest
);
6687 return scm_max (x
, y
);
6691 #define s_max s_scm_i_max
6692 #define g_max g_scm_i_max
6695 scm_max (SCM x
, SCM y
)
6700 return scm_wta_dispatch_0 (g_max
, s_max
);
6701 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6704 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
6707 if (SCM_I_INUMP (x
))
6709 scm_t_inum xx
= SCM_I_INUM (x
);
6710 if (SCM_I_INUMP (y
))
6712 scm_t_inum yy
= SCM_I_INUM (y
);
6713 return (xx
< yy
) ? y
: x
;
6715 else if (SCM_BIGP (y
))
6717 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6718 scm_remember_upto_here_1 (y
);
6719 return (sgn
< 0) ? x
: y
;
6721 else if (SCM_REALP (y
))
6724 double yyd
= SCM_REAL_VALUE (y
);
6727 return scm_from_double (xxd
);
6728 /* If y is a NaN, then "==" is false and we return the NaN */
6729 else if (SCM_LIKELY (!(xxd
== yyd
)))
6731 /* Handle signed zeroes properly */
6737 else if (SCM_FRACTIONP (y
))
6740 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6743 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6745 else if (SCM_BIGP (x
))
6747 if (SCM_I_INUMP (y
))
6749 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6750 scm_remember_upto_here_1 (x
);
6751 return (sgn
< 0) ? y
: x
;
6753 else if (SCM_BIGP (y
))
6755 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6756 scm_remember_upto_here_2 (x
, y
);
6757 return (cmp
> 0) ? x
: y
;
6759 else if (SCM_REALP (y
))
6761 /* if y==NaN then xx>yy is false, so we return the NaN y */
6764 xx
= scm_i_big2dbl (x
);
6765 yy
= SCM_REAL_VALUE (y
);
6766 return (xx
> yy
? scm_from_double (xx
) : y
);
6768 else if (SCM_FRACTIONP (y
))
6773 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6775 else if (SCM_REALP (x
))
6777 if (SCM_I_INUMP (y
))
6779 scm_t_inum yy
= SCM_I_INUM (y
);
6780 double xxd
= SCM_REAL_VALUE (x
);
6784 return scm_from_double (yyd
);
6785 /* If x is a NaN, then "==" is false and we return the NaN */
6786 else if (SCM_LIKELY (!(xxd
== yyd
)))
6788 /* Handle signed zeroes properly */
6794 else if (SCM_BIGP (y
))
6799 else if (SCM_REALP (y
))
6801 double xx
= SCM_REAL_VALUE (x
);
6802 double yy
= SCM_REAL_VALUE (y
);
6804 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6807 else if (SCM_LIKELY (xx
< yy
))
6809 /* If neither (xx > yy) nor (xx < yy), then
6810 either they're equal or one is a NaN */
6811 else if (SCM_UNLIKELY (isnan (xx
)))
6812 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6813 else if (SCM_UNLIKELY (isnan (yy
)))
6814 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6815 /* xx == yy, but handle signed zeroes properly */
6816 else if (double_is_non_negative_zero (yy
))
6821 else if (SCM_FRACTIONP (y
))
6823 double yy
= scm_i_fraction2double (y
);
6824 double xx
= SCM_REAL_VALUE (x
);
6825 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6828 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6830 else if (SCM_FRACTIONP (x
))
6832 if (SCM_I_INUMP (y
))
6836 else if (SCM_BIGP (y
))
6840 else if (SCM_REALP (y
))
6842 double xx
= scm_i_fraction2double (x
);
6843 /* if y==NaN then ">" is false, so we return the NaN y */
6844 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6846 else if (SCM_FRACTIONP (y
))
6851 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6854 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6858 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6859 (SCM x
, SCM y
, SCM rest
),
6860 "Return the minimum of all parameter values.")
6861 #define FUNC_NAME s_scm_i_min
6863 while (!scm_is_null (rest
))
6864 { x
= scm_min (x
, y
);
6866 rest
= scm_cdr (rest
);
6868 return scm_min (x
, y
);
6872 #define s_min s_scm_i_min
6873 #define g_min g_scm_i_min
6876 scm_min (SCM x
, SCM y
)
6881 return scm_wta_dispatch_0 (g_min
, s_min
);
6882 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6885 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
6888 if (SCM_I_INUMP (x
))
6890 scm_t_inum xx
= SCM_I_INUM (x
);
6891 if (SCM_I_INUMP (y
))
6893 scm_t_inum yy
= SCM_I_INUM (y
);
6894 return (xx
< yy
) ? x
: y
;
6896 else if (SCM_BIGP (y
))
6898 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6899 scm_remember_upto_here_1 (y
);
6900 return (sgn
< 0) ? y
: x
;
6902 else if (SCM_REALP (y
))
6905 /* if y==NaN then "<" is false and we return NaN */
6906 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6908 else if (SCM_FRACTIONP (y
))
6911 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6914 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6916 else if (SCM_BIGP (x
))
6918 if (SCM_I_INUMP (y
))
6920 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6921 scm_remember_upto_here_1 (x
);
6922 return (sgn
< 0) ? x
: y
;
6924 else if (SCM_BIGP (y
))
6926 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6927 scm_remember_upto_here_2 (x
, y
);
6928 return (cmp
> 0) ? y
: x
;
6930 else if (SCM_REALP (y
))
6932 /* if y==NaN then xx<yy is false, so we return the NaN y */
6935 xx
= scm_i_big2dbl (x
);
6936 yy
= SCM_REAL_VALUE (y
);
6937 return (xx
< yy
? scm_from_double (xx
) : y
);
6939 else if (SCM_FRACTIONP (y
))
6944 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6946 else if (SCM_REALP (x
))
6948 if (SCM_I_INUMP (y
))
6950 double z
= SCM_I_INUM (y
);
6951 /* if x==NaN then "<" is false and we return NaN */
6952 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6954 else if (SCM_BIGP (y
))
6959 else if (SCM_REALP (y
))
6961 double xx
= SCM_REAL_VALUE (x
);
6962 double yy
= SCM_REAL_VALUE (y
);
6964 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6967 else if (SCM_LIKELY (xx
> yy
))
6969 /* If neither (xx < yy) nor (xx > yy), then
6970 either they're equal or one is a NaN */
6971 else if (SCM_UNLIKELY (isnan (xx
)))
6972 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6973 else if (SCM_UNLIKELY (isnan (yy
)))
6974 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6975 /* xx == yy, but handle signed zeroes properly */
6976 else if (double_is_non_negative_zero (xx
))
6981 else if (SCM_FRACTIONP (y
))
6983 double yy
= scm_i_fraction2double (y
);
6984 double xx
= SCM_REAL_VALUE (x
);
6985 return (yy
< xx
) ? scm_from_double (yy
) : x
;
6988 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6990 else if (SCM_FRACTIONP (x
))
6992 if (SCM_I_INUMP (y
))
6996 else if (SCM_BIGP (y
))
7000 else if (SCM_REALP (y
))
7002 double xx
= scm_i_fraction2double (x
);
7003 /* if y==NaN then "<" is false, so we return the NaN y */
7004 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7006 else if (SCM_FRACTIONP (y
))
7011 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7014 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7018 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7019 (SCM x
, SCM y
, SCM rest
),
7020 "Return the sum of all parameter values. Return 0 if called without\n"
7022 #define FUNC_NAME s_scm_i_sum
7024 while (!scm_is_null (rest
))
7025 { x
= scm_sum (x
, y
);
7027 rest
= scm_cdr (rest
);
7029 return scm_sum (x
, y
);
7033 #define s_sum s_scm_i_sum
7034 #define g_sum g_scm_i_sum
7037 scm_sum (SCM x
, SCM y
)
7039 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7041 if (SCM_NUMBERP (x
)) return x
;
7042 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7043 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7046 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7048 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7050 scm_t_inum xx
= SCM_I_INUM (x
);
7051 scm_t_inum yy
= SCM_I_INUM (y
);
7052 scm_t_inum z
= xx
+ yy
;
7053 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7055 else if (SCM_BIGP (y
))
7060 else if (SCM_REALP (y
))
7062 scm_t_inum xx
= SCM_I_INUM (x
);
7063 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7065 else if (SCM_COMPLEXP (y
))
7067 scm_t_inum xx
= SCM_I_INUM (x
);
7068 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7069 SCM_COMPLEX_IMAG (y
));
7071 else if (SCM_FRACTIONP (y
))
7072 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7073 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7074 SCM_FRACTION_DENOMINATOR (y
));
7076 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7077 } else if (SCM_BIGP (x
))
7079 if (SCM_I_INUMP (y
))
7084 inum
= SCM_I_INUM (y
);
7087 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7090 SCM result
= scm_i_mkbig ();
7091 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7092 scm_remember_upto_here_1 (x
);
7093 /* we know the result will have to be a bignum */
7096 return scm_i_normbig (result
);
7100 SCM result
= scm_i_mkbig ();
7101 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7102 scm_remember_upto_here_1 (x
);
7103 /* we know the result will have to be a bignum */
7106 return scm_i_normbig (result
);
7109 else if (SCM_BIGP (y
))
7111 SCM result
= scm_i_mkbig ();
7112 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7113 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7114 mpz_add (SCM_I_BIG_MPZ (result
),
7117 scm_remember_upto_here_2 (x
, y
);
7118 /* we know the result will have to be a bignum */
7121 return scm_i_normbig (result
);
7123 else if (SCM_REALP (y
))
7125 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7126 scm_remember_upto_here_1 (x
);
7127 return scm_from_double (result
);
7129 else if (SCM_COMPLEXP (y
))
7131 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7132 + SCM_COMPLEX_REAL (y
));
7133 scm_remember_upto_here_1 (x
);
7134 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7136 else if (SCM_FRACTIONP (y
))
7137 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7138 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7139 SCM_FRACTION_DENOMINATOR (y
));
7141 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7143 else if (SCM_REALP (x
))
7145 if (SCM_I_INUMP (y
))
7146 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7147 else if (SCM_BIGP (y
))
7149 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7150 scm_remember_upto_here_1 (y
);
7151 return scm_from_double (result
);
7153 else if (SCM_REALP (y
))
7154 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7155 else if (SCM_COMPLEXP (y
))
7156 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7157 SCM_COMPLEX_IMAG (y
));
7158 else if (SCM_FRACTIONP (y
))
7159 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7161 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7163 else if (SCM_COMPLEXP (x
))
7165 if (SCM_I_INUMP (y
))
7166 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7167 SCM_COMPLEX_IMAG (x
));
7168 else if (SCM_BIGP (y
))
7170 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7171 + SCM_COMPLEX_REAL (x
));
7172 scm_remember_upto_here_1 (y
);
7173 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7175 else if (SCM_REALP (y
))
7176 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7177 SCM_COMPLEX_IMAG (x
));
7178 else if (SCM_COMPLEXP (y
))
7179 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7180 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7181 else if (SCM_FRACTIONP (y
))
7182 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7183 SCM_COMPLEX_IMAG (x
));
7185 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7187 else if (SCM_FRACTIONP (x
))
7189 if (SCM_I_INUMP (y
))
7190 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7191 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7192 SCM_FRACTION_DENOMINATOR (x
));
7193 else if (SCM_BIGP (y
))
7194 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7195 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7196 SCM_FRACTION_DENOMINATOR (x
));
7197 else if (SCM_REALP (y
))
7198 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7199 else if (SCM_COMPLEXP (y
))
7200 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7201 SCM_COMPLEX_IMAG (y
));
7202 else if (SCM_FRACTIONP (y
))
7203 /* a/b + c/d = (ad + bc) / bd */
7204 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7205 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7206 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7208 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7211 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7215 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7217 "Return @math{@var{x}+1}.")
7218 #define FUNC_NAME s_scm_oneplus
7220 return scm_sum (x
, SCM_INUM1
);
7225 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7226 (SCM x
, SCM y
, SCM rest
),
7227 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7228 "the sum of all but the first argument are subtracted from the first\n"
7230 #define FUNC_NAME s_scm_i_difference
7232 while (!scm_is_null (rest
))
7233 { x
= scm_difference (x
, y
);
7235 rest
= scm_cdr (rest
);
7237 return scm_difference (x
, y
);
7241 #define s_difference s_scm_i_difference
7242 #define g_difference g_scm_i_difference
7245 scm_difference (SCM x
, SCM y
)
7246 #define FUNC_NAME s_difference
7248 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7251 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7253 if (SCM_I_INUMP (x
))
7255 scm_t_inum xx
= -SCM_I_INUM (x
);
7256 if (SCM_FIXABLE (xx
))
7257 return SCM_I_MAKINUM (xx
);
7259 return scm_i_inum2big (xx
);
7261 else if (SCM_BIGP (x
))
7262 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7263 bignum, but negating that gives a fixnum. */
7264 return scm_i_normbig (scm_i_clonebig (x
, 0));
7265 else if (SCM_REALP (x
))
7266 return scm_from_double (-SCM_REAL_VALUE (x
));
7267 else if (SCM_COMPLEXP (x
))
7268 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7269 -SCM_COMPLEX_IMAG (x
));
7270 else if (SCM_FRACTIONP (x
))
7271 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7272 SCM_FRACTION_DENOMINATOR (x
));
7274 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7277 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7279 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7281 scm_t_inum xx
= SCM_I_INUM (x
);
7282 scm_t_inum yy
= SCM_I_INUM (y
);
7283 scm_t_inum z
= xx
- yy
;
7284 if (SCM_FIXABLE (z
))
7285 return SCM_I_MAKINUM (z
);
7287 return scm_i_inum2big (z
);
7289 else if (SCM_BIGP (y
))
7291 /* inum-x - big-y */
7292 scm_t_inum xx
= SCM_I_INUM (x
);
7296 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7297 bignum, but negating that gives a fixnum. */
7298 return scm_i_normbig (scm_i_clonebig (y
, 0));
7302 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7303 SCM result
= scm_i_mkbig ();
7306 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7309 /* x - y == -(y + -x) */
7310 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7311 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7313 scm_remember_upto_here_1 (y
);
7315 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7316 /* we know the result will have to be a bignum */
7319 return scm_i_normbig (result
);
7322 else if (SCM_REALP (y
))
7324 scm_t_inum xx
= SCM_I_INUM (x
);
7327 * We need to handle x == exact 0
7328 * specially because R6RS states that:
7329 * (- 0.0) ==> -0.0 and
7330 * (- 0.0 0.0) ==> 0.0
7331 * and the scheme compiler changes
7332 * (- 0.0) into (- 0 0.0)
7333 * So we need to treat (- 0 0.0) like (- 0.0).
7334 * At the C level, (-x) is different than (0.0 - x).
7335 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7338 return scm_from_double (- SCM_REAL_VALUE (y
));
7340 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7342 else if (SCM_COMPLEXP (y
))
7344 scm_t_inum xx
= SCM_I_INUM (x
);
7346 /* We need to handle x == exact 0 specially.
7347 See the comment above (for SCM_REALP (y)) */
7349 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7350 - SCM_COMPLEX_IMAG (y
));
7352 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7353 - SCM_COMPLEX_IMAG (y
));
7355 else if (SCM_FRACTIONP (y
))
7356 /* a - b/c = (ac - b) / c */
7357 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7358 SCM_FRACTION_NUMERATOR (y
)),
7359 SCM_FRACTION_DENOMINATOR (y
));
7361 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7363 else if (SCM_BIGP (x
))
7365 if (SCM_I_INUMP (y
))
7367 /* big-x - inum-y */
7368 scm_t_inum yy
= SCM_I_INUM (y
);
7369 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7371 scm_remember_upto_here_1 (x
);
7373 return (SCM_FIXABLE (-yy
) ?
7374 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7377 SCM result
= scm_i_mkbig ();
7380 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7382 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7383 scm_remember_upto_here_1 (x
);
7385 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7386 /* we know the result will have to be a bignum */
7389 return scm_i_normbig (result
);
7392 else if (SCM_BIGP (y
))
7394 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7395 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7396 SCM result
= scm_i_mkbig ();
7397 mpz_sub (SCM_I_BIG_MPZ (result
),
7400 scm_remember_upto_here_2 (x
, y
);
7401 /* we know the result will have to be a bignum */
7402 if ((sgn_x
== 1) && (sgn_y
== -1))
7404 if ((sgn_x
== -1) && (sgn_y
== 1))
7406 return scm_i_normbig (result
);
7408 else if (SCM_REALP (y
))
7410 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7411 scm_remember_upto_here_1 (x
);
7412 return scm_from_double (result
);
7414 else if (SCM_COMPLEXP (y
))
7416 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7417 - SCM_COMPLEX_REAL (y
));
7418 scm_remember_upto_here_1 (x
);
7419 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7421 else if (SCM_FRACTIONP (y
))
7422 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7423 SCM_FRACTION_NUMERATOR (y
)),
7424 SCM_FRACTION_DENOMINATOR (y
));
7426 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7428 else if (SCM_REALP (x
))
7430 if (SCM_I_INUMP (y
))
7431 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7432 else if (SCM_BIGP (y
))
7434 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7435 scm_remember_upto_here_1 (x
);
7436 return scm_from_double (result
);
7438 else if (SCM_REALP (y
))
7439 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7440 else if (SCM_COMPLEXP (y
))
7441 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7442 -SCM_COMPLEX_IMAG (y
));
7443 else if (SCM_FRACTIONP (y
))
7444 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7446 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7448 else if (SCM_COMPLEXP (x
))
7450 if (SCM_I_INUMP (y
))
7451 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7452 SCM_COMPLEX_IMAG (x
));
7453 else if (SCM_BIGP (y
))
7455 double real_part
= (SCM_COMPLEX_REAL (x
)
7456 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7457 scm_remember_upto_here_1 (x
);
7458 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7460 else if (SCM_REALP (y
))
7461 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7462 SCM_COMPLEX_IMAG (x
));
7463 else if (SCM_COMPLEXP (y
))
7464 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7465 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7466 else if (SCM_FRACTIONP (y
))
7467 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7468 SCM_COMPLEX_IMAG (x
));
7470 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7472 else if (SCM_FRACTIONP (x
))
7474 if (SCM_I_INUMP (y
))
7475 /* a/b - c = (a - cb) / b */
7476 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7477 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7478 SCM_FRACTION_DENOMINATOR (x
));
7479 else if (SCM_BIGP (y
))
7480 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7481 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7482 SCM_FRACTION_DENOMINATOR (x
));
7483 else if (SCM_REALP (y
))
7484 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7485 else if (SCM_COMPLEXP (y
))
7486 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7487 -SCM_COMPLEX_IMAG (y
));
7488 else if (SCM_FRACTIONP (y
))
7489 /* a/b - c/d = (ad - bc) / bd */
7490 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7491 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7492 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7494 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7497 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7502 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7504 "Return @math{@var{x}-1}.")
7505 #define FUNC_NAME s_scm_oneminus
7507 return scm_difference (x
, SCM_INUM1
);
7512 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7513 (SCM x
, SCM y
, SCM rest
),
7514 "Return the product of all arguments. If called without arguments,\n"
7516 #define FUNC_NAME s_scm_i_product
7518 while (!scm_is_null (rest
))
7519 { x
= scm_product (x
, y
);
7521 rest
= scm_cdr (rest
);
7523 return scm_product (x
, y
);
7527 #define s_product s_scm_i_product
7528 #define g_product g_scm_i_product
7531 scm_product (SCM x
, SCM y
)
7533 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7536 return SCM_I_MAKINUM (1L);
7537 else if (SCM_NUMBERP (x
))
7540 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7543 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7548 xx
= SCM_I_INUM (x
);
7553 /* exact1 is the universal multiplicative identity */
7557 /* exact0 times a fixnum is exact0: optimize this case */
7558 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7560 /* if the other argument is inexact, the result is inexact,
7561 and we must do the multiplication in order to handle
7562 infinities and NaNs properly. */
7563 else if (SCM_REALP (y
))
7564 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7565 else if (SCM_COMPLEXP (y
))
7566 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7567 0.0 * SCM_COMPLEX_IMAG (y
));
7568 /* we've already handled inexact numbers,
7569 so y must be exact, and we return exact0 */
7570 else if (SCM_NUMP (y
))
7573 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7577 * This case is important for more than just optimization.
7578 * It handles the case of negating
7579 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7580 * which is a bignum that must be changed back into a fixnum.
7581 * Failure to do so will cause the following to return #f:
7582 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7584 return scm_difference(y
, SCM_UNDEFINED
);
7588 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7590 scm_t_inum yy
= SCM_I_INUM (y
);
7591 scm_t_inum kk
= xx
* yy
;
7592 SCM k
= SCM_I_MAKINUM (kk
);
7593 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7597 SCM result
= scm_i_inum2big (xx
);
7598 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7599 return scm_i_normbig (result
);
7602 else if (SCM_BIGP (y
))
7604 SCM result
= scm_i_mkbig ();
7605 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7606 scm_remember_upto_here_1 (y
);
7609 else if (SCM_REALP (y
))
7610 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7611 else if (SCM_COMPLEXP (y
))
7612 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7613 xx
* SCM_COMPLEX_IMAG (y
));
7614 else if (SCM_FRACTIONP (y
))
7615 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7616 SCM_FRACTION_DENOMINATOR (y
));
7618 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7620 else if (SCM_BIGP (x
))
7622 if (SCM_I_INUMP (y
))
7627 else if (SCM_BIGP (y
))
7629 SCM result
= scm_i_mkbig ();
7630 mpz_mul (SCM_I_BIG_MPZ (result
),
7633 scm_remember_upto_here_2 (x
, y
);
7636 else if (SCM_REALP (y
))
7638 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7639 scm_remember_upto_here_1 (x
);
7640 return scm_from_double (result
);
7642 else if (SCM_COMPLEXP (y
))
7644 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7645 scm_remember_upto_here_1 (x
);
7646 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7647 z
* SCM_COMPLEX_IMAG (y
));
7649 else if (SCM_FRACTIONP (y
))
7650 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7651 SCM_FRACTION_DENOMINATOR (y
));
7653 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7655 else if (SCM_REALP (x
))
7657 if (SCM_I_INUMP (y
))
7662 else if (SCM_BIGP (y
))
7664 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7665 scm_remember_upto_here_1 (y
);
7666 return scm_from_double (result
);
7668 else if (SCM_REALP (y
))
7669 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7670 else if (SCM_COMPLEXP (y
))
7671 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7672 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7673 else if (SCM_FRACTIONP (y
))
7674 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7676 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7678 else if (SCM_COMPLEXP (x
))
7680 if (SCM_I_INUMP (y
))
7685 else if (SCM_BIGP (y
))
7687 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7688 scm_remember_upto_here_1 (y
);
7689 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7690 z
* SCM_COMPLEX_IMAG (x
));
7692 else if (SCM_REALP (y
))
7693 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7694 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7695 else if (SCM_COMPLEXP (y
))
7697 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7698 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7699 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7700 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7702 else if (SCM_FRACTIONP (y
))
7704 double yy
= scm_i_fraction2double (y
);
7705 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7706 yy
* SCM_COMPLEX_IMAG (x
));
7709 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7711 else if (SCM_FRACTIONP (x
))
7713 if (SCM_I_INUMP (y
))
7714 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7715 SCM_FRACTION_DENOMINATOR (x
));
7716 else if (SCM_BIGP (y
))
7717 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7718 SCM_FRACTION_DENOMINATOR (x
));
7719 else if (SCM_REALP (y
))
7720 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7721 else if (SCM_COMPLEXP (y
))
7723 double xx
= scm_i_fraction2double (x
);
7724 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7725 xx
* SCM_COMPLEX_IMAG (y
));
7727 else if (SCM_FRACTIONP (y
))
7728 /* a/b * c/d = ac / bd */
7729 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7730 SCM_FRACTION_NUMERATOR (y
)),
7731 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7732 SCM_FRACTION_DENOMINATOR (y
)));
7734 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7737 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7740 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7741 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7742 #define ALLOW_DIVIDE_BY_ZERO
7743 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7746 /* The code below for complex division is adapted from the GNU
7747 libstdc++, which adapted it from f2c's libF77, and is subject to
7750 /****************************************************************
7751 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7753 Permission to use, copy, modify, and distribute this software
7754 and its documentation for any purpose and without fee is hereby
7755 granted, provided that the above copyright notice appear in all
7756 copies and that both that the copyright notice and this
7757 permission notice and warranty disclaimer appear in supporting
7758 documentation, and that the names of AT&T Bell Laboratories or
7759 Bellcore or any of their entities not be used in advertising or
7760 publicity pertaining to distribution of the software without
7761 specific, written prior permission.
7763 AT&T and Bellcore disclaim all warranties with regard to this
7764 software, including all implied warranties of merchantability
7765 and fitness. In no event shall AT&T or Bellcore be liable for
7766 any special, indirect or consequential damages or any damages
7767 whatsoever resulting from loss of use, data or profits, whether
7768 in an action of contract, negligence or other tortious action,
7769 arising out of or in connection with the use or performance of
7771 ****************************************************************/
7773 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7774 (SCM x
, SCM y
, SCM rest
),
7775 "Divide the first argument by the product of the remaining\n"
7776 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7778 #define FUNC_NAME s_scm_i_divide
7780 while (!scm_is_null (rest
))
7781 { x
= scm_divide (x
, y
);
7783 rest
= scm_cdr (rest
);
7785 return scm_divide (x
, y
);
7789 #define s_divide s_scm_i_divide
7790 #define g_divide g_scm_i_divide
7793 do_divide (SCM x
, SCM y
, int inexact
)
7794 #define FUNC_NAME s_divide
7798 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7801 return scm_wta_dispatch_0 (g_divide
, s_divide
);
7802 else if (SCM_I_INUMP (x
))
7804 scm_t_inum xx
= SCM_I_INUM (x
);
7805 if (xx
== 1 || xx
== -1)
7807 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7809 scm_num_overflow (s_divide
);
7814 return scm_from_double (1.0 / (double) xx
);
7815 else return scm_i_make_ratio (SCM_INUM1
, x
);
7818 else if (SCM_BIGP (x
))
7821 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7822 else return scm_i_make_ratio (SCM_INUM1
, x
);
7824 else if (SCM_REALP (x
))
7826 double xx
= SCM_REAL_VALUE (x
);
7827 #ifndef ALLOW_DIVIDE_BY_ZERO
7829 scm_num_overflow (s_divide
);
7832 return scm_from_double (1.0 / xx
);
7834 else if (SCM_COMPLEXP (x
))
7836 double r
= SCM_COMPLEX_REAL (x
);
7837 double i
= SCM_COMPLEX_IMAG (x
);
7838 if (fabs(r
) <= fabs(i
))
7841 double d
= i
* (1.0 + t
* t
);
7842 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7847 double d
= r
* (1.0 + t
* t
);
7848 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7851 else if (SCM_FRACTIONP (x
))
7852 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7853 SCM_FRACTION_NUMERATOR (x
));
7855 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7858 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7860 scm_t_inum xx
= SCM_I_INUM (x
);
7861 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7863 scm_t_inum yy
= SCM_I_INUM (y
);
7866 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7867 scm_num_overflow (s_divide
);
7869 return scm_from_double ((double) xx
/ (double) yy
);
7872 else if (xx
% yy
!= 0)
7875 return scm_from_double ((double) xx
/ (double) yy
);
7876 else return scm_i_make_ratio (x
, y
);
7880 scm_t_inum z
= xx
/ yy
;
7881 if (SCM_FIXABLE (z
))
7882 return SCM_I_MAKINUM (z
);
7884 return scm_i_inum2big (z
);
7887 else if (SCM_BIGP (y
))
7890 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7891 else return scm_i_make_ratio (x
, y
);
7893 else if (SCM_REALP (y
))
7895 double yy
= SCM_REAL_VALUE (y
);
7896 #ifndef ALLOW_DIVIDE_BY_ZERO
7898 scm_num_overflow (s_divide
);
7901 return scm_from_double ((double) xx
/ yy
);
7903 else if (SCM_COMPLEXP (y
))
7906 complex_div
: /* y _must_ be a complex number */
7908 double r
= SCM_COMPLEX_REAL (y
);
7909 double i
= SCM_COMPLEX_IMAG (y
);
7910 if (fabs(r
) <= fabs(i
))
7913 double d
= i
* (1.0 + t
* t
);
7914 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7919 double d
= r
* (1.0 + t
* t
);
7920 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7924 else if (SCM_FRACTIONP (y
))
7925 /* a / b/c = ac / b */
7926 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7927 SCM_FRACTION_NUMERATOR (y
));
7929 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7931 else if (SCM_BIGP (x
))
7933 if (SCM_I_INUMP (y
))
7935 scm_t_inum yy
= SCM_I_INUM (y
);
7938 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7939 scm_num_overflow (s_divide
);
7941 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7942 scm_remember_upto_here_1 (x
);
7943 return (sgn
== 0) ? scm_nan () : scm_inf ();
7950 /* FIXME: HMM, what are the relative performance issues here?
7951 We need to test. Is it faster on average to test
7952 divisible_p, then perform whichever operation, or is it
7953 faster to perform the integer div opportunistically and
7954 switch to real if there's a remainder? For now we take the
7955 middle ground: test, then if divisible, use the faster div
7958 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7959 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7963 SCM result
= scm_i_mkbig ();
7964 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7965 scm_remember_upto_here_1 (x
);
7967 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7968 return scm_i_normbig (result
);
7973 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7974 else return scm_i_make_ratio (x
, y
);
7978 else if (SCM_BIGP (y
))
7983 /* It's easily possible for the ratio x/y to fit a double
7984 but one or both x and y be too big to fit a double,
7985 hence the use of mpq_get_d rather than converting and
7988 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
7989 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
7990 return scm_from_double (mpq_get_d (q
));
7994 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
7998 SCM result
= scm_i_mkbig ();
7999 mpz_divexact (SCM_I_BIG_MPZ (result
),
8002 scm_remember_upto_here_2 (x
, y
);
8003 return scm_i_normbig (result
);
8006 return scm_i_make_ratio (x
, y
);
8009 else if (SCM_REALP (y
))
8011 double yy
= SCM_REAL_VALUE (y
);
8012 #ifndef ALLOW_DIVIDE_BY_ZERO
8014 scm_num_overflow (s_divide
);
8017 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8019 else if (SCM_COMPLEXP (y
))
8021 a
= scm_i_big2dbl (x
);
8024 else if (SCM_FRACTIONP (y
))
8025 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8026 SCM_FRACTION_NUMERATOR (y
));
8028 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8030 else if (SCM_REALP (x
))
8032 double rx
= SCM_REAL_VALUE (x
);
8033 if (SCM_I_INUMP (y
))
8035 scm_t_inum yy
= SCM_I_INUM (y
);
8036 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8038 scm_num_overflow (s_divide
);
8041 return scm_from_double (rx
/ (double) yy
);
8043 else if (SCM_BIGP (y
))
8045 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8046 scm_remember_upto_here_1 (y
);
8047 return scm_from_double (rx
/ dby
);
8049 else if (SCM_REALP (y
))
8051 double yy
= SCM_REAL_VALUE (y
);
8052 #ifndef ALLOW_DIVIDE_BY_ZERO
8054 scm_num_overflow (s_divide
);
8057 return scm_from_double (rx
/ yy
);
8059 else if (SCM_COMPLEXP (y
))
8064 else if (SCM_FRACTIONP (y
))
8065 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8067 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8069 else if (SCM_COMPLEXP (x
))
8071 double rx
= SCM_COMPLEX_REAL (x
);
8072 double ix
= SCM_COMPLEX_IMAG (x
);
8073 if (SCM_I_INUMP (y
))
8075 scm_t_inum yy
= SCM_I_INUM (y
);
8076 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8078 scm_num_overflow (s_divide
);
8083 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8086 else if (SCM_BIGP (y
))
8088 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8089 scm_remember_upto_here_1 (y
);
8090 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8092 else if (SCM_REALP (y
))
8094 double yy
= SCM_REAL_VALUE (y
);
8095 #ifndef ALLOW_DIVIDE_BY_ZERO
8097 scm_num_overflow (s_divide
);
8100 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8102 else if (SCM_COMPLEXP (y
))
8104 double ry
= SCM_COMPLEX_REAL (y
);
8105 double iy
= SCM_COMPLEX_IMAG (y
);
8106 if (fabs(ry
) <= fabs(iy
))
8109 double d
= iy
* (1.0 + t
* t
);
8110 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8115 double d
= ry
* (1.0 + t
* t
);
8116 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8119 else if (SCM_FRACTIONP (y
))
8121 double yy
= scm_i_fraction2double (y
);
8122 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8125 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8127 else if (SCM_FRACTIONP (x
))
8129 if (SCM_I_INUMP (y
))
8131 scm_t_inum yy
= SCM_I_INUM (y
);
8132 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8134 scm_num_overflow (s_divide
);
8137 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8138 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8140 else if (SCM_BIGP (y
))
8142 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8143 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8145 else if (SCM_REALP (y
))
8147 double yy
= SCM_REAL_VALUE (y
);
8148 #ifndef ALLOW_DIVIDE_BY_ZERO
8150 scm_num_overflow (s_divide
);
8153 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8155 else if (SCM_COMPLEXP (y
))
8157 a
= scm_i_fraction2double (x
);
8160 else if (SCM_FRACTIONP (y
))
8161 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8162 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8164 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8167 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8171 scm_divide (SCM x
, SCM y
)
8173 return do_divide (x
, y
, 0);
8176 static SCM
scm_divide2real (SCM x
, SCM y
)
8178 return do_divide (x
, y
, 1);
8184 scm_c_truncate (double x
)
8189 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8190 half-way case (ie. when x is an integer plus 0.5) going upwards.
8191 Then half-way cases are identified and adjusted down if the
8192 round-upwards didn't give the desired even integer.
8194 "plus_half == result" identifies a half-way case. If plus_half, which is
8195 x + 0.5, is an integer then x must be an integer plus 0.5.
8197 An odd "result" value is identified with result/2 != floor(result/2).
8198 This is done with plus_half, since that value is ready for use sooner in
8199 a pipelined cpu, and we're already requiring plus_half == result.
8201 Note however that we need to be careful when x is big and already an
8202 integer. In that case "x+0.5" may round to an adjacent integer, causing
8203 us to return such a value, incorrectly. For instance if the hardware is
8204 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8205 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8206 returned. Or if the hardware is in round-upwards mode, then other bigger
8207 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8208 representable value, 2^128+2^76 (or whatever), again incorrect.
8210 These bad roundings of x+0.5 are avoided by testing at the start whether
8211 x is already an integer. If it is then clearly that's the desired result
8212 already. And if it's not then the exponent must be small enough to allow
8213 an 0.5 to be represented, and hence added without a bad rounding. */
8216 scm_c_round (double x
)
8218 double plus_half
, result
;
8223 plus_half
= x
+ 0.5;
8224 result
= floor (plus_half
);
8225 /* Adjust so that the rounding is towards even. */
8226 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8231 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8233 "Round the number @var{x} towards zero.")
8234 #define FUNC_NAME s_scm_truncate_number
8236 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8238 else if (SCM_REALP (x
))
8239 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8240 else if (SCM_FRACTIONP (x
))
8241 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8242 SCM_FRACTION_DENOMINATOR (x
));
8244 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8245 s_scm_truncate_number
);
8249 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8251 "Round the number @var{x} towards the nearest integer. "
8252 "When it is exactly halfway between two integers, "
8253 "round towards the even one.")
8254 #define FUNC_NAME s_scm_round_number
8256 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8258 else if (SCM_REALP (x
))
8259 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8260 else if (SCM_FRACTIONP (x
))
8261 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8262 SCM_FRACTION_DENOMINATOR (x
));
8264 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8265 s_scm_round_number
);
8269 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8271 "Round the number @var{x} towards minus infinity.")
8272 #define FUNC_NAME s_scm_floor
8274 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8276 else if (SCM_REALP (x
))
8277 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8278 else if (SCM_FRACTIONP (x
))
8279 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8280 SCM_FRACTION_DENOMINATOR (x
));
8282 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8286 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8288 "Round the number @var{x} towards infinity.")
8289 #define FUNC_NAME s_scm_ceiling
8291 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8293 else if (SCM_REALP (x
))
8294 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8295 else if (SCM_FRACTIONP (x
))
8296 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8297 SCM_FRACTION_DENOMINATOR (x
));
8299 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8303 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8305 "Return @var{x} raised to the power of @var{y}.")
8306 #define FUNC_NAME s_scm_expt
8308 if (scm_is_integer (y
))
8310 if (scm_is_true (scm_exact_p (y
)))
8311 return scm_integer_expt (x
, y
);
8314 /* Here we handle the case where the exponent is an inexact
8315 integer. We make the exponent exact in order to use
8316 scm_integer_expt, and thus avoid the spurious imaginary
8317 parts that may result from round-off errors in the general
8318 e^(y log x) method below (for example when squaring a large
8319 negative number). In this case, we must return an inexact
8320 result for correctness. We also make the base inexact so
8321 that scm_integer_expt will use fast inexact arithmetic
8322 internally. Note that making the base inexact is not
8323 sufficient to guarantee an inexact result, because
8324 scm_integer_expt will return an exact 1 when the exponent
8325 is 0, even if the base is inexact. */
8326 return scm_exact_to_inexact
8327 (scm_integer_expt (scm_exact_to_inexact (x
),
8328 scm_inexact_to_exact (y
)));
8331 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8333 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8335 else if (scm_is_complex (x
) && scm_is_complex (y
))
8336 return scm_exp (scm_product (scm_log (x
), y
));
8337 else if (scm_is_complex (x
))
8338 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8340 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8344 /* sin/cos/tan/asin/acos/atan
8345 sinh/cosh/tanh/asinh/acosh/atanh
8346 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8347 Written by Jerry D. Hedden, (C) FSF.
8348 See the file `COPYING' for terms applying to this program. */
8350 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8352 "Compute the sine of @var{z}.")
8353 #define FUNC_NAME s_scm_sin
8355 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8356 return z
; /* sin(exact0) = exact0 */
8357 else if (scm_is_real (z
))
8358 return scm_from_double (sin (scm_to_double (z
)));
8359 else if (SCM_COMPLEXP (z
))
8361 x
= SCM_COMPLEX_REAL (z
);
8362 y
= SCM_COMPLEX_IMAG (z
);
8363 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8364 cos (x
) * sinh (y
));
8367 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8371 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8373 "Compute the cosine of @var{z}.")
8374 #define FUNC_NAME s_scm_cos
8376 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8377 return SCM_INUM1
; /* cos(exact0) = exact1 */
8378 else if (scm_is_real (z
))
8379 return scm_from_double (cos (scm_to_double (z
)));
8380 else if (SCM_COMPLEXP (z
))
8382 x
= SCM_COMPLEX_REAL (z
);
8383 y
= SCM_COMPLEX_IMAG (z
);
8384 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8385 -sin (x
) * sinh (y
));
8388 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8392 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8394 "Compute the tangent of @var{z}.")
8395 #define FUNC_NAME s_scm_tan
8397 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8398 return z
; /* tan(exact0) = exact0 */
8399 else if (scm_is_real (z
))
8400 return scm_from_double (tan (scm_to_double (z
)));
8401 else if (SCM_COMPLEXP (z
))
8403 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8404 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8405 w
= cos (x
) + cosh (y
);
8406 #ifndef ALLOW_DIVIDE_BY_ZERO
8408 scm_num_overflow (s_scm_tan
);
8410 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8413 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8417 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8419 "Compute the hyperbolic sine of @var{z}.")
8420 #define FUNC_NAME s_scm_sinh
8422 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8423 return z
; /* sinh(exact0) = exact0 */
8424 else if (scm_is_real (z
))
8425 return scm_from_double (sinh (scm_to_double (z
)));
8426 else if (SCM_COMPLEXP (z
))
8428 x
= SCM_COMPLEX_REAL (z
);
8429 y
= SCM_COMPLEX_IMAG (z
);
8430 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8431 cosh (x
) * sin (y
));
8434 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8438 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8440 "Compute the hyperbolic cosine of @var{z}.")
8441 #define FUNC_NAME s_scm_cosh
8443 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8444 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8445 else if (scm_is_real (z
))
8446 return scm_from_double (cosh (scm_to_double (z
)));
8447 else if (SCM_COMPLEXP (z
))
8449 x
= SCM_COMPLEX_REAL (z
);
8450 y
= SCM_COMPLEX_IMAG (z
);
8451 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8452 sinh (x
) * sin (y
));
8455 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8459 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8461 "Compute the hyperbolic tangent of @var{z}.")
8462 #define FUNC_NAME s_scm_tanh
8464 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8465 return z
; /* tanh(exact0) = exact0 */
8466 else if (scm_is_real (z
))
8467 return scm_from_double (tanh (scm_to_double (z
)));
8468 else if (SCM_COMPLEXP (z
))
8470 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8471 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8472 w
= cosh (x
) + cos (y
);
8473 #ifndef ALLOW_DIVIDE_BY_ZERO
8475 scm_num_overflow (s_scm_tanh
);
8477 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8480 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8484 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8486 "Compute the arc sine of @var{z}.")
8487 #define FUNC_NAME s_scm_asin
8489 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8490 return z
; /* asin(exact0) = exact0 */
8491 else if (scm_is_real (z
))
8493 double w
= scm_to_double (z
);
8494 if (w
>= -1.0 && w
<= 1.0)
8495 return scm_from_double (asin (w
));
8497 return scm_product (scm_c_make_rectangular (0, -1),
8498 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8500 else if (SCM_COMPLEXP (z
))
8502 x
= SCM_COMPLEX_REAL (z
);
8503 y
= SCM_COMPLEX_IMAG (z
);
8504 return scm_product (scm_c_make_rectangular (0, -1),
8505 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8508 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8512 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8514 "Compute the arc cosine of @var{z}.")
8515 #define FUNC_NAME s_scm_acos
8517 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8518 return SCM_INUM0
; /* acos(exact1) = exact0 */
8519 else if (scm_is_real (z
))
8521 double w
= scm_to_double (z
);
8522 if (w
>= -1.0 && w
<= 1.0)
8523 return scm_from_double (acos (w
));
8525 return scm_sum (scm_from_double (acos (0.0)),
8526 scm_product (scm_c_make_rectangular (0, 1),
8527 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8529 else if (SCM_COMPLEXP (z
))
8531 x
= SCM_COMPLEX_REAL (z
);
8532 y
= SCM_COMPLEX_IMAG (z
);
8533 return scm_sum (scm_from_double (acos (0.0)),
8534 scm_product (scm_c_make_rectangular (0, 1),
8535 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8538 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8542 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8544 "With one argument, compute the arc tangent of @var{z}.\n"
8545 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8546 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8547 #define FUNC_NAME s_scm_atan
8551 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8552 return z
; /* atan(exact0) = exact0 */
8553 else if (scm_is_real (z
))
8554 return scm_from_double (atan (scm_to_double (z
)));
8555 else if (SCM_COMPLEXP (z
))
8558 v
= SCM_COMPLEX_REAL (z
);
8559 w
= SCM_COMPLEX_IMAG (z
);
8560 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8561 scm_c_make_rectangular (v
, w
+ 1.0))),
8562 scm_c_make_rectangular (0, 2));
8565 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8567 else if (scm_is_real (z
))
8569 if (scm_is_real (y
))
8570 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8572 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8575 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8579 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8581 "Compute the inverse hyperbolic sine of @var{z}.")
8582 #define FUNC_NAME s_scm_sys_asinh
8584 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8585 return z
; /* asinh(exact0) = exact0 */
8586 else if (scm_is_real (z
))
8587 return scm_from_double (asinh (scm_to_double (z
)));
8588 else if (scm_is_number (z
))
8589 return scm_log (scm_sum (z
,
8590 scm_sqrt (scm_sum (scm_product (z
, z
),
8593 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8597 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8599 "Compute the inverse hyperbolic cosine of @var{z}.")
8600 #define FUNC_NAME s_scm_sys_acosh
8602 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8603 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8604 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8605 return scm_from_double (acosh (scm_to_double (z
)));
8606 else if (scm_is_number (z
))
8607 return scm_log (scm_sum (z
,
8608 scm_sqrt (scm_difference (scm_product (z
, z
),
8611 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8615 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8617 "Compute the inverse hyperbolic tangent of @var{z}.")
8618 #define FUNC_NAME s_scm_sys_atanh
8620 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8621 return z
; /* atanh(exact0) = exact0 */
8622 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8623 return scm_from_double (atanh (scm_to_double (z
)));
8624 else if (scm_is_number (z
))
8625 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8626 scm_difference (SCM_INUM1
, z
))),
8629 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8634 scm_c_make_rectangular (double re
, double im
)
8638 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8640 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8641 SCM_COMPLEX_REAL (z
) = re
;
8642 SCM_COMPLEX_IMAG (z
) = im
;
8646 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8647 (SCM real_part
, SCM imaginary_part
),
8648 "Return a complex number constructed of the given @var{real-part} "
8649 "and @var{imaginary-part} parts.")
8650 #define FUNC_NAME s_scm_make_rectangular
8652 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8653 SCM_ARG1
, FUNC_NAME
, "real");
8654 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8655 SCM_ARG2
, FUNC_NAME
, "real");
8657 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8658 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8661 return scm_c_make_rectangular (scm_to_double (real_part
),
8662 scm_to_double (imaginary_part
));
8667 scm_c_make_polar (double mag
, double ang
)
8671 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8672 use it on Glibc-based systems that have it (it's a GNU extension). See
8673 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8675 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8676 sincos (ang
, &s
, &c
);
8682 /* If s and c are NaNs, this indicates that the angle is a NaN,
8683 infinite, or perhaps simply too large to determine its value
8684 mod 2*pi. However, we know something that the floating-point
8685 implementation doesn't know: We know that s and c are finite.
8686 Therefore, if the magnitude is zero, return a complex zero.
8688 The reason we check for the NaNs instead of using this case
8689 whenever mag == 0.0 is because when the angle is known, we'd
8690 like to return the correct kind of non-real complex zero:
8691 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8692 on which quadrant the angle is in.
8694 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8695 return scm_c_make_rectangular (0.0, 0.0);
8697 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8700 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8702 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8703 #define FUNC_NAME s_scm_make_polar
8705 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8706 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8708 /* If mag is exact0, return exact0 */
8709 if (scm_is_eq (mag
, SCM_INUM0
))
8711 /* Return a real if ang is exact0 */
8712 else if (scm_is_eq (ang
, SCM_INUM0
))
8715 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8720 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8722 "Return the real part of the number @var{z}.")
8723 #define FUNC_NAME s_scm_real_part
8725 if (SCM_COMPLEXP (z
))
8726 return scm_from_double (SCM_COMPLEX_REAL (z
));
8727 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8730 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8735 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8737 "Return the imaginary part of the number @var{z}.")
8738 #define FUNC_NAME s_scm_imag_part
8740 if (SCM_COMPLEXP (z
))
8741 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8742 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8745 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8749 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8751 "Return the numerator of the number @var{z}.")
8752 #define FUNC_NAME s_scm_numerator
8754 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8756 else if (SCM_FRACTIONP (z
))
8757 return SCM_FRACTION_NUMERATOR (z
);
8758 else if (SCM_REALP (z
))
8759 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8761 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8766 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8768 "Return the denominator of the number @var{z}.")
8769 #define FUNC_NAME s_scm_denominator
8771 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8773 else if (SCM_FRACTIONP (z
))
8774 return SCM_FRACTION_DENOMINATOR (z
);
8775 else if (SCM_REALP (z
))
8776 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8778 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
8784 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8786 "Return the magnitude of the number @var{z}. This is the same as\n"
8787 "@code{abs} for real arguments, but also allows complex numbers.")
8788 #define FUNC_NAME s_scm_magnitude
8790 if (SCM_I_INUMP (z
))
8792 scm_t_inum zz
= SCM_I_INUM (z
);
8795 else if (SCM_POSFIXABLE (-zz
))
8796 return SCM_I_MAKINUM (-zz
);
8798 return scm_i_inum2big (-zz
);
8800 else if (SCM_BIGP (z
))
8802 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8803 scm_remember_upto_here_1 (z
);
8805 return scm_i_clonebig (z
, 0);
8809 else if (SCM_REALP (z
))
8810 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8811 else if (SCM_COMPLEXP (z
))
8812 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8813 else if (SCM_FRACTIONP (z
))
8815 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8817 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8818 SCM_FRACTION_DENOMINATOR (z
));
8821 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
8827 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8829 "Return the angle of the complex number @var{z}.")
8830 #define FUNC_NAME s_scm_angle
8832 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8833 flo0 to save allocating a new flonum with scm_from_double each time.
8834 But if atan2 follows the floating point rounding mode, then the value
8835 is not a constant. Maybe it'd be close enough though. */
8836 if (SCM_I_INUMP (z
))
8838 if (SCM_I_INUM (z
) >= 0)
8841 return scm_from_double (atan2 (0.0, -1.0));
8843 else if (SCM_BIGP (z
))
8845 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8846 scm_remember_upto_here_1 (z
);
8848 return scm_from_double (atan2 (0.0, -1.0));
8852 else if (SCM_REALP (z
))
8854 if (SCM_REAL_VALUE (z
) >= 0)
8857 return scm_from_double (atan2 (0.0, -1.0));
8859 else if (SCM_COMPLEXP (z
))
8860 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8861 else if (SCM_FRACTIONP (z
))
8863 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8865 else return scm_from_double (atan2 (0.0, -1.0));
8868 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8873 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8875 "Convert the number @var{z} to its inexact representation.\n")
8876 #define FUNC_NAME s_scm_exact_to_inexact
8878 if (SCM_I_INUMP (z
))
8879 return scm_from_double ((double) SCM_I_INUM (z
));
8880 else if (SCM_BIGP (z
))
8881 return scm_from_double (scm_i_big2dbl (z
));
8882 else if (SCM_FRACTIONP (z
))
8883 return scm_from_double (scm_i_fraction2double (z
));
8884 else if (SCM_INEXACTP (z
))
8887 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
8888 s_scm_exact_to_inexact
);
8893 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8895 "Return an exact number that is numerically closest to @var{z}.")
8896 #define FUNC_NAME s_scm_inexact_to_exact
8898 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8905 val
= SCM_REAL_VALUE (z
);
8906 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8907 val
= SCM_COMPLEX_REAL (z
);
8909 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
8910 s_scm_inexact_to_exact
);
8912 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8913 SCM_OUT_OF_RANGE (1, z
);
8920 mpq_set_d (frac
, val
);
8921 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8922 scm_i_mpz2num (mpq_denref (frac
)));
8924 /* When scm_i_make_ratio throws, we leak the memory allocated
8934 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8936 "Returns the @emph{simplest} rational number differing\n"
8937 "from @var{x} by no more than @var{eps}.\n"
8939 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8940 "exact result when both its arguments are exact. Thus, you might need\n"
8941 "to use @code{inexact->exact} on the arguments.\n"
8944 "(rationalize (inexact->exact 1.2) 1/100)\n"
8947 #define FUNC_NAME s_scm_rationalize
8949 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8950 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8951 eps
= scm_abs (eps
);
8952 if (scm_is_false (scm_positive_p (eps
)))
8954 /* eps is either zero or a NaN */
8955 if (scm_is_true (scm_nan_p (eps
)))
8957 else if (SCM_INEXACTP (eps
))
8958 return scm_exact_to_inexact (x
);
8962 else if (scm_is_false (scm_finite_p (eps
)))
8964 if (scm_is_true (scm_finite_p (x
)))
8969 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8971 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8972 scm_ceiling (scm_difference (x
, eps
)))))
8974 /* There's an integer within range; we want the one closest to zero */
8975 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8977 /* zero is within range */
8978 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8983 else if (scm_is_true (scm_positive_p (x
)))
8984 return scm_ceiling (scm_difference (x
, eps
));
8986 return scm_floor (scm_sum (x
, eps
));
8990 /* Use continued fractions to find closest ratio. All
8991 arithmetic is done with exact numbers.
8994 SCM ex
= scm_inexact_to_exact (x
);
8995 SCM int_part
= scm_floor (ex
);
8997 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
8998 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9002 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9003 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9005 /* We stop after a million iterations just to be absolutely sure
9006 that we don't go into an infinite loop. The process normally
9007 converges after less than a dozen iterations.
9010 while (++i
< 1000000)
9012 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9013 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9014 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9016 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9017 eps
))) /* abs(x-a/b) <= eps */
9019 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9020 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9021 return scm_exact_to_inexact (res
);
9025 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9027 tt
= scm_floor (rx
); /* tt = floor (rx) */
9033 scm_num_overflow (s_scm_rationalize
);
9038 /* conversion functions */
9041 scm_is_integer (SCM val
)
9043 return scm_is_true (scm_integer_p (val
));
9047 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9049 if (SCM_I_INUMP (val
))
9051 scm_t_signed_bits n
= SCM_I_INUM (val
);
9052 return n
>= min
&& n
<= max
;
9054 else if (SCM_BIGP (val
))
9056 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9058 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9060 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9062 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9063 return n
>= min
&& n
<= max
;
9073 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9074 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9077 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9078 SCM_I_BIG_MPZ (val
));
9080 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9092 return n
>= min
&& n
<= max
;
9100 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9102 if (SCM_I_INUMP (val
))
9104 scm_t_signed_bits n
= SCM_I_INUM (val
);
9105 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9107 else if (SCM_BIGP (val
))
9109 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9111 else if (max
<= ULONG_MAX
)
9113 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9115 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9116 return n
>= min
&& n
<= max
;
9126 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9129 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9130 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9133 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9134 SCM_I_BIG_MPZ (val
));
9136 return n
>= min
&& n
<= max
;
9144 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9146 scm_error (scm_out_of_range_key
,
9148 "Value out of range ~S to ~S: ~S",
9149 scm_list_3 (min
, max
, bad_val
),
9150 scm_list_1 (bad_val
));
9153 #define TYPE scm_t_intmax
9154 #define TYPE_MIN min
9155 #define TYPE_MAX max
9156 #define SIZEOF_TYPE 0
9157 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9158 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9159 #include "libguile/conv-integer.i.c"
9161 #define TYPE scm_t_uintmax
9162 #define TYPE_MIN min
9163 #define TYPE_MAX max
9164 #define SIZEOF_TYPE 0
9165 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9166 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9167 #include "libguile/conv-uinteger.i.c"
9169 #define TYPE scm_t_int8
9170 #define TYPE_MIN SCM_T_INT8_MIN
9171 #define TYPE_MAX SCM_T_INT8_MAX
9172 #define SIZEOF_TYPE 1
9173 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9174 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9175 #include "libguile/conv-integer.i.c"
9177 #define TYPE scm_t_uint8
9179 #define TYPE_MAX SCM_T_UINT8_MAX
9180 #define SIZEOF_TYPE 1
9181 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9182 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9183 #include "libguile/conv-uinteger.i.c"
9185 #define TYPE scm_t_int16
9186 #define TYPE_MIN SCM_T_INT16_MIN
9187 #define TYPE_MAX SCM_T_INT16_MAX
9188 #define SIZEOF_TYPE 2
9189 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9190 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9191 #include "libguile/conv-integer.i.c"
9193 #define TYPE scm_t_uint16
9195 #define TYPE_MAX SCM_T_UINT16_MAX
9196 #define SIZEOF_TYPE 2
9197 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9198 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9199 #include "libguile/conv-uinteger.i.c"
9201 #define TYPE scm_t_int32
9202 #define TYPE_MIN SCM_T_INT32_MIN
9203 #define TYPE_MAX SCM_T_INT32_MAX
9204 #define SIZEOF_TYPE 4
9205 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9206 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9207 #include "libguile/conv-integer.i.c"
9209 #define TYPE scm_t_uint32
9211 #define TYPE_MAX SCM_T_UINT32_MAX
9212 #define SIZEOF_TYPE 4
9213 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9214 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9215 #include "libguile/conv-uinteger.i.c"
9217 #define TYPE scm_t_wchar
9218 #define TYPE_MIN (scm_t_int32)-1
9219 #define TYPE_MAX (scm_t_int32)0x10ffff
9220 #define SIZEOF_TYPE 4
9221 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9222 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9223 #include "libguile/conv-integer.i.c"
9225 #define TYPE scm_t_int64
9226 #define TYPE_MIN SCM_T_INT64_MIN
9227 #define TYPE_MAX SCM_T_INT64_MAX
9228 #define SIZEOF_TYPE 8
9229 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9230 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9231 #include "libguile/conv-integer.i.c"
9233 #define TYPE scm_t_uint64
9235 #define TYPE_MAX SCM_T_UINT64_MAX
9236 #define SIZEOF_TYPE 8
9237 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9238 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9239 #include "libguile/conv-uinteger.i.c"
9242 scm_to_mpz (SCM val
, mpz_t rop
)
9244 if (SCM_I_INUMP (val
))
9245 mpz_set_si (rop
, SCM_I_INUM (val
));
9246 else if (SCM_BIGP (val
))
9247 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9249 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9253 scm_from_mpz (mpz_t val
)
9255 return scm_i_mpz2num (val
);
9259 scm_is_real (SCM val
)
9261 return scm_is_true (scm_real_p (val
));
9265 scm_is_rational (SCM val
)
9267 return scm_is_true (scm_rational_p (val
));
9271 scm_to_double (SCM val
)
9273 if (SCM_I_INUMP (val
))
9274 return SCM_I_INUM (val
);
9275 else if (SCM_BIGP (val
))
9276 return scm_i_big2dbl (val
);
9277 else if (SCM_FRACTIONP (val
))
9278 return scm_i_fraction2double (val
);
9279 else if (SCM_REALP (val
))
9280 return SCM_REAL_VALUE (val
);
9282 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9286 scm_from_double (double val
)
9290 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9292 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9293 SCM_REAL_VALUE (z
) = val
;
9299 scm_is_complex (SCM val
)
9301 return scm_is_true (scm_complex_p (val
));
9305 scm_c_real_part (SCM z
)
9307 if (SCM_COMPLEXP (z
))
9308 return SCM_COMPLEX_REAL (z
);
9311 /* Use the scm_real_part to get proper error checking and
9314 return scm_to_double (scm_real_part (z
));
9319 scm_c_imag_part (SCM z
)
9321 if (SCM_COMPLEXP (z
))
9322 return SCM_COMPLEX_IMAG (z
);
9325 /* Use the scm_imag_part to get proper error checking and
9326 dispatching. The result will almost always be 0.0, but not
9329 return scm_to_double (scm_imag_part (z
));
9334 scm_c_magnitude (SCM z
)
9336 return scm_to_double (scm_magnitude (z
));
9342 return scm_to_double (scm_angle (z
));
9346 scm_is_number (SCM z
)
9348 return scm_is_true (scm_number_p (z
));
9352 /* Returns log(x * 2^shift) */
9354 log_of_shifted_double (double x
, long shift
)
9356 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9358 if (x
> 0.0 || double_is_non_negative_zero (x
))
9359 return scm_from_double (ans
);
9361 return scm_c_make_rectangular (ans
, M_PI
);
9364 /* Returns log(n), for exact integer n of integer-length size */
9366 log_of_exact_integer_with_size (SCM n
, long size
)
9368 long shift
= size
- 2 * scm_dblprec
[0];
9371 return log_of_shifted_double
9372 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9375 return log_of_shifted_double (scm_to_double (n
), 0);
9378 /* Returns log(n), for exact integer n */
9380 log_of_exact_integer (SCM n
)
9382 return log_of_exact_integer_with_size
9383 (n
, scm_to_long (scm_integer_length (n
)));
9386 /* Returns log(n/d), for exact non-zero integers n and d */
9388 log_of_fraction (SCM n
, SCM d
)
9390 long n_size
= scm_to_long (scm_integer_length (n
));
9391 long d_size
= scm_to_long (scm_integer_length (d
));
9393 if (abs (n_size
- d_size
) > 1)
9394 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9395 log_of_exact_integer_with_size (d
, d_size
)));
9396 else if (scm_is_false (scm_negative_p (n
)))
9397 return scm_from_double
9398 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9400 return scm_c_make_rectangular
9401 (log1p (scm_to_double (scm_divide2real
9402 (scm_difference (scm_abs (n
), d
),
9408 /* In the following functions we dispatch to the real-arg funcs like log()
9409 when we know the arg is real, instead of just handing everything to
9410 clog() for instance. This is in case clog() doesn't optimize for a
9411 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9412 well use it to go straight to the applicable C func. */
9414 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9416 "Return the natural logarithm of @var{z}.")
9417 #define FUNC_NAME s_scm_log
9419 if (SCM_COMPLEXP (z
))
9421 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9422 && defined (SCM_COMPLEX_VALUE)
9423 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9425 double re
= SCM_COMPLEX_REAL (z
);
9426 double im
= SCM_COMPLEX_IMAG (z
);
9427 return scm_c_make_rectangular (log (hypot (re
, im
)),
9431 else if (SCM_REALP (z
))
9432 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9433 else if (SCM_I_INUMP (z
))
9435 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9436 if (scm_is_eq (z
, SCM_INUM0
))
9437 scm_num_overflow (s_scm_log
);
9439 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9441 else if (SCM_BIGP (z
))
9442 return log_of_exact_integer (z
);
9443 else if (SCM_FRACTIONP (z
))
9444 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9445 SCM_FRACTION_DENOMINATOR (z
));
9447 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9452 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9454 "Return the base 10 logarithm of @var{z}.")
9455 #define FUNC_NAME s_scm_log10
9457 if (SCM_COMPLEXP (z
))
9459 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9460 clog() and a multiply by M_LOG10E, rather than the fallback
9461 log10+hypot+atan2.) */
9462 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9463 && defined SCM_COMPLEX_VALUE
9464 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9466 double re
= SCM_COMPLEX_REAL (z
);
9467 double im
= SCM_COMPLEX_IMAG (z
);
9468 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9469 M_LOG10E
* atan2 (im
, re
));
9472 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9474 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9475 if (scm_is_eq (z
, SCM_INUM0
))
9476 scm_num_overflow (s_scm_log10
);
9479 double re
= scm_to_double (z
);
9480 double l
= log10 (fabs (re
));
9481 if (re
> 0.0 || double_is_non_negative_zero (re
))
9482 return scm_from_double (l
);
9484 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9487 else if (SCM_BIGP (z
))
9488 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9489 else if (SCM_FRACTIONP (z
))
9490 return scm_product (flo_log10e
,
9491 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9492 SCM_FRACTION_DENOMINATOR (z
)));
9494 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9499 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9501 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9502 "base of natural logarithms (2.71828@dots{}).")
9503 #define FUNC_NAME s_scm_exp
9505 if (SCM_COMPLEXP (z
))
9507 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9508 && defined (SCM_COMPLEX_VALUE)
9509 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9511 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9512 SCM_COMPLEX_IMAG (z
));
9515 else if (SCM_NUMBERP (z
))
9517 /* When z is a negative bignum the conversion to double overflows,
9518 giving -infinity, but that's ok, the exp is still 0.0. */
9519 return scm_from_double (exp (scm_to_double (z
)));
9522 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9527 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9529 "Return two exact non-negative integers @var{s} and @var{r}\n"
9530 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9531 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9532 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9535 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9537 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9541 scm_exact_integer_sqrt (k
, &s
, &r
);
9542 return scm_values (scm_list_2 (s
, r
));
9547 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9549 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9551 scm_t_inum kk
= SCM_I_INUM (k
);
9555 if (SCM_LIKELY (kk
> 0))
9560 uu
= (ss
+ kk
/ss
) / 2;
9562 *sp
= SCM_I_MAKINUM (ss
);
9563 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9565 else if (SCM_LIKELY (kk
== 0))
9566 *sp
= *rp
= SCM_INUM0
;
9568 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9569 "exact non-negative integer");
9571 else if (SCM_LIKELY (SCM_BIGP (k
)))
9575 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9576 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9577 "exact non-negative integer");
9580 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9581 scm_remember_upto_here_1 (k
);
9582 *sp
= scm_i_normbig (s
);
9583 *rp
= scm_i_normbig (r
);
9586 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9587 "exact non-negative integer");
9591 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9593 "Return the square root of @var{z}. Of the two possible roots\n"
9594 "(positive and negative), the one with positive real part\n"
9595 "is returned, or if that's zero then a positive imaginary part.\n"
9599 "(sqrt 9.0) @result{} 3.0\n"
9600 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9601 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9602 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9604 #define FUNC_NAME s_scm_sqrt
9606 if (SCM_COMPLEXP (z
))
9608 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9609 && defined SCM_COMPLEX_VALUE
9610 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9612 double re
= SCM_COMPLEX_REAL (z
);
9613 double im
= SCM_COMPLEX_IMAG (z
);
9614 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9615 0.5 * atan2 (im
, re
));
9618 else if (SCM_NUMBERP (z
))
9620 double xx
= scm_to_double (z
);
9622 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9624 return scm_from_double (sqrt (xx
));
9627 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9638 mpz_init_set_si (z_negative_one
, -1);
9640 /* It may be possible to tune the performance of some algorithms by using
9641 * the following constants to avoid the creation of bignums. Please, before
9642 * using these values, remember the two rules of program optimization:
9643 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9644 scm_c_define ("most-positive-fixnum",
9645 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9646 scm_c_define ("most-negative-fixnum",
9647 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9649 scm_add_feature ("complex");
9650 scm_add_feature ("inexact");
9651 flo0
= scm_from_double (0.0);
9652 flo_log10e
= scm_from_double (M_LOG10E
);
9654 /* determine floating point precision */
9655 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9657 init_dblprec(&scm_dblprec
[i
-2],i
);
9658 init_fx_radix(fx_per_radix
[i
-2],i
);
9661 /* hard code precision for base 10 if the preprocessor tells us to... */
9662 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9665 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9666 #include "libguile/numbers.x"