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 before 4.2 didn't recognise infinities, so
138 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
139 in March 2006), mpz_cmp_d now handles infinities properly. */
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 GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
320 following the hardware rounding mode, but applied to the absolute
321 value of the mpz_t operand. This is not what we want so we put the
322 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
323 (released in March 2006) mpz_get_d now always truncates towards zero.
325 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
326 before 4.2 is a slowdown. It'd be faster to pick out the relevant
327 high bits with mpz_getlimbn. */
330 scm_i_big2dbl (SCM b
)
335 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
339 /* For GMP earlier than 4.2, force truncation towards zero */
341 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
342 _not_ the number of bits, so this code will break badly on a
343 system with non-binary doubles. */
346 if (bits
> DBL_MANT_DIG
)
348 size_t shift
= bits
- DBL_MANT_DIG
;
349 mpz_init2 (tmp
, DBL_MANT_DIG
);
350 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
351 result
= ldexp (mpz_get_d (tmp
), shift
);
356 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
360 /* GMP 4.2 or later */
361 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
364 if (bits
> DBL_MANT_DIG
)
366 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
367 /* test bit number "pos" in absolute value */
368 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
369 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
371 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
375 scm_remember_upto_here_1 (b
);
380 scm_i_normbig (SCM b
)
382 /* convert a big back to a fixnum if it'll fit */
383 /* presume b is a bignum */
384 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
386 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
387 if (SCM_FIXABLE (val
))
388 b
= SCM_I_MAKINUM (val
);
393 static SCM_C_INLINE_KEYWORD SCM
394 scm_i_mpz2num (mpz_t b
)
396 /* convert a mpz number to a SCM number. */
397 if (mpz_fits_slong_p (b
))
399 scm_t_inum val
= mpz_get_si (b
);
400 if (SCM_FIXABLE (val
))
401 return SCM_I_MAKINUM (val
);
405 SCM z
= make_bignum ();
406 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
411 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
412 static SCM
scm_divide2real (SCM x
, SCM y
);
415 scm_i_make_ratio (SCM numerator
, SCM denominator
)
416 #define FUNC_NAME "make-ratio"
418 /* First make sure the arguments are proper.
420 if (SCM_I_INUMP (denominator
))
422 if (scm_is_eq (denominator
, SCM_INUM0
))
423 scm_num_overflow ("make-ratio");
424 if (scm_is_eq (denominator
, SCM_INUM1
))
429 if (!(SCM_BIGP(denominator
)))
430 SCM_WRONG_TYPE_ARG (2, denominator
);
432 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
433 SCM_WRONG_TYPE_ARG (1, numerator
);
435 /* Then flip signs so that the denominator is positive.
437 if (scm_is_true (scm_negative_p (denominator
)))
439 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
440 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
443 /* Now consider for each of the four fixnum/bignum combinations
444 whether the rational number is really an integer.
446 if (SCM_I_INUMP (numerator
))
448 scm_t_inum x
= SCM_I_INUM (numerator
);
449 if (scm_is_eq (numerator
, SCM_INUM0
))
451 if (SCM_I_INUMP (denominator
))
454 y
= SCM_I_INUM (denominator
);
458 return SCM_I_MAKINUM (x
/ y
);
462 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
463 of that value for the denominator, as a bignum. Apart from
464 that case, abs(bignum) > abs(inum) so inum/bignum is not an
466 if (x
== SCM_MOST_NEGATIVE_FIXNUM
467 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
468 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
469 return SCM_I_MAKINUM(-1);
472 else if (SCM_BIGP (numerator
))
474 if (SCM_I_INUMP (denominator
))
476 scm_t_inum yy
= SCM_I_INUM (denominator
);
477 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
478 return scm_divide (numerator
, denominator
);
482 if (scm_is_eq (numerator
, denominator
))
484 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
485 SCM_I_BIG_MPZ (denominator
)))
486 return scm_divide(numerator
, denominator
);
490 /* No, it's a proper fraction.
493 SCM divisor
= scm_gcd (numerator
, denominator
);
494 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
496 numerator
= scm_divide (numerator
, divisor
);
497 denominator
= scm_divide (denominator
, divisor
);
500 return scm_double_cell (scm_tc16_fraction
,
501 SCM_UNPACK (numerator
),
502 SCM_UNPACK (denominator
), 0);
508 scm_i_fraction2double (SCM z
)
510 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
511 SCM_FRACTION_DENOMINATOR (z
)));
515 double_is_non_negative_zero (double x
)
517 static double zero
= 0.0;
519 return !memcmp (&x
, &zero
, sizeof(double));
522 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
524 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
526 #define FUNC_NAME s_scm_exact_p
528 if (SCM_INEXACTP (x
))
530 else if (SCM_NUMBERP (x
))
533 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
538 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
540 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
542 #define FUNC_NAME s_scm_inexact_p
544 if (SCM_INEXACTP (x
))
546 else if (SCM_NUMBERP (x
))
549 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
554 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
556 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
558 #define FUNC_NAME s_scm_odd_p
562 scm_t_inum val
= SCM_I_INUM (n
);
563 return scm_from_bool ((val
& 1L) != 0);
565 else if (SCM_BIGP (n
))
567 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
568 scm_remember_upto_here_1 (n
);
569 return scm_from_bool (odd_p
);
571 else if (SCM_REALP (n
))
573 double val
= SCM_REAL_VALUE (n
);
574 if (DOUBLE_IS_FINITE (val
))
576 double rem
= fabs (fmod (val
, 2.0));
583 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
588 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
590 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
592 #define FUNC_NAME s_scm_even_p
596 scm_t_inum val
= SCM_I_INUM (n
);
597 return scm_from_bool ((val
& 1L) == 0);
599 else if (SCM_BIGP (n
))
601 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
602 scm_remember_upto_here_1 (n
);
603 return scm_from_bool (even_p
);
605 else if (SCM_REALP (n
))
607 double val
= SCM_REAL_VALUE (n
);
608 if (DOUBLE_IS_FINITE (val
))
610 double rem
= fabs (fmod (val
, 2.0));
617 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
621 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
623 "Return @code{#t} if the real number @var{x} is neither\n"
624 "infinite nor a NaN, @code{#f} otherwise.")
625 #define FUNC_NAME s_scm_finite_p
628 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
629 else if (scm_is_real (x
))
632 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
636 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
638 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
639 "@samp{-inf.0}. Otherwise return @code{#f}.")
640 #define FUNC_NAME s_scm_inf_p
643 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
644 else if (scm_is_real (x
))
647 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
651 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
653 "Return @code{#t} if the real number @var{x} is a NaN,\n"
654 "or @code{#f} otherwise.")
655 #define FUNC_NAME s_scm_nan_p
658 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
659 else if (scm_is_real (x
))
662 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
666 /* Guile's idea of infinity. */
667 static double guile_Inf
;
669 /* Guile's idea of not a number. */
670 static double guile_NaN
;
673 guile_ieee_init (void)
675 /* Some version of gcc on some old version of Linux used to crash when
676 trying to make Inf and NaN. */
679 /* C99 INFINITY, when available.
680 FIXME: The standard allows for INFINITY to be something that overflows
681 at compile time. We ought to have a configure test to check for that
682 before trying to use it. (But in practice we believe this is not a
683 problem on any system guile is likely to target.) */
684 guile_Inf
= INFINITY
;
685 #elif defined HAVE_DINFINITY
687 extern unsigned int DINFINITY
[2];
688 guile_Inf
= (*((double *) (DINFINITY
)));
695 if (guile_Inf
== tmp
)
702 /* C99 NAN, when available */
704 #elif defined HAVE_DQNAN
707 extern unsigned int DQNAN
[2];
708 guile_NaN
= (*((double *)(DQNAN
)));
711 guile_NaN
= guile_Inf
/ guile_Inf
;
715 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
718 #define FUNC_NAME s_scm_inf
720 static int initialized
= 0;
726 return scm_from_double (guile_Inf
);
730 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
733 #define FUNC_NAME s_scm_nan
735 static int initialized
= 0;
741 return scm_from_double (guile_NaN
);
746 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
748 "Return the absolute value of @var{x}.")
749 #define FUNC_NAME s_scm_abs
753 scm_t_inum xx
= SCM_I_INUM (x
);
756 else if (SCM_POSFIXABLE (-xx
))
757 return SCM_I_MAKINUM (-xx
);
759 return scm_i_inum2big (-xx
);
761 else if (SCM_LIKELY (SCM_REALP (x
)))
763 double xx
= SCM_REAL_VALUE (x
);
764 /* If x is a NaN then xx<0 is false so we return x unchanged */
766 return scm_from_double (-xx
);
767 /* Handle signed zeroes properly */
768 else if (SCM_UNLIKELY (xx
== 0.0))
773 else if (SCM_BIGP (x
))
775 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
777 return scm_i_clonebig (x
, 0);
781 else if (SCM_FRACTIONP (x
))
783 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
785 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
786 SCM_FRACTION_DENOMINATOR (x
));
789 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
794 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
796 "Return the quotient of the numbers @var{x} and @var{y}.")
797 #define FUNC_NAME s_scm_quotient
799 if (SCM_LIKELY (scm_is_integer (x
)))
801 if (SCM_LIKELY (scm_is_integer (y
)))
802 return scm_truncate_quotient (x
, y
);
804 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
807 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
811 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
813 "Return the remainder of the numbers @var{x} and @var{y}.\n"
815 "(remainder 13 4) @result{} 1\n"
816 "(remainder -13 4) @result{} -1\n"
818 #define FUNC_NAME s_scm_remainder
820 if (SCM_LIKELY (scm_is_integer (x
)))
822 if (SCM_LIKELY (scm_is_integer (y
)))
823 return scm_truncate_remainder (x
, y
);
825 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
828 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
833 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
835 "Return the modulo of the numbers @var{x} and @var{y}.\n"
837 "(modulo 13 4) @result{} 1\n"
838 "(modulo -13 4) @result{} 3\n"
840 #define FUNC_NAME s_scm_modulo
842 if (SCM_LIKELY (scm_is_integer (x
)))
844 if (SCM_LIKELY (scm_is_integer (y
)))
845 return scm_floor_remainder (x
, y
);
847 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
850 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
854 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
855 two-valued functions. It is called from primitive generics that take
856 two arguments and return two values, when the core procedure is
857 unable to handle the given argument types. If there are GOOPS
858 methods for this primitive generic, it dispatches to GOOPS and, if
859 successful, expects two values to be returned, which are placed in
860 *rp1 and *rp2. If there are no GOOPS methods, it throws a
861 wrong-type-arg exception.
863 FIXME: This obviously belongs somewhere else, but until we decide on
864 the right API, it is here as a static function, because it is needed
865 by the *_divide functions below.
868 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
869 const char *subr
, SCM
*rp1
, SCM
*rp2
)
872 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
874 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
877 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
879 "Return the integer @var{q} such that\n"
880 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
881 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
883 "(euclidean-quotient 123 10) @result{} 12\n"
884 "(euclidean-quotient 123 -10) @result{} -12\n"
885 "(euclidean-quotient -123 10) @result{} -13\n"
886 "(euclidean-quotient -123 -10) @result{} 13\n"
887 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
888 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
890 #define FUNC_NAME s_scm_euclidean_quotient
892 if (scm_is_false (scm_negative_p (y
)))
893 return scm_floor_quotient (x
, y
);
895 return scm_ceiling_quotient (x
, y
);
899 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
901 "Return the real number @var{r} such that\n"
902 "@math{0 <= @var{r} < abs(@var{y})} and\n"
903 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
904 "for some integer @var{q}.\n"
906 "(euclidean-remainder 123 10) @result{} 3\n"
907 "(euclidean-remainder 123 -10) @result{} 3\n"
908 "(euclidean-remainder -123 10) @result{} 7\n"
909 "(euclidean-remainder -123 -10) @result{} 7\n"
910 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
911 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
913 #define FUNC_NAME s_scm_euclidean_remainder
915 if (scm_is_false (scm_negative_p (y
)))
916 return scm_floor_remainder (x
, y
);
918 return scm_ceiling_remainder (x
, y
);
922 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
924 "Return the integer @var{q} and the real number @var{r}\n"
925 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
926 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
928 "(euclidean/ 123 10) @result{} 12 and 3\n"
929 "(euclidean/ 123 -10) @result{} -12 and 3\n"
930 "(euclidean/ -123 10) @result{} -13 and 7\n"
931 "(euclidean/ -123 -10) @result{} 13 and 7\n"
932 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
933 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
935 #define FUNC_NAME s_scm_i_euclidean_divide
937 if (scm_is_false (scm_negative_p (y
)))
938 return scm_i_floor_divide (x
, y
);
940 return scm_i_ceiling_divide (x
, y
);
945 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
947 if (scm_is_false (scm_negative_p (y
)))
948 return scm_floor_divide (x
, y
, qp
, rp
);
950 return scm_ceiling_divide (x
, y
, qp
, rp
);
953 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
954 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
956 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
958 "Return the floor of @math{@var{x} / @var{y}}.\n"
960 "(floor-quotient 123 10) @result{} 12\n"
961 "(floor-quotient 123 -10) @result{} -13\n"
962 "(floor-quotient -123 10) @result{} -13\n"
963 "(floor-quotient -123 -10) @result{} 12\n"
964 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
965 "(floor-quotient 16/3 -10/7) @result{} -4\n"
967 #define FUNC_NAME s_scm_floor_quotient
969 if (SCM_LIKELY (SCM_I_INUMP (x
)))
971 scm_t_inum xx
= SCM_I_INUM (x
);
972 if (SCM_LIKELY (SCM_I_INUMP (y
)))
974 scm_t_inum yy
= SCM_I_INUM (y
);
977 if (SCM_LIKELY (yy
> 0))
979 if (SCM_UNLIKELY (xx
< 0))
982 else if (SCM_UNLIKELY (yy
== 0))
983 scm_num_overflow (s_scm_floor_quotient
);
987 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
988 return SCM_I_MAKINUM (qq
);
990 return scm_i_inum2big (qq
);
992 else if (SCM_BIGP (y
))
994 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
995 scm_remember_upto_here_1 (y
);
997 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
999 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1001 else if (SCM_REALP (y
))
1002 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1003 else if (SCM_FRACTIONP (y
))
1004 return scm_i_exact_rational_floor_quotient (x
, y
);
1006 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1007 s_scm_floor_quotient
);
1009 else if (SCM_BIGP (x
))
1011 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1013 scm_t_inum yy
= SCM_I_INUM (y
);
1014 if (SCM_UNLIKELY (yy
== 0))
1015 scm_num_overflow (s_scm_floor_quotient
);
1016 else if (SCM_UNLIKELY (yy
== 1))
1020 SCM q
= scm_i_mkbig ();
1022 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1025 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1026 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1028 scm_remember_upto_here_1 (x
);
1029 return scm_i_normbig (q
);
1032 else if (SCM_BIGP (y
))
1034 SCM q
= scm_i_mkbig ();
1035 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1038 scm_remember_upto_here_2 (x
, y
);
1039 return scm_i_normbig (q
);
1041 else if (SCM_REALP (y
))
1042 return scm_i_inexact_floor_quotient
1043 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1044 else if (SCM_FRACTIONP (y
))
1045 return scm_i_exact_rational_floor_quotient (x
, y
);
1047 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1048 s_scm_floor_quotient
);
1050 else if (SCM_REALP (x
))
1052 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1053 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1054 return scm_i_inexact_floor_quotient
1055 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1057 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1058 s_scm_floor_quotient
);
1060 else if (SCM_FRACTIONP (x
))
1063 return scm_i_inexact_floor_quotient
1064 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1065 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1066 return scm_i_exact_rational_floor_quotient (x
, y
);
1068 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1069 s_scm_floor_quotient
);
1072 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1073 s_scm_floor_quotient
);
1078 scm_i_inexact_floor_quotient (double x
, double y
)
1080 if (SCM_UNLIKELY (y
== 0))
1081 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1083 return scm_from_double (floor (x
/ y
));
1087 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1089 return scm_floor_quotient
1090 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1091 scm_product (scm_numerator (y
), scm_denominator (x
)));
1094 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1095 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1097 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1099 "Return the real number @var{r} such that\n"
1100 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1101 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1103 "(floor-remainder 123 10) @result{} 3\n"
1104 "(floor-remainder 123 -10) @result{} -7\n"
1105 "(floor-remainder -123 10) @result{} 7\n"
1106 "(floor-remainder -123 -10) @result{} -3\n"
1107 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1108 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1110 #define FUNC_NAME s_scm_floor_remainder
1112 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1114 scm_t_inum xx
= SCM_I_INUM (x
);
1115 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1117 scm_t_inum yy
= SCM_I_INUM (y
);
1118 if (SCM_UNLIKELY (yy
== 0))
1119 scm_num_overflow (s_scm_floor_remainder
);
1122 scm_t_inum rr
= xx
% yy
;
1123 int needs_adjustment
;
1125 if (SCM_LIKELY (yy
> 0))
1126 needs_adjustment
= (rr
< 0);
1128 needs_adjustment
= (rr
> 0);
1130 if (needs_adjustment
)
1132 return SCM_I_MAKINUM (rr
);
1135 else if (SCM_BIGP (y
))
1137 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1138 scm_remember_upto_here_1 (y
);
1143 SCM r
= scm_i_mkbig ();
1144 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1145 scm_remember_upto_here_1 (y
);
1146 return scm_i_normbig (r
);
1155 SCM r
= scm_i_mkbig ();
1156 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1157 scm_remember_upto_here_1 (y
);
1158 return scm_i_normbig (r
);
1161 else if (SCM_REALP (y
))
1162 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1163 else if (SCM_FRACTIONP (y
))
1164 return scm_i_exact_rational_floor_remainder (x
, y
);
1166 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1167 s_scm_floor_remainder
);
1169 else if (SCM_BIGP (x
))
1171 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1173 scm_t_inum yy
= SCM_I_INUM (y
);
1174 if (SCM_UNLIKELY (yy
== 0))
1175 scm_num_overflow (s_scm_floor_remainder
);
1180 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1182 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1183 scm_remember_upto_here_1 (x
);
1184 return SCM_I_MAKINUM (rr
);
1187 else if (SCM_BIGP (y
))
1189 SCM r
= scm_i_mkbig ();
1190 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1193 scm_remember_upto_here_2 (x
, y
);
1194 return scm_i_normbig (r
);
1196 else if (SCM_REALP (y
))
1197 return scm_i_inexact_floor_remainder
1198 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1199 else if (SCM_FRACTIONP (y
))
1200 return scm_i_exact_rational_floor_remainder (x
, y
);
1202 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1203 s_scm_floor_remainder
);
1205 else if (SCM_REALP (x
))
1207 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1208 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1209 return scm_i_inexact_floor_remainder
1210 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1212 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1213 s_scm_floor_remainder
);
1215 else if (SCM_FRACTIONP (x
))
1218 return scm_i_inexact_floor_remainder
1219 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1220 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1221 return scm_i_exact_rational_floor_remainder (x
, y
);
1223 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1224 s_scm_floor_remainder
);
1227 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1228 s_scm_floor_remainder
);
1233 scm_i_inexact_floor_remainder (double x
, double y
)
1235 /* Although it would be more efficient to use fmod here, we can't
1236 because it would in some cases produce results inconsistent with
1237 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1238 close). In particular, when x is very close to a multiple of y,
1239 then r might be either 0.0 or y, but those two cases must
1240 correspond to different choices of q. If r = 0.0 then q must be
1241 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1242 and remainder chooses the other, it would be bad. */
1243 if (SCM_UNLIKELY (y
== 0))
1244 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1246 return scm_from_double (x
- y
* floor (x
/ y
));
1250 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1252 SCM xd
= scm_denominator (x
);
1253 SCM yd
= scm_denominator (y
);
1254 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1255 scm_product (scm_numerator (y
), xd
));
1256 return scm_divide (r1
, scm_product (xd
, yd
));
1260 static void scm_i_inexact_floor_divide (double x
, double y
,
1262 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1265 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1267 "Return the integer @var{q} and the real number @var{r}\n"
1268 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1269 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1271 "(floor/ 123 10) @result{} 12 and 3\n"
1272 "(floor/ 123 -10) @result{} -13 and -7\n"
1273 "(floor/ -123 10) @result{} -13 and 7\n"
1274 "(floor/ -123 -10) @result{} 12 and -3\n"
1275 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1276 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1278 #define FUNC_NAME s_scm_i_floor_divide
1282 scm_floor_divide(x
, y
, &q
, &r
);
1283 return scm_values (scm_list_2 (q
, r
));
1287 #define s_scm_floor_divide s_scm_i_floor_divide
1288 #define g_scm_floor_divide g_scm_i_floor_divide
1291 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1293 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1295 scm_t_inum xx
= SCM_I_INUM (x
);
1296 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1298 scm_t_inum yy
= SCM_I_INUM (y
);
1299 if (SCM_UNLIKELY (yy
== 0))
1300 scm_num_overflow (s_scm_floor_divide
);
1303 scm_t_inum qq
= xx
/ yy
;
1304 scm_t_inum rr
= xx
% yy
;
1305 int needs_adjustment
;
1307 if (SCM_LIKELY (yy
> 0))
1308 needs_adjustment
= (rr
< 0);
1310 needs_adjustment
= (rr
> 0);
1312 if (needs_adjustment
)
1318 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1319 *qp
= SCM_I_MAKINUM (qq
);
1321 *qp
= scm_i_inum2big (qq
);
1322 *rp
= SCM_I_MAKINUM (rr
);
1326 else if (SCM_BIGP (y
))
1328 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1329 scm_remember_upto_here_1 (y
);
1334 SCM r
= scm_i_mkbig ();
1335 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1336 scm_remember_upto_here_1 (y
);
1337 *qp
= SCM_I_MAKINUM (-1);
1338 *rp
= scm_i_normbig (r
);
1353 SCM r
= scm_i_mkbig ();
1354 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1355 scm_remember_upto_here_1 (y
);
1356 *qp
= SCM_I_MAKINUM (-1);
1357 *rp
= scm_i_normbig (r
);
1361 else if (SCM_REALP (y
))
1362 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1363 else if (SCM_FRACTIONP (y
))
1364 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1366 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1367 s_scm_floor_divide
, qp
, rp
);
1369 else if (SCM_BIGP (x
))
1371 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1373 scm_t_inum yy
= SCM_I_INUM (y
);
1374 if (SCM_UNLIKELY (yy
== 0))
1375 scm_num_overflow (s_scm_floor_divide
);
1378 SCM q
= scm_i_mkbig ();
1379 SCM r
= scm_i_mkbig ();
1381 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1382 SCM_I_BIG_MPZ (x
), yy
);
1385 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1386 SCM_I_BIG_MPZ (x
), -yy
);
1387 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1389 scm_remember_upto_here_1 (x
);
1390 *qp
= scm_i_normbig (q
);
1391 *rp
= scm_i_normbig (r
);
1395 else if (SCM_BIGP (y
))
1397 SCM q
= scm_i_mkbig ();
1398 SCM r
= scm_i_mkbig ();
1399 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1400 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1401 scm_remember_upto_here_2 (x
, y
);
1402 *qp
= scm_i_normbig (q
);
1403 *rp
= scm_i_normbig (r
);
1406 else if (SCM_REALP (y
))
1407 return scm_i_inexact_floor_divide
1408 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1409 else if (SCM_FRACTIONP (y
))
1410 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1412 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1413 s_scm_floor_divide
, qp
, rp
);
1415 else if (SCM_REALP (x
))
1417 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1418 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1419 return scm_i_inexact_floor_divide
1420 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1422 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1423 s_scm_floor_divide
, qp
, rp
);
1425 else if (SCM_FRACTIONP (x
))
1428 return scm_i_inexact_floor_divide
1429 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1430 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1431 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1433 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1434 s_scm_floor_divide
, qp
, rp
);
1437 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1438 s_scm_floor_divide
, qp
, rp
);
1442 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1444 if (SCM_UNLIKELY (y
== 0))
1445 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1448 double q
= floor (x
/ y
);
1449 double r
= x
- q
* y
;
1450 *qp
= scm_from_double (q
);
1451 *rp
= scm_from_double (r
);
1456 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1459 SCM xd
= scm_denominator (x
);
1460 SCM yd
= scm_denominator (y
);
1462 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1463 scm_product (scm_numerator (y
), xd
),
1465 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1468 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1469 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1471 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1473 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1475 "(ceiling-quotient 123 10) @result{} 13\n"
1476 "(ceiling-quotient 123 -10) @result{} -12\n"
1477 "(ceiling-quotient -123 10) @result{} -12\n"
1478 "(ceiling-quotient -123 -10) @result{} 13\n"
1479 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1480 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1482 #define FUNC_NAME s_scm_ceiling_quotient
1484 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1486 scm_t_inum xx
= SCM_I_INUM (x
);
1487 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1489 scm_t_inum yy
= SCM_I_INUM (y
);
1490 if (SCM_UNLIKELY (yy
== 0))
1491 scm_num_overflow (s_scm_ceiling_quotient
);
1494 scm_t_inum xx1
= xx
;
1496 if (SCM_LIKELY (yy
> 0))
1498 if (SCM_LIKELY (xx
>= 0))
1501 else if (SCM_UNLIKELY (yy
== 0))
1502 scm_num_overflow (s_scm_ceiling_quotient
);
1506 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1507 return SCM_I_MAKINUM (qq
);
1509 return scm_i_inum2big (qq
);
1512 else if (SCM_BIGP (y
))
1514 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1515 scm_remember_upto_here_1 (y
);
1516 if (SCM_LIKELY (sign
> 0))
1518 if (SCM_LIKELY (xx
> 0))
1520 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1521 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1522 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1524 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1525 scm_remember_upto_here_1 (y
);
1526 return SCM_I_MAKINUM (-1);
1536 else if (SCM_REALP (y
))
1537 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1538 else if (SCM_FRACTIONP (y
))
1539 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1541 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1542 s_scm_ceiling_quotient
);
1544 else if (SCM_BIGP (x
))
1546 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1548 scm_t_inum yy
= SCM_I_INUM (y
);
1549 if (SCM_UNLIKELY (yy
== 0))
1550 scm_num_overflow (s_scm_ceiling_quotient
);
1551 else if (SCM_UNLIKELY (yy
== 1))
1555 SCM q
= scm_i_mkbig ();
1557 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1560 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1561 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1563 scm_remember_upto_here_1 (x
);
1564 return scm_i_normbig (q
);
1567 else if (SCM_BIGP (y
))
1569 SCM q
= scm_i_mkbig ();
1570 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1573 scm_remember_upto_here_2 (x
, y
);
1574 return scm_i_normbig (q
);
1576 else if (SCM_REALP (y
))
1577 return scm_i_inexact_ceiling_quotient
1578 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1579 else if (SCM_FRACTIONP (y
))
1580 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1582 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1583 s_scm_ceiling_quotient
);
1585 else if (SCM_REALP (x
))
1587 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1588 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1589 return scm_i_inexact_ceiling_quotient
1590 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1592 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1593 s_scm_ceiling_quotient
);
1595 else if (SCM_FRACTIONP (x
))
1598 return scm_i_inexact_ceiling_quotient
1599 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1600 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1601 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1603 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1604 s_scm_ceiling_quotient
);
1607 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1608 s_scm_ceiling_quotient
);
1613 scm_i_inexact_ceiling_quotient (double x
, double y
)
1615 if (SCM_UNLIKELY (y
== 0))
1616 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1618 return scm_from_double (ceil (x
/ y
));
1622 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1624 return scm_ceiling_quotient
1625 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1626 scm_product (scm_numerator (y
), scm_denominator (x
)));
1629 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1630 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1632 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1634 "Return the real number @var{r} such that\n"
1635 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1636 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1638 "(ceiling-remainder 123 10) @result{} -7\n"
1639 "(ceiling-remainder 123 -10) @result{} 3\n"
1640 "(ceiling-remainder -123 10) @result{} -3\n"
1641 "(ceiling-remainder -123 -10) @result{} 7\n"
1642 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1643 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1645 #define FUNC_NAME s_scm_ceiling_remainder
1647 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1649 scm_t_inum xx
= SCM_I_INUM (x
);
1650 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1652 scm_t_inum yy
= SCM_I_INUM (y
);
1653 if (SCM_UNLIKELY (yy
== 0))
1654 scm_num_overflow (s_scm_ceiling_remainder
);
1657 scm_t_inum rr
= xx
% yy
;
1658 int needs_adjustment
;
1660 if (SCM_LIKELY (yy
> 0))
1661 needs_adjustment
= (rr
> 0);
1663 needs_adjustment
= (rr
< 0);
1665 if (needs_adjustment
)
1667 return SCM_I_MAKINUM (rr
);
1670 else if (SCM_BIGP (y
))
1672 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1673 scm_remember_upto_here_1 (y
);
1674 if (SCM_LIKELY (sign
> 0))
1676 if (SCM_LIKELY (xx
> 0))
1678 SCM r
= scm_i_mkbig ();
1679 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1680 scm_remember_upto_here_1 (y
);
1681 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1682 return scm_i_normbig (r
);
1684 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1685 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1686 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1688 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1689 scm_remember_upto_here_1 (y
);
1699 SCM r
= scm_i_mkbig ();
1700 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1701 scm_remember_upto_here_1 (y
);
1702 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1703 return scm_i_normbig (r
);
1706 else if (SCM_REALP (y
))
1707 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1708 else if (SCM_FRACTIONP (y
))
1709 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1711 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1712 s_scm_ceiling_remainder
);
1714 else if (SCM_BIGP (x
))
1716 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1718 scm_t_inum yy
= SCM_I_INUM (y
);
1719 if (SCM_UNLIKELY (yy
== 0))
1720 scm_num_overflow (s_scm_ceiling_remainder
);
1725 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1727 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1728 scm_remember_upto_here_1 (x
);
1729 return SCM_I_MAKINUM (rr
);
1732 else if (SCM_BIGP (y
))
1734 SCM r
= scm_i_mkbig ();
1735 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1738 scm_remember_upto_here_2 (x
, y
);
1739 return scm_i_normbig (r
);
1741 else if (SCM_REALP (y
))
1742 return scm_i_inexact_ceiling_remainder
1743 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1744 else if (SCM_FRACTIONP (y
))
1745 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1747 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1748 s_scm_ceiling_remainder
);
1750 else if (SCM_REALP (x
))
1752 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1753 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1754 return scm_i_inexact_ceiling_remainder
1755 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1757 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1758 s_scm_ceiling_remainder
);
1760 else if (SCM_FRACTIONP (x
))
1763 return scm_i_inexact_ceiling_remainder
1764 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1765 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1766 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1768 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1769 s_scm_ceiling_remainder
);
1772 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1773 s_scm_ceiling_remainder
);
1778 scm_i_inexact_ceiling_remainder (double x
, double y
)
1780 /* Although it would be more efficient to use fmod here, we can't
1781 because it would in some cases produce results inconsistent with
1782 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1783 close). In particular, when x is very close to a multiple of y,
1784 then r might be either 0.0 or -y, but those two cases must
1785 correspond to different choices of q. If r = 0.0 then q must be
1786 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1787 and remainder chooses the other, it would be bad. */
1788 if (SCM_UNLIKELY (y
== 0))
1789 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1791 return scm_from_double (x
- y
* ceil (x
/ y
));
1795 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1797 SCM xd
= scm_denominator (x
);
1798 SCM yd
= scm_denominator (y
);
1799 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1800 scm_product (scm_numerator (y
), xd
));
1801 return scm_divide (r1
, scm_product (xd
, yd
));
1804 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1806 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1809 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1811 "Return the integer @var{q} and the real number @var{r}\n"
1812 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1813 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1815 "(ceiling/ 123 10) @result{} 13 and -7\n"
1816 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1817 "(ceiling/ -123 10) @result{} -12 and -3\n"
1818 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1819 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1820 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1822 #define FUNC_NAME s_scm_i_ceiling_divide
1826 scm_ceiling_divide(x
, y
, &q
, &r
);
1827 return scm_values (scm_list_2 (q
, r
));
1831 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1832 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1835 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1837 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1839 scm_t_inum xx
= SCM_I_INUM (x
);
1840 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1842 scm_t_inum yy
= SCM_I_INUM (y
);
1843 if (SCM_UNLIKELY (yy
== 0))
1844 scm_num_overflow (s_scm_ceiling_divide
);
1847 scm_t_inum qq
= xx
/ yy
;
1848 scm_t_inum rr
= xx
% yy
;
1849 int needs_adjustment
;
1851 if (SCM_LIKELY (yy
> 0))
1852 needs_adjustment
= (rr
> 0);
1854 needs_adjustment
= (rr
< 0);
1856 if (needs_adjustment
)
1861 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1862 *qp
= SCM_I_MAKINUM (qq
);
1864 *qp
= scm_i_inum2big (qq
);
1865 *rp
= SCM_I_MAKINUM (rr
);
1869 else if (SCM_BIGP (y
))
1871 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1872 scm_remember_upto_here_1 (y
);
1873 if (SCM_LIKELY (sign
> 0))
1875 if (SCM_LIKELY (xx
> 0))
1877 SCM r
= scm_i_mkbig ();
1878 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1879 scm_remember_upto_here_1 (y
);
1880 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1882 *rp
= scm_i_normbig (r
);
1884 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1885 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1886 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1888 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1889 scm_remember_upto_here_1 (y
);
1890 *qp
= SCM_I_MAKINUM (-1);
1906 SCM r
= scm_i_mkbig ();
1907 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1908 scm_remember_upto_here_1 (y
);
1909 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1911 *rp
= scm_i_normbig (r
);
1915 else if (SCM_REALP (y
))
1916 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1917 else if (SCM_FRACTIONP (y
))
1918 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1920 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1921 s_scm_ceiling_divide
, qp
, rp
);
1923 else if (SCM_BIGP (x
))
1925 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1927 scm_t_inum yy
= SCM_I_INUM (y
);
1928 if (SCM_UNLIKELY (yy
== 0))
1929 scm_num_overflow (s_scm_ceiling_divide
);
1932 SCM q
= scm_i_mkbig ();
1933 SCM r
= scm_i_mkbig ();
1935 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1936 SCM_I_BIG_MPZ (x
), yy
);
1939 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1940 SCM_I_BIG_MPZ (x
), -yy
);
1941 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1943 scm_remember_upto_here_1 (x
);
1944 *qp
= scm_i_normbig (q
);
1945 *rp
= scm_i_normbig (r
);
1949 else if (SCM_BIGP (y
))
1951 SCM q
= scm_i_mkbig ();
1952 SCM r
= scm_i_mkbig ();
1953 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1954 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1955 scm_remember_upto_here_2 (x
, y
);
1956 *qp
= scm_i_normbig (q
);
1957 *rp
= scm_i_normbig (r
);
1960 else if (SCM_REALP (y
))
1961 return scm_i_inexact_ceiling_divide
1962 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1963 else if (SCM_FRACTIONP (y
))
1964 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1966 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1967 s_scm_ceiling_divide
, qp
, rp
);
1969 else if (SCM_REALP (x
))
1971 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1972 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1973 return scm_i_inexact_ceiling_divide
1974 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1976 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1977 s_scm_ceiling_divide
, qp
, rp
);
1979 else if (SCM_FRACTIONP (x
))
1982 return scm_i_inexact_ceiling_divide
1983 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1984 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1985 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1987 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1988 s_scm_ceiling_divide
, qp
, rp
);
1991 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
1992 s_scm_ceiling_divide
, qp
, rp
);
1996 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1998 if (SCM_UNLIKELY (y
== 0))
1999 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2002 double q
= ceil (x
/ y
);
2003 double r
= x
- q
* y
;
2004 *qp
= scm_from_double (q
);
2005 *rp
= scm_from_double (r
);
2010 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2013 SCM xd
= scm_denominator (x
);
2014 SCM yd
= scm_denominator (y
);
2016 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2017 scm_product (scm_numerator (y
), xd
),
2019 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2022 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2023 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2025 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2027 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2029 "(truncate-quotient 123 10) @result{} 12\n"
2030 "(truncate-quotient 123 -10) @result{} -12\n"
2031 "(truncate-quotient -123 10) @result{} -12\n"
2032 "(truncate-quotient -123 -10) @result{} 12\n"
2033 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2034 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2036 #define FUNC_NAME s_scm_truncate_quotient
2038 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2040 scm_t_inum xx
= SCM_I_INUM (x
);
2041 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2043 scm_t_inum yy
= SCM_I_INUM (y
);
2044 if (SCM_UNLIKELY (yy
== 0))
2045 scm_num_overflow (s_scm_truncate_quotient
);
2048 scm_t_inum qq
= xx
/ yy
;
2049 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2050 return SCM_I_MAKINUM (qq
);
2052 return scm_i_inum2big (qq
);
2055 else if (SCM_BIGP (y
))
2057 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2058 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2059 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2061 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2062 scm_remember_upto_here_1 (y
);
2063 return SCM_I_MAKINUM (-1);
2068 else if (SCM_REALP (y
))
2069 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2070 else if (SCM_FRACTIONP (y
))
2071 return scm_i_exact_rational_truncate_quotient (x
, y
);
2073 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2074 s_scm_truncate_quotient
);
2076 else if (SCM_BIGP (x
))
2078 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2080 scm_t_inum yy
= SCM_I_INUM (y
);
2081 if (SCM_UNLIKELY (yy
== 0))
2082 scm_num_overflow (s_scm_truncate_quotient
);
2083 else if (SCM_UNLIKELY (yy
== 1))
2087 SCM q
= scm_i_mkbig ();
2089 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2092 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2093 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2095 scm_remember_upto_here_1 (x
);
2096 return scm_i_normbig (q
);
2099 else if (SCM_BIGP (y
))
2101 SCM q
= scm_i_mkbig ();
2102 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2105 scm_remember_upto_here_2 (x
, y
);
2106 return scm_i_normbig (q
);
2108 else if (SCM_REALP (y
))
2109 return scm_i_inexact_truncate_quotient
2110 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2111 else if (SCM_FRACTIONP (y
))
2112 return scm_i_exact_rational_truncate_quotient (x
, y
);
2114 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2115 s_scm_truncate_quotient
);
2117 else if (SCM_REALP (x
))
2119 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2120 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2121 return scm_i_inexact_truncate_quotient
2122 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2124 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2125 s_scm_truncate_quotient
);
2127 else if (SCM_FRACTIONP (x
))
2130 return scm_i_inexact_truncate_quotient
2131 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2132 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2133 return scm_i_exact_rational_truncate_quotient (x
, y
);
2135 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2136 s_scm_truncate_quotient
);
2139 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2140 s_scm_truncate_quotient
);
2145 scm_i_inexact_truncate_quotient (double x
, double y
)
2147 if (SCM_UNLIKELY (y
== 0))
2148 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2150 return scm_from_double (trunc (x
/ y
));
2154 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2156 return scm_truncate_quotient
2157 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2158 scm_product (scm_numerator (y
), scm_denominator (x
)));
2161 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2162 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2164 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2166 "Return the real number @var{r} such that\n"
2167 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2168 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2170 "(truncate-remainder 123 10) @result{} 3\n"
2171 "(truncate-remainder 123 -10) @result{} 3\n"
2172 "(truncate-remainder -123 10) @result{} -3\n"
2173 "(truncate-remainder -123 -10) @result{} -3\n"
2174 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2175 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2177 #define FUNC_NAME s_scm_truncate_remainder
2179 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2181 scm_t_inum xx
= SCM_I_INUM (x
);
2182 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2184 scm_t_inum yy
= SCM_I_INUM (y
);
2185 if (SCM_UNLIKELY (yy
== 0))
2186 scm_num_overflow (s_scm_truncate_remainder
);
2188 return SCM_I_MAKINUM (xx
% yy
);
2190 else if (SCM_BIGP (y
))
2192 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2193 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2194 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2196 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2197 scm_remember_upto_here_1 (y
);
2203 else if (SCM_REALP (y
))
2204 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2205 else if (SCM_FRACTIONP (y
))
2206 return scm_i_exact_rational_truncate_remainder (x
, y
);
2208 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2209 s_scm_truncate_remainder
);
2211 else if (SCM_BIGP (x
))
2213 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2215 scm_t_inum yy
= SCM_I_INUM (y
);
2216 if (SCM_UNLIKELY (yy
== 0))
2217 scm_num_overflow (s_scm_truncate_remainder
);
2220 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2221 (yy
> 0) ? yy
: -yy
)
2222 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2223 scm_remember_upto_here_1 (x
);
2224 return SCM_I_MAKINUM (rr
);
2227 else if (SCM_BIGP (y
))
2229 SCM r
= scm_i_mkbig ();
2230 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2233 scm_remember_upto_here_2 (x
, y
);
2234 return scm_i_normbig (r
);
2236 else if (SCM_REALP (y
))
2237 return scm_i_inexact_truncate_remainder
2238 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2239 else if (SCM_FRACTIONP (y
))
2240 return scm_i_exact_rational_truncate_remainder (x
, y
);
2242 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2243 s_scm_truncate_remainder
);
2245 else if (SCM_REALP (x
))
2247 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2248 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2249 return scm_i_inexact_truncate_remainder
2250 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2252 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2253 s_scm_truncate_remainder
);
2255 else if (SCM_FRACTIONP (x
))
2258 return scm_i_inexact_truncate_remainder
2259 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2260 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2261 return scm_i_exact_rational_truncate_remainder (x
, y
);
2263 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2264 s_scm_truncate_remainder
);
2267 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2268 s_scm_truncate_remainder
);
2273 scm_i_inexact_truncate_remainder (double x
, double y
)
2275 /* Although it would be more efficient to use fmod here, we can't
2276 because it would in some cases produce results inconsistent with
2277 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2278 close). In particular, when x is very close to a multiple of y,
2279 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2280 correspond to different choices of q. If quotient chooses one and
2281 remainder chooses the other, it would be bad. */
2282 if (SCM_UNLIKELY (y
== 0))
2283 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2285 return scm_from_double (x
- y
* trunc (x
/ y
));
2289 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2291 SCM xd
= scm_denominator (x
);
2292 SCM yd
= scm_denominator (y
);
2293 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2294 scm_product (scm_numerator (y
), xd
));
2295 return scm_divide (r1
, scm_product (xd
, yd
));
2299 static void scm_i_inexact_truncate_divide (double x
, double y
,
2301 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2304 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2306 "Return the integer @var{q} and the real number @var{r}\n"
2307 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2308 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2310 "(truncate/ 123 10) @result{} 12 and 3\n"
2311 "(truncate/ 123 -10) @result{} -12 and 3\n"
2312 "(truncate/ -123 10) @result{} -12 and -3\n"
2313 "(truncate/ -123 -10) @result{} 12 and -3\n"
2314 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2315 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2317 #define FUNC_NAME s_scm_i_truncate_divide
2321 scm_truncate_divide(x
, y
, &q
, &r
);
2322 return scm_values (scm_list_2 (q
, r
));
2326 #define s_scm_truncate_divide s_scm_i_truncate_divide
2327 #define g_scm_truncate_divide g_scm_i_truncate_divide
2330 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2332 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2334 scm_t_inum xx
= SCM_I_INUM (x
);
2335 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2337 scm_t_inum yy
= SCM_I_INUM (y
);
2338 if (SCM_UNLIKELY (yy
== 0))
2339 scm_num_overflow (s_scm_truncate_divide
);
2342 scm_t_inum qq
= xx
/ yy
;
2343 scm_t_inum rr
= xx
% yy
;
2344 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2345 *qp
= SCM_I_MAKINUM (qq
);
2347 *qp
= scm_i_inum2big (qq
);
2348 *rp
= SCM_I_MAKINUM (rr
);
2352 else if (SCM_BIGP (y
))
2354 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2355 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2356 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2358 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2359 scm_remember_upto_here_1 (y
);
2360 *qp
= SCM_I_MAKINUM (-1);
2370 else if (SCM_REALP (y
))
2371 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2372 else if (SCM_FRACTIONP (y
))
2373 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2375 return two_valued_wta_dispatch_2
2376 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2377 s_scm_truncate_divide
, qp
, rp
);
2379 else if (SCM_BIGP (x
))
2381 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2383 scm_t_inum yy
= SCM_I_INUM (y
);
2384 if (SCM_UNLIKELY (yy
== 0))
2385 scm_num_overflow (s_scm_truncate_divide
);
2388 SCM q
= scm_i_mkbig ();
2391 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2392 SCM_I_BIG_MPZ (x
), yy
);
2395 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2396 SCM_I_BIG_MPZ (x
), -yy
);
2397 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2399 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2400 scm_remember_upto_here_1 (x
);
2401 *qp
= scm_i_normbig (q
);
2402 *rp
= SCM_I_MAKINUM (rr
);
2406 else if (SCM_BIGP (y
))
2408 SCM q
= scm_i_mkbig ();
2409 SCM r
= scm_i_mkbig ();
2410 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2411 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2412 scm_remember_upto_here_2 (x
, y
);
2413 *qp
= scm_i_normbig (q
);
2414 *rp
= scm_i_normbig (r
);
2416 else if (SCM_REALP (y
))
2417 return scm_i_inexact_truncate_divide
2418 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2419 else if (SCM_FRACTIONP (y
))
2420 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2422 return two_valued_wta_dispatch_2
2423 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2424 s_scm_truncate_divide
, qp
, rp
);
2426 else if (SCM_REALP (x
))
2428 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2429 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2430 return scm_i_inexact_truncate_divide
2431 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2433 return two_valued_wta_dispatch_2
2434 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2435 s_scm_truncate_divide
, qp
, rp
);
2437 else if (SCM_FRACTIONP (x
))
2440 return scm_i_inexact_truncate_divide
2441 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2442 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2443 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2445 return two_valued_wta_dispatch_2
2446 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2447 s_scm_truncate_divide
, qp
, rp
);
2450 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2451 s_scm_truncate_divide
, qp
, rp
);
2455 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2457 if (SCM_UNLIKELY (y
== 0))
2458 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2461 double q
= trunc (x
/ y
);
2462 double r
= x
- q
* y
;
2463 *qp
= scm_from_double (q
);
2464 *rp
= scm_from_double (r
);
2469 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2472 SCM xd
= scm_denominator (x
);
2473 SCM yd
= scm_denominator (y
);
2475 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2476 scm_product (scm_numerator (y
), xd
),
2478 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2481 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2482 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2483 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2485 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2487 "Return the integer @var{q} such that\n"
2488 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2489 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2491 "(centered-quotient 123 10) @result{} 12\n"
2492 "(centered-quotient 123 -10) @result{} -12\n"
2493 "(centered-quotient -123 10) @result{} -12\n"
2494 "(centered-quotient -123 -10) @result{} 12\n"
2495 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2496 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2498 #define FUNC_NAME s_scm_centered_quotient
2500 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2502 scm_t_inum xx
= SCM_I_INUM (x
);
2503 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2505 scm_t_inum yy
= SCM_I_INUM (y
);
2506 if (SCM_UNLIKELY (yy
== 0))
2507 scm_num_overflow (s_scm_centered_quotient
);
2510 scm_t_inum qq
= xx
/ yy
;
2511 scm_t_inum rr
= xx
% yy
;
2512 if (SCM_LIKELY (xx
> 0))
2514 if (SCM_LIKELY (yy
> 0))
2516 if (rr
>= (yy
+ 1) / 2)
2521 if (rr
>= (1 - yy
) / 2)
2527 if (SCM_LIKELY (yy
> 0))
2538 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2539 return SCM_I_MAKINUM (qq
);
2541 return scm_i_inum2big (qq
);
2544 else if (SCM_BIGP (y
))
2546 /* Pass a denormalized bignum version of x (even though it
2547 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2548 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2550 else if (SCM_REALP (y
))
2551 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2552 else if (SCM_FRACTIONP (y
))
2553 return scm_i_exact_rational_centered_quotient (x
, y
);
2555 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2556 s_scm_centered_quotient
);
2558 else if (SCM_BIGP (x
))
2560 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2562 scm_t_inum yy
= SCM_I_INUM (y
);
2563 if (SCM_UNLIKELY (yy
== 0))
2564 scm_num_overflow (s_scm_centered_quotient
);
2565 else if (SCM_UNLIKELY (yy
== 1))
2569 SCM q
= scm_i_mkbig ();
2571 /* Arrange for rr to initially be non-positive,
2572 because that simplifies the test to see
2573 if it is within the needed bounds. */
2576 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2577 SCM_I_BIG_MPZ (x
), yy
);
2578 scm_remember_upto_here_1 (x
);
2580 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2581 SCM_I_BIG_MPZ (q
), 1);
2585 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2586 SCM_I_BIG_MPZ (x
), -yy
);
2587 scm_remember_upto_here_1 (x
);
2588 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2590 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2591 SCM_I_BIG_MPZ (q
), 1);
2593 return scm_i_normbig (q
);
2596 else if (SCM_BIGP (y
))
2597 return scm_i_bigint_centered_quotient (x
, y
);
2598 else if (SCM_REALP (y
))
2599 return scm_i_inexact_centered_quotient
2600 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2601 else if (SCM_FRACTIONP (y
))
2602 return scm_i_exact_rational_centered_quotient (x
, y
);
2604 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2605 s_scm_centered_quotient
);
2607 else if (SCM_REALP (x
))
2609 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2610 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2611 return scm_i_inexact_centered_quotient
2612 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2614 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2615 s_scm_centered_quotient
);
2617 else if (SCM_FRACTIONP (x
))
2620 return scm_i_inexact_centered_quotient
2621 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2622 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2623 return scm_i_exact_rational_centered_quotient (x
, y
);
2625 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2626 s_scm_centered_quotient
);
2629 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2630 s_scm_centered_quotient
);
2635 scm_i_inexact_centered_quotient (double x
, double y
)
2637 if (SCM_LIKELY (y
> 0))
2638 return scm_from_double (floor (x
/y
+ 0.5));
2639 else if (SCM_LIKELY (y
< 0))
2640 return scm_from_double (ceil (x
/y
- 0.5));
2642 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2647 /* Assumes that both x and y are bigints, though
2648 x might be able to fit into a fixnum. */
2650 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2654 /* Note that x might be small enough to fit into a
2655 fixnum, so we must not let it escape into the wild */
2659 /* min_r will eventually become -abs(y)/2 */
2660 min_r
= scm_i_mkbig ();
2661 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2662 SCM_I_BIG_MPZ (y
), 1);
2664 /* Arrange for rr to initially be non-positive,
2665 because that simplifies the test to see
2666 if it is within the needed bounds. */
2667 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2669 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2670 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2671 scm_remember_upto_here_2 (x
, y
);
2672 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2673 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2674 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2675 SCM_I_BIG_MPZ (q
), 1);
2679 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2680 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2681 scm_remember_upto_here_2 (x
, y
);
2682 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2683 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2684 SCM_I_BIG_MPZ (q
), 1);
2686 scm_remember_upto_here_2 (r
, min_r
);
2687 return scm_i_normbig (q
);
2691 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2693 return scm_centered_quotient
2694 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2695 scm_product (scm_numerator (y
), scm_denominator (x
)));
2698 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2699 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2700 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2702 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2704 "Return the real number @var{r} such that\n"
2705 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2706 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2707 "for some integer @var{q}.\n"
2709 "(centered-remainder 123 10) @result{} 3\n"
2710 "(centered-remainder 123 -10) @result{} 3\n"
2711 "(centered-remainder -123 10) @result{} -3\n"
2712 "(centered-remainder -123 -10) @result{} -3\n"
2713 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2714 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2716 #define FUNC_NAME s_scm_centered_remainder
2718 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2720 scm_t_inum xx
= SCM_I_INUM (x
);
2721 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2723 scm_t_inum yy
= SCM_I_INUM (y
);
2724 if (SCM_UNLIKELY (yy
== 0))
2725 scm_num_overflow (s_scm_centered_remainder
);
2728 scm_t_inum rr
= xx
% yy
;
2729 if (SCM_LIKELY (xx
> 0))
2731 if (SCM_LIKELY (yy
> 0))
2733 if (rr
>= (yy
+ 1) / 2)
2738 if (rr
>= (1 - yy
) / 2)
2744 if (SCM_LIKELY (yy
> 0))
2755 return SCM_I_MAKINUM (rr
);
2758 else if (SCM_BIGP (y
))
2760 /* Pass a denormalized bignum version of x (even though it
2761 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2762 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2764 else if (SCM_REALP (y
))
2765 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2766 else if (SCM_FRACTIONP (y
))
2767 return scm_i_exact_rational_centered_remainder (x
, y
);
2769 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2770 s_scm_centered_remainder
);
2772 else if (SCM_BIGP (x
))
2774 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2776 scm_t_inum yy
= SCM_I_INUM (y
);
2777 if (SCM_UNLIKELY (yy
== 0))
2778 scm_num_overflow (s_scm_centered_remainder
);
2782 /* Arrange for rr to initially be non-positive,
2783 because that simplifies the test to see
2784 if it is within the needed bounds. */
2787 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2788 scm_remember_upto_here_1 (x
);
2794 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2795 scm_remember_upto_here_1 (x
);
2799 return SCM_I_MAKINUM (rr
);
2802 else if (SCM_BIGP (y
))
2803 return scm_i_bigint_centered_remainder (x
, y
);
2804 else if (SCM_REALP (y
))
2805 return scm_i_inexact_centered_remainder
2806 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2807 else if (SCM_FRACTIONP (y
))
2808 return scm_i_exact_rational_centered_remainder (x
, y
);
2810 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2811 s_scm_centered_remainder
);
2813 else if (SCM_REALP (x
))
2815 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2816 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2817 return scm_i_inexact_centered_remainder
2818 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2820 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2821 s_scm_centered_remainder
);
2823 else if (SCM_FRACTIONP (x
))
2826 return scm_i_inexact_centered_remainder
2827 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2828 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2829 return scm_i_exact_rational_centered_remainder (x
, y
);
2831 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2832 s_scm_centered_remainder
);
2835 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2836 s_scm_centered_remainder
);
2841 scm_i_inexact_centered_remainder (double x
, double y
)
2845 /* Although it would be more efficient to use fmod here, we can't
2846 because it would in some cases produce results inconsistent with
2847 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2848 close). In particular, when x-y/2 is very close to a multiple of
2849 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2850 two cases must correspond to different choices of q. If quotient
2851 chooses one and remainder chooses the other, it would be bad. */
2852 if (SCM_LIKELY (y
> 0))
2853 q
= floor (x
/y
+ 0.5);
2854 else if (SCM_LIKELY (y
< 0))
2855 q
= ceil (x
/y
- 0.5);
2857 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2860 return scm_from_double (x
- q
* y
);
2863 /* Assumes that both x and y are bigints, though
2864 x might be able to fit into a fixnum. */
2866 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2870 /* Note that x might be small enough to fit into a
2871 fixnum, so we must not let it escape into the wild */
2874 /* min_r will eventually become -abs(y)/2 */
2875 min_r
= scm_i_mkbig ();
2876 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2877 SCM_I_BIG_MPZ (y
), 1);
2879 /* Arrange for rr to initially be non-positive,
2880 because that simplifies the test to see
2881 if it is within the needed bounds. */
2882 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2884 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2885 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2886 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2887 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2888 mpz_add (SCM_I_BIG_MPZ (r
),
2894 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2895 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2896 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2897 mpz_sub (SCM_I_BIG_MPZ (r
),
2901 scm_remember_upto_here_2 (x
, y
);
2902 return scm_i_normbig (r
);
2906 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2908 SCM xd
= scm_denominator (x
);
2909 SCM yd
= scm_denominator (y
);
2910 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2911 scm_product (scm_numerator (y
), xd
));
2912 return scm_divide (r1
, scm_product (xd
, yd
));
2916 static void scm_i_inexact_centered_divide (double x
, double y
,
2918 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2919 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2922 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2924 "Return the integer @var{q} and the real number @var{r}\n"
2925 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2926 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2928 "(centered/ 123 10) @result{} 12 and 3\n"
2929 "(centered/ 123 -10) @result{} -12 and 3\n"
2930 "(centered/ -123 10) @result{} -12 and -3\n"
2931 "(centered/ -123 -10) @result{} 12 and -3\n"
2932 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2933 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2935 #define FUNC_NAME s_scm_i_centered_divide
2939 scm_centered_divide(x
, y
, &q
, &r
);
2940 return scm_values (scm_list_2 (q
, r
));
2944 #define s_scm_centered_divide s_scm_i_centered_divide
2945 #define g_scm_centered_divide g_scm_i_centered_divide
2948 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2950 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2952 scm_t_inum xx
= SCM_I_INUM (x
);
2953 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2955 scm_t_inum yy
= SCM_I_INUM (y
);
2956 if (SCM_UNLIKELY (yy
== 0))
2957 scm_num_overflow (s_scm_centered_divide
);
2960 scm_t_inum qq
= xx
/ yy
;
2961 scm_t_inum rr
= xx
% yy
;
2962 if (SCM_LIKELY (xx
> 0))
2964 if (SCM_LIKELY (yy
> 0))
2966 if (rr
>= (yy
+ 1) / 2)
2971 if (rr
>= (1 - yy
) / 2)
2977 if (SCM_LIKELY (yy
> 0))
2988 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2989 *qp
= SCM_I_MAKINUM (qq
);
2991 *qp
= scm_i_inum2big (qq
);
2992 *rp
= SCM_I_MAKINUM (rr
);
2996 else if (SCM_BIGP (y
))
2998 /* Pass a denormalized bignum version of x (even though it
2999 can fit in a fixnum) to scm_i_bigint_centered_divide */
3000 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3002 else if (SCM_REALP (y
))
3003 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3004 else if (SCM_FRACTIONP (y
))
3005 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3007 return two_valued_wta_dispatch_2
3008 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3009 s_scm_centered_divide
, qp
, rp
);
3011 else if (SCM_BIGP (x
))
3013 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3015 scm_t_inum yy
= SCM_I_INUM (y
);
3016 if (SCM_UNLIKELY (yy
== 0))
3017 scm_num_overflow (s_scm_centered_divide
);
3020 SCM q
= scm_i_mkbig ();
3022 /* Arrange for rr to initially be non-positive,
3023 because that simplifies the test to see
3024 if it is within the needed bounds. */
3027 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3028 SCM_I_BIG_MPZ (x
), yy
);
3029 scm_remember_upto_here_1 (x
);
3032 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3033 SCM_I_BIG_MPZ (q
), 1);
3039 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3040 SCM_I_BIG_MPZ (x
), -yy
);
3041 scm_remember_upto_here_1 (x
);
3042 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3045 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3046 SCM_I_BIG_MPZ (q
), 1);
3050 *qp
= scm_i_normbig (q
);
3051 *rp
= SCM_I_MAKINUM (rr
);
3055 else if (SCM_BIGP (y
))
3056 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3057 else if (SCM_REALP (y
))
3058 return scm_i_inexact_centered_divide
3059 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3060 else if (SCM_FRACTIONP (y
))
3061 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3063 return two_valued_wta_dispatch_2
3064 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3065 s_scm_centered_divide
, qp
, rp
);
3067 else if (SCM_REALP (x
))
3069 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3070 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3071 return scm_i_inexact_centered_divide
3072 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3074 return two_valued_wta_dispatch_2
3075 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3076 s_scm_centered_divide
, qp
, rp
);
3078 else if (SCM_FRACTIONP (x
))
3081 return scm_i_inexact_centered_divide
3082 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3083 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3084 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3086 return two_valued_wta_dispatch_2
3087 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3088 s_scm_centered_divide
, qp
, rp
);
3091 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3092 s_scm_centered_divide
, qp
, rp
);
3096 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3100 if (SCM_LIKELY (y
> 0))
3101 q
= floor (x
/y
+ 0.5);
3102 else if (SCM_LIKELY (y
< 0))
3103 q
= ceil (x
/y
- 0.5);
3105 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3109 *qp
= scm_from_double (q
);
3110 *rp
= scm_from_double (r
);
3113 /* Assumes that both x and y are bigints, though
3114 x might be able to fit into a fixnum. */
3116 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3120 /* Note that x might be small enough to fit into a
3121 fixnum, so we must not let it escape into the wild */
3125 /* min_r will eventually become -abs(y/2) */
3126 min_r
= scm_i_mkbig ();
3127 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3128 SCM_I_BIG_MPZ (y
), 1);
3130 /* Arrange for rr to initially be non-positive,
3131 because that simplifies the test to see
3132 if it is within the needed bounds. */
3133 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3135 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3136 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3137 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3138 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3140 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3141 SCM_I_BIG_MPZ (q
), 1);
3142 mpz_add (SCM_I_BIG_MPZ (r
),
3149 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3150 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3151 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3153 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3154 SCM_I_BIG_MPZ (q
), 1);
3155 mpz_sub (SCM_I_BIG_MPZ (r
),
3160 scm_remember_upto_here_2 (x
, y
);
3161 *qp
= scm_i_normbig (q
);
3162 *rp
= scm_i_normbig (r
);
3166 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3169 SCM xd
= scm_denominator (x
);
3170 SCM yd
= scm_denominator (y
);
3172 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3173 scm_product (scm_numerator (y
), xd
),
3175 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3178 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3179 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3180 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3182 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3184 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3185 "with ties going to the nearest even integer.\n"
3187 "(round-quotient 123 10) @result{} 12\n"
3188 "(round-quotient 123 -10) @result{} -12\n"
3189 "(round-quotient -123 10) @result{} -12\n"
3190 "(round-quotient -123 -10) @result{} 12\n"
3191 "(round-quotient 125 10) @result{} 12\n"
3192 "(round-quotient 127 10) @result{} 13\n"
3193 "(round-quotient 135 10) @result{} 14\n"
3194 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3195 "(round-quotient 16/3 -10/7) @result{} -4\n"
3197 #define FUNC_NAME s_scm_round_quotient
3199 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3201 scm_t_inum xx
= SCM_I_INUM (x
);
3202 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3204 scm_t_inum yy
= SCM_I_INUM (y
);
3205 if (SCM_UNLIKELY (yy
== 0))
3206 scm_num_overflow (s_scm_round_quotient
);
3209 scm_t_inum qq
= xx
/ yy
;
3210 scm_t_inum rr
= xx
% yy
;
3212 scm_t_inum r2
= 2 * rr
;
3214 if (SCM_LIKELY (yy
< 0))
3234 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3235 return SCM_I_MAKINUM (qq
);
3237 return scm_i_inum2big (qq
);
3240 else if (SCM_BIGP (y
))
3242 /* Pass a denormalized bignum version of x (even though it
3243 can fit in a fixnum) to scm_i_bigint_round_quotient */
3244 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3246 else if (SCM_REALP (y
))
3247 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3248 else if (SCM_FRACTIONP (y
))
3249 return scm_i_exact_rational_round_quotient (x
, y
);
3251 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3252 s_scm_round_quotient
);
3254 else if (SCM_BIGP (x
))
3256 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3258 scm_t_inum yy
= SCM_I_INUM (y
);
3259 if (SCM_UNLIKELY (yy
== 0))
3260 scm_num_overflow (s_scm_round_quotient
);
3261 else if (SCM_UNLIKELY (yy
== 1))
3265 SCM q
= scm_i_mkbig ();
3267 int needs_adjustment
;
3271 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3272 SCM_I_BIG_MPZ (x
), yy
);
3273 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3274 needs_adjustment
= (2*rr
>= yy
);
3276 needs_adjustment
= (2*rr
> yy
);
3280 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3281 SCM_I_BIG_MPZ (x
), -yy
);
3282 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3283 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3284 needs_adjustment
= (2*rr
<= yy
);
3286 needs_adjustment
= (2*rr
< yy
);
3288 scm_remember_upto_here_1 (x
);
3289 if (needs_adjustment
)
3290 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3291 return scm_i_normbig (q
);
3294 else if (SCM_BIGP (y
))
3295 return scm_i_bigint_round_quotient (x
, y
);
3296 else if (SCM_REALP (y
))
3297 return scm_i_inexact_round_quotient
3298 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3299 else if (SCM_FRACTIONP (y
))
3300 return scm_i_exact_rational_round_quotient (x
, y
);
3302 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3303 s_scm_round_quotient
);
3305 else if (SCM_REALP (x
))
3307 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3308 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3309 return scm_i_inexact_round_quotient
3310 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3312 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3313 s_scm_round_quotient
);
3315 else if (SCM_FRACTIONP (x
))
3318 return scm_i_inexact_round_quotient
3319 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3320 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3321 return scm_i_exact_rational_round_quotient (x
, y
);
3323 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3324 s_scm_round_quotient
);
3327 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3328 s_scm_round_quotient
);
3333 scm_i_inexact_round_quotient (double x
, double y
)
3335 if (SCM_UNLIKELY (y
== 0))
3336 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3338 return scm_from_double (scm_c_round (x
/ y
));
3341 /* Assumes that both x and y are bigints, though
3342 x might be able to fit into a fixnum. */
3344 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3347 int cmp
, needs_adjustment
;
3349 /* Note that x might be small enough to fit into a
3350 fixnum, so we must not let it escape into the wild */
3353 r2
= scm_i_mkbig ();
3355 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3356 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3357 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3358 scm_remember_upto_here_2 (x
, r
);
3360 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3361 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3362 needs_adjustment
= (cmp
>= 0);
3364 needs_adjustment
= (cmp
> 0);
3365 scm_remember_upto_here_2 (r2
, y
);
3367 if (needs_adjustment
)
3368 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3370 return scm_i_normbig (q
);
3374 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3376 return scm_round_quotient
3377 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3378 scm_product (scm_numerator (y
), scm_denominator (x
)));
3381 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3382 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3383 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3385 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3387 "Return the real number @var{r} such that\n"
3388 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3389 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3390 "nearest integer, with ties going to the nearest\n"
3393 "(round-remainder 123 10) @result{} 3\n"
3394 "(round-remainder 123 -10) @result{} 3\n"
3395 "(round-remainder -123 10) @result{} -3\n"
3396 "(round-remainder -123 -10) @result{} -3\n"
3397 "(round-remainder 125 10) @result{} 5\n"
3398 "(round-remainder 127 10) @result{} -3\n"
3399 "(round-remainder 135 10) @result{} -5\n"
3400 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3401 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3403 #define FUNC_NAME s_scm_round_remainder
3405 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3407 scm_t_inum xx
= SCM_I_INUM (x
);
3408 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3410 scm_t_inum yy
= SCM_I_INUM (y
);
3411 if (SCM_UNLIKELY (yy
== 0))
3412 scm_num_overflow (s_scm_round_remainder
);
3415 scm_t_inum qq
= xx
/ yy
;
3416 scm_t_inum rr
= xx
% yy
;
3418 scm_t_inum r2
= 2 * rr
;
3420 if (SCM_LIKELY (yy
< 0))
3440 return SCM_I_MAKINUM (rr
);
3443 else if (SCM_BIGP (y
))
3445 /* Pass a denormalized bignum version of x (even though it
3446 can fit in a fixnum) to scm_i_bigint_round_remainder */
3447 return scm_i_bigint_round_remainder
3448 (scm_i_long2big (xx
), y
);
3450 else if (SCM_REALP (y
))
3451 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3452 else if (SCM_FRACTIONP (y
))
3453 return scm_i_exact_rational_round_remainder (x
, y
);
3455 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3456 s_scm_round_remainder
);
3458 else if (SCM_BIGP (x
))
3460 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3462 scm_t_inum yy
= SCM_I_INUM (y
);
3463 if (SCM_UNLIKELY (yy
== 0))
3464 scm_num_overflow (s_scm_round_remainder
);
3467 SCM q
= scm_i_mkbig ();
3469 int needs_adjustment
;
3473 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3474 SCM_I_BIG_MPZ (x
), yy
);
3475 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3476 needs_adjustment
= (2*rr
>= yy
);
3478 needs_adjustment
= (2*rr
> yy
);
3482 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3483 SCM_I_BIG_MPZ (x
), -yy
);
3484 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3485 needs_adjustment
= (2*rr
<= yy
);
3487 needs_adjustment
= (2*rr
< yy
);
3489 scm_remember_upto_here_2 (x
, q
);
3490 if (needs_adjustment
)
3492 return SCM_I_MAKINUM (rr
);
3495 else if (SCM_BIGP (y
))
3496 return scm_i_bigint_round_remainder (x
, y
);
3497 else if (SCM_REALP (y
))
3498 return scm_i_inexact_round_remainder
3499 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3500 else if (SCM_FRACTIONP (y
))
3501 return scm_i_exact_rational_round_remainder (x
, y
);
3503 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3504 s_scm_round_remainder
);
3506 else if (SCM_REALP (x
))
3508 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3509 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3510 return scm_i_inexact_round_remainder
3511 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3513 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3514 s_scm_round_remainder
);
3516 else if (SCM_FRACTIONP (x
))
3519 return scm_i_inexact_round_remainder
3520 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3521 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3522 return scm_i_exact_rational_round_remainder (x
, y
);
3524 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3525 s_scm_round_remainder
);
3528 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3529 s_scm_round_remainder
);
3534 scm_i_inexact_round_remainder (double x
, double y
)
3536 /* Although it would be more efficient to use fmod here, we can't
3537 because it would in some cases produce results inconsistent with
3538 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3539 close). In particular, when x-y/2 is very close to a multiple of
3540 y, then r might be either -abs(y/2) or abs(y/2), but those two
3541 cases must correspond to different choices of q. If quotient
3542 chooses one and remainder chooses the other, it would be bad. */
3544 if (SCM_UNLIKELY (y
== 0))
3545 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3548 double q
= scm_c_round (x
/ y
);
3549 return scm_from_double (x
- q
* y
);
3553 /* Assumes that both x and y are bigints, though
3554 x might be able to fit into a fixnum. */
3556 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3559 int cmp
, needs_adjustment
;
3561 /* Note that x might be small enough to fit into a
3562 fixnum, so we must not let it escape into the wild */
3565 r2
= scm_i_mkbig ();
3567 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3568 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3569 scm_remember_upto_here_1 (x
);
3570 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3572 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3573 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3574 needs_adjustment
= (cmp
>= 0);
3576 needs_adjustment
= (cmp
> 0);
3577 scm_remember_upto_here_2 (q
, r2
);
3579 if (needs_adjustment
)
3580 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3582 scm_remember_upto_here_1 (y
);
3583 return scm_i_normbig (r
);
3587 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3589 SCM xd
= scm_denominator (x
);
3590 SCM yd
= scm_denominator (y
);
3591 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3592 scm_product (scm_numerator (y
), xd
));
3593 return scm_divide (r1
, scm_product (xd
, yd
));
3597 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3598 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3599 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3601 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3603 "Return the integer @var{q} and the real number @var{r}\n"
3604 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3605 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3606 "nearest integer, with ties going to the nearest even integer.\n"
3608 "(round/ 123 10) @result{} 12 and 3\n"
3609 "(round/ 123 -10) @result{} -12 and 3\n"
3610 "(round/ -123 10) @result{} -12 and -3\n"
3611 "(round/ -123 -10) @result{} 12 and -3\n"
3612 "(round/ 125 10) @result{} 12 and 5\n"
3613 "(round/ 127 10) @result{} 13 and -3\n"
3614 "(round/ 135 10) @result{} 14 and -5\n"
3615 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3616 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3618 #define FUNC_NAME s_scm_i_round_divide
3622 scm_round_divide(x
, y
, &q
, &r
);
3623 return scm_values (scm_list_2 (q
, r
));
3627 #define s_scm_round_divide s_scm_i_round_divide
3628 #define g_scm_round_divide g_scm_i_round_divide
3631 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3633 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3635 scm_t_inum xx
= SCM_I_INUM (x
);
3636 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3638 scm_t_inum yy
= SCM_I_INUM (y
);
3639 if (SCM_UNLIKELY (yy
== 0))
3640 scm_num_overflow (s_scm_round_divide
);
3643 scm_t_inum qq
= xx
/ yy
;
3644 scm_t_inum rr
= xx
% yy
;
3646 scm_t_inum r2
= 2 * rr
;
3648 if (SCM_LIKELY (yy
< 0))
3668 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3669 *qp
= SCM_I_MAKINUM (qq
);
3671 *qp
= scm_i_inum2big (qq
);
3672 *rp
= SCM_I_MAKINUM (rr
);
3676 else if (SCM_BIGP (y
))
3678 /* Pass a denormalized bignum version of x (even though it
3679 can fit in a fixnum) to scm_i_bigint_round_divide */
3680 return scm_i_bigint_round_divide
3681 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3683 else if (SCM_REALP (y
))
3684 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3685 else if (SCM_FRACTIONP (y
))
3686 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3688 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3689 s_scm_round_divide
, qp
, rp
);
3691 else if (SCM_BIGP (x
))
3693 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3695 scm_t_inum yy
= SCM_I_INUM (y
);
3696 if (SCM_UNLIKELY (yy
== 0))
3697 scm_num_overflow (s_scm_round_divide
);
3700 SCM q
= scm_i_mkbig ();
3702 int needs_adjustment
;
3706 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3707 SCM_I_BIG_MPZ (x
), yy
);
3708 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3709 needs_adjustment
= (2*rr
>= yy
);
3711 needs_adjustment
= (2*rr
> yy
);
3715 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3716 SCM_I_BIG_MPZ (x
), -yy
);
3717 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3718 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3719 needs_adjustment
= (2*rr
<= yy
);
3721 needs_adjustment
= (2*rr
< yy
);
3723 scm_remember_upto_here_1 (x
);
3724 if (needs_adjustment
)
3726 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3729 *qp
= scm_i_normbig (q
);
3730 *rp
= SCM_I_MAKINUM (rr
);
3734 else if (SCM_BIGP (y
))
3735 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3736 else if (SCM_REALP (y
))
3737 return scm_i_inexact_round_divide
3738 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3739 else if (SCM_FRACTIONP (y
))
3740 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3742 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3743 s_scm_round_divide
, qp
, rp
);
3745 else if (SCM_REALP (x
))
3747 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3748 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3749 return scm_i_inexact_round_divide
3750 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3752 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3753 s_scm_round_divide
, qp
, rp
);
3755 else if (SCM_FRACTIONP (x
))
3758 return scm_i_inexact_round_divide
3759 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3760 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3761 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3763 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3764 s_scm_round_divide
, qp
, rp
);
3767 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3768 s_scm_round_divide
, qp
, rp
);
3772 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3774 if (SCM_UNLIKELY (y
== 0))
3775 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3778 double q
= scm_c_round (x
/ y
);
3779 double r
= x
- q
* y
;
3780 *qp
= scm_from_double (q
);
3781 *rp
= scm_from_double (r
);
3785 /* Assumes that both x and y are bigints, though
3786 x might be able to fit into a fixnum. */
3788 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3791 int cmp
, needs_adjustment
;
3793 /* Note that x might be small enough to fit into a
3794 fixnum, so we must not let it escape into the wild */
3797 r2
= scm_i_mkbig ();
3799 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3800 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3801 scm_remember_upto_here_1 (x
);
3802 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3804 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3805 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3806 needs_adjustment
= (cmp
>= 0);
3808 needs_adjustment
= (cmp
> 0);
3810 if (needs_adjustment
)
3812 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3813 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3816 scm_remember_upto_here_2 (r2
, y
);
3817 *qp
= scm_i_normbig (q
);
3818 *rp
= scm_i_normbig (r
);
3822 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3825 SCM xd
= scm_denominator (x
);
3826 SCM yd
= scm_denominator (y
);
3828 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3829 scm_product (scm_numerator (y
), xd
),
3831 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3835 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3836 (SCM x
, SCM y
, SCM rest
),
3837 "Return the greatest common divisor of all parameter values.\n"
3838 "If called without arguments, 0 is returned.")
3839 #define FUNC_NAME s_scm_i_gcd
3841 while (!scm_is_null (rest
))
3842 { x
= scm_gcd (x
, y
);
3844 rest
= scm_cdr (rest
);
3846 return scm_gcd (x
, y
);
3850 #define s_gcd s_scm_i_gcd
3851 #define g_gcd g_scm_i_gcd
3854 scm_gcd (SCM x
, SCM y
)
3857 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3859 if (SCM_I_INUMP (x
))
3861 if (SCM_I_INUMP (y
))
3863 scm_t_inum xx
= SCM_I_INUM (x
);
3864 scm_t_inum yy
= SCM_I_INUM (y
);
3865 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3866 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3876 /* Determine a common factor 2^k */
3877 while (!(1 & (u
| v
)))
3883 /* Now, any factor 2^n can be eliminated */
3903 return (SCM_POSFIXABLE (result
)
3904 ? SCM_I_MAKINUM (result
)
3905 : scm_i_inum2big (result
));
3907 else if (SCM_BIGP (y
))
3913 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3915 else if (SCM_BIGP (x
))
3917 if (SCM_I_INUMP (y
))
3922 yy
= SCM_I_INUM (y
);
3927 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3928 scm_remember_upto_here_1 (x
);
3929 return (SCM_POSFIXABLE (result
)
3930 ? SCM_I_MAKINUM (result
)
3931 : scm_from_unsigned_integer (result
));
3933 else if (SCM_BIGP (y
))
3935 SCM result
= scm_i_mkbig ();
3936 mpz_gcd (SCM_I_BIG_MPZ (result
),
3939 scm_remember_upto_here_2 (x
, y
);
3940 return scm_i_normbig (result
);
3943 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3946 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3949 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3950 (SCM x
, SCM y
, SCM rest
),
3951 "Return the least common multiple of the arguments.\n"
3952 "If called without arguments, 1 is returned.")
3953 #define FUNC_NAME s_scm_i_lcm
3955 while (!scm_is_null (rest
))
3956 { x
= scm_lcm (x
, y
);
3958 rest
= scm_cdr (rest
);
3960 return scm_lcm (x
, y
);
3964 #define s_lcm s_scm_i_lcm
3965 #define g_lcm g_scm_i_lcm
3968 scm_lcm (SCM n1
, SCM n2
)
3970 if (SCM_UNBNDP (n2
))
3972 if (SCM_UNBNDP (n1
))
3973 return SCM_I_MAKINUM (1L);
3974 n2
= SCM_I_MAKINUM (1L);
3977 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
3978 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3979 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
3980 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
3982 if (SCM_I_INUMP (n1
))
3984 if (SCM_I_INUMP (n2
))
3986 SCM d
= scm_gcd (n1
, n2
);
3987 if (scm_is_eq (d
, SCM_INUM0
))
3990 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
3994 /* inum n1, big n2 */
3997 SCM result
= scm_i_mkbig ();
3998 scm_t_inum nn1
= SCM_I_INUM (n1
);
3999 if (nn1
== 0) return SCM_INUM0
;
4000 if (nn1
< 0) nn1
= - nn1
;
4001 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4002 scm_remember_upto_here_1 (n2
);
4010 if (SCM_I_INUMP (n2
))
4017 SCM result
= scm_i_mkbig ();
4018 mpz_lcm(SCM_I_BIG_MPZ (result
),
4020 SCM_I_BIG_MPZ (n2
));
4021 scm_remember_upto_here_2(n1
, n2
);
4022 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4028 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4033 + + + x (map digit:logand X Y)
4034 + - + x (map digit:logand X (lognot (+ -1 Y)))
4035 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4036 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4041 + + + (map digit:logior X Y)
4042 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4043 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4044 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4049 + + + (map digit:logxor X Y)
4050 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4051 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4052 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4057 + + (any digit:logand X Y)
4058 + - (any digit:logand X (lognot (+ -1 Y)))
4059 - + (any digit:logand (lognot (+ -1 X)) Y)
4064 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4065 (SCM x
, SCM y
, SCM rest
),
4066 "Return the bitwise AND of the integer arguments.\n\n"
4068 "(logand) @result{} -1\n"
4069 "(logand 7) @result{} 7\n"
4070 "(logand #b111 #b011 #b001) @result{} 1\n"
4072 #define FUNC_NAME s_scm_i_logand
4074 while (!scm_is_null (rest
))
4075 { x
= scm_logand (x
, y
);
4077 rest
= scm_cdr (rest
);
4079 return scm_logand (x
, y
);
4083 #define s_scm_logand s_scm_i_logand
4085 SCM
scm_logand (SCM n1
, SCM n2
)
4086 #define FUNC_NAME s_scm_logand
4090 if (SCM_UNBNDP (n2
))
4092 if (SCM_UNBNDP (n1
))
4093 return SCM_I_MAKINUM (-1);
4094 else if (!SCM_NUMBERP (n1
))
4095 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4096 else if (SCM_NUMBERP (n1
))
4099 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4102 if (SCM_I_INUMP (n1
))
4104 nn1
= SCM_I_INUM (n1
);
4105 if (SCM_I_INUMP (n2
))
4107 scm_t_inum nn2
= SCM_I_INUM (n2
);
4108 return SCM_I_MAKINUM (nn1
& nn2
);
4110 else if SCM_BIGP (n2
)
4116 SCM result_z
= scm_i_mkbig ();
4118 mpz_init_set_si (nn1_z
, nn1
);
4119 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4120 scm_remember_upto_here_1 (n2
);
4122 return scm_i_normbig (result_z
);
4126 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4128 else if (SCM_BIGP (n1
))
4130 if (SCM_I_INUMP (n2
))
4133 nn1
= SCM_I_INUM (n1
);
4136 else if (SCM_BIGP (n2
))
4138 SCM result_z
= scm_i_mkbig ();
4139 mpz_and (SCM_I_BIG_MPZ (result_z
),
4141 SCM_I_BIG_MPZ (n2
));
4142 scm_remember_upto_here_2 (n1
, n2
);
4143 return scm_i_normbig (result_z
);
4146 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4149 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4154 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4155 (SCM x
, SCM y
, SCM rest
),
4156 "Return the bitwise OR of the integer arguments.\n\n"
4158 "(logior) @result{} 0\n"
4159 "(logior 7) @result{} 7\n"
4160 "(logior #b000 #b001 #b011) @result{} 3\n"
4162 #define FUNC_NAME s_scm_i_logior
4164 while (!scm_is_null (rest
))
4165 { x
= scm_logior (x
, y
);
4167 rest
= scm_cdr (rest
);
4169 return scm_logior (x
, y
);
4173 #define s_scm_logior s_scm_i_logior
4175 SCM
scm_logior (SCM n1
, SCM n2
)
4176 #define FUNC_NAME s_scm_logior
4180 if (SCM_UNBNDP (n2
))
4182 if (SCM_UNBNDP (n1
))
4184 else if (SCM_NUMBERP (n1
))
4187 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4190 if (SCM_I_INUMP (n1
))
4192 nn1
= SCM_I_INUM (n1
);
4193 if (SCM_I_INUMP (n2
))
4195 long nn2
= SCM_I_INUM (n2
);
4196 return SCM_I_MAKINUM (nn1
| nn2
);
4198 else if (SCM_BIGP (n2
))
4204 SCM result_z
= scm_i_mkbig ();
4206 mpz_init_set_si (nn1_z
, nn1
);
4207 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4208 scm_remember_upto_here_1 (n2
);
4210 return scm_i_normbig (result_z
);
4214 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4216 else if (SCM_BIGP (n1
))
4218 if (SCM_I_INUMP (n2
))
4221 nn1
= SCM_I_INUM (n1
);
4224 else if (SCM_BIGP (n2
))
4226 SCM result_z
= scm_i_mkbig ();
4227 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4229 SCM_I_BIG_MPZ (n2
));
4230 scm_remember_upto_here_2 (n1
, n2
);
4231 return scm_i_normbig (result_z
);
4234 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4237 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4242 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4243 (SCM x
, SCM y
, SCM rest
),
4244 "Return the bitwise XOR of the integer arguments. A bit is\n"
4245 "set in the result if it is set in an odd number of arguments.\n"
4247 "(logxor) @result{} 0\n"
4248 "(logxor 7) @result{} 7\n"
4249 "(logxor #b000 #b001 #b011) @result{} 2\n"
4250 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4252 #define FUNC_NAME s_scm_i_logxor
4254 while (!scm_is_null (rest
))
4255 { x
= scm_logxor (x
, y
);
4257 rest
= scm_cdr (rest
);
4259 return scm_logxor (x
, y
);
4263 #define s_scm_logxor s_scm_i_logxor
4265 SCM
scm_logxor (SCM n1
, SCM n2
)
4266 #define FUNC_NAME s_scm_logxor
4270 if (SCM_UNBNDP (n2
))
4272 if (SCM_UNBNDP (n1
))
4274 else if (SCM_NUMBERP (n1
))
4277 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4280 if (SCM_I_INUMP (n1
))
4282 nn1
= SCM_I_INUM (n1
);
4283 if (SCM_I_INUMP (n2
))
4285 scm_t_inum nn2
= SCM_I_INUM (n2
);
4286 return SCM_I_MAKINUM (nn1
^ nn2
);
4288 else if (SCM_BIGP (n2
))
4292 SCM result_z
= scm_i_mkbig ();
4294 mpz_init_set_si (nn1_z
, nn1
);
4295 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4296 scm_remember_upto_here_1 (n2
);
4298 return scm_i_normbig (result_z
);
4302 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4304 else if (SCM_BIGP (n1
))
4306 if (SCM_I_INUMP (n2
))
4309 nn1
= SCM_I_INUM (n1
);
4312 else if (SCM_BIGP (n2
))
4314 SCM result_z
= scm_i_mkbig ();
4315 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4317 SCM_I_BIG_MPZ (n2
));
4318 scm_remember_upto_here_2 (n1
, n2
);
4319 return scm_i_normbig (result_z
);
4322 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4325 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4330 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4332 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4333 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4334 "without actually calculating the @code{logand}, just testing\n"
4338 "(logtest #b0100 #b1011) @result{} #f\n"
4339 "(logtest #b0100 #b0111) @result{} #t\n"
4341 #define FUNC_NAME s_scm_logtest
4345 if (SCM_I_INUMP (j
))
4347 nj
= SCM_I_INUM (j
);
4348 if (SCM_I_INUMP (k
))
4350 scm_t_inum nk
= SCM_I_INUM (k
);
4351 return scm_from_bool (nj
& nk
);
4353 else if (SCM_BIGP (k
))
4361 mpz_init_set_si (nj_z
, nj
);
4362 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4363 scm_remember_upto_here_1 (k
);
4364 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4370 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4372 else if (SCM_BIGP (j
))
4374 if (SCM_I_INUMP (k
))
4377 nj
= SCM_I_INUM (j
);
4380 else if (SCM_BIGP (k
))
4384 mpz_init (result_z
);
4388 scm_remember_upto_here_2 (j
, k
);
4389 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4390 mpz_clear (result_z
);
4394 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4397 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4402 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4404 "Test whether bit number @var{index} in @var{j} is set.\n"
4405 "@var{index} starts from 0 for the least significant bit.\n"
4408 "(logbit? 0 #b1101) @result{} #t\n"
4409 "(logbit? 1 #b1101) @result{} #f\n"
4410 "(logbit? 2 #b1101) @result{} #t\n"
4411 "(logbit? 3 #b1101) @result{} #t\n"
4412 "(logbit? 4 #b1101) @result{} #f\n"
4414 #define FUNC_NAME s_scm_logbit_p
4416 unsigned long int iindex
;
4417 iindex
= scm_to_ulong (index
);
4419 if (SCM_I_INUMP (j
))
4421 /* bits above what's in an inum follow the sign bit */
4422 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4423 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4425 else if (SCM_BIGP (j
))
4427 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4428 scm_remember_upto_here_1 (j
);
4429 return scm_from_bool (val
);
4432 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4437 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4439 "Return the integer which is the ones-complement of the integer\n"
4443 "(number->string (lognot #b10000000) 2)\n"
4444 " @result{} \"-10000001\"\n"
4445 "(number->string (lognot #b0) 2)\n"
4446 " @result{} \"-1\"\n"
4448 #define FUNC_NAME s_scm_lognot
4450 if (SCM_I_INUMP (n
)) {
4451 /* No overflow here, just need to toggle all the bits making up the inum.
4452 Enhancement: No need to strip the tag and add it back, could just xor
4453 a block of 1 bits, if that worked with the various debug versions of
4455 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4457 } else if (SCM_BIGP (n
)) {
4458 SCM result
= scm_i_mkbig ();
4459 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4460 scm_remember_upto_here_1 (n
);
4464 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4469 /* returns 0 if IN is not an integer. OUT must already be
4472 coerce_to_big (SCM in
, mpz_t out
)
4475 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4476 else if (SCM_I_INUMP (in
))
4477 mpz_set_si (out
, SCM_I_INUM (in
));
4484 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4485 (SCM n
, SCM k
, SCM m
),
4486 "Return @var{n} raised to the integer exponent\n"
4487 "@var{k}, modulo @var{m}.\n"
4490 "(modulo-expt 2 3 5)\n"
4493 #define FUNC_NAME s_scm_modulo_expt
4499 /* There are two classes of error we might encounter --
4500 1) Math errors, which we'll report by calling scm_num_overflow,
4502 2) wrong-type errors, which of course we'll report by calling
4504 We don't report those errors immediately, however; instead we do
4505 some cleanup first. These variables tell us which error (if
4506 any) we should report after cleaning up.
4508 int report_overflow
= 0;
4510 int position_of_wrong_type
= 0;
4511 SCM value_of_wrong_type
= SCM_INUM0
;
4513 SCM result
= SCM_UNDEFINED
;
4519 if (scm_is_eq (m
, SCM_INUM0
))
4521 report_overflow
= 1;
4525 if (!coerce_to_big (n
, n_tmp
))
4527 value_of_wrong_type
= n
;
4528 position_of_wrong_type
= 1;
4532 if (!coerce_to_big (k
, k_tmp
))
4534 value_of_wrong_type
= k
;
4535 position_of_wrong_type
= 2;
4539 if (!coerce_to_big (m
, m_tmp
))
4541 value_of_wrong_type
= m
;
4542 position_of_wrong_type
= 3;
4546 /* if the exponent K is negative, and we simply call mpz_powm, we
4547 will get a divide-by-zero exception when an inverse 1/n mod m
4548 doesn't exist (or is not unique). Since exceptions are hard to
4549 handle, we'll attempt the inversion "by hand" -- that way, we get
4550 a simple failure code, which is easy to handle. */
4552 if (-1 == mpz_sgn (k_tmp
))
4554 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4556 report_overflow
= 1;
4559 mpz_neg (k_tmp
, k_tmp
);
4562 result
= scm_i_mkbig ();
4563 mpz_powm (SCM_I_BIG_MPZ (result
),
4568 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4569 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4576 if (report_overflow
)
4577 scm_num_overflow (FUNC_NAME
);
4579 if (position_of_wrong_type
)
4580 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4581 value_of_wrong_type
);
4583 return scm_i_normbig (result
);
4587 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4589 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4590 "exact integer, @var{n} can be any number.\n"
4592 "Negative @var{k} is supported, and results in\n"
4593 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4594 "@math{@var{n}^0} is 1, as usual, and that\n"
4595 "includes @math{0^0} is 1.\n"
4598 "(integer-expt 2 5) @result{} 32\n"
4599 "(integer-expt -3 3) @result{} -27\n"
4600 "(integer-expt 5 -3) @result{} 1/125\n"
4601 "(integer-expt 0 0) @result{} 1\n"
4603 #define FUNC_NAME s_scm_integer_expt
4606 SCM z_i2
= SCM_BOOL_F
;
4608 SCM acc
= SCM_I_MAKINUM (1L);
4610 /* Specifically refrain from checking the type of the first argument.
4611 This allows us to exponentiate any object that can be multiplied.
4612 If we must raise to a negative power, we must also be able to
4613 take its reciprocal. */
4614 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4615 SCM_WRONG_TYPE_ARG (2, k
);
4617 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4618 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4619 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4620 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4621 /* The next check is necessary only because R6RS specifies different
4622 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4623 we simply skip this case and move on. */
4624 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4626 /* k cannot be 0 at this point, because we
4627 have already checked for that case above */
4628 if (scm_is_true (scm_positive_p (k
)))
4630 else /* return NaN for (0 ^ k) for negative k per R6RS */
4634 if (SCM_I_INUMP (k
))
4635 i2
= SCM_I_INUM (k
);
4636 else if (SCM_BIGP (k
))
4638 z_i2
= scm_i_clonebig (k
, 1);
4639 scm_remember_upto_here_1 (k
);
4643 SCM_WRONG_TYPE_ARG (2, k
);
4647 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4649 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4650 n
= scm_divide (n
, SCM_UNDEFINED
);
4654 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4658 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4660 return scm_product (acc
, n
);
4662 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4663 acc
= scm_product (acc
, n
);
4664 n
= scm_product (n
, n
);
4665 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4673 n
= scm_divide (n
, SCM_UNDEFINED
);
4680 return scm_product (acc
, n
);
4682 acc
= scm_product (acc
, n
);
4683 n
= scm_product (n
, n
);
4690 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4692 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4693 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4695 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4696 "@var{cnt} is negative it's a division, rounded towards negative\n"
4697 "infinity. (Note that this is not the same rounding as\n"
4698 "@code{quotient} does.)\n"
4700 "With @var{n} viewed as an infinite precision twos complement,\n"
4701 "@code{ash} means a left shift introducing zero bits, or a right\n"
4702 "shift dropping bits.\n"
4705 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4706 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4708 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4709 "(ash -23 -2) @result{} -6\n"
4711 #define FUNC_NAME s_scm_ash
4714 bits_to_shift
= scm_to_long (cnt
);
4716 if (SCM_I_INUMP (n
))
4718 scm_t_inum nn
= SCM_I_INUM (n
);
4720 if (bits_to_shift
> 0)
4722 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4723 overflow a non-zero fixnum. For smaller shifts we check the
4724 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4725 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4726 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4732 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4734 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4737 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4741 SCM result
= scm_i_inum2big (nn
);
4742 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4749 bits_to_shift
= -bits_to_shift
;
4750 if (bits_to_shift
>= SCM_LONG_BIT
)
4751 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4753 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4757 else if (SCM_BIGP (n
))
4761 if (bits_to_shift
== 0)
4764 result
= scm_i_mkbig ();
4765 if (bits_to_shift
>= 0)
4767 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4773 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4774 we have to allocate a bignum even if the result is going to be a
4776 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4778 return scm_i_normbig (result
);
4784 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4790 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4791 (SCM n
, SCM start
, SCM end
),
4792 "Return the integer composed of the @var{start} (inclusive)\n"
4793 "through @var{end} (exclusive) bits of @var{n}. The\n"
4794 "@var{start}th bit becomes the 0-th bit in the result.\n"
4797 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4798 " @result{} \"1010\"\n"
4799 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4800 " @result{} \"10110\"\n"
4802 #define FUNC_NAME s_scm_bit_extract
4804 unsigned long int istart
, iend
, bits
;
4805 istart
= scm_to_ulong (start
);
4806 iend
= scm_to_ulong (end
);
4807 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4809 /* how many bits to keep */
4810 bits
= iend
- istart
;
4812 if (SCM_I_INUMP (n
))
4814 scm_t_inum in
= SCM_I_INUM (n
);
4816 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4817 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4818 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4820 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4822 /* Since we emulate two's complement encoded numbers, this
4823 * special case requires us to produce a result that has
4824 * more bits than can be stored in a fixnum.
4826 SCM result
= scm_i_inum2big (in
);
4827 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4832 /* mask down to requisite bits */
4833 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4834 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4836 else if (SCM_BIGP (n
))
4841 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4845 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4846 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4847 such bits into a ulong. */
4848 result
= scm_i_mkbig ();
4849 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4850 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4851 result
= scm_i_normbig (result
);
4853 scm_remember_upto_here_1 (n
);
4857 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4862 static const char scm_logtab
[] = {
4863 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4866 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4868 "Return the number of bits in integer @var{n}. If integer is\n"
4869 "positive, the 1-bits in its binary representation are counted.\n"
4870 "If negative, the 0-bits in its two's-complement binary\n"
4871 "representation are counted. If 0, 0 is returned.\n"
4874 "(logcount #b10101010)\n"
4881 #define FUNC_NAME s_scm_logcount
4883 if (SCM_I_INUMP (n
))
4885 unsigned long c
= 0;
4886 scm_t_inum nn
= SCM_I_INUM (n
);
4891 c
+= scm_logtab
[15 & nn
];
4894 return SCM_I_MAKINUM (c
);
4896 else if (SCM_BIGP (n
))
4898 unsigned long count
;
4899 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4900 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4902 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4903 scm_remember_upto_here_1 (n
);
4904 return SCM_I_MAKINUM (count
);
4907 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4912 static const char scm_ilentab
[] = {
4913 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4917 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4919 "Return the number of bits necessary to represent @var{n}.\n"
4922 "(integer-length #b10101010)\n"
4924 "(integer-length 0)\n"
4926 "(integer-length #b1111)\n"
4929 #define FUNC_NAME s_scm_integer_length
4931 if (SCM_I_INUMP (n
))
4933 unsigned long c
= 0;
4935 scm_t_inum nn
= SCM_I_INUM (n
);
4941 l
= scm_ilentab
[15 & nn
];
4944 return SCM_I_MAKINUM (c
- 4 + l
);
4946 else if (SCM_BIGP (n
))
4948 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4949 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4950 1 too big, so check for that and adjust. */
4951 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4952 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4953 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4954 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4956 scm_remember_upto_here_1 (n
);
4957 return SCM_I_MAKINUM (size
);
4960 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4964 /*** NUMBERS -> STRINGS ***/
4965 #define SCM_MAX_DBL_PREC 60
4966 #define SCM_MAX_DBL_RADIX 36
4968 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4969 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4970 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4973 void init_dblprec(int *prec
, int radix
) {
4974 /* determine floating point precision by adding successively
4975 smaller increments to 1.0 until it is considered == 1.0 */
4976 double f
= ((double)1.0)/radix
;
4977 double fsum
= 1.0 + f
;
4982 if (++(*prec
) > SCM_MAX_DBL_PREC
)
4994 void init_fx_radix(double *fx_list
, int radix
)
4996 /* initialize a per-radix list of tolerances. When added
4997 to a number < 1.0, we can determine if we should raund
4998 up and quit converting a number to a string. */
5002 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5003 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5006 /* use this array as a way to generate a single digit */
5007 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5010 idbl2str (double f
, char *a
, int radix
)
5012 int efmt
, dpt
, d
, i
, wp
;
5014 #ifdef DBL_MIN_10_EXP
5017 #endif /* DBL_MIN_10_EXP */
5022 radix
> SCM_MAX_DBL_RADIX
)
5024 /* revert to existing behavior */
5028 wp
= scm_dblprec
[radix
-2];
5029 fx
= fx_per_radix
[radix
-2];
5033 #ifdef HAVE_COPYSIGN
5034 double sgn
= copysign (1.0, f
);
5039 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5045 strcpy (a
, "-inf.0");
5047 strcpy (a
, "+inf.0");
5052 strcpy (a
, "+nan.0");
5062 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5063 make-uniform-vector, from causing infinite loops. */
5064 /* just do the checking...if it passes, we do the conversion for our
5065 radix again below */
5072 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5080 while (f_cpy
> 10.0)
5083 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5104 if (f
+ fx
[wp
] >= radix
)
5111 /* adding 9999 makes this equivalent to abs(x) % 3 */
5112 dpt
= (exp
+ 9999) % 3;
5116 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5138 a
[ch
++] = number_chars
[d
];
5141 if (f
+ fx
[wp
] >= 1.0)
5143 a
[ch
- 1] = number_chars
[d
+1];
5155 if ((dpt
> 4) && (exp
> 6))
5157 d
= (a
[0] == '-' ? 2 : 1);
5158 for (i
= ch
++; i
> d
; i
--)
5171 if (a
[ch
- 1] == '.')
5172 a
[ch
++] = '0'; /* trailing zero */
5181 for (i
= radix
; i
<= exp
; i
*= radix
);
5182 for (i
/= radix
; i
; i
/= radix
)
5184 a
[ch
++] = number_chars
[exp
/ i
];
5193 icmplx2str (double real
, double imag
, char *str
, int radix
)
5198 i
= idbl2str (real
, str
, radix
);
5199 #ifdef HAVE_COPYSIGN
5200 sgn
= copysign (1.0, imag
);
5204 /* Don't output a '+' for negative numbers or for Inf and
5205 NaN. They will provide their own sign. */
5206 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5208 i
+= idbl2str (imag
, &str
[i
], radix
);
5214 iflo2str (SCM flt
, char *str
, int radix
)
5217 if (SCM_REALP (flt
))
5218 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5220 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5225 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5226 characters in the result.
5228 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5230 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5235 return scm_iuint2str (-num
, rad
, p
) + 1;
5238 return scm_iuint2str (num
, rad
, p
);
5241 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5242 characters in the result.
5244 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5246 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5250 scm_t_uintmax n
= num
;
5252 if (rad
< 2 || rad
> 36)
5253 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5255 for (n
/= rad
; n
> 0; n
/= rad
)
5265 p
[i
] = number_chars
[d
];
5270 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5272 "Return a string holding the external representation of the\n"
5273 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5274 "inexact, a radix of 10 will be used.")
5275 #define FUNC_NAME s_scm_number_to_string
5279 if (SCM_UNBNDP (radix
))
5282 base
= scm_to_signed_integer (radix
, 2, 36);
5284 if (SCM_I_INUMP (n
))
5286 char num_buf
[SCM_INTBUFLEN
];
5287 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5288 return scm_from_locale_stringn (num_buf
, length
);
5290 else if (SCM_BIGP (n
))
5292 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5293 scm_remember_upto_here_1 (n
);
5294 return scm_take_locale_string (str
);
5296 else if (SCM_FRACTIONP (n
))
5298 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5299 scm_from_locale_string ("/"),
5300 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5302 else if (SCM_INEXACTP (n
))
5304 char num_buf
[FLOBUFLEN
];
5305 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5308 SCM_WRONG_TYPE_ARG (1, n
);
5313 /* These print routines used to be stubbed here so that scm_repl.c
5314 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5317 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5319 char num_buf
[FLOBUFLEN
];
5320 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5325 scm_i_print_double (double val
, SCM port
)
5327 char num_buf
[FLOBUFLEN
];
5328 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5332 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5335 char num_buf
[FLOBUFLEN
];
5336 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5341 scm_i_print_complex (double real
, double imag
, SCM port
)
5343 char num_buf
[FLOBUFLEN
];
5344 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5348 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5351 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5352 scm_display (str
, port
);
5353 scm_remember_upto_here_1 (str
);
5358 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5360 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5361 scm_remember_upto_here_1 (exp
);
5362 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5366 /*** END nums->strs ***/
5369 /*** STRINGS -> NUMBERS ***/
5371 /* The following functions implement the conversion from strings to numbers.
5372 * The implementation somehow follows the grammar for numbers as it is given
5373 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5374 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5375 * points should be noted about the implementation:
5377 * * Each function keeps a local index variable 'idx' that points at the
5378 * current position within the parsed string. The global index is only
5379 * updated if the function could parse the corresponding syntactic unit
5382 * * Similarly, the functions keep track of indicators of inexactness ('#',
5383 * '.' or exponents) using local variables ('hash_seen', 'x').
5385 * * Sequences of digits are parsed into temporary variables holding fixnums.
5386 * Only if these fixnums would overflow, the result variables are updated
5387 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5388 * the temporary variables holding the fixnums are cleared, and the process
5389 * starts over again. If for example fixnums were able to store five decimal
5390 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5391 * and the result was computed as 12345 * 100000 + 67890. In other words,
5392 * only every five digits two bignum operations were performed.
5394 * Notes on the handling of exactness specifiers:
5396 * When parsing non-real complex numbers, we apply exactness specifiers on
5397 * per-component basis, as is done in PLT Scheme. For complex numbers
5398 * written in rectangular form, exactness specifiers are applied to the
5399 * real and imaginary parts before calling scm_make_rectangular. For
5400 * complex numbers written in polar form, exactness specifiers are applied
5401 * to the magnitude and angle before calling scm_make_polar.
5403 * There are two kinds of exactness specifiers: forced and implicit. A
5404 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5405 * the entire number, and applies to both components of a complex number.
5406 * "#e" causes each component to be made exact, and "#i" causes each
5407 * component to be made inexact. If no forced exactness specifier is
5408 * present, then the exactness of each component is determined
5409 * independently by the presence or absence of a decimal point or hash mark
5410 * within that component. If a decimal point or hash mark is present, the
5411 * component is made inexact, otherwise it is made exact.
5413 * After the exactness specifiers have been applied to each component, they
5414 * are passed to either scm_make_rectangular or scm_make_polar to produce
5415 * the final result. Note that this will result in a real number if the
5416 * imaginary part, magnitude, or angle is an exact 0.
5418 * For example, (string->number "#i5.0+0i") does the equivalent of:
5420 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5423 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5425 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5427 /* Caller is responsible for checking that the return value is in range
5428 for the given radix, which should be <= 36. */
5430 char_decimal_value (scm_t_uint32 c
)
5432 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5433 that's certainly above any valid decimal, so we take advantage of
5434 that to elide some tests. */
5435 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5437 /* If that failed, try extended hexadecimals, then. Only accept ascii
5442 if (c
>= (scm_t_uint32
) 'a')
5443 d
= c
- (scm_t_uint32
)'a' + 10U;
5449 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5450 unsigned int radix
, enum t_exactness
*p_exactness
)
5452 unsigned int idx
= *p_idx
;
5453 unsigned int hash_seen
= 0;
5454 scm_t_bits shift
= 1;
5456 unsigned int digit_value
;
5459 size_t len
= scm_i_string_length (mem
);
5464 c
= scm_i_string_ref (mem
, idx
);
5465 digit_value
= char_decimal_value (c
);
5466 if (digit_value
>= radix
)
5470 result
= SCM_I_MAKINUM (digit_value
);
5473 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5483 digit_value
= char_decimal_value (c
);
5484 /* This check catches non-decimals in addition to out-of-range
5486 if (digit_value
>= radix
)
5491 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5493 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5495 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5502 shift
= shift
* radix
;
5503 add
= add
* radix
+ digit_value
;
5508 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5510 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5514 *p_exactness
= INEXACT
;
5520 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5521 * covers the parts of the rules that start at a potential point. The value
5522 * of the digits up to the point have been parsed by the caller and are given
5523 * in variable result. The content of *p_exactness indicates, whether a hash
5524 * has already been seen in the digits before the point.
5527 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5530 mem2decimal_from_point (SCM result
, SCM mem
,
5531 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5533 unsigned int idx
= *p_idx
;
5534 enum t_exactness x
= *p_exactness
;
5535 size_t len
= scm_i_string_length (mem
);
5540 if (scm_i_string_ref (mem
, idx
) == '.')
5542 scm_t_bits shift
= 1;
5544 unsigned int digit_value
;
5545 SCM big_shift
= SCM_INUM1
;
5550 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5551 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5556 digit_value
= DIGIT2UINT (c
);
5567 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5569 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5570 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5572 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5580 add
= add
* 10 + digit_value
;
5586 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5587 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5588 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5591 result
= scm_divide (result
, big_shift
);
5593 /* We've seen a decimal point, thus the value is implicitly inexact. */
5605 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5607 switch (scm_i_string_ref (mem
, idx
))
5619 c
= scm_i_string_ref (mem
, idx
);
5627 c
= scm_i_string_ref (mem
, idx
);
5636 c
= scm_i_string_ref (mem
, idx
);
5641 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5645 exponent
= DIGIT2UINT (c
);
5648 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5649 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5652 if (exponent
<= SCM_MAXEXP
)
5653 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5659 if (exponent
> SCM_MAXEXP
)
5661 size_t exp_len
= idx
- start
;
5662 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5663 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5664 scm_out_of_range ("string->number", exp_num
);
5667 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5669 result
= scm_product (result
, e
);
5671 result
= scm_divide2real (result
, e
);
5673 /* We've seen an exponent, thus the value is implicitly inexact. */
5691 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5694 mem2ureal (SCM mem
, unsigned int *p_idx
,
5695 unsigned int radix
, enum t_exactness forced_x
)
5697 unsigned int idx
= *p_idx
;
5699 size_t len
= scm_i_string_length (mem
);
5701 /* Start off believing that the number will be exact. This changes
5702 to INEXACT if we see a decimal point or a hash. */
5703 enum t_exactness implicit_x
= EXACT
;
5708 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5714 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5716 /* Cobble up the fractional part. We might want to set the
5717 NaN's mantissa from it. */
5719 mem2uinteger (mem
, &idx
, 10, &implicit_x
);
5724 if (scm_i_string_ref (mem
, idx
) == '.')
5728 else if (idx
+ 1 == len
)
5730 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5733 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5734 p_idx
, &implicit_x
);
5740 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5741 if (scm_is_false (uinteger
))
5746 else if (scm_i_string_ref (mem
, idx
) == '/')
5754 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5755 if (scm_is_false (divisor
))
5758 /* both are int/big here, I assume */
5759 result
= scm_i_make_ratio (uinteger
, divisor
);
5761 else if (radix
== 10)
5763 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5764 if (scm_is_false (result
))
5776 if (SCM_INEXACTP (result
))
5777 return scm_inexact_to_exact (result
);
5781 if (SCM_INEXACTP (result
))
5784 return scm_exact_to_inexact (result
);
5786 if (implicit_x
== INEXACT
)
5788 if (SCM_INEXACTP (result
))
5791 return scm_exact_to_inexact (result
);
5797 /* We should never get here */
5798 scm_syserror ("mem2ureal");
5802 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5805 mem2complex (SCM mem
, unsigned int idx
,
5806 unsigned int radix
, enum t_exactness forced_x
)
5811 size_t len
= scm_i_string_length (mem
);
5816 c
= scm_i_string_ref (mem
, idx
);
5831 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5832 if (scm_is_false (ureal
))
5834 /* input must be either +i or -i */
5839 if (scm_i_string_ref (mem
, idx
) == 'i'
5840 || scm_i_string_ref (mem
, idx
) == 'I')
5846 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5853 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5854 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5859 c
= scm_i_string_ref (mem
, idx
);
5863 /* either +<ureal>i or -<ureal>i */
5870 return scm_make_rectangular (SCM_INUM0
, ureal
);
5873 /* polar input: <real>@<real>. */
5884 c
= scm_i_string_ref (mem
, idx
);
5902 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5903 if (scm_is_false (angle
))
5908 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5909 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5911 result
= scm_make_polar (ureal
, angle
);
5916 /* expecting input matching <real>[+-]<ureal>?i */
5923 int sign
= (c
== '+') ? 1 : -1;
5924 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5926 if (scm_is_false (imag
))
5927 imag
= SCM_I_MAKINUM (sign
);
5928 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5929 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5933 if (scm_i_string_ref (mem
, idx
) != 'i'
5934 && scm_i_string_ref (mem
, idx
) != 'I')
5941 return scm_make_rectangular (ureal
, imag
);
5950 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5952 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5955 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5957 unsigned int idx
= 0;
5958 unsigned int radix
= NO_RADIX
;
5959 enum t_exactness forced_x
= NO_EXACTNESS
;
5960 size_t len
= scm_i_string_length (mem
);
5962 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5963 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5965 switch (scm_i_string_ref (mem
, idx
+ 1))
5968 if (radix
!= NO_RADIX
)
5973 if (radix
!= NO_RADIX
)
5978 if (forced_x
!= NO_EXACTNESS
)
5983 if (forced_x
!= NO_EXACTNESS
)
5988 if (radix
!= NO_RADIX
)
5993 if (radix
!= NO_RADIX
)
6003 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6004 if (radix
== NO_RADIX
)
6005 radix
= default_radix
;
6007 return mem2complex (mem
, idx
, radix
, forced_x
);
6011 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6012 unsigned int default_radix
)
6014 SCM str
= scm_from_locale_stringn (mem
, len
);
6016 return scm_i_string_to_number (str
, default_radix
);
6020 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6021 (SCM string
, SCM radix
),
6022 "Return a number of the maximally precise representation\n"
6023 "expressed by the given @var{string}. @var{radix} must be an\n"
6024 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6025 "is a default radix that may be overridden by an explicit radix\n"
6026 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6027 "supplied, then the default radix is 10. If string is not a\n"
6028 "syntactically valid notation for a number, then\n"
6029 "@code{string->number} returns @code{#f}.")
6030 #define FUNC_NAME s_scm_string_to_number
6034 SCM_VALIDATE_STRING (1, string
);
6036 if (SCM_UNBNDP (radix
))
6039 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6041 answer
= scm_i_string_to_number (string
, base
);
6042 scm_remember_upto_here_1 (string
);
6048 /*** END strs->nums ***/
6051 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6053 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6055 #define FUNC_NAME s_scm_number_p
6057 return scm_from_bool (SCM_NUMBERP (x
));
6061 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6063 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6064 "otherwise. Note that the sets of real, rational and integer\n"
6065 "values form subsets of the set of complex numbers, i. e. the\n"
6066 "predicate will also be fulfilled if @var{x} is a real,\n"
6067 "rational or integer number.")
6068 #define FUNC_NAME s_scm_complex_p
6070 /* all numbers are complex. */
6071 return scm_number_p (x
);
6075 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6077 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6078 "otherwise. Note that the set of integer values forms a subset of\n"
6079 "the set of real numbers, i. e. the predicate will also be\n"
6080 "fulfilled if @var{x} is an integer number.")
6081 #define FUNC_NAME s_scm_real_p
6083 return scm_from_bool
6084 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6088 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6090 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6091 "otherwise. Note that the set of integer values forms a subset of\n"
6092 "the set of rational numbers, i. e. the predicate will also be\n"
6093 "fulfilled if @var{x} is an integer number.")
6094 #define FUNC_NAME s_scm_rational_p
6096 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6098 else if (SCM_REALP (x
))
6099 /* due to their limited precision, finite floating point numbers are
6100 rational as well. (finite means neither infinity nor a NaN) */
6101 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6107 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6109 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6111 #define FUNC_NAME s_scm_integer_p
6113 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6115 else if (SCM_REALP (x
))
6117 double val
= SCM_REAL_VALUE (x
);
6118 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6126 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6127 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6128 (SCM x
, SCM y
, SCM rest
),
6129 "Return @code{#t} if all parameters are numerically equal.")
6130 #define FUNC_NAME s_scm_i_num_eq_p
6132 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6134 while (!scm_is_null (rest
))
6136 if (scm_is_false (scm_num_eq_p (x
, y
)))
6140 rest
= scm_cdr (rest
);
6142 return scm_num_eq_p (x
, y
);
6146 scm_num_eq_p (SCM x
, SCM y
)
6149 if (SCM_I_INUMP (x
))
6151 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6152 if (SCM_I_INUMP (y
))
6154 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6155 return scm_from_bool (xx
== yy
);
6157 else if (SCM_BIGP (y
))
6159 else if (SCM_REALP (y
))
6161 /* On a 32-bit system an inum fits a double, we can cast the inum
6162 to a double and compare.
6164 But on a 64-bit system an inum is bigger than a double and
6165 casting it to a double (call that dxx) will round. dxx is at
6166 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6167 an integer and fits a long. So we cast yy to a long and
6168 compare with plain xx.
6170 An alternative (for any size system actually) would be to check
6171 yy is an integer (with floor) and is in range of an inum
6172 (compare against appropriate powers of 2) then test
6173 xx==(scm_t_signed_bits)yy. It's just a matter of which
6174 casts/comparisons might be fastest or easiest for the cpu. */
6176 double yy
= SCM_REAL_VALUE (y
);
6177 return scm_from_bool ((double) xx
== yy
6178 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6179 || xx
== (scm_t_signed_bits
) yy
));
6181 else if (SCM_COMPLEXP (y
))
6182 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6183 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6184 else if (SCM_FRACTIONP (y
))
6187 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6189 else if (SCM_BIGP (x
))
6191 if (SCM_I_INUMP (y
))
6193 else if (SCM_BIGP (y
))
6195 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6196 scm_remember_upto_here_2 (x
, y
);
6197 return scm_from_bool (0 == cmp
);
6199 else if (SCM_REALP (y
))
6202 if (isnan (SCM_REAL_VALUE (y
)))
6204 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6205 scm_remember_upto_here_1 (x
);
6206 return scm_from_bool (0 == cmp
);
6208 else if (SCM_COMPLEXP (y
))
6211 if (0.0 != SCM_COMPLEX_IMAG (y
))
6213 if (isnan (SCM_COMPLEX_REAL (y
)))
6215 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6216 scm_remember_upto_here_1 (x
);
6217 return scm_from_bool (0 == cmp
);
6219 else if (SCM_FRACTIONP (y
))
6222 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6224 else if (SCM_REALP (x
))
6226 double xx
= SCM_REAL_VALUE (x
);
6227 if (SCM_I_INUMP (y
))
6229 /* see comments with inum/real above */
6230 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6231 return scm_from_bool (xx
== (double) yy
6232 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6233 || (scm_t_signed_bits
) xx
== yy
));
6235 else if (SCM_BIGP (y
))
6238 if (isnan (SCM_REAL_VALUE (x
)))
6240 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6241 scm_remember_upto_here_1 (y
);
6242 return scm_from_bool (0 == cmp
);
6244 else if (SCM_REALP (y
))
6245 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6246 else if (SCM_COMPLEXP (y
))
6247 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6248 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6249 else if (SCM_FRACTIONP (y
))
6251 double xx
= SCM_REAL_VALUE (x
);
6255 return scm_from_bool (xx
< 0.0);
6256 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6260 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6262 else if (SCM_COMPLEXP (x
))
6264 if (SCM_I_INUMP (y
))
6265 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6266 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6267 else if (SCM_BIGP (y
))
6270 if (0.0 != SCM_COMPLEX_IMAG (x
))
6272 if (isnan (SCM_COMPLEX_REAL (x
)))
6274 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6275 scm_remember_upto_here_1 (y
);
6276 return scm_from_bool (0 == cmp
);
6278 else if (SCM_REALP (y
))
6279 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6280 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6281 else if (SCM_COMPLEXP (y
))
6282 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6283 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6284 else if (SCM_FRACTIONP (y
))
6287 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6289 xx
= SCM_COMPLEX_REAL (x
);
6293 return scm_from_bool (xx
< 0.0);
6294 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6298 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6300 else if (SCM_FRACTIONP (x
))
6302 if (SCM_I_INUMP (y
))
6304 else if (SCM_BIGP (y
))
6306 else if (SCM_REALP (y
))
6308 double yy
= SCM_REAL_VALUE (y
);
6312 return scm_from_bool (0.0 < yy
);
6313 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6316 else if (SCM_COMPLEXP (y
))
6319 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6321 yy
= SCM_COMPLEX_REAL (y
);
6325 return scm_from_bool (0.0 < yy
);
6326 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6329 else if (SCM_FRACTIONP (y
))
6330 return scm_i_fraction_equalp (x
, y
);
6332 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6335 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6339 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6340 done are good for inums, but for bignums an answer can almost always be
6341 had by just examining a few high bits of the operands, as done by GMP in
6342 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6343 of the float exponent to take into account. */
6345 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6346 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6347 (SCM x
, SCM y
, SCM rest
),
6348 "Return @code{#t} if the list of parameters is monotonically\n"
6350 #define FUNC_NAME s_scm_i_num_less_p
6352 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6354 while (!scm_is_null (rest
))
6356 if (scm_is_false (scm_less_p (x
, y
)))
6360 rest
= scm_cdr (rest
);
6362 return scm_less_p (x
, y
);
6366 scm_less_p (SCM x
, SCM y
)
6369 if (SCM_I_INUMP (x
))
6371 scm_t_inum xx
= SCM_I_INUM (x
);
6372 if (SCM_I_INUMP (y
))
6374 scm_t_inum yy
= SCM_I_INUM (y
);
6375 return scm_from_bool (xx
< yy
);
6377 else if (SCM_BIGP (y
))
6379 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6380 scm_remember_upto_here_1 (y
);
6381 return scm_from_bool (sgn
> 0);
6383 else if (SCM_REALP (y
))
6384 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6385 else if (SCM_FRACTIONP (y
))
6387 /* "x < a/b" becomes "x*b < a" */
6389 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6390 y
= SCM_FRACTION_NUMERATOR (y
);
6394 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6396 else if (SCM_BIGP (x
))
6398 if (SCM_I_INUMP (y
))
6400 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6401 scm_remember_upto_here_1 (x
);
6402 return scm_from_bool (sgn
< 0);
6404 else if (SCM_BIGP (y
))
6406 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6407 scm_remember_upto_here_2 (x
, y
);
6408 return scm_from_bool (cmp
< 0);
6410 else if (SCM_REALP (y
))
6413 if (isnan (SCM_REAL_VALUE (y
)))
6415 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6416 scm_remember_upto_here_1 (x
);
6417 return scm_from_bool (cmp
< 0);
6419 else if (SCM_FRACTIONP (y
))
6422 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6424 else if (SCM_REALP (x
))
6426 if (SCM_I_INUMP (y
))
6427 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6428 else if (SCM_BIGP (y
))
6431 if (isnan (SCM_REAL_VALUE (x
)))
6433 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6434 scm_remember_upto_here_1 (y
);
6435 return scm_from_bool (cmp
> 0);
6437 else if (SCM_REALP (y
))
6438 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6439 else if (SCM_FRACTIONP (y
))
6441 double xx
= SCM_REAL_VALUE (x
);
6445 return scm_from_bool (xx
< 0.0);
6446 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6450 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6452 else if (SCM_FRACTIONP (x
))
6454 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6456 /* "a/b < y" becomes "a < y*b" */
6457 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6458 x
= SCM_FRACTION_NUMERATOR (x
);
6461 else if (SCM_REALP (y
))
6463 double yy
= SCM_REAL_VALUE (y
);
6467 return scm_from_bool (0.0 < yy
);
6468 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6471 else if (SCM_FRACTIONP (y
))
6473 /* "a/b < c/d" becomes "a*d < c*b" */
6474 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6475 SCM_FRACTION_DENOMINATOR (y
));
6476 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6477 SCM_FRACTION_DENOMINATOR (x
));
6483 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6486 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6490 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6491 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6492 (SCM x
, SCM y
, SCM rest
),
6493 "Return @code{#t} if the list of parameters is monotonically\n"
6495 #define FUNC_NAME s_scm_i_num_gr_p
6497 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6499 while (!scm_is_null (rest
))
6501 if (scm_is_false (scm_gr_p (x
, y
)))
6505 rest
= scm_cdr (rest
);
6507 return scm_gr_p (x
, y
);
6510 #define FUNC_NAME s_scm_i_num_gr_p
6512 scm_gr_p (SCM x
, SCM y
)
6514 if (!SCM_NUMBERP (x
))
6515 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6516 else if (!SCM_NUMBERP (y
))
6517 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6519 return scm_less_p (y
, x
);
6524 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6525 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6526 (SCM x
, SCM y
, SCM rest
),
6527 "Return @code{#t} if the list of parameters is monotonically\n"
6529 #define FUNC_NAME s_scm_i_num_leq_p
6531 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6533 while (!scm_is_null (rest
))
6535 if (scm_is_false (scm_leq_p (x
, y
)))
6539 rest
= scm_cdr (rest
);
6541 return scm_leq_p (x
, y
);
6544 #define FUNC_NAME s_scm_i_num_leq_p
6546 scm_leq_p (SCM x
, SCM y
)
6548 if (!SCM_NUMBERP (x
))
6549 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6550 else if (!SCM_NUMBERP (y
))
6551 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6552 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6555 return scm_not (scm_less_p (y
, x
));
6560 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6561 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6562 (SCM x
, SCM y
, SCM rest
),
6563 "Return @code{#t} if the list of parameters is monotonically\n"
6565 #define FUNC_NAME s_scm_i_num_geq_p
6567 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6569 while (!scm_is_null (rest
))
6571 if (scm_is_false (scm_geq_p (x
, y
)))
6575 rest
= scm_cdr (rest
);
6577 return scm_geq_p (x
, y
);
6580 #define FUNC_NAME s_scm_i_num_geq_p
6582 scm_geq_p (SCM x
, SCM y
)
6584 if (!SCM_NUMBERP (x
))
6585 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6586 else if (!SCM_NUMBERP (y
))
6587 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6588 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6591 return scm_not (scm_less_p (x
, y
));
6596 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6598 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6600 #define FUNC_NAME s_scm_zero_p
6602 if (SCM_I_INUMP (z
))
6603 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6604 else if (SCM_BIGP (z
))
6606 else if (SCM_REALP (z
))
6607 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6608 else if (SCM_COMPLEXP (z
))
6609 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6610 && SCM_COMPLEX_IMAG (z
) == 0.0);
6611 else if (SCM_FRACTIONP (z
))
6614 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6619 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6621 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6623 #define FUNC_NAME s_scm_positive_p
6625 if (SCM_I_INUMP (x
))
6626 return scm_from_bool (SCM_I_INUM (x
) > 0);
6627 else if (SCM_BIGP (x
))
6629 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6630 scm_remember_upto_here_1 (x
);
6631 return scm_from_bool (sgn
> 0);
6633 else if (SCM_REALP (x
))
6634 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6635 else if (SCM_FRACTIONP (x
))
6636 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6638 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6643 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6645 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6647 #define FUNC_NAME s_scm_negative_p
6649 if (SCM_I_INUMP (x
))
6650 return scm_from_bool (SCM_I_INUM (x
) < 0);
6651 else if (SCM_BIGP (x
))
6653 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6654 scm_remember_upto_here_1 (x
);
6655 return scm_from_bool (sgn
< 0);
6657 else if (SCM_REALP (x
))
6658 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6659 else if (SCM_FRACTIONP (x
))
6660 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6662 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6667 /* scm_min and scm_max return an inexact when either argument is inexact, as
6668 required by r5rs. On that basis, for exact/inexact combinations the
6669 exact is converted to inexact to compare and possibly return. This is
6670 unlike scm_less_p above which takes some trouble to preserve all bits in
6671 its test, such trouble is not required for min and max. */
6673 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6674 (SCM x
, SCM y
, SCM rest
),
6675 "Return the maximum of all parameter values.")
6676 #define FUNC_NAME s_scm_i_max
6678 while (!scm_is_null (rest
))
6679 { x
= scm_max (x
, y
);
6681 rest
= scm_cdr (rest
);
6683 return scm_max (x
, y
);
6687 #define s_max s_scm_i_max
6688 #define g_max g_scm_i_max
6691 scm_max (SCM x
, SCM y
)
6696 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6697 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6700 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6703 if (SCM_I_INUMP (x
))
6705 scm_t_inum xx
= SCM_I_INUM (x
);
6706 if (SCM_I_INUMP (y
))
6708 scm_t_inum yy
= SCM_I_INUM (y
);
6709 return (xx
< yy
) ? y
: x
;
6711 else if (SCM_BIGP (y
))
6713 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6714 scm_remember_upto_here_1 (y
);
6715 return (sgn
< 0) ? x
: y
;
6717 else if (SCM_REALP (y
))
6720 double yyd
= SCM_REAL_VALUE (y
);
6723 return scm_from_double (xxd
);
6724 /* If y is a NaN, then "==" is false and we return the NaN */
6725 else if (SCM_LIKELY (!(xxd
== yyd
)))
6727 /* Handle signed zeroes properly */
6733 else if (SCM_FRACTIONP (y
))
6736 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6739 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6741 else if (SCM_BIGP (x
))
6743 if (SCM_I_INUMP (y
))
6745 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6746 scm_remember_upto_here_1 (x
);
6747 return (sgn
< 0) ? y
: x
;
6749 else if (SCM_BIGP (y
))
6751 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6752 scm_remember_upto_here_2 (x
, y
);
6753 return (cmp
> 0) ? x
: y
;
6755 else if (SCM_REALP (y
))
6757 /* if y==NaN then xx>yy is false, so we return the NaN y */
6760 xx
= scm_i_big2dbl (x
);
6761 yy
= SCM_REAL_VALUE (y
);
6762 return (xx
> yy
? scm_from_double (xx
) : y
);
6764 else if (SCM_FRACTIONP (y
))
6769 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6771 else if (SCM_REALP (x
))
6773 if (SCM_I_INUMP (y
))
6775 scm_t_inum yy
= SCM_I_INUM (y
);
6776 double xxd
= SCM_REAL_VALUE (x
);
6780 return scm_from_double (yyd
);
6781 /* If x is a NaN, then "==" is false and we return the NaN */
6782 else if (SCM_LIKELY (!(xxd
== yyd
)))
6784 /* Handle signed zeroes properly */
6790 else if (SCM_BIGP (y
))
6795 else if (SCM_REALP (y
))
6797 double xx
= SCM_REAL_VALUE (x
);
6798 double yy
= SCM_REAL_VALUE (y
);
6800 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6803 else if (SCM_LIKELY (xx
< yy
))
6805 /* If neither (xx > yy) nor (xx < yy), then
6806 either they're equal or one is a NaN */
6807 else if (SCM_UNLIKELY (isnan (xx
)))
6808 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6809 else if (SCM_UNLIKELY (isnan (yy
)))
6810 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6811 /* xx == yy, but handle signed zeroes properly */
6812 else if (double_is_non_negative_zero (yy
))
6817 else if (SCM_FRACTIONP (y
))
6819 double yy
= scm_i_fraction2double (y
);
6820 double xx
= SCM_REAL_VALUE (x
);
6821 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6824 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6826 else if (SCM_FRACTIONP (x
))
6828 if (SCM_I_INUMP (y
))
6832 else if (SCM_BIGP (y
))
6836 else if (SCM_REALP (y
))
6838 double xx
= scm_i_fraction2double (x
);
6839 /* if y==NaN then ">" is false, so we return the NaN y */
6840 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6842 else if (SCM_FRACTIONP (y
))
6847 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6850 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6854 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6855 (SCM x
, SCM y
, SCM rest
),
6856 "Return the minimum of all parameter values.")
6857 #define FUNC_NAME s_scm_i_min
6859 while (!scm_is_null (rest
))
6860 { x
= scm_min (x
, y
);
6862 rest
= scm_cdr (rest
);
6864 return scm_min (x
, y
);
6868 #define s_min s_scm_i_min
6869 #define g_min g_scm_i_min
6872 scm_min (SCM x
, SCM y
)
6877 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6878 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6881 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6884 if (SCM_I_INUMP (x
))
6886 scm_t_inum xx
= SCM_I_INUM (x
);
6887 if (SCM_I_INUMP (y
))
6889 scm_t_inum yy
= SCM_I_INUM (y
);
6890 return (xx
< yy
) ? x
: y
;
6892 else if (SCM_BIGP (y
))
6894 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6895 scm_remember_upto_here_1 (y
);
6896 return (sgn
< 0) ? y
: x
;
6898 else if (SCM_REALP (y
))
6901 /* if y==NaN then "<" is false and we return NaN */
6902 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6904 else if (SCM_FRACTIONP (y
))
6907 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6910 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6912 else if (SCM_BIGP (x
))
6914 if (SCM_I_INUMP (y
))
6916 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6917 scm_remember_upto_here_1 (x
);
6918 return (sgn
< 0) ? x
: y
;
6920 else if (SCM_BIGP (y
))
6922 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6923 scm_remember_upto_here_2 (x
, y
);
6924 return (cmp
> 0) ? y
: x
;
6926 else if (SCM_REALP (y
))
6928 /* if y==NaN then xx<yy is false, so we return the NaN y */
6931 xx
= scm_i_big2dbl (x
);
6932 yy
= SCM_REAL_VALUE (y
);
6933 return (xx
< yy
? scm_from_double (xx
) : y
);
6935 else if (SCM_FRACTIONP (y
))
6940 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6942 else if (SCM_REALP (x
))
6944 if (SCM_I_INUMP (y
))
6946 double z
= SCM_I_INUM (y
);
6947 /* if x==NaN then "<" is false and we return NaN */
6948 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6950 else if (SCM_BIGP (y
))
6955 else if (SCM_REALP (y
))
6957 double xx
= SCM_REAL_VALUE (x
);
6958 double yy
= SCM_REAL_VALUE (y
);
6960 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6963 else if (SCM_LIKELY (xx
> yy
))
6965 /* If neither (xx < yy) nor (xx > yy), then
6966 either they're equal or one is a NaN */
6967 else if (SCM_UNLIKELY (isnan (xx
)))
6968 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6969 else if (SCM_UNLIKELY (isnan (yy
)))
6970 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6971 /* xx == yy, but handle signed zeroes properly */
6972 else if (double_is_non_negative_zero (xx
))
6977 else if (SCM_FRACTIONP (y
))
6979 double yy
= scm_i_fraction2double (y
);
6980 double xx
= SCM_REAL_VALUE (x
);
6981 return (yy
< xx
) ? scm_from_double (yy
) : x
;
6984 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6986 else if (SCM_FRACTIONP (x
))
6988 if (SCM_I_INUMP (y
))
6992 else if (SCM_BIGP (y
))
6996 else if (SCM_REALP (y
))
6998 double xx
= scm_i_fraction2double (x
);
6999 /* if y==NaN then "<" is false, so we return the NaN y */
7000 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7002 else if (SCM_FRACTIONP (y
))
7007 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7010 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7014 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7015 (SCM x
, SCM y
, SCM rest
),
7016 "Return the sum of all parameter values. Return 0 if called without\n"
7018 #define FUNC_NAME s_scm_i_sum
7020 while (!scm_is_null (rest
))
7021 { x
= scm_sum (x
, y
);
7023 rest
= scm_cdr (rest
);
7025 return scm_sum (x
, y
);
7029 #define s_sum s_scm_i_sum
7030 #define g_sum g_scm_i_sum
7033 scm_sum (SCM x
, SCM y
)
7035 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7037 if (SCM_NUMBERP (x
)) return x
;
7038 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7039 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7042 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7044 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7046 scm_t_inum xx
= SCM_I_INUM (x
);
7047 scm_t_inum yy
= SCM_I_INUM (y
);
7048 scm_t_inum z
= xx
+ yy
;
7049 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7051 else if (SCM_BIGP (y
))
7056 else if (SCM_REALP (y
))
7058 scm_t_inum xx
= SCM_I_INUM (x
);
7059 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7061 else if (SCM_COMPLEXP (y
))
7063 scm_t_inum xx
= SCM_I_INUM (x
);
7064 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7065 SCM_COMPLEX_IMAG (y
));
7067 else if (SCM_FRACTIONP (y
))
7068 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7069 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7070 SCM_FRACTION_DENOMINATOR (y
));
7072 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7073 } else if (SCM_BIGP (x
))
7075 if (SCM_I_INUMP (y
))
7080 inum
= SCM_I_INUM (y
);
7083 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7086 SCM result
= scm_i_mkbig ();
7087 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7088 scm_remember_upto_here_1 (x
);
7089 /* we know the result will have to be a bignum */
7092 return scm_i_normbig (result
);
7096 SCM result
= scm_i_mkbig ();
7097 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7098 scm_remember_upto_here_1 (x
);
7099 /* we know the result will have to be a bignum */
7102 return scm_i_normbig (result
);
7105 else if (SCM_BIGP (y
))
7107 SCM result
= scm_i_mkbig ();
7108 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7109 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7110 mpz_add (SCM_I_BIG_MPZ (result
),
7113 scm_remember_upto_here_2 (x
, y
);
7114 /* we know the result will have to be a bignum */
7117 return scm_i_normbig (result
);
7119 else if (SCM_REALP (y
))
7121 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7122 scm_remember_upto_here_1 (x
);
7123 return scm_from_double (result
);
7125 else if (SCM_COMPLEXP (y
))
7127 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7128 + SCM_COMPLEX_REAL (y
));
7129 scm_remember_upto_here_1 (x
);
7130 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7132 else if (SCM_FRACTIONP (y
))
7133 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7134 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7135 SCM_FRACTION_DENOMINATOR (y
));
7137 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7139 else if (SCM_REALP (x
))
7141 if (SCM_I_INUMP (y
))
7142 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7143 else if (SCM_BIGP (y
))
7145 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7146 scm_remember_upto_here_1 (y
);
7147 return scm_from_double (result
);
7149 else if (SCM_REALP (y
))
7150 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7151 else if (SCM_COMPLEXP (y
))
7152 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7153 SCM_COMPLEX_IMAG (y
));
7154 else if (SCM_FRACTIONP (y
))
7155 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7157 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7159 else if (SCM_COMPLEXP (x
))
7161 if (SCM_I_INUMP (y
))
7162 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7163 SCM_COMPLEX_IMAG (x
));
7164 else if (SCM_BIGP (y
))
7166 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7167 + SCM_COMPLEX_REAL (x
));
7168 scm_remember_upto_here_1 (y
);
7169 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7171 else if (SCM_REALP (y
))
7172 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7173 SCM_COMPLEX_IMAG (x
));
7174 else if (SCM_COMPLEXP (y
))
7175 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7176 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7177 else if (SCM_FRACTIONP (y
))
7178 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7179 SCM_COMPLEX_IMAG (x
));
7181 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7183 else if (SCM_FRACTIONP (x
))
7185 if (SCM_I_INUMP (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_BIGP (y
))
7190 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7191 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7192 SCM_FRACTION_DENOMINATOR (x
));
7193 else if (SCM_REALP (y
))
7194 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7195 else if (SCM_COMPLEXP (y
))
7196 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7197 SCM_COMPLEX_IMAG (y
));
7198 else if (SCM_FRACTIONP (y
))
7199 /* a/b + c/d = (ad + bc) / bd */
7200 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7201 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7202 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7204 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7207 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7211 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7213 "Return @math{@var{x}+1}.")
7214 #define FUNC_NAME s_scm_oneplus
7216 return scm_sum (x
, SCM_INUM1
);
7221 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7222 (SCM x
, SCM y
, SCM rest
),
7223 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7224 "the sum of all but the first argument are subtracted from the first\n"
7226 #define FUNC_NAME s_scm_i_difference
7228 while (!scm_is_null (rest
))
7229 { x
= scm_difference (x
, y
);
7231 rest
= scm_cdr (rest
);
7233 return scm_difference (x
, y
);
7237 #define s_difference s_scm_i_difference
7238 #define g_difference g_scm_i_difference
7241 scm_difference (SCM x
, SCM y
)
7242 #define FUNC_NAME s_difference
7244 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7247 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7249 if (SCM_I_INUMP (x
))
7251 scm_t_inum xx
= -SCM_I_INUM (x
);
7252 if (SCM_FIXABLE (xx
))
7253 return SCM_I_MAKINUM (xx
);
7255 return scm_i_inum2big (xx
);
7257 else if (SCM_BIGP (x
))
7258 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7259 bignum, but negating that gives a fixnum. */
7260 return scm_i_normbig (scm_i_clonebig (x
, 0));
7261 else if (SCM_REALP (x
))
7262 return scm_from_double (-SCM_REAL_VALUE (x
));
7263 else if (SCM_COMPLEXP (x
))
7264 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7265 -SCM_COMPLEX_IMAG (x
));
7266 else if (SCM_FRACTIONP (x
))
7267 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7268 SCM_FRACTION_DENOMINATOR (x
));
7270 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7273 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7275 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7277 scm_t_inum xx
= SCM_I_INUM (x
);
7278 scm_t_inum yy
= SCM_I_INUM (y
);
7279 scm_t_inum z
= xx
- yy
;
7280 if (SCM_FIXABLE (z
))
7281 return SCM_I_MAKINUM (z
);
7283 return scm_i_inum2big (z
);
7285 else if (SCM_BIGP (y
))
7287 /* inum-x - big-y */
7288 scm_t_inum xx
= SCM_I_INUM (x
);
7292 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7293 bignum, but negating that gives a fixnum. */
7294 return scm_i_normbig (scm_i_clonebig (y
, 0));
7298 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7299 SCM result
= scm_i_mkbig ();
7302 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7305 /* x - y == -(y + -x) */
7306 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7307 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7309 scm_remember_upto_here_1 (y
);
7311 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7312 /* we know the result will have to be a bignum */
7315 return scm_i_normbig (result
);
7318 else if (SCM_REALP (y
))
7320 scm_t_inum xx
= SCM_I_INUM (x
);
7323 * We need to handle x == exact 0
7324 * specially because R6RS states that:
7325 * (- 0.0) ==> -0.0 and
7326 * (- 0.0 0.0) ==> 0.0
7327 * and the scheme compiler changes
7328 * (- 0.0) into (- 0 0.0)
7329 * So we need to treat (- 0 0.0) like (- 0.0).
7330 * At the C level, (-x) is different than (0.0 - x).
7331 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7334 return scm_from_double (- SCM_REAL_VALUE (y
));
7336 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7338 else if (SCM_COMPLEXP (y
))
7340 scm_t_inum xx
= SCM_I_INUM (x
);
7342 /* We need to handle x == exact 0 specially.
7343 See the comment above (for SCM_REALP (y)) */
7345 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7346 - SCM_COMPLEX_IMAG (y
));
7348 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7349 - SCM_COMPLEX_IMAG (y
));
7351 else if (SCM_FRACTIONP (y
))
7352 /* a - b/c = (ac - b) / c */
7353 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7354 SCM_FRACTION_NUMERATOR (y
)),
7355 SCM_FRACTION_DENOMINATOR (y
));
7357 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7359 else if (SCM_BIGP (x
))
7361 if (SCM_I_INUMP (y
))
7363 /* big-x - inum-y */
7364 scm_t_inum yy
= SCM_I_INUM (y
);
7365 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7367 scm_remember_upto_here_1 (x
);
7369 return (SCM_FIXABLE (-yy
) ?
7370 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7373 SCM result
= scm_i_mkbig ();
7376 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7378 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7379 scm_remember_upto_here_1 (x
);
7381 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7382 /* we know the result will have to be a bignum */
7385 return scm_i_normbig (result
);
7388 else if (SCM_BIGP (y
))
7390 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7391 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7392 SCM result
= scm_i_mkbig ();
7393 mpz_sub (SCM_I_BIG_MPZ (result
),
7396 scm_remember_upto_here_2 (x
, y
);
7397 /* we know the result will have to be a bignum */
7398 if ((sgn_x
== 1) && (sgn_y
== -1))
7400 if ((sgn_x
== -1) && (sgn_y
== 1))
7402 return scm_i_normbig (result
);
7404 else if (SCM_REALP (y
))
7406 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7407 scm_remember_upto_here_1 (x
);
7408 return scm_from_double (result
);
7410 else if (SCM_COMPLEXP (y
))
7412 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7413 - SCM_COMPLEX_REAL (y
));
7414 scm_remember_upto_here_1 (x
);
7415 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7417 else if (SCM_FRACTIONP (y
))
7418 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7419 SCM_FRACTION_NUMERATOR (y
)),
7420 SCM_FRACTION_DENOMINATOR (y
));
7421 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7423 else if (SCM_REALP (x
))
7425 if (SCM_I_INUMP (y
))
7426 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7427 else if (SCM_BIGP (y
))
7429 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7430 scm_remember_upto_here_1 (x
);
7431 return scm_from_double (result
);
7433 else if (SCM_REALP (y
))
7434 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7435 else if (SCM_COMPLEXP (y
))
7436 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7437 -SCM_COMPLEX_IMAG (y
));
7438 else if (SCM_FRACTIONP (y
))
7439 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7441 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7443 else if (SCM_COMPLEXP (x
))
7445 if (SCM_I_INUMP (y
))
7446 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7447 SCM_COMPLEX_IMAG (x
));
7448 else if (SCM_BIGP (y
))
7450 double real_part
= (SCM_COMPLEX_REAL (x
)
7451 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7452 scm_remember_upto_here_1 (x
);
7453 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7455 else if (SCM_REALP (y
))
7456 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7457 SCM_COMPLEX_IMAG (x
));
7458 else if (SCM_COMPLEXP (y
))
7459 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7460 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7461 else if (SCM_FRACTIONP (y
))
7462 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7463 SCM_COMPLEX_IMAG (x
));
7465 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7467 else if (SCM_FRACTIONP (x
))
7469 if (SCM_I_INUMP (y
))
7470 /* a/b - c = (a - cb) / b */
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_BIGP (y
))
7475 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7476 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7477 SCM_FRACTION_DENOMINATOR (x
));
7478 else if (SCM_REALP (y
))
7479 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7480 else if (SCM_COMPLEXP (y
))
7481 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7482 -SCM_COMPLEX_IMAG (y
));
7483 else if (SCM_FRACTIONP (y
))
7484 /* a/b - c/d = (ad - bc) / bd */
7485 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7486 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7487 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7489 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7492 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7497 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7499 "Return @math{@var{x}-1}.")
7500 #define FUNC_NAME s_scm_oneminus
7502 return scm_difference (x
, SCM_INUM1
);
7507 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7508 (SCM x
, SCM y
, SCM rest
),
7509 "Return the product of all arguments. If called without arguments,\n"
7511 #define FUNC_NAME s_scm_i_product
7513 while (!scm_is_null (rest
))
7514 { x
= scm_product (x
, y
);
7516 rest
= scm_cdr (rest
);
7518 return scm_product (x
, y
);
7522 #define s_product s_scm_i_product
7523 #define g_product g_scm_i_product
7526 scm_product (SCM x
, SCM y
)
7528 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7531 return SCM_I_MAKINUM (1L);
7532 else if (SCM_NUMBERP (x
))
7535 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7538 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7543 xx
= SCM_I_INUM (x
);
7548 /* exact1 is the universal multiplicative identity */
7552 /* exact0 times a fixnum is exact0: optimize this case */
7553 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7555 /* if the other argument is inexact, the result is inexact,
7556 and we must do the multiplication in order to handle
7557 infinities and NaNs properly. */
7558 else if (SCM_REALP (y
))
7559 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7560 else if (SCM_COMPLEXP (y
))
7561 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7562 0.0 * SCM_COMPLEX_IMAG (y
));
7563 /* we've already handled inexact numbers,
7564 so y must be exact, and we return exact0 */
7565 else if (SCM_NUMP (y
))
7568 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7572 * This case is important for more than just optimization.
7573 * It handles the case of negating
7574 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7575 * which is a bignum that must be changed back into a fixnum.
7576 * Failure to do so will cause the following to return #f:
7577 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7579 return scm_difference(y
, SCM_UNDEFINED
);
7583 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7585 scm_t_inum yy
= SCM_I_INUM (y
);
7586 scm_t_inum kk
= xx
* yy
;
7587 SCM k
= SCM_I_MAKINUM (kk
);
7588 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7592 SCM result
= scm_i_inum2big (xx
);
7593 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7594 return scm_i_normbig (result
);
7597 else if (SCM_BIGP (y
))
7599 SCM result
= scm_i_mkbig ();
7600 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7601 scm_remember_upto_here_1 (y
);
7604 else if (SCM_REALP (y
))
7605 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7606 else if (SCM_COMPLEXP (y
))
7607 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7608 xx
* SCM_COMPLEX_IMAG (y
));
7609 else if (SCM_FRACTIONP (y
))
7610 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7611 SCM_FRACTION_DENOMINATOR (y
));
7613 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7615 else if (SCM_BIGP (x
))
7617 if (SCM_I_INUMP (y
))
7622 else if (SCM_BIGP (y
))
7624 SCM result
= scm_i_mkbig ();
7625 mpz_mul (SCM_I_BIG_MPZ (result
),
7628 scm_remember_upto_here_2 (x
, y
);
7631 else if (SCM_REALP (y
))
7633 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7634 scm_remember_upto_here_1 (x
);
7635 return scm_from_double (result
);
7637 else if (SCM_COMPLEXP (y
))
7639 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7640 scm_remember_upto_here_1 (x
);
7641 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7642 z
* SCM_COMPLEX_IMAG (y
));
7644 else if (SCM_FRACTIONP (y
))
7645 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7646 SCM_FRACTION_DENOMINATOR (y
));
7648 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7650 else if (SCM_REALP (x
))
7652 if (SCM_I_INUMP (y
))
7657 else if (SCM_BIGP (y
))
7659 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7660 scm_remember_upto_here_1 (y
);
7661 return scm_from_double (result
);
7663 else if (SCM_REALP (y
))
7664 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7665 else if (SCM_COMPLEXP (y
))
7666 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7667 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7668 else if (SCM_FRACTIONP (y
))
7669 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7671 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7673 else if (SCM_COMPLEXP (x
))
7675 if (SCM_I_INUMP (y
))
7680 else if (SCM_BIGP (y
))
7682 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7683 scm_remember_upto_here_1 (y
);
7684 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7685 z
* SCM_COMPLEX_IMAG (x
));
7687 else if (SCM_REALP (y
))
7688 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7689 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7690 else if (SCM_COMPLEXP (y
))
7692 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7693 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7694 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7695 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7697 else if (SCM_FRACTIONP (y
))
7699 double yy
= scm_i_fraction2double (y
);
7700 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7701 yy
* SCM_COMPLEX_IMAG (x
));
7704 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7706 else if (SCM_FRACTIONP (x
))
7708 if (SCM_I_INUMP (y
))
7709 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7710 SCM_FRACTION_DENOMINATOR (x
));
7711 else if (SCM_BIGP (y
))
7712 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7713 SCM_FRACTION_DENOMINATOR (x
));
7714 else if (SCM_REALP (y
))
7715 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7716 else if (SCM_COMPLEXP (y
))
7718 double xx
= scm_i_fraction2double (x
);
7719 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7720 xx
* SCM_COMPLEX_IMAG (y
));
7722 else if (SCM_FRACTIONP (y
))
7723 /* a/b * c/d = ac / bd */
7724 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7725 SCM_FRACTION_NUMERATOR (y
)),
7726 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7727 SCM_FRACTION_DENOMINATOR (y
)));
7729 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7732 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7735 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7736 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7737 #define ALLOW_DIVIDE_BY_ZERO
7738 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7741 /* The code below for complex division is adapted from the GNU
7742 libstdc++, which adapted it from f2c's libF77, and is subject to
7745 /****************************************************************
7746 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7748 Permission to use, copy, modify, and distribute this software
7749 and its documentation for any purpose and without fee is hereby
7750 granted, provided that the above copyright notice appear in all
7751 copies and that both that the copyright notice and this
7752 permission notice and warranty disclaimer appear in supporting
7753 documentation, and that the names of AT&T Bell Laboratories or
7754 Bellcore or any of their entities not be used in advertising or
7755 publicity pertaining to distribution of the software without
7756 specific, written prior permission.
7758 AT&T and Bellcore disclaim all warranties with regard to this
7759 software, including all implied warranties of merchantability
7760 and fitness. In no event shall AT&T or Bellcore be liable for
7761 any special, indirect or consequential damages or any damages
7762 whatsoever resulting from loss of use, data or profits, whether
7763 in an action of contract, negligence or other tortious action,
7764 arising out of or in connection with the use or performance of
7766 ****************************************************************/
7768 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7769 (SCM x
, SCM y
, SCM rest
),
7770 "Divide the first argument by the product of the remaining\n"
7771 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7773 #define FUNC_NAME s_scm_i_divide
7775 while (!scm_is_null (rest
))
7776 { x
= scm_divide (x
, y
);
7778 rest
= scm_cdr (rest
);
7780 return scm_divide (x
, y
);
7784 #define s_divide s_scm_i_divide
7785 #define g_divide g_scm_i_divide
7788 do_divide (SCM x
, SCM y
, int inexact
)
7789 #define FUNC_NAME s_divide
7793 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7796 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7797 else if (SCM_I_INUMP (x
))
7799 scm_t_inum xx
= SCM_I_INUM (x
);
7800 if (xx
== 1 || xx
== -1)
7802 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7804 scm_num_overflow (s_divide
);
7809 return scm_from_double (1.0 / (double) xx
);
7810 else return scm_i_make_ratio (SCM_INUM1
, x
);
7813 else if (SCM_BIGP (x
))
7816 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7817 else return scm_i_make_ratio (SCM_INUM1
, x
);
7819 else if (SCM_REALP (x
))
7821 double xx
= SCM_REAL_VALUE (x
);
7822 #ifndef ALLOW_DIVIDE_BY_ZERO
7824 scm_num_overflow (s_divide
);
7827 return scm_from_double (1.0 / xx
);
7829 else if (SCM_COMPLEXP (x
))
7831 double r
= SCM_COMPLEX_REAL (x
);
7832 double i
= SCM_COMPLEX_IMAG (x
);
7833 if (fabs(r
) <= fabs(i
))
7836 double d
= i
* (1.0 + t
* t
);
7837 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7842 double d
= r
* (1.0 + t
* t
);
7843 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7846 else if (SCM_FRACTIONP (x
))
7847 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7848 SCM_FRACTION_NUMERATOR (x
));
7850 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7853 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7855 scm_t_inum xx
= SCM_I_INUM (x
);
7856 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7858 scm_t_inum yy
= SCM_I_INUM (y
);
7861 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7862 scm_num_overflow (s_divide
);
7864 return scm_from_double ((double) xx
/ (double) yy
);
7867 else if (xx
% yy
!= 0)
7870 return scm_from_double ((double) xx
/ (double) yy
);
7871 else return scm_i_make_ratio (x
, y
);
7875 scm_t_inum z
= xx
/ yy
;
7876 if (SCM_FIXABLE (z
))
7877 return SCM_I_MAKINUM (z
);
7879 return scm_i_inum2big (z
);
7882 else if (SCM_BIGP (y
))
7885 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7886 else return scm_i_make_ratio (x
, y
);
7888 else if (SCM_REALP (y
))
7890 double yy
= SCM_REAL_VALUE (y
);
7891 #ifndef ALLOW_DIVIDE_BY_ZERO
7893 scm_num_overflow (s_divide
);
7896 return scm_from_double ((double) xx
/ yy
);
7898 else if (SCM_COMPLEXP (y
))
7901 complex_div
: /* y _must_ be a complex number */
7903 double r
= SCM_COMPLEX_REAL (y
);
7904 double i
= SCM_COMPLEX_IMAG (y
);
7905 if (fabs(r
) <= fabs(i
))
7908 double d
= i
* (1.0 + t
* t
);
7909 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7914 double d
= r
* (1.0 + t
* t
);
7915 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7919 else if (SCM_FRACTIONP (y
))
7920 /* a / b/c = ac / b */
7921 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7922 SCM_FRACTION_NUMERATOR (y
));
7924 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7926 else if (SCM_BIGP (x
))
7928 if (SCM_I_INUMP (y
))
7930 scm_t_inum yy
= SCM_I_INUM (y
);
7933 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7934 scm_num_overflow (s_divide
);
7936 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7937 scm_remember_upto_here_1 (x
);
7938 return (sgn
== 0) ? scm_nan () : scm_inf ();
7945 /* FIXME: HMM, what are the relative performance issues here?
7946 We need to test. Is it faster on average to test
7947 divisible_p, then perform whichever operation, or is it
7948 faster to perform the integer div opportunistically and
7949 switch to real if there's a remainder? For now we take the
7950 middle ground: test, then if divisible, use the faster div
7953 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7954 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7958 SCM result
= scm_i_mkbig ();
7959 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7960 scm_remember_upto_here_1 (x
);
7962 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7963 return scm_i_normbig (result
);
7968 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7969 else return scm_i_make_ratio (x
, y
);
7973 else if (SCM_BIGP (y
))
7978 /* It's easily possible for the ratio x/y to fit a double
7979 but one or both x and y be too big to fit a double,
7980 hence the use of mpq_get_d rather than converting and
7983 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
7984 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
7985 return scm_from_double (mpq_get_d (q
));
7989 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
7993 SCM result
= scm_i_mkbig ();
7994 mpz_divexact (SCM_I_BIG_MPZ (result
),
7997 scm_remember_upto_here_2 (x
, y
);
7998 return scm_i_normbig (result
);
8001 return scm_i_make_ratio (x
, y
);
8004 else if (SCM_REALP (y
))
8006 double yy
= SCM_REAL_VALUE (y
);
8007 #ifndef ALLOW_DIVIDE_BY_ZERO
8009 scm_num_overflow (s_divide
);
8012 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8014 else if (SCM_COMPLEXP (y
))
8016 a
= scm_i_big2dbl (x
);
8019 else if (SCM_FRACTIONP (y
))
8020 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8021 SCM_FRACTION_NUMERATOR (y
));
8023 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8025 else if (SCM_REALP (x
))
8027 double rx
= SCM_REAL_VALUE (x
);
8028 if (SCM_I_INUMP (y
))
8030 scm_t_inum yy
= SCM_I_INUM (y
);
8031 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8033 scm_num_overflow (s_divide
);
8036 return scm_from_double (rx
/ (double) yy
);
8038 else if (SCM_BIGP (y
))
8040 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8041 scm_remember_upto_here_1 (y
);
8042 return scm_from_double (rx
/ dby
);
8044 else if (SCM_REALP (y
))
8046 double yy
= SCM_REAL_VALUE (y
);
8047 #ifndef ALLOW_DIVIDE_BY_ZERO
8049 scm_num_overflow (s_divide
);
8052 return scm_from_double (rx
/ yy
);
8054 else if (SCM_COMPLEXP (y
))
8059 else if (SCM_FRACTIONP (y
))
8060 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8062 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8064 else if (SCM_COMPLEXP (x
))
8066 double rx
= SCM_COMPLEX_REAL (x
);
8067 double ix
= SCM_COMPLEX_IMAG (x
);
8068 if (SCM_I_INUMP (y
))
8070 scm_t_inum yy
= SCM_I_INUM (y
);
8071 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8073 scm_num_overflow (s_divide
);
8078 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8081 else if (SCM_BIGP (y
))
8083 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8084 scm_remember_upto_here_1 (y
);
8085 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8087 else if (SCM_REALP (y
))
8089 double yy
= SCM_REAL_VALUE (y
);
8090 #ifndef ALLOW_DIVIDE_BY_ZERO
8092 scm_num_overflow (s_divide
);
8095 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8097 else if (SCM_COMPLEXP (y
))
8099 double ry
= SCM_COMPLEX_REAL (y
);
8100 double iy
= SCM_COMPLEX_IMAG (y
);
8101 if (fabs(ry
) <= fabs(iy
))
8104 double d
= iy
* (1.0 + t
* t
);
8105 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8110 double d
= ry
* (1.0 + t
* t
);
8111 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8114 else if (SCM_FRACTIONP (y
))
8116 double yy
= scm_i_fraction2double (y
);
8117 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8120 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8122 else if (SCM_FRACTIONP (x
))
8124 if (SCM_I_INUMP (y
))
8126 scm_t_inum yy
= SCM_I_INUM (y
);
8127 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8129 scm_num_overflow (s_divide
);
8132 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8133 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8135 else if (SCM_BIGP (y
))
8137 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8138 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8140 else if (SCM_REALP (y
))
8142 double yy
= SCM_REAL_VALUE (y
);
8143 #ifndef ALLOW_DIVIDE_BY_ZERO
8145 scm_num_overflow (s_divide
);
8148 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8150 else if (SCM_COMPLEXP (y
))
8152 a
= scm_i_fraction2double (x
);
8155 else if (SCM_FRACTIONP (y
))
8156 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8157 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8159 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8162 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8166 scm_divide (SCM x
, SCM y
)
8168 return do_divide (x
, y
, 0);
8171 static SCM
scm_divide2real (SCM x
, SCM y
)
8173 return do_divide (x
, y
, 1);
8179 scm_c_truncate (double x
)
8184 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8185 half-way case (ie. when x is an integer plus 0.5) going upwards.
8186 Then half-way cases are identified and adjusted down if the
8187 round-upwards didn't give the desired even integer.
8189 "plus_half == result" identifies a half-way case. If plus_half, which is
8190 x + 0.5, is an integer then x must be an integer plus 0.5.
8192 An odd "result" value is identified with result/2 != floor(result/2).
8193 This is done with plus_half, since that value is ready for use sooner in
8194 a pipelined cpu, and we're already requiring plus_half == result.
8196 Note however that we need to be careful when x is big and already an
8197 integer. In that case "x+0.5" may round to an adjacent integer, causing
8198 us to return such a value, incorrectly. For instance if the hardware is
8199 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8200 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8201 returned. Or if the hardware is in round-upwards mode, then other bigger
8202 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8203 representable value, 2^128+2^76 (or whatever), again incorrect.
8205 These bad roundings of x+0.5 are avoided by testing at the start whether
8206 x is already an integer. If it is then clearly that's the desired result
8207 already. And if it's not then the exponent must be small enough to allow
8208 an 0.5 to be represented, and hence added without a bad rounding. */
8211 scm_c_round (double x
)
8213 double plus_half
, result
;
8218 plus_half
= x
+ 0.5;
8219 result
= floor (plus_half
);
8220 /* Adjust so that the rounding is towards even. */
8221 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8226 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8228 "Round the number @var{x} towards zero.")
8229 #define FUNC_NAME s_scm_truncate_number
8231 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8233 else if (SCM_REALP (x
))
8234 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8235 else if (SCM_FRACTIONP (x
))
8236 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8237 SCM_FRACTION_DENOMINATOR (x
));
8239 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8240 s_scm_truncate_number
);
8244 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8246 "Round the number @var{x} towards the nearest integer. "
8247 "When it is exactly halfway between two integers, "
8248 "round towards the even one.")
8249 #define FUNC_NAME s_scm_round_number
8251 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8253 else if (SCM_REALP (x
))
8254 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8255 else if (SCM_FRACTIONP (x
))
8256 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8257 SCM_FRACTION_DENOMINATOR (x
));
8259 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8260 s_scm_round_number
);
8264 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8266 "Round the number @var{x} towards minus infinity.")
8267 #define FUNC_NAME s_scm_floor
8269 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8271 else if (SCM_REALP (x
))
8272 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8273 else if (SCM_FRACTIONP (x
))
8274 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8275 SCM_FRACTION_DENOMINATOR (x
));
8277 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8281 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8283 "Round the number @var{x} towards infinity.")
8284 #define FUNC_NAME s_scm_ceiling
8286 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8288 else if (SCM_REALP (x
))
8289 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8290 else if (SCM_FRACTIONP (x
))
8291 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8292 SCM_FRACTION_DENOMINATOR (x
));
8294 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8298 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8300 "Return @var{x} raised to the power of @var{y}.")
8301 #define FUNC_NAME s_scm_expt
8303 if (scm_is_integer (y
))
8305 if (scm_is_true (scm_exact_p (y
)))
8306 return scm_integer_expt (x
, y
);
8309 /* Here we handle the case where the exponent is an inexact
8310 integer. We make the exponent exact in order to use
8311 scm_integer_expt, and thus avoid the spurious imaginary
8312 parts that may result from round-off errors in the general
8313 e^(y log x) method below (for example when squaring a large
8314 negative number). In this case, we must return an inexact
8315 result for correctness. We also make the base inexact so
8316 that scm_integer_expt will use fast inexact arithmetic
8317 internally. Note that making the base inexact is not
8318 sufficient to guarantee an inexact result, because
8319 scm_integer_expt will return an exact 1 when the exponent
8320 is 0, even if the base is inexact. */
8321 return scm_exact_to_inexact
8322 (scm_integer_expt (scm_exact_to_inexact (x
),
8323 scm_inexact_to_exact (y
)));
8326 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8328 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8330 else if (scm_is_complex (x
) && scm_is_complex (y
))
8331 return scm_exp (scm_product (scm_log (x
), y
));
8332 else if (scm_is_complex (x
))
8333 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8335 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8339 /* sin/cos/tan/asin/acos/atan
8340 sinh/cosh/tanh/asinh/acosh/atanh
8341 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8342 Written by Jerry D. Hedden, (C) FSF.
8343 See the file `COPYING' for terms applying to this program. */
8345 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8347 "Compute the sine of @var{z}.")
8348 #define FUNC_NAME s_scm_sin
8350 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8351 return z
; /* sin(exact0) = exact0 */
8352 else if (scm_is_real (z
))
8353 return scm_from_double (sin (scm_to_double (z
)));
8354 else if (SCM_COMPLEXP (z
))
8356 x
= SCM_COMPLEX_REAL (z
);
8357 y
= SCM_COMPLEX_IMAG (z
);
8358 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8359 cos (x
) * sinh (y
));
8362 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8366 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8368 "Compute the cosine of @var{z}.")
8369 #define FUNC_NAME s_scm_cos
8371 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8372 return SCM_INUM1
; /* cos(exact0) = exact1 */
8373 else if (scm_is_real (z
))
8374 return scm_from_double (cos (scm_to_double (z
)));
8375 else if (SCM_COMPLEXP (z
))
8377 x
= SCM_COMPLEX_REAL (z
);
8378 y
= SCM_COMPLEX_IMAG (z
);
8379 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8380 -sin (x
) * sinh (y
));
8383 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8387 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8389 "Compute the tangent of @var{z}.")
8390 #define FUNC_NAME s_scm_tan
8392 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8393 return z
; /* tan(exact0) = exact0 */
8394 else if (scm_is_real (z
))
8395 return scm_from_double (tan (scm_to_double (z
)));
8396 else if (SCM_COMPLEXP (z
))
8398 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8399 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8400 w
= cos (x
) + cosh (y
);
8401 #ifndef ALLOW_DIVIDE_BY_ZERO
8403 scm_num_overflow (s_scm_tan
);
8405 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8408 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8412 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8414 "Compute the hyperbolic sine of @var{z}.")
8415 #define FUNC_NAME s_scm_sinh
8417 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8418 return z
; /* sinh(exact0) = exact0 */
8419 else if (scm_is_real (z
))
8420 return scm_from_double (sinh (scm_to_double (z
)));
8421 else if (SCM_COMPLEXP (z
))
8423 x
= SCM_COMPLEX_REAL (z
);
8424 y
= SCM_COMPLEX_IMAG (z
);
8425 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8426 cosh (x
) * sin (y
));
8429 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8433 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8435 "Compute the hyperbolic cosine of @var{z}.")
8436 #define FUNC_NAME s_scm_cosh
8438 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8439 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8440 else if (scm_is_real (z
))
8441 return scm_from_double (cosh (scm_to_double (z
)));
8442 else if (SCM_COMPLEXP (z
))
8444 x
= SCM_COMPLEX_REAL (z
);
8445 y
= SCM_COMPLEX_IMAG (z
);
8446 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8447 sinh (x
) * sin (y
));
8450 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8454 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8456 "Compute the hyperbolic tangent of @var{z}.")
8457 #define FUNC_NAME s_scm_tanh
8459 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8460 return z
; /* tanh(exact0) = exact0 */
8461 else if (scm_is_real (z
))
8462 return scm_from_double (tanh (scm_to_double (z
)));
8463 else if (SCM_COMPLEXP (z
))
8465 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8466 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8467 w
= cosh (x
) + cos (y
);
8468 #ifndef ALLOW_DIVIDE_BY_ZERO
8470 scm_num_overflow (s_scm_tanh
);
8472 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8475 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8479 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8481 "Compute the arc sine of @var{z}.")
8482 #define FUNC_NAME s_scm_asin
8484 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8485 return z
; /* asin(exact0) = exact0 */
8486 else if (scm_is_real (z
))
8488 double w
= scm_to_double (z
);
8489 if (w
>= -1.0 && w
<= 1.0)
8490 return scm_from_double (asin (w
));
8492 return scm_product (scm_c_make_rectangular (0, -1),
8493 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8495 else if (SCM_COMPLEXP (z
))
8497 x
= SCM_COMPLEX_REAL (z
);
8498 y
= SCM_COMPLEX_IMAG (z
);
8499 return scm_product (scm_c_make_rectangular (0, -1),
8500 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8503 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8507 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8509 "Compute the arc cosine of @var{z}.")
8510 #define FUNC_NAME s_scm_acos
8512 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8513 return SCM_INUM0
; /* acos(exact1) = exact0 */
8514 else if (scm_is_real (z
))
8516 double w
= scm_to_double (z
);
8517 if (w
>= -1.0 && w
<= 1.0)
8518 return scm_from_double (acos (w
));
8520 return scm_sum (scm_from_double (acos (0.0)),
8521 scm_product (scm_c_make_rectangular (0, 1),
8522 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8524 else if (SCM_COMPLEXP (z
))
8526 x
= SCM_COMPLEX_REAL (z
);
8527 y
= SCM_COMPLEX_IMAG (z
);
8528 return scm_sum (scm_from_double (acos (0.0)),
8529 scm_product (scm_c_make_rectangular (0, 1),
8530 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8533 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8537 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8539 "With one argument, compute the arc tangent of @var{z}.\n"
8540 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8541 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8542 #define FUNC_NAME s_scm_atan
8546 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8547 return z
; /* atan(exact0) = exact0 */
8548 else if (scm_is_real (z
))
8549 return scm_from_double (atan (scm_to_double (z
)));
8550 else if (SCM_COMPLEXP (z
))
8553 v
= SCM_COMPLEX_REAL (z
);
8554 w
= SCM_COMPLEX_IMAG (z
);
8555 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8556 scm_c_make_rectangular (v
, w
+ 1.0))),
8557 scm_c_make_rectangular (0, 2));
8560 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8562 else if (scm_is_real (z
))
8564 if (scm_is_real (y
))
8565 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8567 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8570 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8574 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8576 "Compute the inverse hyperbolic sine of @var{z}.")
8577 #define FUNC_NAME s_scm_sys_asinh
8579 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8580 return z
; /* asinh(exact0) = exact0 */
8581 else if (scm_is_real (z
))
8582 return scm_from_double (asinh (scm_to_double (z
)));
8583 else if (scm_is_number (z
))
8584 return scm_log (scm_sum (z
,
8585 scm_sqrt (scm_sum (scm_product (z
, z
),
8588 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8592 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8594 "Compute the inverse hyperbolic cosine of @var{z}.")
8595 #define FUNC_NAME s_scm_sys_acosh
8597 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8598 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8599 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8600 return scm_from_double (acosh (scm_to_double (z
)));
8601 else if (scm_is_number (z
))
8602 return scm_log (scm_sum (z
,
8603 scm_sqrt (scm_difference (scm_product (z
, z
),
8606 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8610 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8612 "Compute the inverse hyperbolic tangent of @var{z}.")
8613 #define FUNC_NAME s_scm_sys_atanh
8615 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8616 return z
; /* atanh(exact0) = exact0 */
8617 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8618 return scm_from_double (atanh (scm_to_double (z
)));
8619 else if (scm_is_number (z
))
8620 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8621 scm_difference (SCM_INUM1
, z
))),
8624 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8629 scm_c_make_rectangular (double re
, double im
)
8633 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8635 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8636 SCM_COMPLEX_REAL (z
) = re
;
8637 SCM_COMPLEX_IMAG (z
) = im
;
8641 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8642 (SCM real_part
, SCM imaginary_part
),
8643 "Return a complex number constructed of the given @var{real-part} "
8644 "and @var{imaginary-part} parts.")
8645 #define FUNC_NAME s_scm_make_rectangular
8647 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8648 SCM_ARG1
, FUNC_NAME
, "real");
8649 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8650 SCM_ARG2
, FUNC_NAME
, "real");
8652 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8653 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8656 return scm_c_make_rectangular (scm_to_double (real_part
),
8657 scm_to_double (imaginary_part
));
8662 scm_c_make_polar (double mag
, double ang
)
8666 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8667 use it on Glibc-based systems that have it (it's a GNU extension). See
8668 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8670 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8671 sincos (ang
, &s
, &c
);
8677 /* If s and c are NaNs, this indicates that the angle is a NaN,
8678 infinite, or perhaps simply too large to determine its value
8679 mod 2*pi. However, we know something that the floating-point
8680 implementation doesn't know: We know that s and c are finite.
8681 Therefore, if the magnitude is zero, return a complex zero.
8683 The reason we check for the NaNs instead of using this case
8684 whenever mag == 0.0 is because when the angle is known, we'd
8685 like to return the correct kind of non-real complex zero:
8686 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8687 on which quadrant the angle is in.
8689 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8690 return scm_c_make_rectangular (0.0, 0.0);
8692 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8695 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8697 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8698 #define FUNC_NAME s_scm_make_polar
8700 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8701 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8703 /* If mag is exact0, return exact0 */
8704 if (scm_is_eq (mag
, SCM_INUM0
))
8706 /* Return a real if ang is exact0 */
8707 else if (scm_is_eq (ang
, SCM_INUM0
))
8710 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8715 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8717 "Return the real part of the number @var{z}.")
8718 #define FUNC_NAME s_scm_real_part
8720 if (SCM_COMPLEXP (z
))
8721 return scm_from_double (SCM_COMPLEX_REAL (z
));
8722 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8725 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8730 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8732 "Return the imaginary part of the number @var{z}.")
8733 #define FUNC_NAME s_scm_imag_part
8735 if (SCM_COMPLEXP (z
))
8736 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8737 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8740 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8744 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8746 "Return the numerator of the number @var{z}.")
8747 #define FUNC_NAME s_scm_numerator
8749 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8751 else if (SCM_FRACTIONP (z
))
8752 return SCM_FRACTION_NUMERATOR (z
);
8753 else if (SCM_REALP (z
))
8754 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8756 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8761 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8763 "Return the denominator of the number @var{z}.")
8764 #define FUNC_NAME s_scm_denominator
8766 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8768 else if (SCM_FRACTIONP (z
))
8769 return SCM_FRACTION_DENOMINATOR (z
);
8770 else if (SCM_REALP (z
))
8771 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8773 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8778 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8780 "Return the magnitude of the number @var{z}. This is the same as\n"
8781 "@code{abs} for real arguments, but also allows complex numbers.")
8782 #define FUNC_NAME s_scm_magnitude
8784 if (SCM_I_INUMP (z
))
8786 scm_t_inum zz
= SCM_I_INUM (z
);
8789 else if (SCM_POSFIXABLE (-zz
))
8790 return SCM_I_MAKINUM (-zz
);
8792 return scm_i_inum2big (-zz
);
8794 else if (SCM_BIGP (z
))
8796 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8797 scm_remember_upto_here_1 (z
);
8799 return scm_i_clonebig (z
, 0);
8803 else if (SCM_REALP (z
))
8804 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8805 else if (SCM_COMPLEXP (z
))
8806 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8807 else if (SCM_FRACTIONP (z
))
8809 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8811 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8812 SCM_FRACTION_DENOMINATOR (z
));
8815 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8820 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8822 "Return the angle of the complex number @var{z}.")
8823 #define FUNC_NAME s_scm_angle
8825 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8826 flo0 to save allocating a new flonum with scm_from_double each time.
8827 But if atan2 follows the floating point rounding mode, then the value
8828 is not a constant. Maybe it'd be close enough though. */
8829 if (SCM_I_INUMP (z
))
8831 if (SCM_I_INUM (z
) >= 0)
8834 return scm_from_double (atan2 (0.0, -1.0));
8836 else if (SCM_BIGP (z
))
8838 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8839 scm_remember_upto_here_1 (z
);
8841 return scm_from_double (atan2 (0.0, -1.0));
8845 else if (SCM_REALP (z
))
8847 if (SCM_REAL_VALUE (z
) >= 0)
8850 return scm_from_double (atan2 (0.0, -1.0));
8852 else if (SCM_COMPLEXP (z
))
8853 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8854 else if (SCM_FRACTIONP (z
))
8856 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8858 else return scm_from_double (atan2 (0.0, -1.0));
8861 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8866 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8868 "Convert the number @var{z} to its inexact representation.\n")
8869 #define FUNC_NAME s_scm_exact_to_inexact
8871 if (SCM_I_INUMP (z
))
8872 return scm_from_double ((double) SCM_I_INUM (z
));
8873 else if (SCM_BIGP (z
))
8874 return scm_from_double (scm_i_big2dbl (z
));
8875 else if (SCM_FRACTIONP (z
))
8876 return scm_from_double (scm_i_fraction2double (z
));
8877 else if (SCM_INEXACTP (z
))
8880 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8885 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8887 "Return an exact number that is numerically closest to @var{z}.")
8888 #define FUNC_NAME s_scm_inexact_to_exact
8890 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8897 val
= SCM_REAL_VALUE (z
);
8898 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8899 val
= SCM_COMPLEX_REAL (z
);
8901 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8903 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8904 SCM_OUT_OF_RANGE (1, z
);
8911 mpq_set_d (frac
, val
);
8912 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8913 scm_i_mpz2num (mpq_denref (frac
)));
8915 /* When scm_i_make_ratio throws, we leak the memory allocated
8925 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8927 "Returns the @emph{simplest} rational number differing\n"
8928 "from @var{x} by no more than @var{eps}.\n"
8930 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8931 "exact result when both its arguments are exact. Thus, you might need\n"
8932 "to use @code{inexact->exact} on the arguments.\n"
8935 "(rationalize (inexact->exact 1.2) 1/100)\n"
8938 #define FUNC_NAME s_scm_rationalize
8940 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8941 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8942 eps
= scm_abs (eps
);
8943 if (scm_is_false (scm_positive_p (eps
)))
8945 /* eps is either zero or a NaN */
8946 if (scm_is_true (scm_nan_p (eps
)))
8948 else if (SCM_INEXACTP (eps
))
8949 return scm_exact_to_inexact (x
);
8953 else if (scm_is_false (scm_finite_p (eps
)))
8955 if (scm_is_true (scm_finite_p (x
)))
8960 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8962 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8963 scm_ceiling (scm_difference (x
, eps
)))))
8965 /* There's an integer within range; we want the one closest to zero */
8966 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8968 /* zero is within range */
8969 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8974 else if (scm_is_true (scm_positive_p (x
)))
8975 return scm_ceiling (scm_difference (x
, eps
));
8977 return scm_floor (scm_sum (x
, eps
));
8981 /* Use continued fractions to find closest ratio. All
8982 arithmetic is done with exact numbers.
8985 SCM ex
= scm_inexact_to_exact (x
);
8986 SCM int_part
= scm_floor (ex
);
8988 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
8989 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
8993 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
8994 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
8996 /* We stop after a million iterations just to be absolutely sure
8997 that we don't go into an infinite loop. The process normally
8998 converges after less than a dozen iterations.
9001 while (++i
< 1000000)
9003 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9004 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9005 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9007 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9008 eps
))) /* abs(x-a/b) <= eps */
9010 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9011 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9012 return scm_exact_to_inexact (res
);
9016 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9018 tt
= scm_floor (rx
); /* tt = floor (rx) */
9024 scm_num_overflow (s_scm_rationalize
);
9029 /* conversion functions */
9032 scm_is_integer (SCM val
)
9034 return scm_is_true (scm_integer_p (val
));
9038 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9040 if (SCM_I_INUMP (val
))
9042 scm_t_signed_bits n
= SCM_I_INUM (val
);
9043 return n
>= min
&& n
<= max
;
9045 else if (SCM_BIGP (val
))
9047 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9049 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9051 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9053 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9054 return n
>= min
&& n
<= max
;
9064 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9065 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9068 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9069 SCM_I_BIG_MPZ (val
));
9071 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9083 return n
>= min
&& n
<= max
;
9091 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9093 if (SCM_I_INUMP (val
))
9095 scm_t_signed_bits n
= SCM_I_INUM (val
);
9096 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9098 else if (SCM_BIGP (val
))
9100 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9102 else if (max
<= ULONG_MAX
)
9104 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9106 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9107 return n
>= min
&& n
<= max
;
9117 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9120 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9121 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9124 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9125 SCM_I_BIG_MPZ (val
));
9127 return n
>= min
&& n
<= max
;
9135 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9137 scm_error (scm_out_of_range_key
,
9139 "Value out of range ~S to ~S: ~S",
9140 scm_list_3 (min
, max
, bad_val
),
9141 scm_list_1 (bad_val
));
9144 #define TYPE scm_t_intmax
9145 #define TYPE_MIN min
9146 #define TYPE_MAX max
9147 #define SIZEOF_TYPE 0
9148 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9149 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9150 #include "libguile/conv-integer.i.c"
9152 #define TYPE scm_t_uintmax
9153 #define TYPE_MIN min
9154 #define TYPE_MAX max
9155 #define SIZEOF_TYPE 0
9156 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9157 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9158 #include "libguile/conv-uinteger.i.c"
9160 #define TYPE scm_t_int8
9161 #define TYPE_MIN SCM_T_INT8_MIN
9162 #define TYPE_MAX SCM_T_INT8_MAX
9163 #define SIZEOF_TYPE 1
9164 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9165 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9166 #include "libguile/conv-integer.i.c"
9168 #define TYPE scm_t_uint8
9170 #define TYPE_MAX SCM_T_UINT8_MAX
9171 #define SIZEOF_TYPE 1
9172 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9173 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9174 #include "libguile/conv-uinteger.i.c"
9176 #define TYPE scm_t_int16
9177 #define TYPE_MIN SCM_T_INT16_MIN
9178 #define TYPE_MAX SCM_T_INT16_MAX
9179 #define SIZEOF_TYPE 2
9180 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9181 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9182 #include "libguile/conv-integer.i.c"
9184 #define TYPE scm_t_uint16
9186 #define TYPE_MAX SCM_T_UINT16_MAX
9187 #define SIZEOF_TYPE 2
9188 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9189 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9190 #include "libguile/conv-uinteger.i.c"
9192 #define TYPE scm_t_int32
9193 #define TYPE_MIN SCM_T_INT32_MIN
9194 #define TYPE_MAX SCM_T_INT32_MAX
9195 #define SIZEOF_TYPE 4
9196 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9197 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9198 #include "libguile/conv-integer.i.c"
9200 #define TYPE scm_t_uint32
9202 #define TYPE_MAX SCM_T_UINT32_MAX
9203 #define SIZEOF_TYPE 4
9204 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9205 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9206 #include "libguile/conv-uinteger.i.c"
9208 #define TYPE scm_t_wchar
9209 #define TYPE_MIN (scm_t_int32)-1
9210 #define TYPE_MAX (scm_t_int32)0x10ffff
9211 #define SIZEOF_TYPE 4
9212 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9213 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9214 #include "libguile/conv-integer.i.c"
9216 #define TYPE scm_t_int64
9217 #define TYPE_MIN SCM_T_INT64_MIN
9218 #define TYPE_MAX SCM_T_INT64_MAX
9219 #define SIZEOF_TYPE 8
9220 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9221 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9222 #include "libguile/conv-integer.i.c"
9224 #define TYPE scm_t_uint64
9226 #define TYPE_MAX SCM_T_UINT64_MAX
9227 #define SIZEOF_TYPE 8
9228 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9229 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9230 #include "libguile/conv-uinteger.i.c"
9233 scm_to_mpz (SCM val
, mpz_t rop
)
9235 if (SCM_I_INUMP (val
))
9236 mpz_set_si (rop
, SCM_I_INUM (val
));
9237 else if (SCM_BIGP (val
))
9238 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9240 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9244 scm_from_mpz (mpz_t val
)
9246 return scm_i_mpz2num (val
);
9250 scm_is_real (SCM val
)
9252 return scm_is_true (scm_real_p (val
));
9256 scm_is_rational (SCM val
)
9258 return scm_is_true (scm_rational_p (val
));
9262 scm_to_double (SCM val
)
9264 if (SCM_I_INUMP (val
))
9265 return SCM_I_INUM (val
);
9266 else if (SCM_BIGP (val
))
9267 return scm_i_big2dbl (val
);
9268 else if (SCM_FRACTIONP (val
))
9269 return scm_i_fraction2double (val
);
9270 else if (SCM_REALP (val
))
9271 return SCM_REAL_VALUE (val
);
9273 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9277 scm_from_double (double val
)
9281 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9283 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9284 SCM_REAL_VALUE (z
) = val
;
9289 #if SCM_ENABLE_DEPRECATED == 1
9292 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9294 scm_c_issue_deprecation_warning
9295 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9299 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9303 scm_out_of_range (NULL
, num
);
9306 return scm_to_double (num
);
9310 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9312 scm_c_issue_deprecation_warning
9313 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9317 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9321 scm_out_of_range (NULL
, num
);
9324 return scm_to_double (num
);
9330 scm_is_complex (SCM val
)
9332 return scm_is_true (scm_complex_p (val
));
9336 scm_c_real_part (SCM z
)
9338 if (SCM_COMPLEXP (z
))
9339 return SCM_COMPLEX_REAL (z
);
9342 /* Use the scm_real_part to get proper error checking and
9345 return scm_to_double (scm_real_part (z
));
9350 scm_c_imag_part (SCM z
)
9352 if (SCM_COMPLEXP (z
))
9353 return SCM_COMPLEX_IMAG (z
);
9356 /* Use the scm_imag_part to get proper error checking and
9357 dispatching. The result will almost always be 0.0, but not
9360 return scm_to_double (scm_imag_part (z
));
9365 scm_c_magnitude (SCM z
)
9367 return scm_to_double (scm_magnitude (z
));
9373 return scm_to_double (scm_angle (z
));
9377 scm_is_number (SCM z
)
9379 return scm_is_true (scm_number_p (z
));
9383 /* Returns log(x * 2^shift) */
9385 log_of_shifted_double (double x
, long shift
)
9387 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9389 if (x
> 0.0 || double_is_non_negative_zero (x
))
9390 return scm_from_double (ans
);
9392 return scm_c_make_rectangular (ans
, M_PI
);
9395 /* Returns log(n), for exact integer n of integer-length size */
9397 log_of_exact_integer_with_size (SCM n
, long size
)
9399 long shift
= size
- 2 * scm_dblprec
[0];
9402 return log_of_shifted_double
9403 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9406 return log_of_shifted_double (scm_to_double (n
), 0);
9409 /* Returns log(n), for exact integer n */
9411 log_of_exact_integer (SCM n
)
9413 return log_of_exact_integer_with_size
9414 (n
, scm_to_long (scm_integer_length (n
)));
9417 /* Returns log(n/d), for exact non-zero integers n and d */
9419 log_of_fraction (SCM n
, SCM d
)
9421 long n_size
= scm_to_long (scm_integer_length (n
));
9422 long d_size
= scm_to_long (scm_integer_length (d
));
9424 if (abs (n_size
- d_size
) > 1)
9425 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9426 log_of_exact_integer_with_size (d
, d_size
)));
9427 else if (scm_is_false (scm_negative_p (n
)))
9428 return scm_from_double
9429 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9431 return scm_c_make_rectangular
9432 (log1p (scm_to_double (scm_divide2real
9433 (scm_difference (scm_abs (n
), d
),
9439 /* In the following functions we dispatch to the real-arg funcs like log()
9440 when we know the arg is real, instead of just handing everything to
9441 clog() for instance. This is in case clog() doesn't optimize for a
9442 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9443 well use it to go straight to the applicable C func. */
9445 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9447 "Return the natural logarithm of @var{z}.")
9448 #define FUNC_NAME s_scm_log
9450 if (SCM_COMPLEXP (z
))
9452 #if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
9453 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9455 double re
= SCM_COMPLEX_REAL (z
);
9456 double im
= SCM_COMPLEX_IMAG (z
);
9457 return scm_c_make_rectangular (log (hypot (re
, im
)),
9461 else if (SCM_REALP (z
))
9462 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9463 else if (SCM_I_INUMP (z
))
9465 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9466 if (scm_is_eq (z
, SCM_INUM0
))
9467 scm_num_overflow (s_scm_log
);
9469 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9471 else if (SCM_BIGP (z
))
9472 return log_of_exact_integer (z
);
9473 else if (SCM_FRACTIONP (z
))
9474 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9475 SCM_FRACTION_DENOMINATOR (z
));
9477 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9482 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9484 "Return the base 10 logarithm of @var{z}.")
9485 #define FUNC_NAME s_scm_log10
9487 if (SCM_COMPLEXP (z
))
9489 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9490 clog() and a multiply by M_LOG10E, rather than the fallback
9491 log10+hypot+atan2.) */
9492 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9493 && defined SCM_COMPLEX_VALUE
9494 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9496 double re
= SCM_COMPLEX_REAL (z
);
9497 double im
= SCM_COMPLEX_IMAG (z
);
9498 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9499 M_LOG10E
* atan2 (im
, re
));
9502 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9504 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9505 if (scm_is_eq (z
, SCM_INUM0
))
9506 scm_num_overflow (s_scm_log10
);
9509 double re
= scm_to_double (z
);
9510 double l
= log10 (fabs (re
));
9511 if (re
> 0.0 || double_is_non_negative_zero (re
))
9512 return scm_from_double (l
);
9514 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9517 else if (SCM_BIGP (z
))
9518 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9519 else if (SCM_FRACTIONP (z
))
9520 return scm_product (flo_log10e
,
9521 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9522 SCM_FRACTION_DENOMINATOR (z
)));
9524 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9529 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9531 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9532 "base of natural logarithms (2.71828@dots{}).")
9533 #define FUNC_NAME s_scm_exp
9535 if (SCM_COMPLEXP (z
))
9537 #if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
9538 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9540 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9541 SCM_COMPLEX_IMAG (z
));
9544 else if (SCM_NUMBERP (z
))
9546 /* When z is a negative bignum the conversion to double overflows,
9547 giving -infinity, but that's ok, the exp is still 0.0. */
9548 return scm_from_double (exp (scm_to_double (z
)));
9551 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9556 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9558 "Return the square root of @var{z}. Of the two possible roots\n"
9559 "(positive and negative), the one with positive real part\n"
9560 "is returned, or if that's zero then a positive imaginary part.\n"
9564 "(sqrt 9.0) @result{} 3.0\n"
9565 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9566 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9567 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9569 #define FUNC_NAME s_scm_sqrt
9571 if (SCM_COMPLEXP (z
))
9573 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9574 && defined SCM_COMPLEX_VALUE
9575 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9577 double re
= SCM_COMPLEX_REAL (z
);
9578 double im
= SCM_COMPLEX_IMAG (z
);
9579 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9580 0.5 * atan2 (im
, re
));
9583 else if (SCM_NUMBERP (z
))
9585 double xx
= scm_to_double (z
);
9587 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9589 return scm_from_double (sqrt (xx
));
9592 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9603 mpz_init_set_si (z_negative_one
, -1);
9605 /* It may be possible to tune the performance of some algorithms by using
9606 * the following constants to avoid the creation of bignums. Please, before
9607 * using these values, remember the two rules of program optimization:
9608 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9609 scm_c_define ("most-positive-fixnum",
9610 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9611 scm_c_define ("most-negative-fixnum",
9612 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9614 scm_add_feature ("complex");
9615 scm_add_feature ("inexact");
9616 flo0
= scm_from_double (0.0);
9617 flo_log10e
= scm_from_double (M_LOG10E
);
9619 /* determine floating point precision */
9620 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9622 init_dblprec(&scm_dblprec
[i
-2],i
);
9623 init_fx_radix(fx_per_radix
[i
-2],i
);
9626 /* hard code precision for base 10 if the preprocessor tells us to... */
9627 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9630 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9631 #include "libguile/numbers.x"