1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
57 #include "libguile/_scm.h"
58 #include "libguile/feature.h"
59 #include "libguile/ports.h"
60 #include "libguile/root.h"
61 #include "libguile/smob.h"
62 #include "libguile/strings.h"
63 #include "libguile/bdw-gc.h"
65 #include "libguile/validate.h"
66 #include "libguile/numbers.h"
67 #include "libguile/deprecation.h"
69 #include "libguile/eq.h"
71 /* values per glibc, if not already defined */
73 #define M_LOG10E 0.43429448190325182765
76 #define M_LN2 0.69314718055994530942
79 #define M_PI 3.14159265358979323846
82 typedef scm_t_signed_bits scm_t_inum
;
83 #define scm_from_inum(x) (scm_from_signed_integer (x))
85 /* Tests to see if a C double is neither infinite nor a NaN.
86 TODO: if it's available, use C99's isfinite(x) instead */
87 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
89 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
90 of the infinity, but other platforms return a boolean only. */
91 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
92 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
97 Wonder if this might be faster for some of our code? A switch on
98 the numtag would jump directly to the right case, and the
99 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
101 #define SCM_I_NUMTAG_NOTNUM 0
102 #define SCM_I_NUMTAG_INUM 1
103 #define SCM_I_NUMTAG_BIG scm_tc16_big
104 #define SCM_I_NUMTAG_REAL scm_tc16_real
105 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
106 #define SCM_I_NUMTAG(x) \
107 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
108 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
109 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
110 : SCM_I_NUMTAG_NOTNUM)))
112 /* the macro above will not work as is with fractions */
116 static SCM exactly_one_half
;
117 static SCM flo_log10e
;
119 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
121 /* FLOBUFLEN is the maximum number of characters neccessary for the
122 * printed or scm_string representation of an inexact number.
124 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
127 #if !defined (HAVE_ASINH)
128 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
130 #if !defined (HAVE_ACOSH)
131 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
133 #if !defined (HAVE_ATANH)
134 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
137 /* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
138 an explicit check. In some future gmp (don't know what version number),
139 mpz_cmp_d is supposed to do this itself. */
141 #define xmpz_cmp_d(z, d) \
142 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
144 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
148 #if defined (GUILE_I)
149 #if HAVE_COMPLEX_DOUBLE
151 /* For an SCM object Z which is a complex number (ie. satisfies
152 SCM_COMPLEXP), return its value as a C level "complex double". */
153 #define SCM_COMPLEX_VALUE(z) \
154 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
156 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
158 /* Convert a C "complex double" to an SCM value. */
160 scm_from_complex_double (complex double z
)
162 return scm_c_make_rectangular (creal (z
), cimag (z
));
165 #endif /* HAVE_COMPLEX_DOUBLE */
170 static mpz_t z_negative_one
;
173 /* Clear the `mpz_t' embedded in bignum PTR. */
175 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
179 bignum
= PTR2SCM (ptr
);
180 mpz_clear (SCM_I_BIG_MPZ (bignum
));
183 /* Return a new uninitialized bignum. */
188 GC_finalization_proc prev_finalizer
;
189 GC_PTR prev_finalizer_data
;
191 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
192 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
196 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
198 &prev_finalizer_data
);
207 /* Return a newly created bignum. */
208 SCM z
= make_bignum ();
209 mpz_init (SCM_I_BIG_MPZ (z
));
214 scm_i_inum2big (scm_t_inum x
)
216 /* Return a newly created bignum initialized to X. */
217 SCM z
= make_bignum ();
218 #if SIZEOF_VOID_P == SIZEOF_LONG
219 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
221 /* Note that in this case, you'll also have to check all mpz_*_ui and
222 mpz_*_si invocations in Guile. */
223 #error creation of mpz not implemented for this inum size
229 scm_i_long2big (long x
)
231 /* Return a newly created bignum initialized to X. */
232 SCM z
= make_bignum ();
233 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
238 scm_i_ulong2big (unsigned long x
)
240 /* Return a newly created bignum initialized to X. */
241 SCM z
= make_bignum ();
242 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
247 scm_i_clonebig (SCM src_big
, int same_sign_p
)
249 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
250 SCM z
= make_bignum ();
251 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
253 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
258 scm_i_bigcmp (SCM x
, SCM y
)
260 /* Return neg if x < y, pos if x > y, and 0 if x == y */
261 /* presume we already know x and y are bignums */
262 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
263 scm_remember_upto_here_2 (x
, y
);
268 scm_i_dbl2big (double d
)
270 /* results are only defined if d is an integer */
271 SCM z
= make_bignum ();
272 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
276 /* Convert a integer in double representation to a SCM number. */
279 scm_i_dbl2num (double u
)
281 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
282 powers of 2, so there's no rounding when making "double" values
283 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
284 get rounded on a 64-bit machine, hence the "+1".
286 The use of floor() to force to an integer value ensures we get a
287 "numerically closest" value without depending on how a
288 double->long cast or how mpz_set_d will round. For reference,
289 double->long probably follows the hardware rounding mode,
290 mpz_set_d truncates towards zero. */
292 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
293 representable as a double? */
295 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
296 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
297 return SCM_I_MAKINUM ((scm_t_inum
) u
);
299 return scm_i_dbl2big (u
);
302 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
303 with R5RS exact->inexact.
305 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
306 (ie. truncate towards zero), then adjust to get the closest double by
307 examining the next lower bit and adding 1 (to the absolute value) if
310 Bignums exactly half way between representable doubles are rounded to the
311 next higher absolute value (ie. away from zero). This seems like an
312 adequate interpretation of R5RS "numerically closest", and it's easier
313 and faster than a full "nearest-even" style.
315 The bit test must be done on the absolute value of the mpz_t, which means
316 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
317 negatives as twos complement.
319 In current gmp 4.1.3, mpz_get_d rounding is unspecified. It ends up
320 following the hardware rounding mode, but applied to the absolute value
321 of the mpz_t operand. This is not what we want so we put the high
322 DBL_MANT_DIG bits into a temporary. In some future gmp, don't know when,
323 mpz_get_d is supposed to always truncate towards zero.
325 ENHANCE-ME: The temporary init+clear to force the rounding in gmp 4.1.3
326 is a slowdown. It'd be faster to pick out the relevant high bits with
327 mpz_getlimbn if we could be bothered coding that, and if the new
328 truncating gmp doesn't come out. */
331 scm_i_big2dbl (SCM b
)
336 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
340 /* Current GMP, eg. 4.1.3, force truncation towards zero */
342 if (bits
> DBL_MANT_DIG
)
344 size_t shift
= bits
- DBL_MANT_DIG
;
345 mpz_init2 (tmp
, DBL_MANT_DIG
);
346 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
347 result
= ldexp (mpz_get_d (tmp
), shift
);
352 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
357 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
360 if (bits
> DBL_MANT_DIG
)
362 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
363 /* test bit number "pos" in absolute value */
364 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
365 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
367 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
371 scm_remember_upto_here_1 (b
);
376 scm_i_normbig (SCM b
)
378 /* convert a big back to a fixnum if it'll fit */
379 /* presume b is a bignum */
380 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
382 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
383 if (SCM_FIXABLE (val
))
384 b
= SCM_I_MAKINUM (val
);
389 static SCM_C_INLINE_KEYWORD SCM
390 scm_i_mpz2num (mpz_t b
)
392 /* convert a mpz number to a SCM number. */
393 if (mpz_fits_slong_p (b
))
395 scm_t_inum val
= mpz_get_si (b
);
396 if (SCM_FIXABLE (val
))
397 return SCM_I_MAKINUM (val
);
401 SCM z
= make_bignum ();
402 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
407 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
408 static SCM
scm_divide2real (SCM x
, SCM y
);
411 scm_i_make_ratio (SCM numerator
, SCM denominator
)
412 #define FUNC_NAME "make-ratio"
414 /* First make sure the arguments are proper.
416 if (SCM_I_INUMP (denominator
))
418 if (scm_is_eq (denominator
, SCM_INUM0
))
419 scm_num_overflow ("make-ratio");
420 if (scm_is_eq (denominator
, SCM_INUM1
))
425 if (!(SCM_BIGP(denominator
)))
426 SCM_WRONG_TYPE_ARG (2, denominator
);
428 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
429 SCM_WRONG_TYPE_ARG (1, numerator
);
431 /* Then flip signs so that the denominator is positive.
433 if (scm_is_true (scm_negative_p (denominator
)))
435 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
436 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
439 /* Now consider for each of the four fixnum/bignum combinations
440 whether the rational number is really an integer.
442 if (SCM_I_INUMP (numerator
))
444 scm_t_inum x
= SCM_I_INUM (numerator
);
445 if (scm_is_eq (numerator
, SCM_INUM0
))
447 if (SCM_I_INUMP (denominator
))
450 y
= SCM_I_INUM (denominator
);
454 return SCM_I_MAKINUM (x
/ y
);
458 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
459 of that value for the denominator, as a bignum. Apart from
460 that case, abs(bignum) > abs(inum) so inum/bignum is not an
462 if (x
== SCM_MOST_NEGATIVE_FIXNUM
463 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
464 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
465 return SCM_I_MAKINUM(-1);
468 else if (SCM_BIGP (numerator
))
470 if (SCM_I_INUMP (denominator
))
472 scm_t_inum yy
= SCM_I_INUM (denominator
);
473 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
474 return scm_divide (numerator
, denominator
);
478 if (scm_is_eq (numerator
, denominator
))
480 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
481 SCM_I_BIG_MPZ (denominator
)))
482 return scm_divide(numerator
, denominator
);
486 /* No, it's a proper fraction.
489 SCM divisor
= scm_gcd (numerator
, denominator
);
490 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
492 numerator
= scm_divide (numerator
, divisor
);
493 denominator
= scm_divide (denominator
, divisor
);
496 return scm_double_cell (scm_tc16_fraction
,
497 SCM_UNPACK (numerator
),
498 SCM_UNPACK (denominator
), 0);
504 scm_i_fraction2double (SCM z
)
506 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
507 SCM_FRACTION_DENOMINATOR (z
)));
511 double_is_non_negative_zero (double x
)
513 static double zero
= 0.0;
515 return !memcmp (&x
, &zero
, sizeof(double));
518 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
520 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
522 #define FUNC_NAME s_scm_exact_p
524 if (SCM_INEXACTP (x
))
526 else if (SCM_NUMBERP (x
))
529 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
534 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
536 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
538 #define FUNC_NAME s_scm_inexact_p
540 if (SCM_INEXACTP (x
))
542 else if (SCM_NUMBERP (x
))
545 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
550 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
552 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
554 #define FUNC_NAME s_scm_odd_p
558 scm_t_inum val
= SCM_I_INUM (n
);
559 return scm_from_bool ((val
& 1L) != 0);
561 else if (SCM_BIGP (n
))
563 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
564 scm_remember_upto_here_1 (n
);
565 return scm_from_bool (odd_p
);
567 else if (SCM_REALP (n
))
569 double val
= SCM_REAL_VALUE (n
);
570 if (DOUBLE_IS_FINITE (val
))
572 double rem
= fabs (fmod (val
, 2.0));
579 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
584 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
586 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
588 #define FUNC_NAME s_scm_even_p
592 scm_t_inum val
= SCM_I_INUM (n
);
593 return scm_from_bool ((val
& 1L) == 0);
595 else if (SCM_BIGP (n
))
597 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
598 scm_remember_upto_here_1 (n
);
599 return scm_from_bool (even_p
);
601 else if (SCM_REALP (n
))
603 double val
= SCM_REAL_VALUE (n
);
604 if (DOUBLE_IS_FINITE (val
))
606 double rem
= fabs (fmod (val
, 2.0));
613 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
617 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
619 "Return @code{#t} if the real number @var{x} is neither\n"
620 "infinite nor a NaN, @code{#f} otherwise.")
621 #define FUNC_NAME s_scm_finite_p
624 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
625 else if (scm_is_real (x
))
628 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
632 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
634 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
635 "@samp{-inf.0}. Otherwise return @code{#f}.")
636 #define FUNC_NAME s_scm_inf_p
639 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
640 else if (scm_is_real (x
))
643 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
647 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
649 "Return @code{#t} if the real number @var{x} is a NaN,\n"
650 "or @code{#f} otherwise.")
651 #define FUNC_NAME s_scm_nan_p
654 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
655 else if (scm_is_real (x
))
658 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
662 /* Guile's idea of infinity. */
663 static double guile_Inf
;
665 /* Guile's idea of not a number. */
666 static double guile_NaN
;
669 guile_ieee_init (void)
671 /* Some version of gcc on some old version of Linux used to crash when
672 trying to make Inf and NaN. */
675 /* C99 INFINITY, when available.
676 FIXME: The standard allows for INFINITY to be something that overflows
677 at compile time. We ought to have a configure test to check for that
678 before trying to use it. (But in practice we believe this is not a
679 problem on any system guile is likely to target.) */
680 guile_Inf
= INFINITY
;
681 #elif defined HAVE_DINFINITY
683 extern unsigned int DINFINITY
[2];
684 guile_Inf
= (*((double *) (DINFINITY
)));
691 if (guile_Inf
== tmp
)
698 /* C99 NAN, when available */
700 #elif defined HAVE_DQNAN
703 extern unsigned int DQNAN
[2];
704 guile_NaN
= (*((double *)(DQNAN
)));
707 guile_NaN
= guile_Inf
/ guile_Inf
;
711 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
714 #define FUNC_NAME s_scm_inf
716 static int initialized
= 0;
722 return scm_from_double (guile_Inf
);
726 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
729 #define FUNC_NAME s_scm_nan
731 static int initialized
= 0;
737 return scm_from_double (guile_NaN
);
742 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
744 "Return the absolute value of @var{x}.")
745 #define FUNC_NAME s_scm_abs
749 scm_t_inum xx
= SCM_I_INUM (x
);
752 else if (SCM_POSFIXABLE (-xx
))
753 return SCM_I_MAKINUM (-xx
);
755 return scm_i_inum2big (-xx
);
757 else if (SCM_LIKELY (SCM_REALP (x
)))
759 double xx
= SCM_REAL_VALUE (x
);
760 /* If x is a NaN then xx<0 is false so we return x unchanged */
762 return scm_from_double (-xx
);
763 /* Handle signed zeroes properly */
764 else if (SCM_UNLIKELY (xx
== 0.0))
769 else if (SCM_BIGP (x
))
771 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
773 return scm_i_clonebig (x
, 0);
777 else if (SCM_FRACTIONP (x
))
779 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
781 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
782 SCM_FRACTION_DENOMINATOR (x
));
785 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
790 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
792 "Return the quotient of the numbers @var{x} and @var{y}.")
793 #define FUNC_NAME s_scm_quotient
795 if (SCM_LIKELY (SCM_I_INUMP (x
)) || SCM_LIKELY (SCM_BIGP (x
)))
797 if (SCM_LIKELY (SCM_I_INUMP (y
)) || SCM_LIKELY (SCM_BIGP (y
)))
798 return scm_truncate_quotient (x
, y
);
800 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
803 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
807 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
809 "Return the remainder of the numbers @var{x} and @var{y}.\n"
811 "(remainder 13 4) @result{} 1\n"
812 "(remainder -13 4) @result{} -1\n"
814 #define FUNC_NAME s_scm_remainder
816 if (SCM_LIKELY (SCM_I_INUMP (x
)) || SCM_LIKELY (SCM_BIGP (x
)))
818 if (SCM_LIKELY (SCM_I_INUMP (y
)) || SCM_LIKELY (SCM_BIGP (y
)))
819 return scm_truncate_remainder (x
, y
);
821 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
824 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
829 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
831 "Return the modulo of the numbers @var{x} and @var{y}.\n"
833 "(modulo 13 4) @result{} 1\n"
834 "(modulo -13 4) @result{} 3\n"
836 #define FUNC_NAME s_scm_modulo
838 if (SCM_LIKELY (SCM_I_INUMP (x
)) || SCM_LIKELY (SCM_BIGP (x
)))
840 if (SCM_LIKELY (SCM_I_INUMP (y
)) || SCM_LIKELY (SCM_BIGP (y
)))
841 return scm_floor_remainder (x
, y
);
843 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
846 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
850 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
851 two-valued functions. It is called from primitive generics that take
852 two arguments and return two values, when the core procedure is
853 unable to handle the given argument types. If there are GOOPS
854 methods for this primitive generic, it dispatches to GOOPS and, if
855 successful, expects two values to be returned, which are placed in
856 *rp1 and *rp2. If there are no GOOPS methods, it throws a
857 wrong-type-arg exception.
859 FIXME: This obviously belongs somewhere else, but until we decide on
860 the right API, it is here as a static function, because it is needed
861 by the *_divide functions below.
864 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
865 const char *subr
, SCM
*rp1
, SCM
*rp2
)
868 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
870 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
873 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
875 "Return the integer @var{q} such that\n"
876 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
877 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
879 "(euclidean-quotient 123 10) @result{} 12\n"
880 "(euclidean-quotient 123 -10) @result{} -12\n"
881 "(euclidean-quotient -123 10) @result{} -13\n"
882 "(euclidean-quotient -123 -10) @result{} 13\n"
883 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
884 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
886 #define FUNC_NAME s_scm_euclidean_quotient
888 if (scm_is_false (scm_negative_p (y
)))
889 return scm_floor_quotient (x
, y
);
891 return scm_ceiling_quotient (x
, y
);
895 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
897 "Return the real number @var{r} such that\n"
898 "@math{0 <= @var{r} < abs(@var{y})} and\n"
899 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
900 "for some integer @var{q}.\n"
902 "(euclidean-remainder 123 10) @result{} 3\n"
903 "(euclidean-remainder 123 -10) @result{} 3\n"
904 "(euclidean-remainder -123 10) @result{} 7\n"
905 "(euclidean-remainder -123 -10) @result{} 7\n"
906 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
907 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
909 #define FUNC_NAME s_scm_euclidean_remainder
911 if (scm_is_false (scm_negative_p (y
)))
912 return scm_floor_remainder (x
, y
);
914 return scm_ceiling_remainder (x
, y
);
918 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
920 "Return the integer @var{q} and the real number @var{r}\n"
921 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
922 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
924 "(euclidean/ 123 10) @result{} 12 and 3\n"
925 "(euclidean/ 123 -10) @result{} -12 and 3\n"
926 "(euclidean/ -123 10) @result{} -13 and 7\n"
927 "(euclidean/ -123 -10) @result{} 13 and 7\n"
928 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
929 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
931 #define FUNC_NAME s_scm_i_euclidean_divide
933 if (scm_is_false (scm_negative_p (y
)))
934 return scm_i_floor_divide (x
, y
);
936 return scm_i_ceiling_divide (x
, y
);
941 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
943 if (scm_is_false (scm_negative_p (y
)))
944 return scm_floor_divide (x
, y
, qp
, rp
);
946 return scm_ceiling_divide (x
, y
, qp
, rp
);
949 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
950 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
952 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
954 "Return the floor of @math{@var{x} / @var{y}}.\n"
956 "(floor-quotient 123 10) @result{} 12\n"
957 "(floor-quotient 123 -10) @result{} -13\n"
958 "(floor-quotient -123 10) @result{} -13\n"
959 "(floor-quotient -123 -10) @result{} 12\n"
960 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
961 "(floor-quotient 16/3 -10/7) @result{} -4\n"
963 #define FUNC_NAME s_scm_floor_quotient
965 if (SCM_LIKELY (SCM_I_INUMP (x
)))
967 scm_t_inum xx
= SCM_I_INUM (x
);
968 if (SCM_LIKELY (SCM_I_INUMP (y
)))
970 scm_t_inum yy
= SCM_I_INUM (y
);
973 if (SCM_LIKELY (yy
> 0))
975 if (SCM_UNLIKELY (xx
< 0))
978 else if (SCM_UNLIKELY (yy
== 0))
979 scm_num_overflow (s_scm_floor_quotient
);
983 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
984 return SCM_I_MAKINUM (qq
);
986 return scm_i_inum2big (qq
);
988 else if (SCM_BIGP (y
))
990 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
991 scm_remember_upto_here_1 (y
);
993 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
995 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
997 else if (SCM_REALP (y
))
998 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
999 else if (SCM_FRACTIONP (y
))
1000 return scm_i_exact_rational_floor_quotient (x
, y
);
1002 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1003 s_scm_floor_quotient
);
1005 else if (SCM_BIGP (x
))
1007 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1009 scm_t_inum yy
= SCM_I_INUM (y
);
1010 if (SCM_UNLIKELY (yy
== 0))
1011 scm_num_overflow (s_scm_floor_quotient
);
1012 else if (SCM_UNLIKELY (yy
== 1))
1016 SCM q
= scm_i_mkbig ();
1018 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1021 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1022 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1024 scm_remember_upto_here_1 (x
);
1025 return scm_i_normbig (q
);
1028 else if (SCM_BIGP (y
))
1030 SCM q
= scm_i_mkbig ();
1031 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1034 scm_remember_upto_here_2 (x
, y
);
1035 return scm_i_normbig (q
);
1037 else if (SCM_REALP (y
))
1038 return scm_i_inexact_floor_quotient
1039 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1040 else if (SCM_FRACTIONP (y
))
1041 return scm_i_exact_rational_floor_quotient (x
, y
);
1043 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1044 s_scm_floor_quotient
);
1046 else if (SCM_REALP (x
))
1048 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1049 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1050 return scm_i_inexact_floor_quotient
1051 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1053 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1054 s_scm_floor_quotient
);
1056 else if (SCM_FRACTIONP (x
))
1059 return scm_i_inexact_floor_quotient
1060 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1061 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1062 return scm_i_exact_rational_floor_quotient (x
, y
);
1064 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1065 s_scm_floor_quotient
);
1068 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1069 s_scm_floor_quotient
);
1074 scm_i_inexact_floor_quotient (double x
, double y
)
1076 if (SCM_UNLIKELY (y
== 0))
1077 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1079 return scm_from_double (floor (x
/ y
));
1083 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1085 return scm_floor_quotient
1086 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1087 scm_product (scm_numerator (y
), scm_denominator (x
)));
1090 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1091 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1093 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1095 "Return the real number @var{r} such that\n"
1096 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1097 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1099 "(floor-remainder 123 10) @result{} 3\n"
1100 "(floor-remainder 123 -10) @result{} -7\n"
1101 "(floor-remainder -123 10) @result{} 7\n"
1102 "(floor-remainder -123 -10) @result{} -3\n"
1103 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1104 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1106 #define FUNC_NAME s_scm_floor_remainder
1108 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1110 scm_t_inum xx
= SCM_I_INUM (x
);
1111 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1113 scm_t_inum yy
= SCM_I_INUM (y
);
1114 if (SCM_UNLIKELY (yy
== 0))
1115 scm_num_overflow (s_scm_floor_remainder
);
1118 scm_t_inum rr
= xx
% yy
;
1119 int needs_adjustment
;
1121 if (SCM_LIKELY (yy
> 0))
1122 needs_adjustment
= (rr
< 0);
1124 needs_adjustment
= (rr
> 0);
1126 if (needs_adjustment
)
1128 return SCM_I_MAKINUM (rr
);
1131 else if (SCM_BIGP (y
))
1133 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1134 scm_remember_upto_here_1 (y
);
1139 SCM r
= scm_i_mkbig ();
1140 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1141 scm_remember_upto_here_1 (y
);
1142 return scm_i_normbig (r
);
1151 SCM r
= scm_i_mkbig ();
1152 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1153 scm_remember_upto_here_1 (y
);
1154 return scm_i_normbig (r
);
1157 else if (SCM_REALP (y
))
1158 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1159 else if (SCM_FRACTIONP (y
))
1160 return scm_i_exact_rational_floor_remainder (x
, y
);
1162 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1163 s_scm_floor_remainder
);
1165 else if (SCM_BIGP (x
))
1167 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1169 scm_t_inum yy
= SCM_I_INUM (y
);
1170 if (SCM_UNLIKELY (yy
== 0))
1171 scm_num_overflow (s_scm_floor_remainder
);
1176 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1178 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1179 scm_remember_upto_here_1 (x
);
1180 return SCM_I_MAKINUM (rr
);
1183 else if (SCM_BIGP (y
))
1185 SCM r
= scm_i_mkbig ();
1186 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1189 scm_remember_upto_here_2 (x
, y
);
1190 return scm_i_normbig (r
);
1192 else if (SCM_REALP (y
))
1193 return scm_i_inexact_floor_remainder
1194 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1195 else if (SCM_FRACTIONP (y
))
1196 return scm_i_exact_rational_floor_remainder (x
, y
);
1198 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1199 s_scm_floor_remainder
);
1201 else if (SCM_REALP (x
))
1203 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1204 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1205 return scm_i_inexact_floor_remainder
1206 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1208 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1209 s_scm_floor_remainder
);
1211 else if (SCM_FRACTIONP (x
))
1214 return scm_i_inexact_floor_remainder
1215 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1216 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1217 return scm_i_exact_rational_floor_remainder (x
, y
);
1219 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1220 s_scm_floor_remainder
);
1223 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1224 s_scm_floor_remainder
);
1229 scm_i_inexact_floor_remainder (double x
, double y
)
1231 /* Although it would be more efficient to use fmod here, we can't
1232 because it would in some cases produce results inconsistent with
1233 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1234 close). In particular, when x is very close to a multiple of y,
1235 then r might be either 0.0 or y, but those two cases must
1236 correspond to different choices of q. If r = 0.0 then q must be
1237 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1238 and remainder chooses the other, it would be bad. */
1239 if (SCM_UNLIKELY (y
== 0))
1240 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1242 return scm_from_double (x
- y
* floor (x
/ y
));
1246 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1248 SCM xd
= scm_denominator (x
);
1249 SCM yd
= scm_denominator (y
);
1250 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1251 scm_product (scm_numerator (y
), xd
));
1252 return scm_divide (r1
, scm_product (xd
, yd
));
1256 static void scm_i_inexact_floor_divide (double x
, double y
,
1258 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1261 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1263 "Return the integer @var{q} and the real number @var{r}\n"
1264 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1265 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1267 "(floor/ 123 10) @result{} 12 and 3\n"
1268 "(floor/ 123 -10) @result{} -13 and -7\n"
1269 "(floor/ -123 10) @result{} -13 and 7\n"
1270 "(floor/ -123 -10) @result{} 12 and -3\n"
1271 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1272 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1274 #define FUNC_NAME s_scm_i_floor_divide
1278 scm_floor_divide(x
, y
, &q
, &r
);
1279 return scm_values (scm_list_2 (q
, r
));
1283 #define s_scm_floor_divide s_scm_i_floor_divide
1284 #define g_scm_floor_divide g_scm_i_floor_divide
1287 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1289 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1291 scm_t_inum xx
= SCM_I_INUM (x
);
1292 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1294 scm_t_inum yy
= SCM_I_INUM (y
);
1295 if (SCM_UNLIKELY (yy
== 0))
1296 scm_num_overflow (s_scm_floor_divide
);
1299 scm_t_inum qq
= xx
/ yy
;
1300 scm_t_inum rr
= xx
% yy
;
1301 int needs_adjustment
;
1303 if (SCM_LIKELY (yy
> 0))
1304 needs_adjustment
= (rr
< 0);
1306 needs_adjustment
= (rr
> 0);
1308 if (needs_adjustment
)
1314 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1315 *qp
= SCM_I_MAKINUM (qq
);
1317 *qp
= scm_i_inum2big (qq
);
1318 *rp
= SCM_I_MAKINUM (rr
);
1322 else if (SCM_BIGP (y
))
1324 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1325 scm_remember_upto_here_1 (y
);
1330 SCM r
= scm_i_mkbig ();
1331 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1332 scm_remember_upto_here_1 (y
);
1333 *qp
= SCM_I_MAKINUM (-1);
1334 *rp
= scm_i_normbig (r
);
1349 SCM r
= scm_i_mkbig ();
1350 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1351 scm_remember_upto_here_1 (y
);
1352 *qp
= SCM_I_MAKINUM (-1);
1353 *rp
= scm_i_normbig (r
);
1357 else if (SCM_REALP (y
))
1358 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1359 else if (SCM_FRACTIONP (y
))
1360 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1362 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1363 s_scm_floor_divide
, qp
, rp
);
1365 else if (SCM_BIGP (x
))
1367 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1369 scm_t_inum yy
= SCM_I_INUM (y
);
1370 if (SCM_UNLIKELY (yy
== 0))
1371 scm_num_overflow (s_scm_floor_divide
);
1374 SCM q
= scm_i_mkbig ();
1375 SCM r
= scm_i_mkbig ();
1377 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1378 SCM_I_BIG_MPZ (x
), yy
);
1381 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1382 SCM_I_BIG_MPZ (x
), -yy
);
1383 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1385 scm_remember_upto_here_1 (x
);
1386 *qp
= scm_i_normbig (q
);
1387 *rp
= scm_i_normbig (r
);
1391 else if (SCM_BIGP (y
))
1393 SCM q
= scm_i_mkbig ();
1394 SCM r
= scm_i_mkbig ();
1395 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1396 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1397 scm_remember_upto_here_2 (x
, y
);
1398 *qp
= scm_i_normbig (q
);
1399 *rp
= scm_i_normbig (r
);
1402 else if (SCM_REALP (y
))
1403 return scm_i_inexact_floor_divide
1404 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1405 else if (SCM_FRACTIONP (y
))
1406 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1408 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1409 s_scm_floor_divide
, qp
, rp
);
1411 else if (SCM_REALP (x
))
1413 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1414 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1415 return scm_i_inexact_floor_divide
1416 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1418 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1419 s_scm_floor_divide
, qp
, rp
);
1421 else if (SCM_FRACTIONP (x
))
1424 return scm_i_inexact_floor_divide
1425 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1426 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1427 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1429 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1430 s_scm_floor_divide
, qp
, rp
);
1433 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1434 s_scm_floor_divide
, qp
, rp
);
1438 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1440 if (SCM_UNLIKELY (y
== 0))
1441 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1444 double q
= floor (x
/ y
);
1445 double r
= x
- q
* y
;
1446 *qp
= scm_from_double (q
);
1447 *rp
= scm_from_double (r
);
1452 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1455 SCM xd
= scm_denominator (x
);
1456 SCM yd
= scm_denominator (y
);
1458 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1459 scm_product (scm_numerator (y
), xd
),
1461 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1464 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1465 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1467 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1469 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1471 "(ceiling-quotient 123 10) @result{} 13\n"
1472 "(ceiling-quotient 123 -10) @result{} -12\n"
1473 "(ceiling-quotient -123 10) @result{} -12\n"
1474 "(ceiling-quotient -123 -10) @result{} 13\n"
1475 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1476 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1478 #define FUNC_NAME s_scm_ceiling_quotient
1480 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1482 scm_t_inum xx
= SCM_I_INUM (x
);
1483 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1485 scm_t_inum yy
= SCM_I_INUM (y
);
1486 if (SCM_UNLIKELY (yy
== 0))
1487 scm_num_overflow (s_scm_ceiling_quotient
);
1490 scm_t_inum xx1
= xx
;
1492 if (SCM_LIKELY (yy
> 0))
1494 if (SCM_LIKELY (xx
>= 0))
1497 else if (SCM_UNLIKELY (yy
== 0))
1498 scm_num_overflow (s_scm_ceiling_quotient
);
1502 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1503 return SCM_I_MAKINUM (qq
);
1505 return scm_i_inum2big (qq
);
1508 else if (SCM_BIGP (y
))
1510 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1511 scm_remember_upto_here_1 (y
);
1512 if (SCM_LIKELY (sign
> 0))
1514 if (SCM_LIKELY (xx
> 0))
1516 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1517 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1518 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1520 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1521 scm_remember_upto_here_1 (y
);
1522 return SCM_I_MAKINUM (-1);
1532 else if (SCM_REALP (y
))
1533 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1534 else if (SCM_FRACTIONP (y
))
1535 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1537 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1538 s_scm_ceiling_quotient
);
1540 else if (SCM_BIGP (x
))
1542 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1544 scm_t_inum yy
= SCM_I_INUM (y
);
1545 if (SCM_UNLIKELY (yy
== 0))
1546 scm_num_overflow (s_scm_ceiling_quotient
);
1547 else if (SCM_UNLIKELY (yy
== 1))
1551 SCM q
= scm_i_mkbig ();
1553 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1556 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1557 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1559 scm_remember_upto_here_1 (x
);
1560 return scm_i_normbig (q
);
1563 else if (SCM_BIGP (y
))
1565 SCM q
= scm_i_mkbig ();
1566 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1569 scm_remember_upto_here_2 (x
, y
);
1570 return scm_i_normbig (q
);
1572 else if (SCM_REALP (y
))
1573 return scm_i_inexact_ceiling_quotient
1574 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1575 else if (SCM_FRACTIONP (y
))
1576 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1578 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1579 s_scm_ceiling_quotient
);
1581 else if (SCM_REALP (x
))
1583 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1584 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1585 return scm_i_inexact_ceiling_quotient
1586 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1588 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1589 s_scm_ceiling_quotient
);
1591 else if (SCM_FRACTIONP (x
))
1594 return scm_i_inexact_ceiling_quotient
1595 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1596 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1597 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1599 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1600 s_scm_ceiling_quotient
);
1603 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1604 s_scm_ceiling_quotient
);
1609 scm_i_inexact_ceiling_quotient (double x
, double y
)
1611 if (SCM_UNLIKELY (y
== 0))
1612 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1614 return scm_from_double (ceil (x
/ y
));
1618 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1620 return scm_ceiling_quotient
1621 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1622 scm_product (scm_numerator (y
), scm_denominator (x
)));
1625 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1626 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1628 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1630 "Return the real number @var{r} such that\n"
1631 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1632 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1634 "(ceiling-remainder 123 10) @result{} -7\n"
1635 "(ceiling-remainder 123 -10) @result{} 3\n"
1636 "(ceiling-remainder -123 10) @result{} -3\n"
1637 "(ceiling-remainder -123 -10) @result{} 7\n"
1638 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1639 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1641 #define FUNC_NAME s_scm_ceiling_remainder
1643 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1645 scm_t_inum xx
= SCM_I_INUM (x
);
1646 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1648 scm_t_inum yy
= SCM_I_INUM (y
);
1649 if (SCM_UNLIKELY (yy
== 0))
1650 scm_num_overflow (s_scm_ceiling_remainder
);
1653 scm_t_inum rr
= xx
% yy
;
1654 int needs_adjustment
;
1656 if (SCM_LIKELY (yy
> 0))
1657 needs_adjustment
= (rr
> 0);
1659 needs_adjustment
= (rr
< 0);
1661 if (needs_adjustment
)
1663 return SCM_I_MAKINUM (rr
);
1666 else if (SCM_BIGP (y
))
1668 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1669 scm_remember_upto_here_1 (y
);
1670 if (SCM_LIKELY (sign
> 0))
1672 if (SCM_LIKELY (xx
> 0))
1674 SCM r
= scm_i_mkbig ();
1675 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1676 scm_remember_upto_here_1 (y
);
1677 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1678 return scm_i_normbig (r
);
1680 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1681 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1682 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1684 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1685 scm_remember_upto_here_1 (y
);
1695 SCM r
= scm_i_mkbig ();
1696 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1697 scm_remember_upto_here_1 (y
);
1698 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1699 return scm_i_normbig (r
);
1702 else if (SCM_REALP (y
))
1703 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1704 else if (SCM_FRACTIONP (y
))
1705 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1707 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1708 s_scm_ceiling_remainder
);
1710 else if (SCM_BIGP (x
))
1712 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1714 scm_t_inum yy
= SCM_I_INUM (y
);
1715 if (SCM_UNLIKELY (yy
== 0))
1716 scm_num_overflow (s_scm_ceiling_remainder
);
1721 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1723 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1724 scm_remember_upto_here_1 (x
);
1725 return SCM_I_MAKINUM (rr
);
1728 else if (SCM_BIGP (y
))
1730 SCM r
= scm_i_mkbig ();
1731 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1734 scm_remember_upto_here_2 (x
, y
);
1735 return scm_i_normbig (r
);
1737 else if (SCM_REALP (y
))
1738 return scm_i_inexact_ceiling_remainder
1739 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1740 else if (SCM_FRACTIONP (y
))
1741 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1743 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1744 s_scm_ceiling_remainder
);
1746 else if (SCM_REALP (x
))
1748 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1749 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1750 return scm_i_inexact_ceiling_remainder
1751 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1753 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1754 s_scm_ceiling_remainder
);
1756 else if (SCM_FRACTIONP (x
))
1759 return scm_i_inexact_ceiling_remainder
1760 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1761 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1762 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1764 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1765 s_scm_ceiling_remainder
);
1768 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1769 s_scm_ceiling_remainder
);
1774 scm_i_inexact_ceiling_remainder (double x
, double y
)
1776 /* Although it would be more efficient to use fmod here, we can't
1777 because it would in some cases produce results inconsistent with
1778 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1779 close). In particular, when x is very close to a multiple of y,
1780 then r might be either 0.0 or -y, but those two cases must
1781 correspond to different choices of q. If r = 0.0 then q must be
1782 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1783 and remainder chooses the other, it would be bad. */
1784 if (SCM_UNLIKELY (y
== 0))
1785 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1787 return scm_from_double (x
- y
* ceil (x
/ y
));
1791 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1793 SCM xd
= scm_denominator (x
);
1794 SCM yd
= scm_denominator (y
);
1795 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1796 scm_product (scm_numerator (y
), xd
));
1797 return scm_divide (r1
, scm_product (xd
, yd
));
1800 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1802 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1805 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1807 "Return the integer @var{q} and the real number @var{r}\n"
1808 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1809 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1811 "(ceiling/ 123 10) @result{} 13 and -7\n"
1812 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1813 "(ceiling/ -123 10) @result{} -12 and -3\n"
1814 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1815 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1816 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1818 #define FUNC_NAME s_scm_i_ceiling_divide
1822 scm_ceiling_divide(x
, y
, &q
, &r
);
1823 return scm_values (scm_list_2 (q
, r
));
1827 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1828 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1831 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1833 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1835 scm_t_inum xx
= SCM_I_INUM (x
);
1836 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1838 scm_t_inum yy
= SCM_I_INUM (y
);
1839 if (SCM_UNLIKELY (yy
== 0))
1840 scm_num_overflow (s_scm_ceiling_divide
);
1843 scm_t_inum qq
= xx
/ yy
;
1844 scm_t_inum rr
= xx
% yy
;
1845 int needs_adjustment
;
1847 if (SCM_LIKELY (yy
> 0))
1848 needs_adjustment
= (rr
> 0);
1850 needs_adjustment
= (rr
< 0);
1852 if (needs_adjustment
)
1857 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1858 *qp
= SCM_I_MAKINUM (qq
);
1860 *qp
= scm_i_inum2big (qq
);
1861 *rp
= SCM_I_MAKINUM (rr
);
1865 else if (SCM_BIGP (y
))
1867 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1868 scm_remember_upto_here_1 (y
);
1869 if (SCM_LIKELY (sign
> 0))
1871 if (SCM_LIKELY (xx
> 0))
1873 SCM r
= scm_i_mkbig ();
1874 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1875 scm_remember_upto_here_1 (y
);
1876 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1878 *rp
= scm_i_normbig (r
);
1880 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1881 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1882 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1884 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1885 scm_remember_upto_here_1 (y
);
1886 *qp
= SCM_I_MAKINUM (-1);
1902 SCM r
= scm_i_mkbig ();
1903 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1904 scm_remember_upto_here_1 (y
);
1905 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1907 *rp
= scm_i_normbig (r
);
1911 else if (SCM_REALP (y
))
1912 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1913 else if (SCM_FRACTIONP (y
))
1914 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1916 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1917 s_scm_ceiling_divide
, qp
, rp
);
1919 else if (SCM_BIGP (x
))
1921 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1923 scm_t_inum yy
= SCM_I_INUM (y
);
1924 if (SCM_UNLIKELY (yy
== 0))
1925 scm_num_overflow (s_scm_ceiling_divide
);
1928 SCM q
= scm_i_mkbig ();
1929 SCM r
= scm_i_mkbig ();
1931 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1932 SCM_I_BIG_MPZ (x
), yy
);
1935 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1936 SCM_I_BIG_MPZ (x
), -yy
);
1937 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1939 scm_remember_upto_here_1 (x
);
1940 *qp
= scm_i_normbig (q
);
1941 *rp
= scm_i_normbig (r
);
1945 else if (SCM_BIGP (y
))
1947 SCM q
= scm_i_mkbig ();
1948 SCM r
= scm_i_mkbig ();
1949 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1950 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1951 scm_remember_upto_here_2 (x
, y
);
1952 *qp
= scm_i_normbig (q
);
1953 *rp
= scm_i_normbig (r
);
1956 else if (SCM_REALP (y
))
1957 return scm_i_inexact_ceiling_divide
1958 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1959 else if (SCM_FRACTIONP (y
))
1960 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1962 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1963 s_scm_ceiling_divide
, qp
, rp
);
1965 else if (SCM_REALP (x
))
1967 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1968 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1969 return scm_i_inexact_ceiling_divide
1970 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1972 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1973 s_scm_ceiling_divide
, qp
, rp
);
1975 else if (SCM_FRACTIONP (x
))
1978 return scm_i_inexact_ceiling_divide
1979 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1980 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1981 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1983 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1984 s_scm_ceiling_divide
, qp
, rp
);
1987 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
1988 s_scm_ceiling_divide
, qp
, rp
);
1992 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1994 if (SCM_UNLIKELY (y
== 0))
1995 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
1998 double q
= ceil (x
/ y
);
1999 double r
= x
- q
* y
;
2000 *qp
= scm_from_double (q
);
2001 *rp
= scm_from_double (r
);
2006 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2009 SCM xd
= scm_denominator (x
);
2010 SCM yd
= scm_denominator (y
);
2012 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2013 scm_product (scm_numerator (y
), xd
),
2015 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2018 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2019 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2021 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2023 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2025 "(truncate-quotient 123 10) @result{} 12\n"
2026 "(truncate-quotient 123 -10) @result{} -12\n"
2027 "(truncate-quotient -123 10) @result{} -12\n"
2028 "(truncate-quotient -123 -10) @result{} 12\n"
2029 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2030 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2032 #define FUNC_NAME s_scm_truncate_quotient
2034 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2036 scm_t_inum xx
= SCM_I_INUM (x
);
2037 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2039 scm_t_inum yy
= SCM_I_INUM (y
);
2040 if (SCM_UNLIKELY (yy
== 0))
2041 scm_num_overflow (s_scm_truncate_quotient
);
2044 scm_t_inum qq
= xx
/ yy
;
2045 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2046 return SCM_I_MAKINUM (qq
);
2048 return scm_i_inum2big (qq
);
2051 else if (SCM_BIGP (y
))
2053 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2054 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2055 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2057 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2058 scm_remember_upto_here_1 (y
);
2059 return SCM_I_MAKINUM (-1);
2064 else if (SCM_REALP (y
))
2065 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2066 else if (SCM_FRACTIONP (y
))
2067 return scm_i_exact_rational_truncate_quotient (x
, y
);
2069 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2070 s_scm_truncate_quotient
);
2072 else if (SCM_BIGP (x
))
2074 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2076 scm_t_inum yy
= SCM_I_INUM (y
);
2077 if (SCM_UNLIKELY (yy
== 0))
2078 scm_num_overflow (s_scm_truncate_quotient
);
2079 else if (SCM_UNLIKELY (yy
== 1))
2083 SCM q
= scm_i_mkbig ();
2085 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2088 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2089 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2091 scm_remember_upto_here_1 (x
);
2092 return scm_i_normbig (q
);
2095 else if (SCM_BIGP (y
))
2097 SCM q
= scm_i_mkbig ();
2098 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2101 scm_remember_upto_here_2 (x
, y
);
2102 return scm_i_normbig (q
);
2104 else if (SCM_REALP (y
))
2105 return scm_i_inexact_truncate_quotient
2106 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2107 else if (SCM_FRACTIONP (y
))
2108 return scm_i_exact_rational_truncate_quotient (x
, y
);
2110 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2111 s_scm_truncate_quotient
);
2113 else if (SCM_REALP (x
))
2115 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2116 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2117 return scm_i_inexact_truncate_quotient
2118 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2120 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2121 s_scm_truncate_quotient
);
2123 else if (SCM_FRACTIONP (x
))
2126 return scm_i_inexact_truncate_quotient
2127 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2128 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2129 return scm_i_exact_rational_truncate_quotient (x
, y
);
2131 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2132 s_scm_truncate_quotient
);
2135 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2136 s_scm_truncate_quotient
);
2141 scm_i_inexact_truncate_quotient (double x
, double y
)
2143 if (SCM_UNLIKELY (y
== 0))
2144 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2146 return scm_from_double (trunc (x
/ y
));
2150 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2152 return scm_truncate_quotient
2153 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2154 scm_product (scm_numerator (y
), scm_denominator (x
)));
2157 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2158 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2160 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2162 "Return the real number @var{r} such that\n"
2163 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2164 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2166 "(truncate-remainder 123 10) @result{} 3\n"
2167 "(truncate-remainder 123 -10) @result{} 3\n"
2168 "(truncate-remainder -123 10) @result{} -3\n"
2169 "(truncate-remainder -123 -10) @result{} -3\n"
2170 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2171 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2173 #define FUNC_NAME s_scm_truncate_remainder
2175 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2177 scm_t_inum xx
= SCM_I_INUM (x
);
2178 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2180 scm_t_inum yy
= SCM_I_INUM (y
);
2181 if (SCM_UNLIKELY (yy
== 0))
2182 scm_num_overflow (s_scm_truncate_remainder
);
2184 return SCM_I_MAKINUM (xx
% yy
);
2186 else if (SCM_BIGP (y
))
2188 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2189 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2190 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2192 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2193 scm_remember_upto_here_1 (y
);
2199 else if (SCM_REALP (y
))
2200 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2201 else if (SCM_FRACTIONP (y
))
2202 return scm_i_exact_rational_truncate_remainder (x
, y
);
2204 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2205 s_scm_truncate_remainder
);
2207 else if (SCM_BIGP (x
))
2209 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2211 scm_t_inum yy
= SCM_I_INUM (y
);
2212 if (SCM_UNLIKELY (yy
== 0))
2213 scm_num_overflow (s_scm_truncate_remainder
);
2216 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2217 (yy
> 0) ? yy
: -yy
)
2218 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2219 scm_remember_upto_here_1 (x
);
2220 return SCM_I_MAKINUM (rr
);
2223 else if (SCM_BIGP (y
))
2225 SCM r
= scm_i_mkbig ();
2226 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2229 scm_remember_upto_here_2 (x
, y
);
2230 return scm_i_normbig (r
);
2232 else if (SCM_REALP (y
))
2233 return scm_i_inexact_truncate_remainder
2234 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2235 else if (SCM_FRACTIONP (y
))
2236 return scm_i_exact_rational_truncate_remainder (x
, y
);
2238 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2239 s_scm_truncate_remainder
);
2241 else if (SCM_REALP (x
))
2243 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2244 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2245 return scm_i_inexact_truncate_remainder
2246 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2248 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2249 s_scm_truncate_remainder
);
2251 else if (SCM_FRACTIONP (x
))
2254 return scm_i_inexact_truncate_remainder
2255 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2256 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2257 return scm_i_exact_rational_truncate_remainder (x
, y
);
2259 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2260 s_scm_truncate_remainder
);
2263 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2264 s_scm_truncate_remainder
);
2269 scm_i_inexact_truncate_remainder (double x
, double y
)
2271 /* Although it would be more efficient to use fmod here, we can't
2272 because it would in some cases produce results inconsistent with
2273 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2274 close). In particular, when x is very close to a multiple of y,
2275 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2276 correspond to different choices of q. If quotient chooses one and
2277 remainder chooses the other, it would be bad. */
2278 if (SCM_UNLIKELY (y
== 0))
2279 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2281 return scm_from_double (x
- y
* trunc (x
/ y
));
2285 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2287 SCM xd
= scm_denominator (x
);
2288 SCM yd
= scm_denominator (y
);
2289 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2290 scm_product (scm_numerator (y
), xd
));
2291 return scm_divide (r1
, scm_product (xd
, yd
));
2295 static void scm_i_inexact_truncate_divide (double x
, double y
,
2297 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2300 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2302 "Return the integer @var{q} and the real number @var{r}\n"
2303 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2304 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2306 "(truncate/ 123 10) @result{} 12 and 3\n"
2307 "(truncate/ 123 -10) @result{} -12 and 3\n"
2308 "(truncate/ -123 10) @result{} -12 and -3\n"
2309 "(truncate/ -123 -10) @result{} 12 and -3\n"
2310 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2311 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2313 #define FUNC_NAME s_scm_i_truncate_divide
2317 scm_truncate_divide(x
, y
, &q
, &r
);
2318 return scm_values (scm_list_2 (q
, r
));
2322 #define s_scm_truncate_divide s_scm_i_truncate_divide
2323 #define g_scm_truncate_divide g_scm_i_truncate_divide
2326 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2328 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2330 scm_t_inum xx
= SCM_I_INUM (x
);
2331 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2333 scm_t_inum yy
= SCM_I_INUM (y
);
2334 if (SCM_UNLIKELY (yy
== 0))
2335 scm_num_overflow (s_scm_truncate_divide
);
2338 scm_t_inum qq
= xx
/ yy
;
2339 scm_t_inum rr
= xx
% yy
;
2340 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2341 *qp
= SCM_I_MAKINUM (qq
);
2343 *qp
= scm_i_inum2big (qq
);
2344 *rp
= SCM_I_MAKINUM (rr
);
2348 else if (SCM_BIGP (y
))
2350 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2351 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2352 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2354 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2355 scm_remember_upto_here_1 (y
);
2356 *qp
= SCM_I_MAKINUM (-1);
2366 else if (SCM_REALP (y
))
2367 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2368 else if (SCM_FRACTIONP (y
))
2369 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2371 return two_valued_wta_dispatch_2
2372 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2373 s_scm_truncate_divide
, qp
, rp
);
2375 else if (SCM_BIGP (x
))
2377 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2379 scm_t_inum yy
= SCM_I_INUM (y
);
2380 if (SCM_UNLIKELY (yy
== 0))
2381 scm_num_overflow (s_scm_truncate_divide
);
2384 SCM q
= scm_i_mkbig ();
2387 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2388 SCM_I_BIG_MPZ (x
), yy
);
2391 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2392 SCM_I_BIG_MPZ (x
), -yy
);
2393 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2395 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2396 scm_remember_upto_here_1 (x
);
2397 *qp
= scm_i_normbig (q
);
2398 *rp
= SCM_I_MAKINUM (rr
);
2402 else if (SCM_BIGP (y
))
2404 SCM q
= scm_i_mkbig ();
2405 SCM r
= scm_i_mkbig ();
2406 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2407 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2408 scm_remember_upto_here_2 (x
, y
);
2409 *qp
= scm_i_normbig (q
);
2410 *rp
= scm_i_normbig (r
);
2412 else if (SCM_REALP (y
))
2413 return scm_i_inexact_truncate_divide
2414 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2415 else if (SCM_FRACTIONP (y
))
2416 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2418 return two_valued_wta_dispatch_2
2419 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2420 s_scm_truncate_divide
, qp
, rp
);
2422 else if (SCM_REALP (x
))
2424 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2425 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2426 return scm_i_inexact_truncate_divide
2427 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2429 return two_valued_wta_dispatch_2
2430 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2431 s_scm_truncate_divide
, qp
, rp
);
2433 else if (SCM_FRACTIONP (x
))
2436 return scm_i_inexact_truncate_divide
2437 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2438 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2439 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2441 return two_valued_wta_dispatch_2
2442 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2443 s_scm_truncate_divide
, qp
, rp
);
2446 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2447 s_scm_truncate_divide
, qp
, rp
);
2451 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2453 if (SCM_UNLIKELY (y
== 0))
2454 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2457 double q
= trunc (x
/ y
);
2458 double r
= x
- q
* y
;
2459 *qp
= scm_from_double (q
);
2460 *rp
= scm_from_double (r
);
2465 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2468 SCM xd
= scm_denominator (x
);
2469 SCM yd
= scm_denominator (y
);
2471 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2472 scm_product (scm_numerator (y
), xd
),
2474 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2477 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2478 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2479 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2481 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2483 "Return the integer @var{q} such that\n"
2484 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2485 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2487 "(centered-quotient 123 10) @result{} 12\n"
2488 "(centered-quotient 123 -10) @result{} -12\n"
2489 "(centered-quotient -123 10) @result{} -12\n"
2490 "(centered-quotient -123 -10) @result{} 12\n"
2491 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2492 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2494 #define FUNC_NAME s_scm_centered_quotient
2496 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2498 scm_t_inum xx
= SCM_I_INUM (x
);
2499 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2501 scm_t_inum yy
= SCM_I_INUM (y
);
2502 if (SCM_UNLIKELY (yy
== 0))
2503 scm_num_overflow (s_scm_centered_quotient
);
2506 scm_t_inum qq
= xx
/ yy
;
2507 scm_t_inum rr
= xx
% yy
;
2508 if (SCM_LIKELY (xx
> 0))
2510 if (SCM_LIKELY (yy
> 0))
2512 if (rr
>= (yy
+ 1) / 2)
2517 if (rr
>= (1 - yy
) / 2)
2523 if (SCM_LIKELY (yy
> 0))
2534 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2535 return SCM_I_MAKINUM (qq
);
2537 return scm_i_inum2big (qq
);
2540 else if (SCM_BIGP (y
))
2542 /* Pass a denormalized bignum version of x (even though it
2543 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2544 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2546 else if (SCM_REALP (y
))
2547 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2548 else if (SCM_FRACTIONP (y
))
2549 return scm_i_exact_rational_centered_quotient (x
, y
);
2551 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2552 s_scm_centered_quotient
);
2554 else if (SCM_BIGP (x
))
2556 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2558 scm_t_inum yy
= SCM_I_INUM (y
);
2559 if (SCM_UNLIKELY (yy
== 0))
2560 scm_num_overflow (s_scm_centered_quotient
);
2561 else if (SCM_UNLIKELY (yy
== 1))
2565 SCM q
= scm_i_mkbig ();
2567 /* Arrange for rr to initially be non-positive,
2568 because that simplifies the test to see
2569 if it is within the needed bounds. */
2572 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2573 SCM_I_BIG_MPZ (x
), yy
);
2574 scm_remember_upto_here_1 (x
);
2576 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2577 SCM_I_BIG_MPZ (q
), 1);
2581 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2582 SCM_I_BIG_MPZ (x
), -yy
);
2583 scm_remember_upto_here_1 (x
);
2584 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2586 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2587 SCM_I_BIG_MPZ (q
), 1);
2589 return scm_i_normbig (q
);
2592 else if (SCM_BIGP (y
))
2593 return scm_i_bigint_centered_quotient (x
, y
);
2594 else if (SCM_REALP (y
))
2595 return scm_i_inexact_centered_quotient
2596 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2597 else if (SCM_FRACTIONP (y
))
2598 return scm_i_exact_rational_centered_quotient (x
, y
);
2600 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2601 s_scm_centered_quotient
);
2603 else if (SCM_REALP (x
))
2605 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2606 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2607 return scm_i_inexact_centered_quotient
2608 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2610 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2611 s_scm_centered_quotient
);
2613 else if (SCM_FRACTIONP (x
))
2616 return scm_i_inexact_centered_quotient
2617 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2618 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2619 return scm_i_exact_rational_centered_quotient (x
, y
);
2621 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2622 s_scm_centered_quotient
);
2625 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2626 s_scm_centered_quotient
);
2631 scm_i_inexact_centered_quotient (double x
, double y
)
2633 if (SCM_LIKELY (y
> 0))
2634 return scm_from_double (floor (x
/y
+ 0.5));
2635 else if (SCM_LIKELY (y
< 0))
2636 return scm_from_double (ceil (x
/y
- 0.5));
2638 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2643 /* Assumes that both x and y are bigints, though
2644 x might be able to fit into a fixnum. */
2646 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2650 /* Note that x might be small enough to fit into a
2651 fixnum, so we must not let it escape into the wild */
2655 /* min_r will eventually become -abs(y)/2 */
2656 min_r
= scm_i_mkbig ();
2657 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2658 SCM_I_BIG_MPZ (y
), 1);
2660 /* Arrange for rr to initially be non-positive,
2661 because that simplifies the test to see
2662 if it is within the needed bounds. */
2663 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2665 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2666 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2667 scm_remember_upto_here_2 (x
, y
);
2668 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2669 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2670 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2671 SCM_I_BIG_MPZ (q
), 1);
2675 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2676 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2677 scm_remember_upto_here_2 (x
, y
);
2678 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2679 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2680 SCM_I_BIG_MPZ (q
), 1);
2682 scm_remember_upto_here_2 (r
, min_r
);
2683 return scm_i_normbig (q
);
2687 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2689 return scm_centered_quotient
2690 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2691 scm_product (scm_numerator (y
), scm_denominator (x
)));
2694 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2695 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2696 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2698 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2700 "Return the real number @var{r} such that\n"
2701 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2702 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2703 "for some integer @var{q}.\n"
2705 "(centered-remainder 123 10) @result{} 3\n"
2706 "(centered-remainder 123 -10) @result{} 3\n"
2707 "(centered-remainder -123 10) @result{} -3\n"
2708 "(centered-remainder -123 -10) @result{} -3\n"
2709 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2710 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2712 #define FUNC_NAME s_scm_centered_remainder
2714 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2716 scm_t_inum xx
= SCM_I_INUM (x
);
2717 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2719 scm_t_inum yy
= SCM_I_INUM (y
);
2720 if (SCM_UNLIKELY (yy
== 0))
2721 scm_num_overflow (s_scm_centered_remainder
);
2724 scm_t_inum rr
= xx
% yy
;
2725 if (SCM_LIKELY (xx
> 0))
2727 if (SCM_LIKELY (yy
> 0))
2729 if (rr
>= (yy
+ 1) / 2)
2734 if (rr
>= (1 - yy
) / 2)
2740 if (SCM_LIKELY (yy
> 0))
2751 return SCM_I_MAKINUM (rr
);
2754 else if (SCM_BIGP (y
))
2756 /* Pass a denormalized bignum version of x (even though it
2757 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2758 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2760 else if (SCM_REALP (y
))
2761 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2762 else if (SCM_FRACTIONP (y
))
2763 return scm_i_exact_rational_centered_remainder (x
, y
);
2765 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2766 s_scm_centered_remainder
);
2768 else if (SCM_BIGP (x
))
2770 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2772 scm_t_inum yy
= SCM_I_INUM (y
);
2773 if (SCM_UNLIKELY (yy
== 0))
2774 scm_num_overflow (s_scm_centered_remainder
);
2778 /* Arrange for rr to initially be non-positive,
2779 because that simplifies the test to see
2780 if it is within the needed bounds. */
2783 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2784 scm_remember_upto_here_1 (x
);
2790 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2791 scm_remember_upto_here_1 (x
);
2795 return SCM_I_MAKINUM (rr
);
2798 else if (SCM_BIGP (y
))
2799 return scm_i_bigint_centered_remainder (x
, y
);
2800 else if (SCM_REALP (y
))
2801 return scm_i_inexact_centered_remainder
2802 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2803 else if (SCM_FRACTIONP (y
))
2804 return scm_i_exact_rational_centered_remainder (x
, y
);
2806 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2807 s_scm_centered_remainder
);
2809 else if (SCM_REALP (x
))
2811 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2812 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2813 return scm_i_inexact_centered_remainder
2814 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2816 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2817 s_scm_centered_remainder
);
2819 else if (SCM_FRACTIONP (x
))
2822 return scm_i_inexact_centered_remainder
2823 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2824 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2825 return scm_i_exact_rational_centered_remainder (x
, y
);
2827 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2828 s_scm_centered_remainder
);
2831 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2832 s_scm_centered_remainder
);
2837 scm_i_inexact_centered_remainder (double x
, double y
)
2841 /* Although it would be more efficient to use fmod here, we can't
2842 because it would in some cases produce results inconsistent with
2843 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2844 close). In particular, when x-y/2 is very close to a multiple of
2845 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2846 two cases must correspond to different choices of q. If quotient
2847 chooses one and remainder chooses the other, it would be bad. */
2848 if (SCM_LIKELY (y
> 0))
2849 q
= floor (x
/y
+ 0.5);
2850 else if (SCM_LIKELY (y
< 0))
2851 q
= ceil (x
/y
- 0.5);
2853 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2856 return scm_from_double (x
- q
* y
);
2859 /* Assumes that both x and y are bigints, though
2860 x might be able to fit into a fixnum. */
2862 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2866 /* Note that x might be small enough to fit into a
2867 fixnum, so we must not let it escape into the wild */
2870 /* min_r will eventually become -abs(y)/2 */
2871 min_r
= scm_i_mkbig ();
2872 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2873 SCM_I_BIG_MPZ (y
), 1);
2875 /* Arrange for rr to initially be non-positive,
2876 because that simplifies the test to see
2877 if it is within the needed bounds. */
2878 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2880 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2881 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2882 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2883 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2884 mpz_add (SCM_I_BIG_MPZ (r
),
2890 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2891 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2892 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2893 mpz_sub (SCM_I_BIG_MPZ (r
),
2897 scm_remember_upto_here_2 (x
, y
);
2898 return scm_i_normbig (r
);
2902 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2904 SCM xd
= scm_denominator (x
);
2905 SCM yd
= scm_denominator (y
);
2906 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2907 scm_product (scm_numerator (y
), xd
));
2908 return scm_divide (r1
, scm_product (xd
, yd
));
2912 static void scm_i_inexact_centered_divide (double x
, double y
,
2914 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2915 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2918 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2920 "Return the integer @var{q} and the real number @var{r}\n"
2921 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2922 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2924 "(centered/ 123 10) @result{} 12 and 3\n"
2925 "(centered/ 123 -10) @result{} -12 and 3\n"
2926 "(centered/ -123 10) @result{} -12 and -3\n"
2927 "(centered/ -123 -10) @result{} 12 and -3\n"
2928 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2929 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2931 #define FUNC_NAME s_scm_i_centered_divide
2935 scm_centered_divide(x
, y
, &q
, &r
);
2936 return scm_values (scm_list_2 (q
, r
));
2940 #define s_scm_centered_divide s_scm_i_centered_divide
2941 #define g_scm_centered_divide g_scm_i_centered_divide
2944 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2946 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2948 scm_t_inum xx
= SCM_I_INUM (x
);
2949 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2951 scm_t_inum yy
= SCM_I_INUM (y
);
2952 if (SCM_UNLIKELY (yy
== 0))
2953 scm_num_overflow (s_scm_centered_divide
);
2956 scm_t_inum qq
= xx
/ yy
;
2957 scm_t_inum rr
= xx
% yy
;
2958 if (SCM_LIKELY (xx
> 0))
2960 if (SCM_LIKELY (yy
> 0))
2962 if (rr
>= (yy
+ 1) / 2)
2967 if (rr
>= (1 - yy
) / 2)
2973 if (SCM_LIKELY (yy
> 0))
2984 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2985 *qp
= SCM_I_MAKINUM (qq
);
2987 *qp
= scm_i_inum2big (qq
);
2988 *rp
= SCM_I_MAKINUM (rr
);
2992 else if (SCM_BIGP (y
))
2994 /* Pass a denormalized bignum version of x (even though it
2995 can fit in a fixnum) to scm_i_bigint_centered_divide */
2996 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
2998 else if (SCM_REALP (y
))
2999 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3000 else if (SCM_FRACTIONP (y
))
3001 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3003 return two_valued_wta_dispatch_2
3004 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3005 s_scm_centered_divide
, qp
, rp
);
3007 else if (SCM_BIGP (x
))
3009 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3011 scm_t_inum yy
= SCM_I_INUM (y
);
3012 if (SCM_UNLIKELY (yy
== 0))
3013 scm_num_overflow (s_scm_centered_divide
);
3016 SCM q
= scm_i_mkbig ();
3018 /* Arrange for rr to initially be non-positive,
3019 because that simplifies the test to see
3020 if it is within the needed bounds. */
3023 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3024 SCM_I_BIG_MPZ (x
), yy
);
3025 scm_remember_upto_here_1 (x
);
3028 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3029 SCM_I_BIG_MPZ (q
), 1);
3035 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3036 SCM_I_BIG_MPZ (x
), -yy
);
3037 scm_remember_upto_here_1 (x
);
3038 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3041 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3042 SCM_I_BIG_MPZ (q
), 1);
3046 *qp
= scm_i_normbig (q
);
3047 *rp
= SCM_I_MAKINUM (rr
);
3051 else if (SCM_BIGP (y
))
3052 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3053 else if (SCM_REALP (y
))
3054 return scm_i_inexact_centered_divide
3055 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3056 else if (SCM_FRACTIONP (y
))
3057 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3059 return two_valued_wta_dispatch_2
3060 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3061 s_scm_centered_divide
, qp
, rp
);
3063 else if (SCM_REALP (x
))
3065 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3066 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3067 return scm_i_inexact_centered_divide
3068 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3070 return two_valued_wta_dispatch_2
3071 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3072 s_scm_centered_divide
, qp
, rp
);
3074 else if (SCM_FRACTIONP (x
))
3077 return scm_i_inexact_centered_divide
3078 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3079 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3080 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3082 return two_valued_wta_dispatch_2
3083 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3084 s_scm_centered_divide
, qp
, rp
);
3087 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3088 s_scm_centered_divide
, qp
, rp
);
3092 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3096 if (SCM_LIKELY (y
> 0))
3097 q
= floor (x
/y
+ 0.5);
3098 else if (SCM_LIKELY (y
< 0))
3099 q
= ceil (x
/y
- 0.5);
3101 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3105 *qp
= scm_from_double (q
);
3106 *rp
= scm_from_double (r
);
3109 /* Assumes that both x and y are bigints, though
3110 x might be able to fit into a fixnum. */
3112 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3116 /* Note that x might be small enough to fit into a
3117 fixnum, so we must not let it escape into the wild */
3121 /* min_r will eventually become -abs(y/2) */
3122 min_r
= scm_i_mkbig ();
3123 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3124 SCM_I_BIG_MPZ (y
), 1);
3126 /* Arrange for rr to initially be non-positive,
3127 because that simplifies the test to see
3128 if it is within the needed bounds. */
3129 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3131 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3132 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3133 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3134 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3136 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3137 SCM_I_BIG_MPZ (q
), 1);
3138 mpz_add (SCM_I_BIG_MPZ (r
),
3145 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3146 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3147 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3149 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3150 SCM_I_BIG_MPZ (q
), 1);
3151 mpz_sub (SCM_I_BIG_MPZ (r
),
3156 scm_remember_upto_here_2 (x
, y
);
3157 *qp
= scm_i_normbig (q
);
3158 *rp
= scm_i_normbig (r
);
3162 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3165 SCM xd
= scm_denominator (x
);
3166 SCM yd
= scm_denominator (y
);
3168 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3169 scm_product (scm_numerator (y
), xd
),
3171 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3174 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3175 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3176 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3178 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3180 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3181 "with ties going to the nearest even integer.\n"
3183 "(round-quotient 123 10) @result{} 12\n"
3184 "(round-quotient 123 -10) @result{} -12\n"
3185 "(round-quotient -123 10) @result{} -12\n"
3186 "(round-quotient -123 -10) @result{} 12\n"
3187 "(round-quotient 125 10) @result{} 12\n"
3188 "(round-quotient 127 10) @result{} 13\n"
3189 "(round-quotient 135 10) @result{} 14\n"
3190 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3191 "(round-quotient 16/3 -10/7) @result{} -4\n"
3193 #define FUNC_NAME s_scm_round_quotient
3195 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3197 scm_t_inum xx
= SCM_I_INUM (x
);
3198 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3200 scm_t_inum yy
= SCM_I_INUM (y
);
3201 if (SCM_UNLIKELY (yy
== 0))
3202 scm_num_overflow (s_scm_round_quotient
);
3205 scm_t_inum qq
= xx
/ yy
;
3206 scm_t_inum rr
= xx
% yy
;
3208 scm_t_inum r2
= 2 * rr
;
3210 if (SCM_LIKELY (yy
< 0))
3230 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3231 return SCM_I_MAKINUM (qq
);
3233 return scm_i_inum2big (qq
);
3236 else if (SCM_BIGP (y
))
3238 /* Pass a denormalized bignum version of x (even though it
3239 can fit in a fixnum) to scm_i_bigint_round_quotient */
3240 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3242 else if (SCM_REALP (y
))
3243 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3244 else if (SCM_FRACTIONP (y
))
3245 return scm_i_exact_rational_round_quotient (x
, y
);
3247 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3248 s_scm_round_quotient
);
3250 else if (SCM_BIGP (x
))
3252 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3254 scm_t_inum yy
= SCM_I_INUM (y
);
3255 if (SCM_UNLIKELY (yy
== 0))
3256 scm_num_overflow (s_scm_round_quotient
);
3257 else if (SCM_UNLIKELY (yy
== 1))
3261 SCM q
= scm_i_mkbig ();
3263 int needs_adjustment
;
3267 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3268 SCM_I_BIG_MPZ (x
), yy
);
3269 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3270 needs_adjustment
= (2*rr
>= yy
);
3272 needs_adjustment
= (2*rr
> yy
);
3276 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3277 SCM_I_BIG_MPZ (x
), -yy
);
3278 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3279 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3280 needs_adjustment
= (2*rr
<= yy
);
3282 needs_adjustment
= (2*rr
< yy
);
3284 scm_remember_upto_here_1 (x
);
3285 if (needs_adjustment
)
3286 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3287 return scm_i_normbig (q
);
3290 else if (SCM_BIGP (y
))
3291 return scm_i_bigint_round_quotient (x
, y
);
3292 else if (SCM_REALP (y
))
3293 return scm_i_inexact_round_quotient
3294 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3295 else if (SCM_FRACTIONP (y
))
3296 return scm_i_exact_rational_round_quotient (x
, y
);
3298 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3299 s_scm_round_quotient
);
3301 else if (SCM_REALP (x
))
3303 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3304 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3305 return scm_i_inexact_round_quotient
3306 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3308 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3309 s_scm_round_quotient
);
3311 else if (SCM_FRACTIONP (x
))
3314 return scm_i_inexact_round_quotient
3315 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3316 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3317 return scm_i_exact_rational_round_quotient (x
, y
);
3319 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3320 s_scm_round_quotient
);
3323 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3324 s_scm_round_quotient
);
3329 scm_i_inexact_round_quotient (double x
, double y
)
3331 if (SCM_UNLIKELY (y
== 0))
3332 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3334 return scm_from_double (scm_c_round (x
/ y
));
3337 /* Assumes that both x and y are bigints, though
3338 x might be able to fit into a fixnum. */
3340 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3343 int cmp
, needs_adjustment
;
3345 /* Note that x might be small enough to fit into a
3346 fixnum, so we must not let it escape into the wild */
3349 r2
= scm_i_mkbig ();
3351 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3352 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3353 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3354 scm_remember_upto_here_2 (x
, r
);
3356 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3357 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3358 needs_adjustment
= (cmp
>= 0);
3360 needs_adjustment
= (cmp
> 0);
3361 scm_remember_upto_here_2 (r2
, y
);
3363 if (needs_adjustment
)
3364 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3366 return scm_i_normbig (q
);
3370 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3372 return scm_round_quotient
3373 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3374 scm_product (scm_numerator (y
), scm_denominator (x
)));
3377 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3378 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3379 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3381 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3383 "Return the real number @var{r} such that\n"
3384 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3385 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3386 "nearest integer, with ties going to the nearest\n"
3389 "(round-remainder 123 10) @result{} 3\n"
3390 "(round-remainder 123 -10) @result{} 3\n"
3391 "(round-remainder -123 10) @result{} -3\n"
3392 "(round-remainder -123 -10) @result{} -3\n"
3393 "(round-remainder 125 10) @result{} 5\n"
3394 "(round-remainder 127 10) @result{} -3\n"
3395 "(round-remainder 135 10) @result{} -5\n"
3396 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3397 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3399 #define FUNC_NAME s_scm_round_remainder
3401 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3403 scm_t_inum xx
= SCM_I_INUM (x
);
3404 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3406 scm_t_inum yy
= SCM_I_INUM (y
);
3407 if (SCM_UNLIKELY (yy
== 0))
3408 scm_num_overflow (s_scm_round_remainder
);
3411 scm_t_inum qq
= xx
/ yy
;
3412 scm_t_inum rr
= xx
% yy
;
3414 scm_t_inum r2
= 2 * rr
;
3416 if (SCM_LIKELY (yy
< 0))
3436 return SCM_I_MAKINUM (rr
);
3439 else if (SCM_BIGP (y
))
3441 /* Pass a denormalized bignum version of x (even though it
3442 can fit in a fixnum) to scm_i_bigint_round_remainder */
3443 return scm_i_bigint_round_remainder
3444 (scm_i_long2big (xx
), y
);
3446 else if (SCM_REALP (y
))
3447 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3448 else if (SCM_FRACTIONP (y
))
3449 return scm_i_exact_rational_round_remainder (x
, y
);
3451 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3452 s_scm_round_remainder
);
3454 else if (SCM_BIGP (x
))
3456 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3458 scm_t_inum yy
= SCM_I_INUM (y
);
3459 if (SCM_UNLIKELY (yy
== 0))
3460 scm_num_overflow (s_scm_round_remainder
);
3463 SCM q
= scm_i_mkbig ();
3465 int needs_adjustment
;
3469 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3470 SCM_I_BIG_MPZ (x
), yy
);
3471 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3472 needs_adjustment
= (2*rr
>= yy
);
3474 needs_adjustment
= (2*rr
> yy
);
3478 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3479 SCM_I_BIG_MPZ (x
), -yy
);
3480 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3481 needs_adjustment
= (2*rr
<= yy
);
3483 needs_adjustment
= (2*rr
< yy
);
3485 scm_remember_upto_here_2 (x
, q
);
3486 if (needs_adjustment
)
3488 return SCM_I_MAKINUM (rr
);
3491 else if (SCM_BIGP (y
))
3492 return scm_i_bigint_round_remainder (x
, y
);
3493 else if (SCM_REALP (y
))
3494 return scm_i_inexact_round_remainder
3495 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3496 else if (SCM_FRACTIONP (y
))
3497 return scm_i_exact_rational_round_remainder (x
, y
);
3499 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3500 s_scm_round_remainder
);
3502 else if (SCM_REALP (x
))
3504 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3505 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3506 return scm_i_inexact_round_remainder
3507 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3509 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3510 s_scm_round_remainder
);
3512 else if (SCM_FRACTIONP (x
))
3515 return scm_i_inexact_round_remainder
3516 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3517 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3518 return scm_i_exact_rational_round_remainder (x
, y
);
3520 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3521 s_scm_round_remainder
);
3524 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3525 s_scm_round_remainder
);
3530 scm_i_inexact_round_remainder (double x
, double y
)
3532 /* Although it would be more efficient to use fmod here, we can't
3533 because it would in some cases produce results inconsistent with
3534 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3535 close). In particular, when x-y/2 is very close to a multiple of
3536 y, then r might be either -abs(y/2) or abs(y/2), but those two
3537 cases must correspond to different choices of q. If quotient
3538 chooses one and remainder chooses the other, it would be bad. */
3540 if (SCM_UNLIKELY (y
== 0))
3541 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3544 double q
= scm_c_round (x
/ y
);
3545 return scm_from_double (x
- q
* y
);
3549 /* Assumes that both x and y are bigints, though
3550 x might be able to fit into a fixnum. */
3552 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3555 int cmp
, needs_adjustment
;
3557 /* Note that x might be small enough to fit into a
3558 fixnum, so we must not let it escape into the wild */
3561 r2
= scm_i_mkbig ();
3563 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3564 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3565 scm_remember_upto_here_1 (x
);
3566 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3568 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3569 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3570 needs_adjustment
= (cmp
>= 0);
3572 needs_adjustment
= (cmp
> 0);
3573 scm_remember_upto_here_2 (q
, r2
);
3575 if (needs_adjustment
)
3576 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3578 scm_remember_upto_here_1 (y
);
3579 return scm_i_normbig (r
);
3583 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3585 SCM xd
= scm_denominator (x
);
3586 SCM yd
= scm_denominator (y
);
3587 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3588 scm_product (scm_numerator (y
), xd
));
3589 return scm_divide (r1
, scm_product (xd
, yd
));
3593 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3594 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3595 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3597 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3599 "Return the integer @var{q} and the real number @var{r}\n"
3600 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3601 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3602 "nearest integer, with ties going to the nearest even integer.\n"
3604 "(round/ 123 10) @result{} 12 and 3\n"
3605 "(round/ 123 -10) @result{} -12 and 3\n"
3606 "(round/ -123 10) @result{} -12 and -3\n"
3607 "(round/ -123 -10) @result{} 12 and -3\n"
3608 "(round/ 125 10) @result{} 12 and 5\n"
3609 "(round/ 127 10) @result{} 13 and -3\n"
3610 "(round/ 135 10) @result{} 14 and -5\n"
3611 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3612 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3614 #define FUNC_NAME s_scm_i_round_divide
3618 scm_round_divide(x
, y
, &q
, &r
);
3619 return scm_values (scm_list_2 (q
, r
));
3623 #define s_scm_round_divide s_scm_i_round_divide
3624 #define g_scm_round_divide g_scm_i_round_divide
3627 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3629 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3631 scm_t_inum xx
= SCM_I_INUM (x
);
3632 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3634 scm_t_inum yy
= SCM_I_INUM (y
);
3635 if (SCM_UNLIKELY (yy
== 0))
3636 scm_num_overflow (s_scm_round_divide
);
3639 scm_t_inum qq
= xx
/ yy
;
3640 scm_t_inum rr
= xx
% yy
;
3642 scm_t_inum r2
= 2 * rr
;
3644 if (SCM_LIKELY (yy
< 0))
3664 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3665 *qp
= SCM_I_MAKINUM (qq
);
3667 *qp
= scm_i_inum2big (qq
);
3668 *rp
= SCM_I_MAKINUM (rr
);
3672 else if (SCM_BIGP (y
))
3674 /* Pass a denormalized bignum version of x (even though it
3675 can fit in a fixnum) to scm_i_bigint_round_divide */
3676 return scm_i_bigint_round_divide
3677 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3679 else if (SCM_REALP (y
))
3680 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3681 else if (SCM_FRACTIONP (y
))
3682 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3684 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3685 s_scm_round_divide
, qp
, rp
);
3687 else if (SCM_BIGP (x
))
3689 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3691 scm_t_inum yy
= SCM_I_INUM (y
);
3692 if (SCM_UNLIKELY (yy
== 0))
3693 scm_num_overflow (s_scm_round_divide
);
3696 SCM q
= scm_i_mkbig ();
3698 int needs_adjustment
;
3702 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3703 SCM_I_BIG_MPZ (x
), yy
);
3704 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3705 needs_adjustment
= (2*rr
>= yy
);
3707 needs_adjustment
= (2*rr
> yy
);
3711 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3712 SCM_I_BIG_MPZ (x
), -yy
);
3713 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3714 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3715 needs_adjustment
= (2*rr
<= yy
);
3717 needs_adjustment
= (2*rr
< yy
);
3719 scm_remember_upto_here_1 (x
);
3720 if (needs_adjustment
)
3722 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3725 *qp
= scm_i_normbig (q
);
3726 *rp
= SCM_I_MAKINUM (rr
);
3730 else if (SCM_BIGP (y
))
3731 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3732 else if (SCM_REALP (y
))
3733 return scm_i_inexact_round_divide
3734 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3735 else if (SCM_FRACTIONP (y
))
3736 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3738 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3739 s_scm_round_divide
, qp
, rp
);
3741 else if (SCM_REALP (x
))
3743 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3744 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3745 return scm_i_inexact_round_divide
3746 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3748 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3749 s_scm_round_divide
, qp
, rp
);
3751 else if (SCM_FRACTIONP (x
))
3754 return scm_i_inexact_round_divide
3755 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3756 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3757 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3759 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3760 s_scm_round_divide
, qp
, rp
);
3763 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3764 s_scm_round_divide
, qp
, rp
);
3768 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3770 if (SCM_UNLIKELY (y
== 0))
3771 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3774 double q
= scm_c_round (x
/ y
);
3775 double r
= x
- q
* y
;
3776 *qp
= scm_from_double (q
);
3777 *rp
= scm_from_double (r
);
3781 /* Assumes that both x and y are bigints, though
3782 x might be able to fit into a fixnum. */
3784 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3787 int cmp
, needs_adjustment
;
3789 /* Note that x might be small enough to fit into a
3790 fixnum, so we must not let it escape into the wild */
3793 r2
= scm_i_mkbig ();
3795 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3796 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3797 scm_remember_upto_here_1 (x
);
3798 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3800 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3801 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3802 needs_adjustment
= (cmp
>= 0);
3804 needs_adjustment
= (cmp
> 0);
3806 if (needs_adjustment
)
3808 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3809 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3812 scm_remember_upto_here_2 (r2
, y
);
3813 *qp
= scm_i_normbig (q
);
3814 *rp
= scm_i_normbig (r
);
3818 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3821 SCM xd
= scm_denominator (x
);
3822 SCM yd
= scm_denominator (y
);
3824 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3825 scm_product (scm_numerator (y
), xd
),
3827 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3831 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3832 (SCM x
, SCM y
, SCM rest
),
3833 "Return the greatest common divisor of all parameter values.\n"
3834 "If called without arguments, 0 is returned.")
3835 #define FUNC_NAME s_scm_i_gcd
3837 while (!scm_is_null (rest
))
3838 { x
= scm_gcd (x
, y
);
3840 rest
= scm_cdr (rest
);
3842 return scm_gcd (x
, y
);
3846 #define s_gcd s_scm_i_gcd
3847 #define g_gcd g_scm_i_gcd
3850 scm_gcd (SCM x
, SCM y
)
3853 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3855 if (SCM_I_INUMP (x
))
3857 if (SCM_I_INUMP (y
))
3859 scm_t_inum xx
= SCM_I_INUM (x
);
3860 scm_t_inum yy
= SCM_I_INUM (y
);
3861 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3862 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3872 /* Determine a common factor 2^k */
3873 while (!(1 & (u
| v
)))
3879 /* Now, any factor 2^n can be eliminated */
3899 return (SCM_POSFIXABLE (result
)
3900 ? SCM_I_MAKINUM (result
)
3901 : scm_i_inum2big (result
));
3903 else if (SCM_BIGP (y
))
3909 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3911 else if (SCM_BIGP (x
))
3913 if (SCM_I_INUMP (y
))
3918 yy
= SCM_I_INUM (y
);
3923 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3924 scm_remember_upto_here_1 (x
);
3925 return (SCM_POSFIXABLE (result
)
3926 ? SCM_I_MAKINUM (result
)
3927 : scm_from_unsigned_integer (result
));
3929 else if (SCM_BIGP (y
))
3931 SCM result
= scm_i_mkbig ();
3932 mpz_gcd (SCM_I_BIG_MPZ (result
),
3935 scm_remember_upto_here_2 (x
, y
);
3936 return scm_i_normbig (result
);
3939 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3942 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3945 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3946 (SCM x
, SCM y
, SCM rest
),
3947 "Return the least common multiple of the arguments.\n"
3948 "If called without arguments, 1 is returned.")
3949 #define FUNC_NAME s_scm_i_lcm
3951 while (!scm_is_null (rest
))
3952 { x
= scm_lcm (x
, y
);
3954 rest
= scm_cdr (rest
);
3956 return scm_lcm (x
, y
);
3960 #define s_lcm s_scm_i_lcm
3961 #define g_lcm g_scm_i_lcm
3964 scm_lcm (SCM n1
, SCM n2
)
3966 if (SCM_UNBNDP (n2
))
3968 if (SCM_UNBNDP (n1
))
3969 return SCM_I_MAKINUM (1L);
3970 n2
= SCM_I_MAKINUM (1L);
3973 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
3974 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3975 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
3976 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
3978 if (SCM_I_INUMP (n1
))
3980 if (SCM_I_INUMP (n2
))
3982 SCM d
= scm_gcd (n1
, n2
);
3983 if (scm_is_eq (d
, SCM_INUM0
))
3986 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
3990 /* inum n1, big n2 */
3993 SCM result
= scm_i_mkbig ();
3994 scm_t_inum nn1
= SCM_I_INUM (n1
);
3995 if (nn1
== 0) return SCM_INUM0
;
3996 if (nn1
< 0) nn1
= - nn1
;
3997 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
3998 scm_remember_upto_here_1 (n2
);
4006 if (SCM_I_INUMP (n2
))
4013 SCM result
= scm_i_mkbig ();
4014 mpz_lcm(SCM_I_BIG_MPZ (result
),
4016 SCM_I_BIG_MPZ (n2
));
4017 scm_remember_upto_here_2(n1
, n2
);
4018 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4024 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4029 + + + x (map digit:logand X Y)
4030 + - + x (map digit:logand X (lognot (+ -1 Y)))
4031 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4032 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4037 + + + (map digit:logior X Y)
4038 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4039 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4040 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4045 + + + (map digit:logxor X Y)
4046 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4047 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4048 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4053 + + (any digit:logand X Y)
4054 + - (any digit:logand X (lognot (+ -1 Y)))
4055 - + (any digit:logand (lognot (+ -1 X)) Y)
4060 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4061 (SCM x
, SCM y
, SCM rest
),
4062 "Return the bitwise AND of the integer arguments.\n\n"
4064 "(logand) @result{} -1\n"
4065 "(logand 7) @result{} 7\n"
4066 "(logand #b111 #b011 #b001) @result{} 1\n"
4068 #define FUNC_NAME s_scm_i_logand
4070 while (!scm_is_null (rest
))
4071 { x
= scm_logand (x
, y
);
4073 rest
= scm_cdr (rest
);
4075 return scm_logand (x
, y
);
4079 #define s_scm_logand s_scm_i_logand
4081 SCM
scm_logand (SCM n1
, SCM n2
)
4082 #define FUNC_NAME s_scm_logand
4086 if (SCM_UNBNDP (n2
))
4088 if (SCM_UNBNDP (n1
))
4089 return SCM_I_MAKINUM (-1);
4090 else if (!SCM_NUMBERP (n1
))
4091 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4092 else if (SCM_NUMBERP (n1
))
4095 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4098 if (SCM_I_INUMP (n1
))
4100 nn1
= SCM_I_INUM (n1
);
4101 if (SCM_I_INUMP (n2
))
4103 scm_t_inum nn2
= SCM_I_INUM (n2
);
4104 return SCM_I_MAKINUM (nn1
& nn2
);
4106 else if SCM_BIGP (n2
)
4112 SCM result_z
= scm_i_mkbig ();
4114 mpz_init_set_si (nn1_z
, nn1
);
4115 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4116 scm_remember_upto_here_1 (n2
);
4118 return scm_i_normbig (result_z
);
4122 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4124 else if (SCM_BIGP (n1
))
4126 if (SCM_I_INUMP (n2
))
4129 nn1
= SCM_I_INUM (n1
);
4132 else if (SCM_BIGP (n2
))
4134 SCM result_z
= scm_i_mkbig ();
4135 mpz_and (SCM_I_BIG_MPZ (result_z
),
4137 SCM_I_BIG_MPZ (n2
));
4138 scm_remember_upto_here_2 (n1
, n2
);
4139 return scm_i_normbig (result_z
);
4142 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4145 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4150 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4151 (SCM x
, SCM y
, SCM rest
),
4152 "Return the bitwise OR of the integer arguments.\n\n"
4154 "(logior) @result{} 0\n"
4155 "(logior 7) @result{} 7\n"
4156 "(logior #b000 #b001 #b011) @result{} 3\n"
4158 #define FUNC_NAME s_scm_i_logior
4160 while (!scm_is_null (rest
))
4161 { x
= scm_logior (x
, y
);
4163 rest
= scm_cdr (rest
);
4165 return scm_logior (x
, y
);
4169 #define s_scm_logior s_scm_i_logior
4171 SCM
scm_logior (SCM n1
, SCM n2
)
4172 #define FUNC_NAME s_scm_logior
4176 if (SCM_UNBNDP (n2
))
4178 if (SCM_UNBNDP (n1
))
4180 else if (SCM_NUMBERP (n1
))
4183 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4186 if (SCM_I_INUMP (n1
))
4188 nn1
= SCM_I_INUM (n1
);
4189 if (SCM_I_INUMP (n2
))
4191 long nn2
= SCM_I_INUM (n2
);
4192 return SCM_I_MAKINUM (nn1
| nn2
);
4194 else if (SCM_BIGP (n2
))
4200 SCM result_z
= scm_i_mkbig ();
4202 mpz_init_set_si (nn1_z
, nn1
);
4203 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4204 scm_remember_upto_here_1 (n2
);
4206 return scm_i_normbig (result_z
);
4210 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4212 else if (SCM_BIGP (n1
))
4214 if (SCM_I_INUMP (n2
))
4217 nn1
= SCM_I_INUM (n1
);
4220 else if (SCM_BIGP (n2
))
4222 SCM result_z
= scm_i_mkbig ();
4223 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4225 SCM_I_BIG_MPZ (n2
));
4226 scm_remember_upto_here_2 (n1
, n2
);
4227 return scm_i_normbig (result_z
);
4230 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4233 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4238 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4239 (SCM x
, SCM y
, SCM rest
),
4240 "Return the bitwise XOR of the integer arguments. A bit is\n"
4241 "set in the result if it is set in an odd number of arguments.\n"
4243 "(logxor) @result{} 0\n"
4244 "(logxor 7) @result{} 7\n"
4245 "(logxor #b000 #b001 #b011) @result{} 2\n"
4246 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4248 #define FUNC_NAME s_scm_i_logxor
4250 while (!scm_is_null (rest
))
4251 { x
= scm_logxor (x
, y
);
4253 rest
= scm_cdr (rest
);
4255 return scm_logxor (x
, y
);
4259 #define s_scm_logxor s_scm_i_logxor
4261 SCM
scm_logxor (SCM n1
, SCM n2
)
4262 #define FUNC_NAME s_scm_logxor
4266 if (SCM_UNBNDP (n2
))
4268 if (SCM_UNBNDP (n1
))
4270 else if (SCM_NUMBERP (n1
))
4273 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4276 if (SCM_I_INUMP (n1
))
4278 nn1
= SCM_I_INUM (n1
);
4279 if (SCM_I_INUMP (n2
))
4281 scm_t_inum nn2
= SCM_I_INUM (n2
);
4282 return SCM_I_MAKINUM (nn1
^ nn2
);
4284 else if (SCM_BIGP (n2
))
4288 SCM result_z
= scm_i_mkbig ();
4290 mpz_init_set_si (nn1_z
, nn1
);
4291 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4292 scm_remember_upto_here_1 (n2
);
4294 return scm_i_normbig (result_z
);
4298 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4300 else if (SCM_BIGP (n1
))
4302 if (SCM_I_INUMP (n2
))
4305 nn1
= SCM_I_INUM (n1
);
4308 else if (SCM_BIGP (n2
))
4310 SCM result_z
= scm_i_mkbig ();
4311 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4313 SCM_I_BIG_MPZ (n2
));
4314 scm_remember_upto_here_2 (n1
, n2
);
4315 return scm_i_normbig (result_z
);
4318 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4321 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4326 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4328 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4329 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4330 "without actually calculating the @code{logand}, just testing\n"
4334 "(logtest #b0100 #b1011) @result{} #f\n"
4335 "(logtest #b0100 #b0111) @result{} #t\n"
4337 #define FUNC_NAME s_scm_logtest
4341 if (SCM_I_INUMP (j
))
4343 nj
= SCM_I_INUM (j
);
4344 if (SCM_I_INUMP (k
))
4346 scm_t_inum nk
= SCM_I_INUM (k
);
4347 return scm_from_bool (nj
& nk
);
4349 else if (SCM_BIGP (k
))
4357 mpz_init_set_si (nj_z
, nj
);
4358 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4359 scm_remember_upto_here_1 (k
);
4360 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4366 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4368 else if (SCM_BIGP (j
))
4370 if (SCM_I_INUMP (k
))
4373 nj
= SCM_I_INUM (j
);
4376 else if (SCM_BIGP (k
))
4380 mpz_init (result_z
);
4384 scm_remember_upto_here_2 (j
, k
);
4385 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4386 mpz_clear (result_z
);
4390 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4393 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4398 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4400 "Test whether bit number @var{index} in @var{j} is set.\n"
4401 "@var{index} starts from 0 for the least significant bit.\n"
4404 "(logbit? 0 #b1101) @result{} #t\n"
4405 "(logbit? 1 #b1101) @result{} #f\n"
4406 "(logbit? 2 #b1101) @result{} #t\n"
4407 "(logbit? 3 #b1101) @result{} #t\n"
4408 "(logbit? 4 #b1101) @result{} #f\n"
4410 #define FUNC_NAME s_scm_logbit_p
4412 unsigned long int iindex
;
4413 iindex
= scm_to_ulong (index
);
4415 if (SCM_I_INUMP (j
))
4417 /* bits above what's in an inum follow the sign bit */
4418 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4419 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4421 else if (SCM_BIGP (j
))
4423 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4424 scm_remember_upto_here_1 (j
);
4425 return scm_from_bool (val
);
4428 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4433 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4435 "Return the integer which is the ones-complement of the integer\n"
4439 "(number->string (lognot #b10000000) 2)\n"
4440 " @result{} \"-10000001\"\n"
4441 "(number->string (lognot #b0) 2)\n"
4442 " @result{} \"-1\"\n"
4444 #define FUNC_NAME s_scm_lognot
4446 if (SCM_I_INUMP (n
)) {
4447 /* No overflow here, just need to toggle all the bits making up the inum.
4448 Enhancement: No need to strip the tag and add it back, could just xor
4449 a block of 1 bits, if that worked with the various debug versions of
4451 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4453 } else if (SCM_BIGP (n
)) {
4454 SCM result
= scm_i_mkbig ();
4455 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4456 scm_remember_upto_here_1 (n
);
4460 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4465 /* returns 0 if IN is not an integer. OUT must already be
4468 coerce_to_big (SCM in
, mpz_t out
)
4471 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4472 else if (SCM_I_INUMP (in
))
4473 mpz_set_si (out
, SCM_I_INUM (in
));
4480 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4481 (SCM n
, SCM k
, SCM m
),
4482 "Return @var{n} raised to the integer exponent\n"
4483 "@var{k}, modulo @var{m}.\n"
4486 "(modulo-expt 2 3 5)\n"
4489 #define FUNC_NAME s_scm_modulo_expt
4495 /* There are two classes of error we might encounter --
4496 1) Math errors, which we'll report by calling scm_num_overflow,
4498 2) wrong-type errors, which of course we'll report by calling
4500 We don't report those errors immediately, however; instead we do
4501 some cleanup first. These variables tell us which error (if
4502 any) we should report after cleaning up.
4504 int report_overflow
= 0;
4506 int position_of_wrong_type
= 0;
4507 SCM value_of_wrong_type
= SCM_INUM0
;
4509 SCM result
= SCM_UNDEFINED
;
4515 if (scm_is_eq (m
, SCM_INUM0
))
4517 report_overflow
= 1;
4521 if (!coerce_to_big (n
, n_tmp
))
4523 value_of_wrong_type
= n
;
4524 position_of_wrong_type
= 1;
4528 if (!coerce_to_big (k
, k_tmp
))
4530 value_of_wrong_type
= k
;
4531 position_of_wrong_type
= 2;
4535 if (!coerce_to_big (m
, m_tmp
))
4537 value_of_wrong_type
= m
;
4538 position_of_wrong_type
= 3;
4542 /* if the exponent K is negative, and we simply call mpz_powm, we
4543 will get a divide-by-zero exception when an inverse 1/n mod m
4544 doesn't exist (or is not unique). Since exceptions are hard to
4545 handle, we'll attempt the inversion "by hand" -- that way, we get
4546 a simple failure code, which is easy to handle. */
4548 if (-1 == mpz_sgn (k_tmp
))
4550 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4552 report_overflow
= 1;
4555 mpz_neg (k_tmp
, k_tmp
);
4558 result
= scm_i_mkbig ();
4559 mpz_powm (SCM_I_BIG_MPZ (result
),
4564 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4565 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4572 if (report_overflow
)
4573 scm_num_overflow (FUNC_NAME
);
4575 if (position_of_wrong_type
)
4576 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4577 value_of_wrong_type
);
4579 return scm_i_normbig (result
);
4583 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4585 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4586 "exact integer, @var{n} can be any number.\n"
4588 "Negative @var{k} is supported, and results in\n"
4589 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4590 "@math{@var{n}^0} is 1, as usual, and that\n"
4591 "includes @math{0^0} is 1.\n"
4594 "(integer-expt 2 5) @result{} 32\n"
4595 "(integer-expt -3 3) @result{} -27\n"
4596 "(integer-expt 5 -3) @result{} 1/125\n"
4597 "(integer-expt 0 0) @result{} 1\n"
4599 #define FUNC_NAME s_scm_integer_expt
4602 SCM z_i2
= SCM_BOOL_F
;
4604 SCM acc
= SCM_I_MAKINUM (1L);
4606 /* Specifically refrain from checking the type of the first argument.
4607 This allows us to exponentiate any object that can be multiplied.
4608 If we must raise to a negative power, we must also be able to
4609 take its reciprocal. */
4610 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4611 SCM_WRONG_TYPE_ARG (2, k
);
4613 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4614 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4615 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4616 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4617 /* The next check is necessary only because R6RS specifies different
4618 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4619 we simply skip this case and move on. */
4620 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4622 /* k cannot be 0 at this point, because we
4623 have already checked for that case above */
4624 if (scm_is_true (scm_positive_p (k
)))
4626 else /* return NaN for (0 ^ k) for negative k per R6RS */
4630 if (SCM_I_INUMP (k
))
4631 i2
= SCM_I_INUM (k
);
4632 else if (SCM_BIGP (k
))
4634 z_i2
= scm_i_clonebig (k
, 1);
4635 scm_remember_upto_here_1 (k
);
4639 SCM_WRONG_TYPE_ARG (2, k
);
4643 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4645 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4646 n
= scm_divide (n
, SCM_UNDEFINED
);
4650 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4654 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4656 return scm_product (acc
, n
);
4658 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4659 acc
= scm_product (acc
, n
);
4660 n
= scm_product (n
, n
);
4661 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4669 n
= scm_divide (n
, SCM_UNDEFINED
);
4676 return scm_product (acc
, n
);
4678 acc
= scm_product (acc
, n
);
4679 n
= scm_product (n
, n
);
4686 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4688 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4689 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4691 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4692 "@var{cnt} is negative it's a division, rounded towards negative\n"
4693 "infinity. (Note that this is not the same rounding as\n"
4694 "@code{quotient} does.)\n"
4696 "With @var{n} viewed as an infinite precision twos complement,\n"
4697 "@code{ash} means a left shift introducing zero bits, or a right\n"
4698 "shift dropping bits.\n"
4701 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4702 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4704 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4705 "(ash -23 -2) @result{} -6\n"
4707 #define FUNC_NAME s_scm_ash
4710 bits_to_shift
= scm_to_long (cnt
);
4712 if (SCM_I_INUMP (n
))
4714 scm_t_inum nn
= SCM_I_INUM (n
);
4716 if (bits_to_shift
> 0)
4718 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4719 overflow a non-zero fixnum. For smaller shifts we check the
4720 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4721 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4722 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4728 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4730 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4733 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4737 SCM result
= scm_i_inum2big (nn
);
4738 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4745 bits_to_shift
= -bits_to_shift
;
4746 if (bits_to_shift
>= SCM_LONG_BIT
)
4747 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4749 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4753 else if (SCM_BIGP (n
))
4757 if (bits_to_shift
== 0)
4760 result
= scm_i_mkbig ();
4761 if (bits_to_shift
>= 0)
4763 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4769 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4770 we have to allocate a bignum even if the result is going to be a
4772 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4774 return scm_i_normbig (result
);
4780 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4786 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4787 (SCM n
, SCM start
, SCM end
),
4788 "Return the integer composed of the @var{start} (inclusive)\n"
4789 "through @var{end} (exclusive) bits of @var{n}. The\n"
4790 "@var{start}th bit becomes the 0-th bit in the result.\n"
4793 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4794 " @result{} \"1010\"\n"
4795 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4796 " @result{} \"10110\"\n"
4798 #define FUNC_NAME s_scm_bit_extract
4800 unsigned long int istart
, iend
, bits
;
4801 istart
= scm_to_ulong (start
);
4802 iend
= scm_to_ulong (end
);
4803 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4805 /* how many bits to keep */
4806 bits
= iend
- istart
;
4808 if (SCM_I_INUMP (n
))
4810 scm_t_inum in
= SCM_I_INUM (n
);
4812 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4813 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4814 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4816 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4818 /* Since we emulate two's complement encoded numbers, this
4819 * special case requires us to produce a result that has
4820 * more bits than can be stored in a fixnum.
4822 SCM result
= scm_i_inum2big (in
);
4823 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4828 /* mask down to requisite bits */
4829 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4830 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4832 else if (SCM_BIGP (n
))
4837 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4841 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4842 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4843 such bits into a ulong. */
4844 result
= scm_i_mkbig ();
4845 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4846 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4847 result
= scm_i_normbig (result
);
4849 scm_remember_upto_here_1 (n
);
4853 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4858 static const char scm_logtab
[] = {
4859 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4862 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4864 "Return the number of bits in integer @var{n}. If integer is\n"
4865 "positive, the 1-bits in its binary representation are counted.\n"
4866 "If negative, the 0-bits in its two's-complement binary\n"
4867 "representation are counted. If 0, 0 is returned.\n"
4870 "(logcount #b10101010)\n"
4877 #define FUNC_NAME s_scm_logcount
4879 if (SCM_I_INUMP (n
))
4881 unsigned long c
= 0;
4882 scm_t_inum nn
= SCM_I_INUM (n
);
4887 c
+= scm_logtab
[15 & nn
];
4890 return SCM_I_MAKINUM (c
);
4892 else if (SCM_BIGP (n
))
4894 unsigned long count
;
4895 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4896 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4898 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4899 scm_remember_upto_here_1 (n
);
4900 return SCM_I_MAKINUM (count
);
4903 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4908 static const char scm_ilentab
[] = {
4909 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4913 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4915 "Return the number of bits necessary to represent @var{n}.\n"
4918 "(integer-length #b10101010)\n"
4920 "(integer-length 0)\n"
4922 "(integer-length #b1111)\n"
4925 #define FUNC_NAME s_scm_integer_length
4927 if (SCM_I_INUMP (n
))
4929 unsigned long c
= 0;
4931 scm_t_inum nn
= SCM_I_INUM (n
);
4937 l
= scm_ilentab
[15 & nn
];
4940 return SCM_I_MAKINUM (c
- 4 + l
);
4942 else if (SCM_BIGP (n
))
4944 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4945 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4946 1 too big, so check for that and adjust. */
4947 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4948 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4949 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4950 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4952 scm_remember_upto_here_1 (n
);
4953 return SCM_I_MAKINUM (size
);
4956 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4960 /*** NUMBERS -> STRINGS ***/
4961 #define SCM_MAX_DBL_PREC 60
4962 #define SCM_MAX_DBL_RADIX 36
4964 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4965 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4966 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4969 void init_dblprec(int *prec
, int radix
) {
4970 /* determine floating point precision by adding successively
4971 smaller increments to 1.0 until it is considered == 1.0 */
4972 double f
= ((double)1.0)/radix
;
4973 double fsum
= 1.0 + f
;
4978 if (++(*prec
) > SCM_MAX_DBL_PREC
)
4990 void init_fx_radix(double *fx_list
, int radix
)
4992 /* initialize a per-radix list of tolerances. When added
4993 to a number < 1.0, we can determine if we should raund
4994 up and quit converting a number to a string. */
4998 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
4999 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5002 /* use this array as a way to generate a single digit */
5003 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5006 idbl2str (double f
, char *a
, int radix
)
5008 int efmt
, dpt
, d
, i
, wp
;
5010 #ifdef DBL_MIN_10_EXP
5013 #endif /* DBL_MIN_10_EXP */
5018 radix
> SCM_MAX_DBL_RADIX
)
5020 /* revert to existing behavior */
5024 wp
= scm_dblprec
[radix
-2];
5025 fx
= fx_per_radix
[radix
-2];
5029 #ifdef HAVE_COPYSIGN
5030 double sgn
= copysign (1.0, f
);
5035 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5041 strcpy (a
, "-inf.0");
5043 strcpy (a
, "+inf.0");
5048 strcpy (a
, "+nan.0");
5058 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5059 make-uniform-vector, from causing infinite loops. */
5060 /* just do the checking...if it passes, we do the conversion for our
5061 radix again below */
5068 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5076 while (f_cpy
> 10.0)
5079 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5100 if (f
+ fx
[wp
] >= radix
)
5107 /* adding 9999 makes this equivalent to abs(x) % 3 */
5108 dpt
= (exp
+ 9999) % 3;
5112 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5134 a
[ch
++] = number_chars
[d
];
5137 if (f
+ fx
[wp
] >= 1.0)
5139 a
[ch
- 1] = number_chars
[d
+1];
5151 if ((dpt
> 4) && (exp
> 6))
5153 d
= (a
[0] == '-' ? 2 : 1);
5154 for (i
= ch
++; i
> d
; i
--)
5167 if (a
[ch
- 1] == '.')
5168 a
[ch
++] = '0'; /* trailing zero */
5177 for (i
= radix
; i
<= exp
; i
*= radix
);
5178 for (i
/= radix
; i
; i
/= radix
)
5180 a
[ch
++] = number_chars
[exp
/ i
];
5189 icmplx2str (double real
, double imag
, char *str
, int radix
)
5194 i
= idbl2str (real
, str
, radix
);
5195 #ifdef HAVE_COPYSIGN
5196 sgn
= copysign (1.0, imag
);
5200 /* Don't output a '+' for negative numbers or for Inf and
5201 NaN. They will provide their own sign. */
5202 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5204 i
+= idbl2str (imag
, &str
[i
], radix
);
5210 iflo2str (SCM flt
, char *str
, int radix
)
5213 if (SCM_REALP (flt
))
5214 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5216 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5221 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5222 characters in the result.
5224 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5226 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5231 return scm_iuint2str (-num
, rad
, p
) + 1;
5234 return scm_iuint2str (num
, rad
, p
);
5237 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5238 characters in the result.
5240 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5242 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5246 scm_t_uintmax n
= num
;
5248 if (rad
< 2 || rad
> 36)
5249 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5251 for (n
/= rad
; n
> 0; n
/= rad
)
5261 p
[i
] = number_chars
[d
];
5266 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5268 "Return a string holding the external representation of the\n"
5269 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5270 "inexact, a radix of 10 will be used.")
5271 #define FUNC_NAME s_scm_number_to_string
5275 if (SCM_UNBNDP (radix
))
5278 base
= scm_to_signed_integer (radix
, 2, 36);
5280 if (SCM_I_INUMP (n
))
5282 char num_buf
[SCM_INTBUFLEN
];
5283 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5284 return scm_from_locale_stringn (num_buf
, length
);
5286 else if (SCM_BIGP (n
))
5288 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5289 scm_remember_upto_here_1 (n
);
5290 return scm_take_locale_string (str
);
5292 else if (SCM_FRACTIONP (n
))
5294 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5295 scm_from_locale_string ("/"),
5296 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5298 else if (SCM_INEXACTP (n
))
5300 char num_buf
[FLOBUFLEN
];
5301 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5304 SCM_WRONG_TYPE_ARG (1, n
);
5309 /* These print routines used to be stubbed here so that scm_repl.c
5310 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5313 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5315 char num_buf
[FLOBUFLEN
];
5316 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5321 scm_i_print_double (double val
, SCM port
)
5323 char num_buf
[FLOBUFLEN
];
5324 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5328 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5331 char num_buf
[FLOBUFLEN
];
5332 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5337 scm_i_print_complex (double real
, double imag
, SCM port
)
5339 char num_buf
[FLOBUFLEN
];
5340 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5344 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5347 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5348 scm_display (str
, port
);
5349 scm_remember_upto_here_1 (str
);
5354 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5356 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5357 scm_remember_upto_here_1 (exp
);
5358 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5362 /*** END nums->strs ***/
5365 /*** STRINGS -> NUMBERS ***/
5367 /* The following functions implement the conversion from strings to numbers.
5368 * The implementation somehow follows the grammar for numbers as it is given
5369 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5370 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5371 * points should be noted about the implementation:
5373 * * Each function keeps a local index variable 'idx' that points at the
5374 * current position within the parsed string. The global index is only
5375 * updated if the function could parse the corresponding syntactic unit
5378 * * Similarly, the functions keep track of indicators of inexactness ('#',
5379 * '.' or exponents) using local variables ('hash_seen', 'x').
5381 * * Sequences of digits are parsed into temporary variables holding fixnums.
5382 * Only if these fixnums would overflow, the result variables are updated
5383 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5384 * the temporary variables holding the fixnums are cleared, and the process
5385 * starts over again. If for example fixnums were able to store five decimal
5386 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5387 * and the result was computed as 12345 * 100000 + 67890. In other words,
5388 * only every five digits two bignum operations were performed.
5390 * Notes on the handling of exactness specifiers:
5392 * When parsing non-real complex numbers, we apply exactness specifiers on
5393 * per-component basis, as is done in PLT Scheme. For complex numbers
5394 * written in rectangular form, exactness specifiers are applied to the
5395 * real and imaginary parts before calling scm_make_rectangular. For
5396 * complex numbers written in polar form, exactness specifiers are applied
5397 * to the magnitude and angle before calling scm_make_polar.
5399 * There are two kinds of exactness specifiers: forced and implicit. A
5400 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5401 * the entire number, and applies to both components of a complex number.
5402 * "#e" causes each component to be made exact, and "#i" causes each
5403 * component to be made inexact. If no forced exactness specifier is
5404 * present, then the exactness of each component is determined
5405 * independently by the presence or absence of a decimal point or hash mark
5406 * within that component. If a decimal point or hash mark is present, the
5407 * component is made inexact, otherwise it is made exact.
5409 * After the exactness specifiers have been applied to each component, they
5410 * are passed to either scm_make_rectangular or scm_make_polar to produce
5411 * the final result. Note that this will result in a real number if the
5412 * imaginary part, magnitude, or angle is an exact 0.
5414 * For example, (string->number "#i5.0+0i") does the equivalent of:
5416 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5419 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5421 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5423 /* Caller is responsible for checking that the return value is in range
5424 for the given radix, which should be <= 36. */
5426 char_decimal_value (scm_t_uint32 c
)
5428 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5429 that's certainly above any valid decimal, so we take advantage of
5430 that to elide some tests. */
5431 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5433 /* If that failed, try extended hexadecimals, then. Only accept ascii
5438 if (c
>= (scm_t_uint32
) 'a')
5439 d
= c
- (scm_t_uint32
)'a' + 10U;
5445 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5446 unsigned int radix
, enum t_exactness
*p_exactness
)
5448 unsigned int idx
= *p_idx
;
5449 unsigned int hash_seen
= 0;
5450 scm_t_bits shift
= 1;
5452 unsigned int digit_value
;
5455 size_t len
= scm_i_string_length (mem
);
5460 c
= scm_i_string_ref (mem
, idx
);
5461 digit_value
= char_decimal_value (c
);
5462 if (digit_value
>= radix
)
5466 result
= SCM_I_MAKINUM (digit_value
);
5469 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5479 digit_value
= char_decimal_value (c
);
5480 /* This check catches non-decimals in addition to out-of-range
5482 if (digit_value
>= radix
)
5487 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5489 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5491 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5498 shift
= shift
* radix
;
5499 add
= add
* radix
+ digit_value
;
5504 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5506 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5510 *p_exactness
= INEXACT
;
5516 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5517 * covers the parts of the rules that start at a potential point. The value
5518 * of the digits up to the point have been parsed by the caller and are given
5519 * in variable result. The content of *p_exactness indicates, whether a hash
5520 * has already been seen in the digits before the point.
5523 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5526 mem2decimal_from_point (SCM result
, SCM mem
,
5527 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5529 unsigned int idx
= *p_idx
;
5530 enum t_exactness x
= *p_exactness
;
5531 size_t len
= scm_i_string_length (mem
);
5536 if (scm_i_string_ref (mem
, idx
) == '.')
5538 scm_t_bits shift
= 1;
5540 unsigned int digit_value
;
5541 SCM big_shift
= SCM_INUM1
;
5546 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5547 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5552 digit_value
= DIGIT2UINT (c
);
5563 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5565 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5566 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5568 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5576 add
= add
* 10 + digit_value
;
5582 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5583 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5584 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5587 result
= scm_divide (result
, big_shift
);
5589 /* We've seen a decimal point, thus the value is implicitly inexact. */
5601 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5603 switch (scm_i_string_ref (mem
, idx
))
5615 c
= scm_i_string_ref (mem
, idx
);
5623 c
= scm_i_string_ref (mem
, idx
);
5632 c
= scm_i_string_ref (mem
, idx
);
5637 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5641 exponent
= DIGIT2UINT (c
);
5644 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5645 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5648 if (exponent
<= SCM_MAXEXP
)
5649 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5655 if (exponent
> SCM_MAXEXP
)
5657 size_t exp_len
= idx
- start
;
5658 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5659 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5660 scm_out_of_range ("string->number", exp_num
);
5663 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5665 result
= scm_product (result
, e
);
5667 result
= scm_divide2real (result
, e
);
5669 /* We've seen an exponent, thus the value is implicitly inexact. */
5687 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5690 mem2ureal (SCM mem
, unsigned int *p_idx
,
5691 unsigned int radix
, enum t_exactness forced_x
)
5693 unsigned int idx
= *p_idx
;
5695 size_t len
= scm_i_string_length (mem
);
5697 /* Start off believing that the number will be exact. This changes
5698 to INEXACT if we see a decimal point or a hash. */
5699 enum t_exactness implicit_x
= EXACT
;
5704 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5710 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5712 /* Cobble up the fractional part. We might want to set the
5713 NaN's mantissa from it. */
5715 mem2uinteger (mem
, &idx
, 10, &implicit_x
);
5720 if (scm_i_string_ref (mem
, idx
) == '.')
5724 else if (idx
+ 1 == len
)
5726 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5729 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5730 p_idx
, &implicit_x
);
5736 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5737 if (scm_is_false (uinteger
))
5742 else if (scm_i_string_ref (mem
, idx
) == '/')
5750 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5751 if (scm_is_false (divisor
))
5754 /* both are int/big here, I assume */
5755 result
= scm_i_make_ratio (uinteger
, divisor
);
5757 else if (radix
== 10)
5759 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5760 if (scm_is_false (result
))
5772 if (SCM_INEXACTP (result
))
5773 return scm_inexact_to_exact (result
);
5777 if (SCM_INEXACTP (result
))
5780 return scm_exact_to_inexact (result
);
5782 if (implicit_x
== INEXACT
)
5784 if (SCM_INEXACTP (result
))
5787 return scm_exact_to_inexact (result
);
5793 /* We should never get here */
5794 scm_syserror ("mem2ureal");
5798 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5801 mem2complex (SCM mem
, unsigned int idx
,
5802 unsigned int radix
, enum t_exactness forced_x
)
5807 size_t len
= scm_i_string_length (mem
);
5812 c
= scm_i_string_ref (mem
, idx
);
5827 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5828 if (scm_is_false (ureal
))
5830 /* input must be either +i or -i */
5835 if (scm_i_string_ref (mem
, idx
) == 'i'
5836 || scm_i_string_ref (mem
, idx
) == 'I')
5842 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5849 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5850 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5855 c
= scm_i_string_ref (mem
, idx
);
5859 /* either +<ureal>i or -<ureal>i */
5866 return scm_make_rectangular (SCM_INUM0
, ureal
);
5869 /* polar input: <real>@<real>. */
5880 c
= scm_i_string_ref (mem
, idx
);
5898 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5899 if (scm_is_false (angle
))
5904 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5905 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5907 result
= scm_make_polar (ureal
, angle
);
5912 /* expecting input matching <real>[+-]<ureal>?i */
5919 int sign
= (c
== '+') ? 1 : -1;
5920 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5922 if (scm_is_false (imag
))
5923 imag
= SCM_I_MAKINUM (sign
);
5924 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5925 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5929 if (scm_i_string_ref (mem
, idx
) != 'i'
5930 && scm_i_string_ref (mem
, idx
) != 'I')
5937 return scm_make_rectangular (ureal
, imag
);
5946 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5948 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5951 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5953 unsigned int idx
= 0;
5954 unsigned int radix
= NO_RADIX
;
5955 enum t_exactness forced_x
= NO_EXACTNESS
;
5956 size_t len
= scm_i_string_length (mem
);
5958 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5959 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5961 switch (scm_i_string_ref (mem
, idx
+ 1))
5964 if (radix
!= NO_RADIX
)
5969 if (radix
!= NO_RADIX
)
5974 if (forced_x
!= NO_EXACTNESS
)
5979 if (forced_x
!= NO_EXACTNESS
)
5984 if (radix
!= NO_RADIX
)
5989 if (radix
!= NO_RADIX
)
5999 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6000 if (radix
== NO_RADIX
)
6001 radix
= default_radix
;
6003 return mem2complex (mem
, idx
, radix
, forced_x
);
6007 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6008 unsigned int default_radix
)
6010 SCM str
= scm_from_locale_stringn (mem
, len
);
6012 return scm_i_string_to_number (str
, default_radix
);
6016 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6017 (SCM string
, SCM radix
),
6018 "Return a number of the maximally precise representation\n"
6019 "expressed by the given @var{string}. @var{radix} must be an\n"
6020 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6021 "is a default radix that may be overridden by an explicit radix\n"
6022 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6023 "supplied, then the default radix is 10. If string is not a\n"
6024 "syntactically valid notation for a number, then\n"
6025 "@code{string->number} returns @code{#f}.")
6026 #define FUNC_NAME s_scm_string_to_number
6030 SCM_VALIDATE_STRING (1, string
);
6032 if (SCM_UNBNDP (radix
))
6035 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6037 answer
= scm_i_string_to_number (string
, base
);
6038 scm_remember_upto_here_1 (string
);
6044 /*** END strs->nums ***/
6047 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6049 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6051 #define FUNC_NAME s_scm_number_p
6053 return scm_from_bool (SCM_NUMBERP (x
));
6057 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6059 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6060 "otherwise. Note that the sets of real, rational and integer\n"
6061 "values form subsets of the set of complex numbers, i. e. the\n"
6062 "predicate will also be fulfilled if @var{x} is a real,\n"
6063 "rational or integer number.")
6064 #define FUNC_NAME s_scm_complex_p
6066 /* all numbers are complex. */
6067 return scm_number_p (x
);
6071 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6073 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6074 "otherwise. Note that the set of integer values forms a subset of\n"
6075 "the set of real numbers, i. e. the predicate will also be\n"
6076 "fulfilled if @var{x} is an integer number.")
6077 #define FUNC_NAME s_scm_real_p
6079 return scm_from_bool
6080 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6084 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6086 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6087 "otherwise. Note that the set of integer values forms a subset of\n"
6088 "the set of rational numbers, i. e. the predicate will also be\n"
6089 "fulfilled if @var{x} is an integer number.")
6090 #define FUNC_NAME s_scm_rational_p
6092 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6094 else if (SCM_REALP (x
))
6095 /* due to their limited precision, finite floating point numbers are
6096 rational as well. (finite means neither infinity nor a NaN) */
6097 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6103 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6105 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6107 #define FUNC_NAME s_scm_integer_p
6109 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6111 else if (SCM_REALP (x
))
6113 double val
= SCM_REAL_VALUE (x
);
6114 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6122 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6123 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6124 (SCM x
, SCM y
, SCM rest
),
6125 "Return @code{#t} if all parameters are numerically equal.")
6126 #define FUNC_NAME s_scm_i_num_eq_p
6128 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6130 while (!scm_is_null (rest
))
6132 if (scm_is_false (scm_num_eq_p (x
, y
)))
6136 rest
= scm_cdr (rest
);
6138 return scm_num_eq_p (x
, y
);
6142 scm_num_eq_p (SCM x
, SCM y
)
6145 if (SCM_I_INUMP (x
))
6147 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6148 if (SCM_I_INUMP (y
))
6150 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6151 return scm_from_bool (xx
== yy
);
6153 else if (SCM_BIGP (y
))
6155 else if (SCM_REALP (y
))
6157 /* On a 32-bit system an inum fits a double, we can cast the inum
6158 to a double and compare.
6160 But on a 64-bit system an inum is bigger than a double and
6161 casting it to a double (call that dxx) will round. dxx is at
6162 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6163 an integer and fits a long. So we cast yy to a long and
6164 compare with plain xx.
6166 An alternative (for any size system actually) would be to check
6167 yy is an integer (with floor) and is in range of an inum
6168 (compare against appropriate powers of 2) then test
6169 xx==(scm_t_signed_bits)yy. It's just a matter of which
6170 casts/comparisons might be fastest or easiest for the cpu. */
6172 double yy
= SCM_REAL_VALUE (y
);
6173 return scm_from_bool ((double) xx
== yy
6174 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6175 || xx
== (scm_t_signed_bits
) yy
));
6177 else if (SCM_COMPLEXP (y
))
6178 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6179 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6180 else if (SCM_FRACTIONP (y
))
6183 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6185 else if (SCM_BIGP (x
))
6187 if (SCM_I_INUMP (y
))
6189 else if (SCM_BIGP (y
))
6191 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6192 scm_remember_upto_here_2 (x
, y
);
6193 return scm_from_bool (0 == cmp
);
6195 else if (SCM_REALP (y
))
6198 if (isnan (SCM_REAL_VALUE (y
)))
6200 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6201 scm_remember_upto_here_1 (x
);
6202 return scm_from_bool (0 == cmp
);
6204 else if (SCM_COMPLEXP (y
))
6207 if (0.0 != SCM_COMPLEX_IMAG (y
))
6209 if (isnan (SCM_COMPLEX_REAL (y
)))
6211 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6212 scm_remember_upto_here_1 (x
);
6213 return scm_from_bool (0 == cmp
);
6215 else if (SCM_FRACTIONP (y
))
6218 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6220 else if (SCM_REALP (x
))
6222 double xx
= SCM_REAL_VALUE (x
);
6223 if (SCM_I_INUMP (y
))
6225 /* see comments with inum/real above */
6226 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6227 return scm_from_bool (xx
== (double) yy
6228 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6229 || (scm_t_signed_bits
) xx
== yy
));
6231 else if (SCM_BIGP (y
))
6234 if (isnan (SCM_REAL_VALUE (x
)))
6236 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6237 scm_remember_upto_here_1 (y
);
6238 return scm_from_bool (0 == cmp
);
6240 else if (SCM_REALP (y
))
6241 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6242 else if (SCM_COMPLEXP (y
))
6243 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6244 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6245 else if (SCM_FRACTIONP (y
))
6247 double xx
= SCM_REAL_VALUE (x
);
6251 return scm_from_bool (xx
< 0.0);
6252 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6256 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
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 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6296 else if (SCM_FRACTIONP (x
))
6298 if (SCM_I_INUMP (y
))
6300 else if (SCM_BIGP (y
))
6302 else if (SCM_REALP (y
))
6304 double yy
= SCM_REAL_VALUE (y
);
6308 return scm_from_bool (0.0 < yy
);
6309 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6312 else if (SCM_COMPLEXP (y
))
6315 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6317 yy
= SCM_COMPLEX_REAL (y
);
6321 return scm_from_bool (0.0 < yy
);
6322 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6325 else if (SCM_FRACTIONP (y
))
6326 return scm_i_fraction_equalp (x
, y
);
6328 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6331 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6335 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6336 done are good for inums, but for bignums an answer can almost always be
6337 had by just examining a few high bits of the operands, as done by GMP in
6338 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6339 of the float exponent to take into account. */
6341 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6342 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6343 (SCM x
, SCM y
, SCM rest
),
6344 "Return @code{#t} if the list of parameters is monotonically\n"
6346 #define FUNC_NAME s_scm_i_num_less_p
6348 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6350 while (!scm_is_null (rest
))
6352 if (scm_is_false (scm_less_p (x
, y
)))
6356 rest
= scm_cdr (rest
);
6358 return scm_less_p (x
, y
);
6362 scm_less_p (SCM x
, SCM y
)
6365 if (SCM_I_INUMP (x
))
6367 scm_t_inum xx
= SCM_I_INUM (x
);
6368 if (SCM_I_INUMP (y
))
6370 scm_t_inum yy
= SCM_I_INUM (y
);
6371 return scm_from_bool (xx
< yy
);
6373 else if (SCM_BIGP (y
))
6375 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6376 scm_remember_upto_here_1 (y
);
6377 return scm_from_bool (sgn
> 0);
6379 else if (SCM_REALP (y
))
6380 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6381 else if (SCM_FRACTIONP (y
))
6383 /* "x < a/b" becomes "x*b < a" */
6385 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6386 y
= SCM_FRACTION_NUMERATOR (y
);
6390 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6392 else if (SCM_BIGP (x
))
6394 if (SCM_I_INUMP (y
))
6396 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6397 scm_remember_upto_here_1 (x
);
6398 return scm_from_bool (sgn
< 0);
6400 else if (SCM_BIGP (y
))
6402 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6403 scm_remember_upto_here_2 (x
, y
);
6404 return scm_from_bool (cmp
< 0);
6406 else if (SCM_REALP (y
))
6409 if (isnan (SCM_REAL_VALUE (y
)))
6411 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6412 scm_remember_upto_here_1 (x
);
6413 return scm_from_bool (cmp
< 0);
6415 else if (SCM_FRACTIONP (y
))
6418 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6420 else if (SCM_REALP (x
))
6422 if (SCM_I_INUMP (y
))
6423 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6424 else if (SCM_BIGP (y
))
6427 if (isnan (SCM_REAL_VALUE (x
)))
6429 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6430 scm_remember_upto_here_1 (y
);
6431 return scm_from_bool (cmp
> 0);
6433 else if (SCM_REALP (y
))
6434 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6435 else if (SCM_FRACTIONP (y
))
6437 double xx
= SCM_REAL_VALUE (x
);
6441 return scm_from_bool (xx
< 0.0);
6442 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6446 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6448 else if (SCM_FRACTIONP (x
))
6450 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6452 /* "a/b < y" becomes "a < y*b" */
6453 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6454 x
= SCM_FRACTION_NUMERATOR (x
);
6457 else if (SCM_REALP (y
))
6459 double yy
= SCM_REAL_VALUE (y
);
6463 return scm_from_bool (0.0 < yy
);
6464 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6467 else if (SCM_FRACTIONP (y
))
6469 /* "a/b < c/d" becomes "a*d < c*b" */
6470 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6471 SCM_FRACTION_DENOMINATOR (y
));
6472 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6473 SCM_FRACTION_DENOMINATOR (x
));
6479 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6482 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6486 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6487 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6488 (SCM x
, SCM y
, SCM rest
),
6489 "Return @code{#t} if the list of parameters is monotonically\n"
6491 #define FUNC_NAME s_scm_i_num_gr_p
6493 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6495 while (!scm_is_null (rest
))
6497 if (scm_is_false (scm_gr_p (x
, y
)))
6501 rest
= scm_cdr (rest
);
6503 return scm_gr_p (x
, y
);
6506 #define FUNC_NAME s_scm_i_num_gr_p
6508 scm_gr_p (SCM x
, SCM y
)
6510 if (!SCM_NUMBERP (x
))
6511 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6512 else if (!SCM_NUMBERP (y
))
6513 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6515 return scm_less_p (y
, x
);
6520 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6521 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6522 (SCM x
, SCM y
, SCM rest
),
6523 "Return @code{#t} if the list of parameters is monotonically\n"
6525 #define FUNC_NAME s_scm_i_num_leq_p
6527 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6529 while (!scm_is_null (rest
))
6531 if (scm_is_false (scm_leq_p (x
, y
)))
6535 rest
= scm_cdr (rest
);
6537 return scm_leq_p (x
, y
);
6540 #define FUNC_NAME s_scm_i_num_leq_p
6542 scm_leq_p (SCM x
, SCM y
)
6544 if (!SCM_NUMBERP (x
))
6545 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6546 else if (!SCM_NUMBERP (y
))
6547 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6548 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6551 return scm_not (scm_less_p (y
, x
));
6556 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6557 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6558 (SCM x
, SCM y
, SCM rest
),
6559 "Return @code{#t} if the list of parameters is monotonically\n"
6561 #define FUNC_NAME s_scm_i_num_geq_p
6563 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6565 while (!scm_is_null (rest
))
6567 if (scm_is_false (scm_geq_p (x
, y
)))
6571 rest
= scm_cdr (rest
);
6573 return scm_geq_p (x
, y
);
6576 #define FUNC_NAME s_scm_i_num_geq_p
6578 scm_geq_p (SCM x
, SCM y
)
6580 if (!SCM_NUMBERP (x
))
6581 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6582 else if (!SCM_NUMBERP (y
))
6583 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6584 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6587 return scm_not (scm_less_p (x
, y
));
6592 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6594 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6596 #define FUNC_NAME s_scm_zero_p
6598 if (SCM_I_INUMP (z
))
6599 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6600 else if (SCM_BIGP (z
))
6602 else if (SCM_REALP (z
))
6603 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6604 else if (SCM_COMPLEXP (z
))
6605 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6606 && SCM_COMPLEX_IMAG (z
) == 0.0);
6607 else if (SCM_FRACTIONP (z
))
6610 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6615 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6617 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6619 #define FUNC_NAME s_scm_positive_p
6621 if (SCM_I_INUMP (x
))
6622 return scm_from_bool (SCM_I_INUM (x
) > 0);
6623 else if (SCM_BIGP (x
))
6625 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6626 scm_remember_upto_here_1 (x
);
6627 return scm_from_bool (sgn
> 0);
6629 else if (SCM_REALP (x
))
6630 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6631 else if (SCM_FRACTIONP (x
))
6632 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6634 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6639 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6641 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6643 #define FUNC_NAME s_scm_negative_p
6645 if (SCM_I_INUMP (x
))
6646 return scm_from_bool (SCM_I_INUM (x
) < 0);
6647 else if (SCM_BIGP (x
))
6649 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6650 scm_remember_upto_here_1 (x
);
6651 return scm_from_bool (sgn
< 0);
6653 else if (SCM_REALP (x
))
6654 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6655 else if (SCM_FRACTIONP (x
))
6656 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6658 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6663 /* scm_min and scm_max return an inexact when either argument is inexact, as
6664 required by r5rs. On that basis, for exact/inexact combinations the
6665 exact is converted to inexact to compare and possibly return. This is
6666 unlike scm_less_p above which takes some trouble to preserve all bits in
6667 its test, such trouble is not required for min and max. */
6669 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6670 (SCM x
, SCM y
, SCM rest
),
6671 "Return the maximum of all parameter values.")
6672 #define FUNC_NAME s_scm_i_max
6674 while (!scm_is_null (rest
))
6675 { x
= scm_max (x
, y
);
6677 rest
= scm_cdr (rest
);
6679 return scm_max (x
, y
);
6683 #define s_max s_scm_i_max
6684 #define g_max g_scm_i_max
6687 scm_max (SCM x
, SCM y
)
6692 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6693 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6696 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6699 if (SCM_I_INUMP (x
))
6701 scm_t_inum xx
= SCM_I_INUM (x
);
6702 if (SCM_I_INUMP (y
))
6704 scm_t_inum yy
= SCM_I_INUM (y
);
6705 return (xx
< yy
) ? y
: x
;
6707 else if (SCM_BIGP (y
))
6709 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6710 scm_remember_upto_here_1 (y
);
6711 return (sgn
< 0) ? x
: y
;
6713 else if (SCM_REALP (y
))
6716 double yyd
= SCM_REAL_VALUE (y
);
6719 return scm_from_double (xxd
);
6720 /* If y is a NaN, then "==" is false and we return the NaN */
6721 else if (SCM_LIKELY (!(xxd
== yyd
)))
6723 /* Handle signed zeroes properly */
6729 else if (SCM_FRACTIONP (y
))
6732 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6735 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6737 else if (SCM_BIGP (x
))
6739 if (SCM_I_INUMP (y
))
6741 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6742 scm_remember_upto_here_1 (x
);
6743 return (sgn
< 0) ? y
: x
;
6745 else if (SCM_BIGP (y
))
6747 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6748 scm_remember_upto_here_2 (x
, y
);
6749 return (cmp
> 0) ? x
: y
;
6751 else if (SCM_REALP (y
))
6753 /* if y==NaN then xx>yy is false, so we return the NaN y */
6756 xx
= scm_i_big2dbl (x
);
6757 yy
= SCM_REAL_VALUE (y
);
6758 return (xx
> yy
? scm_from_double (xx
) : y
);
6760 else if (SCM_FRACTIONP (y
))
6765 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6767 else if (SCM_REALP (x
))
6769 if (SCM_I_INUMP (y
))
6771 scm_t_inum yy
= SCM_I_INUM (y
);
6772 double xxd
= SCM_REAL_VALUE (x
);
6776 return scm_from_double (yyd
);
6777 /* If x is a NaN, then "==" is false and we return the NaN */
6778 else if (SCM_LIKELY (!(xxd
== yyd
)))
6780 /* Handle signed zeroes properly */
6786 else if (SCM_BIGP (y
))
6791 else if (SCM_REALP (y
))
6793 double xx
= SCM_REAL_VALUE (x
);
6794 double yy
= SCM_REAL_VALUE (y
);
6796 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6799 else if (SCM_LIKELY (xx
< yy
))
6801 /* If neither (xx > yy) nor (xx < yy), then
6802 either they're equal or one is a NaN */
6803 else if (SCM_UNLIKELY (isnan (xx
)))
6804 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6805 else if (SCM_UNLIKELY (isnan (yy
)))
6806 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6807 /* xx == yy, but handle signed zeroes properly */
6808 else if (double_is_non_negative_zero (yy
))
6813 else if (SCM_FRACTIONP (y
))
6815 double yy
= scm_i_fraction2double (y
);
6816 double xx
= SCM_REAL_VALUE (x
);
6817 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6820 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6822 else if (SCM_FRACTIONP (x
))
6824 if (SCM_I_INUMP (y
))
6828 else if (SCM_BIGP (y
))
6832 else if (SCM_REALP (y
))
6834 double xx
= scm_i_fraction2double (x
);
6835 /* if y==NaN then ">" is false, so we return the NaN y */
6836 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6838 else if (SCM_FRACTIONP (y
))
6843 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6846 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6850 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6851 (SCM x
, SCM y
, SCM rest
),
6852 "Return the minimum of all parameter values.")
6853 #define FUNC_NAME s_scm_i_min
6855 while (!scm_is_null (rest
))
6856 { x
= scm_min (x
, y
);
6858 rest
= scm_cdr (rest
);
6860 return scm_min (x
, y
);
6864 #define s_min s_scm_i_min
6865 #define g_min g_scm_i_min
6868 scm_min (SCM x
, SCM y
)
6873 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6874 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6877 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6880 if (SCM_I_INUMP (x
))
6882 scm_t_inum xx
= SCM_I_INUM (x
);
6883 if (SCM_I_INUMP (y
))
6885 scm_t_inum yy
= SCM_I_INUM (y
);
6886 return (xx
< yy
) ? x
: y
;
6888 else if (SCM_BIGP (y
))
6890 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6891 scm_remember_upto_here_1 (y
);
6892 return (sgn
< 0) ? y
: x
;
6894 else if (SCM_REALP (y
))
6897 /* if y==NaN then "<" is false and we return NaN */
6898 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6900 else if (SCM_FRACTIONP (y
))
6903 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6906 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6908 else if (SCM_BIGP (x
))
6910 if (SCM_I_INUMP (y
))
6912 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6913 scm_remember_upto_here_1 (x
);
6914 return (sgn
< 0) ? x
: y
;
6916 else if (SCM_BIGP (y
))
6918 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6919 scm_remember_upto_here_2 (x
, y
);
6920 return (cmp
> 0) ? y
: x
;
6922 else if (SCM_REALP (y
))
6924 /* if y==NaN then xx<yy is false, so we return the NaN y */
6927 xx
= scm_i_big2dbl (x
);
6928 yy
= SCM_REAL_VALUE (y
);
6929 return (xx
< yy
? scm_from_double (xx
) : y
);
6931 else if (SCM_FRACTIONP (y
))
6936 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6938 else if (SCM_REALP (x
))
6940 if (SCM_I_INUMP (y
))
6942 double z
= SCM_I_INUM (y
);
6943 /* if x==NaN then "<" is false and we return NaN */
6944 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6946 else if (SCM_BIGP (y
))
6951 else if (SCM_REALP (y
))
6953 double xx
= SCM_REAL_VALUE (x
);
6954 double yy
= SCM_REAL_VALUE (y
);
6956 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6959 else if (SCM_LIKELY (xx
> yy
))
6961 /* If neither (xx < yy) nor (xx > yy), then
6962 either they're equal or one is a NaN */
6963 else if (SCM_UNLIKELY (isnan (xx
)))
6964 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6965 else if (SCM_UNLIKELY (isnan (yy
)))
6966 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6967 /* xx == yy, but handle signed zeroes properly */
6968 else if (double_is_non_negative_zero (xx
))
6973 else if (SCM_FRACTIONP (y
))
6975 double yy
= scm_i_fraction2double (y
);
6976 double xx
= SCM_REAL_VALUE (x
);
6977 return (yy
< xx
) ? scm_from_double (yy
) : x
;
6980 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6982 else if (SCM_FRACTIONP (x
))
6984 if (SCM_I_INUMP (y
))
6988 else if (SCM_BIGP (y
))
6992 else if (SCM_REALP (y
))
6994 double xx
= scm_i_fraction2double (x
);
6995 /* if y==NaN then "<" is false, so we return the NaN y */
6996 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6998 else if (SCM_FRACTIONP (y
))
7003 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7006 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7010 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7011 (SCM x
, SCM y
, SCM rest
),
7012 "Return the sum of all parameter values. Return 0 if called without\n"
7014 #define FUNC_NAME s_scm_i_sum
7016 while (!scm_is_null (rest
))
7017 { x
= scm_sum (x
, y
);
7019 rest
= scm_cdr (rest
);
7021 return scm_sum (x
, y
);
7025 #define s_sum s_scm_i_sum
7026 #define g_sum g_scm_i_sum
7029 scm_sum (SCM x
, SCM y
)
7031 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7033 if (SCM_NUMBERP (x
)) return x
;
7034 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7035 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7038 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7040 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7042 scm_t_inum xx
= SCM_I_INUM (x
);
7043 scm_t_inum yy
= SCM_I_INUM (y
);
7044 scm_t_inum z
= xx
+ yy
;
7045 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7047 else if (SCM_BIGP (y
))
7052 else if (SCM_REALP (y
))
7054 scm_t_inum xx
= SCM_I_INUM (x
);
7055 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7057 else if (SCM_COMPLEXP (y
))
7059 scm_t_inum xx
= SCM_I_INUM (x
);
7060 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7061 SCM_COMPLEX_IMAG (y
));
7063 else if (SCM_FRACTIONP (y
))
7064 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7065 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7066 SCM_FRACTION_DENOMINATOR (y
));
7068 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7069 } else if (SCM_BIGP (x
))
7071 if (SCM_I_INUMP (y
))
7076 inum
= SCM_I_INUM (y
);
7079 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7082 SCM result
= scm_i_mkbig ();
7083 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7084 scm_remember_upto_here_1 (x
);
7085 /* we know the result will have to be a bignum */
7088 return scm_i_normbig (result
);
7092 SCM result
= scm_i_mkbig ();
7093 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7094 scm_remember_upto_here_1 (x
);
7095 /* we know the result will have to be a bignum */
7098 return scm_i_normbig (result
);
7101 else if (SCM_BIGP (y
))
7103 SCM result
= scm_i_mkbig ();
7104 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7105 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7106 mpz_add (SCM_I_BIG_MPZ (result
),
7109 scm_remember_upto_here_2 (x
, y
);
7110 /* we know the result will have to be a bignum */
7113 return scm_i_normbig (result
);
7115 else if (SCM_REALP (y
))
7117 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7118 scm_remember_upto_here_1 (x
);
7119 return scm_from_double (result
);
7121 else if (SCM_COMPLEXP (y
))
7123 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7124 + SCM_COMPLEX_REAL (y
));
7125 scm_remember_upto_here_1 (x
);
7126 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7128 else if (SCM_FRACTIONP (y
))
7129 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7130 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7131 SCM_FRACTION_DENOMINATOR (y
));
7133 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7135 else if (SCM_REALP (x
))
7137 if (SCM_I_INUMP (y
))
7138 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7139 else if (SCM_BIGP (y
))
7141 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7142 scm_remember_upto_here_1 (y
);
7143 return scm_from_double (result
);
7145 else if (SCM_REALP (y
))
7146 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7147 else if (SCM_COMPLEXP (y
))
7148 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7149 SCM_COMPLEX_IMAG (y
));
7150 else if (SCM_FRACTIONP (y
))
7151 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7153 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7155 else if (SCM_COMPLEXP (x
))
7157 if (SCM_I_INUMP (y
))
7158 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7159 SCM_COMPLEX_IMAG (x
));
7160 else if (SCM_BIGP (y
))
7162 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7163 + SCM_COMPLEX_REAL (x
));
7164 scm_remember_upto_here_1 (y
);
7165 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7167 else if (SCM_REALP (y
))
7168 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7169 SCM_COMPLEX_IMAG (x
));
7170 else if (SCM_COMPLEXP (y
))
7171 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7172 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7173 else if (SCM_FRACTIONP (y
))
7174 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7175 SCM_COMPLEX_IMAG (x
));
7177 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7179 else if (SCM_FRACTIONP (x
))
7181 if (SCM_I_INUMP (y
))
7182 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7183 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7184 SCM_FRACTION_DENOMINATOR (x
));
7185 else if (SCM_BIGP (y
))
7186 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7187 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7188 SCM_FRACTION_DENOMINATOR (x
));
7189 else if (SCM_REALP (y
))
7190 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7191 else if (SCM_COMPLEXP (y
))
7192 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7193 SCM_COMPLEX_IMAG (y
));
7194 else if (SCM_FRACTIONP (y
))
7195 /* a/b + c/d = (ad + bc) / bd */
7196 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7197 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7198 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7200 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7203 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7207 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7209 "Return @math{@var{x}+1}.")
7210 #define FUNC_NAME s_scm_oneplus
7212 return scm_sum (x
, SCM_INUM1
);
7217 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7218 (SCM x
, SCM y
, SCM rest
),
7219 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7220 "the sum of all but the first argument are subtracted from the first\n"
7222 #define FUNC_NAME s_scm_i_difference
7224 while (!scm_is_null (rest
))
7225 { x
= scm_difference (x
, y
);
7227 rest
= scm_cdr (rest
);
7229 return scm_difference (x
, y
);
7233 #define s_difference s_scm_i_difference
7234 #define g_difference g_scm_i_difference
7237 scm_difference (SCM x
, SCM y
)
7238 #define FUNC_NAME s_difference
7240 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7243 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7245 if (SCM_I_INUMP (x
))
7247 scm_t_inum xx
= -SCM_I_INUM (x
);
7248 if (SCM_FIXABLE (xx
))
7249 return SCM_I_MAKINUM (xx
);
7251 return scm_i_inum2big (xx
);
7253 else if (SCM_BIGP (x
))
7254 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7255 bignum, but negating that gives a fixnum. */
7256 return scm_i_normbig (scm_i_clonebig (x
, 0));
7257 else if (SCM_REALP (x
))
7258 return scm_from_double (-SCM_REAL_VALUE (x
));
7259 else if (SCM_COMPLEXP (x
))
7260 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7261 -SCM_COMPLEX_IMAG (x
));
7262 else if (SCM_FRACTIONP (x
))
7263 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7264 SCM_FRACTION_DENOMINATOR (x
));
7266 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7269 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7271 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7273 scm_t_inum xx
= SCM_I_INUM (x
);
7274 scm_t_inum yy
= SCM_I_INUM (y
);
7275 scm_t_inum z
= xx
- yy
;
7276 if (SCM_FIXABLE (z
))
7277 return SCM_I_MAKINUM (z
);
7279 return scm_i_inum2big (z
);
7281 else if (SCM_BIGP (y
))
7283 /* inum-x - big-y */
7284 scm_t_inum xx
= SCM_I_INUM (x
);
7288 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7289 bignum, but negating that gives a fixnum. */
7290 return scm_i_normbig (scm_i_clonebig (y
, 0));
7294 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7295 SCM result
= scm_i_mkbig ();
7298 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7301 /* x - y == -(y + -x) */
7302 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7303 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7305 scm_remember_upto_here_1 (y
);
7307 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7308 /* we know the result will have to be a bignum */
7311 return scm_i_normbig (result
);
7314 else if (SCM_REALP (y
))
7316 scm_t_inum xx
= SCM_I_INUM (x
);
7319 * We need to handle x == exact 0
7320 * specially because R6RS states that:
7321 * (- 0.0) ==> -0.0 and
7322 * (- 0.0 0.0) ==> 0.0
7323 * and the scheme compiler changes
7324 * (- 0.0) into (- 0 0.0)
7325 * So we need to treat (- 0 0.0) like (- 0.0).
7326 * At the C level, (-x) is different than (0.0 - x).
7327 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7330 return scm_from_double (- SCM_REAL_VALUE (y
));
7332 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7334 else if (SCM_COMPLEXP (y
))
7336 scm_t_inum xx
= SCM_I_INUM (x
);
7338 /* We need to handle x == exact 0 specially.
7339 See the comment above (for SCM_REALP (y)) */
7341 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7342 - SCM_COMPLEX_IMAG (y
));
7344 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7345 - SCM_COMPLEX_IMAG (y
));
7347 else if (SCM_FRACTIONP (y
))
7348 /* a - b/c = (ac - b) / c */
7349 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7350 SCM_FRACTION_NUMERATOR (y
)),
7351 SCM_FRACTION_DENOMINATOR (y
));
7353 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7355 else if (SCM_BIGP (x
))
7357 if (SCM_I_INUMP (y
))
7359 /* big-x - inum-y */
7360 scm_t_inum yy
= SCM_I_INUM (y
);
7361 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7363 scm_remember_upto_here_1 (x
);
7365 return (SCM_FIXABLE (-yy
) ?
7366 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7369 SCM result
= scm_i_mkbig ();
7372 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7374 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7375 scm_remember_upto_here_1 (x
);
7377 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7378 /* we know the result will have to be a bignum */
7381 return scm_i_normbig (result
);
7384 else if (SCM_BIGP (y
))
7386 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7387 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7388 SCM result
= scm_i_mkbig ();
7389 mpz_sub (SCM_I_BIG_MPZ (result
),
7392 scm_remember_upto_here_2 (x
, y
);
7393 /* we know the result will have to be a bignum */
7394 if ((sgn_x
== 1) && (sgn_y
== -1))
7396 if ((sgn_x
== -1) && (sgn_y
== 1))
7398 return scm_i_normbig (result
);
7400 else if (SCM_REALP (y
))
7402 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7403 scm_remember_upto_here_1 (x
);
7404 return scm_from_double (result
);
7406 else if (SCM_COMPLEXP (y
))
7408 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7409 - SCM_COMPLEX_REAL (y
));
7410 scm_remember_upto_here_1 (x
);
7411 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7413 else if (SCM_FRACTIONP (y
))
7414 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7415 SCM_FRACTION_NUMERATOR (y
)),
7416 SCM_FRACTION_DENOMINATOR (y
));
7417 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7419 else if (SCM_REALP (x
))
7421 if (SCM_I_INUMP (y
))
7422 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7423 else if (SCM_BIGP (y
))
7425 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7426 scm_remember_upto_here_1 (x
);
7427 return scm_from_double (result
);
7429 else if (SCM_REALP (y
))
7430 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7431 else if (SCM_COMPLEXP (y
))
7432 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7433 -SCM_COMPLEX_IMAG (y
));
7434 else if (SCM_FRACTIONP (y
))
7435 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7437 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7439 else if (SCM_COMPLEXP (x
))
7441 if (SCM_I_INUMP (y
))
7442 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7443 SCM_COMPLEX_IMAG (x
));
7444 else if (SCM_BIGP (y
))
7446 double real_part
= (SCM_COMPLEX_REAL (x
)
7447 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7448 scm_remember_upto_here_1 (x
);
7449 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7451 else if (SCM_REALP (y
))
7452 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7453 SCM_COMPLEX_IMAG (x
));
7454 else if (SCM_COMPLEXP (y
))
7455 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7456 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7457 else if (SCM_FRACTIONP (y
))
7458 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7459 SCM_COMPLEX_IMAG (x
));
7461 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7463 else if (SCM_FRACTIONP (x
))
7465 if (SCM_I_INUMP (y
))
7466 /* a/b - c = (a - cb) / b */
7467 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7468 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7469 SCM_FRACTION_DENOMINATOR (x
));
7470 else if (SCM_BIGP (y
))
7471 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7472 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7473 SCM_FRACTION_DENOMINATOR (x
));
7474 else if (SCM_REALP (y
))
7475 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7476 else if (SCM_COMPLEXP (y
))
7477 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7478 -SCM_COMPLEX_IMAG (y
));
7479 else if (SCM_FRACTIONP (y
))
7480 /* a/b - c/d = (ad - bc) / bd */
7481 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7482 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7483 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7485 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7488 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7493 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7495 "Return @math{@var{x}-1}.")
7496 #define FUNC_NAME s_scm_oneminus
7498 return scm_difference (x
, SCM_INUM1
);
7503 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7504 (SCM x
, SCM y
, SCM rest
),
7505 "Return the product of all arguments. If called without arguments,\n"
7507 #define FUNC_NAME s_scm_i_product
7509 while (!scm_is_null (rest
))
7510 { x
= scm_product (x
, y
);
7512 rest
= scm_cdr (rest
);
7514 return scm_product (x
, y
);
7518 #define s_product s_scm_i_product
7519 #define g_product g_scm_i_product
7522 scm_product (SCM x
, SCM y
)
7524 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7527 return SCM_I_MAKINUM (1L);
7528 else if (SCM_NUMBERP (x
))
7531 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7534 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7539 xx
= SCM_I_INUM (x
);
7544 /* exact1 is the universal multiplicative identity */
7548 /* exact0 times a fixnum is exact0: optimize this case */
7549 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7551 /* if the other argument is inexact, the result is inexact,
7552 and we must do the multiplication in order to handle
7553 infinities and NaNs properly. */
7554 else if (SCM_REALP (y
))
7555 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7556 else if (SCM_COMPLEXP (y
))
7557 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7558 0.0 * SCM_COMPLEX_IMAG (y
));
7559 /* we've already handled inexact numbers,
7560 so y must be exact, and we return exact0 */
7561 else if (SCM_NUMP (y
))
7564 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7568 * This case is important for more than just optimization.
7569 * It handles the case of negating
7570 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7571 * which is a bignum that must be changed back into a fixnum.
7572 * Failure to do so will cause the following to return #f:
7573 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7575 return scm_difference(y
, SCM_UNDEFINED
);
7579 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7581 scm_t_inum yy
= SCM_I_INUM (y
);
7582 scm_t_inum kk
= xx
* yy
;
7583 SCM k
= SCM_I_MAKINUM (kk
);
7584 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7588 SCM result
= scm_i_inum2big (xx
);
7589 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7590 return scm_i_normbig (result
);
7593 else if (SCM_BIGP (y
))
7595 SCM result
= scm_i_mkbig ();
7596 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7597 scm_remember_upto_here_1 (y
);
7600 else if (SCM_REALP (y
))
7601 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7602 else if (SCM_COMPLEXP (y
))
7603 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7604 xx
* SCM_COMPLEX_IMAG (y
));
7605 else if (SCM_FRACTIONP (y
))
7606 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7607 SCM_FRACTION_DENOMINATOR (y
));
7609 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7611 else if (SCM_BIGP (x
))
7613 if (SCM_I_INUMP (y
))
7618 else if (SCM_BIGP (y
))
7620 SCM result
= scm_i_mkbig ();
7621 mpz_mul (SCM_I_BIG_MPZ (result
),
7624 scm_remember_upto_here_2 (x
, y
);
7627 else if (SCM_REALP (y
))
7629 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7630 scm_remember_upto_here_1 (x
);
7631 return scm_from_double (result
);
7633 else if (SCM_COMPLEXP (y
))
7635 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7636 scm_remember_upto_here_1 (x
);
7637 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7638 z
* SCM_COMPLEX_IMAG (y
));
7640 else if (SCM_FRACTIONP (y
))
7641 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7642 SCM_FRACTION_DENOMINATOR (y
));
7644 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7646 else if (SCM_REALP (x
))
7648 if (SCM_I_INUMP (y
))
7653 else if (SCM_BIGP (y
))
7655 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7656 scm_remember_upto_here_1 (y
);
7657 return scm_from_double (result
);
7659 else if (SCM_REALP (y
))
7660 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7661 else if (SCM_COMPLEXP (y
))
7662 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7663 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7664 else if (SCM_FRACTIONP (y
))
7665 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7667 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7669 else if (SCM_COMPLEXP (x
))
7671 if (SCM_I_INUMP (y
))
7676 else if (SCM_BIGP (y
))
7678 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7679 scm_remember_upto_here_1 (y
);
7680 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7681 z
* SCM_COMPLEX_IMAG (x
));
7683 else if (SCM_REALP (y
))
7684 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7685 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7686 else if (SCM_COMPLEXP (y
))
7688 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7689 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7690 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7691 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7693 else if (SCM_FRACTIONP (y
))
7695 double yy
= scm_i_fraction2double (y
);
7696 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7697 yy
* SCM_COMPLEX_IMAG (x
));
7700 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7702 else if (SCM_FRACTIONP (x
))
7704 if (SCM_I_INUMP (y
))
7705 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7706 SCM_FRACTION_DENOMINATOR (x
));
7707 else if (SCM_BIGP (y
))
7708 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7709 SCM_FRACTION_DENOMINATOR (x
));
7710 else if (SCM_REALP (y
))
7711 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7712 else if (SCM_COMPLEXP (y
))
7714 double xx
= scm_i_fraction2double (x
);
7715 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7716 xx
* SCM_COMPLEX_IMAG (y
));
7718 else if (SCM_FRACTIONP (y
))
7719 /* a/b * c/d = ac / bd */
7720 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7721 SCM_FRACTION_NUMERATOR (y
)),
7722 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7723 SCM_FRACTION_DENOMINATOR (y
)));
7725 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7728 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7731 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7732 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7733 #define ALLOW_DIVIDE_BY_ZERO
7734 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7737 /* The code below for complex division is adapted from the GNU
7738 libstdc++, which adapted it from f2c's libF77, and is subject to
7741 /****************************************************************
7742 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7744 Permission to use, copy, modify, and distribute this software
7745 and its documentation for any purpose and without fee is hereby
7746 granted, provided that the above copyright notice appear in all
7747 copies and that both that the copyright notice and this
7748 permission notice and warranty disclaimer appear in supporting
7749 documentation, and that the names of AT&T Bell Laboratories or
7750 Bellcore or any of their entities not be used in advertising or
7751 publicity pertaining to distribution of the software without
7752 specific, written prior permission.
7754 AT&T and Bellcore disclaim all warranties with regard to this
7755 software, including all implied warranties of merchantability
7756 and fitness. In no event shall AT&T or Bellcore be liable for
7757 any special, indirect or consequential damages or any damages
7758 whatsoever resulting from loss of use, data or profits, whether
7759 in an action of contract, negligence or other tortious action,
7760 arising out of or in connection with the use or performance of
7762 ****************************************************************/
7764 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7765 (SCM x
, SCM y
, SCM rest
),
7766 "Divide the first argument by the product of the remaining\n"
7767 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7769 #define FUNC_NAME s_scm_i_divide
7771 while (!scm_is_null (rest
))
7772 { x
= scm_divide (x
, y
);
7774 rest
= scm_cdr (rest
);
7776 return scm_divide (x
, y
);
7780 #define s_divide s_scm_i_divide
7781 #define g_divide g_scm_i_divide
7784 do_divide (SCM x
, SCM y
, int inexact
)
7785 #define FUNC_NAME s_divide
7789 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7792 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7793 else if (SCM_I_INUMP (x
))
7795 scm_t_inum xx
= SCM_I_INUM (x
);
7796 if (xx
== 1 || xx
== -1)
7798 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7800 scm_num_overflow (s_divide
);
7805 return scm_from_double (1.0 / (double) xx
);
7806 else return scm_i_make_ratio (SCM_INUM1
, x
);
7809 else if (SCM_BIGP (x
))
7812 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7813 else return scm_i_make_ratio (SCM_INUM1
, x
);
7815 else if (SCM_REALP (x
))
7817 double xx
= SCM_REAL_VALUE (x
);
7818 #ifndef ALLOW_DIVIDE_BY_ZERO
7820 scm_num_overflow (s_divide
);
7823 return scm_from_double (1.0 / xx
);
7825 else if (SCM_COMPLEXP (x
))
7827 double r
= SCM_COMPLEX_REAL (x
);
7828 double i
= SCM_COMPLEX_IMAG (x
);
7829 if (fabs(r
) <= fabs(i
))
7832 double d
= i
* (1.0 + t
* t
);
7833 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7838 double d
= r
* (1.0 + t
* t
);
7839 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7842 else if (SCM_FRACTIONP (x
))
7843 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7844 SCM_FRACTION_NUMERATOR (x
));
7846 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7849 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7851 scm_t_inum xx
= SCM_I_INUM (x
);
7852 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7854 scm_t_inum yy
= SCM_I_INUM (y
);
7857 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7858 scm_num_overflow (s_divide
);
7860 return scm_from_double ((double) xx
/ (double) yy
);
7863 else if (xx
% yy
!= 0)
7866 return scm_from_double ((double) xx
/ (double) yy
);
7867 else return scm_i_make_ratio (x
, y
);
7871 scm_t_inum z
= xx
/ yy
;
7872 if (SCM_FIXABLE (z
))
7873 return SCM_I_MAKINUM (z
);
7875 return scm_i_inum2big (z
);
7878 else if (SCM_BIGP (y
))
7881 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7882 else return scm_i_make_ratio (x
, y
);
7884 else if (SCM_REALP (y
))
7886 double yy
= SCM_REAL_VALUE (y
);
7887 #ifndef ALLOW_DIVIDE_BY_ZERO
7889 scm_num_overflow (s_divide
);
7892 return scm_from_double ((double) xx
/ yy
);
7894 else if (SCM_COMPLEXP (y
))
7897 complex_div
: /* y _must_ be a complex number */
7899 double r
= SCM_COMPLEX_REAL (y
);
7900 double i
= SCM_COMPLEX_IMAG (y
);
7901 if (fabs(r
) <= fabs(i
))
7904 double d
= i
* (1.0 + t
* t
);
7905 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7910 double d
= r
* (1.0 + t
* t
);
7911 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7915 else if (SCM_FRACTIONP (y
))
7916 /* a / b/c = ac / b */
7917 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7918 SCM_FRACTION_NUMERATOR (y
));
7920 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7922 else if (SCM_BIGP (x
))
7924 if (SCM_I_INUMP (y
))
7926 scm_t_inum yy
= SCM_I_INUM (y
);
7929 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7930 scm_num_overflow (s_divide
);
7932 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7933 scm_remember_upto_here_1 (x
);
7934 return (sgn
== 0) ? scm_nan () : scm_inf ();
7941 /* FIXME: HMM, what are the relative performance issues here?
7942 We need to test. Is it faster on average to test
7943 divisible_p, then perform whichever operation, or is it
7944 faster to perform the integer div opportunistically and
7945 switch to real if there's a remainder? For now we take the
7946 middle ground: test, then if divisible, use the faster div
7949 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7950 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7954 SCM result
= scm_i_mkbig ();
7955 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7956 scm_remember_upto_here_1 (x
);
7958 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7959 return scm_i_normbig (result
);
7964 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7965 else return scm_i_make_ratio (x
, y
);
7969 else if (SCM_BIGP (y
))
7974 /* It's easily possible for the ratio x/y to fit a double
7975 but one or both x and y be too big to fit a double,
7976 hence the use of mpq_get_d rather than converting and
7979 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
7980 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
7981 return scm_from_double (mpq_get_d (q
));
7985 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
7989 SCM result
= scm_i_mkbig ();
7990 mpz_divexact (SCM_I_BIG_MPZ (result
),
7993 scm_remember_upto_here_2 (x
, y
);
7994 return scm_i_normbig (result
);
7997 return scm_i_make_ratio (x
, y
);
8000 else if (SCM_REALP (y
))
8002 double yy
= SCM_REAL_VALUE (y
);
8003 #ifndef ALLOW_DIVIDE_BY_ZERO
8005 scm_num_overflow (s_divide
);
8008 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8010 else if (SCM_COMPLEXP (y
))
8012 a
= scm_i_big2dbl (x
);
8015 else if (SCM_FRACTIONP (y
))
8016 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8017 SCM_FRACTION_NUMERATOR (y
));
8019 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8021 else if (SCM_REALP (x
))
8023 double rx
= SCM_REAL_VALUE (x
);
8024 if (SCM_I_INUMP (y
))
8026 scm_t_inum yy
= SCM_I_INUM (y
);
8027 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8029 scm_num_overflow (s_divide
);
8032 return scm_from_double (rx
/ (double) yy
);
8034 else if (SCM_BIGP (y
))
8036 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8037 scm_remember_upto_here_1 (y
);
8038 return scm_from_double (rx
/ dby
);
8040 else if (SCM_REALP (y
))
8042 double yy
= SCM_REAL_VALUE (y
);
8043 #ifndef ALLOW_DIVIDE_BY_ZERO
8045 scm_num_overflow (s_divide
);
8048 return scm_from_double (rx
/ yy
);
8050 else if (SCM_COMPLEXP (y
))
8055 else if (SCM_FRACTIONP (y
))
8056 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8058 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8060 else if (SCM_COMPLEXP (x
))
8062 double rx
= SCM_COMPLEX_REAL (x
);
8063 double ix
= SCM_COMPLEX_IMAG (x
);
8064 if (SCM_I_INUMP (y
))
8066 scm_t_inum yy
= SCM_I_INUM (y
);
8067 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8069 scm_num_overflow (s_divide
);
8074 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8077 else if (SCM_BIGP (y
))
8079 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8080 scm_remember_upto_here_1 (y
);
8081 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8083 else if (SCM_REALP (y
))
8085 double yy
= SCM_REAL_VALUE (y
);
8086 #ifndef ALLOW_DIVIDE_BY_ZERO
8088 scm_num_overflow (s_divide
);
8091 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8093 else if (SCM_COMPLEXP (y
))
8095 double ry
= SCM_COMPLEX_REAL (y
);
8096 double iy
= SCM_COMPLEX_IMAG (y
);
8097 if (fabs(ry
) <= fabs(iy
))
8100 double d
= iy
* (1.0 + t
* t
);
8101 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8106 double d
= ry
* (1.0 + t
* t
);
8107 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8110 else if (SCM_FRACTIONP (y
))
8112 double yy
= scm_i_fraction2double (y
);
8113 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8116 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8118 else if (SCM_FRACTIONP (x
))
8120 if (SCM_I_INUMP (y
))
8122 scm_t_inum yy
= SCM_I_INUM (y
);
8123 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8125 scm_num_overflow (s_divide
);
8128 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8129 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8131 else if (SCM_BIGP (y
))
8133 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8134 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8136 else if (SCM_REALP (y
))
8138 double yy
= SCM_REAL_VALUE (y
);
8139 #ifndef ALLOW_DIVIDE_BY_ZERO
8141 scm_num_overflow (s_divide
);
8144 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8146 else if (SCM_COMPLEXP (y
))
8148 a
= scm_i_fraction2double (x
);
8151 else if (SCM_FRACTIONP (y
))
8152 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8153 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8155 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8158 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8162 scm_divide (SCM x
, SCM y
)
8164 return do_divide (x
, y
, 0);
8167 static SCM
scm_divide2real (SCM x
, SCM y
)
8169 return do_divide (x
, y
, 1);
8175 scm_c_truncate (double x
)
8180 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8181 half-way case (ie. when x is an integer plus 0.5) going upwards.
8182 Then half-way cases are identified and adjusted down if the
8183 round-upwards didn't give the desired even integer.
8185 "plus_half == result" identifies a half-way case. If plus_half, which is
8186 x + 0.5, is an integer then x must be an integer plus 0.5.
8188 An odd "result" value is identified with result/2 != floor(result/2).
8189 This is done with plus_half, since that value is ready for use sooner in
8190 a pipelined cpu, and we're already requiring plus_half == result.
8192 Note however that we need to be careful when x is big and already an
8193 integer. In that case "x+0.5" may round to an adjacent integer, causing
8194 us to return such a value, incorrectly. For instance if the hardware is
8195 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8196 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8197 returned. Or if the hardware is in round-upwards mode, then other bigger
8198 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8199 representable value, 2^128+2^76 (or whatever), again incorrect.
8201 These bad roundings of x+0.5 are avoided by testing at the start whether
8202 x is already an integer. If it is then clearly that's the desired result
8203 already. And if it's not then the exponent must be small enough to allow
8204 an 0.5 to be represented, and hence added without a bad rounding. */
8207 scm_c_round (double x
)
8209 double plus_half
, result
;
8214 plus_half
= x
+ 0.5;
8215 result
= floor (plus_half
);
8216 /* Adjust so that the rounding is towards even. */
8217 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8222 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8224 "Round the number @var{x} towards zero.")
8225 #define FUNC_NAME s_scm_truncate_number
8227 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8229 else if (SCM_REALP (x
))
8230 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8231 else if (SCM_FRACTIONP (x
))
8232 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8233 SCM_FRACTION_DENOMINATOR (x
));
8235 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8236 s_scm_truncate_number
);
8240 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8242 "Round the number @var{x} towards the nearest integer. "
8243 "When it is exactly halfway between two integers, "
8244 "round towards the even one.")
8245 #define FUNC_NAME s_scm_round_number
8247 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8249 else if (SCM_REALP (x
))
8250 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8251 else if (SCM_FRACTIONP (x
))
8252 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8253 SCM_FRACTION_DENOMINATOR (x
));
8255 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8256 s_scm_round_number
);
8260 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8262 "Round the number @var{x} towards minus infinity.")
8263 #define FUNC_NAME s_scm_floor
8265 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8267 else if (SCM_REALP (x
))
8268 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8269 else if (SCM_FRACTIONP (x
))
8270 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8271 SCM_FRACTION_DENOMINATOR (x
));
8273 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8277 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8279 "Round the number @var{x} towards infinity.")
8280 #define FUNC_NAME s_scm_ceiling
8282 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8284 else if (SCM_REALP (x
))
8285 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8286 else if (SCM_FRACTIONP (x
))
8287 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8288 SCM_FRACTION_DENOMINATOR (x
));
8290 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8294 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8296 "Return @var{x} raised to the power of @var{y}.")
8297 #define FUNC_NAME s_scm_expt
8299 if (scm_is_integer (y
))
8301 if (scm_is_true (scm_exact_p (y
)))
8302 return scm_integer_expt (x
, y
);
8305 /* Here we handle the case where the exponent is an inexact
8306 integer. We make the exponent exact in order to use
8307 scm_integer_expt, and thus avoid the spurious imaginary
8308 parts that may result from round-off errors in the general
8309 e^(y log x) method below (for example when squaring a large
8310 negative number). In this case, we must return an inexact
8311 result for correctness. We also make the base inexact so
8312 that scm_integer_expt will use fast inexact arithmetic
8313 internally. Note that making the base inexact is not
8314 sufficient to guarantee an inexact result, because
8315 scm_integer_expt will return an exact 1 when the exponent
8316 is 0, even if the base is inexact. */
8317 return scm_exact_to_inexact
8318 (scm_integer_expt (scm_exact_to_inexact (x
),
8319 scm_inexact_to_exact (y
)));
8322 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8324 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8326 else if (scm_is_complex (x
) && scm_is_complex (y
))
8327 return scm_exp (scm_product (scm_log (x
), y
));
8328 else if (scm_is_complex (x
))
8329 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8331 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8335 /* sin/cos/tan/asin/acos/atan
8336 sinh/cosh/tanh/asinh/acosh/atanh
8337 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8338 Written by Jerry D. Hedden, (C) FSF.
8339 See the file `COPYING' for terms applying to this program. */
8341 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8343 "Compute the sine of @var{z}.")
8344 #define FUNC_NAME s_scm_sin
8346 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8347 return z
; /* sin(exact0) = exact0 */
8348 else if (scm_is_real (z
))
8349 return scm_from_double (sin (scm_to_double (z
)));
8350 else if (SCM_COMPLEXP (z
))
8352 x
= SCM_COMPLEX_REAL (z
);
8353 y
= SCM_COMPLEX_IMAG (z
);
8354 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8355 cos (x
) * sinh (y
));
8358 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8362 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8364 "Compute the cosine of @var{z}.")
8365 #define FUNC_NAME s_scm_cos
8367 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8368 return SCM_INUM1
; /* cos(exact0) = exact1 */
8369 else if (scm_is_real (z
))
8370 return scm_from_double (cos (scm_to_double (z
)));
8371 else if (SCM_COMPLEXP (z
))
8373 x
= SCM_COMPLEX_REAL (z
);
8374 y
= SCM_COMPLEX_IMAG (z
);
8375 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8376 -sin (x
) * sinh (y
));
8379 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8383 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8385 "Compute the tangent of @var{z}.")
8386 #define FUNC_NAME s_scm_tan
8388 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8389 return z
; /* tan(exact0) = exact0 */
8390 else if (scm_is_real (z
))
8391 return scm_from_double (tan (scm_to_double (z
)));
8392 else if (SCM_COMPLEXP (z
))
8394 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8395 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8396 w
= cos (x
) + cosh (y
);
8397 #ifndef ALLOW_DIVIDE_BY_ZERO
8399 scm_num_overflow (s_scm_tan
);
8401 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8404 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8408 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8410 "Compute the hyperbolic sine of @var{z}.")
8411 #define FUNC_NAME s_scm_sinh
8413 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8414 return z
; /* sinh(exact0) = exact0 */
8415 else if (scm_is_real (z
))
8416 return scm_from_double (sinh (scm_to_double (z
)));
8417 else if (SCM_COMPLEXP (z
))
8419 x
= SCM_COMPLEX_REAL (z
);
8420 y
= SCM_COMPLEX_IMAG (z
);
8421 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8422 cosh (x
) * sin (y
));
8425 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8429 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8431 "Compute the hyperbolic cosine of @var{z}.")
8432 #define FUNC_NAME s_scm_cosh
8434 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8435 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8436 else if (scm_is_real (z
))
8437 return scm_from_double (cosh (scm_to_double (z
)));
8438 else if (SCM_COMPLEXP (z
))
8440 x
= SCM_COMPLEX_REAL (z
);
8441 y
= SCM_COMPLEX_IMAG (z
);
8442 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8443 sinh (x
) * sin (y
));
8446 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8450 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8452 "Compute the hyperbolic tangent of @var{z}.")
8453 #define FUNC_NAME s_scm_tanh
8455 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8456 return z
; /* tanh(exact0) = exact0 */
8457 else if (scm_is_real (z
))
8458 return scm_from_double (tanh (scm_to_double (z
)));
8459 else if (SCM_COMPLEXP (z
))
8461 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8462 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8463 w
= cosh (x
) + cos (y
);
8464 #ifndef ALLOW_DIVIDE_BY_ZERO
8466 scm_num_overflow (s_scm_tanh
);
8468 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8471 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8475 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8477 "Compute the arc sine of @var{z}.")
8478 #define FUNC_NAME s_scm_asin
8480 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8481 return z
; /* asin(exact0) = exact0 */
8482 else if (scm_is_real (z
))
8484 double w
= scm_to_double (z
);
8485 if (w
>= -1.0 && w
<= 1.0)
8486 return scm_from_double (asin (w
));
8488 return scm_product (scm_c_make_rectangular (0, -1),
8489 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8491 else if (SCM_COMPLEXP (z
))
8493 x
= SCM_COMPLEX_REAL (z
);
8494 y
= SCM_COMPLEX_IMAG (z
);
8495 return scm_product (scm_c_make_rectangular (0, -1),
8496 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8499 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8503 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8505 "Compute the arc cosine of @var{z}.")
8506 #define FUNC_NAME s_scm_acos
8508 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8509 return SCM_INUM0
; /* acos(exact1) = exact0 */
8510 else if (scm_is_real (z
))
8512 double w
= scm_to_double (z
);
8513 if (w
>= -1.0 && w
<= 1.0)
8514 return scm_from_double (acos (w
));
8516 return scm_sum (scm_from_double (acos (0.0)),
8517 scm_product (scm_c_make_rectangular (0, 1),
8518 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8520 else if (SCM_COMPLEXP (z
))
8522 x
= SCM_COMPLEX_REAL (z
);
8523 y
= SCM_COMPLEX_IMAG (z
);
8524 return scm_sum (scm_from_double (acos (0.0)),
8525 scm_product (scm_c_make_rectangular (0, 1),
8526 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8529 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8533 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8535 "With one argument, compute the arc tangent of @var{z}.\n"
8536 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8537 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8538 #define FUNC_NAME s_scm_atan
8542 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8543 return z
; /* atan(exact0) = exact0 */
8544 else if (scm_is_real (z
))
8545 return scm_from_double (atan (scm_to_double (z
)));
8546 else if (SCM_COMPLEXP (z
))
8549 v
= SCM_COMPLEX_REAL (z
);
8550 w
= SCM_COMPLEX_IMAG (z
);
8551 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8552 scm_c_make_rectangular (v
, w
+ 1.0))),
8553 scm_c_make_rectangular (0, 2));
8556 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8558 else if (scm_is_real (z
))
8560 if (scm_is_real (y
))
8561 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8563 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8566 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8570 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8572 "Compute the inverse hyperbolic sine of @var{z}.")
8573 #define FUNC_NAME s_scm_sys_asinh
8575 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8576 return z
; /* asinh(exact0) = exact0 */
8577 else if (scm_is_real (z
))
8578 return scm_from_double (asinh (scm_to_double (z
)));
8579 else if (scm_is_number (z
))
8580 return scm_log (scm_sum (z
,
8581 scm_sqrt (scm_sum (scm_product (z
, z
),
8584 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8588 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8590 "Compute the inverse hyperbolic cosine of @var{z}.")
8591 #define FUNC_NAME s_scm_sys_acosh
8593 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8594 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8595 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8596 return scm_from_double (acosh (scm_to_double (z
)));
8597 else if (scm_is_number (z
))
8598 return scm_log (scm_sum (z
,
8599 scm_sqrt (scm_difference (scm_product (z
, z
),
8602 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8606 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8608 "Compute the inverse hyperbolic tangent of @var{z}.")
8609 #define FUNC_NAME s_scm_sys_atanh
8611 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8612 return z
; /* atanh(exact0) = exact0 */
8613 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8614 return scm_from_double (atanh (scm_to_double (z
)));
8615 else if (scm_is_number (z
))
8616 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8617 scm_difference (SCM_INUM1
, z
))),
8620 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8625 scm_c_make_rectangular (double re
, double im
)
8629 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8631 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8632 SCM_COMPLEX_REAL (z
) = re
;
8633 SCM_COMPLEX_IMAG (z
) = im
;
8637 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8638 (SCM real_part
, SCM imaginary_part
),
8639 "Return a complex number constructed of the given @var{real-part} "
8640 "and @var{imaginary-part} parts.")
8641 #define FUNC_NAME s_scm_make_rectangular
8643 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8644 SCM_ARG1
, FUNC_NAME
, "real");
8645 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8646 SCM_ARG2
, FUNC_NAME
, "real");
8648 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8649 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8652 return scm_c_make_rectangular (scm_to_double (real_part
),
8653 scm_to_double (imaginary_part
));
8658 scm_c_make_polar (double mag
, double ang
)
8662 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8663 use it on Glibc-based systems that have it (it's a GNU extension). See
8664 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8666 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8667 sincos (ang
, &s
, &c
);
8673 /* If s and c are NaNs, this indicates that the angle is a NaN,
8674 infinite, or perhaps simply too large to determine its value
8675 mod 2*pi. However, we know something that the floating-point
8676 implementation doesn't know: We know that s and c are finite.
8677 Therefore, if the magnitude is zero, return a complex zero.
8679 The reason we check for the NaNs instead of using this case
8680 whenever mag == 0.0 is because when the angle is known, we'd
8681 like to return the correct kind of non-real complex zero:
8682 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8683 on which quadrant the angle is in.
8685 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8686 return scm_c_make_rectangular (0.0, 0.0);
8688 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8691 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8693 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8694 #define FUNC_NAME s_scm_make_polar
8696 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8697 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8699 /* If mag is exact0, return exact0 */
8700 if (scm_is_eq (mag
, SCM_INUM0
))
8702 /* Return a real if ang is exact0 */
8703 else if (scm_is_eq (ang
, SCM_INUM0
))
8706 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8711 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8713 "Return the real part of the number @var{z}.")
8714 #define FUNC_NAME s_scm_real_part
8716 if (SCM_COMPLEXP (z
))
8717 return scm_from_double (SCM_COMPLEX_REAL (z
));
8718 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8721 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8726 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8728 "Return the imaginary part of the number @var{z}.")
8729 #define FUNC_NAME s_scm_imag_part
8731 if (SCM_COMPLEXP (z
))
8732 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8733 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8736 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8740 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8742 "Return the numerator of the number @var{z}.")
8743 #define FUNC_NAME s_scm_numerator
8745 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8747 else if (SCM_FRACTIONP (z
))
8748 return SCM_FRACTION_NUMERATOR (z
);
8749 else if (SCM_REALP (z
))
8750 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8752 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8757 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8759 "Return the denominator of the number @var{z}.")
8760 #define FUNC_NAME s_scm_denominator
8762 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8764 else if (SCM_FRACTIONP (z
))
8765 return SCM_FRACTION_DENOMINATOR (z
);
8766 else if (SCM_REALP (z
))
8767 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8769 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8774 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8776 "Return the magnitude of the number @var{z}. This is the same as\n"
8777 "@code{abs} for real arguments, but also allows complex numbers.")
8778 #define FUNC_NAME s_scm_magnitude
8780 if (SCM_I_INUMP (z
))
8782 scm_t_inum zz
= SCM_I_INUM (z
);
8785 else if (SCM_POSFIXABLE (-zz
))
8786 return SCM_I_MAKINUM (-zz
);
8788 return scm_i_inum2big (-zz
);
8790 else if (SCM_BIGP (z
))
8792 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8793 scm_remember_upto_here_1 (z
);
8795 return scm_i_clonebig (z
, 0);
8799 else if (SCM_REALP (z
))
8800 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8801 else if (SCM_COMPLEXP (z
))
8802 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8803 else if (SCM_FRACTIONP (z
))
8805 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8807 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8808 SCM_FRACTION_DENOMINATOR (z
));
8811 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8816 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8818 "Return the angle of the complex number @var{z}.")
8819 #define FUNC_NAME s_scm_angle
8821 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8822 flo0 to save allocating a new flonum with scm_from_double each time.
8823 But if atan2 follows the floating point rounding mode, then the value
8824 is not a constant. Maybe it'd be close enough though. */
8825 if (SCM_I_INUMP (z
))
8827 if (SCM_I_INUM (z
) >= 0)
8830 return scm_from_double (atan2 (0.0, -1.0));
8832 else if (SCM_BIGP (z
))
8834 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8835 scm_remember_upto_here_1 (z
);
8837 return scm_from_double (atan2 (0.0, -1.0));
8841 else if (SCM_REALP (z
))
8843 if (SCM_REAL_VALUE (z
) >= 0)
8846 return scm_from_double (atan2 (0.0, -1.0));
8848 else if (SCM_COMPLEXP (z
))
8849 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8850 else if (SCM_FRACTIONP (z
))
8852 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8854 else return scm_from_double (atan2 (0.0, -1.0));
8857 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8862 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8864 "Convert the number @var{z} to its inexact representation.\n")
8865 #define FUNC_NAME s_scm_exact_to_inexact
8867 if (SCM_I_INUMP (z
))
8868 return scm_from_double ((double) SCM_I_INUM (z
));
8869 else if (SCM_BIGP (z
))
8870 return scm_from_double (scm_i_big2dbl (z
));
8871 else if (SCM_FRACTIONP (z
))
8872 return scm_from_double (scm_i_fraction2double (z
));
8873 else if (SCM_INEXACTP (z
))
8876 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8881 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8883 "Return an exact number that is numerically closest to @var{z}.")
8884 #define FUNC_NAME s_scm_inexact_to_exact
8886 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8893 val
= SCM_REAL_VALUE (z
);
8894 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8895 val
= SCM_COMPLEX_REAL (z
);
8897 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8899 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8900 SCM_OUT_OF_RANGE (1, z
);
8907 mpq_set_d (frac
, val
);
8908 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8909 scm_i_mpz2num (mpq_denref (frac
)));
8911 /* When scm_i_make_ratio throws, we leak the memory allocated
8921 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8923 "Returns the @emph{simplest} rational number differing\n"
8924 "from @var{x} by no more than @var{eps}.\n"
8926 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8927 "exact result when both its arguments are exact. Thus, you might need\n"
8928 "to use @code{inexact->exact} on the arguments.\n"
8931 "(rationalize (inexact->exact 1.2) 1/100)\n"
8934 #define FUNC_NAME s_scm_rationalize
8936 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8937 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8938 eps
= scm_abs (eps
);
8939 if (scm_is_false (scm_positive_p (eps
)))
8941 /* eps is either zero or a NaN */
8942 if (scm_is_true (scm_nan_p (eps
)))
8944 else if (SCM_INEXACTP (eps
))
8945 return scm_exact_to_inexact (x
);
8949 else if (scm_is_false (scm_finite_p (eps
)))
8951 if (scm_is_true (scm_finite_p (x
)))
8956 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8958 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8959 scm_ceiling (scm_difference (x
, eps
)))))
8961 /* There's an integer within range; we want the one closest to zero */
8962 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8964 /* zero is within range */
8965 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8970 else if (scm_is_true (scm_positive_p (x
)))
8971 return scm_ceiling (scm_difference (x
, eps
));
8973 return scm_floor (scm_sum (x
, eps
));
8977 /* Use continued fractions to find closest ratio. All
8978 arithmetic is done with exact numbers.
8981 SCM ex
= scm_inexact_to_exact (x
);
8982 SCM int_part
= scm_floor (ex
);
8984 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
8985 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
8989 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
8990 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
8992 /* We stop after a million iterations just to be absolutely sure
8993 that we don't go into an infinite loop. The process normally
8994 converges after less than a dozen iterations.
8997 while (++i
< 1000000)
8999 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9000 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9001 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9003 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9004 eps
))) /* abs(x-a/b) <= eps */
9006 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9007 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9008 return scm_exact_to_inexact (res
);
9012 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9014 tt
= scm_floor (rx
); /* tt = floor (rx) */
9020 scm_num_overflow (s_scm_rationalize
);
9025 /* conversion functions */
9028 scm_is_integer (SCM val
)
9030 return scm_is_true (scm_integer_p (val
));
9034 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9036 if (SCM_I_INUMP (val
))
9038 scm_t_signed_bits n
= SCM_I_INUM (val
);
9039 return n
>= min
&& n
<= max
;
9041 else if (SCM_BIGP (val
))
9043 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9045 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9047 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9049 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9050 return n
>= min
&& n
<= max
;
9060 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9061 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9064 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9065 SCM_I_BIG_MPZ (val
));
9067 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9079 return n
>= min
&& n
<= max
;
9087 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9089 if (SCM_I_INUMP (val
))
9091 scm_t_signed_bits n
= SCM_I_INUM (val
);
9092 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9094 else if (SCM_BIGP (val
))
9096 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9098 else if (max
<= ULONG_MAX
)
9100 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9102 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9103 return n
>= min
&& n
<= max
;
9113 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9116 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9117 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9120 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9121 SCM_I_BIG_MPZ (val
));
9123 return n
>= min
&& n
<= max
;
9131 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9133 scm_error (scm_out_of_range_key
,
9135 "Value out of range ~S to ~S: ~S",
9136 scm_list_3 (min
, max
, bad_val
),
9137 scm_list_1 (bad_val
));
9140 #define TYPE scm_t_intmax
9141 #define TYPE_MIN min
9142 #define TYPE_MAX max
9143 #define SIZEOF_TYPE 0
9144 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9145 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9146 #include "libguile/conv-integer.i.c"
9148 #define TYPE scm_t_uintmax
9149 #define TYPE_MIN min
9150 #define TYPE_MAX max
9151 #define SIZEOF_TYPE 0
9152 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9153 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9154 #include "libguile/conv-uinteger.i.c"
9156 #define TYPE scm_t_int8
9157 #define TYPE_MIN SCM_T_INT8_MIN
9158 #define TYPE_MAX SCM_T_INT8_MAX
9159 #define SIZEOF_TYPE 1
9160 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9161 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9162 #include "libguile/conv-integer.i.c"
9164 #define TYPE scm_t_uint8
9166 #define TYPE_MAX SCM_T_UINT8_MAX
9167 #define SIZEOF_TYPE 1
9168 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9169 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9170 #include "libguile/conv-uinteger.i.c"
9172 #define TYPE scm_t_int16
9173 #define TYPE_MIN SCM_T_INT16_MIN
9174 #define TYPE_MAX SCM_T_INT16_MAX
9175 #define SIZEOF_TYPE 2
9176 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9177 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9178 #include "libguile/conv-integer.i.c"
9180 #define TYPE scm_t_uint16
9182 #define TYPE_MAX SCM_T_UINT16_MAX
9183 #define SIZEOF_TYPE 2
9184 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9185 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9186 #include "libguile/conv-uinteger.i.c"
9188 #define TYPE scm_t_int32
9189 #define TYPE_MIN SCM_T_INT32_MIN
9190 #define TYPE_MAX SCM_T_INT32_MAX
9191 #define SIZEOF_TYPE 4
9192 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9193 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9194 #include "libguile/conv-integer.i.c"
9196 #define TYPE scm_t_uint32
9198 #define TYPE_MAX SCM_T_UINT32_MAX
9199 #define SIZEOF_TYPE 4
9200 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9201 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9202 #include "libguile/conv-uinteger.i.c"
9204 #define TYPE scm_t_wchar
9205 #define TYPE_MIN (scm_t_int32)-1
9206 #define TYPE_MAX (scm_t_int32)0x10ffff
9207 #define SIZEOF_TYPE 4
9208 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9209 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9210 #include "libguile/conv-integer.i.c"
9212 #define TYPE scm_t_int64
9213 #define TYPE_MIN SCM_T_INT64_MIN
9214 #define TYPE_MAX SCM_T_INT64_MAX
9215 #define SIZEOF_TYPE 8
9216 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9217 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9218 #include "libguile/conv-integer.i.c"
9220 #define TYPE scm_t_uint64
9222 #define TYPE_MAX SCM_T_UINT64_MAX
9223 #define SIZEOF_TYPE 8
9224 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9225 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9226 #include "libguile/conv-uinteger.i.c"
9229 scm_to_mpz (SCM val
, mpz_t rop
)
9231 if (SCM_I_INUMP (val
))
9232 mpz_set_si (rop
, SCM_I_INUM (val
));
9233 else if (SCM_BIGP (val
))
9234 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9236 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9240 scm_from_mpz (mpz_t val
)
9242 return scm_i_mpz2num (val
);
9246 scm_is_real (SCM val
)
9248 return scm_is_true (scm_real_p (val
));
9252 scm_is_rational (SCM val
)
9254 return scm_is_true (scm_rational_p (val
));
9258 scm_to_double (SCM val
)
9260 if (SCM_I_INUMP (val
))
9261 return SCM_I_INUM (val
);
9262 else if (SCM_BIGP (val
))
9263 return scm_i_big2dbl (val
);
9264 else if (SCM_FRACTIONP (val
))
9265 return scm_i_fraction2double (val
);
9266 else if (SCM_REALP (val
))
9267 return SCM_REAL_VALUE (val
);
9269 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9273 scm_from_double (double val
)
9277 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9279 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9280 SCM_REAL_VALUE (z
) = val
;
9285 #if SCM_ENABLE_DEPRECATED == 1
9288 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9290 scm_c_issue_deprecation_warning
9291 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9295 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9299 scm_out_of_range (NULL
, num
);
9302 return scm_to_double (num
);
9306 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9308 scm_c_issue_deprecation_warning
9309 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9313 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9317 scm_out_of_range (NULL
, num
);
9320 return scm_to_double (num
);
9326 scm_is_complex (SCM val
)
9328 return scm_is_true (scm_complex_p (val
));
9332 scm_c_real_part (SCM z
)
9334 if (SCM_COMPLEXP (z
))
9335 return SCM_COMPLEX_REAL (z
);
9338 /* Use the scm_real_part to get proper error checking and
9341 return scm_to_double (scm_real_part (z
));
9346 scm_c_imag_part (SCM z
)
9348 if (SCM_COMPLEXP (z
))
9349 return SCM_COMPLEX_IMAG (z
);
9352 /* Use the scm_imag_part to get proper error checking and
9353 dispatching. The result will almost always be 0.0, but not
9356 return scm_to_double (scm_imag_part (z
));
9361 scm_c_magnitude (SCM z
)
9363 return scm_to_double (scm_magnitude (z
));
9369 return scm_to_double (scm_angle (z
));
9373 scm_is_number (SCM z
)
9375 return scm_is_true (scm_number_p (z
));
9379 /* Returns log(x * 2^shift) */
9381 log_of_shifted_double (double x
, long shift
)
9383 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9385 if (x
> 0.0 || double_is_non_negative_zero (x
))
9386 return scm_from_double (ans
);
9388 return scm_c_make_rectangular (ans
, M_PI
);
9391 /* Returns log(n), for exact integer n of integer-length size */
9393 log_of_exact_integer_with_size (SCM n
, long size
)
9395 long shift
= size
- 2 * scm_dblprec
[0];
9398 return log_of_shifted_double
9399 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9402 return log_of_shifted_double (scm_to_double (n
), 0);
9405 /* Returns log(n), for exact integer n */
9407 log_of_exact_integer (SCM n
)
9409 return log_of_exact_integer_with_size
9410 (n
, scm_to_long (scm_integer_length (n
)));
9413 /* Returns log(n/d), for exact non-zero integers n and d */
9415 log_of_fraction (SCM n
, SCM d
)
9417 long n_size
= scm_to_long (scm_integer_length (n
));
9418 long d_size
= scm_to_long (scm_integer_length (d
));
9420 if (abs (n_size
- d_size
) > 1)
9421 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9422 log_of_exact_integer_with_size (d
, d_size
)));
9423 else if (scm_is_false (scm_negative_p (n
)))
9424 return scm_from_double
9425 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9427 return scm_c_make_rectangular
9428 (log1p (scm_to_double (scm_divide2real
9429 (scm_difference (scm_abs (n
), d
),
9435 /* In the following functions we dispatch to the real-arg funcs like log()
9436 when we know the arg is real, instead of just handing everything to
9437 clog() for instance. This is in case clog() doesn't optimize for a
9438 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9439 well use it to go straight to the applicable C func. */
9441 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9443 "Return the natural logarithm of @var{z}.")
9444 #define FUNC_NAME s_scm_log
9446 if (SCM_COMPLEXP (z
))
9448 #if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
9449 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9451 double re
= SCM_COMPLEX_REAL (z
);
9452 double im
= SCM_COMPLEX_IMAG (z
);
9453 return scm_c_make_rectangular (log (hypot (re
, im
)),
9457 else if (SCM_REALP (z
))
9458 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9459 else if (SCM_I_INUMP (z
))
9461 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9462 if (scm_is_eq (z
, SCM_INUM0
))
9463 scm_num_overflow (s_scm_log
);
9465 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9467 else if (SCM_BIGP (z
))
9468 return log_of_exact_integer (z
);
9469 else if (SCM_FRACTIONP (z
))
9470 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9471 SCM_FRACTION_DENOMINATOR (z
));
9473 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9478 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9480 "Return the base 10 logarithm of @var{z}.")
9481 #define FUNC_NAME s_scm_log10
9483 if (SCM_COMPLEXP (z
))
9485 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9486 clog() and a multiply by M_LOG10E, rather than the fallback
9487 log10+hypot+atan2.) */
9488 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9489 && defined SCM_COMPLEX_VALUE
9490 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9492 double re
= SCM_COMPLEX_REAL (z
);
9493 double im
= SCM_COMPLEX_IMAG (z
);
9494 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9495 M_LOG10E
* atan2 (im
, re
));
9498 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9500 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9501 if (scm_is_eq (z
, SCM_INUM0
))
9502 scm_num_overflow (s_scm_log10
);
9505 double re
= scm_to_double (z
);
9506 double l
= log10 (fabs (re
));
9507 if (re
> 0.0 || double_is_non_negative_zero (re
))
9508 return scm_from_double (l
);
9510 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9513 else if (SCM_BIGP (z
))
9514 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9515 else if (SCM_FRACTIONP (z
))
9516 return scm_product (flo_log10e
,
9517 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9518 SCM_FRACTION_DENOMINATOR (z
)));
9520 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9525 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9527 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9528 "base of natural logarithms (2.71828@dots{}).")
9529 #define FUNC_NAME s_scm_exp
9531 if (SCM_COMPLEXP (z
))
9533 #if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
9534 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9536 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9537 SCM_COMPLEX_IMAG (z
));
9540 else if (SCM_NUMBERP (z
))
9542 /* When z is a negative bignum the conversion to double overflows,
9543 giving -infinity, but that's ok, the exp is still 0.0. */
9544 return scm_from_double (exp (scm_to_double (z
)));
9547 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9552 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9554 "Return the square root of @var{z}. Of the two possible roots\n"
9555 "(positive and negative), the one with positive real part\n"
9556 "is returned, or if that's zero then a positive imaginary part.\n"
9560 "(sqrt 9.0) @result{} 3.0\n"
9561 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9562 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9563 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9565 #define FUNC_NAME s_scm_sqrt
9567 if (SCM_COMPLEXP (z
))
9569 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9570 && defined SCM_COMPLEX_VALUE
9571 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9573 double re
= SCM_COMPLEX_REAL (z
);
9574 double im
= SCM_COMPLEX_IMAG (z
);
9575 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9576 0.5 * atan2 (im
, re
));
9579 else if (SCM_NUMBERP (z
))
9581 double xx
= scm_to_double (z
);
9583 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9585 return scm_from_double (sqrt (xx
));
9588 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9599 mpz_init_set_si (z_negative_one
, -1);
9601 /* It may be possible to tune the performance of some algorithms by using
9602 * the following constants to avoid the creation of bignums. Please, before
9603 * using these values, remember the two rules of program optimization:
9604 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9605 scm_c_define ("most-positive-fixnum",
9606 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9607 scm_c_define ("most-negative-fixnum",
9608 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9610 scm_add_feature ("complex");
9611 scm_add_feature ("inexact");
9612 flo0
= scm_from_double (0.0);
9613 flo_log10e
= scm_from_double (M_LOG10E
);
9615 /* determine floating point precision */
9616 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9618 init_dblprec(&scm_dblprec
[i
-2],i
);
9619 init_fx_radix(fx_per_radix
[i
-2],i
);
9622 /* hard code precision for base 10 if the preprocessor tells us to... */
9623 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9626 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9627 #include "libguile/numbers.x"